ape/0000755000175100001440000000000013020051200011014 5ustar hornikusersape/COPYING0000644000175100001440000004313312337057645012110 0ustar hornikusers GNU GENERAL PUBLIC LICENSE Version 2, June 1991 Copyright (C) 1989, 1991 Free Software Foundation, Inc. 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Everyone is permitted to copy and distribute verbatim copies of this license document, but changing it is not allowed. Preamble The licenses for most software are designed to take away your freedom to share and change it. By contrast, the GNU General Public License is intended to guarantee your freedom to share and change free software--to make sure the software is free for all its users. This General Public License applies to most of the Free Software Foundation's software and to any other program whose authors commit to using it. (Some other Free Software Foundation software is covered by the GNU Library General Public License instead.) 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 this service 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 make restrictions that forbid anyone to deny you these rights or to ask you to surrender the rights. These restrictions translate to certain responsibilities for you if you distribute copies of the software, or if you modify it. For example, if you distribute copies of such a program, whether gratis or for a fee, you must give the recipients all the rights that you have. 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. We protect your rights with two steps: (1) copyright the software, and (2) offer you this license which gives you legal permission to copy, distribute and/or modify the software. Also, for each author's protection and ours, we want to make certain that everyone understands that there is no warranty for this free software. If the software is modified by someone else and passed on, we want its recipients to know that what they have is not the original, so that any problems introduced by others will not reflect on the original authors' reputations. Finally, any free program is threatened constantly by software patents. We wish to avoid the danger that redistributors of a free program will individually obtain patent licenses, in effect making the program proprietary. To prevent this, we have made it clear that any patent must be licensed for everyone's free use or not licensed at all. The precise terms and conditions for copying, distribution and modification follow. GNU GENERAL PUBLIC LICENSE TERMS AND CONDITIONS FOR COPYING, DISTRIBUTION AND MODIFICATION 0. This License applies to any program or other work which contains a notice placed by the copyright holder saying it may be distributed under the terms of this General Public License. The "Program", below, refers to any such program or work, and a "work based on the Program" means either the Program or any derivative work under copyright law: that is to say, a work containing the Program or a portion of it, either verbatim or with modifications and/or translated into another language. (Hereinafter, translation is included without limitation in the term "modification".) Each licensee is addressed as "you". Activities other than copying, distribution and modification are not covered by this License; they are outside its scope. The act of running the Program is not restricted, and the output from the Program is covered only if its contents constitute a work based on the Program (independent of having been made by running the Program). Whether that is true depends on what the Program does. 1. You may copy and distribute 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 and disclaimer of warranty; keep intact all the notices that refer to this License and to the absence of any warranty; and give any other recipients of the Program a copy of this License along with the Program. You may charge a fee for the physical act of transferring a copy, and you may at your option offer warranty protection in exchange for a fee. 2. You may modify your copy or copies of the Program or any portion of it, thus forming a work based on the Program, and copy and distribute such modifications or work under the terms of Section 1 above, provided that you also meet all of these conditions: a) You must cause the modified files to carry prominent notices stating that you changed the files and the date of any change. b) You must cause any work that you distribute or publish, that in whole or in part contains or is derived from the Program or any part thereof, to be licensed as a whole at no charge to all third parties under the terms of this License. c) If the modified program normally reads commands interactively when run, you must cause it, when started running for such interactive use in the most ordinary way, to print or display an announcement including an appropriate copyright notice and a notice that there is no warranty (or else, saying that you provide a warranty) and that users may redistribute the program under these conditions, and telling the user how to view a copy of this License. (Exception: if the Program itself is interactive but does not normally print such an announcement, your work based on the Program is not required to print an announcement.) These requirements apply to the modified work as a whole. If identifiable sections of that work are not derived from the Program, and can be reasonably considered independent and separate works in themselves, then this License, and its terms, do not apply to those sections when you distribute them as separate works. But when you distribute the same sections as part of a whole which is a work based on the Program, the distribution of the whole must be on the terms of this License, whose permissions for other licensees extend to the entire whole, and thus to each and every part regardless of who wrote it. Thus, it is not the intent of this section to claim rights or contest your rights to work written entirely by you; rather, the intent is to exercise the right to control the distribution of derivative or collective works based on the Program. In addition, mere aggregation of another work not based on the Program with the Program (or with a work based on the Program) on a volume of a storage or distribution medium does not bring the other work under the scope of this License. 3. You may copy and distribute the Program (or a work based on it, under Section 2) in object code or executable form under the terms of Sections 1 and 2 above provided that you also do one of the following: a) Accompany it with the complete corresponding machine-readable source code, which must be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, b) Accompany it with a written offer, valid for at least three years, to give any third party, for a charge no more than your cost of physically performing source distribution, a complete machine-readable copy of the corresponding source code, to be distributed under the terms of Sections 1 and 2 above on a medium customarily used for software interchange; or, c) Accompany it with the information you received as to the offer to distribute corresponding source code. (This alternative is allowed only for noncommercial distribution and only if you received the program in object code or executable form with such an offer, in accord with Subsection b above.) The source code for a work means the preferred form of the work for making modifications to it. For an executable work, complete source code means all the source code for all modules it contains, plus any associated interface definition files, plus the scripts used to control compilation and installation of the executable. However, as a special exception, the source code distributed need not include anything that is normally distributed (in either source or binary form) with the major components (compiler, kernel, and so on) of the operating system on which the executable runs, unless that component itself accompanies the executable. If distribution of executable or object code is made by offering access to copy from a designated place, then offering equivalent access to copy the source code from the same place counts as distribution of the source code, even though third parties are not compelled to copy the source along with the object code. 4. You may not copy, modify, sublicense, or distribute the Program except as expressly provided under this License. Any attempt otherwise to copy, modify, sublicense or distribute the Program is void, and will automatically terminate your rights under this License. However, parties who have received copies, or rights, from you under this License will not have their licenses terminated so long as such parties remain in full compliance. 5. You are not required to accept this License, since you have not signed it. However, nothing else grants you permission to modify or distribute the Program or its derivative works. These actions are prohibited by law if you do not accept this License. Therefore, by modifying or distributing the Program (or any work based on the Program), you indicate your acceptance of this License to do so, and all its terms and conditions for copying, distributing or modifying the Program or works based on it. 6. Each time you redistribute the Program (or any work based on the Program), the recipient automatically receives a license from the original licensor to copy, distribute or modify the Program subject to these terms and conditions. You may not impose any further restrictions on the recipients' exercise of the rights granted herein. You are not responsible for enforcing compliance by third parties to this License. 7. If, as a consequence of a court judgment or allegation of patent infringement or for any other reason (not limited to patent issues), 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 distribute so as to satisfy simultaneously your obligations under this License and any other pertinent obligations, then as a consequence you may not distribute the Program at all. For example, if a patent license would not permit royalty-free redistribution of the Program by all those who receive copies directly or indirectly through you, then the only way you could satisfy both it and this License would be to refrain entirely from distribution of the Program. If any portion of this section is held invalid or unenforceable under any particular circumstance, the balance of the section is intended to apply and the section as a whole is intended to apply in other circumstances. It is not the purpose of this section to induce you to infringe any patents or other property right claims or to contest validity of any such claims; this section has the sole purpose of protecting the integrity of the free software distribution system, which is implemented by public license practices. Many people have made generous contributions to the wide range of software distributed through that system in reliance on consistent application of that system; it is up to the author/donor to decide if he or she is willing to distribute software through any other system and a licensee cannot impose that choice. This section is intended to make thoroughly clear what is believed to be a consequence of the rest of this License. 8. If the distribution and/or use of the Program is restricted in certain countries either by patents or by copyrighted interfaces, the original copyright holder who places the Program under this License may add an explicit geographical distribution limitation excluding those countries, so that distribution is permitted only in or among countries not thus excluded. In such case, this License incorporates the limitation as if written in the body of this License. 9. The Free Software Foundation may publish revised and/or new versions of the 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 a version number of this License which applies to it and "any later version", you have the option of following the terms and conditions either of that version or of any later version published by the Free Software Foundation. If the Program does not specify a version number of this License, you may choose any version ever published by the Free Software Foundation. 10. If you wish to incorporate parts of the Program into other free programs whose distribution conditions are different, write to the author to ask for permission. For software which is copyrighted by the Free Software Foundation, write to the Free Software Foundation; we sometimes make exceptions for this. Our decision will be guided by the two goals of preserving the free status of all derivatives of our free software and of promoting the sharing and reuse of software generally. NO WARRANTY 11. BECAUSE THE PROGRAM IS LICENSED FREE OF CHARGE, 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. 12. IN NO EVENT UNLESS REQUIRED BY APPLICABLE LAW OR AGREED TO IN WRITING WILL ANY COPYRIGHT HOLDER, OR ANY OTHER PARTY WHO MAY MODIFY AND/OR REDISTRIBUTE 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. 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 convey 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 2 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, write to the Free Software Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301 USA Also add information on how to contact you by electronic and paper mail. If the program is interactive, make it output a short notice like this when it starts in an interactive mode: Gnomovision version 69, Copyright (C) year name of author Gnomovision 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, the commands you use may be called something other than `show w' and `show c'; they could even be mouse-clicks or menu items--whatever suits your program. You should also get your employer (if you work as a programmer) or your school, if any, to sign a "copyright disclaimer" for the program, if necessary. Here is a sample; alter the names: Yoyodyne, Inc., hereby disclaims all copyright interest in the program `Gnomovision' (which makes passes at compilers) written by James Hacker. , 1 April 1989 Ty Coon, President of Vice This 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 Library General Public License instead of this License. ape/inst/0000755000175100001440000000000012465107777012032 5ustar hornikusersape/inst/CITATION0000644000175100001440000000114511444646646013167 0ustar hornikuserscitHeader("To cite ape in a publication use:") citEntry(entry="Article", title = "A{PE}: analyses of phylogenetics and evolution in {R} language", author = personList(as.person("E. Paradis"),as.person("J. Claude"), as.person("K. Strimmer")), journal = "Bioinformatics", year = "2004", volume = "20", pages = "289-290", textVersion = "Paradis E., Claude J. & Strimmer K. 2004. APE: analyses of phylogenetics and evolution in R language. Bioinformatics 20: 289-290.") citFooter("As ape is evolving quickly, you may want to cite also its version number (found with 'library(help = ape)').")ape/inst/doc/0000755000175100001440000000000013017516351012561 5ustar hornikusersape/inst/doc/MoranI.pdf0000644000175100001440000072177513017516351014464 0ustar hornikusers%PDF-1.5 % 3 0 obj << /Length 2787 /Filter /FlateDecode >> stream xZYo#~ׯ$!e>ā7Xk8݇9!S=3M)J7ȃ8GTUuuxuSˋo(Y Ǥ0ՌYYJoY~n=M߿vݢm; n4VjKOZT\7~eeZ"Įh%LMl~SKcNbq%XLOP&VPQBҪgH{70^66 n*`f}\ō |MMMozl]^1J!Xօ!߆wOVr"h/Z?MHV/JqAsf?,< rLn~Vw o4%rrC;R` A64+5Xvn< 1"C[lA]2`˝,M䣋'Gxjh,`޽†Jf =F222M]tE+cG}CK9Hӷy+Uq z\rtrKĘf|H\h~s۝Q79up']nRj1TPK>J%VvCq`)~&Pݫ%p7F8y1Ft*j&@aGM"l2Mtǒ[Y*2JC.l rUP痫^.!Wc:ɇ+-pW mR'P%X+ִs6UCu>CZ9c*yg!6` utFǂ'+i8:B~bQz `r~ZS/k`baC D( [CwPI*wPKJ~jp(TY2ncRU/tnk!ͼ@T焺-|{7A̹ؤU"k9 7ulm(.fiVvp{-4ô yD Cu a|T:Z``ngޜCT 'KlߠBg뫸۹ʊ2%CImdegwOip^M.UzZ|tM: ^2ӫɾ-1+ Zi,אB endstream endobj 18 0 obj << /Length 3189 /Filter /FlateDecode >> stream xڵZY~ׯA}p1)AHIXsj?na5MvULbY!^={ZI7.'W7]V꼂߫m|]MʼLtef2SmLTG̪\rѼbUD˵m&J& YjfʘLM0?̊H`B VL*%D\z(OcL^D'WNyX)}S[jp4_o"w̌2ߦ*;#uәl;;m S]g<5~ >S^Lg0DI>t&\ӂs^ԕY_.^JU0tnK]-Gex<ʾC7- aTڳ`X*yXBY(HN7$f`6 J;v{z* zp0OĚ.We l@V e1(C@'E3ưmJD\;;tfj4S[R!AS%KQn*v\<>T")HB~1;1Å,HtOڀ6Z9U%v1e} / O8yV18"W5rh+WdpGڊgh#~)Dq&%G/0glx-GLޞؕ?&r1 f_8Fqn7ïە,ѱ#==8#q8GOؒG~^y<=1=8=w w jМr dԃE .;^d ʑY'u嬠k0zq~w}t&W֕g4C!GGЊYstWZv,8> {+^ܽQhՃ<3E*8 _vޭCmIeyͭ/sȾPpv))q@t-1W4Ty@$˕{*g> E=;JY  H{"l- 8Cwhݍ{o M5 t^*nrc0vmb| -Z|Xu+) 4~s$*%}dz: D ;jx#5^ܶ _oN14?UŸvLԫarUg (fAQBEEZ]|A{pNC)vCoI:8CQ$5e1]Dd׷C5="r8^n`ٞk}A_%>#Widҏ)[BpTJy{cۿCO/sU+mǭ3#)9J$O |iˣa0?$=ǹ0gTNZ akK &$ OaQ%tŁ*>=ې6 Q,O! N!>э؉g߄K̓tJ;&P:6eFڌׄa)X;8n 6BHuOI+!C.:Zǵps=L^e) BN+]ٳO[IӓPf#zxNfZZjrB>ڻ}N?lh \\ :Wq2 D3?ex/@^JFJHgw) endstream endobj 27 0 obj << /Length 1075 /Filter /FlateDecode >> stream xW_o6 R")[lf@0b+xݧx)YSl`ФHVLA+*^Yeɢ⥶KUق}f̖ӼP&Mstꋮ0eeqjpl?,Mhy$xx {م2ЕA?XQTa8j U5)QGA̿=[mժ_ree5Rr%*8H+0) <ҥ4ys4 *$`\31XQwHCQ%1C0n)(g>3)tW ka,W tAzd=A+6 |FϞInaP OpZ]H#:kwAbK}..wFtW1H]omGk@`{@;oq6C׻0ޡxCoFD^7{= 6}js? e7%UҫJkec+˵\ rUq\)z2pA/ endstream endobj 24 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (/tmp/RtmpShOZQe/Rbuilda8519227029/ape/vignettes/MoranI-003.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 28 0 R /BBox [0 0 432 432] /Resources << /ProcSet [ /PDF /Text ] /Font << /F2 29 0 R/F4 30 0 R>> /ExtGState << >>/ColorSpace << /sRGB 31 0 R >>>> /Length 448 /Filter /FlateDecode >> stream xTMk1WѾL53J:6I0B!c$.WZi?&x]xzΌL=PpƀF!exOxU?ov4ja^~_ ~)U|#t,(q=>ZBQ#8) ESoJ4M*If9IJRpRO$R+[Q}'M[=_y} b,D~ewWDi ^}iWj>ߖ`5,N/3Y<.q٥(Egw؝gG5]a2#ݱp}V*qz:I-'y3yFq_|#_;T?׬"ƣ`\JͧjrZ f84_Tn3Un- =M= endstream endobj 33 0 obj << /Alternate /DeviceRGB /N 3 /Length 2596 /Filter /FlateDecode >> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~ endstream endobj 36 0 obj << /Length 1791 /Filter /FlateDecode >> stream xX[F~_!B6D͌F#$B/)t}Pl-%Ү6U! [̜w9$DIU"^_>KBɢHT剉|)mz,,cg^p*jRp%Nz%< Ώ&Ql*tΪ(}rFH"x hnY[ ؆.+S"2 8G=: ~V~>Hƾd7gO? k$g;ɗM%fZ3-cHSIgɿ2N]tZ=.!x#O+wEy$W=ٽ U4yi7٭XѦU NsYH!q}UT> U)C&_ThIVǙr) #+`mWs)J,9d mBjLD@e7:7[tq\q0 +{^/)@fVe>{sG kxu@g`;d 8c2lQqD?@A/lWKt- $3&Ya >TmN6+£`3LU(M|/*V8 'hS5 _ߵGɀK(MF;e4u%U$mCP9%=n[rAA@WgӼUI!1`mxDB[" ޮhҾ:{X:"P1;qc :4rsp;vZՂMHC]o%.y yhf*>{?EOL6TŦ$wl̙= )OMM s@S2t:i;eSBxu@' ?7in03p3`(9$Fҁ_'IM,DUKUxe!оGVM }5vaw:x~|/9&`h4+#h:S=I{='* cWRe}1q%uŏ=!HdՙJS;jH!t3x_1~qI#ICMgC@sLȚxx$\vɈ=-`@LF8w38 it4f<Eq$| ƨܤYONNBN3InItG__O^^yF.>s/Z V=n'd‘Sh¶mS.:ԝ V#I+ iw -xPB]_ui'! gГ{ V,А) (ʣ`u(:QsBwh:V <՞łVJV( ˒oz%e  endstream endobj 43 0 obj << /Length 2950 /Filter /FlateDecode >> stream xێ=_!F#&͹pHIi!DILuY޺ ҬwE(3goCͬU!zuUV&ovLiׅ檲BVwRyS<&\Yͼ.72{&oppງĈU35aWWu̬kaw~Xd)kXr<񚉄ʋZ1~`$5pAy]+rv:z7h{">p{N'&@Vtyܣx쎈(4$#!#gMQM> Ax[(D|졘M{'0fn@[| 7z%3EمqqkWPғҦ.|JѮ7M+3Fc{xs$4I59ۍU3Ƣr;ܔ D v~h ?I(h{/ E~hpi﮷bk$Y(/]lr]oKq\W.,cH^tI| -tnu1aHU' q<ȶC,v9A;E@Ad-!L9W04.Yh5 *dǃqiұG#o Rډoz/ 2l׉n( F2qj_Z 33ft"BeqH^QCϣ+˭;x壘G(Ԕ YZfA>*6T0l)~04ɽܼ 0}B%acf$%=놴Ze:Ҭ\ژJ#:ܖ"oH#0A\% gO#ҙq"&`h\!X|#U-p[78I ~ǩFGF ,XiՂ[eЄ^(<!AeTZ?Gܷ(D1M`Gs4YxGB l(1}"~`>kcMu#$\ڗ/A@ԓu,':3 Xv?pg_< R?~ƙirZԖN (})57|}'ivp^vaXF'qVky7(4qD]*>cG/(hh? }w`B[!oeؐ>s+ w84 zyX<?Zi6b5e[Hܜ#1XiYD$FX7xmjWrHd.UU$5h:ܙ!$h¸j׶]lnKl]*KƽLzj"SR*^GoU@1:s꼬x& ˱6LaE@ZOJjEe5(mb0N2)sigTɵsqy̔ Zˬħԉ A;WV Jf⮤m#3_Styw9jpLt ,ԽOLdS(BL- 1KT> Ińpv1IOSantD ߪ.Y eLlL,d!R//Я6;C嗲BxN X0KpK'}[TnCNa+/[F'AC5*/+d5;O~ U^AL&s1jB5,HI cӒM[0A+ƪ-(IGŢ⻗;3.i`5-Dj|Mg0hy7ԉΟ#A2on5'W{iݷܺ=׸RV)Y^,yLD?rw<)^ږFmhr<0stbt6ẃ ǟ]A.g==޻8vV<Ɠ"8/f/(S8sa}B!ָG\qfڭ^E1 s}:T{ZRN{iW@OF #@'n#ד?<.Yϖ!"ʖXK>w|E$Q 29aaHI䨄{*oj3m_;=5וV>ݜy`)UQK}[_S% dIzK0X:gZ@]k9Z%[> stream xWI6W=h)J.HL"Ed[v\ؒ+y&6ؓAТh=>{hI*ϳuU*LV6V\Z(mh74ɲ,~j;qp-/Wy mwӼ9%&#?6x) LMpannua(1ZUdU~&P[ rZ& OQ5(_RUH 5U=4[QAKt WYS)]眳@ B+9TrY&F-*qšbY!_y*/g(.A9z~T'!~(jNA m(gӶgŞsS1R8eqNH!𩱤-^(12-SvWare`_UN8ExiFeM^{)f)K Q֭H{,Jzn²vdcmɂ dCf=|}R:OSq8֔/ih}Ӕ)7qSO{ژ_7vc>hJAC?h,_\~oi. endstream endobj 44 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (/tmp/RtmpShOZQe/Rbuilda8519227029/ape/vignettes/MoranI-010.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 49 0 R /BBox [0 0 432 432] /Resources << /ProcSet [ /PDF /Text ] /Font << /F1 50 0 R/F2 51 0 R>> /ExtGState << >>/ColorSpace << /sRGB 52 0 R >>>> /Length 647 /Filter /FlateDecode >> stream xUMoA ϯPwC*ZQВ8T=6HDIUgg7!hR8t=s ý{p `Z010pJ|:^:TiZp|Ou} pB(. V7 *B`cBkd$)48FL7Q"e oЕ %۵ַ+5)IW`j KF}Zh1j.pUwsN.IN@LGE`>+,Ysvi/+miIai\YS5h}PwOMbxP vMy=*/0xHo>YM՟N^#q/_vg6c}V۽ݍM(sZEgK]niӗWvJ1TztK7ޏo:'B̳6y)6mX#dqKifo9Pr@Tgsڐ߇Fdz٪h8liwC1\ů=X0m4}1d3"c6XꮭkI" r>G:O;Q y)h(atiIuXQpy]{ oQtMzJ\ endstream endobj 54 0 obj << /Alternate /DeviceRGB /N 3 /Length 2596 /Filter /FlateDecode >> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~ endstream endobj 58 0 obj << /Length 511 /Filter /FlateDecode >> stream xmTK@+8$/QًaztnHuC*(1%>%*N%J᜖ZyNɯDyl^by|'3$^~zYB8㥆 u'n~~ץz?\x9J3rzoΨ[ql:a|? o>PzfLllE [Xb=[Hyj͌peH_ܰi'spkY " Hscwo:7[NR0BiU0s9 =! ="0v>2!)鏩FbrieX=,K\s` A\LHC¦\IdVUcs6OO󐭵PGj#`D+C_d ZdՌ> /ExtGState << >>/ColorSpace << /sRGB 63 0 R >>>> /Length 903 /Filter /FlateDecode >> stream xVN[A ߯x[PAEUH, hUģM}='$B7cf3>p9?{awpΧ@!{@36{'/-[x2N& l}}7g0>ޏPY#RHK8jv?ZG N@ ሟAvwMF'>Qҁ+dE mm_E˽Hy Uc݌+M֣R[ꭔDI ^t hE] U_E__ƅe9mYmj0\OlmUų=4y9Y7ZxjOɣ?+b/; $.>KK 1M9Zu%TJ6&1ZJG,e2Ä?Nju1[OjʗC+ &c,z_џ_+x lE <Vx>.ws^}>^Ls ],e@q)wߥl /$j7h[ 6ERmE,RZE'x;̗d] /l+Ha eMn!Ml3*'T}Dg}AD'T}CkABs5ݠuݨ-꬛-aXiXq7[y7[toȹT"YLMIL(FvVI{$J5ؕ:T^5=+Zd[r-DW_d` |.y { endstream endobj 65 0 obj << /Alternate /DeviceRGB /N 3 /Length 2596 /Filter /FlateDecode >> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~ endstream endobj 68 0 obj << /Length 1235 /Filter /FlateDecode >> stream xڍWI6WЃ8DIZ m3I$F-ɕ43ɿ#(j!-h;+Xĸ$呔0ZFf(2i$Gspѯ=L=?WwETRq"&JKI^ֻS>$,TyܝGx9Z vpNpwU8n@Uk`[&`:3m[c̾ެR4p3ԣ~ IDD|"z j%Ml[r~$\Ƙ?=ޑG{^5dҙ4h҄L0UaI3`e./5|ʙ$V@BK"Z$Yp@2e|v!4 p;CuEծ(S'aos0^mZf };(Ϡ-d*لCg[dzT&Og]:w?z0S/#<~'SF%vQkx혀 ǒ`,\){c^& Y@:uVw5=ڻl}19t@Z(efثiISR} +iK4ooۮGz<6lޔ gx#^ɘ _XX3$J"?& endstream endobj 55 0 obj << /Type /XObject /Subtype /Form /FormType 1 /PTEX.FileName (/tmp/RtmpShOZQe/Rbuilda8519227029/ape/vignettes/MoranI-012.pdf) /PTEX.PageNumber 1 /PTEX.InfoDict 69 0 R /BBox [0 0 432 432] /Resources << /ProcSet [ /PDF /Text ] /Font << /F1 70 0 R/F2 71 0 R>> /ExtGState << >>/ColorSpace << /sRGB 72 0 R >>>> /Length 774 /Filter /FlateDecode >> stream xVKoA ؞ǎZъJJVQ%)${ VI ݍǏy  B#8XkWqu n 3y T8/|2Zg9";2! &hNZ\xӗllZkqoj@EqxBҬk^$}ԟg0:P}+w;7X6N)ȵٝY=u#`^8Mkq֊$iSl'yL_Jf{5:_eaejPisЁr xٹ$lHF42z𱴦,YaL"H$ LXfFI8tnexnt1i~oJB+jٍsZ4Z@$n_<[B_ ȐFPqˇ!ri::b 䝹Hi maEanآCu&#|% V fS]K!(5{ԍPol@~=w \Tw:]ha0X%^1x%t 4y1]uXymqy;]7gsWx(|9(y7N{?-Aqu>9N..C0Z/IV !&8 {/(UY 1y˟G~{oߨ߾zPny6n endstream endobj 74 0 obj << /Alternate /DeviceRGB /N 3 /Length 2596 /Filter /FlateDecode >> stream xwTSϽ7PkhRH H.*1 J"6DTpDQ2(C"QDqpId߼y͛~kg}ֺLX Xňg` lpBF|،l *?Y"1P\8=W%Oɘ4M0J"Y2Vs,[|e92<se'9`2&ctI@o|N6(.sSdl-c(2-yH_/XZ.$&\SM07#1ؙYrfYym";8980m-m(]v^DW~ emi]P`/u}q|^R,g+\Kk)/C_|Rax8t1C^7nfzDp 柇u$/ED˦L L[B@ٹЖX!@~(* {d+} G͋љς}WL$cGD2QZ4 E@@A(q`1D `'u46ptc48.`R0) @Rt CXCP%CBH@Rf[(t CQhz#0 Zl`O828.p|O×X ?:0FBx$ !i@ڐH[EE1PL ⢖V6QP>U(j MFkt,:.FW8c1L&ӎ9ƌaX: rbl1 {{{;}#tp8_\8"Ey.,X%%Gщ1-9ҀKl.oo/O$&'=JvMޞxǥ{=Vs\x ‰N柜>ucKz=s/ol|ϝ?y ^d]ps~:;/;]7|WpQoH!ɻVsnYs}ҽ~4] =>=:`;cܱ'?e~!ańD#G&}'/?^xI֓?+\wx20;5\ӯ_etWf^Qs-mw3+?~O~ endstream endobj 77 0 obj << /Length 2996 /Filter /FlateDecode >> stream xZY~Woת.8x% 6jØvU%%*Rude~ejrNIΏ?R&mKlҦ\,&N,>g G<5РdlQt?GvjrW2@y7Og%+{-tC,۞S?ЙI>':LJiɸM'33UX7iJyy#}90̔YTqa D$ZQ7(Ŋ8" eXq9:pɒSԝ F@CUkؠpxkFH`,:uYC5Gnw bj#r+R5yoq}qAK:$~vHR˻F܈ʚc#^:qbc6ۧvn±=ݢnـVjQ_ƓQ-J^6ްͬ  WTse0ʑ֨ ^Y,>7:7G.u<,U4t-"$Sen ɕ\XjP5t̆['3UloX*ẝrYH.Pox4tplY2;i΂]}f-"2͞qӤ*3mNLQMB7s5o;D;:vIai8_fm%9F BDu-bU@="*rNyLUԖh=UAVNo~6=oMAm:=]\<\ 5lsV.w:gY Pl}`*a@Y8YE{f&1o|z!ZPb-d4xg/!}s}BW@t5[ D>!N9yK* X*nk>ՁoNmXqq[,0gi ij^#5UZUZRO.2L[YÁoV0MRUQcHYKz*o6\ m jH N0p?l7[x)Nn;nRwz3n)>pG+N#r2ʗW2tDeLզ2˾_ח-a}מ̕%iJJm/S-H2^o>ٌη"ZKr_t>I(rkrJ(^b2$W@_*TtGX2owdl0Mw(G=Pqh?#$c+: նEKZ]؎|>PِÎ~nVehR7ʔ`pTh˪s6FGUA{rJl[Ekx!,X٨[S7~_P@(`VY|:۹",&.ԇL`| 'S{l c*+K0W0ɫXvAW;Ԟ݋V{+\%h nAY|'}fT zcd;Jp~'Fu)'(TBKZdxxLtHd~Qp&.A7a8)_[AsAH~Af5"SGs A I.y~h%H<&*Z-3Tfwuwld8iu%:y{hN2ѩ! uPbY?<_V[~2|gtRf_/-=(ϙFZr}qyK憍Cڝf{,q>?%Hc/ىzۧX.!s 2m MȤ꩖@Pd 3q1F$cϐqpTC@-[8 G~^M ǚjOAoK_Gf˯t8Ӊx8t1~$*~`^iݔFE`tGJrPi~^1`Egcsqϧ_Q}?H G N@A{[߰Q x+%p}um:XdP2w8r?şXH4T/D >:UI`>w]wH2lbRO-R_ٓytq?8 endstream endobj 86 0 obj << /Length 149 /Filter /FlateDecode >> stream x3135R0P0Bc3csCB.c46K$r9yr+p{E=}JJS ]  b<]00 @0?`d=0s@f d'n.WO@.sud endstream endobj 100 0 obj << /Length1 1895 /Length2 12244 /Length3 0 /Length 13418 /Filter /FlateDecode >> stream xڍP\- 5HݵFhܝAww4\BpG9:cj 5Mq+' ؍] , `gbegD9cGB\AN`"$!@sKp r 8H{ʬ'0Fu{G%C@t#4l/-N ussdcd5wteu؈20\_4 Z-ݽA}ࢵhUfϰTÎ*GSqj?ȖPq .17/Lʧ#nyksU|F*at:Zߔ|Ig2FUJJ#K7'ul[wjT8MHyQ4 BHOTc*V(Uh]mp#Sg6CuNѦ dδѩIn.,tYq SLR2xokMn >3wRwڌ+d\7rE>ꂯ7YOYzx~(#6]Q\ͨaycf W$G .T[CK?>fj5f d:Y8M 7rP{zKnDh ]MV@\6~Yك #F?BG׺6큭RCTڗG~Б_F%am_qa3p)&)IW/c5"|YL>pB$bxF. OKu XS{guSQO[oU9*(I3i CbVEژFtd,jF;틃3vCoTzv SX N,%9wx UJ ;C6*6,s͐J6p(LE~T#T-4!"r'w_i#2)c 2TAkV`a0 1M̾#1w5 RRzt5 jP~2&6?οf=(v5Q:'[S=AiVf!PZTVVWmNfi>wBsb/Q5[cE6gPBX3u߻"3:4X]p7Z*Mo(W!|/VL7Jg2cZ DZfX j1SqU-n>!Fpk5!܅Ae.xy/ zɜ>AņÆ1*%ӱ@*Y/҂&ڧXKP JΝel Z Z婬X-媐6Wo/}pZWgQRtF`Dm 5h[K˔rrί%|t M_2.*-9%n޲:B 唨5 sXpW)39*6~f\e (Igubנ (H4A?|ՐњGMϧM;^O &}NP~G(A]|}D(@'y9Rvkȣ9^LSpPP1843pK *6w!xCS՗W񇈸3]?uSQ'EIQHϭ׬RbsFQKCP<_K7 _OP- ?VIۚ/ϸ@ !9!-j: Ap+Bz?W8iZ΂9򭢓 E9qXΚ5X;zqUdƧ5cBqʨe^mØ+_52xkϧ O4 2\D6E9Ek1+%C\9RCfqF9w+s[PkӮ(ݧ[gVAl"R!8bA}'Mn# XbB[.w}<^H"hEpVYJZRz>tPD&Ox<cʐ2܋ k%7$j5 ]RC︩9Z@{`wEC\ fy$Aarr A"w*'e/K.KGײ0sE+Y*ڈZSF 2Q`ˤRoT7P)_R#;fjpH4j*s. ͪ$4Ǽ:ȃ4*7e'ap|A|4mAlMQtŞ0c)7~_Pzd|˘nqECI \\ԘGJԜ0-]h}3Relwʴ$E=iY n Egs|)S e]=,ay-gkT#~ky rw5E0("ǫ ʨj φ^e!Co6 $J=tȹF͊$LҺ4dwu݌֬к(كV|,vjBj^C?թD4\N B] kڎG&.v_ژYkL3GRɝZmiL$zjcvC,+8t(B0dw؈{ߪ'Uun7^r* ~'#\H5`mKM+И>LZX|{F fy䜀jkRW ħױ2k>Y(y.W{蚺`P[Q kkL/Lфg0˴6+sXZ 1\3>/> ,nOen5貛).zv{+g~(9Citb7A|z1Vغt % l( [hAʊ(7D]hIINcU2yk1j_=Z3 @˧ &:*C134{/(OYaDXjBzZE^6@kyۯvgng@mVsE1@xu+m\\ݒ|Gjh)seۓgDazWӚuCdoTߕۄ2yL?O{Z^+Rѐ)9o$1gl{ɔt\Gtey9,qeOX Iܔ` KدS6XGWB >M xZx]vR<}esL<=F)>$12W ĭǁ.@ %O!8CXlqfYa#-< B Tw[1;&r\TI9QJb3q\Rcx`1,3M Z߅w {9lQJDUáпopK0w,nKSuj\b>;ڔ+lg쨔KXp U4ì$O.[2lpm Ǐ͙3Z ?tJ=)bw~0Jjqi"^!ҳ+՘ .|c}4XR}Q3J֊OBaYJwՄV!: u)bL/*O.4 XYöAZd6A>i]Vm+:vڳr = B ׊r-v[AknQ>yq2QH[Q Z줅;},`eJ[;B!7W"G*>x#hlЕ֮Mif!zx)J(_kµvKaU;_ts/?]x#VRiτv4`2G7$ZI ҙ#핥Ҥx#u?mdXwbr9!'E`ݍ$RީS%uEV/gLd5Û$Mvu옭ZbDHgf1Y;K;e}+-AO^Ig5 EvŐ(D7kp/^á׫,o`F`|bQE.ƿcym1>|fZoU#bK0qjޯB,YqO<%,7Qw yȌE L @q}۽ۻ#o"X3˙O_C\3M-bVv|4YEL0_/^DΓ'fr4 a0>Ѥg)i1& 1twyI)V aO"A{>]t.ă_?D")!ڨX9lld U!3S߃+7@Lm X L0k QMc}ڻ"|޻S |YeFc|C S^^++ ^oĮ3$:8g[G\\m9AaH^=a v94,NLw$,) ΣW `oExϕ&(0;GoOM'I(>w"Gsih/J<9HU Lp"S^5J.*<ֻܿnwֽ1"X iﲝ||6S 3rΧjk +3#^.]W7~ꆑoCmy%P .°KCRyYB1{(q=l`7fFq$6yӟ~E $gh U`bH5v]o*~PV/Y -Xk4.w븯elz9}5f@d3ouv#'ʢdP;.E>%,)wH((n 7{.ChVaB6=ֻ]ݏHbjuf^AVCF˂evS!o+}rK}r6&.nXrRX-kғ}\?EzGE\=CYV?L~\0Fxs/joMDLМa߾WfPJ5G $(йCjYG7s Ԣ4#cQd4K?VKJxM8S%Up)FI~8gWN_8a┤sڻ30BL-ی ~(}ǰUd )޴!8}W*䤁r.Udqk?ds1yR߈J]~JwP?hΠ8L ܼ0qhyH6Xm `;ڨ.MZzn N:ڗt OrR+;1ן}ߩ=1Fznw L+9/NR[@O*e&}b}nm;nQz:FV' <8.%pu_-}tLJ*' 5rU ZrDcfJ6C=~LKV U&BFn r9!GQ-2WBOC VBjxasoqL ɨFnߪҚSv\\+a?L>U,j}Z;%Aʈ-3_ h.|b"J)TSTmO2  }_ވ߳YeU01.8q42erߤ:;UIg33G%i{L#γackz:OX]ӸGWƻ[+9=$s߸kVP:#Ufh+Y[fiEW*jָ7>.\hc$HV*}2ˑ >.yF`B0YuXsj满rO[<*Ih3+ B, V3p}D eَatټXd'YcMp:VIIAcJx%Js|X\EnSȮbroő34n>]͓?WTPQXgrbg?>Y6J$E+Շr6A{mC/DOJ`Oݼ츻c13Vf|JMVg]&gOܼAay"t+bf9-l A+eݠW_$BtȪ y)]c7'o +NR6b3}qf9|׊$$1LQdA1I;3[ӕ[3 n}mYڔ~Z<86꿡 @8ݐeA 0Cujx&=cyB!%N 3x[|%Pv-vkU3|0D.جNJ׹BN7KFiӏIUX)g )ȷ"Rύ&UӻZЋaqy? Ǚr6c߰ B #p {#C} 6clU ƹ-3!ہj}cBXMͶ)NZTn& |drUӄg=bڧmL(/JVQ O Mۂ 'V IJ`1w $=t\>𠬏nh8|Я8ȝ2؟dژ&Sԡh,X)vHjN u~Z5'3u``9ƊTtt]?zV6N(PA/!|_O_!׮0CS[ IY(.p53|>ZaDz" 0y s${xcFPNJ`7Eh +nￌW}'Dkn-,xlW/9\lLKx#/1@xt:@':(*c4^ * "jWF}:ZML_]<NA%?ˑD'ɴ@%rV+[G#IBqd SSJ:.ٹ7 .O؃aܛ,&;J][ Gl[G{SY::Syu/ZLPz;R)$q|"%P$$Q{ST! Wrzr+D=2Fڑ]Hyzs\J 㨚1ζ4+{Ia? mH0]py՘@kH" $3zdIQE nRGvJ%'et Aر:8=_¦Dӫ j`o1-WV&^'j\u֓^FBm_2tDb%³K2en\ݍy!K5Uy奆7zԗ9E?p0OkJD|UN~c!tdPL$1t=Dw هIn@B8;T/nc6q6믧Mt( ΋3,ܴH=] endstream endobj 102 0 obj << /Length1 1492 /Length2 6449 /Length3 0 /Length 7454 /Filter /FlateDecode >> stream xڍtTZ6)t(1tݍ0  13C "t)H(HH  ҂{Ykf~~yae7UpCT0/O@b CQn I/BĔAr@QI@P@@o"! PyC:|M8 $`U{!NΨ} sb<  t@(g͎`BP~*!ByHܑ|p,'rB7K2@#` EQ> pp!0M0y@`"ܟ_ 0AaNG͇E@0_D~A@7߭ Ѝ?`CB~iUU`Jpww $՟2ߜu}`WP/^&0DC&D@<_3 < A@x#u o7pQ{F7a_G@}V7~}gs08?W̯f`G?" J "11A@ 郠_0G8@~oτp]K~c]?N|;f_UNT~uøf t7oՁ8@@nAABP_>v1M~͚ч#^/P@࿰޼ [ 7-U``ïA5߬DhD:@|nR7p;#@`:9CBA/Lw@aQ? t z~IH7o_r^\܍ֿ׿&"\^F*]ȺjɋEys}A)t-pbDo57E<6xspapl (U߇-^z|:^cKPWfMO/qb"5V jD\&$X>`-ϝa⥿E{w#YkFGۉBhEIJcA[4؇dЊ҅ $Gk59#PW>c؊Zq@1}[.6L~{OM*OJ%-<:(6k c4w%XZЗBB0!ȧb BTl^6+;%#W]d_c414Uq]-9>x%Vj(lԉT|.rBi◉zI\_bVD.|"&uR>i^zbj㙦pĖ);MU$+o>O+OD_Qz4005]$QLn)chn9vKQ-I]ϑQyX<DLS?$]rl'Uh]/炝F1B|zAé_S-H6M&̔g옜.jRDiNx^LRq):t15J_3Dǖ{⢿X ,ꭩ! c~2 p  e~] vWXw,ǛE cbe.7ځMt_>N{TmHlɸL2l?KzY8 UÌGD1VwWU n$J3r׺/4,+>Ij/3x8V:Lzm/*QfLb(Ih Au /,/ֻWU 1F8yoХ`G?Da-ohxK,s>ݑ?p[6۠U8+CE?jZY= > (uYBE\/[ƎeV[7sw$JS?_zKqK{+NW/O`UƻNƊN["(J*D i;}zG$Ԉ&њO =:Qw(`c X)WJ Vn jeTȞ ?ގѪKXɚNN=6CiL"v}J8E']zmO )zevi}+՝ӊ }N A<@KzI%A GY(Am$ ihAY֚ĊD#-bw#})D]xvu\KRW?ܙiW܎#AUGCI(="pς喬Sa[T@Fx U);< Pɶɛ̡. jlU*4:cΗ6a]7,XNj; $82JzHhf"3tZ|*$A j{]+"2dëʗ#+bP}a3#AξQzX)el=:^Nyakw?1}ߙ-1I|(~Eǖ{{MAy]E㕆1քP-.]ֽ-z 8l#Bn>0qOq :$wX^7 F̶BZ[hq/Bju_wְidαA?AEE5u|%/}Y 4,d86Yc%r4eBª-O4<ت?%k gR,T3ԍw)t݋{K+Fa|pC#mfaZi7g.#04Hx& Ҭ6S3X㭍c|-Yz5JH ?MS)%kH czF*IwL=l<]_*HNB0P%2IUg @_ĜVg67fJXOhH+;(Nk Gic-eb۹ܻ}>D_ԃa$णSaT>q|Rc!9E`yg Wq#2GN]0,5=-tFESy 'ST /L2$W[~\sph:y>h C>EUvY␥q\XXqb@f0V/wh^e뭁=mӪf(:QO\V~ Jmǎ^iC=Au H}QMC j?AX#oLBvf.~4cGsIs51&m;'QNV{t_CX;Ij0OLIp`k>03} Ů B=tO3 `\U{q%I*Q>U1(g;%ފ{`ȑ|>&Aw!.2&2#ʞkuZϾyIl {f(KK~4ē.i۷ _GWpY?TLJTWu`Qv >[~Lv{~06OB4ď0Ix5lWYUC0IZjP<TK#PUAzm̰n:hdJ|6;@Yhq WiqkŦ-,na&և4\,azziB듳Zh+p^A; w QQYCC^RIsm<ʢX*[ѪEƛ%1NCѺ6ZDt5z7jՙ[E7o HQPjЛ~z;QyG,~u+hKj~h㷼%*f*/Dy,|Ʒ$qu\UfiyG! &96*eHn9mW˒$ꒉ+hjblo0x?p!L/ޞ}sN-PnNczo+X…(޸GJiYB zM1BcW 8,?(3(u WufcX-J>mEkf!{,i)\leCVU.'^L!ya ,kI2u5B\CS1ҰSt$puh,oф,_bN,C 'iHKܡO^ X>q㳁Ļ= ޡ?eϞb Wj8ird꩝k|=f}e)ڋƁvhX5'vQy!F2qM'%mcfzmG@ꦌ^v?wK-u|9c bηauLUؘ~6LNDl*sYuSiDZ'85S띤BLI㿘MUKU ,;2j¶IoT@R˵҈8Op^MxSb{H$JײM`4x`PV%qq}wG3/,!hWd S~: >/]? b弣A1K> |˷;`݅V] "i}^so#㞮,Az-/Pi_s[U%޻?p(a)>zXbylr“gA dncv8f.蕤냽7~)ܨh0*.6/ 1nMc=5j7Ϸ};nCX4M3c4oY\ jFt X|>),\ pXItC|~ Jt6t|ͻ+ u%#^},nxAbi^S9>#&hrZUSiMɯU4qOK_P_BpwE1yWۈNfĄ[tg.dBEBI?,LZJdWm8Pqoi0$/2b>]AW U!t'Wi\6E0E*}ׄџY_֨,k^-vXV̜x.Ӵ/&NcSX7Ruv8+y )hl LX%2t!]-[3F $Dzˇl2rm[J٩%L+"׆B규4էM}c̉]t?9#+Kk|j8)TYȵ<+{DHj4Q"]l@ל2Iښ/ȉ8qO1}Jݵd\5Tu{y۹47~)t M ̘L&}{2-r4/_qdw9( h 6 4j%Z#31>?>w!Iw|ͧLȏ Ot_H~,69Vt{ޣSry`Sq;;Ol31.!wzmfcOM%ݐ:tI"C -(r1)CU ʬbix;.|(!Wcha]`SJ͈:Xy ywg>Gn =56{ghMsuv2zt9xgf,$j#;k M ;f)?bQzϼ`>{0f[mQa)Z /cDz mrRDb?aRcRGK#V1u9NN} 8=Pj?ˆ蘣#8@A{ƭ@kv d_T?6 o endstream endobj 104 0 obj << /Length1 1724 /Length2 10319 /Length3 0 /Length 11440 /Filter /FlateDecode >> stream xڍT.k[Hqwwww,@ ݥE EJR;̙s{WJg~R]Eb8p TT8\`W{ ((/ )I& t}2T8\^A>Avv'; !.i; P8R' ) >? t9N^xxs<%vX!O.}V߃)l'?w-Yx~=Gw6˿!/'4LxlA^S=vx g)I/韂wz"%8»@W6'p k̘jVNRl7mUFE=Bvۚ<~~"j ^$`K:Yt1K-Z,׵]3Itx|!_K Ht4]7y_9GEfR) _c$zTa /tuF(nӄJsV.qW⾗\W|ϲ|!VfdϘ> YU4Ǿ5dK~V|n>ѤKnWX52;Ű%DʝRHo0=JCƾom[U(BT &l]_49 !z6ڢ -8\\:/~\x{q??mosryRY戃[EFMO窱rW4Nl4D@a#28%zw9yB%\j~Y^H+{i@͞B&@é L_HwÚ}&,/і45En {MƩfF~v-/pVCn#*jX6,4v[%VΚkH& |weMB|-°ݔb,I[|8xGEq@јuxy# UK`N.=' EA} (يe@vs?N# C:vZ}8>ؕ5n ֧t~/XvL)S{n/ݝmGӕ2xU#OjBCl_FdV2k$..$<1k 9m*rwitgk_s -}]):`5-_wcHa-sisc`hϿ᥿T{#O{`H/d@kGyB)qaJkU?s;BeQs9&GM6]eHUs]8]1v:KwP+;u:\b<\9osV+еc{t_` \6,mkC5=2W1ȳ@Gl'-dۃa[sZO]Wn|MfGOz) MQ3i] j,N'%d[t"-ꃔdy}+˟6ܢ/#QMFg3 *{\̌ ݑ~ې-̄]-~ƫw} :iY0my~DZXV7H" 1Tgllx5,Vҥ'Mp7 *z%̰)! O[z:䓡0j=|kioS쒪 j`iZmFWb-ہD(L$v|C!iV VD"*/ h[}Nr.lTG0byCMD؅!@q@sQMh&:crRD]85`4{SeuWR[Z*s)/pzG.7mbʑߎ99ɥ$<0@3$da@ؒeO?CH鼍{YhHj Q9n)M[ZbqbAhS=0{ueG:/ѿ;1k 4#Y̥NuFcU8mʣSyf'E8 ҮIU)x5JZTzr}ўR|ۺeX0evLEW,'vFNZN_ EpaZ ݋f3"ZFLrdNe^h>/ұ.*T!wߣZLC um)M8_;7=^) }5v겄VH~*c8Jdݕ1"2LeM瀩i:9ܱa7^vcYFYOfK} wr αd= ]TճJQKiF0!m1KL${~ HBTo QFK۝[/𛈤_'ȫ^(bX33hdDx.AhQrk5i.Ax`wS= .&pPl"MgmВc諫.5y&7Խ,B]IȽWV40+؂p9?)tMoht%X42e1p ˯ +\57Y4촞vR;?MY>ڽUyPHI.]UV3|J͇f= ЉS;A*D8Xx &G'RjG~DHJMxdh-"$lJ\!mfȊߓZdl&B+$f)9Q#q$v+>WGkbKPQ͐$gmOwmJ\]E+L]K>f՛ g/ْIjIf=4Yq+̣'mϩ-MU]M uaՠ*15FwALliXj2_l/hNMtp3'ΏO;mpbn%?mBۍH9+Cj;k-^n<]Q wY\9bg؈̅CSn6QvF!Yq{hq"[~R%8rxB,1=%rmN<24853w'P$o9T=\$~^c^1hvk [Az#i )Ӫ>C4ۥʘ7+N:f8Tnb%+gY(A-1՟:Dx{\ o_d5c3 x0(`}>^h bW8L`m< %K*"u3iH~JC _7o7ɓfI sti zbd#ɍV4zYdLU0~9N-W(gYG}pa1nDN S` Un~TÄ.ၯTq ^ ûAf&p2`Jlu{٭ v%Gnj_'fK26RY6Nޡ~GPrLo IF,Gv41 h N[OOHQdx3=ṃ&#k4 XvOGߡº-p}cɗ()dNXJq }lT>v "6%v9̦$\RvsӨm&h X~?'OMQ+[zT ٯi};wI<)u&%AKx*Up249F3*W&cwX-#8">r`YV6'(u4Tƀ59K~iM>C1#ث|{|I0 ˚ ;LOu7o=Z/ZlVCCF)-X Bˀ$\RL2UN#jF0lӘϓ~ Rɝ,:h.|[g~xըt2I\2)~"$BJ}o?};jH ƽ *]1g 8%1r&Pjzc%SKJ$t9^!`Ps 7k.!k MTyAc],W' H4&/Vk|qH<"8jֻߥ^#T@lSZF Zq1|Ge~WQﴽI#;¦^97 @#vnC񝾿j(uwl,>$LJ`#=\<=ͣM Lrp um=W?JMFQWýg$[#XBoƭi 8rX!53Pj~Ф: JHƶzw 9! ϰ!I`.~b_c[祥rȧJqjuPu˾.g ,'A-յb{svUvhP5EףAY}ڢ7w[VĹ73.v~i١M4?/.hKj/Twh#|( NSuF^~&B$F™XWp ED]aM[c0L}?h i3b5X zW}'3mQ崞o\L6~LNVHrѯKӚ|8/i|=w.]G2.;Qggҗ+-Xr?!yW͊㣴yI#`yn=J7 Ӗz0Ԝu2 eg{RW dc6dQ9Ieh ]SQetƤ'W`9I}DRy3QJ}jKm9 z9#-x3 J_,:5jYI\CO·6g;x!@,fPTtH1l>w*TnǪav!He [MrٳnLLp̹"6F-]|RIJZnR빁?KӵݱrQpRU#lx07x{?2px]]7 k$2GvR&HAΐ:1#}FNǩ]q3[E{^=πUkMZE|UfwO.y4u`KGK1#{VMEfڬÁr;${q'$^\]Jc$ۛQSinUem{bwp=fxwL 7*w׶0&>2d!Zrfrn;X`߽N{#f򷥯K*%{j"=M Q#_؄5deYm/_ecl Jn1})&:J91^:̔]-~<"Pk8q,1(%p67n.탻yCٯ$($dPO+x`MW+rЁ9!wx/|$z{FފuONHQhCg'i6?وH2]|N)uѶbߙV l .(19f>b›tJ (cL4J>'nb4.5Cu̱dd<3Mj4 >)3,Ru, ش2ĄLNXS΢I~3D]iƒB*ȇޤ7YΌH;Qۉn -չy \FfPMoOxOٯ ** -SAT{ڕ;d;m@nUDc(AJ?F^Ab( QMa= e[ݍ^"ч?P5"a$s.!p};꾻5r%A|B 3˫HGǓ=ZSm}-l03P~J-֚i&cXq3e0ux60FD ^ɶѱkޮvۓs,#5ߐG;T3?`F/54mDݠJ/b "Y4 _]%[KId@+ rȫmRڈ/x2A!;l5& a%Aq!mTj'|@(XUwH PݎzÛ̠_䩱 ~Zzpk-E_y:_w{kr3/+uzJwqVЬsM[~sC3ntCզ Vt3j?9 >X e"T0#@׸Y !&V>w?])Ge$s-bfE_L2ƭ/B }A}AFli{yY}-{ťek(j4[vuMDِx(+ETat_DS<}jLnCjY͂TH}&ha l۬HڽAz9eς476ϕ@"y/泮('+ fJoC;βxgQ[5TFlѰ@z88VG@:sTNaՕz|x>u;}@<}MvK/a#l[Q 'G<^I_U<"b~xwYP[mVOɠٜ~~K$3OzY07/q?+N^WCh2E>k^.X`Mic/"ykGS/-%Gi˄iHz{RhEV7p% RKkړMgiVԼIwH×3^%vhUWzũ@<|\ܕQ܂IcC;lKȈOdq*1*٭ymD$'537E+/Ll$mbQmJfmoLsQo#@wRj\SY0ߎDO ^bx}sy^t^@YW#8^)x(]3Fؾm7n8XZniJ8pη b\O~VΫ08Av~oR}db9=U/ba ,-bG1C y#oi.ԗm=KiQ^+{45aSpL2mu<=QXSC8guR)%H_RRY^8<|ttkA p92yi^dF@kCAΘJL+o)_˳3TvƎb.?cPKoa('5C(K}M:0c`-MK!\=f)0 \B*kc=k:(t߯rhgbjߟ~8Q™NT[mCWBpzͧDZ #?TQiHd,AS\m<.xTq [XXSnU( Rd4i)V;; ;}`ZZp#sAgz30xůn;wpM cu?m:x{ ws2=)} kQ|]t+/<`wfIզv5j w [%\\ENQ2k?j!_q6Î*4r ua~L ݭZAP=.ިB}XRi|86P%_I&){'mTw<Q5B/ቅ0KSRu%,h>Z?_:79;c<O\hukkDsnҔb8غzGJ@C)N#)4}tο)8}g%fIi}.BJu7]L 4ó> stream xڍtT>H5C )ݩ0 0 1t# RtwKHwJ"-%) ~Z߷fߜ89ه^CKaG\ n(@FUUQqLL:0/I CE#@ F0Y0\ >HP$$ x@"D`W@CqdN0+k$j-6HDDw:@U0jh# 0(%XŭHQ777n37JCZP'Wa7.@FX"NP ApgT @mVT;@Up:re*NC {0Xuyn;[ 9#P`W0l 9 / Es@:s;~QUurp =t՟, Aϟ#^0/.|AlQ3J\`g԰!_/! ,~ E]=xPjul7DP}'_׌( <0<6a xl6QDUs;[F( ䷾P,e~-Pw(wn j>rZO971AvM.kg+uMlԤ~9Z?墓fEg;}2댚a~4hS7MÏ$-Y:gܘ 䅔Z?VRh!tNY2Wc^F'aPow+wo=2@5pqPNZ\o1 :3u#/gD l/& bӺw0B7^mdu]K}$pH7Y^]ytBs#nsLӷ9G @rb| K8Hͽ:O]hrF^]B}=z/|#;>WL\F$[<ձ a'T$?.3  RUmkGDD+Cݡev%׉q R9n.q2_t;6gĥqx}͚Xm㜟~cykP6kPlANHdML9&QG kYJc8!7C:); voG"ٓ"ޥa |BA[2|( .n D#hD|#&# Ő!q$%1d6Wnʵ`=Ue؁`ߔm&'W;w@#' x!AoM8dDzd]ʏ} ~5he!$?kueon%dTAn`f{ ;̷snya!2TlYQɁGa3>'yaw &K}WKK݇#fdQ|T mgKIp1Y^^L*]ޠ$ }Hkq%_(xǫ,Mq65$?VN-UZ.뱘}s'@31Q ݁-y˃Qy.&*_ 7t_~8>dt~txo1 ?N 8}mˏAGVB7Ntz9O|T;4e:K>'rROC=I4$g[';sRKw¥-TI:[g0hM_e=:!M .D%pk Sa)_ĘGRr̈QHj<{64/BΧz,^=ڜv)h>xh(2tW8bZ5E_ Of_m%M͟4܉'ZFH֖M8ݧށ5n2Xj1L4SӇ!Dꗂe"CZ$w\]{K4z6mV P\+6y<KQψ@\OAQ8Ecwl2gD>$|+<ɘ!HR;\= 9"ӛuٶO%ލ$B#vwg?F^:T:QXЪ%Ӳ%d̯t%P|5n񛖧 nEǕ7LJK>Տ] Kg9=G Cl+.9Jpex]ػ]q&sh-GZ#i6E}S\Ct@,BqPV/ 3FshgE+^񮴜Yq*yMzgrryPvtȻì}bW~,؛VmvU ۜ֩F4Jȗ&ڿ 64(oy)v_ʒޘzvF'n*\ț4I'ݖ8Gw4Y7? @#e0;l:dXO/vlyNjHjs?D8N[=}L$ki\i[d5B/О|wvRKy%4K׫|RpHj˜)".ʩB4>k:tJRfm}s_ݼ}mTo$߳;/gmL6+F>|V=hۑ#D^Pjlͅ+f3VL, J>`3IZ$~w3</%a:Y*-5&2B/~YݚCKw'U€VM3*#;WwJBk;YEd5lR1:s“7#8xErӍ릐2,ijz俤ұ4yxo ȡeQ]T#ޙu;8F'25{. |*OF^UM;\M}Rǔi2>Y#qJ#'1kJ)d3JeªLm>C.3EqdڴM( I%֊6#猅5RleFdFIڮMLTɚ+,lJJ~W[^( =X6_%4V_Onzp}=:w=֧?|}}εc!cVߣ"O:qX%cBH6x,wG򏵀di;dZBl^3Cdj@BA?.p4BtY?YG{$ #6Y -zSOYM{MDͼ%~J^a`3oBxr:y{oNDQk o8C!Q\UyCa󢱦R1 g{$pg[ٱkeNTt?L,n9 Soړ5PVe)A#Tln*,WNO\.[6`RȥUyjb507͇&YB32t2+w)#&K:06^֧C{GꘟPթ:[<2QPLI֊ W/Á Z+ےCw׏>Rj۫:X'19! T #ŒOOCj,z}^ikk?\v(>J;bB2d&*5z$np^-L>3ϩtiiT)5w6$x 6Q 9㈦%ZPOD-73 'X&&-#}IIl{nD6kf!~ 8^ heEY5lvCJY.#]^Ex&7 ڑ&samtV}Mw<IcaWGzȹqT~USr>G8&zDO~$`u]o}! ccb:zT TfX?^]0y-D]|4:^}`w 7EK-zbET4&AeҜ>M<)(i2g3KR+c)y+s50K|Jj{oiS=(6ƁC9BiT`M-p`'cѳYnF.ͲN6޹g]X[ xFpaqO0HJLh[6J11So" n3kŷhFLcAP%ġ ZSrwS}'#;{!｢Բ>SY/J$xɂ$e7A۬ /驷[$ L^2;^w4abtޫ2VPӕOM= K\p5>Z-ul5 Os;6q>(Ҕ5&O}*čn@e Yc\Xr }<́xjstOvnw&Rm6-ںLFwcS45XSNIJƹD#mf26翜X_QD1hoX'*~)dqQivnLLJDȃ/>jn_wSw3ئZɨL~b(MxC;jG̘-B jboott.Gg\𢶎hx>sJ|i*j-mK>}^u͠0E D;łx`'63Kt'x}=egm1'*yk螪u/.s5Ѻ~Ʈ`yʧ. ?nr6j*L5j^Eu̅UJ|hz~%mii\>N5lE|,v/1MFNsAllledSY4Iޱًʨd/3v^3ӁH*2gxIܴoڙ9˙v= T4Rk(|ΖVXW`zƠS5ZמmcS$F[bVktɬ 5jp_ȈdHC#^i'bL\*, PB[ƺkwG%ێ7lCkSʣ7r3slSn7&McC0&ẮC0a9hӸ~eaSVnMjPwi=0u(1B#Q6Tʰ ثjNa w֦=icUlFJ˄Y}*H>Z47&|\f6eFLR7FS&8ƶ7A&\o-IZš v~.d-E),1ΈO"p(7)gAE͌ݧр62 ll"O^ܲgY#7أBj q1D ,+Mg_CUaR- ^t0zwY1'*++rC"aT`"(3 ʊ? aŃNqOـNWK~r7zr(Q{!֖i fb%Urs%ԿC}tB}(Ma%8'ʧR\zFnsNFt;V=w)a%-7:kgaݦ_@}ĂqGkh2O30E29{ۥ ҍT 1`ƵJ6ݹ?~!聞, yƗB":ߝ.pw,fMcI  *5~]qfo̝l7*q5ǘlLѺ)~C L=|iF/z-G.@,:yD$_-p=)f~Mλ*6!W.Lh^Q2ágYx8G`?eK/XF{(wL_bW'ַY1ꯆ1 n n?RL{ I eZ}s+_'{;7Inc+2H-,'j;jPgO5xI3>O(fJǾ`ԙ CLSzWR𫞖Po;o ^9ud\:2v`j շëJe>œ,Vҕc& Sm5XO>ta;j%S66ݞ~wRu㤬D'o0j?ou,i|Ŷ<..:-> ~kee)FDx燐J"%]IŔ#q%}߽WdƦG\.cLkk;-I#nEmh^/֠F!1~O> stream xڍtTT6`PJKa``DPTq}k:s~¨k#g+/XPR`^0quRP ֧`qZ($ @8DD `Q"a h($MĢrqG;``q11逜 "-(=u P08/͋r@{m_PxXCe# -i:p7n/f*@N`(W(p@GYH_@3͇zBP,wP@YNb;pŠy_#*e%Ġ~pðgNHa@Õp)`]D1XTD@Tpo߯>A/7v?W+`cPO8q?-"E0 $Oun. c~~t~LuuUL<x"х"O`ӿZYL-`-B`URpvf?P_PX jZ--忣j(V rH{,y `?~Z E``8oKk$\F`as~@Xb AXa~ }(!a(_P"걖*/ؙ;;ѯ5|j\D( pwǞ 3e7 L`a/ÚkhxV?Hd|(T^L6x3Q<Qrlіw;4R{G=+)~GtLįq L;qtcIZ el; X|?z\YD=IM*%8 ,& dj9`uϐR%:EAjye[Yd~6* ZTD= ov,A9)D[T 82NCE3ƙ"cl%LER/8hnd=txV/gfk$/ oQdHzve69GRzgš{>ʯ%z9y{-"" u;]QA=L-Ϊ46)^):[Wysࠊ=m)\[z7?%{dfAy8 wB{̜ gyHRi'(o8T??ּ<x[񚯥 DL}A'6p]zYFcX~XAar~N@ˉ̦&f'uS=SjmÕRNn=[ԴH[n/Xpԧqkm𐆁`y}.+>W^+S[#(T=v2낗 oƏ!O{MrZ>9%st GuTh([(S#fɴUk9'oҜH{1h^k0qH75NNkTYΩq`ZcJ0T!c|ool+r4ptJZ!Hʢ\p`Ҧ`kbыz~cF?`v/#0qg :?հjJ8^8ϼUYS4L ]S?T6H`%8Mb'Ժ;duuzqf*BU-.zVu ww{|.<۲}d5v@?ʉr j BsZuA/II.TFH7ibB Ϟ}beb8' ov˗Kxc>]dApCA*'+/xh,'R2Q0y*[2˓nO"v2vaD ޣR F~1m%CДJfyJ$:ŒrϿjIpahp_aNyO[kr+jyLS_Cr(=BMMT;cin/=b&Mm??gKړM:L_h0Hľf]vZNl*~bÏ>N'͗Nު"ֱ[!C,鳕R׼LMs ^K' Grhȯ?%KƯ٫qJg\5ãש}V_on3I09i`Tjψ/)E͈&#z[)!@3A6C`6{yP9g) f}n48yqluz*Gs,\ U[zfcחV |ѻ;MCrft87nޔ*`?'OOy ̨Oٛ/bC >EQ>g Ψ%\Yo'nY܇ޭ+s|a3#c}S:rԤ?'㮊G8[: :;{%[l\8sM6(BM>,xi;I(" {yW*axHhw^E0~X6#-wO\ uGx\BnNan!|{t/AX&q*$ @^D/7vUnA![܀ڽv끤6mT &Srm5Yq< dq`gmA)9Q}ote;Yey!r_I(\0Lp/ZPա4 b~$Son>b8/o"'/YXpȭ]t*8WG/lvQ&r}_^vQ*./Wh0Zް+굟VG 8%TmtMDB7aM`p?zwIE{/2P // T4?v1On});w+avGB+Ǯ{@dWwofRy򯥳~r]8Gy4hI`&";V3#d憜dyVqx2QKovSe#ӜCٜ$?\M(N?|V3~a U3ڋ6^JHR:+\M7`s/h@_wz$T&ۥINCk@Ϙ͚Yx @Gհb&$ ;IhĤoӄHxۥ락j{w[$TP^2 wUŊ)xhg[ge<[<\*yCTlUk}ޕV'lޜx|^nN hH tISGe݉FIt l~M:|^Qe elo?T]Y5-Ң7+Zb7}6R{샃+1'xkPUV-]^갬gsw,+xA(t4_qgr7@!q dAPUGq%4\jb!=$P$NTlgƲҤ8fXڂ ފjo}o)")Bk~X/>W@?6 u*A7,bXlfH6CMCy[*eVF-G#7G ^ y >(4]KHAY BYTCogbno Q-V~.8"Ŝ\ܽ;2jhj׭(`06xQpwvlMѷCVK=۾%wm#ʫ\RU-/%GdKYjȩ^̓LNg2hTL\QMkPWG2@0r&E`v_+Z FS}qV|:,ȣ5 N l;4-JEsPu/т, IG6i - z>?-_Gqɩ C]m\̑z01TMrӸJ_u̵#!fQ BT}ʔȽSϊӱ'Gu(Bd$­}`Pl_!K }ƆSl&TZ{4kő5h~rӌNz seU2D=+[@P!S/C݂a?Ďm{e-L0 YՓGYķW(FMHy,XO 46" AK;;4B5ΒOo^$jUd$?&"I3S_x9eGƦ<*B(9MB "sw6vɠ{#/?B:pKXtbPˮ8JWRNz>N7 . C XI`u7pX:3spPw< #Vhs7+zb^<tDF`:M(KIu0lf8㓷:icKKdŌS}_/N__kkt\aXcz+}.sY\N. D14S3z7Yaʉ=[J~SsWswhu:(lo}>ml*MRD, M;Ng&pJpډIu}RFC 2ƟYLw?HuژpEEf e-ZyWR\wVrW` $#LQCy*[s)rl Hn:zr<%V{{pl :Dg PصT|Tt!.C8Fk W~T0>~]]O4|| %/P^j&i8KS}Wa:SYSc@L{_Ç(|s+QzaAJI&09t=`$F3t }EYϤςއzBV@ևi-kS1>I^~RȑK֕ y-_&X%΄b7CENxOٞu23Msl.FVO&+-bEuM`~:%&Zt?|_AO/%o[k(㱢F\cE 7K9QSk!i4TPA })P$N^o@pWfxP|/ApL@ .GV_pSYjLvp 45;I?po3e"ye̾FU^յ/sf ?ߠr^89]m4s_f~%RJ4)g^m/m]+,XIʱ[:vPZ([>r"6q|>-epSAܒKİSN{$ q>pK@K?:{'=4x/Cܩg4ŸnٝB ޶CO=CdQY7>}3$le7M剳 t=`6Vf3o*qb*y ܣ#|g G]o'äjz=ZYºȟM'eRD ]ߍ0BQp |twMΚ&^Xqբ`y7Je9Ns>׏+VZ؜`fgj\87l>1Bmt#<%OT t+JWXk"=>5b:th^f endstream endobj 110 0 obj << /Length1 2691 /Length2 23118 /Length3 0 /Length 24644 /Filter /FlateDecode >> stream xڌPi 3xpwwww=@݂[ \ۙ~_uNMsu}P( 9%]x*L&&V&&x 5+W[?bx =@cWLd'`q09x9y,LL3tp[2@x QG/g+ KWP=ޙR9::[]-vƶUS+\tuuad`0sappxXZT.@gwWc;ߙ1S,\:z; )t Jm@6fs#+:9{Y[̭lE 9WOW:/Cc[ycwc+[c_̍cPblbe+E_n@U7uڻ'f 4݋;x̭%aȨno$-ؙ8Y@'Ԓ{5/G_J_bP~>sP@?+s puv/gfYLV𿽃@1V]&1~}}o˨#%)LwDD<>lLzv&!=׍?48+mo-Lcg9Z !cbg2}1_^߆pK/к@TͬVEhdjj-WeV@%_ Ԛ p_* hsR׊sAM!v3h̀ 1tJ` F_Q70F\F߈(/d0JFF߈(#6o"F .o/qQ@\#E7qQ@5~#PtO_ XǍA $5@LMm7o9_(o"jjlfgn jA!ׄ1AL=r'03 h],w'7Цv*o20Vߐt͂s_nDXAc͐% L4Ae35P, 2vƦt2 oC*o~ Q\:V9^ 6 6P"IrQ6Pmm\8P4'7WBV7 +?0;,; GoAN\Bpʞ{Wxecm]?5Cky!%Qfػ ykqTʼ3!U be^r [ ElҒCz^ U IvGEBqߘlTT`pи?T E%0E1]R8 v{΄DMĝĮ9ESa{Ƀ\ZhQ__XQ/nm@ϝw3QWc)2! ;5.^DUɼ7zFIOnV镰x٣!m)I?]󿋎|1lYSnX"˘\?!{ʄ)0v,(,\+|K̶z kvy_K|]L0Bnb#9gS2O~S$U \R6$ :Oh?IkÚEmRa~KPPb# CBxFAa^,*3&ZF ,HcwhvNj?*lYbƒT=)B5ܷ5Aol,aȿ/6YCBڐZnzՏ@ !\#+Δ#lÑ\h/W\J|l̳WwR`K(H-~βn?X?A[}nr<9wC4oJDtֶǦNax+ݖ_{V_m4 iR^^>Gr$݇c'iN42)KmJ[aEp䰬qdv'<;HY^Eiji%rr-o7tpfCQwx#,I&52#tn,}8kn 34i{*&_ &aR|;q,ێhvљAk'ڒQ8x37.TI|D"g6Upì=(/Tᄄ)[;~v &Cy:YP;Aݩ[Ffd؅3زA/஥5Ri(=etmM])! Uλ'K9Etr3Ucq ]PlXNa݊ b4̓ѧ7}y뉌׽YJ,y߻ޑ-hAK$Fr,8$u}cya" `17B߉#X[gykM +|ǘ&qAEDm"/??!ٯ iW=-n[~_A##P Z!נ:lKwVr݂].3Yީp)5yUc;vrn {H=#pAUʬ yHՊ Vt\\sD!ǽa-r7H%6d%LhھZ2Y%i9(M|o̦vPQR2RHp19w1ͰG}SU_3G 퍫v^Y_ %J^\Z2Qxޖ <\.NBOnHiP1VXg=,1`m6rN{wjq Lsib7+)H jq $Gk[Xh6ދR7׳ukՕYح< QxA@u#ZVxñ$ONBSKWቋ% o.^=rNcҚ"xy#0m3) Õ"Õ9]P$C{z' SK0 .&A:.>Sq m2T')0,>fY9}h(Ckm)؄BLl-x4oALm;hbpލ"ʞ*ԧuHoy.]|qHF5~[ntQ`)'I9(umM$deU>։q2ڮ"B:v^ҼQH*:tHj&1A4 \}O^f데G>âyccEnׂ]RQ^ tUb#h:$=| +5싘aQHa*ZB,g\ ,JܱsQӠu?ƉЯn(vA;\'xKlH,T4Fpe1 Wה.Rj>/OcYu?f{z/f !e`ߥ> QGVq}&dH@vٸP=)}Ln}m/-'syK2fϷK{uHvas L!x9XQQ( :MgD{Lo6L[(OԌdP9~BoA@mh:x`Ki5*u!4,]=E}z>W ܸ w>e9c <{[p)Y$L͑IeƺwJlRs|h>5.Kajcd_zڻ۔#ЅcNK?1eW.w`iyjtaT[m0B 2zCĤQ]=WRz&jjmRlx)Sj>^?ROHxg54 oK JQBw$B0$ 5YI:y.i1MI <ϡSM_>l2d}/&,KAڧ2w|3Ctܢc83Oa=:@",JQvh4) e@L{ 2x7(TA|8τ'k/p>W6c Fuow \Bl4?aclk NXmF%mQGw=3|쓔#^v?h|``yhi|xXB|zogKO?uNW5zϊG2wՆ@Š_^&`*6%y"6/CgHQĩ/t!Mxol|TPjibǩ:ÔIæf %ڞZd>lӢpqN8`ǀN5#>hDÙ}='Z_oѠFҍP2]"s#+c F9ۇ:*G1?G=r nKr‡~p}3{VI^ Bvig3RVsum4+՝ɳ)tmgb7bեq[t?!ǂ]O3&7.iL4>5:eWQQ-\'ĎrgFRկC.mۿ=}I{V,U01Oe-4ہ.fD{bx'[Dd:_/փjKyMĠ+~GRO '3Oo&8^K̆h+$#,?e8ц[ZgyAY$#-bqI &ID/)̲*'rג6Q ,2!Ԣ "m^vX%t]rϪxjhȖqR_JN3Ʃno{$ޚiHc`UJn095B ݀[FTUz !?e/ XSiZwDo7N4df}SڴP&KD#~S<@0yH+HHRㅎ$&WmF}{5I$ăDM=T#Ip*?OQe)z^[,SĿaS|=$tX ԯm:nͺdw7!J@YJaUW-})53sKPDhA+UU:Jv 9N6V f˸ez5jUIz~t: -X?knbT=37SzM '//ڛFqo% 3??mA^IRn)7UVJ#<ݜSO3X̒Z{Qm_T 5y|Q]psPt|2L!|{vY+3ّۛѝUsVn2HjY_GR0'7YUy!z ȱ_,KTy-mnpR#WV."2bJO\-脴ۚլ9;8q=G\+x̪5 .msl+uA/WO9bdi?_=9vutPiUA3g!U՚xGjH6g]M0I_)ȹ"xpD캙{b/$u Ke^bmFō&= /ô (+m?bNϴĘI}H¬]&35Q;6#;]GM '҆:}=m=^iec:ITj lFp17p|WRMvR#! e^* a"eYE4Iֽ{ԕGƎ|FO96Hkit^^ WP. Or513N8\UnST< j \aٲzmz@~}9R6Qzk]qP9j }1;=-{7hV)v7^ThԧGV(Aa$ʑ%n3%s,J<s0lg<@Qb;C@1J)5{J+_kgDUwa='Y8owZ"Xi,-2!K^qNU5tF5G8sd'l H2&_y-^5E /(`w[y]MTeIHe-&o?@g{W(ўW s5E}aarTJsWB%޼G0;gDYf@[A?\ ?siːƸ&Z* TP;gY6!>[T |mi}뵬'wByǟP%exE/gzd 7 ֊u9e`՜b6UKK1gS4z ܧGM觚);g~7 _/ٙBy>{RZ/QfFXHtjVDH-;3^)*þDl >{he^TCHT҄Ҝվ"_ bޖy z{>1ɺܳM!ˏ/5}x OSx9,85+[3D5_h  %H~},HO$h>Z-*(,c{IfF^cơgMW9MXY-BnD,js j F$V`ˆXz.$l5 ϧ@,aS}/%ݏʟRW/ CʍyۿRs+&FZlbӸ-rRGi+bQ,뒉r{reZYkz&, Xs MN׶W7׎|X$=:=vYT?Sjs|7:+?eʽ\:AxuhA^n&HRx1<䞃4e< ܄?ܘlXi[+0lg#%p5 Vz6}P_03u,_=4]toҏ GuθlJΪ`D&d6ъ%bwHʭH{bDr_<.6Zj5/ CJS<(3A=!KЦ1Wm͙Tvԑ8̖&Yy2~qljP87F0 [3'V˧%Mm2kq@-c#i;-!O4=ĝz0J`gd O*`+?92o&Es6Pp= j^aR}4}`xN% &KYN{6j)C=ԦlW`ƊHNt/:d.>\h08l)f?y_ A{ :c+A^QO7ejvm!$:G׍FSϨVtN/6ңusU5dgbd{V78u\4E |y*x2z~X#F~Rcv!e5݅1+q>X0O*aUeXi+=Lj(6Y2A)#ڃ7L}ܗT)r1+SΔyUB'~5t$`q)h3xkPe`="WNC1@ e^8y~%v })o"TvXOhT4hDNo] Lpiz}xe- 5}/2˱ #e&tkb\%'lɕ;77oJHr}ĺT'Nݑ)ZVWnPR0S2fD Oq)Th&J0EN|w:θHbm(=G/6Bl?O,D'Y6(yM TLBX^*{Qo᰾wJq+Hx:΄|/H?PSkH>8/Zo\KukjKnϝÓIzK Y+Y=պ#\(G61]AZv@J9%5jn^jDpDl[Y$ry&qts.{c_4"WؕWmV!rPc1XZѳ$Ƌ]m4o?ٗb*9Ե8+%n-Z"-H~.0+x1Ar qi\YNbodXv&mP_@u2Qcy8n4O'l{8ӑW{% Q;>|H)wy"Mal 1I5)$j1e 1;zGNo"1B<Ӭ! QmS1` !9$!FJL_HtT$&ANP:~0ހ·Mvc'M؈ I',4 R!%_ypVIJ7fޑIα52RdS:B )m_=2Af ?}kCR\<̧ʲ9^lÐ"XO9B{z4;{yTDy uq )``{Ss[  <#Z}a߃a.ܿw*5Q:{gGJlfL_t_$ ˋ 5 <~yX!ف;VȒ"O=3>dFOχN̝/\gG#%kשD>H֓TM@\b ۮ_;!mٶ(b\Do¥1Bڴ+Q_2zE! M# r}uzؾ-f~P<|7}3q~[ Q+"(>"s5 :8/ Œy޵_!^Js6NpH \> Œb26$52{WnccdtP0fQ׺!zisTR3)+yow?rWAMUwճHUKG[%}5`PRLiC? "ӟz  {Yyr5j]C#*lK0nı,^A4Lג̈́r)>NsN/#~V3B>F;-3sjquޑWd`ΰM!5uY>bWY/a]dWBo(scҌ{ =ђ#7JB&jP>3|*p ?iن2| Y|0&C8;63#׭M_Yk2ϏѸ`<\6 Z"tں:DV8Wֹ1\`0eР؟LRSuLQmhҧIḖLQ̌]Oc-DأpQkE=yɇ-$^ɫ~WzFs_Kխ9::Ǘ &qIH翰NE)?9YT֔qߴ C52jvx~#vov&xWNU dFjF&v8H}ՙkᤦy+Bd4̔zYJ|3,Qi 7 Q=k\LI4G"S84NLM&829+x"7#[qs({m~2" k C4WA_hzecGJY4ҚD:X 4#ggjX0u ;'!\I.sgϚ<>p,7Rxbfc?qK1U+r|iǢYplD0MK.Q1|qFQolٳWt|1Ŭk:5Eno ~f|Kc GB i 5U|D{mnRYw5U3%BllI#VnWB-'Y13>玄Q; #A58J?&^K&P_gJho5GK9kI&߽{ +e[}ҧ8YfW5)ߣO<ƺTD'u֠iIa;GΌySR&,b7@}g$n@bǮ3]!y\шl#SV2]4>4,~sX;eXY?{4rp2-屈O>CVSeƉwi&Dx~ Q*wZ (\CA+h=8#~ rѓ7xׯ&uF#$W!(mgGm;=`{37b~LΜ$ nDUG9 $ytik7u3]b ;m[H!>wu3Qɥ|č֫s]BۣɊ^2.X*lu+|{s\z1 ~ hDՔւzM\Y]#'uMyFhќ.\I1}] 9ax5YM> D3Y7Hr2ke6 7^wu+ Y'ۥzzT\kZAݞ'=7c_cH?pû^:dXpn7Hd :K/o$Kx&m^ %P*Oq9Ot D2% 8yТ 'ԃ~|pPC^Ue,N/vIL^R&O؋~UzǪ d-=k?&-)_Ӈx xD(POIYmȴj˯JX Q]CSg;al<lAہxa^4?ԓXwh&CQ8{ߞ$;=͒dL _t٢ke6)no$:{Kq'S706d':٬ ,(@G]].E20.gg5NGpEH8}LGu_U'??17 pډ8m[آ5=.!$)>iԶ8h=TĸP|K1Qp { ;'ư>*4AH*u6pw.4rȺO[J v|tj VN2ȟd[ =1q4] MfX "o Y>Sܱⁿ|Rh-N'?z~Lt>c7{%X:fLM+저Pڃ> ^vѧ%qF^^r9MW ʵpgf}7yrظo"k/?{8;>.uXri7Z3 ),%BDɼqd1}꜏*&8XC<@i&z':WN-< {#x-qlH P$yon̻ŋ|Hm\s7KwD((>֦`\X_\,2簧poڠ:y7Ƽ HI|CLTeJ4s!(&kVKlHަTr՝JeUrS.M=kp]) xRP8(weaj1L DA%D<?Kp E:@VrjN`cz`+Vi: yRx݊lL*qMDlc\*5 YB,NURöD(_ K;:J=Hʁiۻ59.v3-Y&rB,4 ]T٫/ʆ/B/:+''&PMl0B1@z[0wAT4t ۞uB ~dm,r>UxnQAU`éOic.7g\xtP˓eݨ>]GϑH{SS X:'AR7LB zstTLOɒM?GH~>{B!af Vhz1TѲ6j+ =w@ .ljcM=!_=Cp( c|LC{m.Ӈ55ff.5}U1o#^:/!S<-pb܈o z,7.;Etţ"6ى7wECGh%Xra(9evkCy},j]do L&ռklC4Syop%CXlNu8=v {t+%P9a}ZV?B&Xsk30=6D 9n*D>mήZP]T T4T G, Or vT "&"lTJqyaYa4ؙ-tв@5Rj0½n?2"hos#MjO~`*~:BpA@;$Plt̵>8 {3a'm~/f筀s OoO4{FCp+;5f>]4J1uܺ"0+!DzWe ʗ.vr^sp"$dz]Zs>UHE QfObR26MSeOgLO{+>hct_PYƆMF)zh؊Ȅ`#7:o 9hos݈pI5!0óW .I_?6MD(%mQZeH$v^+ r1VPkNo:HJѷ$g- ޙ,k"e_ڢ7}*] fjz -#FWH.ʖ=h2[+Lf(?p|I ӢφzxE eC+i`HRW@l} EyG b-MgS&qj}e+1,򐃉tˏ'ؚ_rW s UB0hעkfO2qi\_*t5@hKbayŒ}/6ؙ ά2=8A;GŪ MP ШU2; sxB5ZXІy1|DM梙^˂ui*LMAOo p+1Cצ?kh˝5SＭKxdJ3KFWbk=|X:>/`*>r޸tvH9T~mWjQ v9B&#gݚI1Pw &ґCI|+Ūlxe^[|d-L.'iqtVCPCy<.BDZ)BxE3ZٽJD5fӇ n{yV7Fq56j2X.X!B-&u>}q}|ާY`m` /0wޓ]WJ 8cAE`& XWIK+?ܣMpm+I<v9ANwV[Mi\f(/84L0PGI%Q[+) }|k'ư^[96Ue|0=o Lc'ΒzHo}Ĩ"eGf8 Yc0>i\PXXt iH崬ֻ{T ExHex2[*+ ȼ\,5$ z4YR;}}Ĝt]3y9*~bqzS!MT=",=hzZDy]͕jH 2Q?#<.4bGc</wyB9QPy@[ uzaW?zsI_#X33X"qjf+56a;X'QU=>5*'hG*$$xՖU؟>?"hYe(ExJ8JJ!btuV[Hw!J(BghwřD[quȽK) ҬKqXpCHcDJJǩUg%q[[Zpb4)A:FGOam$g,2'sW 4ۆ$ڄ-a2G,Hy=~9  ӿ6>e2Rw 2sՒ:c|}/[X\XDۤRr.99f @uo1X=q<o*m4ZUymUK+2ٞßbAAzMP$LHj1M#r]/ŵd Qv]ǵZzuXQ$nz}S PYTi+J{]}m0,t抮{'!18݆M& 1G>#Rv gE%7uR+m^MK(rc9=-X~[h\d7ļhQv2ީԱAs6wIZ vZkN;rB)?bwW%mL.NqR}舄4vKxދ$[ Fz_p]D6D'hP)!u5PXǦqpj,^Fn$m0m )gAq2VL ""VãFbͣ=[bpnv0Jt u:37_ 0R) g{(ӯAhJXůaє44 )973XAgWJo򨭘;`Y8}+%-: ^؍Y @u|aM92z\-ʕcJ22Bl('Q#h ͯ$l7 ZWjS[pRWp2Yu06\0w;QD7;ʹ *]iRzѳ%;{U:,>mEنS}3zMF(X%)xؖBPkfS$8p\A X(A%PD&˹L ޕdf@b qF չp#=Ҳ|٫ Dfޮ"g9lʺE78+?v G"hoC#_~5}2Pv7l]*'"N.'h#^W;vuWϊRk]+9jhciclGK(f.BR4u^B. oRBR%R :]&L\j~-cmm)goyHe ,54+ZriVيߋ;5>G׫Q| ٸRh`X}C^(rUHnZ"_kYaXz|M8=ӳuݒV.!t/zrX/ [#T$ R%}>y8-Ww)ڿq5\L^iֺ`Lb hli 8>;adՋZeTАoHhơL2NcѪ5!M"lTb*k匸 .lz,o-&ٍpDUWvRnnjmz*5#K= S#nO ݔY~3аN,ueykVn I!wE_L]t6f ,5k?ucd@Jm8"T7 v*&'򏨍O+ Vg4tVTCXt&xp,[ˌ1Qq ʑQz}dӇGv^g: Iy V?/!,,7'f5[ovPbC1N$kӞ&A(DVPfVB*bMyQJ4W#|df8:!k_O>S+۟2pI,e|,K7Qi~\eհ]Y# c. s2G<=Q Ȥ.6tY:\_rqBKDM >\46zz,[z,XB%TEBlB@Ӟ5Z/MSNtݴA^|PIE$xo؂TW8tBF_u|& q4I`"ʧr)I=iLxV2'D U ϹI|G '#Qd(䍛v@ j Y)s>z X|⵪SG?& ɧU]ۓX]=eƽomWYfr8S1PLbܧeE%\(ΘKqǴiO/Ldz,`Unʄtdr{wtE,}HF H8*p.?dwaDm23 t L6>Imb0}_GD?떅1V1lco҉a OXO+Zm -FM|3GB] RFD>mGK+Y:oPzN 4x5vzݛI8=K~鹢vCbMp(^VY7yq*d^|YP|$1Q|@a-,;XDAVYRb MٗLsAznLk/ ]4? PMݧ +;\͓m' }.*')恽oa z+T( 3D#5vw-)H4-l̂bjO3;kMX*+yFb~ĖCG)`l[BNg-!)f%vG<-RsOk|gR -E8zy;wڽm`}tPG׺ѧFC2rq¸-5 Hd 8Ÿu1sI+1z'FEk)'j,}|v\:pU:B)g.8me[Om^,?P194hIai%{LT|M?yPUg뽥!.AKgwU!PqcfiIN(]ރ~H".AF:DGka4Bw*s'c/ YOSZ\&jP^6 1nN+<*#jLWY>c!6]N rLHNFI^{Z.}[,^6BuLqdR -[zzkCF8~wh¤%+EN<}L\6 ZȸF' Lpg#wv6(VxcK;^2otذIhxXlj V@=& %ó@ؼzK/;-8GYْ %JtO$,ػIqRxMCuaO [~[v/ڪպlhdz |x\*uŦGSف9 %],4[YmH`)UInzcmNI)뚺> [J(17L3w3m*<"ڕDLeq R± ^7v@to9HʇzR8Z)mbA[2\qa(uf#ݢ"h͑ƃOPO٧s%'j\S'ĤN1]%eCMK}hqkի rRfwXX-S:MmI%U'M$C3!> stream xڍP-%hiFh]$e?i0d|^lެC,~aĦ;NN!@~`+ p|o[A`?ٟ ?C#gqg,/KG??M]^KRAωIJ:z|X,<~~;￳uO gϧv߹TE 7<_J#O࿳4 ɺq^5-/UΪ,nUp>cȂ=A`W ?]ك! uGW?Ͳ{~9\ 8]Rbh{8yx@(,$N*Z<0x`E}6ߦ??Mo, zfl,l6п  /_) s*ȿs*J?s{ >Wr<;]o '\=ynVA?u1nP<  @]w m `ٝKg`Yva"0T}ހ^Ib_/S>#G&k>&jN.~!x(Q7@BƢ-dۥHƏw/Y7P2>WūP:&x&qskڜ./__MH*-n@;Ʒq{j@Lhi&_+hOr(JBpb¬~RD˩G'gд!HDbFZ=X]oh4!oܶPtM590{=~h"qko l MCC~ukJ4[º,r+RD)2r[цLkw2ITU"w5F(eKPz7bK12}x^Exq 0k$;_J?dQC|2/D;lM<Sk5~E_2QtmFɇ#}Y\uF[ ?$XԽ^ A !# <>eҚ"*S샙'Rpf|{EC#AǑtn*^U^ ixcL=kd Jᑦ369^}lv9&4ߴ]arE yJNy^IwOcd5oEt= Fx>%W)|Ӧ\~yJQ#Q2M9aA.UByuƷ+NK o?ː#IF?֢R>N+J}[kƒbCI@)MfH<NED*t?oCU_\uJ"bbV7 sWS2r=]m8L}r@ڕhbvLDCDzYQ? R[9~NT#I,1%ӻ͚9:gxC%x t,jR\$< V)5`ʄ4{tau6ĨbUʧ8WXô=&Z ^llefT*@U~x+G]qs73i"RxF>HlV2M/ F× JMwmvu_ݡfL eY丸"@oq}.顦cIH|}4cyG$lI"9HQ4O|hO0߹YE`)Ͳmʧw?zX2*@XJB=Lw5t/p1j7W~2\d1ꡗ8PrD1J_-CG4U:,R:PouV=7r샨FWm igX7$+2NYe)191݉0JaJ?!%YtEK*CʙMUeӇӖP;A k'jxIȅm54}2,9HW&D<#| L:=d V5?FObI+UH_+rvL*J Ϩk5)pϙIb$ESppmT}}\NytG`Iա.3 24)^.V倴%bI9uPxk* (q]^5/_PȬքKYrk>2<5)\U;kO ʨv ]6&*ņ&N/ **UOKr<(FYW1)"Kb M܄tSI?您.WL!K@4RQ|כb=N}[O}[ Y+T~KhO%zs1bcbG w%]HK4v.h `E/ʒe6>wLDDN0SIT3T~,HS(!udQȖYFFmBx!”W zhY$>Mk׻O hSWuJFq16NeQsFP\9\L}%vWD$SZ F lb|t||,fCKU*ɿօѺLWS[XNF%{| ЇZ.ť9:R^s^k+E!TIP2A0n8}>gߴ Uc&#a2 읰51\OՐi>o ʸ94l%Q3@D?씣; Dޣ&B*iKDȚGXs|3i9[&gٕO5b^!Nz4]RzTWYF!eUP:b+c?FY%mt8@Ea4VGti s-j.G"OW")z۟>$u'PF)\dF~Cg5waK9ﻇ+@cs ʇib(DiEu%iDw' al?W1} zG\Wqvc`C4)$rmOUCMRgPrAmToR44z(X-uk'2"΃{ctN+ o~X7&E^MձwuD4}m9u"R~CvxphB9$Bԛv +{ʗ' *m_θd/B @.K9ۄk%:+Rd*&~wʒn99EFNXv_})AǮBjLxz!~UU׵ꏽyhb8 Y>g8w!cMǡ5r(N~b]l?օR|ʽDmt/4C@P<'dl84T٘\VWѩRqϓزC#ς4vf=1Gﺳ̦ nXtGu?tJ bygAml~.7^Y+~Q_]#.U axEH$uDEC;օATynr1nd emPH\6\ή:1 V1MkP@|Uv|NV_xdSs=|o% o'3bG8?Ify#K [0MŴ#26T_-8HrwЪPۨ`izB7[\jae=p5mf ,UgX>R e sZE#!gi, "=Ą8/G:DY#oMpRo}g;VѼkb1!ݬB$Ļr;gxmp+5?wl_zB &yo/u3ta\o/F-BaΩ؍b-,l5W=[$d Z)o4 rdf2{N>h p'C.}{oDk}NH?®Lef}eޏퟻ(Zg3s_뮰v7ׄ{+]3%5F1,,1IߖF2yxD AN>E9hJ }V׆EWkh{m.ah;($`éccgi,ި>]zxu8݃2 @*k i3rsH| r9Xڵe#. ,}NZ1He=Ru΂ $coV1/Vy=MffA(v8%2EwiBLj_jzOXD2XJ%yFK[ WL1Pa:,)R%0 Wְi ‰ hrmIp2XvEL2:aʛ1TU &%FiCLSKS([Vz;Q&&69uĬ/s? (]=ĤDK<O*,ftEƱ.VӰ^av'Df_C8vmXffkȭWuj_KjnC7v0Yt f{{9G>NpO-e^䇰ie 1 buD'22ȣW]/tZ"`Oo_͠HǢ;!KAOqvg4D $oe5P$:H,6 5i"26(ų̋5ޓ&0M. r{'HA͔T/T/>ZrYCPC~vg?sp+O)o%ydcqC= aS ZQG[YpQ_xM4S2e˵a)"[3 q,I|]G\Bj,! +EB4 9ٽmQޣn>]Vx1+Z3~0LIwW8% S>kJ`ˮkٗlF6YmgCal 9޻w?l&Fp&pJ)l#:%5t/r9jv 4RKB>|ڃJOc@tḇ.{|1_Dm XU eG;R +NrVNZyeѮc}ڭ(2[ @*=ToA;&SM9Yy ;yBx7J:цKtϥaF*b4SiT ֟욭A| s\4R!Π^L߮}*l >ñI:P1XBMIMBWYۤ^+<գ󻼷"EqRU|@Cw1zBC`+м ? [/28}(4@WDB`ȯC4Z;Ɇ:&eȖUI7 mX-7 R9E1+!O+KiSZman0YoZ,mؒ,Żo:-ͱ2uT1_7&f Ǟ7%hx+n7z(T40ZVˍ$!bpGJ ߚ=KWՏ R J")l5D^sf`9|eA4v8}_Pݮ¹]yÕ"Yw{}fUN,OwE C:Q75tH V5Bn}&p{7{9?;uhUjXVlQկnb*"}ӕF C  CrF"4;&/аZ5)xE5wB^g &0˭$R˗T19%Y*}/.k,zŁE?|ΖxfN }V(@'}яuI^tKqz <8衭8rF~]n5TgĹk+Vx5 Kwy2HCC 7 UvCC0)xIr5p)cK_%=tp$U B> @2d#j!؂B Y{-l}WEg dVsk Zm୩w",.zW[k)6>7B8tw-L_d8]>2g TK:U')̤tjCS3 w}㜕Yݣ:5ؽNVUOBS<4B BM!" =L%ؼvU_I#t4r1p{#åB<͍ cʧSwzeDmIb0sj+ZH)){cS^3FP G%}l]OEP'JY=G#-,I<}2]+:JZ߼";\'vPZ4`2" $BE;+,cAyy LQ2&]k1!ǣ0qNax~&ַ-药s:]- Fd?J3VigZ@˔ҕھVEK?BA6>޾d!e>w$"B<0SJ$W >un]&*?xn7H ^zb֯[L@zZw[kϞ`k=V,FG~dNb[7vWا|MR]~]8<>qM|SU!ռL<aa^)Kv9xh R~ Xr&E7}Q#\ ׼<:Cu"Ś}Qz*X4N6DL@؊g' yیF'+@3?G6^fՄX^}am)sYЫ;Y cݹ5f®Wf~qx L1E+?yt9 6՟ؗ se+Z hLxWpهne.C3q>gʤU&FO2MQÖMv|qjSod)H9t Ϊ$t'aH>9T-YoJ[%xseq -ʗ5bv -R; $#Z!46$opyq<7)6;iy[wOY3I_,Xdk9âx$t>dZΚ| Dϔiyܵ>iE55(C{(젺z<' !BqaݝEep 0v/tTԅJڑ5A *nLZ; |1VY5Q;P:gM02oiZcGka2E\aJ;ro#"ċE$ld/hq"Avmt񂽥)~^?Ӌfu66-;@\֯=~!]ۊUeX4 jg[/?` eR94j񳶨q.?`U endstream endobj 114 0 obj << /Length1 1667 /Length2 9700 /Length3 0 /Length 10769 /Filter /FlateDecode >> stream xڍP\.Cp Ntn .  'Gf̽_^u-_{}kס&W`!`W&6fV~:ZjKL tvA2p$\_ `= `ge!ę i(1!` 2dm?Z :13 P2s:d0h@,@@W A+hl qcx\m@;aΘ6 ?+W3g E`]^<@gKr"@XOF_g`cf;_޿8YX@^ 5 dH+2z2 ] /ff {3?*7H^= g w,üR O x9v/?'kx}V &,Y '7_&/"d@W+++zZذC[ҁ#`d|Cq1s\݀~>V7BfcX,\@k/b՟e O hh)i0:qq' p;*Xq[A|rJ)t y!-@ YX-^lL࿣8ICQ92xᬛ /[_S;9Ve#E TZI?ZB\@o+^6pya*wJ)sq̜ͼY_a{YEK0!/.Vgx,#7{Af >w,l?beE`/RÿL@LLAvߐ 2?K~./R`r)/C=K PЎZ7LB3Ի:tL>KΝn)t5b)#}+RWdO>#ڒ|Mԧvۑ N5 "f}r-OƋZs/0PK^ c4;XàY9 W&$z3O٫g2dw|7yVjR^az#=Uc f+{|Q<9ng ^Dɣ跞α@?3oF=0=^65bH u۱TI&< kڧpis<5{ά ?6aΈ,cSXK61ANN!X6v^ZSiaRC,&”Lgy,ffڍ_,6^•OOmznjm+Π[6M$rhgz3H!_W#ꍔ?73> tņ3j6̑!1jZ!Ǣ'S+,JܣtȐgm6~B$x C@<ـATg"3Y#"1d>9x5/`]Wӑ=x)|WHe/jIeQ/REa;A%W7U͂[qgOکz23ZȻ̈ vu"pCROh.#h+bfѸ<:FWRYLv<+)KӈB95$I&/6mb @xt T9ȾD=+M.y!iK;D "Ėd}a>}ؕHZJ)+8ay~qɎZz>û9Ő>aJJ{!J;glKd/|uЭnIQ.z6rEaF}ը8U_ʯb~}u;!5-A_˩־#`J"lγDc/GEڅ||b^^L'SUDUF-0}*$EWNOdPd-dH? uq7ёh3EdAزaM ;! 6ǫmsʃKbpAX GlbEOb!P,Ji #cYљE 2$YkyQlb稸NEӳyCY"3U$BWqG,}EeQɃDo*ة8fkަ>>iVA1gDOYܣAw{6̾a SDczTNbO9?Ş( {I$'U1i8y%s]Gjvqer˹Q&fzH.nIb(~Q'Uy+O?XtJ! x!B?2lT١fP lc?ꌉ&y5M }9G1E54jā1_I6]x~N$g[yP+g2BoZ+iwPw{a0gZ7Ja 7It#}X-D3)ı.&*稽ۨ8C o([R*%tg^6~fzԒ&"ҨξBƀ"g\B'Im6r4WsfE]e>v8q*,NSM\":<ɯmT=V1ͽYtV0[a ra܄\wmy 9[nڹ*v՞c05Y;ԿrbGrPY6%;Z0d.u6qrn@od<.XM9Oه!8$cFZU!R!Bl״NhX~H.`kZ`DٌY_t7J,D;6siQc*ҟ E1ʷa+Khr3`]?IJ-jzZU )j'fƍ#ZK:z5 @3^T H|K) OAR$1M҂J ߯|;Px4FuJ--KKE2'ԬH%}bgUҎxDR#¤]hzJu9!_eF QSo +Ri W )^ 5 *p-FPr.ZQ}cImji<8- wǥo0m ^-F XE, 2Tq1WuApjvXa|i#{bZDǮݯ= T&skx Py I+D<-H߲yGX߭]b0%pUjSQ4h g2"Y#-"'yc.WhzZ A1,X}'f{\o,HɱN?G6u8yCDr GSFliDYDEc  P8H>QLur5t':Tt0q=iX up1\l抐 <B?caj&1N9k[E(ٻ=;;x,qڿރgҗ<@ tߑY4KKɹ< Uac:x9^qviaC,ȟ 757`6oCBƟңst8EN+&j1ZбD2 HZ$,QS04>)iaU)]V( >qRrs. G ۨz0W3'U0&3QAY5^1"dS-5cAŲH hKG1i?3d& _ Gfܚ:l 1sع*Bi (ũtc)q4BNnb xoWc߲YSfG !]Z2Z7J:%o"<*ϪɛcNdVkf4~GuUIvH 0*lɲO+g͙' ,x"b#+n=3P +shdi0{`Lt4}П3Uu=:[ c7wPVw?icy)V~wsEєzV^p쓱#ցӰhE,徴IyOKls^ݯc)ƗI"v)y4\ƐeWdE8L|[DՉ7XJ~k&qq4\v2\>#%t8ƐW*|kSk"1,}?qA=4:݄_*yבnDke!AmjؒܫY+9ɥe#򂉖ܑ{хf!f׾=ω5Flb)ÅfʮȦhnF&Pwi~sę\ަ 黎L/P-[_IE!zLy"1(\yaO>eG(gO[lJj$*5MչyRfZqgz9WGGն3g4cpp}VaΪg$ 6d:It}ʸ*JqGi#Ym`, [ iM!/JQvH , ZΪޞ0شIi*ӸgTrm@^QIVBΌxAsrpEf [| '~3GֻtrC:&wܶT_S#5T;t Ur Yhj){tvSH+iWԝŜ S9~s׽iFhuHbGe+k14vE`EV@Xv_Sf %Q{DSj ~ydAz3O̢=x]nP'Th ? #"F Uo)CfMjhcB)q4dL۶^{gё#I7r$B1$em267wZ^íAjȭY\@X*#t-\E\P?Y.?Em|f#3[YdQZDkz0s7VR[N\6]#ЭDuA_ّC7"p[osL#aFEi~jjzr+AFKsARBt\VIcXTaFJzV5SzseFOc m+ :qhr/FS!Tŋ譽e2=f`׻@[CYr? :ì4z:-+NFY4u KBc(YF-bެA7)=E_w5%jA).ː e8n.VRVK1j= p"kVUGqG\Μ`n^ma-w38Wk )oz=2tK}]"[=_;+F֐;<2NyC{})a (eꢆARGUYӺg[ NK!u*[]sCe%ĵ5Ap>|/l&{k}*fy)r[Xqьӑ##H-./dz(N!Xz"Kv.Kx VSW3R|8]S|N&ΰK17-N~yYwI𩴣(F-iH1isIM0<}7}(#ߏn\LvA|OmoXyƁvpV\6P< 33dUeaTD"fT14)_?ݨH({G?kR)]rGw½S7 G{'s,WOjƠ*'xk5ePaӓ 8pW$:Į;ڇvYf?[#S ~]ݟŷzI@|M}=FYV ^ vK JڄNJbx k>.|GL,u\-+ /Zp>W# J .E{E^[P"B[m,(>]HӘjpT]h֮J'X2"[\ =fucfj%buIC sZ X %&و B\f;Ngڢ4N„S&%7XYDw+#[ڋPbj7xN]iq gA:Kx` #&&~] Q9#Íno+ow8!Ljt.+w[&sM5_wT>pпSX% }ᲃQF^stw|vH9V(zWbuOLũ5Yポ3p1tE ۰_5ZTd=[.o5XNKJC槞L "Q<9\<ӨJ3NF*%76-i*$[H1:j(d#Pjn¬|viěO0cB&s Wʕ-QiOC+^@o%f5Fcќx&8Ml1(=M!-TsѸ5%7@eh21^wȭ~ݏ OH21"򵱩awӱ:RlzgεIP ubG;=R3;ܲElƿH60U!w&/NmkGexZ1G+=io%WtΨE.0 j1دKa؍iF7wU@g#q$a *m0_bk i݃yKLW\pBacc%#9(IHQp0- 2bdpJ[)|_=(XBP%ϚO,0~9ϖaԱ4Ɩra1;Sv}:"`W"oqsݕR¹٩yƉ]۸}Z8Kp˱5S/<^f7SqRLEʚv13MP ׷@T?}[e۶]xC# e endstream endobj 116 0 obj << /Length1 1357 /Length2 5945 /Length3 0 /Length 6875 /Filter /FlateDecode >> stream xڍWTlS@$T1:6QBc66CB@B 4P@N}w9=Ͽ{LHD"B`a,@T @@9#ZP^p$BP0'SqfH@ %eR @!% P]$ETCz`Qpg4.˿^(,##%Cv2B!n3$CcW{ #QΊ|_8` |`_ !ߍ S.p?b3p789x#a(.7LG`C1c k40 Bp8`#M}a4- Bܼ8q.T1@p՝@{ {~u(+ nG5; U:⦎VWG8:jCeQ-s HJZ0P_ͱJ/1@ ,P{A|`4QG8 p9GljaNͣ <0[Ho1UWUH _H`1(_UA8!2M_}޿g,C$0I/]7t?vsZ; Wo4HijCW#?:h*g h["3Fz=(!0:G *4L"KTBA X ܊q7 ?GCG7"$pB(~S\ {~ )Bh{0 A)f&Pmǵ*7|ƀVgPOIjQU^_{4˟gɦ#/)6UE~S\y%32ԕC-Mm\HwV ]쇨eI=ʳQxq`C Z= kyCl[ bK'~^\L}W]K׽>x!c'T߲1j]n,/3!N\bv{){ xޜ"FTQ Mr}ŁŕA EjRi۾b#ȴ-|Z8w6rS"gɱ/$u=٬J]*R쏦YX\ژ}ВJTEO^Nkn'UH~Y?]-V+H?<5+*ɐEɖ I+j"y X~%]y6Amo^^gHxF`^UH!5}R@AUxvV#kR%+HDᆩ(L۾ZHې_X^=Qy5\gBSV{x:zQU+^4Fa VV1a%?OiMv\u3@`%J;x\ZNu^W? KJTwBZ\Π]=s B)E;K3VR&,7S*EW׭<_!\ȥ'{12{{Nq~U;{/ˈ هI1u}.T. ]5͔H9vz/[h"/I:]H";mvX=L^hf\ .\p:V+zmLR1N9Ujp;[),x,w5!stjh\󺘹|mktI:5J;o^"-cJ5yZmߨn>$IOxLRz\G"nr$4B0$o5 !,*h2U\;"p:v17H`duu%K`Pv "sޛ] 6|g @"tQ:糙X  CgL` *n1L)& Iv%[w"֮`vrxL=1#J}fFG3oK4ǠkZyw}|mؘHhcwNE=Ԗq9aA}e#l-}DH1t{fE1SZN6_f9} dzD.HGKͰseQˢ"6f|.˨Kҕ*cWwؗV:y {) jZ\ʎ3]uMA}*`0X=xْ3k۫=ݲ+A_{:29^8l\3fffrzAW]&6*$ V>g]p_tO/*uu0V~jeʷVן!+%e NλpfSI#;TTp6p#uRaގ NbUjx @O?eHiƶܤWM<)(ِJ!|rї#U\}Bfuy#i!X}yv7ъntHtu:_Z__'_ȖfoF%o`I'sS}wJ0&[ 6m--5^?XLJiar@^ R-4,2f;Ӿ;@ʩ8,}Uڒux\n T:>Oms< m.wlrlH)biK k U{^t{jec%QAu+ f0Dտ,&K 0XR滏L߱l,8ڜbpVgWrS8T m I35UX6?*'QPByΔ;[E:W1(Tԗr]^@/ݰ6qV'tk'LYY>+ۓ$ ԕK]vccg J9 Ɋeh&W'4To㍩a}Eeq7P: 3,9Z-RUr&x348uxTk\+ife#^6Y0FVr%" ;aýqם"15KR*o#m1T(d Rtv~ȉPu1WC)͊7LLdFh.b:mwuj$".㒉ğvM(GeŔggcIޡ6o^9|H)M GCS+Ff*dUvV@Ny셼2GKEѮwl '_|"2')*W6XNWÚd1nzn CXK~)vWܸTlOH9{ g'/ۏ)ƅXӍp iNh wWxž{Ծ$bv[3zۤSݟTxE?,z&?hepD촎2ҋu%'}L> T'T98c7SQ`+ħn0vy}7'4!,} S4%=IũS} _j@{p㐋fvkpCِȠ8o[/ Ր=N0Y9;q=MJ$|.{١>5^}l G7c.ۓ}A Cjb6a9}Ssi* KToOŎJp*Vː{kG>(1[cgws7#ԷK/\XbXއZ oj֎ r6(TTT!+s\rzv<pZiRrг|P<:ewm [/`#(=/Ŗo=4cx۞z :dLdNqNqp85zSM!R-Ya\6Ƚ)KM7fA8p(3zgKk޹d̷g5">& rlZ @SZn۲=Mo/Vzcps s{wdL,g.֤G6x~-ܹ&zXav|ՒQ+{C9HD*a{VDMA#CO"-%&X6oLWWPGJf3*Tk@JpN5ϲt;_T,'J5T>|ޛԞn矇 ~#S~ۀv-ѼnۛwD6a:oU So¶D4Ts&}B+<%و1x@Pl@gF!tⶳEk5Q_4+)>#9SLyGXf$q¯ګ,h06#u5JXCf4Dtf[\G&Nsw`7;Mʫ33S!V #7P[u</-LҞuU\Aji_!6td_p:aܞmxV59/yi cLVUMx]ndk1&7A {3aOy`@`7EB\Qܓ9|5jړU)X"W4Ͱ/C9 endstream endobj 118 0 obj << /Length1 1457 /Length2 6805 /Length3 0 /Length 7795 /Filter /FlateDecode >> stream xڍvTj.%1t(-#! !H CCtJ*HJ+ҍ(H|ufxw<]vO[We WD!Ѽ>8PNCW 66} (˹L1@!N@",`߆(7q<apw ag# v80(EÝonAz(W {4E:8y^=Pw Ԅ:`#z([ 08iw SQjj OB ;Ca0 @mNp:"m~BQ7PO( j}c;q(PQFan;;W_anC9;ÑhwnpM}@Dy!mH_%x W_7 `10 {A+!\P.@ۛ[ <~[o m04n@~m7wCxo}s2 ႔ 5 e,/!~~!Q㫂E${ӥk-'߱4Q79!X ݿ?(z89rRZ3/ _=7@lMUnpo z2H;4ᮈh#0?TZ0'rGzP0t7[sy4o[Y_l~m0܌FAn@qޔE~ST!@f#b@ͳ,8y(m&U ( w+y&Me˿ 8L`8T=i>]g[3Jqk8#K|v,I6qpo/1I2Qwl 0=zȫmF^0Tr\=DI(O{Jæt ^~51{\4krˈEqM:qt91nPS}'8p/rlw"8pϓn)|?v9 )}\8DYޝKˋcW1i+ˎ)"* RlAi5ל%YU؆]iTjP$lz;tz<\hˤ4]T2+i/3[8<+Nƒl\[.~bv07obH.@~VzfX>ح5E\4Xo$a^r;͢o^OYJǞ/x(t4V ՝0PƩ?B6\4TPYyp1MmU?)S @) \)y3z2SnT lR{Vm[h '4=q$Sidc^vqK_?F f' l]>7E>!D鳹w~XՋKyI 6,My<^`HKp'i:4Pc}+~;viamdLN_fVs& )]ogMAFu* /ʌ')Y)v[Fmzfz3"jTWtL{N︽Hy_zL0k[P6DOlf Bv>9+Yhwm$][3}!GLJr?5tAδi2z#;#sܒݔʸF9ڣKX9.M6"uZig[*~h pi0 ɯmdztTIcI'pB2N{`_~ ur}^.D{I[ŋgᲬH3!q1c1CnƢ>kmi}qjSx}H*ޕ>S~ICA>))-Z'ts^ g.o/TMm^odkkQ6ﶄQr}-k:sIFNM:r0o\-pꉓƧXnh,p-d$cEc$51𥉉⺎STZCϜ|z?Z$徎{{ \aXd읟JK4ϭ*Ԩ\P&~vSf @e?O`OW> 58/!me=(G'< kb$p~P0|ۂEq|{MlC\wgMw<3`!"^ 8F.R|L<]>z;]-*%A=Vuh`a1<'ڙJWe4bуGټڇQu{féϊ^Ӿp0 ~3db^!V˂a)kXvgx5n8f8? - >iO/Ky@P8F\ʺ`08eГ~}o(p}A{xsqj "~fK^EiwGs(s m8إY:`{{Q$%aO|PHZUJPwbho,S` + Qm?JD6@Yq%G@{}7 2Z"ȴsU˔6I2mX]78( z/ϔha=K*5DR镔-)n<5GRR" Pzp]‹.'6oZ%Xi9"М!!mU d,N}1,63zXw6q{HiK;{Z^# σl/^-qb!:hDEget0Q-kg'/V:/LҨE&- 4ZgyfQX/4ÊqI\F"N{hy Uu<\cY*IwUϟl^dj ʙ#&zAg￞h-j up}rw~10_P=* }xXm$yc$YrLDRVcbnŹ|ljyןfIIfLoxt'u 6_Aj_?KmgFcOr},v#)lٛs. Utn;Ө}+fÏ4=7*ϷQs8rUyW 0^#'ש%u=S^|1=˼>ъ϶E6L m13i;vZfK'1BRwio#&~hӿIQ~-,N7AsfR;7|FFIXVDq GuweHɌL fraǞ~![018BIr7VZ+~::okpq|fHhp<44aP CSEuzd xR+`.ڰK!1 x_ em$H񾴜́umocv|Px x\LG}#T[J></ *.!Iꇸ8ʘ/~cw J2MNn7I sndYUR;+a]5\%;BMQuwHQ0)as/LA55IrFۉ!ˤr `Ɯ26k8=p{(i K@q[|Ow(ūPB8!o 0s (P.OVQљ͵ .Z&EEZsYi 5FjdX H?Y3l2}eXc \EjJ!pE蟅ªD{e6FNZ;j'ZߢVْ;/l\Ex} h찾m(mD3ɨnf$ ,vM6u(mjc7 /djY$s,K}.HR0a}eqTCo_dis-}8ݞ(V2̪7B]qOS3:8|msRjZCRP!y92'˔:.}P.e:*}Y +^uR1+8>$_Gsy Dm=73Zk̰4:i'̺|m"'(Z€L d3*#B]CS1%W?rtXٞwF:2?$Tp |jPT{Kb\F˛4}}aSo0C顯@vm W2Y5P (}@$h %83Up֢:pYzM!kM(Ƕ{R#X8ʘCWry\@gu{:j=`!t|YpwK}9bM-ih+m/#Itq(&^3sSkxfDvĕ:H]m]+5J&ٔ`[QN%0XZ*)O{XĀY|Xś^dSV VEN:|L+*so1*Dm=xgf >áV.3nwQ ,W9 <}ĩ1Qoն|l#Kѭcg:he'/y=8qY$z 2|i?PLyXt>|5*!jMs˙+MSD&9 m5sHrl{jC)h_Oӹ5 vPQ[zZTd!Y\kKƈ0X(6(pq1*պ 9**9bW{n9-%/ S:MHS?> 5"~?*aHOO㹙V"rڙ\MewnNrY ߣ/{,, qlE!ֳH( =ߝ7}l|LIS e'89l?ä8;5^܎Nrg b?|9Q ǘSl[BY]޶ &8 DU=c86N.}#|vk=SktTYH v?(Eq|ͲOOg*\Qџ3$w3[Ag<Y#6k0/tr}diR8?| umTYzoCβ"=}>/t~ua|.5vuY*i-=ѭ.KɃu|kjs>$9B8i}HZ$n &+۹7?=bN7MIbۥ[2췿}ד bH%Ic)-"9A?kVw}^ӛNQي aNVP13A)A6:J,gGsT?'\E{ *V3l\8Pd%b626p/-5rPLd|Jzaz+Eޑ}z>tR`j`KO4&fL~gfSRXD`B`'v,Tδg<*Z6SZ"]1%2 4nZQ@iNnzIoz˒'9>zP\OۼNѶ|3wAy) kyl΃6rkV8 ^`ĤB՝D81%`z.zwmbBg$6=. P{2*e:Lce> stream xڍPZ- ! wi]4H7@! Aɝ{gz>kٲ邚\EYjB\,l E5^ ; 5Z Bp<$M]ryll|6:$MErF:x:]o@gN0qك5FsS;: rt..,,P'+az&;r9,(ڃƂB а;%VZ:;9 9*@2`5 ?;j` C`;@YZÅ ` mhj }7u3ۙ=I - 0}_9;\Yv+dR =;?I랬j C:[!Kpu`Մ]Ax-x#an;9_o/l8|o,.3wg1/Үvvt=_g,˳ <_% G9/4 i@/v gLHysv|N9%@g'g=j⹻e>pG|./2:9=?)]d2? 5xoSF؝y{\hz[;{ީ1:ݪӕXЗWKRt d-w>jSۭ('' HI5D<8h5vQ9bܸx/nG/eX2C, 3)4v\<#a4G{̯o^˕]TzpأS4)rKVFS᷏'v鼶nΌh' Xpe#V[&ؗ' pf,ɭzȞ493)'xj1{ϭڝ~$QI NouguՅ90D8CZ:+o K~d'#^Ue.I!l`,ZFl`?G!_\cX' z # ,L)tjL]oW#6a0~N:J*Kkv$דܕh6`n>j:i]%95IyAG'Ut+Q:{d2"NU2;Bl(+|ݒgk&x}n(~Wӏ^#zLぇKZkoʴdU!`;K! sOn|G2n_+zySNe6;& ~\(`;*HX)~etNJ XNY\xN^I +'_3^ 䉣bBf`){eiu4oh`T'yp|Mv!\e5нmKWl^p&=E%+:u؈ @ 6QEт#qJXI0>q^틺΢$UTՀKVw9'M#B)KSp#MݞvK"!z*W&rԎf˫o_ m4|c1ҥB]!s.D5߲RkE(;'J mPYQHLbc 9FJ,vuf˷P;{'z(ecdb6poӎy=::^LT86]Fp2w~j|Ycչ4!taF9@9 Z3X;wpsJ*5q Ӆ] ,Gl"9=vP!hCH|s-_}d~-ߕظ6CN` &~7y&{0D"IJ=ynNMm#B8@`sS=ڱWDɩ4:+o>?T@pǥ>y.Ed2A@ hT%^űKŘ`hYBKGdW?ס7ASS ;谸|,CӍo2#X79TKLoC":d3[>,,O GԹ֊HR E/~oMO3dh$oCi^+bzdyö@Hdl{uNzKw+@rsֽŇ:dlw6{Zm-i[K==&Vא"l(z/d ~=-χs9):"iHnW)b[u^!j)$.cfcf9B оňnhܤC^C_*pc賬zAެl' #m,a7-tFW"QC?3X,鿭; [Fb܍uDFe}kX$ HJ93JN M:aÕQS[dQjno/"YT"U#FK-x?x6'Nxġ^εU6'Ԃ1`║%2ndvBc'.WJ[ZU#.be Pb̌0 ,ڨ 'Gt2bbvgJI8ގz$մpk/o vMO}ȳ.2t|9Ahv /=AH|KdyD&LuW?60vc? n6#eW9w#]|Hud,)=T0=0V$mg]njҫFcXBcG_mT -E]3y =aJklYj%" Xɹܾ^LmR 2Ls}Lx8vΏme4ޮž% 6IpH>(f1 +^( BޮjFiQ edhzu潪:li`tc9-tۼ\^8.AkqC,Q>7fQت0mZmvC;T!p%e2VoS `C8BF 65 u;RzEPsюhk34h^K9ޔs5Tʢc=)qE~5# `z9q+B JR%M|v'S/ONKzN֢)* H-3qvcao 6yh3>6Ҿ~)CGy,%7j^f2Q?}!9!KgӒ (el.3~|#x^ВtbՈ!2۟׉?SHW𥉉Øpq{6ĻlTvJ>I;|; Ȫ14O)> +}eS8x o0N[O~6#|~x_~/ʁH2-?`K>.Nl-=7^l#TK(3V\kL3H/-s6]_IQTɺOthr^ᣛFoP3ij^4bCL߷bc̆5}x# Afp15ѮaLCDeY,LYEc}NQP\-}} /db~ srN:ǿjJg#L8XWzDp)nR^3%~a zzn*#}wW ul=4$+ f͌T AҼ:s㖎EڄKiu#;K8Rn#Vzc!U-Bԉ>Ieaʭ-5\(Gu  7C4n/uLߣQiL.'nvہURe)Nj鱗8,@F`;lɰJظzh0kBUĭ#j-ȘL?=KlLX~.m[ $ ƦF S:B7,b +*,Ho| H jO7c~4%~>ayv&fXx1hx2]T~>'`:0GK^d9-IQ3kK CW=$VM15~4cJ.AQy7Bp5' ЃN]r>`^F/5_^L9v=|_hQb*pֻ1J~8D˽ JOpsVm+ʣPS+Qwz3-euzА%c榵pIݗҢ{HۧަV,kxONEħ~prQ"zv20Jxҭ7V)N`#znq8hRw)+CnyҨrQ"]0%4θ鞕jXĨt5ץ!+;#Ֆiͪ4)Q׫EG[N?kS2wٔ‘o5f}xzwq{a>; 9}lόC;Mp#',%,Ȫ8)[i/8V?N?^ao|T|R +ˡ͠<ќXՊhvz DR1S>6"ƛl=4{-iq̇p]VhBǁa?=_2z@/ kɦT+-,#Z(g.nZ98L)(gpxόXίy |oΧX.߳3`crOǟBU8 &Cܲ -iiUy/Jaaez7(N:(PaޖfG\;a doVk[1=Mj3}+=_Wp+4w;g|$ʷU]\Z*u3D{^9Hʟ@HfW Ck|l`T-5_|٠4|Ue8+8ơao^a  U$zv=%f̖Zbov5с#Ej%;U]>DC$|Y\+ _Dž̕2_ą3Юo#xY l6KE:)ZwEeKol[NEY`.1pVI9t+DVFnzL:XIFV zu2OKr~ pAӡ/zMaM󎲗˅# dyOp@PuMgV?}CIn0/1l|b/Ф3.?Au1g4^)#aSWm'@"2g9#)\>V9>*NA]f}@vgbD6׉QK.b'>pk;/hqޜ /QSq yhEޕK1Q/BRه@ 9۝i?na1)2THӚ ;6RA?_LǵSeK?5 Mwz38Z? r7QzRܴ^^^};c&<%D{8\aYA/_Cu;'Vě@5Y/NwQFe)TW;iT zwFl(窡c˾(+$ۧD$^Vicqȟ}&?0+z{s!@:T#<Ү]3,`"lJP9L1 Ei@nl;B}x+XvuȥZ2pz_{ we+]B|ѻ3T[%(\a53J@.Z,M/){EOeꊼm'#qǯ 2D l%&=NDjP 9yڊSJh*JQ"߹|1&jUYa|bXIGB>=eE*V`ut|^(h%)ń![l.MVOjw'!dCc8"0cB.;fjm&s7Kڅ!J\UU+M|G+BDMOo;}Juf XdGs p:s,IVLA oW4 ]܏DL|^·Ey?M(HT7~>NBiԵJ]kӭ;Ug~)M84]'mV`\cd2Ϋ& 4KCr tbyoȖ%﵉MiFCBYȯ=h5}!qQ"u\CnYF895$O?LbԹJlЦov/j׎E;jv^'#53LDy\v+VC62eS _|O koP+BiN6Bl% Ȉ&kb ~lq*qаO}mJRT^Nz}xJCajI[ z| Z3F ԥSO#F}p0&;NZ ~P!s@X篱=43! B aZQ{2R}mYmyDZbtDvW$b,tk] O $)R4 5WGYt Em i/ӷ^xzDΏ we ~xN=W<~-͸.0I=/=)[ L2U&\} .\\|FPs_kOIToırD~;_TX>`e51J=f'}Vy`&/|)<(ti+ [s+zǶS75:CQa>%Sr1_/,[$>,FLLශh/[!z#MsV 6Rcg5Yȑ+P1+3Yw!2J*,T5G6D0jv"kYTV FVbPTЏ&}wI UMK/Y GJkJ''g54Oij9Tk EjI}XAD&ǸXyA!%+ʨttl%JA z/)YzpV$[dG˹S, $lV䇞Ȝ/eUJ(zyA;&jxL eС`iɝ[ϳ) 6Ch(%Jw߻ i9ډdRlG׵P(}gH7곥mD>iMAfE\ &d~hT1?=J^ǎcI*JL6K;$yU'>6<~6NĽ}ʳIs8Op ~\B5H~PCGb`ӕ)eP'pfʱ6m$,asα%=<1;~| Qy .{oX_۴~h. 'Itq=0^I?y^y,[uT^B5NF~Ig֫S7y*;^t']kfCy{R`֋>qǡ|}k^ttJޘ̙$mlW91إpºݤ`g|DNBG^YO_#jxUQq?|:5ׅ1}~J~Gw$qS|=;,`OquCus` Y.R7̈́ t7ٓxqWSnL?'tqեm4CI4Dk؈b̍-1p?}vIKFa v5L[1s>?>y{M=3}iﺼa+M&lu]aGjPS~qdžk|2!)ͤ8;kPr.#!<.z"47 +MU'aC4qK`oH>(ea-7Ǿ殖D9~{7Dy`e@I=ǝԤ ˠV˫K\b;v͹qFM`qh\k>|ws.?);]m8KiiOW`#`q^/Rr1^/MC$q:7us4] As[W?A}PPT ` r v;pqiR*?2vM6y|GXN͐'iAn 8YeJeFbQdNLPa'~٫N1?2l .0mj`lxpV`Q.WBR +zj k앀.T:6Ȅ0JFTi0fGgI1a|0C( "#tmU*c{uߥ'wGgIv&;į~DDQ7 4!O&7}nN_ c#糑Q)al]Oq"Z݂d0ȣM vńq&G@sz{'Nbi4WV_QS)eT U-V8jyim?y-A-, ,ҘUXƯzm+J+G 6GX_T-Q1=*pg!$2x(bhf?0>V띸ޥ1Nꎺ|n؄kZMB_b.y /|KHN e*rwg= @`îgn&(kG _{}v0ʘTg$x X(ct%:pjL*A|_M4Ps19$L oP#!2䗖 = 3/{gТNwU(t) ؆u&{*VԠXg?`- "Ѥgq`!F-;x&d|PӰԷU_adDZρj%v9 |&&ahj. $On`J3v?V endstream endobj 122 0 obj << /Length1 2399 /Length2 15118 /Length3 0 /Length 16526 /Filter /FlateDecode >> stream xڍeT\SCpww58ACp'5=8]}_5Usٞ9*2u&Q '3;3+?@\Q]ACʎ@EanA89FhILr67??++ￆN SO "3@@%jce:?t6>>D6榎ESwkDsS{ B~vwwgab6upcvrcxٸ[Ԁn@WO௴JcFhX۸[de 6@G7:.Pv:Xwx_ΦNΦ>6VK{ @YJ۝`h񗡩 d/)QU)(dfjfcW,ZB? W9>,q+ gMG@"?2+;X mn!>)svrXRXA_~n@0Ell swOtho Wo>+h}e3 'G{?j4:Is198l<n>n@R1:Z:Tr gOK 4@y7`b5a=rI_5Y:4uPt-5{6W+n Z QG+h31sr[l&e Pq7ט[8UljLlG5s;uUS%͝,9v.n+hع~lzk,̎N (+_%7HxX,REbA?X #^ *(߈t r?V?-9{LVș@̝A/?Zb7Ѳp7u&P.*]KK3@&V"V=4q >@Xd6"7(mT;?tAY;rv5(?jP0gs6w,ΠO[8AqÖT 'w?blzqQt:DpeG@A@gRw7uG`?|A#+P @P+<A̼ o@Px?l@@TJ[_Or hd.nEЋioc[݃!|_ Ϯ7#_BeZNR<2P2ˎO3B&?%AJ<^#q! {]*! H' CeBZx:>se@U~#Qr_[gi[Oc`/|C )xiF[;ɺG^cYl! c%@ JAWUXGg ;eCg/ HY^!'e2牾<'#s20f̎PA}RY$K%;eu$!vn'ŝbd܌2}a8XCN Ȉ ,7g"o_Bt0M3v(()aꝾCT2o}Pﲯf'iJq!Rt9s0TR0Mpzg1՜+ at x@^{8O7Pyf , >kNX&a2<}B 3?M xT=EN 2J 34,&ϱ?ٗo̡fҞ0&2h=4>>~1^xn,[19qb/1s*q|3ae` %}٢918QX,emZy*(uNh4X ~3S3[w@ۛÉvCFR=F}9 co Ӄ뢛܊Y U3u &h/ Ez0_OFIP\&/ J97٦(m Ʈ]NIMhvûJ⿱=wDʿhy3 gbgigp<3f}ESd*,bz<#Ƨ@fCF!7):g$0/@bѳM?zәmC.[m+oz:[ߪ>GǻQd X8[ǡOYr|AƼilj`Mc? %S1u\.ÃpaW LnK7=-LlBv1YI5 %B 50KxIETQ4[Hò(GŃOB,`j_+Ե^: -Qq9> =ű0nlN|b0է9^zj`uC?w%NQ ]ؗ㋞)6fn+EJ2 'JcrbԚLˆAeuXcñ8*]ϰ,QY2V'}+X5tU= rܢ* #sn4 x(OŲ"PF3]- =n/a o5|i'g楢}|3RuXq  4fu5oz|qe"0pV9LR1ƻDD3}ļRV[~3Aj;!O菋PJVŷ3%9ҹq0V됋3}b6 /̍]e‡ ^2Gy<7TCb̙} mPԘ=? Ph^.)GO!+(JfgHth/gOϡw;Sa1+2}i~U{@gĂ5Dkui` pD"nq"glf'xD_lj(lfɉbn*ޡsr>:*)STc'}0|̋-§-;ڳ/߳^iꊧ5c,B4#n 2+(Vc?Y=S3y?HތM"|n+/ a-_nzj;W#$i:^\M Uk<3b|6ykWY;:18_5Twg]L^O%ݰ (ޑ+8".Pxh5m H 1ytfȻ;Ee}I"}G݉#,]y_RĆT؞qz3_fk#]i4SCCX1 C1DuFFE<1oIS8}k#cү;owG8`ɐ]+wU*BN9I b"YlW82l?.+#fB Xp hs@dZ"?\X JWgqƤMr X\ u2n* %Z~1sKvqi2m@eئ]DT^Nf!5sț};qG,"0ud*UT]>qf9tP-#g2 | ]I92wB0`Dp&_ G!V3~誖!J;!a p~&I\DfgNos@~g܏+N}U5jV7& ?&/ytd쐼i*PD8l|NfQ$7>=t޴)7a^P< £!Բ;~Ts +GoRR\ 1)#nNyEb6Ul~RضX=eҺC/Mqev"O o}F_ttڠ |Ɓ'%PgZVWBPzC݈hweQzwώ0'Jگק?Z>(mt+яp`Kcd~}?X Q 'r^C5w ([bba9VyU>ճp쳘g^Y.,~ń0:v'J6l fBR"hP%b"ha*C+)k^vHث2Ȣ%]U %!>uw%[htVOn'q9^:zZϔ:fګN6 ^J-soUC-F؁O; /V˃#.0N8BA B "gLc#'FV@ bub= ΀AKHo_LrmTaj[(HPȶx:LuB0RTp[۴4T|=]eP}j48'<ѵq.a,}'3ֶҳѽb] w&s/;L P&zw!:M7NTtKhz4pZOk˪FؼTQzvg1>gԬ[萀/J}k|\eʝ&q=(쀡Bd$\lՎ'b@ LcF=V ƭG&Sm!}CAix㦐רw,qܤ-mjDr4/5saٷ  IQZbQGxyO03,S_y$;¸'7|[Yn[r{`& X28wD J;U_2ڐGcM wdeP^0L4bo,l Or5r(^bҲ*ᔥ #71*WUEDT@ zdoTQ?MD[c#O(_KKޡQ3"/&@s[>,{#&j0t 'n {XL,%/ܤ%'T=m(hy^|LȦ|] <1`yGE 7^U_P\4xyv߃HQ,:`4o+qzmr^-PԴ9i_݇k# vV#*&,Pk5 2]C1zt?Ne0zu?< 'x(f};%? D-}Q&junNo 2HG{Y,$p lK]u/~zAkhNo}Ux"< Y-NpO]n#6EC"I^L=u`-،:0{K-2qG3OJ3HU$B/THUdgF9ߛ3'b7Y7ޡ-0&d [Hga'aT& oy>nD O@,<[+,-܊z燢rD+p3j9t ÐT]mttAͅ0#6/w_h_3t[bCdZ)pmA|4de߂ߖQ(J{ba5'}1l ZU$oUD|#[q&s>gkƒs9P,ьB=h_͐^,$ dTtalF.$Nas.aL%sMiDEl|'L εЯ~;cLZ/ Mb38csN|Czv\bϪ(&[ep3Tbn{_NͯWzCA>F!{%XB}RjkʻX4f&{/=ro q>m7 V}s4o ؟]KEكޮ `zv6mNhY^bՂ$B֞ 8[q@!PF^)(`J}A@fP^nxfV$%6>d{]99a3yI)nQyTŌy{,fhWA*:?x|o"Vkd A^F mdnM~⏐MAh80|cWuw [s柒vvIRP0'Uob)PR MJ鶫]+2V%Pezf:f!kq}{ [GMؕX+=´ZBlI5)&3EQ<Ѿ1WAkNp:0=%JMhaO0qոpU̐k+*}>ex[*C5n տ.oYh>o{pZʹt vk[0So SA_[0@͈љһfqڡyA8eŅ#4QیXOjMRw笨(v[;8qiLUF'mK=%c}Lǽb߻1Uk9+vSI4f&r<7H pEۨL7B^v iyu.X㽦XLAbHEz7FwjUkh_EVh"ĈD_:v&}-RiHwR{F!ak)*z0b_;!($50ކwmj7R\oo8G⩆Y~8n =p ndjC*4G%x7`̺yOOdevmFS EwUDsU3Ǵl07ɐrhak]J#k l7 t)7ƭ$ }̸L4ڃ(2;¶q>/.`'XJDql7~*-Ƒ[vLv9°ș;f=+0?25@^ٳ jM`G1P!d2B8ۓnpWs0A<8EO\N w]#$J· :Ҝ輭*kmo|mpoE"V(U.RH bs@E*jM/*o1Qab4CMCS;\IC+MLҐ&O ٥i;BqHnx~nuh?,Ya~rrdHڬc>®NJ (=(*b2+ES8Î#;hR!6pxfeggȈcuvoyhۻe^ zSl]{xoI!_ofwwyT,t~N.ɎbpF~wRZ~ɔvkaj(aTOe/=bz4}ok a$Ym$<9M$-&WYݹS+Z.^Hw1Np22܂xu$&xR>&$1Mʦ0-yqy@s=+u ժIЩ ,^9-538VU :-Y~prƣْiaQNvqCŇ_5Xe,:7Qi?H\[8c[ SC!Ɗa:a2 E P#0ɂLoAࢩ:y6~/ʼ/|fQrQ2#1bW>)AҴg=ĴRpk`"]OF`.ܴ65_N?B|%ؑO '/>6o!}"1"c"p g <)JO u'gLᲹ6fC]d1&-Gc,Z^2jVJo92b"'(I3vMi,>}ߴပKF!q%u+S/0ڈ4 K`F'D³֕<3b)"qkQc z ohypF"u[rӼAŬ~lUuO dA1_d@[q؞s# mWqMvG.ج`=~-1&:}0G 5JKJU3T; &HχT&̼bA#!T8p￭vN1.cRl> *xڵ|my/<>{;]mcB;=A&ҁoܷkuXR ˢIjo7vɳ2wKmxh C$N]j`udb s@ܒQu@/0zE]^SL(mW %xԯZR 'K8+fge׸?跍v? gցd})[B~>0y;#s+&E{˘]妎i`izl>wU"#ќPGGް/Dn^K:n@";"q>L-`)DLȓΙ9e - w&fuCiPaz0ɕ τ<ǒ9'( >GTOOq?uaS Uk(,zH4dz.cquI&]07Ұ(@y}s(/+LD Is ?;9AELZbTȟ8W hyd+Ǥ#ߠd (BPݤK9/7}O;ڞ] ]RԒԏ#Է"IbE:3k5߆ 8#k4O;>֯o5.M{Z#'%XR*^*VrU@!6RTȷ;>.,ыG aSp SKa& y2_DQ]q.Yg? ƆD㳪bW(͟#QO R#wf&zr/?TTlG$ԏk 9S\y o=6ؾ7qcka^yPoJ<R* #̟wxBȷʨ:(qMU|[ثя > X8O78h{h*,[ZW=)womwA^3"J.84`WK@,'?R>@}U9:7f?ngN--GOĐFTdqylih.jv_+T%HOJ0-ە:I&Cu|4bG|m3")o/$#)aHJ'pAMm`IyPlZ.~ZOjq Ԇo `9nv SSh7Ɲ \K i/1~/9~i#\<6!a6mLy,U(URAWsWwkXi0̃6 (F3mUh./ćYnVsjD؜~ӗp7'l/ *3};?J.fҊzxsdyJJ,^.|tS!{dدX#^E1X`/GӦ,#e ,8-)>V׬X[|lbe/_?2?-pOQ^W\~JEhyJ'G}YB^~CYG }k5q%]g[W1-DzN3´{uLM7o)s~HQGxl R܎i+2Oxr<J^~_YKLᠾjLSM}[I@}y'CRs*֮nM`9z| d1996g$]1a9QɄ+=cp}& Ԩ@a祓W%e];m^5R~17g ňe%B=݇`zh\M ,ݳoH757'Xu})Ĝq0**|~d'>W D%M9[֏|w|]{MrEa8֯(4؁ƍy4};{]D7}38sz˻9}^ {aZpČ.Y"IK.xp0"nt0U_Z ׎a30܊ r! ܱ Xwh#lb1l)kdE*>:6s?FxPqZe9wFHI?(eɆw8kOCXan>Ks*V,ƿI' l+OcqMp%Ǒ<J˭jYJ}M@oYeV-?Wh&bcF\A@MMGK1bE@] q7!HFRJ F#je_ATZF7O@صӉ>qL>@Aɐ]]qhY~CA׀`TxZsVYa&*^gT-``{eptB5~fWp>.^E]S!>qj$-߰j vhCsu,f2\+z(ǔ?=~ggvd6p4ekV/|&4EӕI{y$ ;I*k)qf󣚗 #%+5FG6:!3x圹Eb }Za*8'Y_2XuG?}.jjNuB-$% >n0Dw>݂ 㐐; D0^#IO rbh]("pg#!5?l~[9ٹdz! jQkXC䛩'(֓+r p>@= a qC*]J04/ f!kDzՃ{,lʜ "SrIЏh^ lup3p ּe,Q4o`ŸY_Ҙ٠# `rp*pyL4"n읫t3t 6mtN&݀սqcP-{3g4H܂4>cpShd VViAU$vEw?^\A*?ek mdq4\8q975*n5?>)jрx"LpW}tRF}Wtۘ5XภMOvlrnSwldiAyTYql[PN@V~K+7\Iۈ~g;zI>xb*vchp %U>O<̒RȞW)^5M↯*L[sH.:E6?ZVhm4.|p{pHG\ˋl1iL]or,vbh~f-P2U5Zrg8ӈzpR~287EG!5*-|ȷ;jBO?E?HiiNEQsY͗xwOSWm%CQq7yY9# N^mYnLLޥJ˴\'F+"D{BH1+ W3i/g_1wl2*RIkua+mϢ<{5= г6>ߖn{w(U'xսSyHK':LvJBB3اc;Yx؆5~1锉dmz0UlTfk-35BeA\m\a(эPՄIro9!aL>%ꐓv!G,3jS&twBし9kk_89Bޱ?ĒZZ<|`̃P/:o!b0Ogh,O1<7_/v"6 $M~VHB*&,/^hN[AS 1f]\lcn7XR!`8}"uFaMLDށ0 ]^{.[dZơ>W(4m),w7Gsej" endstream endobj 124 0 obj << /Length1 1492 /Length2 7074 /Length3 0 /Length 8069 /Filter /FlateDecode >> stream xڍTk6H H7C7%HJt 03%! R%)H7 Hwz<{k}ߚfaU┴C0' (V@ /ȃȨ ECc2@]p?0'FU0= E@(7,A-*\E8 ( wtZ b rNH:@`@8ܯhh-J "\`.8+hB\ nK/U5.LF 寀 vP >f qܯRP9B`plO?ٿ AapG0 XA!59e.Y]`70l~: '3pr6,W2Pg{r9\;eYZaur(ܻ0볆 @ P 8 6ܿt~9z;V4 P+ @8B| ,9 o{7/C@f {)I)pA~a˨G mc?`3R `΍@/W#9W{q8jq/\WGP]_:oTI6"XC6/_fA._w O~,{QAK,ƌ_vv{bϣ%㷌\08>pO`wu‚n/oWܖ0AnL~q~7&Sm\=ۿߗ[V7]KRs -4w#mS9IY $ONP] {,&g!dKp]YC-#I4p Q u'o^ (]ϻmva p&R"%3#iVFx1Άɮ /Fn#1RMQ䗞 cRzӻx)u y)f!'KWuAb?.@G58Hr{B!ŶNMr]\9.{!"PcY+М'"jgU9h5#.m+VErb -jKM 4D!\jҠ3,+cT &yTgp!{K+fay )LQPdвj=;aoi[9ﬡ'Y0;7Mֶ<,6u^:I&2BDAzu?췭>7Z+ +,RbXBm{zmf~vx;g49,pBq?% lNڎȽLftԙfۯl3JGbGdkrwNfo3]0XW&QjƠaUv[iWe=ozD <H?'Ǵ3/De.qڔo?aD&Σh1&9hH*; UfYJȤ xnԜ8cƗ$Q)*l[&hS0≟jSƐ"GTe>I81Pc*z?L*dgxJFǥIjS֙y5nҡ1Łgb񮼚D[~S1BQn~=cb.%kJ@_xf[_YmAmMRfy4jz=9w7D&OQ !_J#}: PqcR<"ȅ;S}/=A<@6bP}Z"!VZq[{O j߇W;cSq ȯf6zS: UnHM#![H@|vSRV*.jW,HjdxCdiQS;G)1 ecvNSMסz l .vO fDO~bKt~M FX~Hq~,#Ri؝K&Q3jH+b<*,,9ӲlcԀ]m! $/2l45&' ["ðI!ck:9kӊAERP{@ԝ8M7~ԋ'DN-ҞPS̼2+T OfO.CI}iQV+Ȟm;aSiX^-=h#ً9Ѱ6T 6i$!&\G~[1Xq|6cSnʔ@ꓢl1}qd Q*NqH M qvWjIqeG|idԄ. &zع/FJg`,TRGk屐þuv8_8P0zh?`diDn^4XJJo0tUMGN>n]/Lr;q(u9ZJ|U Ɠ,}d?sՋoT`&&| ^l.1OAwä{goEV&9C:,9$q ~ -r$WOk~rUugC9}&#,9,;<ȝ)U?|w)E0߉Ͼ'7ws^Px/aS2n*cx„^+$3m0w|]_shP&~&2Y]Ul(YY | $Ui?R /qyH;_;۠;e2+@3D>VGs/o)f֐gUz/#Io\S.1gi'B"d z 7syeۗVw-Ks57w.ݾixEj(@.lRE&3LUO +O#.i\OȰ| qjm?? >BdiKҚ4,Tiy>@=i_zfucdqΰdRj':;F6^>*3B O4~(6E;ǵC%.ψ9:|L1XՑjnmAש47"yBY7t=7ph[0Y1'TiˋvkH4P  ^?c o ϯ{F"4yٻzveF_@2@jˡ!>,zkEz*(L3:Blj#;N$ )J#tCM['f%W0q:؃: EIqS21{9v:)q_x1VVkLgbtN>cD*?G~Ph'($' ~ֱNg ܑ9f}2yۓ+ī5' Q=~KwOscԋ`"b B~ f#'uAR0p5Dk~6^/ͭͅD?Ġls}NCaE!|/ f\(5ct qfh㎤3Eg Ȁ8bD&sxxolvs_!0%92d"$k7V[PrH>jfKˆhk>_[C͋i>5 |?BEAq.2w-ߨF ׀Zl(c!R#үx:o(s\]_zK'FiqAa᪹]YV5Y3&UM>3vAJCPܹQix{A .L]wGFT"ґXq:r^C3@=YfxV¡#CW,aGu$*nh:kHvHzERD|.9n #^O V7~ٳM@M5KƐ+O(C+"9O 3Di?eퟄO@.ͭx_\Hz*SX4>>azPW*V!"<})F/Yny93-Puf $WvoWpy֙bMPp-F2m;kV~=i@jD>z*\zus-a#g6(^w6ml WO5X"J Ư1 M(<*KȐf09(8Qƶ"*K!Eiq`G>O`Z2 )mNyp,~%97ﺥM v7|'EDaGuEa%Yd4474TvG$7G\s4ʇoaApq~)rչL6%=0ϗwDҶN6l5U,.opfie0_%dmܬO_?2) r*NzR'.ptg>ՄdDNS/:&S!Q[:J$M~ gyQXD0uN ։"pms!(nA1T )0jTsB]ucO yfeEQ%L}T )2p4YfOڰZ2֕U{"B).:WP⸹eͱ%*9 YL2 >hԺ3.|b6>qe2|N@o3ή8bъN.CK;^vf|Jm!`bbQEP9D>Aˌ* k' LE&DRI`/G>Ԍ"3Z:oYVrW/f~uנkoה Ю6N5sUYJe<"bh_(SdElAwryܟuܻde"ne15'JY[5+KVܨx[]3T۝kq`S3~]֤h\(^L2ĝ[-DטBes9"kDTpXU  ab'˳տ%iu*\5)sn@|7$"eoPۇz. 7C8,:-U= 肪鮽7HF9|ZqGn>gr|iz0 {H@̽gUrwjB< YR>q[n7>mz Q>yHnk֐5?'4ߨ̣&rqG:'F&w~l|'nRW C9ʭ> jS'9EE/;=t~~R{o3+[\Caj fStwJ(5Ki}CruZ%#!S@֚+N2ʍKe>fl/Af)?ʌ 1ly5Xw3\XV^[@9oCstӺ34k/؜_DYZQbtvDz`Q<<41Q׿P,M~sko zJ)ʆ0~V${#2.i<[tXQGHz.bu ̷3{S'7u 6+zFE fL/FNxQ/?'fȽ6=wڙJj$0i.] O9)?l7^ n``6l1=>t ۄ"N'Y)C6eCF Ӹ0xmoF>4t'9SƏ&t訔ZzDW7-^_3_~ wzW>z3&h1&XG>o8t#0> stream xڍTuXTݷ$tCG$fpEKZi[@B)I鐋~~q<眵ֻ^k݌4u80y$… ʨHA@02]aD03 qB\njHP  D e!np+'P9e(JY@t B@5-vE(a.*"j( qpDlYفp[6rY T8Ե;AZCP0!o\V0v}*P;"!O8h 5U9]<\؁/ yq!CRZ@N E]9UvV2H?Y8 yOǶ#bȥ;”dDݺl`.@>$œ0-ׯEt=a_9|@Q`pk q]P0_ @+8h #TuìoY{M@$AnyfD{}\ZjlwXZ9@@0HH( &g'FhvjO&)Vk#o CxSzi;b*wO,AsaW[=!oUoK#;Uפּ;=`VpïKrpL u9 nu}v{82wv+/)"~鍛A ۃ[aZ<~sʼn@ܦoZ#Q_*$r~ue&rY#]Q濚P"Mێ0 DBEj^KQs brs uXʜQ)˛۵K;eO^}CW{A'aCg;ys9~- YVՅIAzOʦKK;+y&ׯ2UP _vyo٣w9g!&h%4!S$C/CM8/4[\ Mp"kU ;u"M] \,0_1 StZ´1~g% V`gRSqUiS0>EG5'.T%ݙPxfm"T)H\k%HX{e'ƽ03]o3gH2dUʧ6ixBߝj?8\'g 踉7`S} $~=wg=ܺ\Ž X;bQCy*/F27HxqqVO=B;OQh޼~G,шRƉ齯.8/X|P<4>]ai 1SˠȆA_*8sN+G+ſ* m4˫PDa ƾΑثK9K TdKl7ZB^*ų2 \3oh˓|"Ku;yb#UiQYw5ef9i mdD(8.~g?so3rYY^f3H&AR%ͳo#"(neGKU qn.nkZfsE6tklیbN<=|P'}gi<-0 iOFb73]I[/a#b4jJqmkT鷉1q$wZUH-SN5S<;hBuSaEhy|^ JI]p˜dCs0oo|I4$3ЦNڻi4gkMAyԗ1/]Y%L G?",Bܨ * 8ol>qNQ>$Ѽ']MQ<&cU4&.bTWUT9|1}i^WѱUn>!~W Or'qŰA'kAWp&#t|w~Bn%531Y1F-B[gDL`.u5F;7*~a.É\"sfAՇ|Mܚex!6!p-kF].+ ]S;jB=3ӵ)㪣C$v$jkNY6p;GϤ 6 1EU? IrD Kiڱ1G+{BF/f92Sjcp4-#esczZ==E_hӓ^::{--D&-#iL  i' 4/CU@Wq_6XDq "K}-k<%*Ws͡YLjM8${xYqUDsͮe<QSG8z8s|}1oqyͨ.u|cȓNJic,a2Z:1 *_˱PZ7i8_UK,-N IUͨ>KC72RSj4IV֎vpBBIHԞ>UC\uۓCS H0]%% :cP"Oz.@Zij{?w&O>kK=!ZUڿ./~{Ku$'+ӵX+.yiCX˛Ň$$KS\]FJ? } SQ4:bYgpU~67,% &](EXzN CyL Bp] #vaN\1Lt+Xݩfi R s7 "^̽1\xFe$c4mR ۄKy{ QA:n&Ӊݖiopk[1/-5RC}F×\vd>!*E*j*~3SQv J>ӕ/kE ?ZʺyvF6᷅D·o*y@ ?d ,]N 2y/kxr +t{ۻK_NkfaZcߐ 2pޱ k4&JRڤ -O+ V;T Կ&"v78"N>R5]hsZ{r*1.봯遲' 9yfʟMDgfMS^_<UQr0Ж?n zzkq/%c`yamM^AYHZ}-hzM9Rql^˛= c^ŕM k*j"Y OuW.oI$KKL#t'[?Y"xdNƔMDyT%[0)hCj?\ߞ'ә`S:vqe Sd_ 3&Yɫ! RGk~Wݸ9LW\pD,8Y{zZNN~É -q8Gсģ5q|bs{8KXS#,m}\ob7~[|p;{5lNG+ř\C>CH谫  Y~W[wWSr*tmjzS^Z^uyŤqӮ|Ҍu})oĬU ۑ먪k Y엶O?6\J>QFln`6Xz 4;i=ySsSL\P@`s%۾G4N #>3?ďפ [kf4fS츎`KɂWՑz1=J@mVԓYDG-#9ӟ1^,j_ : 3@Ax Ҿ\+Zd_< +_yZ"ۏ ܛ/ ^һMG51on9{,ȭqDV=Jp..fG|^" W04yAo})71gtаi&VO۵}J12;E9I%P??[a,0LUcͪeC֟[)-ҪN^("Cy E.9z"%[θNlVo`T` mT9]6D .aBAvsr9䯼T4?Beh^Q%Ro6^b;$ifDɇo Ln6͛Suܸ;^5Q؞aTL;_Sbh] &8 YmOfgA)|'Q_4ii'7YV }Hv Pi܉z5iv}i|6O"LyJ:J Ǧ.vW8 'ө^9nk|1KIbMttBunapX>d?<ᴻtVpK!:%1GuŦmkZA:["Q@bj7㣣yY20x O 7[:Ǘs\4J.*CUe0=wp2 C#1uU6"ׇ.;72&#:zQ8fb?X$0wڿC\2e, O~ZTp6}T|PNpy+է]ҳUBދϙS#8Xkurp19h.vW`J9!|-4!λTg~tU GZu A%{KR[hMB, J]N)7rp0l޴N^fs?0MƠtMgqzxJaL)ٙ'ނ [~PGN[Q W\{wM}D C$6dn)D(yYҠ@7ͦ>n endstream endobj 128 0 obj << /Length1 1427 /Length2 6290 /Length3 0 /Length 7269 /Filter /FlateDecode >> stream xڍxT۶5"Ҥ@@zｃ4CH $*7AP:HJ) {_x|{sdYϐOi QA"|@  BllF047NfqE`(B@h BcH@ JI! Po"UrHEȦtr;1y~pbWhgLF00Da?BpJ9. g?^C; (;e5~B6  E{\! ! aq` յ._d?W?޿A`0!PUG{y /"BbA d!.P0vQ(W`Yatv (_)\!`̾{ 9\' CAa"`=q+` c4@(.**"<@<y@~Ø|\.(  |@ v00` !C1 X1dQ7 +ki_F'OH'.  D~?|P$@r1w4g@(-"@0M,.? +Rq9"?v3 Q3H, j kt!v07AiGc'/RyB`h_ 75opD~0/ l!;anFM 325lB"+ȋs֘G3vb#h ӣt%uB@ so:n"~[Q 3%); g`7!Ut|køK="h/|2U'(<77S6>Kǽ>i.;p!U-ܳpȗ=Ik?*B~@ǂ#t2TSxv#39#Ӿ̜u =`nI{"Hx ,L5׊El{{҄5*E+(hzk0 &P&dk4DNKRYh n>[1ے'Vgx[P[ RdZ:sf5Hު4VJ;ӁJaxn#}$\ {>iؽ1 BV)}_^*]sR) Z6 =:̎Kny쁕1%!N6߷t"Y('2wEN?p+5?";lr& rspZU%ɉόę4J!0$#p/ax=W.:B:Q:a %8oYۺ [k?rx\á~߉T0<^U6(~j m L&<2cCۣXc]m)ju8},!8fϽ ֓F|!hw"A3.֛u:.?J((r̄ ThE+{x4V$4re5w,X5F\vh,Ry]O3]^Ȏ;VO蔂p#,5M )j] 5ݮh*A R{NhumA^01d*'e4Mb`O^I3"6p|ͨcbԏ'Nxn(,wN!ywj` kuRURXfo&ظ̀=i*15M~){blߕo@k*)=q^ML;+%kLƮ kݛsve;k$?[}Oɤ7ػn2S@HC2)gÛG5Mt* ߐW?׳.ͤ(SWv {g50Sh hC+[vōZ5alb͓P K#rp=aH[fGv)Ʌ{:D̝# oE4INpJZChsK0FJJ"%1t'|̚\ӉjOFƲBCkaʦk9+0äj`t䦍ş༟ם?dp?i1nj{v029il v|dEڀjb y'l͕l">^*ߟY l3dɓLt2$9U&wGgWdUPX DN<τܸ*F\+_|JuJPKsXMt^Q̭wJ2N6exlyt2ф6E[C5z{.gΚ\EZI+ޓ`sᖂܬ6CWjwLp8NGNKІHd?WQPpv9֙STIr[4㜛a#b_^:`En}wK5SVy=Msgs4U.cwr8Ûٛڽ;*Nv37/ az[:,~Dx9Vuyoy|78WL.Fł4tw\smp> 3rvJ;TS?=(ķ)Rc>K@=(G}K5hfW޵#jWyXF|PHHI\!i.㹚 ~q%f 0sX[e" s'xaooGOG/̘:%'EC4 3o3o{jY3P\F?mNIUdKuRt4~K= upYyz!5f޶ 8' Vf26JT =XKd3-Ǩ|:? +Gz4=?Ǹds ZSOGE<ܩ&2|z3]8h؊.?K 0zU=xxDl/~ปïa j; E9~/ǧCKU_3,1=loyLx4c6Snɏ3y?"+`]\*UˊU/Nڍ _O܄sWI|kߐk͔^bbPv'%y|([\cs]Uہf&޳kZɻ2FI4v`W(:]0J]$d:nD/rWgt&L^&*SkcZ7!|o;i_2!r oSDui3d[*ttMTARs6? ȁD/duh_#Y+WUp[~_hYrC)롸r~3U43+Y@s[6"g*5+dlfYj{fpi:(Wc>N䊞ޢ";_ZPt{̥ )k=PLi]e8#\U$}`[)?nwfNg6.vu紜/e̘;@ȍHLL(m?z*ᖔy1(oS[zC$nE}N_o|?T%|\:8T[$SXn:z@FOcG9rG,R9?+҆-:ۉɉN%%!ژwQI֢c*w4xCi \EzF$R1FIOU\Oɓ'v v(?w֌a t>Z RdMu,-E7t$/["LÕ38 =iKYZ?ϹRmΧU1[ȎZl:n(O>;P^<@jd`}#}Klm;9a0p)m*}mVA˥[.m4UwrUi:"(tʞ*ٲej N)u S&y>WgEVAmmfº'gk:XZP5Fzn> TѪsg<|+J򌟥U|3>ci )k0oQ8SNavttZNxpG/xrc]~ _M%s5[>F>kL^*RՔfLhe]Ӛ-Hu*Ξj9<թhQَP?4^lHM&G_x,8z.iޜeq4tt~O]{侴q9oꓭ= ,1.D껄)]rwP[f˒B "(%es^Eo7vo[N7}(R6*5@-%]ƽhx5qN޵:QSry|l&^+{'8O/] &>uSԴ0w<(ŲU#y0%ӽmDQc*. 'M dٸNW^'Rjc)ǥg~g9A|r򊷗 bQ5ƨ%^kIxFъ"Ƹd"CqiUquQOS>C!U6)eqћ:v$d2Dh9R(yŪuVq3XE;7=,c,e;3s0\k& Vsrs1YnG=R wI QϣGzfcO$tKwp+ vCdmXT%k ~) ?>qJ}5H@̻퉪d7 m;ZlχS{ypvU4y%rشԃхu3aSM+]G&*@# ~`}q\Q$83݃K{!CJB-v,!I2aqH{3UY쁧q Q,iƴ1e!^Qhw) 7;*G^6wٱ$xf5!q"jFCIQ]84^ Zh1it'ZP5{9A߲nD%} w"B5ƅA绶OnXdy{&N@睦D wsK28XH[dt/.5>OꡔX 3\I|><6mKaut3_Jfy֗SqMe45UN_w֒zg?PKXn2jbX ϲ=CߴEշܺ?ǎ2sO33q;bweԞ?A /Dd^Ee,[P:׊S-$hOWj"@O?8~! r@k2"F[':87mK[FrHhNYN{C͕Ďӷ]7w'4L&TDV3{uYϤE4:L*zFQs Vc[FL*0~J;>&n>NS"!5>=Љ кeYNOlK%L2yVܨ._qk+e\]N\qRk&_%-1vỵ:;Q{ư9ˆ[Ou ̂֙ Ts |/L_5_}_r\?`+dvݚo?r?\<]9gk8 +fhH6z/=֨`AL:t$&"Xl+\L̗QI ]Su`lE> stream xڍP !`@w K sr}UU{zzU0h꼒[.W\5]%n./.A]!d-/j`- Z %@0@dP(]4;>,n!.H9A֖.5K=eGkK'O fQ{(Uˋvgaxm  Q2@wih ]{/e@@;ew*@W_쀿t#Ŗ`gWKhȫr@K?- 'K?[䥴/] p@@NGcs;;]?ɂ܁/:\C ?ʰpsydy1cB\\\<mm>?_jsl_l/ @o77d X@.hd1mwyp7돟~t ?SGPF딖{^^sy_>7%oZb %#`{@XKҹ@?nes_"y'?-AN>Gte /C JP˗ir{W|\|Ay7Fk1oN &yY|/Cf@^ZOew_9k/twA{qL fpr/K/5lh\?S_$rN SziC<NCKB/YNHih/N/gi/|QHh8|/Gbjw__"_|Izy8e)—}!—Ӄ _dx _dx _dx m9R]s R_gv>n<7;q9}&ZlhGb;ztu[hf!fws6s_An,#2 /ܻ̎*ZN%zșدJ۴aKe찠4LWԽn2 4v},sEV :,3ų(%mŁ xX TVL?DXdKD.&3u+ɣ.OZ;8o IʚN+do9瞴F b ɎBvw2_ `+3`G: /?Qs3q~Nj<=&豹q 4W;]kJj s$n)<zֶ)GʘT:a4}e꿜N?nQ >@P{zHv:5Hy~OW;b^0ef^"C@wɺDNW]Yo%}bw'tZq0{(<0ge%cxuu0?*.~ҍ rXM/" jTh>,=~;CBOt, `f^ڹw@W ˘~lГ$Piѥ IOϒ?_ Zb?z&vҥCQD0q=f:ڬ}eUѽ(8Eع.t}yz# Rܚݓʼnn_ub.[s-< H+ƜL5/0^65 ޓni;lX o (Ԅ MIPX.?c+K1J:DOQoOpÕf۝ (5`XOp7`%P"ZgZWB-5iܚ"vP_Yf#c5Nk\V5b1&ZK+x|PZmi?n:]/D"v裿݋9ueS:iZToT"~Z)o,nB؎\.`]V7@Y{&\@Lml"P\ʗ|&~h `w:Kl禿:<*>.~{3" ތ","Pu8,l)>,h>sL|~1Sw}N}厹zҁ#6_fxP|}Qo7o,-5jO|DY& "ZGOBqs3f]W_|6Ы<-ge-օ8?M ^<+ nIJc)O9. Mp:+58˽,~r[2x,(E8`CSmWᢓY;1@]$L? IC,eF_ no}b"WG6apN22 ?PپIM=gDwVP{=u^eoY:t<^ z^g& ͋ 0 8J ]{;c2r5^;}U\U=TR:.\df=`zvLjdR#Ugݷj@bqݮEb.CH̿1ĿO:G.?|@#+:gMpnTY EajUpѡ4'T90 eXN 5($YyYmYIE6/ ᝍ8XP:$NY*Xn'8[RP'!+JYRvĚ=\+s\=9ƟQP"6{}QRs]bÅ&G k_!iZf\ڕ_#n_W\=p,fJzә1)fm;k#mJzs'~w6oayDih(%*GW2be5L+ ;12b*U4݄:9pb`A(XB}?D,.&bBȽ'~.wp\uk A`%5S5E#ͱӯnl'\8zt4fMSQMڙ4'^ OL!!> a[òʼn@{:ޥ¢<^<$/146L$&6.Ae<S>ܷ([0LOL\0&%xjPav_ٜCyJY PCrmxU9Ð>>؟#8Y@7VBC-kڥPT6N8ڣ{ud"5 =~ #0Тugp.|0 QUZm-m{Y%b*My)0 Yʊ`_N(]w{L0nBM=;xr[cVT?>;褩k fpjgC/'rE`Y~~BD)fI*i3u$:_Xjso?@Nfig׋Odmoh6?Ɨjͣo ?N`B}XrJJp,D<%C>57Ճi{@{N_:)0zlxCsnvXmbڔ_A[GUX=~SO)=~lf\!qC)AA6MVM\!RSsfZ!bNVkpu{L:NJ}) 3/k ;t@zRQ'l0e1/.b_,`YfrWe+JxǯOmqU m9<}%OM|l:;#~ Kr-0>G .FKꆾ*G.!|\S}xh8{o-;pzi}h1kAO|׋{6qOqQ, bl89;AjL"c>q:`.em]n8]L!Of̰W/#rLj:!:5mI[%+ߏ~p6nvt`SFѧ,F/UQ[c觡.&&!Wi_d#f&,I=tE#ڈJ5VmQY>9$7:?/Ԛz^mZ5O8+*U!յF0+ ( Ax7acل&xt{GZ4Fk ů< =ܨQ7-v3 }$SLB~k&c5S!Yq=PKK bۙ4u&t;.~F>Ha\f'(lju:g?PA%xUi^^~:B P2^w&Iꛛ B65yt{~/2=JD8ӯ;*/Ϳ!j0}8[PSы#HHi E@5QrP8~ޝ\ dU҅'ohR ;$筞јEbhCw bnzXïk)ܛ%ֿ.rcjhh&壨ȹJGB5 mA:(.J3N$ :XŐ8IRܖ&R[BbvֳʡYG궲PWHp⸍l "^rVCg #0HEYdUD/>a'i̿F6-e9kQP!zU ;[`w aD>t-(kEDd7Ndxځ1^4.lJ^F+u"zII ⵞe"^g ĀTFWknٌmn%Z?j%;-3nV@d?%|0|B'lUcc p $V^ T[)'AOi lIGڃU7/Zg&U5~\(Wh%P|Մ灡5hgAՠA <~'ry4&5.51eō0C9ICiq+:x|`%WOQ)3ӲaTO<$iwZEFJ;ۍPj4tEf䅬[[~KQ(Ofg<ZJ\<gQ(CY$a:)Y:p39"Dqh+l=J P"N0cin 00F.fD"x1;8yc>@XXKV@Wk3 .$}U1q-{v|ԓu|N &lڏa~1}ž/hJU-N.= ?H˪Rh<<0bXj U).-EuVNv {eLGg Lհ@-3IG\|J Z.!STi+O\|>a+YfaV% H\7٢ïI_}'*gQkɻFP [/- +k  j=ޞJR:do"'2ΊiMmy X3~KoI&apű;{e eN@ӭwMI$uƫUɓ\ grrEȶ=(9]uU&[!)9Yϝ$ Oe^V#]&٥,m߉vQטYr ~IꕏW? 1.-~R>#;D5Mp/~$ekЄϢQזo5-B6h4Dtהhn!c],ZZ1ղ( I$bڒm:i=p;\CըX,\ -}8д@WicVY%X)a9'JoMsSqF=U}#n1mu[!O H!e$J#DzOߐ ;+{G}V>/7#?+RK'U49Tįrx6 bMvZc`-{. ݺo5bIlJ1B '*dD ^#OwCaSDt,EqnoN9Jkk㲂__lY<4gemg'I&}6qydRWf͡wtŖ* )uke.MƸ?dq#m:|~L"=*"nɊ|ffcbʋH]3}p}o/\{@q Z&,Иh\2s :I \wT9YVNjWԝ)†Þr=+)RsMBfVަVml˰O(e)o+(x>3WO&Aǘ he%h ۱R6~kPDiL6HtYy|D%U\:s:L4~]9{o5@V$i #b.L~&PfxykJy="B9?J3_AaW^J  1y|+UAJ`x&XDg\/e-_YR[VīoBy}`g.D&eQX'>1cl1FuGoI]G##YGx4_?c,*$oiE[xFۄ5I(Iy*~7:;հ[4R;X#N"Z5>A"jk2/pk56=g$L-@xP#qlj^~2GАHJ{m2="+,EcUsk$ vF[N4f[' SȊ#78^֑<^1Ԭ?r6#+~,}gW` @Yg)@oֳfTU ;b!Us;&x9$hb;]=&']4NAIè8U#ߕFΑ׳-^ycf݌<DGij+fmzZ;W2 N`VL]QG D~yUu$aѦVqvB8!Vj_)٬`L$E'υ |Xi\WퟀX)~z M@tFATO#Vg6ɨhÝsõ2檎u%D=9sp O>ĿKw!tUA̅ACbMbKR4cY'}?龜4ZE7\ h"<' _?e\|nX/AJdWf۫SoO^۩Ŕ 'w%2uHiDxZ:0{f!%7Zmk1ws{A%>pST)#RDk3paK$nISQ$\v~-Wm9R搥>ȝ$)ɦmb/L,լc\)=6qȗWKӓm\\ɆDL@UͿKm#w%SOF3rYxA釳;.L9&|mR9m"s>u.1Io"Jv^엾xA jDyO 8ØQx0_ rE}qm;RBΩ3K|-Mw1nzBW#aB3'5{l\WZ͏ -\Fj1uRMO@ zk)(刦>vA-6#>w-Tp癪 \ZՐھX~ʈpY~?t/E1tWNl!f3.p/ h>9*?{)k#Jk(r/,ZxSԾ"[@E#c⩈SF=z{M~K~-Ҵ&4 BTN_jNJRD^T:mT  pD/04U{Z{^Jt6|Iqv֧iyNc(XaO1K7w "bء.AQDd`}fxDd&7+o5o-4 M\^E/ZWN 'AL` /]B:P726M=r8-$j>Cڟj3x+ P$ÅGZvیFcR3j駒X WN,&֠{¯iA⑾-ԜHZn  t9܇3ݺ|$#tɫdLfK?i8C691N&:2j+%2h!\(BA -BϼvL3Ym YBHTyQoKL98ǂa[Vi9Vhj7~,baH0Es+9k {/P[|gX(esA^ty"Ds6 @Vsd~SbV]hq..d^ʠXA>i?yL)(K[XaRC_Jb{&H?^< S=YE[Cn[$z\ _d=][DDSE[y}5Xj7zL%+H0!/EUm)v+ 5`|&4"TXR#QW=aϐDX2ب5OT㉫٨-ڿcUU=w_v3,7QqNf;t`j׆zro< aN{A51;W)\Y:jjGQ,INe$e4U 8 !c[#O0~QfyTV^< blgpZ;}.=,a.^i1fcvnRYf:*D|U 5|%Skt+,xVS5̼ 9HWt?N7ᘏQ]ܻ(VJ̍?6.wcg`< F5tw! ,[/E>/ޙt2 }`C=U{|YB]7֎M|čJ#&M[:Ijzn*_dԦ]0WCt\x9VҔ¤H/~pOXnm)38s/?ED??}~L܊u MrSv~f͉u( Jwh+T]""Pj]Vx+6! `[[_){'$= s|4X,&˦6\4M~ٻw\ɢ>o#镬4A;y%K3F:lĵ\0TsA8,xr΄pNk۫o¨M S * S`qQ3OiDЛWG&rڙypQ헭<*E@4oUh7\!`QCtqAP2}s?&v6>OtoDPZl7Leo]܁- Sc8ƛgI}A{6"M|DQ`6h*/dSYoNyg F!Y=O<PӢf.EioQv;s ǼܖIk;a74kcTybVP聃6M\;3M21@HYޖy ۯA-fJvйS$i;iye|^ Z{g&NH9.|K.gI3&U0)hښP4g1J롔ŶM_;u9RV n@(UioBuӄ)-c)g?U#1f Wh#s,#4J߭.qδ?v4xX#>^zRE>*TSfwFoV^o\#Np 'puG|x崨Y ԣX12ɦ= %.FT-@x+*ohn?;IsK顤Gh_t s }-R$=u(SGﾣi(pX-omkFq.9eE:-MB:ȘMU΄MAfٶ|>kc>vˁbƷH݆L;U`|+:-.zzxЋSLy'acL(+Ve'?c#*Lh#^_v藧O/\F\#8xy mQR jVdi,N`rϑ "|G. +h+>PmbR] H6_*~Xk{BLf~6щΣމO'|vj 4 X":IemAO&\;s^AvYf5[Ǿ6@wGЋfa=ɐ}1Tး~\:BSN߉j! IXͅdm%"V8rع@ppYۜ@o?F50?kkTE>ɐ;`OEKњˌ{^&0@;h(ٍ&d4B~8vk CZW,vzjO+|w'`ڍ]QnC8p?M!!# [﫪SgÙklԂ^t=xUdd/.2 d۶2s9%[ئrU~ Q#@Q(FLfd'{#ɥ`J 8k.=ع@6m0}^*|`.|n"l󝕧Qyh)~pCQ Kd6&#ր#c ITm itv5xg*a [A^,Q}؍bvp̌mZ.U/e Dйs+q#`<_x {%n#JV˓gWEo2񀩀*f\Wt!&bzlos} FRo5)+^9"c ak}*A$ )ytnfOaE$-YR߄ChnR˿n CEY^ySCh2UHTLKp~ g1c$uPO=%$>u[n Ϻ ?[ՄHˬJ oi L-ϋ]18 ac̺Thhw>۹WIon>wFs*5嘗=A/OF\vY +9bLT3ӑ=n ]x]3~Ú"0@*PF:R >FmKaL&iQ>?ە7o/ -(){`Ԩ?G!D]!.r4f :9ʴ[GX?i(%.([vxFc$e\CWoe5{cyĕ5epm*E!X RR~): k~!!fa%#zXPsƍ(ׯ I$\l&m¡ fLt0<6V,iE ?~>` L* իT~FZ  >J cXh`H;Įc\λ r[jb_oV :b0/c8臑R'pRV"r53!d/KݔTƒuWgoRcۯqzkYX=)5^|0^gr7# 魑f6bۧܓ[B2 N-*2\Z.([EYI5 'ݥ:ZmLRYwPC+c_FxU`(sI!@% endstream endobj 132 0 obj << /Length1 2369 /Length2 16777 /Length3 0 /Length 18169 /Filter /FlateDecode >> stream xڌp  Gmgcnlm۶m;٠acNޜs~o}ggv߾fɉUL쌀v L<9UUf&+ ,95?tXr5-?$D4QCA9;[5`ab#@ :{8Z;#ʘI:@halh 3t6|x46[==#5 t:M 7;5Xrӿ*vn@hbkt|xH쁶030ܿ2daPepvwښ%hhdojhamh!wq!%Gى2Qf1[;_Z8?ZڹzZؚ=[ e>Hhf@g;+ 3@7/G>^vӏ4>X/'CW O"Xff3hfa h/G w61IcLl=bFa5euq_; @ `gpps|׊ſ_~T?{Ԁ%o1@՟1abg2b<Ho>տ6[+M,\l/Wclͬ[H 'q w߳/hde331r[}\؝(fklgגs  =`>&&@`k`jWK9B8"7Q쿈 (1%  `8Ї? (}S/}xP>22r44~ LYK01c;>ÿh_Q;kkCH|DcC?N9;|,ҘQ6b۹LJ?G(94*Z~dp>b~\"??Tm?xPG?X!6S?lų81v*Ǚw{v@AG͘?J'5bwu?L|'[lG>sv‡ :~dv0'UOl0vq('݁ưK vƼw'gwө齖\RRFWŨn?/z7Cu$)u>{'(v.NcN 5 W`-M…X6 rem6݂Xm^} sAĿ.̪ k규:usW;sA*N@BF+I>pۀƦSiK=,er`\+K :yT8T  1#.3xaRIN ^ʂgR3ƧcH90C4uH[HIvMm>₰Ixb%c1Rp}lw;HV5/#Wu}f2M|*m=Hq%[IKZZuэa C Y-$!>>ֻg o,_'c$ZlbFfZgim14kNVwѪMD{9>W1}7fx(S=R/3nm}J6EZxj#>v^EӜ֍<1/.+ZSShUYA17v->Zr"T!ק1!}ƭ/*oEC+RJ7 "U/J]1lLƠsl.'n]9,ߴ.E7g dDeo,Ú DCC"xI/+c+̜VGbA>V;? ϙWgeO\Z|fK~l= s mt&|Ld!a}|;sTֵ3X8Ezʂ9)9W}Pz`4fn,=lymݟt9=W =f#Z62.5);+ōm-luC.Ļ1Ǽ<IeGz5Ď .TE%]>w;an\RKdMnɖ5;јњ]@!&ր'( ֡d7fχs&` Pv4]ߑFc-g>vH2 'T^BNrܖ1doԫlTreTݮyr/BjAVGY'KnסcX9"uQ@mq1A[P =UoCEb \EBivGKGе5A{o~54&_!~0;w4 c }:H44ϭU;ݑ ~py j=E=ATG׷XSFad<_ߵȂ#@2&b7bcA8׽d߫QnXd j;{u:b~z[tI`^0q>X{辕mMZGeXTHM9$ÎDXJ лOlDaC9nWկ'_N&BUPٶ#MgL2Ggz*_zW[Hw~_FbD@{[_G(@$BSO6z. ܪ/Dqa=uH0~_d#}J',{+PLm)˫t nQIɞ/`\SIˆ 6?%aD>k$B-`po7d O.H+SrhӫҜgxhPʵR@םʡU) &G@4( 閳p@_ SsQc0 "ݥ&cu0\8#`b^' hyP[gܵ%onWҹN(ص]_5SmM01$u23yƌ "WBilT~Ky9HK&I 6Λ~彺"1{\CvpҘ%|ΝHc=Xgc=uәS}>,8R홙 S=[?@(sz6 clRP2ځ? ++A)ZYݫ&#l;O*'*fZݩz0M /7 ~bJNy?}hNhn@X(l(+`WgGiuM`G@QSeVc~E w.̹i(^:٣lIVp7TwAs~}O R>m#c6`*X1rX|M -j Zj>W5f5gW9vQO\B-^pm>?SFi"M Ѿ)bHX:[2pl|uln~~pƃu?˛&ӛBKJ)y-4 jFܯBC3ӎ[" 69Q%y®߾2hnsW<=ջ":DЖL.hIҞ1cwMEs9HAw?OO؆6wF!H t0sؑw5ڋLdX{""'=sA^\VoOMM;uE|tͲCjwt2#nynaCb5E$Rg1``:&27N>,8^JBnGP.ʨ`Y FބO|,=8FB>!y%s όȔ`GXƉ~_fsns vZ0ƒNa̻ʴN0iU|˵\8OF71 m#~೑hw0c(k&!d>,=թNVK}WqBRmsB](wZZyXܟ09_t*8mK>)7ez^g/]+;( /0h6'0a @;}vEDn #jo~8f9eM֞{#/e&gM-"E/9,ufB*}F!Ba՘ScU\$TgJY%H55sXPLΊ]nn }<)i~(/DbD8]r~uՈ.Z xzޢa<=d! x mo^u]CGy[`6:o"Q wJ'uesh\ļ# WSCx4ݲrCYFɥr28i^Fv2YR{3_X{c;\TQ>U 큪<-I- @Z, GhkX%וSs!ɅCъFFVWm&cNi47Lc+H6,plG ˳XT% fvϥd'ʏy-oO(y-+YKMY`[xXEDyG]I0 gП:#Qٺaio29U31|Y5yکr=_m[\ {L.Zw@m5c4pr@ݷsNhm <֏HX8U@Kdd0+R!H%昩0#prrW%}2އ3"zns7MJ6΋y=T(2}]GT-B4m:*6Bnmu#WF"BJ7>]:FKCu&I#S׬G| PI 䙯$MCN0(*{ۚ)P33ޏ,v5NZø ENI^VF; \@n qXTO/-Y߻! nWM6:8U:NZY7iחB(sQ*[6%?z:6~r=n#q=Y!|PӈV|ZU=l2ϮNE@/%8THBwyfJF<]zfƋ Ԧ8CKhy B:j+B)vOM8n#t鬮guVYJL,I%=$^ľm󣪐h%XZA?+aˀ1'}س(s-7zv~)veN|2/`LV$IfrAtM^NlGoQϪ.f|Ҥ_"7NgPSXd}GF\RL|ګ0}{ >|>5qn^@Ug4ցtL>N|eYx=Ay/ PM|˗revN&͍WBYv%^MqkD y*c/9n`v61E2,R{Y7X+ϐ[pR,C~`8;F's܌a]r=wpϺHa: |E}i1 |`O/?=%^^0'YY`C+XJ&NSm>s7c7{14s|0uLSav|᳉9d#LFx9Y;8p*b5X<+dhA䞵ŋ5G TrC;NN)է4Z)釠^|ģ "quF\~@$Kk kټ*i{jaFʕ6D5΄4 csֻ>WY+vF~5;BS| j#}3]a l Ve^κd~[i~oWk8.$D{nnDj8ZTarA3%Hgdn9AK2[V8B[:)SCԢ/'6<#JϘc`Lf Ŧ-  3ŸPX 88w!+f~_H)DKr+D`Yw{%jK,/W)r|nL4)π3}EhxK3ɶ8b"#m-sj~dz9  íb\v 3T\$tRJXf՟?Iwި>- ԧ.帹%Me^(WAKG_bR> 3ExiR(ѾAc@u ul:Pjj~gXpD~h˜6`vʳYin#~r jQ֡o6GVa"<0۟{~ Pf@6UCgp21mY fr3u@DHbFVѸ>lBxXn]11 y`,Rqe q \kLr({Tb=ZaEէY ޫK[K2;+wB|bbt #2k]@xye( 'HB+qiO@FALٱIMK؉tM<`1oFF3 2B?uUbʒPp9[H᦯YC d;g#)|>(~.2qBTozqHM|8}B{0V+4r51`%Wm|;c'GCR_Z R$ky7 b_#*@Ԕdž+l(RF;KP; GF}rI}L`n0{֩XlV=bILq5)0Rf/|MF:_ b;ojl k2u~FlOJ* J|RV [00FVzSAY\!+ Nсbv!$L]Wş (茢?gQ2M + \4 'H#+?V f!4_mVA#\v8$}w(LۗDdljfWI@!k(!Nyʉ־Nv'TRRyU lugQ _X~j^;0 = 1).M;ͺ2xweqv#j'2]tn Ef/|)K =Sy~0-L(moX~8yw*$| isF͞׹V++ʽs (3a"N75.E :i-F[xZw[+dᦥ/u5nF'C#eC/!kunLmW`BϺt-pҭlv|I/D"n@wvz7CJ5vO9d[MLWy!R|h"U*tc LgFppxjtFKSMN\LGc/"@'U'5).?7hRHDPaIhF9NCذ|Mt}:B$3oSo, 7$-#gS:-G0IM? d'q02B} z8eQ-ux*WcmJSeL&|\Jjoo[tjTxBu\؋P'z!ڱћQWy +Vr}ߪ"^i 旪*`$=қr}*M唲mhGvv~<ͶǚULp8 aw)E)S^)@{BKgv B"2)IWwnl%rw[I~sGL>Khm~н|J/#[ 13^HY6aw'[X%"!٣K:} >1)Rvw xus[R6_b 7䛨vOVrJ8fK!cָ ^H%dсL9޹R&Vmo'~aii4C_L7_u'JEYȡT)BNW_[Q@QS\˗K1d+ICBǤRn @׊]&Uۮeb %r* ~og[(F-^;ٰdAIqnfZauGcj} a$}D]g Ke9 _Hm5bz[ ;L|=+5(}vg\ E nٸa{tGsjT7UFrvvr34F?)?rg~zhv۞o54&voqW p_iK p+Dܻ03%[`*6 .73J{(韀T*Q}1U)!DOq%ś ~] ]~wTdg}o~ (AY˵SoY(V!ĉE8W>}Hɶyi0͜C cNҊȾ=dkp%.!|T^,k7 saK:ܩesz:}3B.{nY `~@0kjC/R"\Y=zC_gFۺVj% ن6BᆪG]?%7sܚ]"gOt/M*"\/)EӵP #sP{ؽ> {wțwDԎ"J9yܽnxͲ17fK+R/nD'ǣ-,ӥ-AOO"r>G9TQ!~0 kv* wu>&+U Y0`4p8ϽiހvD7=F3r{ 3wޥ4`/ikr]6ͨZ?)QfNllR@(~gH̱}:jJS{nC !Dm ?LL'U('"'[_ݐX6AI۱6aVV735¹ۀH?pVJkM:nЦ} oKYC1KFgR98fq,gWXDz #&t%@o)ɐ^ԣAT} 4F;7~>[,-ubkL*#|Q."'=p3cm^DLq踘Z{Y|:cz5F,"rHV2\GEO΂~+pDx-/kH{c|tf~Լ *y܏>j 9{KL M{ AGCkh~P A(b 7i-[ZĢO; +=6->֍޽}WqRF#[O'"FZbOR*t{?헲c?0;4akGZ o*X+[ lR:&'LFu$_1Ac7{ڍr4 "D#!D}ՐƵML9E1:i' b1u= 9+XFF =K0q0}E?RcyF]_qCPma* 9m==UELWW7:d9͏![ؠ>Z}tV#/;̅Dl0z_pnܳ/S>ۍ4tJ;B)%z=SN bh~iЕǩBx xg3XL~[  .K]ܢ=]U-T TAiq"s{ϋ0 %7 G2rGv} #i[R7_k}94ѮT  x489,w$y&@ncNi* r)Kmڣf/FHM˜pwo A7#3ۙ=wd^̵o3;o yےQ;o1XSAbѮCB]yh3\Tv 'M8QQd|lޚeh:4ܖVptaeW#%GJ\IܘLuY"#!r9UAg%1{OV |^p8{˧"lS4Tg"vߢ %*;V7 r|쫶}y[m)b#bO9n6c25Hv}u<{^{`{Tp˥u^^hKuCqð X2&W⁘؆:VS3 .-Z];5YMcc-)HZ0TUP %^71k.s),o *M^,s:8/[xnepӲ vz.ͅo(Bb''x\\" vHŠܵuq%+[)bRء9 ,^2* 8XORk yMx(s$w/`A' F$%KB(dZҳ`ߖiĨ߻Ia6.'`) 3^rNP-*1klq33Owcx"ڟ˸9*#2-^M鹔Ni/y^ĞK7 ~m74RvKSFhu Dt~:l'``B`_ ߏh.4 ^0-46SKVVS-`8\m=L<y!_d?¬Q"[S X/OTgAJ:SԿo }dټz-x=`]rQXES܃JsvˠI5xJ+PV$0Z\D_xfT;匋E3"pnFLdzVI4$ma{.fBXfn`>=p,[ƸgIGͱ qvГ6}K`fJ#v/5R(&Y!ln)" q7[l="l̓;_TM)A4ǨbU]DqqDct$NpOfHWa|EUrڱ_ U_Pw#(X[cpN05Goq_̓#y8X GfCPR>5LqJa).Q(uԽ85:%+xr1K:g~S_΁&.毞ot ttfՎRay3\䥟"P& qF^*J9E7-oԛQt}oEhӓBlܺes^`V?*ݽ-ζ;KkW@e໤Olz9:f3=\U0u73'g q, h%_܂!ZEvI35zXw 1F wyHq%pi[7NY?YsJ[՞pFtr!E~ˬb\sIP3܉ākC=D 0I-3Z~$Q|$ʄ+$ ; pNwACՖFgOZY;`Չ8vg2mtӊnU{ݿY+F;>Jߒd8T2*;h;ҢOw+wBy/Ta3k2]!a} UƷo)JH'4RQfh xPbg5Q9J_ag nUٞ|!""=V(Q +jt8pA1xVr] DMTu~ߠ#jEăD†w),Cb;n'M% \p Ytvw?d[уUy='AIq~$\itQHzC[%TߍAH1_OhYNn1PjxhhI^#o؜1?]xlr?`ړfG(yNUBoA j➖Y/exy-Y/BU-:I&}<(! WF\=-W$w;-S+!-2|e}.pW SޡCYpVNRU>BpZD-ya^KIlq%.'S3؇ݦfbtL"NWw=!0ZZs"G*r-5({a-X_PN!Op J Ft| !1<݅;ƿ;iZ.چEwn \ 9$=pׯ)]\,. .AwZ$6.HMz }q@dےҌN]K#M6IJ #`0E(L$wHWՅ GFxf8лTt%; q,!!@HvQ|F*goV4?9De|4ZznC<_c\D',δ-{ n5Qh>\G2F2oF̍jJŪl~x^?`*{sa#FS$K{?eӢXϼVON'``TzyOjQs\B4뛲wENfp-W1PEѭ}:ԻR%HJ*ʒw+\IJq#a0uU1a; sW>+ ֮~Kd>/r5b0T9dxp5r * endstream endobj 134 0 obj << /Length1 1528 /Length2 2975 /Length3 0 /Length 3946 /Filter /FlateDecode >> stream xڍt 8T}H(-K, .c\ܚ,d/4"IRE=ٲٲ=$^.z[y~g9{~5?"Fu0C]S++Q@a0V 0sit #@" gJ#&*X%`0Hץz Or̿I*ˮ0`JdxD  G )uO F:J8$- B O4 Xi0#RP―'D_3|4@ dt$ 498bhkd5,c6GJ"^ &HT`"_&(I,@VD2}V+'iG{t bQt"z% 2e=MJ0νR$d~赛=S}Wpczaț ~P/p FEx^Io:+f/4A @'~wX "1WeG̠F.0f &/ZBf>I @+8E Ĝ(+vk"C^/c5?sQ͂/;bpJM-HI&VH~?d DTd Rm5 &^CYm؃s]: C 0++F`МJV)+ AGD=Du[/y@ш~DF8E <` $@ ܩ4 UURФ oP@{U47ߠ< HNxUG$&>W5 x$qvSIja *i }lWR?s3̀nO ՝Ĝp~ Upk,MUU. deg;e?v% K,Coܥ>v|睕3Z-q uMYlЇD-^ƟF]Uc<۵tQ*sEi)Wz {e7Dٰ+D0Ƅ'[s; $FPQ =͛se!iy_I]OvR;Eu+{!:=rI OWid'aP4vۚFA~6Udv]iW=`lg rGBݧMS~umA-vi=jc lE{aGU*1x28:>a[lC%[7)zLlD g61J4=3r.@!Rl3E(}11/Î#|q Utם}\r%3ڭ{F[yge@c&/4aEX:'+>{1'5꣞(gL؈磍BY7> l\ a1n_32 :9XB6M/q+&*gFͥOp6N^ߝ2[ [@󦽝{df{}oOc9F>T)nAC+.y k ۿFK6dň-Gv6ѯ-GwR}-M+(]:=[:D"FQIoқ8n_Sw"*a R{pr I b@bux,gᕞ!iM]8XywANYL症f8lݬPYW64:2MԪv6~O#.bD\#hHJ 4[׹noTmԧ> stream x\[s;~ǡNaҩ]SE- xp&l0.jv8ə3Cj]ҺZrU,//+rU#ޚBE_"SBç..)}aT!@әeJ + %K 3ՅR*+,w=4: ˲@ <ڞְx_҂,h 퀮 q0/xW)%ǥK]PB @芠 kJxQ<  4 rXBK!g,Km{OX_+laH `=MVJ *A` CuJP6XԅTe*h0Ԝ 'U<R; k0!Ait=Xv@}]Ά5WgGm GC*3q_J ho83U0MUد~𾺊 MU5W=,J ]M'բ ]cQ|Ur6Dw!{&PFRpcnh Ԥ4wҊm({{Ϫb4 UUtUKZ@tznClpu1΋Wr;[K鉓Q%+2xZWp'hr'I& (:-?}t6~ɘj0 v>, Vo:kہn; lRw1v'Oo3[|û3]i8]|mpO(pڛ_> ұNn73oo?GxJuwÌqe}Zu^%cOT`& e'< 瑎rPrKP`\ fFJ2z5ОSK$L)QTr Zl)T.juߦ:`5ZB}4&Q& $"#1ėJY%pL\ )\' f5SWZ=l:l<1Ґʌy/ u*+*S.!=Et[+u@P=.`/܌w!0Gx`&Z\7&ZPRn4fUO%A Hij\(Y3du]"7*Z"qf4$B$le~$.䵤}.֤,-7=R劎M䑴cRQ5uHmKPm Yׅ#Ce$5r#M&P"@$RPYr}`1a8/*1M ڣ/ch\cl܎S.!$+P{8~/Ӈb߭RJB]q$R׭uf؞nSB X% [QҖwۘv%Kڔ]'8N,`Pw0N!Q]OEơK&<y'SfLb[WfO۴s59]Bfz!z )qmZs[vdh ϰ?MJYfi7 J֚_Ӓ n:TyFf'@ h6u v Ku#c-K$Ӊ;B9_Y҉>|D7Ypf7Kɞ>8H%Xen4>^#$yGqA.5Ik>4C &TJ)ܠ͜Ae)q2J( QtA *t AvG](LZH/Pt!B_ch}@M~hG QQa[u'Q[bVfeb 5ABv9IQ^N=)q'v,ț1JQ7Du<n]u&6 1"R~j=*)MbO"FVRS P2u Uxj`caJ NDF[GFoQLI$rNJ ;ZLEjw7I?m Ƅo$ ݄01(NE6Zr$p) &+ne2%1M mOl$KFl ݪh«lb8=PF4(4v6Wj !;jF#(Qp t0@Vaa~"8ٓ-i$D< 8-kw-N* NeJ%atPt$*%%Z#mKbɒӒV4 !TapOgh2\rBt|rmYC9 ɡѴOq SkĒ["A:AH7(c qJL$$\J{Ķ~q襤(eoW䏠(ylgfQ,Plyh",MEQs77&)lDGڤDhnRT)*R+\A۵LD,Y#g<8jh$S?{|^Ce1}Gs\=F oz`CGx4|49WE'=~$.2˸GbO#B[N PJ|_˙8b$cq)&b*J\j6X\̪J,1K]C>`GnГ7'v )?N@5*2e21>SzNg! =szZ{3 x0///]jcq(sc @{pL[mۣ7X d*A Wg$;Aڋ?.IrZo_| B5^HeW\|WN4~Uyu9uϫ|>р:2lr'dhԆ``jӎt:Y;6uvt|B:@0ycDᕉ7ցЁչ}{`uc^d:j;.N u[ 2{Н V?yDo;|-R"w a#֝`>`LDҮFq_ޏSc ROQ UM wxUyq'x3bExKA#.SkǕzR;k7<^p γp4bH@[;Φ`f)Fg\uܗ`x|QxNӉȭǦpyh͓.[[ƈ57qЙ%F%c_! >{Kn3u\||J@:Zl'~w {{̘F,̘kvA|(T n*6|}ם Չc)9pڐ1M<V 5D ؽ wo?"wCaN|4c/ &#(_ݢCe5GlV{O^$>λu-O޼v[ ~aГi=s[Hʬ7yR6 w31|-mp6;[0jwa5ձCyӯ6 wӦ-do' mfפ,} 6 +36:y xCv,v3˼j+rj37'?_.1jOqy>:Q N f-}xn⺋e?XOd|Oۚ?pz+0_ endstream endobj 138 0 obj << /Producer (pdfTeX-1.40.16) /Creator (TeX) /CreationDate (D:20161130103328+01'00') /ModDate (D:20161130103328+01'00') /Trapped /False /PTEX.Fullbanner (This is pdfTeX, Version 3.14159265-2.6-1.40.16 (TeX Live 2015/Debian) kpathsea version 6.2.1) >> endobj 139 0 obj << /Type /XRef /Index [0 140] /Size 140 /W [1 3 1] /Root 137 0 R /Info 138 0 R /ID [ ] /Length 380 /Filter /FlateDecode >> stream xSaw?%:HTJ) I/8䈼1v,hLaaZ1vvfjLV,tgs_=DDOUPD.1E +p]e3|>dCLMEôO EmǕP`5Q4}:TxpBWt+pL5S?6&͊h94Ejab+Шq;4 O >y -Z C;P]A8pQn^8ǡO1ͯP|WsGkPv Ia )i)N+\g:]yyY9/ ŒW ʺf]s]IxPM,= endstream endobj startxref 237953 %%EOF ape/inst/doc/MoranI.R0000644000175100001440000000523013017516351014071 0ustar hornikusers### R code from vignette source 'MoranI.Rnw' ################################################### ### code chunk number 1: MoranI.Rnw:21-22 ################################################### options(width=60) ################################################### ### code chunk number 2: MoranI.Rnw:119-122 ################################################### body <- c(4.09434, 3.61092, 2.37024, 2.02815, -1.46968) longevity <- c(4.74493, 3.3322, 3.3673, 2.89037, 2.30259) names(body) <- names(longevity) <- c("Homo", "Pongo", "Macaca", "Ateles", "Galago") ################################################### ### code chunk number 3: MoranI.Rnw:128-134 ################################################### library(ape) trnwk <- "((((Homo:0.21,Pongo:0.21):0.28,Macaca:0.49):0.13,Ateles:0.62)" trnwk[2] <- ":0.38,Galago:1.00);" tr <- read.tree(text = trnwk) plot(tr) axisPhylo() ################################################### ### code chunk number 4: MoranI.Rnw:140-142 ################################################### w <- 1/cophenetic(tr) w ################################################### ### code chunk number 5: MoranI.Rnw:146-147 ################################################### diag(w) <- 0 ################################################### ### code chunk number 6: MoranI.Rnw:151-152 ################################################### Moran.I(body, w) ################################################### ### code chunk number 7: MoranI.Rnw:172-173 ################################################### Moran.I(body, w, alt = "greater") ################################################### ### code chunk number 8: MoranI.Rnw:178-179 ################################################### Moran.I(longevity, w) ################################################### ### code chunk number 9: MoranI.Rnw:240-243 ################################################### data(carnivora) carnivora$log10SW <- log10(carnivora$SW) carnivora$log10FW <- log10(carnivora$FW) ################################################### ### code chunk number 10: MoranI.Rnw:247-250 ################################################### fm1.carn <- log10SW ~ Order/SuperFamily/Family/Genus co1 <- correlogram.formula(fm1.carn, data = carnivora) plot(co1) ################################################### ### code chunk number 11: MoranI.Rnw:265-268 ################################################### fm2.carn <- log10SW + log10FW ~ Order/SuperFamily/Family/Genus co2 <- correlogram.formula(fm2.carn, data = carnivora) print(plot(co2)) ################################################### ### code chunk number 12: MoranI.Rnw:276-277 ################################################### plot(co2, FALSE) ape/inst/doc/MoranI.Rnw0000644000175100001440000003106013017516351014436 0ustar hornikusers\documentclass[a4paper]{article} %\VignetteIndexEntry{Moran's I} %\VignettePackage{ape} \usepackage{fancyvrb} \usepackage{color} \newcommand{\code}{\texttt} \newcommand{\pkg}{\textsf} \newcommand{\ape}{\pkg{ape}} \newcommand{\ade}{\pkg{ade4}} \newcommand{\spatial}{\pkg{spatial}} \renewcommand{\sp}{\pkg{sp}} \author{Emmanuel Paradis} \title{Moran's Autocorrelation Coefficient in Comparative Methods} \begin{document} \maketitle <>= options(width=60) @ This document clarifies the use of Moran's autocorrelation coefficient to quantify whether the distribution of a trait among a set of species is affected or not by their phylogenetic relationships. \section{Theoretical Background} Moran's autocorrelation coefficient (often denoted as $I$) is an extension of Pearson product-moment correlation coefficient to a univariate series \cite{Cliff1973, Moran1950}. Recall that Pearson's correlation (denoted as $\rho$) between two variables $x$ and $y$ both of length $n$ is: \begin{displaymath} \rho = \frac{\displaystyle\sum_{i=1}^n(x_i - \bar{x})(y_i - \bar{y})}{\displaystyle\left[{\sum_{i=1}^n(x_i - \bar{x})^2\sum_{i=1}^n(y_i - \bar{y})^2}\right]^{1/2}}, \end{displaymath} where $\bar{x}$ and $\bar{y}$ are the sample means of both variables. $\rho$ measures whether, on average, $x_i$ and $y_i$ are associated. For a single variable, say $x$, $I$ will measure whether $x_i$ and $x_j$, with $i\ne j$, are associated. Note that with $\rho$, $x_i$ and $x_j$ are {\em not} associated since the pairs $(x_i,y_i)$ are assumed to be independent of each other. In the study of spatial patterns and processes, we may logically expect that close observations are more likely to be similar than those far apart. It is usual to associate a {\em weight} to each pair $(x_i,x_j)$ which quantifies this \cite{Cliff1981}. In its simplest form, these weights will take values 1 for close neighbours, and 0 otherwise. We also set $w_{ii}=0$. These weights are sometimes referred to as a {\em neighbouring function}. $I$'s formula is: \begin{equation} I = \frac{n}{S_0} \frac{\displaystyle\sum_{i=1}^n \sum_{j=1}^n w_{ij}(x_i - \bar{x})(x_j - \bar{x})}{\displaystyle\sum_{i=1}^n (x_i - \bar{x})^2},\label{eq:morani} \end{equation} where $w_{ij}$ is the weight between observation $i$ and $j$, and $S_0$ is the sum of all $w_{ij}$'s: \begin{displaymath} S_0 = \sum_{i=1}^n \sum_{j=1}^n w_{ij}. \end{displaymath} Quite not so intuitively, the expected value of $I$ under the null hypothesis of no autocorrelation is not equal to zero but given by $I_0 = -1/(n-1)$. The expected variance of $I_0$ is also known, and so we can make a test of the null hypothesis. If the observed value of $I$ (denoted $\hat{I}$) is significantly greater than $I_0$, then values of $x$ are positively autocorrelated, whereas if $\hat{I} c,\\ \end{array}\] where $c$ is a cut-off phylogenetic distance above which the species are considered to have evolved completely independently, and $\alpha$ is a coefficient (see \cite{Gittleman1990} for details). By analogy to the use of a spatial correlogram where coefficients are calculated assuming different sizes of the ``neighbourhood'' and then plotted to visualize the spatial extent of autocorrelation, they proposed to calculate $I$ at different taxonomic levels. \section{Implementation in \ape} From version 1.2-6, \ape\ has functions \code{Moran.I} and \code{correlogram.formula} implementing the approach developed by Gittleman \& Kot. There was an error in the help pages of \code{?Moran.I} (corrected in ver.\ 2.1) where the weights were referred to as ``distance weights''. This has been wrongly interpreted in my book \cite[pp.~139--142]{Paradis2006}. The analyses below aim to correct this. \subsection{Phylogenetic Distances} The data, taken from \cite{Cheverud1985}, are the log-transformed body mass and longevity of five species of primates: <<>>= body <- c(4.09434, 3.61092, 2.37024, 2.02815, -1.46968) longevity <- c(4.74493, 3.3322, 3.3673, 2.89037, 2.30259) names(body) <- names(longevity) <- c("Homo", "Pongo", "Macaca", "Ateles", "Galago") @ The tree has branch lengths scaled so that the root age is one. We read the tree with \ape, and plot it: <>= library(ape) trnwk <- "((((Homo:0.21,Pongo:0.21):0.28,Macaca:0.49):0.13,Ateles:0.62)" trnwk[2] <- ":0.38,Galago:1.00);" tr <- read.tree(text = trnwk) plot(tr) axisPhylo() @ We choose the weights as $w_{ij}=1/d_{ij}$, where the $d$'s is the distances measured on the tree: <<>>= w <- 1/cophenetic(tr) w @ Of course, we must set the diagonal to zero: <<>>= diag(w) <- 0 @ We can now perform the analysis with Moran's $I$: <<>>= Moran.I(body, w) @ Not surprisingly, the results are opposite to those in \cite{Paradis2006} since, there, the distances (given by \code{cophenetic(tr)}) were used as weights. (Note that the argument \code{dist} has been since renamed \code{weight}.\footnote{The older code was actually correct; nevertheless, it has been rewritten, and is now much faster. The documentation has been clarified. The function \code{correlogram.phylo}, which computed Moran's $I$ for a tree given as argument using the distances among taxa, has been removed.}) We can now conclude for a slighly significant positive phylogenetic correlation among body mass values for these five species. The new version of \code{Moran.I} gains the option \code{alternative} which specifies the alternative hypothesis (\code{"two-sided"} by default, i.e., H$_1$: $I \ne I_0$). As expected from the above result, we divide the $P$-value be two if we define H$_1$ as $I > I_0$: <<>>= Moran.I(body, w, alt = "greater") @ The same analysis with \code{longevity} gives: <<>>= Moran.I(longevity, w) @ As for \code{body}, the results are nearly mirrored compared to \cite{Paradis2006} where a non-significant negative phylogenetic correlation was found: it is now positive but still largely not significant. \subsection{Taxonomic Levels} The function \code{correlogram.formula} provides an interface to calculate Moran's $I$ for one or several variables giving a series of taxonomic levels. An example of its use was provided in \cite[pp.~141--142]{Paradis2006}. The code of this function has been simplified, and the graphical presentation of the results have been improved. \code{correlogram.formula}'s main argument is a formula which is ``sliced'', and \code{Moran.I} is called for each of these elements. Two things have been changed for the end-user at this level: \begin{enumerate} \item In the old version, the rhs of the formula was given in the order of the taxonomic hierarchy: e.g., \code{Order/SuperFamily/Family/Genus}. Not respecting this order resulted in an error. In the new version, any order is accepted, but the order given is then respected when plotted the correlogram. \item Variable transformations (e.g., log) were allowed on the lhs of the formula. Because of the simplification of the code, this is no more possible. So it is the responsibility of the user to apply any tranformation before the analysis. \end{enumerate} Following Gittleman \& Kot \cite{Gittleman1990}, the autocorrelation at a higher level (e.g., family) is calculated among species belonging to the same category and to different categories at the level below (genus). To formalize this, let us write the different levels as $X^1/X^2/X^3/\dots/X^n$ with $X^n$ being the lowest one (\code{Genus} in the above formula): \begin{displaymath} \begin{array}{l} \left.\begin{array}{ll} w_{ij}=1 & \mathrm{if}\ X_i^k = X_j^k\ \mathrm{and}\ X_i^{k+1} \ne X_j^{k+1}\\ w_{ij}=0 & \mathrm{otherwise}\\ \end{array} \right\} k < n \\\\ \left.\begin{array}{ll} w_{ij}=1 & \mathrm{if}\ X_i^k = X_j^k\\ w_{ij}=0 & \mathrm{otherwise}\\ \end{array} \right\} k = n \end{array} \end{displaymath} This is thus different from the idea of a ``neighbourhood'' of different sizes, but rather similar to the idea of partial correlation where the influence of the lowest level is removed when considering the highest ones \cite{Gittleman1990}. To repeat the analyses on the \code{carnivora} data set, we first log$_{10}$-transform the variables mean body mass (\code{SW}) and the mean female body mass (\code{FW}): <<>>= data(carnivora) carnivora$log10SW <- log10(carnivora$SW) carnivora$log10FW <- log10(carnivora$FW) @ We first consider a single variable analysis (as in \cite{Paradis2006}): <>= fm1.carn <- log10SW ~ Order/SuperFamily/Family/Genus co1 <- correlogram.formula(fm1.carn, data = carnivora) plot(co1) @ A legend now appears by default, but can be removed with \code{legend = FALSE}. Most of the appearance of the graph can be customized via the option of the plot method (see \code{?plot.correlogram} for details). This is the same analysis than the one displayed on Fig.~6.3 of \cite{Paradis2006}. When a single variable is given in the lhs in \code{correlogram.formula}, an object of class \code{"correlogram"} is returned as above. If several variables are analysed simultaneously, the object returned is of class \code{"correlogramList"}, and the correlograms can be plotted together with the appropriate plot method: <>= fm2.carn <- log10SW + log10FW ~ Order/SuperFamily/Family/Genus co2 <- correlogram.formula(fm2.carn, data = carnivora) print(plot(co2)) @ By default, lattice is used to plot the correlograms on separate panels; using \code{lattice = FALSE} (actually the second argument, see \code{?plot.correlogramList}) makes a standard graph superimposing the different correlograms: <>= plot(co2, FALSE) @ The options are roughly the same than above, but do not have always the same effect since lattice and base graphics do not have the same graphical parameters. For instance, \code{legend = FALSE} has no effect if \code{lattice = TRUE}. \section{Implementation in \ade} The analysis done with \ade\ in \cite{Paradis2006} suffers from the same error than the one done with \code{Moran.I} since it was also done with a distance matrix. So I correct this below: \begin{Schunk} \begin{Sinput} > library(ade4) > gearymoran(w, data.frame(body, longevity)) \end{Sinput} \begin{Soutput} class: krandtest Monte-Carlo tests Call: as.krandtest(sim = matrix(res$result, ncol = nvar, byr = TRUE), obs = res$obs, alter = alter, names = test.names) Test number: 2 Permutation number: 999 Alternative hypothesis: greater Test Obs Std.Obs Pvalue 1 body -0.06256789 2.1523342 0.001 2 longevity -0.22990437 0.3461414 0.414 other elements: NULL \end{Soutput} \end{Schunk} The results are wholly consistent with those from \ape, but the estimated coefficients are substantially different. This is because the computational methods are not the same in both packages. In \ade, the weight matrix is first transformed as a relative frequency matrix with $\tilde{w}_{ij} = w_{ij}/S_0$. The weights are further transformed with: \begin{displaymath} p_{ij} = \tilde{w}_{ij} - \sum_{i=1}^n\tilde{w}_{ij}\sum_{j=1}^n\tilde{w}_{ij}, \end{displaymath} with $p_{ij}$ being the elements of the matrix denoted as $P$. Moran's $I$ is finally computed with $x^\mathrm{T}Px$. In \ape, the weights are first row-normalized: \begin{displaymath} w_{ij} \Big/ \sum_{i=1}^n w_{ij}, \end{displaymath} then eq.~\ref{eq:morani} is applied. Another difference between both packages, though less important, is that in \ade\ the weight matrix is forced to be symmetric with $(W+W^\mathrm{T})/2$. In \ape, this matrix is assumed to be symmetric, which is likely to be the case like in the examples above. \section{Other Implementations} Package \sp\ has several functions, including \code{moran.test}, that are more specifically targeted to the analysis of spatial data. Package \spatial\ has the function \code{correlogram} that computes and plots spatial correlograms. \section*{Acknowledgements} I am thankful to Thibaut Jombart for clarifications on Moran's $I$. \bibliographystyle{plain} \bibliography{ape} \end{document} ape/src/0000755000175100001440000000000013017516351011626 5ustar hornikusersape/src/Makevars0000644000175100001440000000006013017516351013316 0ustar hornikusersPKG_LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) ape/src/NNI.c0000644000175100001440000002632013017516351012421 0ustar hornikusers/* NNI.c 2007-09-05 */ /* Copyright 2007 Vincent Lefort */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include "me.h" //boolean leaf(node *v); /*edge *siblingEdge(edge *e); edge *depthFirstTraverse(tree *T, edge *e); edge *findBottomLeft(edge *e); edge *topFirstTraverse(tree *T, edge *e); edge *moveUpRight(edge *e); double wf(double lambda, double D_LR, double D_LU, double D_LD, double D_RU, double D_RD, double D_DU);*/ /*NNI functions for unweighted OLS topological switches*/ /*fillTableUp fills all the entries in D associated with e->head,f->head and those edges g->head above e->head*/ void fillTableUp(edge *e, edge *f, double **A, double **D, tree *T) { edge *g,*h; if (T->root == f->tail) { if (leaf(e->head)) A[e->head->index][f->head->index] = A[f->head->index][e->head->index] = D[e->head->index2][f->tail->index2]; else { g = e->head->leftEdge; h = e->head->rightEdge; A[e->head->index][f->head->index] = A[f->head->index][e->head->index] = (g->bottomsize*A[f->head->index][g->head->index] + h->bottomsize*A[f->head->index][h->head->index]) /e->bottomsize; } } else { g = f->tail->parentEdge; fillTableUp(e,g,A,D,T); /*recursive call*/ h = siblingEdge(f); A[e->head->index][f->head->index] = A[f->head->index][e->head->index] = (g->topsize*A[e->head->index][g->head->index] + h->bottomsize*A[e->head->index][h->head->index])/f->topsize; } } void makeOLSAveragesTable(tree *T, double **D, double **A); double **buildAveragesTable(tree *T, double **D) { int i,j; double **A; A = (double **) malloc(T->size*sizeof(double *)); for(i = 0; i < T->size;i++) { A[i] = (double *) malloc(T->size*sizeof(double)); for(j=0;jsize;j++) A[i][j] = 0.0; } makeOLSAveragesTable(T,D,A); return(A); } double wf2(double lambda, double D_AD, double D_BC, double D_AC, double D_BD, double D_AB, double D_CD) { double weight; weight = 0.5*(lambda*(D_AC + D_BD) + (1 - lambda)*(D_AD + D_BC) + (D_AB + D_CD)); return(weight); } int NNIEdgeTest(edge *e, tree *T, double **A, double *weight) { int a,b,c,d; edge *f; double *lambda; double D_LR, D_LU, D_LD, D_RD, D_RU, D_DU; double w1,w2,w0; if ((leaf(e->tail)) || (leaf(e->head))) return(NONE); lambda = (double *)malloc(3*sizeof(double)); a = e->tail->parentEdge->topsize; f = siblingEdge(e); b = f->bottomsize; c = e->head->leftEdge->bottomsize; d = e->head->rightEdge->bottomsize; lambda[0] = ((double) b*c + a*d)/((a + b)*(c+d)); lambda[1] = ((double) b*c + a*d)/((a + c)*(b+d)); lambda[2] = ((double) c*d + a*b)/((a + d)*(b+c)); D_LR = A[e->head->leftEdge->head->index][e->head->rightEdge->head->index]; D_LU = A[e->head->leftEdge->head->index][e->tail->index]; D_LD = A[e->head->leftEdge->head->index][f->head->index]; D_RU = A[e->head->rightEdge->head->index][e->tail->index]; D_RD = A[e->head->rightEdge->head->index][f->head->index]; D_DU = A[e->tail->index][f->head->index]; w0 = wf2(lambda[0],D_RU,D_LD,D_LU,D_RD,D_DU,D_LR); w1 = wf2(lambda[1],D_RU,D_LD,D_DU,D_LR,D_LU,D_RD); w2 = wf2(lambda[2],D_DU,D_LR,D_LU,D_RD,D_RU,D_LD); free(lambda); if (w0 <= w1) { if (w0 <= w2) /*w0 <= w1,w2*/ { *weight = 0.0; return(NONE); } else /*w2 < w0 <= w1 */ { *weight = w2 - w0; /* if (verbose) { printf("Swap across %s. ",e->label); printf("Weight dropping by %lf.\n",w0 - w2); printf("New weight should be %lf.\n",T->weight + w2 - w0); }*/ return(RIGHT); } } else if (w2 <= w1) /*w2 <= w1 < w0*/ { *weight = w2 - w0; /* if (verbose) { printf("Swap across %s. ",e->label); printf("Weight dropping by %lf.\n",w0 - w2); printf("New weight should be %lf.\n",T->weight + w2 - w0); }*/ return(RIGHT); } else /*w1 < w2, w0*/ { *weight = w1 - w0; /* if (verbose) { printf("Swap across %s. ",e->label); printf("Weight dropping by %lf.\n",w0 - w1); printf("New weight should be %lf.\n",T->weight + w1 - w0); }*/ return(LEFT); } } int *initPerm(int size); void NNIupdateAverages(double **A, edge *e, edge *par, edge *skew, edge *swap, edge *fixed, tree *T) { node *v; edge *elooper; v = e->head; /*first, v*/ A[e->head->index][e->head->index] = (swap->bottomsize* ((skew->bottomsize*A[skew->head->index][swap->head->index] + fixed->bottomsize*A[fixed->head->index][swap->head->index]) / e->bottomsize) + par->topsize* ((skew->bottomsize*A[skew->head->index][par->head->index] + fixed->bottomsize*A[fixed->head->index][par->head->index]) / e->bottomsize) ) / e->topsize; elooper = findBottomLeft(e); /*next, we loop over all the edges which are below e*/ while (e != elooper) { A[e->head->index][elooper->head->index] = A[elooper->head->index][v->index] = (swap->bottomsize*A[elooper->head->index][swap->head->index] + par->topsize*A[elooper->head->index][par->head->index]) / e->topsize; elooper = depthFirstTraverse(T,elooper); } elooper = findBottomLeft(swap); /*next we loop over all the edges below and including swap*/ while (swap != elooper) { A[e->head->index][elooper->head->index] = A[elooper->head->index][e->head->index] = (skew->bottomsize * A[elooper->head->index][skew->head->index] + fixed->bottomsize*A[elooper->head->index][fixed->head->index]) / e->bottomsize; elooper = depthFirstTraverse(T,elooper); } /*now elooper = skew */ A[e->head->index][elooper->head->index] = A[elooper->head->index][e->head->index] = (skew->bottomsize * A[elooper->head->index][skew->head->index] + fixed->bottomsize* A[elooper->head->index][fixed->head->index]) / e->bottomsize; /*finally, we loop over all the edges in the tree on the far side of parEdge*/ elooper = T->root->leftEdge; while ((elooper != swap) && (elooper != e)) /*start a top-first traversal*/ { A[e->head->index][elooper->head->index] = A[elooper->head->index][e->head->index] = (skew->bottomsize * A[elooper->head->index][skew->head->index] + fixed->bottomsize* A[elooper->head->index][fixed->head->index]) / e->bottomsize; elooper = topFirstTraverse(T,elooper); } /*At this point, elooper = par. We finish the top-first traversal, excluding the subtree below par*/ elooper = moveUpRight(par); while (NULL != elooper) { A[e->head->index][elooper->head->index] = A[elooper->head->index][e->head->index] = (skew->bottomsize * A[elooper->head->index][skew->head->index] + fixed->bottomsize* A[elooper->head->index][fixed->head->index]) / e->bottomsize; elooper = topFirstTraverse(T,elooper); } } void NNItopSwitch(tree *T, edge *e, int direction, double **A) { edge *par, *fixed; edge *skew, *swap; /* if (verbose) printf("Branch swap across edge %s.\n",e->label);*/ if (LEFT == direction) swap = e->head->leftEdge; else swap = e->head->rightEdge; skew = siblingEdge(e); fixed = siblingEdge(swap); par = e->tail->parentEdge; /* if (verbose) { printf("Branch swap: switching edges %s and %s.\n",skew->label,swap->label); }*/ /*perform topological switch by changing f from (u,b) to (v,b) and g from (v,c) to (u,c), necessitatates also changing parent fields*/ swap->tail = e->tail; skew->tail = e->head; if (LEFT == direction) e->head->leftEdge = skew; else e->head->rightEdge = skew; if (skew == e->tail->rightEdge) e->tail->rightEdge = swap; else e->tail->leftEdge = swap; /*both topsize and bottomsize change for e, but nowhere else*/ e->topsize = par->topsize + swap->bottomsize; e->bottomsize = fixed->bottomsize + skew->bottomsize; NNIupdateAverages(A, e, par, skew, swap, fixed,T); } /*end NNItopSwitch*/ void reHeapElement(int *p, int *q, double *v, int length, int i); void pushHeap(int *p, int *q, double *v, int length, int i); void popHeap(int *p, int *q, double *v, int length, int i); void NNIRetestEdge(int *p, int *q, edge *e,tree *T, double **avgDistArray, double *weights, int *location, int *possibleSwaps) { int tloc; tloc = location[e->head->index+1]; location[e->head->index+1] = NNIEdgeTest(e,T,avgDistArray,weights + e->head->index+1); if (NONE == location[e->head->index+1]) { if (NONE != tloc) popHeap(p,q,weights,(*possibleSwaps)--,q[e->head->index+1]); } else { if (NONE == tloc) pushHeap(p,q,weights,(*possibleSwaps)++,q[e->head->index+1]); else reHeapElement(p,q,weights,*possibleSwaps,q[e->head->index+1]); } } void permInverse(int *p, int *q, int length); int makeThreshHeap(int *p, int *q, double *v, int arraySize, double thresh); //void NNI(tree *T, double **avgDistArray, int *count) void NNI(tree *T, double **avgDistArray, int *count, double **D, int numSpecies) { edge *e, *centerEdge; edge **edgeArray; int *location; int *p,*q; int i,j; int possibleSwaps; double *weights; p = initPerm(T->size+1); q = initPerm(T->size+1); edgeArray = (edge **) malloc((T->size+1)*sizeof(double)); weights = (double *) malloc((T->size+1)*sizeof(double)); location = (int *) malloc((T->size+1)*sizeof(int)); double epsilon = 0.0; for (i=0; isize+1;i++) { weights[i] = 0.0; location[i] = NONE; } e = findBottomLeft(T->root->leftEdge); /* *count = 0; */ while (NULL != e) { edgeArray[e->head->index+1] = e; location[e->head->index+1] = NNIEdgeTest(e,T,avgDistArray,weights + e->head->index + 1); e = depthFirstTraverse(T,e); } possibleSwaps = makeThreshHeap(p,q,weights,T->size+1,0.0); permInverse(p,q,T->size+1); /*we put the negative values of weights into a heap, indexed by p with the minimum value pointed to by p[1]*/ /*p[i] is index (in edgeArray) of edge with i-th position in the heap, q[j] is the position of edge j in the heap */ while (weights[p[1]] + epsilon < 0) { centerEdge = edgeArray[p[1]]; (*count)++; T->weight = T->weight + weights[p[1]]; NNItopSwitch(T,edgeArray[p[1]],location[p[1]],avgDistArray); location[p[1]] = NONE; weights[p[1]] = 0.0; /*after the NNI, this edge is in optimal configuration*/ popHeap(p,q,weights,possibleSwaps--,1); /*but we must retest the other four edges*/ e = centerEdge->head->leftEdge; NNIRetestEdge(p,q,e,T,avgDistArray,weights,location,&possibleSwaps); e = centerEdge->head->rightEdge; NNIRetestEdge(p,q,e,T,avgDistArray,weights,location,&possibleSwaps); e = siblingEdge(centerEdge); NNIRetestEdge(p,q,e,T,avgDistArray,weights,location,&possibleSwaps); e = centerEdge->tail->parentEdge; NNIRetestEdge(p,q,e,T,avgDistArray,weights,location,&possibleSwaps); } free(p); free(q); free(location); free(edgeArray); } /* void NNIwithoutMatrix(tree *T, double **D, int *count) { double **avgDistArray; avgDistArray = buildAveragesTable(T,D); NNI(T,avgDistArray,count); } void NNIWithPartialMatrix(tree *T,double **D,double **A,int *count) { makeOLSAveragesTable(T,D,A); NNI(T,A,count); } */ ape/src/TBR.c0000644000175100001440000005156413017516351012434 0ustar hornikusers/* TBR.c 2014-03-04 */ /* Copyright 2009 Richard Desper */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include "me.h" /*functions from me_balanced.c*/ void makeBMEAveragesTable(tree *T, double **D, double **A); void assignBMEWeights(tree *T, double **A); /*from me.c*/ edge *siblingEdge(edge *e); double **initDoubleMatrix(int d); void freeMatrix(double **D, int size); edge *depthFirstTraverse(tree *T, edge *e); edge *findBottomLeft(edge *e); /*from bnni.c*/ void weighTree(tree *T); void freeTree(tree *T); /*from SPR.c*/ void zero3DMatrix(double ***X, int h, int l, int w); void assignTBRDownWeightsUp(edge *etest, node *vtest, node *va, edge *back, node *cprev, double oldD_AB, double coeff, double **A, double ***swapWeights, double *bestWeight, edge **eBestSplit, edge **eBestTop, edge **eBestBottom); void assignTBRDownWeightsSkew(edge *etest, node *vtest, node *va, edge *back, node *cprev, double oldD_AB, double coeff, double **A, double ***swapWeights, double *bestWeight, edge **eBestSplit, edge **eBestTop, edge **eBestBototm); void assignTBRDownWeightsDown(edge *etest, node *vtest, node *va, edge *back, node *cprev, double oldD_AB, double coeff, double **A, double ***swapWeights, double *bestWeight, edge **eBestSplit, edge **eBestTop, edge **eBestBottom); void assignTBRUpWeights(edge *ebottom, node *vtest, node *va, edge *back, node *cprev, double oldD_AB, double coeff, double **A, double **dXTop, double ***swapWeights, edge *etop, double *bestWeight, edge **bestSplit, edge **bestTop, edge **bestBottom) /*function assigns the value for etop if the tree below vtest is moved to be below etop*/ /*and SPR for tree bottom tree splits ebottom*/ /*recursive function searching over values of ebottom*/ /*minor variant of SPR.c's assignUpWeights difference is the index assignment in the array swapWeights, which has a different meaning for the TBR routines*/ /*also using dXTop to assign value of average distance to tree above vtest*/ { /*SPR performed on tree above vtest...*/ edge *sib, *left, *right; /*B is above vtest, A is other tree below vtest unioned with trees in path to vtest*/ /*sib is tree C being passed by B*/ /*D is tree below etest*/ double D_AB, D_CD, D_AC, D_BD; sib = siblingEdge(ebottom); left = ebottom->head->leftEdge; right = ebottom->head->rightEdge; if (NULL == etop) { if (NULL == back) /*first recursive call*/ { if (NULL == left) return; /*no subtree below for SPR*/ else /*NULL == back and NULL == etop*/ { assignTBRUpWeights(left,vtest,va,ebottom,va,A[va->index][vtest->index],0.5,A,dXTop,swapWeights,NULL,bestWeight,bestSplit,bestTop,bestBottom); assignTBRUpWeights(right,vtest,va,ebottom,va,A[va->index][vtest->index],0.5,A,dXTop,swapWeights,NULL,bestWeight,bestSplit,bestTop,bestBottom); } } else /*NULL != back*/ { D_BD = A[ebottom->head->index][vtest->index]; /*B is tree above vtest, D is tree below ebottom*/ D_CD = A[sib->head->index][ebottom->head->index]; /*C is tree below sib*/ D_AC = A[back->head->index][sib->head->index] + coeff*(A[va->index][sib->head->index] - A[vtest->index][sib->head->index]); /*va is root of subtree skew back at vtest*/ /*A is union of tree below va and all subtrees already passed in path from vtest to ebottom*/ D_AB = 0.5*(oldD_AB + A[vtest->index][cprev->index]); swapWeights[vtest->index][ebottom->head->index][ebottom->head->index] = swapWeights[vtest->index][back->head->index][back->head->index] + (D_AC + D_BD - D_AB - D_CD); if (swapWeights[vtest->index][ebottom->head->index][ebottom->head->index] < *bestWeight) { *bestSplit = vtest->parentEdge; *bestTop = NULL; *bestBottom = ebottom; *bestWeight = swapWeights[vtest->index][ebottom->head->index][ebottom->head->index]; } if (NULL != left) { assignTBRUpWeights(left,vtest,va,ebottom,sib->head,D_AB,0.5*coeff,A,dXTop,swapWeights,NULL,bestWeight,bestSplit,bestTop,bestBottom); assignTBRUpWeights(right,vtest,va,ebottom,sib->head,D_AB,0.5*coeff,A,dXTop,swapWeights,NULL,bestWeight,bestSplit,bestTop,bestBottom); } } } else /*NULL != etop*/ { if (NULL == back) /*first recursive call*/ { if (swapWeights[vtest->index][etop->head->index][etop->head->index]< *bestWeight) /*this represents value of SPR from esplit to etop, with no SPR in bottom tree*/ { *bestSplit = vtest->parentEdge; *bestTop = etop; *bestBottom = NULL; *bestWeight = swapWeights[vtest->index][etop->head->index][etop->head->index]; } if (NULL == left) return; /*no subtree below for SPR*/ else if (NULL != etop)/*start the process of assigning weights recursively*/ { assignTBRUpWeights(left,vtest,va,ebottom,va,dXTop[va->index][etop->head->index],0.5,A,dXTop,swapWeights,etop,bestWeight,bestSplit,bestTop,bestBottom); assignTBRUpWeights(right,vtest,va,ebottom,va,dXTop[va->index][etop->head->index],0.5,A,dXTop,swapWeights,etop,bestWeight,bestSplit,bestTop,bestBottom); } } /*NULL == back*/ /*in following bit, any average distance of form A[vtest->index][x->index] is replaced by dXTop[x->index][etop->head->index]*/ else /*second or later recursive call, NULL != etop*/ { D_BD = dXTop[ebottom->head->index][etop->head->index]; /*B is tree above vtest - it is in configuration indexed by etop*/ /*D is tree below ebottom*/ D_CD = A[sib->head->index][ebottom->head->index]; /*C is tree below sib*/ D_AC = A[back->head->index][sib->head->index] + coeff*(A[va->index][sib->head->index] - A[sib->head->index][vtest->index]); /*it is correct to use A[][] here because the bad average distances involving B from the first term will be cancelled by the bad average distances involving B in the subtracted part*/ /*va is root of subtree skew back at vtest*/ /*A is union of tree below va and all subtrees already passed in path from vtest to ebottom*/ D_AB = 0.5*(oldD_AB + dXTop[cprev->index][etop->head->index]); swapWeights[vtest->index][ebottom->head->index][etop->head->index] = swapWeights[vtest->index][back->head->index][etop->head->index] + (D_AC + D_BD - D_AB - D_CD); if (swapWeights[vtest->index][ebottom->head->index][etop->head->index] + swapWeights[vtest->index][etop->head->index][etop->head->index]< *bestWeight) /*first term is contribution of second SPR, second term is contribution of first SPR*/ { *bestSplit = vtest->parentEdge; *bestTop = etop; *bestBottom = ebottom; *bestWeight = swapWeights[vtest->index][ebottom->head->index][etop->head->index] + swapWeights[vtest->index][etop->head->index][etop->head->index]; } if (NULL != left) { assignTBRUpWeights(left,vtest, va, ebottom, sib->head, D_AB, 0.5*coeff, A, dXTop, swapWeights,etop,bestWeight,bestSplit,bestTop,bestBottom); assignTBRUpWeights(right,vtest, va, ebottom, sib->head, D_AB, 0.5*coeff, A, dXTop, swapWeights,etop,bestWeight,bestSplit,bestTop,bestBottom); } } /*else NULL != back, etop*/ } } /*recall NNI formula: change in tree length from AB|CD split to AC|BD split is proportional to D_AC + D_BD - D_AB - D_CD*/ /*in our case B is the tree being moved (below vtest), A is the tree backwards below back, but with the vtest subtree removed, C is the sibling tree of back and D is the tree above vtest*/ /*use va to denote the root of the sibling tree to B in the original tree*/ /*please excuse the multiple uses of the same letters: A,D, etc.*/ void assignTBRDownWeightsUp(edge *etest, node *vtest, node *va, edge *back, node *cprev, double oldD_AB, double coeff, double **A, double ***swapWeights, double *bestWeight, edge **bestSplitEdge, edge **bestTop, edge **bestBottom) { edge *par, *sib, *skew; double D_AC, D_BD, D_AB, D_CD; par = etest->tail->parentEdge; skew = siblingEdge(etest); if (NULL == back) /*first recursive call*/ { if (NULL == par) return; else /*start the process of assigning weights recursively*/ { assignTBRDownWeightsUp(par,vtest,va,etest,va,A[va->index][vtest->index],0.5,A,swapWeights,bestWeight,bestSplitEdge,bestTop,bestBottom); assignTBRDownWeightsSkew(skew,vtest,va,etest,va,A[va->index][vtest->index],0.5,A,swapWeights,bestWeight,bestSplitEdge,bestTop,bestBottom); } } else /*second or later recursive call*/ { sib = siblingEdge(back); D_BD = A[vtest->index][etest->head->index]; /*straightforward*/ D_CD = A[sib->head->index][etest->head->index]; /*this one too*/ D_AC = A[sib->head->index][back->head->index] + coeff*(A[sib->head->index][va->index] - A[sib->head->index][vtest->index]); D_AB = 0.5*(oldD_AB + A[vtest->index][cprev->index]); swapWeights[vtest->index][etest->head->index][etest->head->index] = swapWeights[vtest->index][back->head->index][back->head->index] + (D_AC + D_BD - D_AB - D_CD); /*using diagonal to store values for SPR swaps above the split edge*/ /*this is value of swapping tree below vtest to break etest*/ if (swapWeights[vtest->index][etest->head->index][etest->head->index] < *bestWeight) { *bestWeight = swapWeights[vtest->index][etest->head->index][etest->head->index]; *bestSplitEdge = vtest->parentEdge; *bestTop = etest; *bestBottom = NULL; } if (NULL != par) { assignTBRDownWeightsUp(par,vtest,va,etest,sib->head,D_AB,0.5*coeff,A,swapWeights,bestWeight,bestSplitEdge,bestTop,bestBottom); assignTBRDownWeightsSkew(skew,vtest,va,etest,sib->head,D_AB,0.5*coeff,A,swapWeights,bestWeight,bestSplitEdge,bestTop,bestBottom); } } } void assignTBRDownWeightsSkew(edge *etest, node *vtest, node *va, edge *back, node *cprev, double oldD_AB, double coeff, double **A, double ***swapWeights, double *bestWeight, edge **bestSplitEdge, edge **bestTop, edge **bestBottom) { /*same general idea as assignDownWeights, except needing to keep track of things a bit differently*/ edge *par, *left, *right; /*par here = sib before left, right here = par, skew before*/ double D_AB, D_CD, D_AC, D_BD; /*B is subtree being moved - below vtest A is subtree remaining fixed - below va, unioned with all trees already passed by B*/ /*C is subtree being passed by B, in this case above par D is subtree below etest, fixed on other side*/ par = etest->tail->parentEdge; left = etest->head->leftEdge; right = etest->head->rightEdge; if (NULL == back) { if (NULL == left) return; else { assignTBRDownWeightsDown(left,vtest,va,etest,etest->tail,A[vtest->index][etest->tail->index],0.5,A,swapWeights,bestWeight,bestSplitEdge,bestTop,bestBottom); assignTBRDownWeightsDown(right,vtest,va,etest,etest->tail,A[vtest->index][etest->tail->index],0.5,A,swapWeights,bestWeight,bestSplitEdge,bestTop,bestBottom); } } else { D_BD = A[vtest->index][etest->head->index]; D_CD = A[par->head->index][etest->head->index]; D_AC = A[back->head->index][par->head->index] + coeff*(A[va->index][par->head->index] - A[vtest->index][par->head->index]); D_AB = 0.5*(oldD_AB + A[vtest->index][cprev->index]); swapWeights[vtest->index][etest->head->index][etest->head->index] = swapWeights[vtest->index][back->head->index][back->head->index] + (D_AC + D_BD - D_AB - D_CD); if (swapWeights[vtest->index][etest->head->index][etest->head->index] < *bestWeight) { *bestWeight = swapWeights[vtest->index][etest->head->index][etest->head->index]; *bestSplitEdge = vtest->parentEdge; *bestTop = etest; *bestBottom = NULL; } if (NULL != left) { assignTBRDownWeightsDown(left,vtest, va, etest, etest->tail, D_AB, 0.5*coeff, A, swapWeights,bestWeight,bestSplitEdge,bestTop,bestBottom); assignTBRDownWeightsDown(right,vtest, va, etest, etest->tail, D_AB, 0.5*coeff, A, swapWeights,bestWeight,bestSplitEdge,bestTop,bestBottom); } } } void assignTBRDownWeightsDown(edge *etest, node *vtest, node *va, edge *back, node *cprev, double oldD_AB, double coeff, double **A, double ***swapWeights, double *bestWeight, edge **bestSplitEdge, edge **bestTop, edge **bestBottom) { /*again the same general idea*/ edge *sib, *left, *right; /*sib here = par in assignDownWeightsSkew rest is the same as assignDownWeightsSkew*/ double D_AB, D_CD, D_AC, D_BD; /*B is below vtest, A is below va unioned with all trees already passed by B*/ /*C is subtree being passed - below sib*/ /*D is tree below etest*/ sib = siblingEdge(etest); left = etest->head->leftEdge; right = etest->head->rightEdge; D_BD = A[vtest->index][etest->head->index]; D_CD = A[sib->head->index][etest->head->index]; D_AC = A[sib->head->index][back->head->index] + coeff*(A[sib->head->index][va->index] - A[sib->head->index][vtest->index]); D_AB = 0.5*(oldD_AB + A[vtest->index][cprev->index]); swapWeights[vtest->index][etest->head->index][etest->head->index] = swapWeights[vtest->index][back->head->index][back->head->index] + ( D_AC + D_BD - D_AB - D_CD); if (swapWeights[vtest->index][etest->head->index][etest->head->index] < *bestWeight) { *bestWeight = swapWeights[vtest->index][etest->head->index][etest->head->index]; *bestSplitEdge = vtest->parentEdge; *bestTop = etest; *bestBottom = NULL; } if (NULL != left) { assignTBRDownWeightsDown(left,vtest, va, etest, sib->head, D_AB, 0.5*coeff, A, swapWeights,bestWeight,bestSplitEdge,bestTop,bestBottom); assignTBRDownWeightsDown(right,vtest, va, etest, sib->head, D_AB, 0.5*coeff, A, swapWeights,bestWeight,bestSplitEdge,bestTop,bestBottom); } } /*general idea is to have a double loop for a given edge, testing all SPRs for the subtrees above and below a given edge. Then that function loops over all the edges of a tree*/ void TBRswitch(tree *T, edge *e1, edge *e2, edge *e3); /*vbottom is node below esplit for average calculations in matrix dXTop, A is matrix of average distances from original tree, dXout is average distance from vbottom to tree rooted at far edge of eback, if SPR breaking eback, UpOrDown indicates whether etop is in path above split edge (Up) or not (Down)*/ void calcTBRTopBottomAverage(node *vbottom, double **A, double **dXTop, double dXOut, edge *esplit, edge *etop, edge *eback, int UpOrDown) { edge *enew1, *enew2, *emove; double newdXOut; if (esplit == eback) /*top level call - means trivial SPR*/ dXTop[vbottom->index][etop->head->index] = A[vbottom->index][esplit->head->index]; else dXTop[vbottom->index][etop->head->index] = dXTop[vbottom->index][eback->head->index] + 0.25*(A[vbottom->index][etop->head->index] - dXOut); /*by moving etop past the vbottom tree, everything in the etop tree is closer by coefficient of 0.25, while everything in the old back tree is further by a coefficient of 0.25*/ /*everything in the tree that is being moved (emove) keeps the same relative weight in the average distance calculation*/ if (UP == UpOrDown) { enew1 = etop->tail->parentEdge; if (NULL != enew1) /*need to do recursive calls*/ { enew2 = siblingEdge(etop); emove = siblingEdge(eback); /*emove is third edge meeting at vertex with eback, etest*/ if (esplit == eback) newdXOut = A[vbottom->index][emove->head->index]; else newdXOut = 0.5*(dXOut + A[vbottom->index][emove->head->index]); calcTBRTopBottomAverage(vbottom,A,dXTop,newdXOut,esplit, enew1,etop,UP); /*old etop is new value for back*/ calcTBRTopBottomAverage(vbottom,A,dXTop,newdXOut,esplit, enew2,etop,DOWN); } } else /*moving down*/ { enew1 = etop->head->leftEdge; if (NULL != enew1) { enew2 = etop->head->rightEdge; if (eback == siblingEdge(etop)) emove = etop->tail->parentEdge; else emove = siblingEdge(etop); if (esplit == eback) newdXOut = A[vbottom->index][emove->head->index]; else newdXOut = 0.5*(dXOut + A[vbottom->index][emove->head->index]); calcTBRTopBottomAverage(vbottom,A,dXTop,newdXOut,esplit,enew1,etop,DOWN); calcTBRTopBottomAverage(vbottom,A,dXTop,newdXOut,esplit,enew2,etop,DOWN); } } } void calcTBRaverages(tree *T, edge *esplit, double **A, double **dXTop) { edge *ebottom, *par, *sib; for (ebottom = findBottomLeft(esplit); ebottom != esplit; ebottom = depthFirstTraverse(T,ebottom)) { par = esplit->tail->parentEdge; sib = siblingEdge(esplit); calcTBRTopBottomAverage(ebottom->head,A, dXTop, 0.0, esplit, par,esplit,UP); calcTBRTopBottomAverage(ebottom->head,A, dXTop, 0.0, esplit, sib,esplit,DOWN); } } void TBR(tree *T, double **D, double **A) { int i; edge *esplit, *etop, *eBestTop, *eBestBottom, *eBestSplit; edge *eout, *block; edge *left, *right, *par, *sib; double **dXTop; /*dXTop[i][j] is average distance from subtree rooted at i to tree above split edge, if SPR above split edge cuts edge whose head has index j*/ double bestWeight; double ***TBRWeights; dXTop = initDoubleMatrix(T->size); weighTree(T); TBRWeights = (double ***)calloc(T->size,sizeof(double **)); for(i=0;isize;i++) TBRWeights[i] = initDoubleMatrix(T->size); do { zero3DMatrix(TBRWeights,T->size,T->size,T->size); bestWeight = 0.0; eBestSplit = eBestTop = eBestBottom = NULL; for(esplit=depthFirstTraverse(T,NULL);NULL!=esplit;esplit=depthFirstTraverse(T,esplit)) { par = esplit->tail->parentEdge; if (NULL != par) { sib = siblingEdge(esplit); /*next two lines calculate the possible improvements for any SPR above esplit*/ assignTBRDownWeightsUp(par,esplit->head,sib->head,NULL,NULL,0.0,1.0,A,TBRWeights,&bestWeight,&eBestSplit,&eBestTop,&eBestBottom); assignTBRDownWeightsSkew(sib,esplit->head,sib->tail,NULL,NULL,0.0,1.0,A,TBRWeights,&bestWeight,&eBestSplit,&eBestTop,&eBestBottom); calcTBRaverages(T,esplit,A,dXTop); /*calculates the average distance from any subtree below esplit to the entire subtree above esplit, after any possible SPR above*/ /*for etop above esplit, we loop using information from above to calculate values for all possible SPRs below esplit*/ } right = esplit->head->rightEdge; if (NULL != right) { left = esplit->head->leftEdge; /*test case: etop = null means only do bottom SPR*/ assignTBRUpWeights(left,esplit->head,right->head,NULL,NULL,0.0,1.0,A,dXTop,TBRWeights,NULL,&bestWeight,&eBestSplit,&eBestTop,&eBestBottom); assignTBRUpWeights(right,esplit->head,left->head,NULL,NULL,0.0,1.0,A,dXTop,TBRWeights,NULL,&bestWeight,&eBestSplit,&eBestTop,&eBestBottom); block = esplit; while (NULL != block) { if (block != esplit) { etop = block; assignTBRUpWeights(left,esplit->head,right->head,NULL,NULL,0.0,1.0,A,dXTop,TBRWeights,etop,&bestWeight,&eBestSplit,&eBestTop,&eBestBottom); assignTBRUpWeights(right,esplit->head,left->head,NULL,NULL,0.0,1.0,A,dXTop,TBRWeights,etop,&bestWeight,&eBestSplit,&eBestTop,&eBestBottom); } eout = siblingEdge(block); if (NULL != eout) { etop = findBottomLeft(eout); while (etop->tail != eout->tail) { /*for ebottom below esplit*/ assignTBRUpWeights(left,esplit->head,right->head,NULL,NULL,0.0,1.0,A,dXTop,TBRWeights,etop,&bestWeight,&eBestSplit,&eBestTop,&eBestBottom); assignTBRUpWeights(right,esplit->head,left->head,NULL,NULL,0.0,1.0,A,dXTop,TBRWeights,etop,&bestWeight,&eBestSplit,&eBestTop,&eBestBottom); etop = depthFirstTraverse(T,etop); } /*etop == eout*/ assignTBRUpWeights(left,esplit->head,right->head,NULL,NULL,0.0,1.0,A,dXTop,TBRWeights,etop,&bestWeight,&eBestSplit,&eBestTop,&eBestBottom); assignTBRUpWeights(right,esplit->head,left->head,NULL,NULL,0.0,1.0,A,dXTop,TBRWeights,etop,&bestWeight,&eBestSplit,&eBestTop,&eBestBottom); } block = block->tail->parentEdge; } } /*if NULL != right*/ } /*for esplit*/ /*find bestWeight, best split edge, etc.*/ if (bestWeight < -EPSILON) { // if (verbose) // { // printf("TBR #%d: Splitting edge %s: top edge %s, bottom edge %s\n",*count+1, // eBestSplit->label, eBestTop->label,eBestBottom->label); // printf("Old tree weight is %lf, new tree weight should be %lf\n",T->weight, T->weight + 0.25*bestWeight); // } TBRswitch(T,eBestSplit,eBestTop,eBestBottom); makeBMEAveragesTable(T,D,A); assignBMEWeights(T,A); weighTree(T); // if (verbose) // printf("TBR: new tree weight is %lf\n\n",T->weight);< // (*count)++; } else bestWeight = 1.0; } while (bestWeight < -EPSILON); for(i=0;isize;i++) freeMatrix(TBRWeights[i],T->size); freeMatrix(dXTop,T->size); free(TBRWeights); /* added by EP 2014-03-04 */ } void SPRTopShift(tree *T, node *v, edge *e, int UpOrDown); void TBRswitch(tree *T, edge *es, edge *et, edge *eb) { if (NULL != et) SPRTopShift(T,es->head,et,DOWN); /*DOWN because tree being moved is below split edge*/ if (NULL != eb) SPRTopShift(T,es->head,eb,UP); /*UP because tree being moved is above split edge*/ } ape/src/pic.c0000644000175100001440000000205313017516351012545 0ustar hornikusers/* pic.c 2006-11-13 */ /* Copyright 2006 Emmanuel Paradis */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include void C_pic(int *ntip, int *nnode, int *edge1, int *edge2, double *edge_len, double *phe, double *contr, double *var_contr, int *var, int *scaled) { /* The tree must be in pruningwise order */ int anc, d1, d2, ic, i, j, k; double sumbl; for (i = 0; i < *ntip * 2 - 3; i += 2) { j = i + 1; anc = edge1[i]; d1 = edge2[i] - 1; d2 = edge2[j] - 1; sumbl = edge_len[i] + edge_len[j]; ic = anc - *ntip - 1; contr[ic] = phe[d1] - phe[d2]; if (*scaled) contr[ic] = contr[ic]/sqrt(sumbl); if (*var) var_contr[ic] = sumbl; phe[anc - 1] = (phe[d1]*edge_len[j] + phe[d2]*edge_len[i])/sumbl; /* find the edge where `anc' is a descendant (except if at the root): it is obviously below the j'th edge */ if (j != *ntip * 2 - 3) { k = j + 1; while (edge2[k] != anc) k++; edge_len[k] = edge_len[k] + edge_len[i]*edge_len[j]/sumbl; } } } ape/src/nj.c0000644000175100001440000000672513017516351012413 0ustar hornikusers/* nj.c 2011-10-20 */ /* Copyright 2006-2011 Emmanuel Paradis */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include "ape.h" double sum_dist_to_i(int n, double *D, int i) /* returns the sum of all distances D_ij between i and j with j = 1...n and j != i */ { /* we use the fact that the distances are arranged sequentially in the lower triangle, e.g. with n = 6 the 15 distances are stored as (the C indices are indicated): i 1 2 3 4 5 2 0 3 1 5 j 4 2 6 9 5 3 7 10 12 6 4 8 11 13 14 so that we sum the values of the ith column--1st loop--and those of (i - 1)th row (labelled 'i')--2nd loop */ double sum = 0; int j, start, end; if (i < n) { /* the expression below CANNOT be factorized because of the integer operations (it took me a while to find out...) */ start = n*(i - 1) - i*(i - 1)/2; end = start + n - i; for (j = start; j < end; j++) sum += D[j]; } if (i > 1) { start = i - 2; for (j = 1; j <= i - 1; j++) { sum += D[start]; start += n - j - 1; } } return(sum); } void C_nj(double *D, int *N, int *edge1, int *edge2, double *edge_length) { double *S, Sdist, Ndist, *new_dist, A, B, smallest_S, x, y; int n, i, j, k, ij, smallest, OTU1, OTU2, cur_nod, o_l, *otu_label; S = &Sdist; new_dist = &Ndist; otu_label = &o_l; n = *N; cur_nod = 2*n - 2; S = (double*)R_alloc(n + 1, sizeof(double)); new_dist = (double*)R_alloc(n*(n - 1)/2, sizeof(double)); otu_label = (int*)R_alloc(n + 1, sizeof(int)); for (i = 1; i <= n; i++) otu_label[i] = i; /* otu_label[0] is not used */ k = 0; while (n > 3) { for (i = 1; i <= n; i++) S[i] = sum_dist_to_i(n, D, i); /* S[0] is not used */ ij = 0; smallest_S = 1e50; B = n - 2; for (i = 1; i < n; i++) { for (j = i + 1; j <= n; j++) { A = B*D[ij] - S[i] - S[j]; if (A < smallest_S) { OTU1 = i; OTU2 = j; smallest_S = A; smallest = ij; } ij++; } } edge2[k] = otu_label[OTU1]; edge2[k + 1] = otu_label[OTU2]; edge1[k] = edge1[k + 1] = cur_nod; /* get the distances between all OTUs but the 2 selected ones and the latter: a) get the sum for both b) compute the distances for the new OTU */ A = D[smallest]; ij = 0; for (i = 1; i <= n; i++) { if (i == OTU1 || i == OTU2) continue; x = D[give_index(i, OTU1, n)]; /* dist between OTU1 and i */ y = D[give_index(i, OTU2, n)]; /* dist between OTU2 and i */ new_dist[ij] = (x + y - A)/2; ij++; } /* compute the branch lengths */ B = (S[OTU1] - S[OTU2])/B; /* don't need B anymore */ edge_length[k] = (A + B)/2; edge_length[k + 1] = (A - B)/2; /* update before the next loop (we are sure that OTU1 < OTU2) */ if (OTU1 != 1) for (i = OTU1; i > 1; i--) otu_label[i] = otu_label[i - 1]; if (OTU2 != n) for (i = OTU2; i < n; i++) otu_label[i] = otu_label[i + 1]; otu_label[1] = cur_nod; for (i = 1; i < n; i++) { if (i == OTU1 || i == OTU2) continue; for (j = i + 1; j <= n; j++) { if (j == OTU1 || j == OTU2) continue; new_dist[ij] = D[DINDEX(i, j)]; ij++; } } n--; for (i = 0; i < n*(n - 1)/2; i++) D[i] = new_dist[i]; cur_nod--; k = k + 2; } for (i = 0; i < 3; i++) { edge1[*N*2 - 4 - i] = cur_nod; edge2[*N*2 - 4 - i] = otu_label[i + 1]; } edge_length[*N*2 - 4] = (D[0] + D[1] - D[2])/2; edge_length[*N*2 - 5] = (D[0] + D[2] - D[1])/2; edge_length[*N*2 - 6] = (D[2] + D[1] - D[0])/2; } ape/src/bipartition.c0000644000175100001440000001453613017516351014327 0ustar hornikusers/* bipartition.c 2014-01-02 */ /* Copyright 2005-2014 Emmanuel Paradis */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include "ape.h" SEXP seq_root2tip(SEXP edge, SEXP nbtip, SEXP nbnode) { int i, j, k, Nedge, *x, *done, dn, sumdone, lt, ROOT, Ntip, Nnode; SEXP ans, seqnod, tmp_vec; /* The following is needed only if we are not sure that the storage mode of `edge' is "integer". */ PROTECT(edge = coerceVector(edge, INTSXP)); PROTECT(nbtip = coerceVector(nbtip, INTSXP)); PROTECT(nbnode = coerceVector(nbnode, INTSXP)); x = INTEGER(edge); /* copy the pointer */ Ntip = *INTEGER(nbtip); Nnode = *INTEGER(nbnode); Nedge = LENGTH(edge)/2; ROOT = Ntip + 1; PROTECT(ans = allocVector(VECSXP, Ntip)); PROTECT(seqnod = allocVector(VECSXP, Nnode)); done = &dn; done = (int*)R_alloc(Nnode, sizeof(int)); for (i = 0; i < Nnode; i++) done[i] = 0; tmp_vec = allocVector(INTSXP, 1); INTEGER(tmp_vec)[0] = ROOT; /* sure ? */ SET_VECTOR_ELT(seqnod, 0, tmp_vec); sumdone = 0; while (sumdone < Nnode) { for (i = 0; i < Nnode; i++) { /* loop through all nodes */ /* if the vector is not empty and its */ /* descendants are not yet found */ if (VECTOR_ELT(seqnod, i) == R_NilValue || done[i]) continue; /* look for the descendants in 'edge': */ for (j = 0; j < Nedge; j++) { /* skip the terminal edges, we look only for nodes now */ if (x[j] - Ntip != i + 1 || x[j + Nedge] <= Ntip) continue; /* can now make the sequence from */ /* the root to the current node */ lt = LENGTH(VECTOR_ELT(seqnod, i)); tmp_vec = allocVector(INTSXP, lt + 1); for (k = 0; k < lt; k++) INTEGER(tmp_vec)[k] = INTEGER(VECTOR_ELT(seqnod, i))[k]; INTEGER(tmp_vec)[lt] = x[j + Nedge]; SET_VECTOR_ELT(seqnod, x[j + Nedge] - Ntip - 1, tmp_vec); } done[i] = 1; sumdone++; } } /* build the sequence from root to tip */ /* by simply looping through 'edge' */ for (i = 0; i < Nedge; i++) { /* skip the internal edges */ if (x[i + Nedge] > Ntip) continue; lt = LENGTH(VECTOR_ELT(seqnod, x[i] - Ntip - 1)); tmp_vec = allocVector(INTSXP, lt + 1); for (j = 0; j < lt; j++) INTEGER(tmp_vec)[j] = INTEGER(VECTOR_ELT(seqnod, x[i] - Ntip - 1))[j]; INTEGER(tmp_vec)[lt] = x[i + Nedge]; SET_VECTOR_ELT(ans, x[i + Nedge] - 1, tmp_vec); } UNPROTECT(5); return ans; } /* EOF seq_root2tip */ SEXP bipartition(SEXP edge, SEXP nbtip, SEXP nbnode) { int i, j, k, lt, lt2, inod, Ntip, Nnode; SEXP ans, seqnod, tmp_vec; PROTECT(edge = coerceVector(edge, INTSXP)); PROTECT(nbtip = coerceVector(nbtip, INTSXP)); PROTECT(nbnode = coerceVector(nbnode, INTSXP)); Ntip = *INTEGER(nbtip); Nnode = *INTEGER(nbnode); PROTECT(ans = allocVector(VECSXP, Nnode)); PROTECT(seqnod = seq_root2tip(edge, nbtip, nbnode)); for (i = 0; i < LENGTH(seqnod); i++) { /* for each tip */ lt = LENGTH(VECTOR_ELT(seqnod, i)); for (j = 0; j < lt - 1; j++) { inod = INTEGER(VECTOR_ELT(seqnod, i))[j] - Ntip - 1; if (VECTOR_ELT(ans, inod) == R_NilValue) { tmp_vec = allocVector(INTSXP, 1); INTEGER(tmp_vec)[0] = i + 1; } else { lt2 = LENGTH(VECTOR_ELT(ans, inod)); tmp_vec = allocVector(INTSXP, lt2 + 1); for (k = 0; k < lt2; k++) INTEGER(tmp_vec)[k] = INTEGER(VECTOR_ELT(ans, inod))[k]; INTEGER(tmp_vec)[lt2] = i + 1; } SET_VECTOR_ELT(ans, inod, tmp_vec); } } UNPROTECT(5); return ans; } /* bipartition */ int SameClade(SEXP clade1, SEXP clade2) { int i, n = LENGTH(clade1), *c1, *c2; if (n != LENGTH(clade2)) return 0; c1 = INTEGER(clade1); c2 = INTEGER(clade2); for (i = 0; i < n; i++) if (c1[i] != c2[i]) return 0; return 1; } SEXP prop_part(SEXP TREES, SEXP nbtree, SEXP keep_partitions) { int i, j, k, KeepPartition, Ntree, Ntip, Nnode, Npart, NpartCurrent, *no; SEXP bp, ans, nbtip, nbnode, number; PROTECT(nbtree = coerceVector(nbtree, INTSXP)); PROTECT(keep_partitions = coerceVector(keep_partitions, INTSXP)); Ntree = *INTEGER(nbtree); KeepPartition = *INTEGER(keep_partitions); Ntip = LENGTH(getListElement(VECTOR_ELT(TREES, 0), "tip.label")); Nnode = *INTEGER(getListElement(VECTOR_ELT(TREES, 0), "Nnode")); PROTECT(nbtip = allocVector(INTSXP, 1)); PROTECT(nbnode = allocVector(INTSXP, 1)); INTEGER(nbtip)[0] = Ntip; INTEGER(nbnode)[0] = Nnode; if (KeepPartition) Npart = Ntree * (Ntip - 2) + 1; else Npart = Ntip - 1; PROTECT(number = allocVector(INTSXP, Npart)); no = INTEGER(number); /* copy the pointer */ /* The first partition in the returned list has all tips, so it is observed in all trees: */ no[0] = Ntree; /* The partitions in the first tree are obviously observed once: */ for (i = 1; i < Nnode; i++) no[i] = 1; if (KeepPartition) { for (i = Nnode; i < Npart; i++) no[i] = 0; PROTECT(ans = allocVector(VECSXP, Npart)); PROTECT(bp = bipartition(getListElement(VECTOR_ELT(TREES, 0), "edge"), nbtip, nbnode)); for (i = 0; i < Nnode; i++) SET_VECTOR_ELT(ans, i, VECTOR_ELT(bp, i)); UNPROTECT(1); } else { PROTECT(ans = bipartition(getListElement(VECTOR_ELT(TREES, 0), "edge"), nbtip, nbnode)); } NpartCurrent = Nnode; /* We start on the 2nd tree: */ for (k = 1; k < Ntree; k++) { /* in case there are trees with multichotomies: */ nbnode = getListElement(VECTOR_ELT(TREES, k), "Nnode"); Nnode = INTEGER(nbnode)[0]; PROTECT(bp = bipartition(getListElement(VECTOR_ELT(TREES, k), "edge"), nbtip, nbnode)); for (i = 1; i < Nnode; i++) { j = 1; next_j: if (SameClade(VECTOR_ELT(bp, i), VECTOR_ELT(ans, j))) { no[j]++; continue; } j++; if (j < NpartCurrent) goto next_j; if (KeepPartition) { no[NpartCurrent]++; SET_VECTOR_ELT(ans, NpartCurrent, VECTOR_ELT(bp, i)); NpartCurrent++; } } UNPROTECT(1); } if (KeepPartition && NpartCurrent < Npart) { PROTECT(bp = allocVector(VECSXP, NpartCurrent)); for (i = 0; i < NpartCurrent; i++) SET_VECTOR_ELT(bp, i, VECTOR_ELT(ans, i)); setAttrib(bp, install("number"), number); UNPROTECT(7); return bp; } else { setAttrib(ans, install("number"), number); UNPROTECT(6); return ans; } } /* prop_part */ ape/src/heap.c0000644000175100001440000000507213017516351012713 0ustar hornikusers/* heap.c 2007-09-05 */ /* Copyright 2007 Vincent Lefort */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include "me.h" int *initPerm(int size) { int *p; int i; p = (int *) malloc(size*sizeof(int)); for(i = 0;i 0) && (v[p[here]] < v[p[up]])) while ((up > 0) && (v[p[here]] < v[p[up]])) /*we push the new value up the heap*/ { swap(p,q,up,here); here = up; up = here / 2; } else heapify(p,q,v,i,length); } void popHeap(int *p, int *q, double *v, int length, int i) { swap(p,q,i,length); /*puts new value at the last position in the heap*/ reHeapElement(p,q, v,length-1,i); /*put the swapped guy in the right place*/ } void pushHeap(int *p, int *q, double *v, int length, int i) { swap(p,q,i,length+1); /*puts new value at the last position in the heap*/ reHeapElement(p,q, v,length+1,length+1); /*put that guy in the right place*/ } int makeThreshHeap(int *p, int *q, double *v, int arraySize, double thresh) { int i, heapsize; heapsize = 0; for(i = 1; i < arraySize;i++) if(v[q[i]] < thresh) pushHeap(p,q,v,heapsize++,i); return(heapsize); } ape/src/delta_plot.c0000644000175100001440000000312413017516351014121 0ustar hornikusers/* delta_plot.c 2011-06-23 */ /* Copyright 2010-2011 Emmanuel Paradis */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include void delta_plot(double *D, int *size, int *nbins, int *counts, double *deltabar) { int x, y, u, v; /* same notation than in Holland et al. 2002 */ int n = *size, nb = *nbins; double dxy, dxu, dxv, dyu, dyv, duv, A, B, C, delta; int xy, xu, xv, yu, yv, uv, i; for (x = 0; x < n - 3; x++) { xy = x*n - x*(x + 1)/2; /* do NOT factorize */ for (y = x + 1; y < n - 2; y++, xy++) { yu = y*n - y*(y + 1)/2; /* do NOT factorize */ dxy = D[xy]; xu = xy + 1; for (u = y + 1; u < n - 1; u++, xu++, yu++) { uv = u*n - u*(u + 1)/2; /* do NOT factorize */ dxu = D[xu]; dyu = D[yu]; xv = xu + 1; yv = yu + 1; for (v = u + 1; v < n; v++, xv++, yv++, uv++) { dxv = D[xv]; dyv = D[yv]; duv = D[uv]; A = dxv + dyu; B = dxu + dyv; C = dxy + duv; if (A == B && B == C) delta = 0; else while (1) { if (C <= B && B <= A) {delta = (A - B)/(A - C); break;} if (B <= C && C <= A) {delta = (A - C)/(A - B); break;} if (A <= C && C <= B) {delta = (B - C)/(B - A); break;} if (C <= A && A <= B) {delta = (B - A)/(B - C); break;} if (A <= B && B <= C) {delta = (C - B)/(C - A); break;} if (B <= A && A <= C) {delta = (C - A)/(C - B); break;} } /* if (delta == 1) i = nb - 1; else */ i = delta * nb; counts[i] += 1; deltabar[x] += delta; deltabar[y] += delta; deltabar[u] += delta; deltabar[v] += delta; } } } } } ape/src/tree_build.c0000644000175100001440000001165013017516351014113 0ustar hornikusers/* tree_build.c 2011-06-23 */ /* Copyright 2008-2011 Emmanuel Paradis */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include #include static int str2int(char *x, int n) { int i, k = 1, ans = 0; for (i = n - 1; i >= 0; i--, k *= 10) ans += ((int)x[i] - 48) * k; return ans; } void extract_portion_Newick(const char *x, int a, int b, char *y) { int i, j; for (i = a, j = 0; i <= b; i++, j++) y[j] = x[i]; y[j] = '\0'; } void decode_terminal_edge_token(const char *x, int a, int b, int *node, double *w) { int co = a; char *endstr, str[100]; while (x[co] != ':') co++; extract_portion_Newick(x, a, co - 1, str); *node = str2int(str, co - a); extract_portion_Newick(x, co + 1, b, str); *w = R_strtod(str, &endstr); } void decode_internal_edge(const char *x, int a, int b, char *lab, double *w) { int co = a; char *endstr, str[100]; while (x[co] != ':') co++; if (a == co) lab[0] = '\0'; /* if no node label */ else extract_portion_Newick(x, a, co - 1, lab); extract_portion_Newick(x, co + 1, b, str); *w = R_strtod(str, &endstr); } #define ADD_INTERNAL_EDGE \ e[j] = curnode; \ e[j + nedge] = curnode = ++node; \ stack_internal[k++] = j; \ j++ #define ADD_TERMINAL_EDGE \ e[j] = curnode; \ decode_terminal_edge_token(x, pr + 1, ps - 1, &tmpi, &tmpd); \ e[j + nedge] = tmpi; \ el[j] = tmpd; \ j++ #define GO_DOWN \ decode_internal_edge(x, ps + 1, pt - 1, lab, &tmpd); \ SET_STRING_ELT(node_label, curnode - 1 - ntip, mkChar(lab)); \ l = stack_internal[--k]; \ el[l] = tmpd; \ curnode = e[l] SEXP treeBuildWithTokens(SEXP nwk) { const char *x; int n, i, ntip = 1, nnode = 0, nedge, *e, curnode, node, j, *skeleton, nsk = 0, ps, pr, pt, tmpi, l, k, stack_internal[10000]; double *el, tmpd; char lab[512]; SEXP edge, edge_length, Nnode, node_label, phy; PROTECT(nwk = coerceVector(nwk, STRSXP)); x = CHAR(STRING_ELT(nwk, 0)); n = strlen(x); skeleton = (int *)R_alloc(n, sizeof(int *)); /* first pass on the Newick string to localize parentheses and commas */ for (i = 0; i < n; i++) { if (x[i] == '(') { skeleton[nsk] = i; nsk++; continue; } if (x[i] == ',') { skeleton[nsk] = i; nsk++; ntip++; continue; } if (x[i] == ')') { skeleton[nsk] = i; nsk++; nnode++; } } nedge = ntip + nnode - 1; PROTECT(Nnode = allocVector(INTSXP, 1)); PROTECT(edge = allocVector(INTSXP, nedge*2)); PROTECT(edge_length = allocVector(REALSXP, nedge)); PROTECT(node_label = allocVector(STRSXP, nnode)); INTEGER(Nnode)[0] = nnode; e = INTEGER(edge); el = REAL(edge_length); curnode = node = ntip + 1; k = j = 0; /* j: index of the current position in the edge matrix */ /* k: index of the current position in stack_internal */ /* stack_internal is a simple array storing the indices of the successive internal edges from the root; it's a stack so it is incremented every time an internal edge is added, and decremented every GO_DOWN step. This makes easy to the index of the subtending edge. */ /* second pass on the Newick string to build the "phylo" object elements */ for (i = 1; i < nsk - 1; i++) { ps = skeleton[i]; // Rprintf(""); /* <- again !!!! */ if (x[ps] == '(') { ADD_INTERNAL_EDGE; continue; } pr = skeleton[i - 1]; if (x[ps] == ',') { if (x[pr] != ')') { /* !!! accolades indispensables !!! */ ADD_TERMINAL_EDGE; } continue; } if (x[ps] == ')') { pt = skeleton[i + 1]; // <- utile ??? if (x[pr] == ',') { ADD_TERMINAL_EDGE; GO_DOWN; continue; } if (x[pr] == ')') { GO_DOWN; } } } pr = skeleton[nsk - 2]; ps = skeleton[nsk - 1]; /* is the last edge terminal? */ if (x[pr] == ',' && x[ps] == ')') { ADD_TERMINAL_EDGE; } /* is there a root edge and/or root label? */ if (ps < n - 2) { i = ps + 1; while (i < n - 2 && x[i] != ':') i++; if (i < n - 2) { PROTECT(phy = allocVector(VECSXP, 5)); SEXP root_edge; decode_internal_edge(x, ps + 1, n - 2, lab, &tmpd); PROTECT(root_edge = allocVector(REALSXP, 1)); REAL(root_edge)[0] = tmpd; SET_VECTOR_ELT(phy, 4, root_edge); UNPROTECT(1); SET_STRING_ELT(node_label, 0, mkChar(lab)); } else { extract_portion_Newick(x, ps + 1, n - 2, lab); SET_STRING_ELT(node_label, 0, mkChar(lab)); PROTECT(phy = allocVector(VECSXP, 4)); } } else PROTECT(phy = allocVector(VECSXP, 4)); SET_VECTOR_ELT(phy, 0, edge); SET_VECTOR_ELT(phy, 1, edge_length); SET_VECTOR_ELT(phy, 2, Nnode); SET_VECTOR_ELT(phy, 3, node_label); UNPROTECT(6); return phy; } #undef ADD_INTERNAL_EDGE #undef ADD_TERMINAL_EDGE #undef GO_DOWN ape/src/ewLasso.c0000644000175100001440000001215613017516351013414 0ustar hornikusers/* ewLasso.c 2013-03-30 */ /* Copyright 2013 Andrei-Alin Popescu */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include "ape.h" int isTripletCover(int nmb, int n, int** s, int stat, int sSoFar[n], int* a)//number of sides, number of leaves, sides, side under consideration, set so far, lasso { int ret=0; if(stat==nmb)return 1; int i=0; for(i=1;i<=n;i++) { if(!s[stat][i])continue;//not in set int sw=1, j; for(j=1;j<=n;j++)//check if all distances to previous candidates are present { if(!sSoFar[j])continue;//not in set so far if(!a[i*(n+1)+j]){//if not, then i is not a good candidate for this side //Rprintf("failed to find distance between %i and %i, a[%i][%i]=%i \n",i,j,i,j,a[i*(n+1)+j]); sw=0; } } if(!sw)continue;//not all required distances are present sSoFar[i]=1;//try choosing i as representative for the side ret+=isTripletCover(nmb,n,s,stat+1,sSoFar,a)>0?1:0;//see if, with i chosen, we can find leaves in other sides to satisfy the triplet cover condition sSoFar[i]=0; } return ret; } void C_ewLasso(double *D, int *N, int *e1, int *e2) { int n, i, j, k; n=*N; int tCov=1; int* a = (int*)R_alloc((n+1)*(n+1), sizeof(int));//adjacency matrix of G_{\cL} graph for(i=1;i<=n;i++) { for(j=1;j<=n;j++) { if(D[give_index(i,j,n)]==-1)//if missing value then no edge between pair of taxa (i,j) in G { a[i*(n+1)+j]=a[j*(n+1)+i]=0; } else { a[i*(n+1)+j]=a[j*(n+1)+i]=1;// otherwise edge between pair of taxa (i,j) in G } } } //check for connectedness of G int *q = (int*)R_alloc(2*n-1, sizeof(int));//BFS queue int *v = (int*)R_alloc(2*n-1, sizeof(int));//visited? int p=0,u=1;//p-head of queue, u- position after last loaded element for(i=1;i<=n;i++)v[i]=-1; int stNBipartite=1, con=1, comp=1; int ini=1; /*for(i=1;i<=n;i++) { for(j=1;j<=n;j++) { Rprintf("a[%i][%i]=%i ",i,j,a[i*(n+1)+j]); } Rprintf("\n"); }*/ while(comp) { q[p]=ini; v[ini]=1; comp=0; int stNBipartiteLoc=0;//check if current connected component is bipartite while(p not bipartite { stNBipartiteLoc=1; } if(v[i]!=-1)continue; //Rprintf("vertex %i \n",i); q[u++]=i; v[i]=1-v[head]; } p++; } stNBipartite*=stNBipartiteLoc;//anding strngly-non-bipartite over all connected components //check if all vertices have been visited for(int i=1;i<=n;i++) { if(v[i]==-1) { comp=1; p=0; u=1; ini=i; con=0; break; } } } Rprintf("connected: %i\n",con); Rprintf("strongly non-bipartite: %i\n",stNBipartite); //finally check if \cL is triplet cover of T //adjencency matrix of tree, 1 to n are leaves int *at= (int*)R_alloc((2*n-1)*(2*n-1), sizeof(int)); for(i=1;i<=2*n-2;i++) { for(j=1;j<=2*n-2;j++)at[i*(2*n-1)+j]=0; } for(i=0;i<2*n-3;i++) { //Rprintf("e1[%i]=%i e2[%i]=%i \n",i,e1[i],i,e2[i]); at[e1[i]*(2*n-1)+e2[i]]=at[e2[i]*(2*n-1)+e1[i]]=1; } /*for(i=1;i<2*n-1;i++) { for(j=1;j<2*n-1;j++) { Rprintf("at[%i][%i]=%i ",i,j,at[i*(2*n-1)+j]); } Rprintf("\n"); }*/ for(i=n+1;i<=2*n-2;i++)//for each interior vertex { for(j=1;j<2*n-1;j++)//reset queue and visited veectors { v[j]=-1; q[j]=0; } v[i]=1;//'disconnect' graph at i int *l=(int*)R_alloc(2*n-2, sizeof(int));//vertices adjacent to i int nmb=0;//number of found adjacent vertices of i for(j=1;j<=2*n-2;j++)//find adjacent vertices { if(at[i*(2*n-1)+j]==1) { l[nmb++]=j; } } int** s=(int**)R_alloc(nmb,sizeof(int*));//set of leaves in each side, stored as presence/absence for(j=0;j0?1:0; } Rprintf("is triplet cover? %i \n",tCov); } ape/src/mvrs.c0000644000175100001440000003473513017516351012775 0ustar hornikusers/* mvrs.c 2013-09-26 */ /* Copyright 2011-2012 Andrei-Alin Popescu */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include "ape.h" void C_mvrs(double *D, double* v,int *N, int *edge1, int *edge2, double *edge_length,int* fsS) { //assume missing values are denoted by -1 double *S,*R ,*new_v, Sdist, Ndist, *new_dist, A, B, smallest_S; int n, i, j, k, ij, OTU1, OTU2, cur_nod, o_l, *otu_label; /*for(i=0;i 3) { ij = 0; for(i=1;i smallest_S) { OTU1 = i; OTU2 = j; smallest_S = A; /* smallest = ij; */ } ij++; } } } if(s[give_index(OTU1,OTU2,n)]<=2) {error("distance information insufficient to construct a tree, leaves %i and %i isolated from tree",OTU1,OTU2); } //Rprintf("agglomerating %i and %i, Q=%f \n",OTU1,OTU2,smallest_S); /*for(i=1;i 1; i--) otu_label[i] = otu_label[i - 1]; if (OTU2 != n) for (i = OTU2; i < n; i++) otu_label[i] = otu_label[i + 1]; otu_label[1] = cur_nod; n--; for (i = 0; i < n*(n - 1)/2; i++) { D[i] = new_dist[i]; v[i] = new_v[i]; if(sw==1) { R[i] = newR[i]; s[i] = newS[i]; } } cur_nod--; k = k + 2; } int dK=0;//number of known distances in final distance matrix int iUK=-1;//index of unkown distance, if we have one missing distance int iK=-1;//index of only known distance, only needed if dK==1 for (i = 0; i < 3; i++) { edge1[*N*2 - 4 - i] = cur_nod; edge2[*N*2 - 4 - i] = otu_label[i + 1]; if(D[i]!=-1){dK++;iK=i;}else{iUK=i;} } if(dK==2) {//if two distances are known: assume our leaves are x,y,z, d(x,z) unknown //and edge weights of three edges are a,b,c, then any b,c>0 that //satisfy c-b=d(y,z)-d(x,y) a+c=d(y,z) are good edge weights, but for //simplicity we assume a=c if d(yz)max)max=D[i]; } D[iUK]=max; } if(dK==1) {//through similar motivation as above, if we have just one known distance //we set the other two distances equal to it for(i=0;i<3;i++) {if(i==iK)continue; D[i]=D[iK]; } } if(dK==0) {//no distances are known, we just set them to 1 for(i=0;i<3;i++) {D[i]=1; } } edge_length[*N*2 - 4] = (D[0] + D[1] - D[2])/2; edge_length[*N*2 - 5] = (D[0] + D[2] - D[1])/2; edge_length[*N*2 - 6] = (D[2] + D[1] - D[0])/2; } ape/src/bNNI.c0000644000175100001440000002500313017516351012560 0ustar hornikusers/* bNNI.c 2013-09-26 */ /* Copyright 2007 Vincent Lefort */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include "me.h" /*boolean leaf(node *v); edge *siblingEdge(edge *e); edge *depthFirstTraverse(tree *T, edge *e); edge *findBottomLeft(edge *e); edge *topFirstTraverse(tree *T, edge *e); edge *moveUpRight(edge *e);*/ void limitedFillTableUp(edge *e, edge *f, double **A, edge *trigger); void assignBMEWeights(tree *T, double **A); //void updateAveragesMatrix(tree *T, double **A, node *v,int direction); void bNNItopSwitch(tree *T, edge *e, int direction, double **A); int bNNIEdgeTest(edge *e, tree *T, double **A, double *weight); void updatePair(double **A, edge *nearEdge, edge *farEdge, node *closer, node *further, double dcoeff, int direction); int *initPerm(int size); void reHeapElement(int *p, int *q, double *v, int length, int i); void pushHeap(int *p, int *q, double *v, int length, int i); void popHeap(int *p, int *q, double *v, int length, int i); void bNNIRetestEdge(int *p, int *q, edge *e,tree *T, double **avgDistArray, double *weights, int *location, int *possibleSwaps) { int tloc; tloc = location[e->head->index+1]; location[e->head->index+1] = bNNIEdgeTest(e,T,avgDistArray,weights + e->head->index+1); if (NONE == location[e->head->index+1]) { if (NONE != tloc) popHeap(p,q,weights,(*possibleSwaps)--,q[e->head->index+1]); } else { if (NONE == tloc) pushHeap(p,q,weights,(*possibleSwaps)++,q[e->head->index+1]); else reHeapElement(p,q,weights,*possibleSwaps,q[e->head->index+1]); } } int makeThreshHeap(int *p, int *q, double *v, int arraySize, double thresh); void permInverse(int *p, int *q, int length); void weighTree(tree *T) { edge *e; T->weight = 0; for(e = depthFirstTraverse(T,NULL);NULL!=e;e=depthFirstTraverse(T,e)) T->weight += e->distance; } //void bNNI(tree *T, double **avgDistArray, int *count) void bNNI(tree *T, double **avgDistArray, int *count, double **D, int numSpecies) { edge *e;//, *centerEdge deleted by EP, 2013-09-26, see also below edge **edgeArray; int *p, *location, *q; int i,j; int possibleSwaps; double *weights; p = initPerm(T->size+1); q = initPerm(T->size+1); edgeArray = (edge **) malloc((T->size+1)*sizeof(double)); weights = (double *) malloc((T->size+1)*sizeof(double)); location = (int *) malloc((T->size+1)*sizeof(int)); double epsilon = 0.0; for (i=0; isize+1;i++) { weights[i] = 0.0; location[i] = NONE; } /* if (verbose) { assignBMEWeights(T,avgDistArray); weighTree(T); }*/ e = findBottomLeft(T->root->leftEdge); while (NULL != e) { edgeArray[e->head->index+1] = e; location[e->head->index+1] = bNNIEdgeTest(e,T,avgDistArray,weights + e->head->index + 1); e = depthFirstTraverse(T,e); } possibleSwaps = makeThreshHeap(p,q,weights,T->size+1,0.0); permInverse(p,q,T->size+1); /*we put the negative values of weights into a heap, indexed by p with the minimum value pointed to by p[1]*/ /*p[i] is index (in edgeArray) of edge with i-th position in the heap, q[j] is the position of edge j in the heap */ while (weights[p[1]] + epsilon < 0) { /* centerEdge = edgeArray[p[1]]; apparently unused later, deleted by EP, 2013-09-26 */ (*count)++; /* if (verbose) { T->weight = T->weight + weights[p[1]]; printf("New tree weight is %lf.\n",T->weight); }*/ bNNItopSwitch(T,edgeArray[p[1]],location[p[1]],avgDistArray); location[p[1]] = NONE; weights[p[1]] = 0.0; /*after the bNNI, this edge is in optimal configuration*/ popHeap(p,q,weights,possibleSwaps--,1); /*but we must retest the other edges of T*/ /*CHANGE 2/28/2003 expanding retesting to _all_ edges of T*/ e = depthFirstTraverse(T,NULL); while (NULL != e) { bNNIRetestEdge(p,q,e,T,avgDistArray,weights,location,&possibleSwaps); e = depthFirstTraverse(T,e); } } free(p); free(q); free(location); free(edgeArray); free(weights); assignBMEWeights(T,avgDistArray); } /*This function is the meat of the average distance matrix recalculation*/ /*Idea is: we are looking at the subtree rooted at rootEdge. The subtree rooted at closer is closer to rootEdge after the NNI, while the subtree rooted at further is further to rootEdge after the NNI. direction tells the direction of the NNI with respect to rootEdge*/ void updateSubTreeAfterNNI(double **A, node *v, edge *rootEdge, node *closer, node *further, double dcoeff, int direction) { edge *sib; switch(direction) { case UP: /*rootEdge is below the center edge of the NNI*/ /*recursive calls to subtrees, if necessary*/ if (NULL != rootEdge->head->leftEdge) updateSubTreeAfterNNI(A, v, rootEdge->head->leftEdge, closer, further, 0.5*dcoeff,UP); if (NULL != rootEdge->head->rightEdge) updateSubTreeAfterNNI(A, v, rootEdge->head->rightEdge, closer, further, 0.5*dcoeff,UP); updatePair(A, rootEdge, rootEdge, closer, further, dcoeff, UP); sib = siblingEdge(v->parentEdge); A[rootEdge->head->index][v->index] = A[v->index][rootEdge->head->index] = 0.5*A[rootEdge->head->index][sib->head->index] + 0.5*A[rootEdge->head->index][v->parentEdge->tail->index]; break; case DOWN: /*rootEdge is above the center edge of the NNI*/ sib = siblingEdge(rootEdge); if (NULL != sib) updateSubTreeAfterNNI(A, v, sib, closer, further, 0.5*dcoeff, SKEW); if (NULL != rootEdge->tail->parentEdge) updateSubTreeAfterNNI(A, v, rootEdge->tail->parentEdge, closer, further, 0.5*dcoeff, DOWN); updatePair(A, rootEdge, rootEdge, closer, further, dcoeff, DOWN); A[rootEdge->head->index][v->index] = A[v->index][rootEdge->head->index] = 0.5*A[rootEdge->head->index][v->leftEdge->head->index] + 0.5*A[rootEdge->head->index][v->rightEdge->head->index]; break; case SKEW: /*rootEdge is in subtree skew to v*/ if (NULL != rootEdge->head->leftEdge) updateSubTreeAfterNNI(A, v, rootEdge->head->leftEdge, closer, further, 0.5*dcoeff,SKEW); if (NULL != rootEdge->head->rightEdge) updateSubTreeAfterNNI(A, v, rootEdge->head->rightEdge, closer, further, 0.5*dcoeff,SKEW); updatePair(A, rootEdge, rootEdge, closer, further, dcoeff, UP); A[rootEdge->head->index][v->index] = A[v->index][rootEdge->head->index] = 0.5*A[rootEdge->head->index][v->leftEdge->head->index] + 0.5*A[rootEdge->head->index][v->rightEdge->head->index]; break; } } /*swapping across edge whose head is v*/ void bNNIupdateAverages(double **A, node *v, edge *par, edge *skew, edge *swap, edge *fixed) { A[v->index][v->index] = 0.25*(A[fixed->head->index][par->head->index] + A[fixed->head->index][swap->head->index] + A[skew->head->index][par->head->index] + A[skew->head->index][swap->head->index]); updateSubTreeAfterNNI(A, v, fixed, skew->head, swap->head, 0.25, UP); updateSubTreeAfterNNI(A, v, par, swap->head, skew->head, 0.25, DOWN); updateSubTreeAfterNNI(A, v, skew, fixed->head, par->head, 0.25, UP); updateSubTreeAfterNNI(A, v, swap, par->head, fixed->head, 0.25, SKEW); } void bNNItopSwitch(tree *T, edge *e, int direction, double **A) { edge *down, *swap, *fixed; node *u, *v; /* if (verbose) { printf("Performing branch swap across edge %s ",e->label); printf("with "); if (LEFT == direction) printf("left "); else printf("right "); printf("subtree.\n"); }*/ down = siblingEdge(e); u = e->tail; v = e->head; if (LEFT == direction) { swap = e->head->leftEdge; fixed = e->head->rightEdge; v->leftEdge = down; } else { swap = e->head->rightEdge; fixed = e->head->leftEdge; v->rightEdge = down; } swap->tail = u; down->tail = v; if(e->tail->leftEdge == e) u->rightEdge = swap; else u->leftEdge = swap; bNNIupdateAverages(A, v, e->tail->parentEdge, down, swap, fixed); } double wf5(double D_AD, double D_BC, double D_AC, double D_BD, double D_AB, double D_CD) { double weight; weight = 0.25*(D_AC + D_BD + D_AD + D_BC) + 0.5*(D_AB + D_CD); return(weight); } int bNNIEdgeTest(edge *e, tree *T, double **A, double *weight) { edge *f; double D_LR, D_LU, D_LD, D_RD, D_RU, D_DU; double w1,w2,w0; /* if (verbose) printf("Branch swap: testing edge %s.\n",e->label);*/ if ((leaf(e->tail)) || (leaf(e->head))) return(NONE); f = siblingEdge(e); D_LR = A[e->head->leftEdge->head->index][e->head->rightEdge->head->index]; D_LU = A[e->head->leftEdge->head->index][e->tail->index]; D_LD = A[e->head->leftEdge->head->index][f->head->index]; D_RU = A[e->head->rightEdge->head->index][e->tail->index]; D_RD = A[e->head->rightEdge->head->index][f->head->index]; D_DU = A[e->tail->index][f->head->index]; w0 = wf5(D_RU,D_LD,D_LU,D_RD,D_DU,D_LR); /*weight of current config*/ w1 = wf5(D_RU,D_LD,D_DU,D_LR,D_LU,D_RD); /*weight with L<->D switch*/ w2 = wf5(D_DU,D_LR,D_LU,D_RD,D_RU,D_LD); /*weight with R<->D switch*/ if (w0 <= w1) { if (w0 <= w2) /*w0 <= w1,w2*/ { *weight = 0.0; return(NONE); } else /*w2 < w0 <= w1 */ { *weight = w2 - w0; /* if (verbose) { printf("Possible swap across %s. ",e->label); printf("Weight dropping by %lf.\n",w0 - w2); printf("New weight would be %lf.\n",T->weight + w2 - w0); }*/ return(RIGHT); } } else if (w2 <= w1) /*w2 <= w1 < w0*/ { *weight = w2 - w0; /* if (verbose) { printf("Possible swap across %s. ",e->label); printf("Weight dropping by %lf.\n",w0 - w2); printf("New weight should be %lf.\n",T->weight + w2 - w0); }*/ return(RIGHT); } else /*w1 < w2, w0*/ { *weight = w1 - w0; /* if (verbose) { printf("Possible swap across %s. ",e->label); printf("Weight dropping by %lf.\n",w0 - w1); printf("New weight should be %lf.\n",T->weight + w1 - w0); }*/ return(LEFT); } } /*limitedFillTableUp fills all the entries in D associated with e->head,f->head and those edges g->head above e->head, working recursively and stopping when trigger is reached*/ void limitedFillTableUp(edge *e, edge *f, double **A, edge *trigger) { edge *g,*h; g = f->tail->parentEdge; if (f != trigger) limitedFillTableUp(e,g,A,trigger); h = siblingEdge(f); A[e->head->index][f->head->index] = A[f->head->index][e->head->index] = 0.5*(A[e->head->index][g->head->index] + A[e->head->index][h->head->index]); } ape/src/mvr.c0000644000175100001440000001357113017516351012605 0ustar hornikusers/* mvr.c 2012-05-02 */ /* Copyright 2011-2012 Andrei-Alin Popescu */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include "ape.h" void C_mvr(double *D, double* v,int *N, int *edge1, int *edge2, double *edge_length) { double *S, Sdist, *new_v, Ndist, *new_dist, A, B, smallest_S; int n, i, j, k, ij, smallest, OTU1, OTU2, cur_nod, o_l, *otu_label; S = &Sdist; new_dist = &Ndist; otu_label = &o_l; n = *N; cur_nod = 2*n - 2; S = (double*)R_alloc(n + 1, sizeof(double)); new_dist = (double*)R_alloc(n*(n - 1)/2, sizeof(double)); new_v = (double*)R_alloc(n*(n - 1)/2, sizeof(double)); otu_label = (int*)R_alloc(n + 1, sizeof(int)); for (i = 1; i <= n; i++) otu_label[i] = i; /* otu_label[0] is not used */ k = 0; while (n > 3) { /*for(i=1;i 1; i--) otu_label[i] = otu_label[i - 1]; if (OTU2 != n) for (i = OTU2; i < n; i++) otu_label[i] = otu_label[i + 1]; otu_label[1] = cur_nod; for (i = 1; i < n; i++) { if (i == OTU1 || i == OTU2) continue; for (j = i + 1; j <= n; j++) { if (j == OTU1 || j == OTU2) continue; new_dist[ij] = D[DINDEX(i, j)]; new_v[ij]=v[give_index(i,j,n)]; ij++; } } n--; for (i = 0; i < n*(n - 1)/2; i++) {D[i] = new_dist[i]; v[i] = new_v[i]; } cur_nod--; k = k + 2; } for (i = 0; i < 3; i++) { edge1[*N*2 - 4 - i] = cur_nod; edge2[*N*2 - 4 - i] = otu_label[i + 1]; } edge_length[*N*2 - 4] = (D[0] + D[1] - D[2])/2; edge_length[*N*2 - 5] = (D[0] + D[2] - D[1])/2; edge_length[*N*2 - 6] = (D[2] + D[1] - D[0])/2; } ape/src/read_dna.c0000644000175100001440000001241113017516351013526 0ustar hornikusers/* read_dna.c 2016-06-21 */ /* Copyright 2013-2016 Emmanuel Paradis */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include #include // The initial code defining and initialising the translation table: // // for (i = 0; i < 122; i++) tab_trans[i] = 0x00; // // tab_trans[65] = 0x88; /* A */ // tab_trans[71] = 0x48; /* G */ // tab_trans[67] = 0x28; /* C */ // tab_trans[84] = 0x18; /* T */ // tab_trans[82] = 0xc0; /* R */ // tab_trans[77] = 0xa0; /* M */ // tab_trans[87] = 0x90; /* W */ // tab_trans[83] = 0x60; /* S */ // tab_trans[75] = 0x50; /* K */ // tab_trans[89] = 0x30; /* Y */ // tab_trans[86] = 0xe0; /* V */ // tab_trans[72] = 0xb0; /* H */ // tab_trans[68] = 0xd0; /* D */ // tab_trans[66] = 0x70; /* B */ // tab_trans[78] = 0xf0; /* N */ // // tab_trans[97] = 0x88; /* a */ // tab_trans[103] = 0x48; /* g */ // tab_trans[99] = 0x28; /* c */ // tab_trans[116] = 0x18; /* t */ // tab_trans[114] = 0xc0; /* r */ // tab_trans[109] = 0xa0; /* m */ // tab_trans[119] = 0x90; /* w */ // tab_trans[115] = 0x60; /* s */ // tab_trans[107] = 0x50; /* k */ // tab_trans[121] = 0x30; /* y */ // tab_trans[118] = 0xe0; /* v */ // tab_trans[104] = 0xb0; /* h */ // tab_trans[100] = 0xd0; /* d */ // tab_trans[98] = 0x70; /* b */ // tab_trans[110] = 0xf0; /* n */ // // tab_trans[45] = 0x04; /* - */ // tab_trans[63] = 0x02; /* ? */ static const unsigned char tab_trans[] = { 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 0-9 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 10-19 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 20-29 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 30-39 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x04, 0x00, 0x00, 0x00, 0x00, /* 40-49 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 50-59 */ 0x00, 0x00, 0x00, 0x02, 0x00, 0x88, 0x70, 0x28, 0xd0, 0x00, /* 60-69 */ 0x00, 0x48, 0xb0, 0x00, 0x00, 0x50, 0x00, 0xa0, 0xf0, 0x00, /* 70-79 */ 0x00, 0x00, 0xc0, 0x60, 0x18, 0x00, 0xe0, 0x90, 0x00, 0x30, /* 80-89 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x88, 0x70, 0x28, /* 90-99 */ 0xd0, 0x00, 0x00, 0x48, 0xb0, 0x00, 0x00, 0x50, 0x00, 0xa0, /* 100-109 */ 0xf0, 0x00, 0x00, 0x00, 0xc0, 0x60, 0x18, 0x00, 0xe0, 0x90, /* 110-119 */ 0x00, 0x30, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 120-129 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 130-139 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 140-149 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 150-159 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 160-169 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 170-179 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 180-189 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 190-199 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 200-209 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 210-219 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 220-229 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 230-239 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 240-249 */ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; /* 250-255 */ static const unsigned char hook = 0x3e; static const unsigned char lineFeed = 0x0a; /* static const unsigned char space = 0x20; */ SEXP rawStreamToDNAbin(SEXP x) { int k, startOfSeq; long i, j, n; double N; unsigned char *xr, *rseq, *buffer, tmp; SEXP obj, nms, seq; PROTECT(x = coerceVector(x, RAWSXP)); N = XLENGTH(x); xr = RAW(x); /* do a 1st pass to find the number of sequences this code should be robust to '>' present inside a label or in the header text before the sequences */ n = 0; k = 0; /* use k as a flag */ if (xr[0] == hook) { k = 1; startOfSeq = 0; } for (i = 1; i < N; i++) { if (k && xr[i] == lineFeed) { n++; k = 0; } else if (xr[i] == hook) { if (!n) startOfSeq = i; k = 1; } } PROTECT(obj = allocVector(VECSXP, n)); PROTECT(nms = allocVector(STRSXP, n)); /* Refine the way the size of the buffer is set? */ buffer = (unsigned char *)R_alloc(N, sizeof(unsigned char)); i = (long) startOfSeq; j = 0; /* gives the index of the sequence */ while (i < N) { /* 1st read the label... */ i++; k = 0; while (xr[i] != lineFeed) buffer[k++] = xr[i++]; buffer[k] = '\0'; SET_STRING_ELT(nms, j, mkChar((char *)buffer)); /* ... then read the sequence */ n = 0; while (i < N && xr[i] != hook) { tmp = tab_trans[xr[i++]]; /* If we are sure that the FASTA file is correct (ie, the sequence on a single line and only the IUAPC code (plus '-' and '?') is used, then the following check would not be needed; additionally the size of tab_trans could be restriced to 0-121. This check has the advantage that all invalid characters are simply ignored without causing error -- except if '>' occurs in the middle of a sequence. */ if (tmp) buffer[n++] = tmp; } PROTECT(seq = allocVector(RAWSXP, n)); rseq = RAW(seq); for (k = 0; k < n; k++) rseq[k] = buffer[k]; SET_VECTOR_ELT(obj, j, seq); UNPROTECT(1); j++; } setAttrib(obj, R_NamesSymbol, nms); UNPROTECT(3); return obj; } ape/src/me_ols.c0000644000175100001440000005013413017516351013253 0ustar hornikusers/* me_ols.c 2012-04-30 */ /* Copyright 2007 Vincent Lefort GMEsplitEdge() modified by Emmanuel Paradis */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include "me.h" /*from NNI.c*/ void fillTableUp(edge *e, edge *f, double **A, double **D, tree *T); /*OLSint and OLSext use the average distance array to calculate weights instead of using the edge average weight fields*/ void OLSext(edge *e, double **A) { edge *f, *g; if(leaf(e->head)) { f = siblingEdge(e); e->distance = 0.5*(A[e->head->index][e->tail->index] + A[e->head->index][f->head->index] - A[f->head->index][e->tail->index]); } else { f = e->head->leftEdge; g = e->head->rightEdge; e->distance = 0.5*(A[e->head->index][f->head->index] + A[e->head->index][g->head->index] - A[f->head->index][g->head->index]); } } double wf(double lambda, double D_LR, double D_LU, double D_LD, double D_RU, double D_RD, double D_DU) { double weight; weight = 0.5*(lambda*(D_LU + D_RD) + (1 -lambda)*(D_LD + D_RU) - (D_LR + D_DU)); return(weight); } void OLSint(edge *e, double **A) { double lambda; edge *left, *right, *sib; left = e->head->leftEdge; right = e->head->rightEdge; sib = siblingEdge(e); lambda = ((double) sib->bottomsize*left->bottomsize + right->bottomsize*e->tail->parentEdge->topsize) / (e->bottomsize*e->topsize); e->distance = wf(lambda,A[left->head->index][right->head->index], A[left->head->index][e->tail->index], A[left->head->index][sib->head->index], A[right->head->index][e->tail->index], A[right->head->index][sib->head->index], A[sib->head->index][e->tail->index]); } void assignOLSWeights(tree *T, double **A) { edge *e; e = depthFirstTraverse(T,NULL); while (NULL != e) { if ((leaf(e->head)) || (leaf(e->tail))) OLSext(e,A); else OLSint(e,A); e = depthFirstTraverse(T,e); } } /*makes table of average distances from scratch*/ void makeOLSAveragesTable(tree *T, double **D, double **A) { edge *e, *f, *g, *h; edge *exclude; e = f = NULL; e = depthFirstTraverse(T,e); while (NULL != e) { f = e; exclude = e->tail->parentEdge; /*we want to calculate A[e->head][f->head] for all edges except those edges which are ancestral to e. For those edges, we will calculate A[e->head][f->head] to have a different meaning, later*/ if(leaf(e->head)) while (NULL != f) { if (exclude != f) { if (leaf(f->head)) A[e->head->index][f->head->index] = A[f->head->index][e->head->index] = D[e->head->index2][f->head->index2]; else { g = f->head->leftEdge; h = f->head->rightEdge; A[e->head->index][f->head->index] = A[f->head->index][e->head->index] = (g->bottomsize*A[e->head->index][g->head->index] + h->bottomsize*A[e->head->index][h->head->index])/f->bottomsize; } } else /*exclude == f*/ exclude = exclude->tail->parentEdge; f = depthFirstTraverse(T,f); } else /*e->head is not a leaf, so we go recursively to values calculated for the nodes below e*/ while(NULL !=f ) { if (exclude != f) { g = e->head->leftEdge; h = e->head->rightEdge; A[e->head->index][f->head->index] = A[f->head->index][e->head->index] = (g->bottomsize*A[f->head->index][g->head->index] + h->bottomsize*A[f->head->index][h->head->index])/e->bottomsize; } else exclude = exclude->tail->parentEdge; f = depthFirstTraverse(T,f); } /*now we move to fill up the rest of the table: we want A[e->head->index][f->head->index] for those cases where e is an ancestor of f, or vice versa. We'll do this by choosing e via a depth first-search, and the recursing for f up the path to the root*/ f = e->tail->parentEdge; if (NULL != f) fillTableUp(e,f,A,D,T); e = depthFirstTraverse(T,e); } /*we are indexing this table by vertex indices, but really the underlying object is the edge set. Thus, the array is one element too big in each direction, but we'll ignore the entries involving the root, and instead refer to each edge by the head of that edge. The head of the root points to the edge ancestral to the rest of the tree, so we'll keep track of up distances by pointing to that head*/ /*10/13/2001: collapsed three depth-first searces into 1*/ } void GMEcalcDownAverage(node *v, edge *e, double **D, double **A) { edge *left, *right; if (leaf(e->head)) A[e->head->index][v->index] = D[v->index2][e->head->index2]; else { left = e->head->leftEdge; right = e->head->rightEdge; A[e->head->index][v->index] = ( left->bottomsize * A[left->head->index][v->index] + right->bottomsize * A[right->head->index][v->index]) / e->bottomsize; } } void GMEcalcUpAverage(node *v, edge *e, double **D, double **A) { edge *up, *down; if (NULL == e->tail->parentEdge) A[v->index][e->head->index] = D[v->index2][e->tail->index2]; else { up = e->tail->parentEdge; down = siblingEdge(e); A[v->index][e->head->index] = (up->topsize * A[v->index][up->head->index] + down->bottomsize * A[down->head->index][v->index]) / e->topsize; } } /*this function calculates average distance D_Xv for each X which is a set of leaves of an induced subtree of T*/ void GMEcalcNewvAverages(tree *T, node *v, double **D, double **A) { /*loop over edges*/ /*depth-first search*/ edge *e; e = NULL; e = depthFirstTraverse(T,e); /*the downward averages need to be calculated from bottom to top */ while(NULL != e) { GMEcalcDownAverage(v,e,D,A); e = depthFirstTraverse(T,e); } e = topFirstTraverse(T,e); /*the upward averages need to be calculated from top to bottom */ while(NULL != e) { GMEcalcUpAverage(v,e,D,A); e = topFirstTraverse(T,e); } } double wf4(double lambda, double lambda2, double D_AB, double D_AC, double D_BC, double D_Av, double D_Bv, double D_Cv) { return(((1 - lambda) * (D_AC + D_Bv) + (lambda2 - 1)*(D_AB + D_Cv) + (lambda - lambda2)*(D_BC + D_Av))); } /*testEdge cacluates what the OLS weight would be if v were inserted into T along e. Compare against known values for inserting along f = e->parentEdge */ /*edges are tested by a top-first, left-first scheme. we presume all distances are fixed to the correct weight for e->parentEdge, if e is a left-oriented edge*/ void testEdge(edge *e, node *v, double **A) { double lambda, lambda2; edge *par, *sib; sib = siblingEdge(e); par = e->tail->parentEdge; /*C is set above e->tail, B is set below e, and A is set below sib*/ /*following the nomenclature of Desper & Gascuel*/ lambda = (((double) (sib->bottomsize + e->bottomsize*par->topsize)) / ((1 + par->topsize)*(par->bottomsize))); lambda2 = (((double) (sib->bottomsize + e->bottomsize*par->topsize)) / ((1 + e->bottomsize)*(e->topsize))); e->totalweight = par->totalweight + wf4(lambda,lambda2,A[e->head->index][sib->head->index], A[sib->head->index][e->tail->index], A[e->head->index][e->tail->index], A[sib->head->index][v->index],A[e->head->index][v->index], A[v->index][e->tail->index]); } void printDoubleTable(double **A, int d) { int i,j; for(i=0;ilabel);*/ /*initialize variables as necessary*/ /*CASE 1: T is empty, v is the first node*/ if (NULL == T) /*create a tree with v as only vertex, no edges*/ { T_e = newTree(); T_e->root = v; /*note that we are rooting T arbitrarily at a leaf. T->root is not the phylogenetic root*/ v->index = 0; T_e->size = 1; return(T_e); } /*CASE 2: T is a single-vertex tree*/ if (1 == T->size) { v->index = 1; e = makeEdge("",T->root,v,0.0); //sprintf(e->label,"E1"); snprintf(e->label,EDGE_LABEL_LENGTH,"E1"); e->topsize = 1; e->bottomsize = 1; A[v->index][v->index] = D[v->index2][T->root->index2]; T->root->leftEdge = v->parentEdge = e; T->size = 2; return(T); } /*CASE 3: T has at least two nodes and an edge. Insert new node by breaking one of the edges*/ v->index = T->size; /*if (!(T->size % 100)) printf("T->size is %d\n",T->size);*/ GMEcalcNewvAverages(T,v,D,A); /*calcNewvAverges will assign values to all the edge averages of T which include the node v. Will do so using pre-existing averages in T and information from A,D*/ e_min = T->root->leftEdge; e = e_min->head->leftEdge; while (NULL != e) { testEdge(e,v,A); /*testEdge tests weight of tree if loop variable e is the edge split, places this weight in e->totalweight field */ if (e->totalweight < w_min) { e_min = e; w_min = e->totalweight; } e = topFirstTraverse(T,e); } /*e_min now points at the edge we want to split*/ GMEsplitEdge(T,v,e_min,A); return(T); } void updateSubTreeAverages(double **A, edge *e, node *v, int direction); /*the ME version of updateAveragesMatrix does not update the entire matrix A, but updates A[v->index][w->index] whenever this represents an average of 1-distant or 2-distant subtrees*/ void GMEupdateAveragesMatrix(double **A, edge *e, node *v, node *newNode) { edge *sib, *par, *left, *right; sib = siblingEdge(e); left = e->head->leftEdge; right = e->head->rightEdge; par = e->tail->parentEdge; /*we need to update the matrix A so all 1-distant, 2-distant, and 3-distant averages are correct*/ /*first, initialize the newNode entries*/ /*1-distant*/ A[newNode->index][newNode->index] = (e->bottomsize*A[e->head->index][e->head->index] + A[v->index][e->head->index]) / (e->bottomsize + 1); /*1-distant for v*/ A[v->index][v->index] = (e->bottomsize*A[e->head->index][v->index] + e->topsize*A[v->index][e->head->index]) / (e->bottomsize + e->topsize); /*2-distant for v,newNode*/ A[v->index][newNode->index] = A[newNode->index][v->index] = A[v->index][e->head->index]; /*second 2-distant for newNode*/ A[newNode->index][e->tail->index] = A[e->tail->index][newNode->index] = (e->bottomsize*A[e->head->index][e->tail->index] + A[v->index][e->tail->index])/(e->bottomsize + 1); /*third 2-distant for newNode*/ A[newNode->index][e->head->index] = A[e->head->index][newNode->index] = A[e->head->index][e->head->index]; if (NULL != sib) { /*fourth and last 2-distant for newNode*/ A[newNode->index][sib->head->index] = A[sib->head->index][newNode->index] = (e->bottomsize*A[sib->head->index][e->head->index] + A[sib->head->index][v->index]) / (e->bottomsize + 1); updateSubTreeAverages(A,sib,v,SKEW); /*updates sib and below*/ } if (NULL != par) { if (e->tail->leftEdge == e) updateSubTreeAverages(A,par,v,LEFT); /*updates par and above*/ else updateSubTreeAverages(A,par,v,RIGHT); } if (NULL != left) updateSubTreeAverages(A,left,v,UP); /*updates left and below*/ if (NULL != right) updateSubTreeAverages(A,right,v,UP); /*updates right and below*/ /*1-dist for e->head*/ A[e->head->index][e->head->index] = (e->topsize*A[e->head->index][e->head->index] + A[e->head->index][v->index]) / (e->topsize+1); /*2-dist for e->head (v,newNode,left,right) taken care of elsewhere*/ /*3-dist with e->head either taken care of elsewhere (below) or unchanged (sib,e->tail)*/ /*symmetrize the matrix (at least for distant-2 subtrees) */ A[v->index][e->head->index] = A[e->head->index][v->index]; /*and distant-3 subtrees*/ A[e->tail->index][v->index] = A[v->index][e->tail->index]; if (NULL != left) A[v->index][left->head->index] = A[left->head->index][v->index]; if (NULL != right) A[v->index][right->head->index] = A[right->head->index][v->index]; if (NULL != sib) A[v->index][sib->head->index] = A[sib->head->index][v->index]; } void GMEsplitEdge(tree *T, node *v, edge *e, double **A) { int nodelabel = 0;//char nodelabel[NODE_LABEL_LENGTH]; char edgelabel[EDGE_LABEL_LENGTH]; edge *newPendantEdge; edge *newInternalEdge; node *newNode; //snprintf(nodelabel,1,""); newNode = makeNewNode(nodelabel,T->size + 1); //sprintf(edgelabel,"E%d",T->size); snprintf(edgelabel,EDGE_LABEL_LENGTH,"E%d",T->size); newPendantEdge = makeEdge(edgelabel,newNode,v,0.0); //sprintf(edgelabel,"E%d",T->size+1); snprintf(edgelabel,EDGE_LABEL_LENGTH,"E%d",T->size+1); newInternalEdge = makeEdge(edgelabel,newNode,e->head,0.0); /* if (verbose) printf("Inserting node %s on edge %s between nodes %s and %s.\n", v->label,e->label,e->tail->label,e->head->label);*/ /*update the matrix of average distances*/ /*also updates the bottomsize, topsize fields*/ GMEupdateAveragesMatrix(A,e,v,newNode); newNode->parentEdge = e; e->head->parentEdge = newInternalEdge; v->parentEdge = newPendantEdge; e->head = newNode; T->size = T->size + 2; if (e->tail->leftEdge == e) { newNode->leftEdge = newInternalEdge; newNode->rightEdge = newPendantEdge; } else { newNode->leftEdge = newInternalEdge; newNode->rightEdge = newPendantEdge; } /*assign proper topsize, bottomsize values to the two new Edges*/ newPendantEdge->bottomsize = 1; newPendantEdge->topsize = e->bottomsize + e->topsize; newInternalEdge->bottomsize = e->bottomsize; newInternalEdge->topsize = e->topsize; /*off by one, but we adjust that below*/ /*and increment these fields for all other edges*/ updateSizes(newInternalEdge,UP); updateSizes(e,DOWN); } void updateSubTreeAverages(double **A, edge *e, node *v, int direction) /*the monster function of this program*/ { edge *sib, *left, *right, *par; left = e->head->leftEdge; right = e->head->rightEdge; sib = siblingEdge(e); par = e->tail->parentEdge; switch(direction) { /*want to preserve correctness of all 1-distant, 2-distant, and 3-distant averages*/ /*1-distant updated at edge splitting the two trees*/ /*2-distant updated: (left->head,right->head) and (head,tail) updated at a given edge. Note, NOT updating (head,sib->head)! (That would lead to multiple updating).*/ /*3-distant updated: at edge in center of quartet*/ case UP: /*point of insertion is above e*/ /*1-distant average of nodes below e to nodes above e*/ A[e->head->index][e->head->index] = (e->topsize*A[e->head->index][e->head->index] + A[e->head->index][v->index])/(e->topsize + 1); /*2-distant average of nodes below e to nodes above parent of e*/ A[e->head->index][par->head->index] = A[par->head->index][e->head->index] = (par->topsize*A[par->head->index][e->head->index] + A[e->head->index][v->index]) / (par->topsize + 1); /*must do both 3-distant averages involving par*/ if (NULL != left) { updateSubTreeAverages(A, left, v, UP); /*and recursive call*/ /*3-distant average*/ A[par->head->index][left->head->index] = A[left->head->index][par->head->index] = (par->topsize*A[par->head->index][left->head->index] + A[left->head->index][v->index]) / (par->topsize + 1); } if (NULL != right) { updateSubTreeAverages(A, right, v, UP); A[par->head->index][right->head->index] = A[right->head->index][par->head->index] = (par->topsize*A[par->head->index][right->head->index] + A[right->head->index][v->index]) / (par->topsize + 1); } break; case SKEW: /*point of insertion is skew to e*/ /*1-distant average of nodes below e to nodes above e*/ A[e->head->index][e->head->index] = (e->topsize*A[e->head->index][e->head->index] + A[e->head->index][v->index])/(e->topsize + 1); /*no 2-distant averages to update in this case*/ /*updating 3-distant averages involving sib*/ if (NULL != left) { updateSubTreeAverages(A, left, v, UP); A[sib->head->index][left->head->index] = A[left->head->index][sib->head->index] = (sib->bottomsize*A[sib->head->index][left->head->index] + A[left->head->index][v->index]) / (sib->bottomsize + 1); } if (NULL != right) { updateSubTreeAverages(A, right, v, UP); A[sib->head->index][right->head->index] = A[right->head->index][sib->head->index] = (sib->bottomsize*A[par->head->index][right->head->index] + A[right->head->index][v->index]) / (sib->bottomsize + 1); } break; case LEFT: /*point of insertion is below the edge left*/ /*1-distant average*/ A[e->head->index][e->head->index] = (e->bottomsize*A[e->head->index][e->head->index] + A[v->index][e->head->index])/(e->bottomsize + 1); /*2-distant averages*/ A[e->head->index][e->tail->index] = A[e->tail->index][e->head->index] = (e->bottomsize*A[e->head->index][e->tail->index] + A[v->index][e->tail->index])/(e->bottomsize + 1); A[left->head->index][right->head->index] = A[right->head->index][left->head->index] = (left->bottomsize*A[right->head->index][left->head->index] + A[right->head->index][v->index]) / (left->bottomsize+1); /*3-distant avereages involving left*/ if (NULL != sib) { updateSubTreeAverages(A, sib, v, SKEW); A[left->head->index][sib->head->index] = A[sib->head->index][left->head->index] = (left->bottomsize*A[left->head->index][sib->head->index] + A[sib->head->index][v->index]) / (left->bottomsize + 1); } if (NULL != par) { if (e->tail->leftEdge == e) updateSubTreeAverages(A, par, v, LEFT); else updateSubTreeAverages(A, par, v, RIGHT); A[left->head->index][par->head->index] = A[par->head->index][left->head->index] = (left->bottomsize*A[left->head->index][par->head->index] + A[v->index][par->head->index]) / (left->bottomsize + 1); } break; case RIGHT: /*point of insertion is below the edge right*/ /*1-distant average*/ A[e->head->index][e->head->index] = (e->bottomsize*A[e->head->index][e->head->index] + A[v->index][e->head->index])/(e->bottomsize + 1); /*2-distant averages*/ A[e->head->index][e->tail->index] = A[e->tail->index][e->head->index] = (e->bottomsize*A[e->head->index][e->tail->index] + A[v->index][e->tail->index])/(e->bottomsize + 1); A[left->head->index][right->head->index] = A[right->head->index][left->head->index] = (right->bottomsize*A[right->head->index][left->head->index] + A[left->head->index][v->index]) / (right->bottomsize+1); /*3-distant avereages involving right*/ if (NULL != sib) { updateSubTreeAverages(A, sib, v, SKEW); A[right->head->index][sib->head->index] = A[sib->head->index][right->head->index] = (right->bottomsize*A[right->head->index][sib->head->index] + A[sib->head->index][v->index]) / (right->bottomsize + 1); } if (NULL != par) { if (e->tail->leftEdge == e) updateSubTreeAverages(A, par, v, LEFT); else updateSubTreeAverages(A, par, v, RIGHT); A[right->head->index][par->head->index] = A[par->head->index][right->head->index] = (right->bottomsize*A[right->head->index][par->head->index] + A[v->index][par->head->index]) / (right->bottomsize + 1); } break; } } void assignBottomsize(edge *e) { if (leaf(e->head)) e->bottomsize = 1; else { assignBottomsize(e->head->leftEdge); assignBottomsize(e->head->rightEdge); e->bottomsize = e->head->leftEdge->bottomsize + e->head->rightEdge->bottomsize; } } void assignTopsize(edge *e, int numLeaves) { if (NULL != e) { e->topsize = numLeaves - e->bottomsize; assignTopsize(e->head->leftEdge,numLeaves); assignTopsize(e->head->rightEdge,numLeaves); } } void assignAllSizeFields(tree *T) { assignBottomsize(T->root->leftEdge); assignTopsize(T->root->leftEdge,T->size/2 + 1); } ape/src/mat_expo.c0000644000175100001440000000342213017516351013607 0ustar hornikusers/* matexpo.c 2011-06-23 */ /* Copyright 2007-2011 Emmanuel Paradis */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include #include void mat_expo(double *P, int *nr) /* This function computes the exponential of a nr x nr matrix */ { double *U, *vl, *WR, *Uinv, *WI, *work; int i, j, k, l, info, *ipiv, n = *nr, nc = n*n, lw = nc << 1; char yes = 'V', no = 'N'; U = (double *)R_alloc(nc, sizeof(double)); vl = (double *)R_alloc(n, sizeof(double)); WR = (double *)R_alloc(n, sizeof(double)); Uinv = (double *)R_alloc(nc, sizeof(double)); WI = (double *)R_alloc(n, sizeof(double)); work = (double *)R_alloc(lw, sizeof(double)); ipiv = (int *)R_alloc(nc, sizeof(int)); /* The matrix is not symmetric, so we use 'dgeev'. We take the real part of the eigenvalues -> WR and the right eigenvectors (vr) -> U */ F77_CALL(dgeev)(&no, &yes, &n, P, &n, WR, WI, vl, &n, U, &n, work, &lw, &info); /* It is not necessary to sort the eigenvalues... Copy U -> P */ memcpy(P, U, nc*sizeof(double)); /* For the inversion, we first make Uinv an identity matrix */ memset(Uinv, 0, nc*sizeof(double)); for (i = 0; i < nc; i += n + 1) Uinv[i] = 1; /* The matrix is not symmetric, so we use 'dgesv'. This subroutine puts the result in Uinv (B) (P [= U] is erased) */ F77_CALL(dgesv)(&n, &n, P, &n, ipiv, Uinv, &n, &info); /* The matrix product of U with the eigenvalues diagonal matrix: */ for (i = 0; i < n; i++) for (j = 0; j < n; j++) U[j + i*n] *= exp(WR[i]); /* The second matrix product with U^-1 */ memset(P, 0, nc*sizeof(double)); for (k = 0; k < n; k++) { for (l = 0; l < n; l++) { lw = l + k*n; for (i = 0 + n*k, j = l; j < nc; i++, j += n) P[lw] += U[j]*Uinv[i]; } } } ape/src/SPR.c0000644000175100001440000003443013017516351012442 0ustar hornikusers/* SPR.c 2013-09-26 */ /* Copyright 2009 Richard Desper */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include "me.h" /*functions from bNNI.c*/ void makeBMEAveragesTable(tree *T, double **D, double **A); void assignBMEWeights(tree *T, double **A); /*from me.c*/ edge *siblingEdge(edge *e); void weighTree(tree *T); void freeMatrix(double **D, int size); edge *depthFirstTraverse(tree *T, edge *e); double **initDoubleMatrix(int d); /*from below*/ node *indexedNode(tree *T, int i); edge *indexedEdge(tree *T, int i); void assignSPRWeights(node *v, double **A, double ***swapWeights); void SPRTopShift(tree *T, node *vmove, edge *esplit, int UpOrDown); void assignDownWeightsUp(edge *etest, node *vtest, node *va, edge *back, node *cprev, double oldD_AB, double coeff, double **A, double ***swapWeights); void assignDownWeightsSkew(edge *etest, node *vtest, node *va, edge *back, node *cprev, double oldD_AB, double coeff, double **A, double ***swapWeights); void assignDownWeightsDown(edge *etest, node *vtest, node *va, edge *back, node *cprev, double oldD_AB, double coeff, double **A, double ***swapWeights); void assignUpWeights(edge *etest, node *vtest, node *va, edge *back, node *cprve, double oldD_AB, double coeff, double **A, double ***swapWeights); void zero3DMatrix(double ***X, int h, int l, int w) { int i,j,k; for(i=0;iweight);*/ for(i=0;i<2;i++) swapWeights[i] = initDoubleMatrix(T->size); do { swapValue=0.0; zero3DMatrix(swapWeights,2,T->size,T->size); i = j = k = 0; for(e=depthFirstTraverse(T,NULL);NULL!=e;e=depthFirstTraverse(T,e)) assignSPRWeights(e->head,A,swapWeights); findTableMin(&i,&j,&k,T->size,swapWeights,&swapValue); swapValue = swapWeights[i][j][k]; if (swapValue < -EPSILON) { // if (verbose) // printf("New tree weight should be %lf.\n",T->weight + 0.25*swapValue); v = indexedNode(T,j); f = indexedEdge(T,k); // if (verbose) // printf("Swapping tree below %s to split edge %s with head %s and tail %s\n", // v->parentEdge->label,f->label,f->head->label,f->tail->label); SPRTopShift(T,v,f,2-i); makeBMEAveragesTable(T,D,A); assignBMEWeights(T,A); weighTree(T); (*count)++; /*sprintf(filename,"tree%d.new",*count);*/ // if (verbose) // printf("After %d SPRs, tree weight is %lf.\n\n",*count,T->weight); /*treefile = fopen(filename,"w"); NewickPrintTree(T,treefile); fclose(treefile);*/ } } while (swapValue < -EPSILON); for(i=0;i<2;i++) freeMatrix(swapWeights[i],T->size); free(swapWeights); /*if (verbose) readOffTree(T);*/ } /*assigns values to array swapWeights*/ /*swapWeights[0][j][k] will be the value of removing the tree below the edge whose head node has index j and reattaching it to split the edge whose head has the index k*/ /*swapWeights[1][j][k] will be the value of removing the tree above the edge whose head node has index j and reattaching it to split the edge whose head has the index k*/ void assignSPRWeights(node *vtest, double **A, double ***swapWeights) { edge *etest, *left, *right, *sib, *par; etest = vtest->parentEdge; left = vtest->leftEdge; right = vtest->rightEdge; par = etest->tail->parentEdge; sib = siblingEdge(etest); if (NULL != par) assignDownWeightsUp(par,vtest,sib->head,NULL,NULL,0.0,1.0,A,swapWeights); if (NULL != sib) assignDownWeightsSkew(sib,vtest,sib->tail,NULL,NULL,0.0,1.0,A,swapWeights); /*assigns values for moving subtree rooted at vtest, starting with edge parental to tail of edge parental to vtest*/ if (NULL != left) { assignUpWeights(left,vtest,right->head,NULL,NULL,0.0,1.0,A,swapWeights); assignUpWeights(right,vtest,left->head,NULL,NULL,0.0,1.0,A,swapWeights); } } /*recall NNI formula: change in tree length from AB|CD split to AC|BD split is proportional to D_AC + D_BD - D_AB - D_CD*/ /*in our case B is the tree being moved (below vtest), A is the tree backwards below back, but with the vtest subtree removed, C is the sibling tree of back and D is the tree above etest*/ /*use va to denote the root of the sibling tree to B in the original tree*/ /*please excuse the multiple uses of the same letters: A,D, etc.*/ void assignDownWeightsUp(edge *etest, node *vtest, node *va, edge *back, node *cprev, double oldD_AB, double coeff, double **A, double ***swapWeights) { edge *par, *sib, *skew; double D_AC, D_BD, D_AB, D_CD; par = etest->tail->parentEdge; skew = siblingEdge(etest); if (NULL == back) /*first recursive call*/ { if (NULL == par) return; else /*start the process of assigning weights recursively*/ { assignDownWeightsUp(par,vtest,va,etest,va,A[va->index][vtest->index],0.5,A,swapWeights); assignDownWeightsSkew(skew,vtest,va,etest,va,A[va->index][vtest->index],0.5,A,swapWeights); } } else /*second or later recursive call*/ { sib = siblingEdge(back); D_BD = A[vtest->index][etest->head->index]; /*straightforward*/ D_CD = A[sib->head->index][etest->head->index]; /*this one too*/ D_AC = A[sib->head->index][back->head->index] + coeff*(A[sib->head->index][va->index] - A[sib->head->index][vtest->index]); D_AB = 0.5*(oldD_AB + A[vtest->index][cprev->index]); swapWeights[0][vtest->index][etest->head->index] = swapWeights[0][vtest->index][back->head->index] + (D_AC + D_BD - D_AB - D_CD); if (NULL != par) { assignDownWeightsUp(par,vtest,va,etest,sib->head,D_AB,0.5*coeff,A,swapWeights); assignDownWeightsSkew(skew,vtest,va,etest,sib->head,D_AB,0.5*coeff,A,swapWeights); } } } void assignDownWeightsSkew(edge *etest, node *vtest, node *va, edge *back, node *cprev, double oldD_AB, double coeff, double **A, double ***swapWeights) { /*same general idea as assignDownWeights, except needing to keep track of things a bit differently*/ edge *par, *left, *right; /*par here = sib before left, right here = par, skew before*/ double D_AB, D_CD, D_AC, D_BD; /*B is subtree being moved - below vtest A is subtree remaining fixed - below va, unioned with all trees already passed by B*/ /*C is subtree being passed by B, in this case above par D is subtree below etest, fixed on other side*/ par = etest->tail->parentEdge; left = etest->head->leftEdge; right = etest->head->rightEdge; if (NULL == back) { if (NULL == left) return; else { assignDownWeightsDown(left,vtest,va,etest,etest->tail,A[vtest->index][etest->tail->index],0.5,A,swapWeights); assignDownWeightsDown(right,vtest,va,etest,etest->tail,A[vtest->index][etest->tail->index],0.5,A,swapWeights); } } else { D_BD = A[vtest->index][etest->head->index]; D_CD = A[par->head->index][etest->head->index]; D_AC = A[back->head->index][par->head->index] + coeff*(A[va->index][par->head->index] - A[vtest->index][par->head->index]); D_AB = 0.5*(oldD_AB + A[vtest->index][cprev->index]); swapWeights[0][vtest->index][etest->head->index] = swapWeights[0][vtest->index][back->head->index] + (D_AC + D_BD - D_AB - D_CD); if (NULL != left) { assignDownWeightsDown(left,vtest, va, etest, etest->tail, D_AB, 0.5*coeff, A, swapWeights); assignDownWeightsDown(right,vtest, va, etest, etest->tail, D_AB, 0.5*coeff, A, swapWeights); } } } void assignDownWeightsDown(edge *etest, node *vtest, node *va, edge *back, node *cprev, double oldD_AB, double coeff, double **A, double ***swapWeights) { /*again the same general idea*/ edge *sib, *left, *right; /*sib here = par in assignDownWeightsSkew rest is the same as assignDownWeightsSkew*/ double D_AB, D_CD, D_AC, D_BD; /*B is below vtest, A is below va unioned with all trees already passed by B*/ /*C is subtree being passed - below sib*/ /*D is tree below etest*/ sib = siblingEdge(etest); left = etest->head->leftEdge; right = etest->head->rightEdge; D_BD = A[vtest->index][etest->head->index]; D_CD = A[sib->head->index][etest->head->index]; D_AC = A[sib->head->index][back->head->index] + coeff*(A[sib->head->index][va->index] - A[sib->head->index][vtest->index]); D_AB = 0.5*(oldD_AB + A[vtest->index][cprev->index]); swapWeights[0][vtest->index][etest->head->index] = swapWeights[0][vtest->index][back->head->index] + ( D_AC + D_BD - D_AB - D_CD); if (NULL != left) { assignDownWeightsDown(left,vtest, va, etest, sib->head, D_AB, 0.5*coeff, A, swapWeights); assignDownWeightsDown(right,vtest, va, etest, sib->head, D_AB, 0.5*coeff, A, swapWeights); } } void assignUpWeights(edge *etest, node *vtest, node *va, edge *back, node *cprev, double oldD_AB, double coeff, double **A, double ***swapWeights) { /*SPR performed on tree above vtest...*/ /*same idea as above, with appropriate selections of edges and nodes*/ edge *sib, *left, *right; /*B is above vtest, A is other tree below vtest unioned with trees in path to vtest*/ /*sib is tree C being passed by B*/ /*D is tree below etest*/ double D_AB, D_CD, D_AC, D_BD; // double thisWeight; deleted by EP, 2013-09-16, also below sib = siblingEdge(etest); left = etest->head->leftEdge; right = etest->head->rightEdge; if (NULL == back) /*first recursive call*/ { if (NULL == left) return; else /*start the process of assigning weights recursively*/ { assignUpWeights(left,vtest,va,etest,va,A[va->index][vtest->index],0.5,A,swapWeights); assignUpWeights(right,vtest,va,etest,va,A[va->index][vtest->index],0.5,A,swapWeights); } } else /*second or later recursive call*/ { D_BD = A[vtest->index][etest->head->index]; D_CD = A[sib->head->index][etest->head->index]; D_AC = A[back->head->index][sib->head->index] + coeff*(A[va->index][sib->head->index] - A[vtest->index][sib->head->index]); D_AB = 0.5*(oldD_AB + A[vtest->index][cprev->index]); // thisWeight = deleted by EP, 2013-09-16 swapWeights[1][vtest->index][etest->head->index] = swapWeights[1][vtest->index][back->head->index] + (D_AC + D_BD - D_AB - D_CD); if (NULL != left) { assignUpWeights(left,vtest, va, etest, sib->head, D_AB, 0.5*coeff, A, swapWeights); assignUpWeights(right,vtest, va, etest, sib->head, D_AB, 0.5*coeff, A, swapWeights); } } } void pruneSubtree(edge *p, edge *u, edge *d) /*starting with edge u above edges p, d*/ /*removes p, d from tree, u connects to d->head to compensate*/ { p->tail->parentEdge = NULL;/*remove p subtree*/ u->head = d->head; d->head->parentEdge = u; /*u connected to d->head*/ d->head = NULL; /*d removed from tree*/ } void SPRsplitEdge(edge *e, edge *p, edge *d) /*splits edge e to make it parental to p,d. d is parental to what previously was below e*/ { d->head = e->head; e->head = p->tail; p->tail->parentEdge = e; d->head->parentEdge = d; } /*topological shift function*/ /*removes subtree rooted at v and re-inserts to spilt e*/ void SPRDownShift(tree *T, node *v, edge *e) { edge *vup, *vdown, *vpar; vpar = v->parentEdge; vdown = siblingEdge(vpar); vup = vpar->tail->parentEdge; /*topological shift*/ pruneSubtree(vpar,vup,vdown); /*removes v subtree and vdown, extends vup*/ SPRsplitEdge(e,vpar,vdown); /*splits e to make e sibling edge to vpar, both below vup*/ } void SPRUpShift(tree *T, node *vmove, edge *esplit) /*an inelegant iterative version*/ { edge *f; edge **EPath; edge **sib; node **v; int i; int pathLength; for(f=esplit->tail->parentEdge,pathLength=1;f->tail != vmove;f=f->tail->parentEdge) pathLength++; /*count number of edges to vmove*/ /*note that pathLength > 0 will hold*/ EPath = (edge **)malloc(pathLength*sizeof(edge *)); v = (node **)malloc(pathLength*sizeof(edge *)); sib = (edge **)malloc((pathLength+1)*sizeof(edge *)); /*there are pathLength + 1 side trees, one at the head and tail of each edge in the path*/ sib[pathLength] = siblingEdge(esplit); i = pathLength; f = esplit->tail->parentEdge; while (i > 0) { i--; EPath[i] = f; sib[i] = siblingEdge(f); v[i] = f->head; f = f->tail->parentEdge; } /*indexed so head of Epath is v[i], tail is v[i-1] and sibling edge is sib[i]*/ /*need to assign head, tail of each edge in path as well as have proper values for the left and right fields*/ if (esplit == esplit->tail->leftEdge) { vmove->leftEdge = esplit; vmove->rightEdge = EPath[pathLength-1]; } else { vmove->rightEdge = esplit; vmove->leftEdge = EPath[pathLength-1]; } esplit->tail = vmove; /*espilt->head remains unchanged*/ /*vmove has the proper fields for left, right, and parentEdge*/ for(i=0;i<(pathLength-1);i++) EPath[i]->tail = v[i+1]; /*this bit flips the orientation along the path the tail of Epath[i] is now v[i+1] instead of v[i-1]*/ EPath[pathLength-1]->tail = vmove; for(i=1;ileftEdge) v[i]->rightEdge = EPath[i-1]; else v[i]->leftEdge = EPath[i-1]; } if (sib[1] == v[0]->leftEdge) v[0]->rightEdge = sib[0]; else v[0]->leftEdge = sib[0]; sib[0]->tail = v[0]; free(EPath); free(v); free(sib); } void SPRTopShift(tree *T, node *vmove, edge *esplit, int UpOrDown) { if (DOWN == UpOrDown) SPRDownShift(T,vmove,esplit); else SPRUpShift(T,vmove,esplit); } node *indexedNode(tree *T, int i) { edge *e; for(e = depthFirstTraverse(T,NULL);NULL!=e;e=depthFirstTraverse(T,e)) if (i == e->head->index) return(e->head); if (i == T->root->index) return(T->root); return(NULL); } edge *indexedEdge(tree *T, int i) { edge *e; for(e = depthFirstTraverse(T,NULL);NULL!=e;e=depthFirstTraverse(T,e)) if (i == e->head->index) return(e); return(NULL); } ape/src/njs.c0000644000175100001440000005223513017516351012573 0ustar hornikusers/* njs.c 2013-09-26 */ /* Copyright 2011-2013 Andrei-Alin Popescu */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include "ape.h" int H(double t) { if (t >= 0 - 1e-10) return 1; return 0; } void choosePair(double* D,int n,double* R,int* s, int* sw, int* x, int* y, int fS) { int i=0,j=0,k=0; int sww=0; double cFS[fS]; int iFS[fS]; int jFS[fS]; for(k=0;knumb;k++); //Rprintf("k=%i ",k); for(tr=fS-1;tr>k;tr--) {cFS[tr]=cFS[tr-1]; iFS[tr]=iFS[tr-1]; jFS[tr]=jFS[tr-1]; } if(kmax){max=nb;} cFS[i]=nb; } /*Rprintf("all N*(x,y)\n"); for(k=0;kmax){max=nb;} cFS[i]=nb; } /*Rprintf("all c*xy values\n"); for(k=0;kmax){max=nb;} cFS[i]=nb; } /*Rprintf("all m*xy values\n"); for(k=0;kmax){max=nb;iPos=i;} cFS[i]=nb; } /*Rprintf("cN*xy\n"); Rprintf("value[%i]=%f ",0,cFS[0]); Rprintf("i=%i ",iFS[0]); Rprintf("j=%i ",jFS[0]); Rprintf("\n");*/ if(iFS[iPos]==0 || jFS[iPos]==0) { error("distance information insufficient to construct a tree, cannot calculate agglomeration criterion"); } *x=iFS[iPos];*y=jFS[iPos]; } double cnxy(int x, int y, int n,double* D) { int i=0; int j=0; double nMeanXY=0; //Rprintf("cN[%i,%i]\n",x,y); for(i=1;i<=n;i++) { for(j=1;j<=n;j++) {if(i==j)continue; if((i==x && j==y) || (j==x && i==y))continue; double n1=0; double n2=0; if(i!=x)n1=D[give_index(i,x,n)]; if(j!=y)n2=D[give_index(j,y,n)]; if(n1==-1 || n2==-1 || D[give_index(i,j,n)]==-1)continue; nMeanXY+=(n1+n2-D[give_index(x,y,n)]-D[give_index(i,j,n)]); //Rprintf("cnMeanXY after (%i,%i)=%f\n",i,j,nMeanXY); } } return nMeanXY; } int mxy(int x,int y,int n,double* D) { int i=0; int mx[n+1]; int my[n+1]; for(i=1;i<=n;i++) { mx[i]=0;my[i]=0; } for(i=1;i<=n;i++) { if(i!=x && D[give_index(x,i,n)]==-1) { mx[i]=1; } if(i!=y && D[give_index(y,i,n)]==-1) { my[i]=1; } } /*for(i=1;i<=n;i++) { Rprintf("mx[%i]=%i ",i,mx[i]); } Rprintf("\n"); for(i=1;i<=n;i++) { Rprintf("my[%i]=%i ",i,my[i]); } Rprintf("\n");*/ int xmy=0; int ymx=0; for(i=1;i<=n;i++) { if(i!=x && mx[i]==1 && my[i]==0) { xmy++; } if(i!=y && my[i]==1 && mx[i]==0) { ymx++; } } //Rprintf("xmy=%i, ymx=%i, xmy+ymx=%i\n",xmy,ymx,xmy+ymx); return xmy+ymx; } double nxy(int x, int y, int n,double* D) { int sCXY=0; int i=0; int j=0; double nMeanXY=0; //Rprintf("N[%i,%i]\n",x,y); for(i=1;i<=n;i++) { for(j=1;j<=n;j++) {if(i==j)continue; if((i==x && j==y) || (j==x && i==y))continue; double n1=0; double n2=0; if(i!=x)n1=D[give_index(i,x,n)]; if(j!=y)n2=D[give_index(j,y,n)]; if(n1==-1 || n2==-1 || D[give_index(i,j,n)]==-1)continue; sCXY++; //Rprintf("considered pair (%i,%i)\n",i,j); nMeanXY+=H(n1+n2-D[give_index(x,y,n)]-D[give_index(i,j,n)]); //Rprintf("nMeanXY after (%i,%i)=%f\n",i,j,nMeanXY); } } //Rprintf("sCXY=%i",sCXY); if(sCXY==0) return 0; return nMeanXY/sCXY; } int cxy(int x, int y, int n,double* D) { int sCXY=0; int i=0; int j=0; for(i=1;i<=n;i++) { for(j=1;j<=n;j++) {if(i==j)continue; if((i==x && j==y) || (j==x && i==y))continue; double n1=0; double n2=0; if(i!=x)n1=D[give_index(i,x,n)]; if(j!=y)n2=D[give_index(j,y,n)]; if(n1==-1 || n2==-1 || D[give_index(i,j,n)]==-1)continue; sCXY++; } } return sCXY; } void C_njs(double *D, int *N, int *edge1, int *edge2, double *edge_length, int *fsS) { //assume missing values are denoted by -1 double *S,*R, Sdist, Ndist, *new_dist, A, B, smallest_S; int n, i, j, k, ij, OTU1, OTU2, cur_nod, o_l, *otu_label; /*for(i=0;i 3) { ij = 0; for(i=1;i smallest_S) { OTU1 = i; OTU2 = j; smallest_S = A; /* smallest = ij; */ } ij++; } } } /*Rprintf("agglomerating %i and %i, Q=%f \n",OTU1,OTU2,smallest_S); for(i=1;i 1; i--) otu_label[i] = otu_label[i - 1]; if (OTU2 != n) for (i = OTU2; i < n; i++) otu_label[i] = otu_label[i + 1]; otu_label[1] = cur_nod; n--; for (i = 0; i < n*(n - 1)/2; i++) { D[i] = new_dist[i]; if(sw==1) { R[i] = newR[i]; s[i] = newS[i]; } } cur_nod--; k = k + 2; } int dK=0;//number of known distances in final distance matrix int iUK=-1;//index of unkown distance, if we have one missing distance int iK=-1;//index of only known distance, only needed if dK==1 for (i = 0; i < 3; i++) { edge1[*N*2 - 4 - i] = cur_nod; edge2[*N*2 - 4 - i] = otu_label[i + 1]; if(D[i]!=-1){dK++;iK=i;}else{iUK=i;} } if(dK==2) {//if two distances are known: assume our leaves are x,y,z, d(x,z) unknown //and edge weights of three edges are a,b,c, then any b,c>0 that //satisfy c-b=d(y,z)-d(x,y) a+c=d(y,z) are good edge weights, but for //simplicity we assume a=c if d(yz)max)max=D[i]; } D[iUK]=max; } if(dK==1) {//through similar motivation as above, if we have just one known distance //we set the other two distances equal to it for(i=0;i<3;i++) {if(i==iK)continue; D[i]=D[iK]; } } if(dK==0) {//no distances are known, we just set them to 1 for(i=0;i<3;i++) {D[i]=1; } } edge_length[*N*2 - 4] = (D[0] + D[1] - D[2])/2; edge_length[*N*2 - 5] = (D[0] + D[2] - D[1])/2; edge_length[*N*2 - 6] = (D[2] + D[1] - D[0])/2; } ape/src/additive.c0000644000175100001440000000276013017516351013570 0ustar hornikusers/* additive.c 2011-10-11 */ /* Copyright 2011 Andrei-Alin Popescu */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include "ape.h" void C_additive(double *dd, int* np, int* mp, double *ret)//d received as dist object, -1 for missing entries { int n=*np; int m=*mp; int i=0,j=0; double max=dd[0]; double d[n][n]; for(i=1;imax) { max=dd[give_index(i,j,n)]; } } } d[n-1][n-1]=0; int entrCh=0; do{ entrCh=0; for(i=0;i(d[i][l]+d[j][k]))?(d[i][k]+d[j][l]):(d[i][l]+d[j][k])); mx-=d[k][l]; if(mx void C_rTraitCont(int *model, int *Nedge, int *edge1, int *edge2, double *el, double *sigma, double *alpha, double *theta, double *x) { /* The tree must be in pruningwise order */ int i; double alphaT, M, S; switch(*model) { case 1 : for (i = *Nedge - 1; i >= 0; i--) { GetRNGstate(); x[edge2[i]] = x[edge1[i]] + sqrt(el[i]) * sigma[i] * norm_rand(); PutRNGstate(); } break; case 2 : for (i = *Nedge - 1; i >= 0; i--) { if (alpha[i]) { alphaT = alpha[i] * el[i]; M = exp(-alphaT); S = sigma[i] * sqrt((1 - exp(-2 * alphaT))/(2 * alpha[i])); } else { /* same than if (alpha[i] == 0) */ M = 1; S = sqrt(el[i]) * sigma[i]; } GetRNGstate(); x[edge2[i]] = x[edge1[i]] * M + theta[i] * (1 - M) + S * norm_rand(); PutRNGstate(); } break; } } ape/src/bionjs.c0000644000175100001440000003552213017516351013265 0ustar hornikusers/* bionjs.c 2014-03-21 */ /* Copyright 2011-2014 Andrei-Alin Popescu */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include "ape.h" void C_bionjs(double *D, int *N, int *edge1, int *edge2, double *edge_length, int* fsS) { //assume missing values are denoted by -1 double *S,*R , *v,*new_v, Sdist, Ndist, *new_dist, A, B, smallest_S; int n, i, j, k, ij, OTU1, OTU2, cur_nod, o_l, *otu_label; /*for(i=0;i 3) { ij = 0; for(i=1;i smallest_S) { OTU1 = i; OTU2 = j; smallest_S = A; /* smallest = ij; */ } ij++; } } } //Rprintf("agglomerating %i and %i, Q=%f \n",OTU1,OTU2,smallest_S); /*for(i=1;i1.0)lamb=1.0; }else{ if(v[give_index(OTU2,OTU1,n)]!=0.0) lamb=0.5+(1.0/(2*(n-2)*v[give_index(OTU1,OTU2,n)]))*lambSum; else lamb=0.5; if(lamb<0.0)lamb=0.0; if(lamb>1.0)lamb=1.0; } //although s was updated above, s[otu1,otu2] has remained unchanged //so it is safe to use it here //if complete distanes, use N-2, else use S int down=B; if(sw==1){down=s[give_index(OTU1,OTU2,n)]-2;} if(down<=0) {error("distance information insufficient to construct a tree, leaves %i and %i isolated from tree",OTU1,OTU2); } //Rprintf("down=%f\n",B); sum*=(1.0/(2*(down))); //Rprintf("sum=%f\n",sum); double dxy=D[give_index(OTU1,OTU2,n)]/2; //Rprintf("R[%i,%i]:%f \n",OTU1,OTU2,sum); edge_length[k] = dxy+sum;//OTU1 //Rprintf("l1:%f \n",edge_length[k]); edge_length[k + 1] = dxy-sum;//OTU2 //Rprintf("l2:%f \n",edge_length[k+1]); //no need to change distance matrix update for complete distance //case, as pairs will automatically fall in the right cathegory //OTU1=x, OTU2=y from formulas A = D[give_index(OTU1,OTU2,n)]; ij = 0; for (i = 1; i <= n; i++) { if (i == OTU1 || i == OTU2) continue; if(D[give_index(OTU1,i,n)]!=-1 && D[give_index(OTU2,i,n)]!=-1) { new_dist[ij]= lamb*(D[give_index(OTU1,i,n)]-edge_length[k])+(1-lamb)*(D[give_index(OTU2,i,n)]-edge_length[k+1]); new_v[ij]=lamb*v[give_index(OTU1,i,n)]+(1-lamb)*v[give_index(OTU2,i,n)]-lamb*(1-lamb)*v[give_index(OTU1,OTU2,n)]; }else{ if(D[give_index(OTU1,i,n)]!=-1) { new_dist[ij]=D[give_index(OTU1,i,n)]-edge_length[k]; new_v[ij]=v[give_index(OTU1,i,n)]; }else{ if(D[give_index(OTU2,i,n)]!=-1) { new_dist[ij]=D[give_index(OTU2,i,n)]-edge_length[k+1]; new_v[ij]=v[give_index(OTU2,i,n)]; }else{new_dist[ij]=-1;new_v[ij]=-1;} } } ij++; } for (i = 1; i < n; i++) { if (i == OTU1 || i == OTU2) continue; for (j = i + 1; j <= n; j++) { if (j == OTU1 || j == OTU2) continue; new_dist[ij] = D[DINDEX(i, j)]; new_v[ij]=v[give_index(i,j,n)]; ij++; } } /*for(i=1;i 1; i--) otu_label[i] = otu_label[i - 1]; if (OTU2 != n) for (i = OTU2; i < n; i++) otu_label[i] = otu_label[i + 1]; otu_label[1] = cur_nod; n--; for (i = 0; i < n*(n - 1)/2; i++) { D[i] = new_dist[i]; v[i] = new_v[i]; if(sw==1) { R[i] = newR[i]; s[i] = newS[i]; } } cur_nod--; k = k + 2; } int dK=0;//number of known distances in final distance matrix int iUK=-1;//index of unkown distance, if we have one missing distance int iK=-1;//index of only known distance, only needed if dK==1 for (i = 0; i < 3; i++) { edge1[*N*2 - 4 - i] = cur_nod; edge2[*N*2 - 4 - i] = otu_label[i + 1]; if(D[i]!=-1){dK++;iK=i;}else{iUK=i;} } if(dK==2) {//if two distances are known: assume our leaves are x,y,z, d(x,z) unknown //and edge weights of three edges are a,b,c, then any b,c>0 that //satisfy c-b=d(y,z)-d(x,y) a+c=d(y,z) are good edge weights, but for //simplicity we assume a=c if d(yz)max)max=D[i]; } D[iUK]=max; } if(dK==1) {//through similar motivation as above, if we have just one known distance //we set the other two distances equal to it for(i=0;i<3;i++) {if(i==iK)continue; D[i]=D[iK]; } } if(dK==0) {//no distances are known, we just set them to 1 for(i=0;i<3;i++) {D[i]=1; } } edge_length[*N*2 - 4] = (D[0] + D[1] - D[2])/2; edge_length[*N*2 - 5] = (D[0] + D[2] - D[1])/2; edge_length[*N*2 - 6] = (D[2] + D[1] - D[0])/2; } ape/src/plot_phylo.c0000644000175100001440000000526413017516351014172 0ustar hornikusers/* plot_phylo.c (2014-03-05) */ /* Copyright 2004-2014 Emmanuel Paradis */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include void node_depth_edgelength(int *ntip, int *nnode, int *edge1, int *edge2, int *nedge, double *edge_length, double *xx) { int i; /* We do a preorder tree traversal starting from the bottom */ /* of `edge'; we assume `xx' has 0 for the root and the tree */ /* is in pruningwise order. */ for (i = *nedge - 1; i >= 0; i--) xx[edge2[i] - 1] = xx[edge1[i] - 1] + edge_length[i]; } void node_depth(int *ntip, int *nnode, int *e1, int *e2, int *nedge, double *xx, int *method) /* method == 1: the node depths are proportional to the number of tips method == 2: the node depths are evenly spaced */ { int i; /* First set the coordinates for all tips */ for (i = 0; i < *ntip; i++) xx[i] = 1; /* Then compute recursively for the nodes; we assume `xx' has */ /* been initialized with 0's which is true if it has been */ /* created in R (the tree must be in pruningwise order) */ if (*method == 1) { for (i = 0; i < *nedge; i++) xx[e1[i] - 1] = xx[e1[i] - 1] + xx[e2[i] - 1]; } else { /* *method == 2 */ for (i = 0; i < *nedge; i++) { /* if a value > 0 has already been assigned to the ancestor node of this edge, check that the descendant node is not at the same level or more */ if (xx[e1[i] - 1]) if (xx[e1[i] - 1] >= xx[e2[i] - 1] + 1) continue; xx[e1[i] - 1] = xx[e2[i] - 1] + 1; } } } void node_height(int *ntip, int *nnode, int *edge1, int *edge2, int *nedge, double *yy) { int i, n; double S; /* The coordinates of the tips have been already computed */ S = 0; n = 0; for (i = 0; i < *nedge - 1; i++) { S += yy[edge2[i] - 1]; n++; if (edge1[i + 1] != edge1[i]) { yy[edge1[i] - 1] = S/n; S = 0; n = 0; } } /* do the last edge */ /* i = *nedge - 1; */ S += yy[edge2[i] - 1]; n++; yy[edge1[i] - 1] = S/n; } void node_height_clado(int *ntip, int *nnode, int *edge1, int *edge2, int *nedge, double *xx, double *yy) { int i, j, n; double S; i = 1; node_depth(ntip, nnode, edge1, edge2, nedge, xx, &i); /* The coordinates of the tips have been already computed */ S = 0; n = 0; for (i = 0; i < *nedge - 1; i++) { j = edge2[i] - 1; S += yy[j] * xx[j]; n += xx[j]; if (edge1[i + 1] != edge1[i]) { yy[edge1[i] - 1] = S/n; S = 0; n = 0; } } /* do the last edge */ /* i = *nedge - 1; */ j = edge2[i] - 1; S += yy[j] * xx[j]; n += xx[j]; yy[edge1[i] - 1] = S/n; } ape/src/treePop.c0000644000175100001440000001315213017516351013412 0ustar hornikusers/* treePop.c 2013-09-19 */ /* Copyright 2011-2013 Andrei-Alin Popescu */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include #include #include int lsb(uint8_t * a) { int i = 0; while (a[i] == 0) i++; /* count number of elements = 0 */ int b = 7; while ((a[i] & (1 << b)) == 0) b--; return i*8 + (8 - b); } short count_bits(uint8_t n) { short c; /* c accumulates the total bits set in v */ for (c = 0; n; c++) n &= n - 1; /* clear the least significant bit set */ return c; } /* Print n as a binary number */ /*void printbits(uint8_t n) { uint8_t i; i = 1 << (sizeof(n) * 8 - 1); while (i > 0) { if (n & i) Rprintf("1"); else Rprintf("0"); i >>= 1; } }*/ uint8_t* setdiff(uint8_t* x, uint8_t *y, int nrow) //x-y { int i = 0; uint8_t* ret = (uint8_t*)R_alloc(nrow, sizeof(uint8_t)); for (i = 0; i < nrow; i++) { uint8_t tmp = (~y[i]); /* Rprintf("x[%i]=",i); printbits(x[i]); Rprintf("\n"); Rprintf("y[%i]=",i); printbits(y[i]); Rprintf("\n"); Rprintf("tmp=\n"); printbits(tmp); Rprintf("\n"); */ ret[i] = (x[i] & tmp); } return ret; } void C_treePop(int* splits, double* w,int* ncolp,int* np, int* ed1, int* ed2, double* edLen) { int n=*np; int ncol=*ncolp; int nrow=ceil(n/(double)8); uint8_t split[nrow][ncol]; int i=0,j=0; /*Rprintf("n=%i nrow=%i ncol=%i\n",n,nrow,ncol); Rprintf("got\n"); for(i=0;in/2) { for(j=0;j=2)//if not trivial split {nNodes++; gn=nNodes; } else { gn=lsb(sp); } // Rprintf("gn=%i\n",gn); ed2[numEdges]=gn; edLen[numEdges]=w[ind[i]]; numEdges++; uint8_t* sdd=setdiff(vl,sp,nrow); for(ii=0;ii= 0; j--) neworder[iii--] = L[i + m * j] + 1; for (j = 0; j < pos[i]; j++) { k = e[L[i + m * j] + Nedge]; if (k > n) bar_reorder2(k, n, m, Nedge, e, neworder, L, pos); } } #define update_L(x)\ k = e_reord[i] - Ntip - 1;\ L[k + Nnode * pos[k]] = x;\ pos[k]++ SEXP bitsplits_multiPhylo(SEXP x, SEXP n, SEXP nr) { int Ntip, Nnode, Nr, Ntrees, itr, Nc, *e, *e_reord, Nedge, *L, *pos, i, j, k, ispl, *newor, d, inod, y, *rfreq, new_split; unsigned char *split, *rmat; SEXP mat, freq, ans, EDGE, final_nc; PROTECT(x = coerceVector(x, VECSXP)); PROTECT(n = coerceVector(n, INTSXP)); /* nb of tips */ PROTECT(nr = coerceVector(nr, INTSXP)); /* nb of rows in the matrix of splits */ Ntrees = LENGTH(x); Ntip = *INTEGER(n); Nr = *INTEGER(nr); Nc = (Ntip - 3) * Ntrees; /* the maximum number of splits that can be found */ /* Rprintf("Nc = %d\n", Nc); */ PROTECT(mat = allocVector(RAWSXP, Nr * Nc)); PROTECT(freq = allocVector(INTSXP, Nc)); rmat = RAW(mat); rfreq = INTEGER(freq); memset(rmat, 0, Nr * Nc * sizeof(unsigned char)); /* memset(rfreq, 0, Nc * sizeof(int)); */ split = (unsigned char*)R_alloc(Nr, sizeof(unsigned char)); ispl = 0; /* nb of splits already stored */ for (itr = 0; itr < Ntrees; itr++) { /* Rprintf("itr = %d\n", itr); */ Nnode = *INTEGER(getListElement(VECTOR_ELT(x, itr), "Nnode")); PROTECT(EDGE = getListElement(VECTOR_ELT(x, itr), "edge")); e = INTEGER(EDGE); Nedge = LENGTH(EDGE)/2; /* Rprintf("Nedge = %d\n", Nedge); */ /* see explanations in ape/src/reorder_phylo.c */ L = (int*)R_alloc(Nnode * (Nedge - Ntip + 1), sizeof(int)); pos = (int*)R_alloc(Nnode, sizeof(int)); memset(pos, 0, Nnode * sizeof(int)); for (i = 0; i < Nedge; i++) { k = e[i] - Ntip - 1; j = pos[k]; pos[k]++; L[k + Nnode * j] = i; } iii = Nedge - 1; newor = (int*)R_alloc(Nedge, sizeof(int)); bar_reorder2(Ntip + 1, Ntip, Nnode, Nedge, e, newor, L, pos); e_reord = (int*)R_alloc(2 * Nedge, sizeof(int)); for (i = 0; i < Nedge; i++) newor[i]--; /* change R indices into C indices */ for (i = 0; i < Nedge; i++) { e_reord[i] = e[newor[i]]; e_reord[i + Nedge] = e[newor[i] + Nedge]; } /* the tree is now reordered */ /* reallocate L and reinitialize pos */ L = (int*)R_alloc(Nnode * Ntip, sizeof(int)); memset(pos, 0, Nnode * sizeof(int)); for (i = 0; i < Nedge; i++) { memset(split, 0, Nr * sizeof(unsigned char)); d = e_reord[i + Nedge]; if (d <= Ntip) { /* trivial split from a terminal branch */ update_L(d); continue; } inod = d - Ntip - 1; for (j = 0; j < pos[inod]; j++) { y = L[inod + Nnode * j]; /* Rprintf("itr = %d\ty = %d\n", itr, y); */ split[(y - 1) / 8] |= mask81[y % 8]; update_L(y); /* update L */ } OneWiseBitsplits(split, Nr, 1, Ntip % 8); new_split = 1; if (itr > 0) { /* if we are handling the 1st tree, no need to check cause all splits are new */ j = 0; /* column of rmat */ k = 0; /* row */ y = 0; /* number of columns of rmat to shift */ while (j < ispl) { if (split[k] != rmat[k + y]) { /* the two splits are different so move to the next col of rmat */ j++; k = 0; y += Nr; } else k++; if (k == Nr) { /* the two splits are the same, so stop here */ rfreq[j]++; new_split = 0; break; } } } if (new_split) { /* Rprintf("ispl = %d\n", ispl); */ for (j = 0; j < Nr; j++) rmat[j + ispl * Nr] = split[j]; rfreq[ispl] = 1; ispl++; } } UNPROTECT(1); } PROTECT(ans = allocVector(VECSXP, 3)); PROTECT(final_nc = allocVector(INTSXP, 1)); INTEGER(final_nc)[0] = ispl; SET_VECTOR_ELT(ans, 0, mat); SET_VECTOR_ELT(ans, 1, freq); SET_VECTOR_ELT(ans, 2, final_nc); UNPROTECT(7); return ans; } ape/src/dist_nodes.c0000644000175100001440000000263613017516351014134 0ustar hornikusers/* dist_nodes.c 2012-08-14 */ /* Copyright 2012 Emmanuel Paradis */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include #define DINDEX2(i, j) i + NM * j /* The algorithm is pretty simple: the tree must be in cladewise order because the edges are visited contiguously. Each edge gives trivially one distance, then by moving up along the edge matrix, one finds nodes that have already been visited and the distance matrix can be updated. */ void dist_nodes(int *n, int *m, int *e1, int *e2, double *el, int *N, double *D) /* n: nb of tips, m: nb of nodes, N: nb of edges */ { int i, j, k, a, d, NM = *n + *m, ROOT; double x; ROOT = e1[0]; d = e2[0]; /* the 2 nodes of the 1st edge */ D[DINDEX2(ROOT, d)] = D[DINDEX2(d, ROOT)] = el[0]; /* the 1st edge gives the 1st distance */ /* go down along the edge matrix starting at the 2nd edge: */ for (i = 1; i < *N; i++) { a = e1[i]; d = e2[i]; x = el[i]; /* get the i-th nodes and branch length */ D[DINDEX2(a, d)] = D[DINDEX2(d, a)] = x; /* then go up along the edge matrix from the i-th edge to visit the nodes already visited and update the distances: */ for (j = i - 1; j >= 0; j--) { k = e2[j]; if (k == a) continue; D[DINDEX2(k, d)] = D[DINDEX2(d, k)] = D[DINDEX2(a, k)] + x; } if (k != ROOT) D[DINDEX2(ROOT, d)] = D[DINDEX2(d, ROOT)] = D[DINDEX2(ROOT, a)] + x; } } ape/src/tree_phylo.c0000644000175100001440000000360713017516351014152 0ustar hornikusers/* tree_phylo.c 2012-04-30 */ /* Copyright 2008-2012 Emmanuel Paradis */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include "me.h" static int curnod, curtip, iedge; #define DO_EDGE\ el[iedge] = EDGE->distance;\ if (leaf(EDGE->head)) {\ edge2[iedge] = curtip;\ ilab[curtip - 1] = EDGE->head->label;\ iedge++;\ curtip++;\ } else {\ edge2[iedge] = curnod;\ iedge++;\ subtree2phylo(EDGE->head, edge1, edge2, el, ilab);\ } int leaf(node *v) { int count = 0; if (NULL != v->parentEdge) count++; if (NULL != v->leftEdge) count++; if (NULL != v->rightEdge) count++; if (NULL != v->middleEdge) count++; if (count > 1) return(0); return(1); } void subtree2phylo(node *parent, int *edge1, int *edge2, double *el, int *ilab) { edge *EDGE; int localnode; EDGE = parent->leftEdge; /* 'localnode' keeps a copy of the node ancestor # between the two (recursive) calls of subtree2phylo */ localnode = edge1[iedge] = curnod; curnod++; DO_EDGE EDGE = parent->rightEdge; edge1[iedge] = localnode; DO_EDGE } /* transforms a 'tree' struc of pointers into an object of class "phylo" assumes the tree is unrooted and binary, so there are 2n - 3 edges assumes labels are int */ void tree2phylo(tree *T, int *edge1, int *edge2, double *el, int *ilab, int n) { edge *EDGE; curnod = n + 1; /* the root for ape */ /* there's in fact only one edge from the "root" which is a tip in ape's terminology (i.e., a node of degree 1) */ EDGE = T->root->leftEdge; edge1[0] = curnod; edge2[0] = 1; /* <- the 1st tip */ ilab[0] = T->root->label; el[0] = EDGE->distance; /* now can initialize these two: */ curtip = 2; /* <- the 2nd tip */ iedge = 1; /* <- the 2nd edge */ edge1[iedge] = curnod; /* 'T->root->leftEdge->head' is the root for ape, so don't need to test if it's a leaf */ subtree2phylo(EDGE->head, edge1, edge2, el, ilab); } ape/src/me_balanced.c0000644000175100001440000003427613017516351014220 0ustar hornikusers/* me_balanced.c 2012-04-30 */ /* Copyright 2007 Vincent Lefort BMEsplitEdge() modified by Emmanuel Paradis */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include "me.h" void BalWFext(edge *e, double **A) /*works except when e is the one edge inserted to new vertex v by firstInsert*/ { edge *f, *g; if ((leaf(e->head)) && (leaf(e->tail))) e->distance = A[e->head->index][e->head->index]; else if (leaf(e->head)) { f = e->tail->parentEdge; g = siblingEdge(e); e->distance = 0.5*(A[e->head->index][g->head->index] + A[e->head->index][f->head->index] - A[g->head->index][f->head->index]); } else { f = e->head->leftEdge; g = e->head->rightEdge; e->distance = 0.5*(A[g->head->index][e->head->index] + A[f->head->index][e->head->index] - A[f->head->index][g->head->index]); } } void BalWFint(edge *e, double **A) { int up, down, left, right; up = e->tail->index; down = (siblingEdge(e))->head->index; left = e->head->leftEdge->head->index; right = e->head->rightEdge->head->index; e->distance = 0.25*(A[up][left] + A[up][right] + A[left][down] + A[right][down]) - 0.5*(A[down][up] + A[left][right]); } void assignBMEWeights(tree *T, double **A) { edge *e; e = depthFirstTraverse(T,NULL); while (NULL != e) { if ((leaf(e->head)) || (leaf(e->tail))) BalWFext(e,A); else BalWFint(e,A); e = depthFirstTraverse(T,e); } } void BMEcalcDownAverage(tree *T, node *v, edge *e, double **D, double **A) { edge *left, *right; if (leaf(e->head)) A[e->head->index][v->index] = D[v->index2][e->head->index2]; else { left = e->head->leftEdge; right = e->head->rightEdge; A[e->head->index][v->index] = 0.5 * A[left->head->index][v->index] + 0.5 * A[right->head->index][v->index]; } } void BMEcalcUpAverage(tree *T, node *v, edge *e, double **D, double **A) { edge *up,*down; if (T->root == e->tail) A[v->index][e->head->index] = D[v->index2][e->tail->index2]; /*for now, use convention v->index first => looking up v->index second => looking down */ else { up = e->tail->parentEdge; down = siblingEdge(e); A[v->index][e->head->index] = 0.5 * A[v->index][up->head->index] +0.5 * A[down->head->index][v->index]; } } void BMEcalcNewvAverages(tree *T, node *v, double **D, double **A) { /*loop over edges*/ /*depth-first search*/ edge *e; e = NULL; e = depthFirstTraverse(T,e); /*the downward averages need to be calculated from bottom to top */ while(NULL != e) { BMEcalcDownAverage(T,v,e,D,A); e = depthFirstTraverse(T,e); } e = topFirstTraverse(T,e); /*the upward averages need to be calculated from top to bottom */ while(NULL != e) { BMEcalcUpAverage(T,v,e,D,A); e = topFirstTraverse(T,e); } } /*update Pair updates A[nearEdge][farEdge] and makes recursive call to subtree beyond farEdge*/ /*root is head or tail of edge being split, depending on direction toward v*/ void updatePair(double **A, edge *nearEdge, edge *farEdge, node *v, node *root, double dcoeff, int direction) { edge *sib; switch(direction) /*the various cases refer to where the new vertex has been inserted, in relation to the edge nearEdge*/ { case UP: /*this case is called when v has been inserted above or skew to farEdge*/ /*do recursive calls first!*/ if (NULL != farEdge->head->leftEdge) updatePair(A,nearEdge,farEdge->head->leftEdge,v,root,dcoeff,UP); if (NULL != farEdge->head->rightEdge) updatePair(A,nearEdge,farEdge->head->rightEdge,v,root,dcoeff,UP); A[farEdge->head->index][nearEdge->head->index] = A[nearEdge->head->index][farEdge->head->index] = A[farEdge->head->index][nearEdge->head->index] + dcoeff*A[farEdge->head->index][v->index] - dcoeff*A[farEdge->head->index][root->index]; break; case DOWN: /*called when v has been inserted below farEdge*/ if (NULL != farEdge->tail->parentEdge) updatePair(A,nearEdge,farEdge->tail->parentEdge,v,root,dcoeff,DOWN); sib = siblingEdge(farEdge); if (NULL != sib) updatePair(A,nearEdge,sib,v,root,dcoeff,UP); A[farEdge->head->index][nearEdge->head->index] = A[nearEdge->head->index][farEdge->head->index] = A[farEdge->head->index][nearEdge->head->index] + dcoeff*A[v->index][farEdge->head->index] - dcoeff*A[farEdge->head->index][root->index]; } } void updateSubTree(double **A, edge *nearEdge, node *v, node *root, node *newNode, double dcoeff, int direction) { edge *sib; switch(direction) { case UP: /*newNode is above the edge nearEdge*/ A[v->index][nearEdge->head->index] = A[nearEdge->head->index][v->index]; A[newNode->index][nearEdge->head->index] = A[nearEdge->head->index][newNode->index] = A[nearEdge->head->index][root->index]; if (NULL != nearEdge->head->leftEdge) updateSubTree(A, nearEdge->head->leftEdge, v, root, newNode, 0.5*dcoeff, UP); if (NULL != nearEdge->head->rightEdge) updateSubTree(A, nearEdge->head->rightEdge, v, root, newNode, 0.5*dcoeff, UP); updatePair(A, nearEdge, nearEdge, v, root, dcoeff, UP); break; case DOWN: /*newNode is below the edge nearEdge*/ A[nearEdge->head->index][v->index] = A[v->index][nearEdge->head->index]; A[newNode->index][nearEdge->head->index] = A[nearEdge->head->index][newNode->index] = 0.5*(A[nearEdge->head->index][root->index] + A[v->index][nearEdge->head->index]); sib = siblingEdge(nearEdge); if (NULL != sib) updateSubTree(A, sib, v, root, newNode, 0.5*dcoeff, SKEW); if (NULL != nearEdge->tail->parentEdge) updateSubTree(A, nearEdge->tail->parentEdge, v, root, newNode, 0.5*dcoeff, DOWN); updatePair(A, nearEdge, nearEdge, v, root, dcoeff, DOWN); break; case SKEW: /*newNode is neither above nor below nearEdge*/ A[v->index][nearEdge->head->index] = A[nearEdge->head->index][v->index]; A[newNode->index][nearEdge->head->index] = A[nearEdge->head->index][newNode->index] = 0.5*(A[nearEdge->head->index][root->index] + A[nearEdge->head->index][v->index]); if (NULL != nearEdge->head->leftEdge) updateSubTree(A, nearEdge->head->leftEdge, v, root, newNode, 0.5*dcoeff,SKEW); if (NULL != nearEdge->head->rightEdge) updateSubTree(A, nearEdge->head->rightEdge, v, root, newNode, 0.5*dcoeff,SKEW); updatePair(A, nearEdge, nearEdge, v, root, dcoeff, UP); } } /*we update all the averages for nodes (u1,u2), where the insertion point of v is in "direction" from both u1 and u2 */ /*The general idea is to proceed in a direction from those edges already corrected */ /*r is the root of the tree relative to the inserted node*/ void BMEupdateAveragesMatrix(double **A, edge *e, node *v,node *newNode) { edge *sib, *par, *left, *right; /*first, update the v,newNode entries*/ A[newNode->index][newNode->index] = 0.5*(A[e->head->index][e->head->index] + A[v->index][e->head->index]); A[v->index][newNode->index] = A[newNode->index][v->index] = A[v->index][e->head->index]; A[v->index][v->index] = 0.5*(A[e->head->index][v->index] + A[v->index][e->head->index]); left = e->head->leftEdge; right = e->head->rightEdge; if (NULL != left) updateSubTree(A,left,v,e->head,newNode,0.25,UP); /*updates left and below*/ if (NULL != right) updateSubTree(A,right,v,e->head,newNode,0.25,UP); /*updates right and below*/ sib = siblingEdge(e); if (NULL != sib) updateSubTree(A,sib,v,e->head,newNode,0.25,SKEW); /*updates sib and below*/ par = e->tail->parentEdge; if (NULL != par) updateSubTree(A,par,v,e->head,newNode,0.25,DOWN); /*updates par and above*/ /*must change values A[e->head][*] last, as they are used to update the rest of the matrix*/ A[newNode->index][e->head->index] = A[e->head->index][newNode->index] = A[e->head->index][e->head->index]; A[v->index][e->head->index] = A[e->head->index][v->index]; updatePair(A,e,e,v,e->head,0.5,UP); /*updates e->head fields only*/ } /*A is tree below sibling, B is tree below edge, C is tree above edge*/ double wf3(double D_AB, double D_AC, double D_kB, double D_kC) { return(D_AC + D_kB - D_AB - D_kC); } void BMEtestEdge(edge *e, node *v, double **A) { edge *up, *down; down = siblingEdge(e); up = e->tail->parentEdge; e->totalweight = wf3(A[e->head->index][down->head->index], A[down->head->index][e->tail->index], A[e->head->index][v->index], A[v->index][e->tail->index]) + up->totalweight; } void BMEsplitEdge(tree *T, node *v, edge *e, double **A) { edge *newPendantEdge; edge *newInternalEdge; node *newNode; int nodeLabel = 0;//char nodeLabel[NODE_LABEL_LENGTH]; char edgeLabel1[EDGE_LABEL_LENGTH]; char edgeLabel2[EDGE_LABEL_LENGTH]; //snprintf(nodeLabel,1,""); //sprintf(edgeLabel1,"E%d",T->size); //sprintf(edgeLabel2,"E%d",T->size+1); snprintf(edgeLabel1,EDGE_LABEL_LENGTH,"E%d",T->size); snprintf(edgeLabel2,EDGE_LABEL_LENGTH,"E%d",T->size+1); /*make the new node and edges*/ newNode = makeNewNode(nodeLabel,T->size+1); newPendantEdge = makeEdge(edgeLabel1,newNode,v,0.0); newInternalEdge = makeEdge(edgeLabel2,newNode,e->head,0.0); /*update the matrix of average distances*/ BMEupdateAveragesMatrix(A,e,v,newNode); /*put them in the correct topology*/ newNode->parentEdge = e; e->head->parentEdge = newInternalEdge; v->parentEdge = newPendantEdge; e->head = newNode; T->size = T->size + 2; if (e->tail->leftEdge == e) /*actually this is totally arbitrary and probably unnecessary*/ { newNode->leftEdge = newInternalEdge; newNode->rightEdge = newPendantEdge; } else { newNode->leftEdge = newInternalEdge; newNode->rightEdge = newPendantEdge; } } tree *BMEaddSpecies(tree *T,node *v, double **D, double **A) /*the key function of the program addSpeices inserts the node v to the tree T. It uses testEdge to see what the relative weight would be if v split a particular edge. Once insertion point is found, v is added to T, and A is updated. Edge weights are not assigned until entire tree is build*/ { tree *T_e; edge *e; /*loop variable*/ edge *e_min; /*points to best edge seen thus far*/ double w_min = 0.0; /*used to keep track of tree weights*/ /*initialize variables as necessary*/ /*CASE 1: T is empty, v is the first node*/ if (NULL == T) /*create a tree with v as only vertex, no edges*/ { T_e = newTree(); T_e->root = v; /*note that we are rooting T arbitrarily at a leaf. T->root is not the phylogenetic root*/ v->index = 0; T_e->size = 1; return(T_e); } /*CASE 2: T is a single-vertex tree*/ if (1 == T->size) { v->index = 1; e = makeEdge("",T->root,v,0.0); //sprintf(e->label,"E1"); snprintf(e->label,EDGE_LABEL_LENGTH,"E1"); A[v->index][v->index] = D[v->index2][T->root->index2]; T->root->leftEdge = v->parentEdge = e; T->size = 2; return(T); } /*CASE 3: T has at least two nodes and an edge. Insert new node by breaking one of the edges*/ v->index = T->size; BMEcalcNewvAverages(T,v,D,A); /*calcNewvAverages will update A for the row and column include the node v. Will do so using pre-existing averages in T and information from A,D*/ e_min = T->root->leftEdge; e = e_min->head->leftEdge; while (NULL != e) { BMEtestEdge(e,v,A); /*testEdge tests weight of tree if loop variable e is the edge split, places this value in the e->totalweight field */ if (e->totalweight < w_min) { e_min = e; w_min = e->totalweight; } e = topFirstTraverse(T,e); } /*e_min now points at the edge we want to split*/ /* if (verbose) printf("Inserting %s between %s and %s on %s\n",v->label,e_min->tail->label, e_min->head->label,e_min->label);*/ BMEsplitEdge(T,v,e_min,A); return(T); } /*calcUpAverages will ensure that A[e->head->index][f->head->index] is filled for any f >= g. Works recursively*/ void calcUpAverages(double **D, double **A, edge *e, edge *g) { node *u,*v; edge *s; if (!(leaf(g->tail))) { calcUpAverages(D,A,e,g->tail->parentEdge); s = siblingEdge(g); u = g->tail; v = s->head; A[e->head->index][g->head->index] = A[g->head->index][e->head->index] = 0.5*(A[e->head->index][u->index] + A[e->head->index][v->index]); } } void makeBMEAveragesTable(tree *T, double **D, double **A) { edge *e, *f, *exclude; node *u,*v; /*first, let's deal with the averages involving the root of T*/ e = T->root->leftEdge; f = depthFirstTraverse(T,NULL); while (NULL != f) { if (leaf(f->head)) { A[e->head->index][f->head->index] = A[f->head->index][e->head->index] = D[e->tail->index2][f->head->index2]; } else { u = f->head->leftEdge->head; v = f->head->rightEdge->head; A[e->head->index][f->head->index] = A[f->head->index][e->head->index] = 0.5*(A[e->head->index][u->index] + A[e->head->index][v->index]); } f = depthFirstTraverse(T,f); } e = depthFirstTraverse(T,NULL); while (T->root->leftEdge != e) { f = exclude = e; while (T->root->leftEdge != f) { if (f == exclude) exclude = exclude->tail->parentEdge; else if (leaf(e->head)) { if (leaf(f->head)) A[e->head->index][f->head->index] = A[f->head->index][e->head->index] = D[e->head->index2][f->head->index2]; else { u = f->head->leftEdge->head; /*since f is chosen using a depth-first search, other values have been calculated*/ v = f->head->rightEdge->head; A[e->head->index][f->head->index] = A[f->head->index][e->head->index] = 0.5*(A[e->head->index][u->index] + A[e->head->index][v->index]); } } else { u = e->head->leftEdge->head; v = e->head->rightEdge->head; A[e->head->index][f->head->index] = A[f->head->index][e->head->index] = 0.5*(A[f->head->index][u->index] + A[f->head->index][v->index]); } f = depthFirstTraverse(T,f); } e = depthFirstTraverse(T,e); } e = depthFirstTraverse(T,NULL); while (T->root->leftEdge != e) { calcUpAverages(D,A,e,e); /*calculates averages for A[e->head->index][g->head->index] for any edge g in path from e to root of tree*/ e = depthFirstTraverse(T,e); } } /*makeAveragesMatrix*/ ape/src/reorder_phylo.c0000644000175100001440000001063013017516351014647 0ustar hornikusers/* reorder_phylo.c 2012-09-03 */ /* Copyright 2008-2012 Emmanuel Paradis */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include static int iii; void foo_reorder(int node, int n, int m, int *e1, int *e2, int *neworder, int *L, int *pos) { int i = node - n - 1, j, k; /* 'i' is the C index corresponding to 'node' */ for (j = 0; j < pos[i]; j++) { k = L[i + m * j]; neworder[iii++] = k + 1; if (e2[k] > n) /* is it an internal edge? */ foo_reorder(e2[k], n, m, e1, e2, neworder, L, pos); } } void bar_reorder(int node, int n, int m, int *e1, int *e2, int *neworder, int *L, int *pos) { int i = node - n - 1, j, k; for (j = pos[i] - 1; j >= 0; j--) neworder[iii--] = L[i + m * j] + 1; for (j = 0; j < pos[i]; j++) { k = e2[L[i + m * j]]; if (k > n) bar_reorder(k, n, m, e1, e2, neworder, L, pos); } } void neworder_phylo(int *n, int *e1, int *e2, int *N, int *neworder, int *order) /* n: nb of tips m: nb of nodes N: nb of edges */ { int i, j, k, *L, *pos, m = *N - *n + 1, degrmax = *n - m + 1; /* degrmax is the largest value that a node degree can be */ /* L is a 1-d array storing, for each node, the C indices of the rows of the edge matrix where the node is ancestor (i.e., present in the 1st column). It is used in the same way than a matrix (which is actually a vector) is used in R as a 2-d structure. */ L = (int*)R_alloc(m * degrmax, sizeof(int)); /* pos gives the position for each 'row' of L, that is the number of elements which have already been stored for that 'row'. */ pos = (int*)R_alloc(m, sizeof(int)); memset(pos, 0, m * sizeof(int)); /* we now go down along the edge matrix */ for (i = 0; i < *N; i++) { k = e1[i] - *n - 1; /* k is the 'row' index in L corresponding to node e1[i] */ j = pos[k]; /* the current 'column' position corresponding to k */ pos[k]++; /* increment in case the same node is found in another row of the edge matrix */ L[k + m * j] = i; } /* L is now ready: we can start the recursive calls. */ /* We start with the root 'n + 1': its index will be changed into the corresponding C index inside the recursive function. */ switch(*order) { case 1 : iii = 0; foo_reorder(*n + 1, *n, m, e1, e2, neworder, L, pos); break; case 2 : iii = *N - 1; bar_reorder(*n + 1, *n, m, e1, e2, neworder, L, pos); break; } } #define DO_NODE_PRUNING\ /* go back down in `edge' to set `neworder' */\ for (j = 0; j <= i; j++) {\ /* if find the edge where `node' is */\ /* the descendant, make as ready */\ if (edge2[j] == node) ready[j] = 1;\ if (edge1[j] != node) continue;\ neworder[nextI] = j + 1;\ ready[j] = 0; /* mark the edge as done */\ nextI++;\ } void neworder_pruningwise(int *ntip, int *nnode, int *edge1, int *edge2, int *nedge, int *neworder) { int *ready, *Ndegr, i, j, node, nextI, n; nextI = *ntip + *nnode; Ndegr = (int*)R_alloc(nextI, sizeof(int)); memset(Ndegr, 0, nextI*sizeof(int)); for (i = 0; i < *nedge; i++) (Ndegr[edge1[i] - 1])++; ready = (int*)R_alloc(*nedge, sizeof(int)); /* `ready' indicates whether an edge is ready to be */ /* collected; only the terminal edges are initially ready */ for (i = 0; i < *nedge; i++) ready[i] = (edge2[i] <= *ntip) ? 1 : 0; /* `n' counts the number of times a node has been seen. */ /* This algo will work if the tree is in cladewise order, */ /* so that the nodes of "cherries" will be contiguous in `edge'. */ n = 0; nextI = 0; while (nextI < *nedge - Ndegr[*ntip]) { for (i = 0; i < *nedge; i++) { if (!ready[i]) continue; if (!n) { /* if found an edge ready, initialize `node' and start counting */ node = edge1[i]; n = 1; } else { /* else counting has already started */ if (edge1[i] == node) n++; else { /* if the node has changed we checked that all edges */ /* from `node' have been found */ if (n == Ndegr[node - 1]) { DO_NODE_PRUNING } /* in all cases reset `n' and `node' and carry on */ node = edge1[i]; n = 1; } } /* go to the next edge */ /* if at the end of `edge', check that we can't do a node */ if (n == Ndegr[node - 1]) { DO_NODE_PRUNING n = 0; } } } for (i = 0; i < *nedge; i++) { if (!ready[i]) continue; neworder[nextI] = i + 1; nextI++; } } ape/src/me.h0000644000175100001440000000635313017516351012407 0ustar hornikusers/* me.h 2012-04-30 */ /* Copyright 2007-2008 Vincent Lefort, modified by Emmanuel Paradis */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include #ifndef NONE #define NONE 0 #endif #ifndef UP #define UP 1 #endif #ifndef DOWN #define DOWN 2 #endif #ifndef LEFT #define LEFT 3 #endif #ifndef RIGHT #define RIGHT 4 #endif #ifndef SKEW #define SKEW 5 #endif #ifndef MAX_LABEL_LENGTH #define MAX_LABEL_LENGTH 30 #endif //#ifndef NODE_LABEL_LENGTH //#define NODE_LABEL_LENGTH 30 //#endif #ifndef EDGE_LABEL_LENGTH #define EDGE_LABEL_LENGTH 30 #endif #ifndef MAX_DIGITS #define MAX_DIGITS 20 #endif /* #ifndef INPUT_SIZE */ /* #define INPUT_SIZE 100 */ /* #endif */ #ifndef MAX_INPUT_SIZE #define MAX_INPUT_SIZE 100000 #endif #ifndef EPSILON #define EPSILON 1.E-06 #endif #ifndef ReadOpenParenthesis #define ReadOpenParenthesis 0 #endif #ifndef ReadSubTree #define ReadSubTree 1 #endif #ifndef ReadLabel #define ReadLabel 2 #endif #ifndef ReadWeight #define ReadWeight 3 #endif #ifndef AddEdge #define AddEdge 4 #endif #define XINDEX(i, j) n*(i - 1) - i*(i - 1)/2 + j - i - 1 typedef struct word { char name[MAX_LABEL_LENGTH]; struct word *suiv; } WORD; typedef struct pointers { WORD *head; WORD *tail; } POINTERS; typedef struct node { int label; /* char label[NODE_LABEL_LENGTH]; */ struct edge *parentEdge; struct edge *leftEdge; struct edge *middleEdge; struct edge *rightEdge; int index; int index2; } node; typedef struct edge { char label[EDGE_LABEL_LENGTH]; struct node *tail; /*for edge (u,v), u is the tail, v is the head*/ struct node *head; int bottomsize; /*number of nodes below edge */ int topsize; /*number of nodes above edge */ double distance; double totalweight; } edge; typedef struct tree { char name[MAX_LABEL_LENGTH]; struct node *root; int size; double weight; } tree; typedef struct set { struct node *firstNode; struct set *secondNode; } set; void me_b(double *X, int *N, int *labels, int *nni, int *spr, int *tbr, int *edge1, int *edge2, double *el); void me_o(double *X, int *N, int *labels, int *nni, int *edge1, int *edge2, double *el); double **initDoubleMatrix(int d); double **loadMatrix (double *X, int *labels, int n, set *S); set *addToSet(node *v, set *X); node *makeNewNode(int label, int i); node *makeNode(int label, edge *parentEdge, int index); node *copyNode(node *v); edge *siblingEdge(edge *e); edge *makeEdge(char *label, node *tail, node *head, double weight); tree *newTree(); void updateSizes(edge *e, int direction); tree *detrifurcate(tree *T); void compareSets(tree *T, set *S); void partitionSizes(tree *T); edge *depthFirstTraverse(tree *T, edge *e); edge *findBottomLeft(edge *e); edge *moveRight(edge *e); edge *topFirstTraverse(tree *T, edge *e); edge *moveUpRight(edge *e); void freeMatrix(double **D, int size); void freeSet(set *S); void freeTree(tree *T); void freeSubTree(edge *e); int leaf(node *v); /* int whiteSpace(char c); */ /* node *decodeNewickSubtree(char *treeString, tree *T, int *uCount); */ /* tree *readNewickString (char *str, int numLeaves); */ void subtree2phylo(node *parent, int *edge1, int *edge2, double *el, int *ilab); void tree2phylo(tree *T, int *edge1, int *edge2, double *el, int *ilab, int n); ape/src/dist_dna.c0000644000175100001440000012106513017516351013564 0ustar hornikusers/* dist_dna.c 2016-11-28 */ /* Copyright 2005-2016 Emmanuel Paradis */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include #include "ape.h" /* from R: print(log(4), d = 22) */ #define LN4 1.386294361119890572454 /* returns 8 if the base is known surely, 0 otherwise */ #define KnownBase(a) (a & 8) /* returns 1 if the base is adenine surely, 0 otherwise */ #define IsAdenine(a) a == 136 /* returns 1 if the base is guanine surely, 0 otherwise */ #define IsGuanine(a) a == 72 /* returns 1 if the base is cytosine surely, 0 otherwise */ #define IsCytosine(a) a == 40 /* returns 1 if the base is thymine surely, 0 otherwise */ #define IsThymine(a) a == 24 /* returns 1 if the base is a purine surely, 0 otherwise */ #define IsPurine(a) a > 63 /* returns 1 if the base is a pyrimidine surely, 0 otherwise */ #define IsPyrimidine(a) a < 64 /* returns 1 if both bases are different surely, 0 otherwise */ #define DifferentBase(a, b) (a & b) < 16 /* returns 1 if both bases are the same surely, 0 otherwise */ #define SameBase(a, b) KnownBase(a) && a == b /* computes directly the determinant of a 4x4 matrix */ double detFourByFour(double *x) { double det, a33a44, a34a43, a34a42, a32a44, a32a43, a33a42, a34a41, a31a44, a31a43, a33a41, a31a42, a32a41; a33a44 = x[10]*x[15]; a34a43 = x[14]*x[11]; a34a42 = x[14]*x[7]; a32a44 = x[6]*x[15]; a32a43 = x[6]*x[11]; a33a42 = x[10]*x[7]; a34a41 = x[14]*x[3]; a31a44 = x[2]*x[15]; a31a43 = x[2]*x[11]; a33a41 = x[10]*x[3]; a31a42 = x[2]*x[7]; a32a41 = x[6]*x[3]; det = x[0]*x[5]*(a33a44 - a34a43) + x[0]*x[9]*(a34a42 - a32a44) + x[0]*x[13]*(a32a43 - a33a42) + x[4]*x[9]*(a31a44 - a34a41) + x[4]*x[13]*(a33a41 - a31a43) + x[4]*x[1]*(a34a43 - a33a44) + x[8]*x[13]*(a31a42 - a32a41) + x[8]*x[1]*(a32a44 - a34a42) + x[8]*x[5]*(a34a41 - a31a44) + x[12]*x[1]*(a33a42 - a32a43) + x[12]*x[5]*(a31a43 - a33a41) + x[12]*x[9]*(a32a41 - a31a42); return det; } #define CHECK_PAIRWISE_DELETION\ if (KnownBase(x[s1]) && KnownBase(x[s2])) L++;\ else continue; #define COUNT_TS_TV\ if (SameBase(x[s1], x[s2])) continue;\ Nd++;\ if (IsPurine(x[s1]) && IsPurine(x[s2])) {\ Ns++;\ continue;\ }\ if (IsPyrimidine(x[s1]) && IsPyrimidine(x[s2])) Ns++; void distDNA_indel(unsigned char *x, int *n, int *s, double *d) { int i1, i2, s1, s2, target, N; target = 0; for (i1 = 1; i1 < *n; i1++) { for (i2 = i1 + 1; i2 <= *n; i2++) { N = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) if ((x[s1] ^ x[s2]) & 4) N++; d[target] = ((double) N); target++; } } } void DNAbin2indelblock(unsigned char *x, int *n, int *s, int *y) { int i, j, k, pos, ngap, indel = 0; for (i = 0; i < *n; i++) { j = i; k = 0; while (k < *s) { if (x[j] == 4) { if (!indel) { pos = j; indel = 1; ngap = 1; } else ngap++; } else { if (indel) { y[pos] = ngap; indel = 0; } } j += *n; k++; } if (indel) { y[pos] = ngap; indel = 0; } } } void distDNA_indelblock(unsigned char *x, int *n, int *s, double *d) { int *y, i1, i2, s1, s2, target, Nd; y = (int*)R_alloc(*n * *s, sizeof(int)); memset(y, 0, *n * *s * sizeof(int)); DNAbin2indelblock(x, n, s, y); target = 0; for (i1 = 1; i1 < *n; i1++) { for (i2 = i1 + 1; i2 <= *n; i2++) { Nd = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) if (y[s1] != y[s2]) Nd++; d[target] = ((double) Nd); target++; } } } void distDNA_TsTv(unsigned char *x, int *n, int *s, double *d, int Ts, int pairdel) { int i1, i2, s1, s2, target, Nd, Ns; target = 0; for (i1 = 1; i1 < *n; i1++) { for (i2 = i1 + 1; i2 <= *n; i2++) { Nd = Ns = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) { if (pairdel && !(KnownBase(x[s1]) && KnownBase(x[s2]))) continue; COUNT_TS_TV } if (Ts) d[target] = ((double) Ns); /* output number of transitions */ else d[target] = ((double) Nd - Ns); /* output number of transversions */ target++; } } } void distDNA_raw(unsigned char *x, int *n, int *s, double *d, int scaled) { int i1, i2, s1, s2, target, Nd; target = 0; for (i1 = 1; i1 < *n; i1++) { for (i2 = i1 + 1; i2 <= *n; i2++) { Nd = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) if (DifferentBase(x[s1], x[s2])) Nd++; if (scaled) d[target] = ((double) Nd / *s); else d[target] = ((double) Nd); target++; } } } void distDNA_raw_pairdel(unsigned char *x, int *n, int *s, double *d, int scaled) { int i1, i2, s1, s2, target, Nd, L; target = 0; for (i1 = 1; i1 < *n; i1++) { for (i2 = i1 + 1; i2 <= *n; i2++) { Nd = L = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) { CHECK_PAIRWISE_DELETION if (DifferentBase(x[s1], x[s2])) Nd++; } if (scaled) d[target] = ((double) Nd/L); else d[target] = ((double) Nd); target++; } } } #define COMPUTE_DIST_JC69\ p = ((double) Nd/L);\ if (*gamma)\ d[target] = 0.75 * *alpha*(pow(1 - 4*p/3, -1/ *alpha) - 1);\ else d[target] = -0.75*log(1 - 4*p/3);\ if (*variance) {\ if (*gamma) var[target] = p*(1 - p)/(pow(1 - 4*p/3, -2/(*alpha + 1)) * L);\ else var[target] = p*(1 - p)/(pow(1 - 4*p/3, 2)*L);\ } void distDNA_JC69(unsigned char *x, int *n, int *s, double *d, int *variance, double *var, int *gamma, double *alpha) { int i1, i2, s1, s2, target, Nd, L; double p; L = *s; target = 0; for (i1 = 1; i1 < *n; i1++) { for (i2 = i1 + 1; i2 <= *n; i2++) { Nd = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) if (DifferentBase(x[s1], x[s2])) Nd++; COMPUTE_DIST_JC69 target++; } } } void distDNA_JC69_pairdel(unsigned char *x, int *n, int *s, double *d, int *variance, double *var, int *gamma, double *alpha) { int i1, i2, s1, s2, target, Nd, L; double p; target = 0; for (i1 = 1; i1 < *n; i1++) { for (i2 = i1 + 1; i2 <= *n; i2++) { Nd = L = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1+= *n, s2 += *n) { CHECK_PAIRWISE_DELETION if (DifferentBase(x[s1], x[s2])) Nd++; } COMPUTE_DIST_JC69 target++; } } } #define COMPUTE_DIST_K80\ P = ((double) Ns/L);\ Q = ((double) (Nd - Ns)/L);\ a1 = 1 - 2*P - Q;\ a2 = 1 - 2*Q;\ if (*gamma) {\ b = -1 / *alpha;\ d[target] = *alpha * (pow(a1, b) + 0.5*pow(a2, b) - 1.5)/2;\ }\ else d[target] = -0.5 * log(a1 * sqrt(a2));\ if (*variance) {\ if (*gamma) {\ b = -(1 / *alpha + 1);\ c1 = pow(a1, b);\ c2 = pow(a2, b);\ c3 = (c1 + c2)/2;\ } else {\ c1 = 1/a1;\ c2 = 1/a2;\ c3 = (c1 + c2)/2;\ }\ var[target] = (c1*c1*P + c3*c3*Q - pow(c1*P + c3*Q, 2))/L;\ } void distDNA_K80(unsigned char *x, int *n, int *s, double *d, int *variance, double *var, int *gamma, double *alpha) { int i1, i2, s1, s2, target, Nd, Ns, L; double P, Q, a1, a2, b, c1, c2, c3; L = *s; target = 0; for (i1 = 1; i1 < *n; i1++) { for (i2 = i1 + 1; i2 <= *n; i2++) { Nd = Ns = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1+= *n, s2 += *n) { COUNT_TS_TV } COMPUTE_DIST_K80 target++; } } } void distDNA_K80_pairdel(unsigned char *x, int *n, int *s, double *d, int *variance, double *var, int *gamma, double *alpha) { int i1, i2, s1, s2, target, Nd, Ns, L; double P, Q, a1, a2, b, c1, c2, c3; target = 0; for (i1 = 1; i1 < *n; i1++) { for (i2 = i1 + 1; i2 <= *n; i2++) { Nd = Ns = L = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) { CHECK_PAIRWISE_DELETION COUNT_TS_TV } COMPUTE_DIST_K80 target++; } } } #define COMPUTE_DIST_F81\ p = ((double) Nd/L);\ if (*gamma) d[target] = E * *alpha * (pow(1 - p/E, -1/ *alpha) - 1);\ else d[target] = -E*log(1 - p/E);\ if (*variance) {\ if (*gamma) var[target] = p*(1 - p)/(pow(1 - p/E, -2/(*alpha + 1)) * L);\ else var[target] = p*(1 - p)/(pow(1 - p/E, 2)*L);\ } void distDNA_F81(unsigned char *x, int *n, int *s, double *d, double *BF, int *variance, double *var, int *gamma, double *alpha) { int i1, i2, s1, s2, target, Nd, L; double p, E; L = *s; E = 1 - BF[0]*BF[0] - BF[1]*BF[1] - BF[2]*BF[2] - BF[3]*BF[3]; target = 0; for (i1 = 1; i1 < *n; i1++) { for (i2 = i1 + 1; i2 <= *n; i2++) { Nd = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1+= *n, s2 += *n) if (DifferentBase(x[s1], x[s2])) Nd++; COMPUTE_DIST_F81 target++; } } } void distDNA_F81_pairdel(unsigned char *x, int *n, int *s, double *d, double *BF, int *variance, double *var, int *gamma, double *alpha) { int i1, i2, s1, s2, target, Nd, L; double p, E; E = 1 - BF[0]*BF[0] - BF[1]*BF[1] - BF[2]*BF[2] - BF[3]*BF[3]; target = 0; for (i1 = 1; i1 < *n; i1++) { for (i2 = i1 + 1; i2 <= *n; i2++) { Nd = L = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) { CHECK_PAIRWISE_DELETION if (DifferentBase(x[s1], x[s2])) Nd++; } COMPUTE_DIST_F81 target++; } } } #define COUNT_TS_TV1_TV2\ if (SameBase(x[s1], x[s2])) continue;\ Nd++;\ if ((x[s1] | x[s2]) == 152 || (x[s1] | x[s2]) == 104) {\ Nv1++;\ continue;\ }\ if ((x[s1] | x[s2]) == 168 || (x[s1] | x[s2]) == 88) Nv2++; #define COMPUTE_DIST_K81\ P = ((double) (Nd - Nv1 - Nv2)/L);\ Q = ((double) Nv1/L);\ R = ((double) Nv2/L);\ a1 = 1 - 2*P - 2*Q;\ a2 = 1 - 2*P - 2*R;\ a3 = 1 - 2*Q - 2*R;\ d[target] = -0.25*log(a1*a2*a3);\ if (*variance) {\ a = (1/a1 + 1/a2)/2;\ b = (1/a1 + 1/a3)/2;\ c = (1/a2 + 1/a3)/2;\ var[target] = (a*a*P + b*b*Q + c*c*R - pow(a*P + b*Q + c*R, 2))/2;\ } void distDNA_K81(unsigned char *x, int *n, int *s, double *d, int *variance, double *var) { int i1, i2, Nd, Nv1, Nv2, L, s1, s2, target; double P, Q, R, a1, a2, a3, a, b, c; L = *s; target = 0; for (i1 = 1; i1 < *n; i1++) { for (i2 = i1 + 1; i2 <= *n; i2++) { Nd = Nv1 = Nv2 = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) { COUNT_TS_TV1_TV2 } COMPUTE_DIST_K81 target++; } } } void distDNA_K81_pairdel(unsigned char *x, int *n, int *s, double *d, int *variance, double *var) { int i1, i2, Nd, Nv1, Nv2, L, s1, s2, target; double P, Q, R, a1, a2, a3, a, b, c; target = 0; for (i1 = 1; i1 < *n; i1++) { for (i2 = i1 + 1; i2 <= *n; i2++) { Nd = Nv1 = Nv2 = L = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) { CHECK_PAIRWISE_DELETION COUNT_TS_TV1_TV2 } COMPUTE_DIST_K81 target++; } } } #define PREPARE_BF_F84\ A = (BF[0]*BF[2])/(BF[0] + BF[2]) + (BF[1]*BF[3])/(BF[1] + BF[3]);\ B = BF[0]*BF[2] + BF[1]*BF[3];\ C = (BF[0] + BF[2])*(BF[1] + BF[3]); #define COMPUTE_DIST_F84\ P = ((double) Ns/L);\ Q = ((double) (Nd - Ns)/L);\ d[target] = -2*A*log(1 - P/(2*A) - (A - B)*Q/(2*A*C)) + 2*(A - B - C)*log(1 - Q/(2*C));\ if (*variance) {\ t1 = A*C;\ t2 = C*P/2;\ t3 = (A - B)*Q/2;\ a = t1/(t1 - t2 - t3);\ b = A*(A - B)/(t1 - t2 - t3) - (A - B - C)/(C - Q/2);\ var[target] = (a*a*P + b*b*Q - pow(a*P + b*Q, 2))/L;\ } void distDNA_F84(unsigned char *x, int *n, int *s, double *d, double *BF, int *variance, double *var) { int i1, i2, Nd, Ns, L, target, s1, s2; double P, Q, A, B, C, a, b, t1, t2, t3; PREPARE_BF_F84 L = *s; target = 0; for (i1 = 1; i1 < *n; i1++) { for (i2 = i1 + 1; i2 <= *n; i2++) { Nd = Ns = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) { COUNT_TS_TV } COMPUTE_DIST_F84 target++; } } } void distDNA_F84_pairdel(unsigned char *x, int *n, int *s, double *d, double *BF, int *variance, double *var) { int i1, i2, Nd, Ns, L, target, s1, s2; double P, Q, A, B, C, a, b, t1, t2, t3; PREPARE_BF_F84 target = 0; for (i1 = 1; i1 < *n; i1++) { for (i2 = i1 + 1; i2 <= *n; i2++) { Nd = Ns = L = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) { CHECK_PAIRWISE_DELETION COUNT_TS_TV } COMPUTE_DIST_F84 target++; } } } #define COMPUTE_DIST_T92\ P = ((double) Ns/L);\ Q = ((double) (Nd - Ns)/L);\ a1 = 1 - P/wg - Q;\ a2 = 1 - 2*Q;\ d[target] = -wg*log(a1) - 0.5*(1 - wg)*log(a2);\ if (*variance) {\ c1 = 1/a1;\ c2 = 1/a2;\ c3 = wg*(c1 - c2) + c2;\ var[target] = (c1*c1*P + c3*c3*Q - pow(c1*P + c3*Q, 2))/L;\ } void distDNA_T92(unsigned char *x, int *n, int *s, double *d, double *BF, int *variance, double *var) { int i1, i2, Nd, Ns, L, target, s1, s2; double P, Q, wg, a1, a2, c1, c2, c3; L = *s; wg = 2 * (BF[1] + BF[2]) * (1 - (BF[1] + BF[2])); target = 0; for (i1 = 1; i1 < *n; i1++) { for (i2 = i1 + 1; i2 <= *n; i2++) { Nd = Ns = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) { COUNT_TS_TV } COMPUTE_DIST_T92 target++; } } } void distDNA_T92_pairdel(unsigned char *x, int *n, int *s, double *d, double *BF, int *variance, double *var) { int i1, i2, Nd, Ns, L, target, s1, s2; double P, Q, wg, a1, a2, c1, c2, c3; wg = 2 * (BF[1] + BF[2]) * (1 - (BF[1] + BF[2])); target = 0; for (i1 = 1; i1 < *n; i1++) { for (i2 = i1 + 1; i2 <= *n; i2++) { Nd = Ns = L = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) { CHECK_PAIRWISE_DELETION COUNT_TS_TV } COMPUTE_DIST_T92 target++; } } } /* returns 1 if one of the base is adenine and the other one is guanine surely, 0 otherwise */ #define AdenineAndGuanine(a, b) (a | b) == 200 /* returns 1 if one of the base is cytosine and the other one is thymine surely, 0 otherwise */ #define CytosineAndThymine(a, b) (a | b) == 56 #define PREPARE_BF_TN93\ gR = BF[0] + BF[2];\ gY = BF[1] + BF[3];\ k1 = 2 * BF[0] * BF[2] / gR;\ k2 = 2 * BF[1] * BF[3] / gY;\ k3 = 2 * (gR * gY - BF[0]*BF[2]*gY/gR - BF[1]*BF[3]*gR/gY); #define COUNT_TS1_TS2_TV\ if (DifferentBase(x[s1], x[s2])) {\ Nd++;\ if (AdenineAndGuanine(x[s1], x[s2])) {\ Ns1++;\ continue;\ }\ if (CytosineAndThymine(x[s1], x[s2])) Ns2++;\ } #define COMPUTE_DIST_TN93\ P1 = ((double) Ns1/L);\ P2 = ((double) Ns2/L);\ Q = ((double) (Nd - Ns1 - Ns2)/L);\ w1 = 1 - P1/k1 - Q/(2*gR);\ w2 = 1 - P2/k2 - Q/(2*gY);\ w3 = 1 - Q/(2*gR*gY);\ if (*gamma) {\ k4 = 2*(BF[0]*BF[2] + BF[1]*BF[3] + gR*gY);\ b = -1 / *alpha;\ c1 = pow(w1, b);\ c2 = pow(w2, b);\ c3 = pow(w3, b);\ c4 = k1*c1/(2*gR) + k2*c2/(2*gY) + k3*c3/(2*gR*gY);\ d[target] = *alpha * (k1*pow(w1, b) + k2*pow(w2, b) + k3*pow(w3, b) - k4);\ } else {\ k4 = 2*((BF[0]*BF[0] + BF[2]*BF[2])/(2*gR*gR) + (BF[2]*BF[2] + BF[3]*BF[3])/(2*gY*gY));\ c1 = 1/w1;\ c2 = 1/w2;\ c3 = 1/w3;\ c4 = k1 * c1/(2 * gR) + k2 * c2/(2 * gY) + k4 * c3;\ d[target] = -k1*log(w1) - k2*log(w2) - k3*log(w3);\ }\ if (*variance)\ var[target] = (c1*c1*P1 + c2*c2*P2 + c4*c4*Q - pow(c1*P1 + c2*P2 + c4*Q, 2))/L; void distDNA_TN93(unsigned char *x, int *n, int *s, double *d, double *BF, int *variance, double *var, int *gamma, double *alpha) { int i1, i2, Nd, Ns1, Ns2, L, target, s1, s2; double P1, P2, Q, gR, gY, k1, k2, k3, k4, w1, w2, w3, c1, c2, c3, c4, b; L = *s; PREPARE_BF_TN93 target = 0; for (i1 = 1; i1 < *n; i1++) { for (i2 = i1 + 1; i2 <= *n; i2++) { Nd = Ns1 = Ns2 = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) { COUNT_TS1_TS2_TV } COMPUTE_DIST_TN93 target++; } } } void distDNA_TN93_pairdel(unsigned char *x, int *n, int *s, double *d, double *BF, int *variance, double *var, int *gamma, double *alpha) { int i1, i2, Nd, Ns1, Ns2, L, target, s1, s2; double P1, P2, Q, gR, gY, k1, k2, k3, k4, w1, w2, w3, c1, c2, c3, c4, b; PREPARE_BF_TN93 target = 0; for (i1 = 1; i1 < *n; i1++) { for (i2 = i1 + 1; i2 <= *n; i2++) { Nd = Ns1 = Ns2 = L = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) { CHECK_PAIRWISE_DELETION COUNT_TS1_TS2_TV } COMPUTE_DIST_TN93 target++; } } } void distDNA_GG95(unsigned char *x, int *n, int *s, double *d, int *variance, double *var) { int i1, i2, s1, s2, target, GC, Nd, Ns, tl, npair; double *theta, gcprop, *P, pp, *Q, qq, *tstvr, svr, A, sum, ma /* mean alpha */, K1, K2; theta = &gcprop; P = &pp; Q = &qq; tstvr = &svr; npair = *n * (*n - 1) / 2; theta = (double*)R_alloc(*n, sizeof(double)); P = (double*)R_alloc(npair, sizeof(double)); Q = (double*)R_alloc(npair, sizeof(double)); tstvr = (double*)R_alloc(npair, sizeof(double)); /* get the proportion of GC (= theta) in each sequence */ for (i1 = 1; i1 <= *n; i1++) { GC = 0; for (s1 = i1 - 1; s1 < i1 + *n*(*s - 1); s1 += *n) if (IsCytosine(x[s1]) || IsGuanine(x[s1])) GC += 1; theta[i1 - 1] = ((double) GC / *s); } /* get the proportions of transitions and transversions, and the estimates of their ratio for each pair */ target = 0; for (i1 = 1; i1 < *n; i1++) { for (i2 = i1 + 1; i2 <= *n; i2++) { Nd = Ns = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) { COUNT_TS_TV } P[target] = ((double) Ns / *s); Q[target] = ((double) (Nd - Ns) / *s); A = log(1 - 2*Q[target]); tstvr[target] = 2*(log(1 - 2*P[target] - Q[target]) - 0.5*A)/A; target++; } } /* compute the mean alpha (ma) = mean Ts/Tv */ sum = 0; tl = 0; for (i1 = 0; i1 < npair; i1++) /* some values of tstvr are -Inf if there is no transversions observed: we exclude them */ if (R_FINITE(tstvr[i1])) { sum += tstvr[i1]; tl += 1; } ma = sum/tl; /* compute the distance for each pair */ target = 0; for (i1 = 1; i1 < *n; i1++) { for (i2 = i1 + 1; i2 <= *n; i2++) { A = 1 - 2*Q[target]; K1 = 1 + ma*(theta[i1 - 1]*(1 - theta[i1 - 1]) + theta[i2 - 1]*(1 - theta[i2 - 1])); K2 = ma*pow(theta[i1 - 1] - theta[i2 - 1], 2)/(ma + 1); d[target] = -0.5*K1*log(A) + K2*(1 - pow(A, 0.25*(ma + 1))); if (*variance) var[target] = pow(K1 + K2*0.5*(ma + 1)*pow(A, 0.25*(ma + 1)), 2)*Q[target]*(1 - Q[target])/(A*A * *s); target++; } } } void distDNA_GG95_pairdel(unsigned char *x, int *n, int *s, double *d, int *variance, double *var) { int i1, i2, s1, s2, target, *L, length, GC, Nd, Ns, tl, npair; double *theta, gcprop, *P, pp, *Q, qq, *tstvr, svr, A, sum, ma /* mean alpha */, K1, K2; theta = &gcprop; L = &length; P = &pp; Q = &qq; tstvr = &svr; npair = *n * (*n - 1) / 2; theta = (double*)R_alloc(*n, sizeof(double)); L = (int*)R_alloc(npair, sizeof(int)); P = (double*)R_alloc(npair, sizeof(double)); Q = (double*)R_alloc(npair, sizeof(double)); tstvr = (double*)R_alloc(npair, sizeof(double)); /* get the proportion of GC (= theta) in each sequence */ for (i1 = 1; i1 <= *n; i1++) { tl = GC = 0; for (s1 = i1 - 1; s1 < i1 + *n*(*s - 1); s1 += *n) { if (KnownBase(x[s1])) tl++; else continue; if (IsCytosine(x[s1]) || IsGuanine(x[s1])) GC += 1; } theta[i1 - 1] = ((double) GC / tl); } /* get the proportions of transitions and transversions, and the estimates of their ratio for each pair; we also get the sample size for each pair in L */ target = 0; for (i1 = 1; i1 < *n; i1++) { for (i2 = i1 + 1; i2 <= *n; i2++) { Nd = Ns = L[target] = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) { if (KnownBase(x[s1]) && KnownBase(x[s2])) L[target]++; else continue; COUNT_TS_TV } P[target] = ((double) Ns/L[target]); Q[target] = ((double) (Nd - Ns)/L[target]); A = log(1 - 2*Q[target]); tstvr[target] = 2*(log(1 - 2*P[target] - Q[target]) - 0.5*A)/A; target++; } } /* compute the mean alpha (ma) = mean Ts/Tv */ sum = 0; tl = 0; for (i1 = 0; i1 < npair; i1++) /* some values of tstvr are -Inf if there is no transversions observed: we exclude them */ if (R_FINITE(tstvr[i1])) { sum += tstvr[i1]; tl += 1; } ma = sum/tl; /* compute the distance for each pair */ target = 0; for (i1 = 1; i1 < *n; i1++) { for (i2 = i1 + 1; i2 <= *n; i2++) { A = 1 - 2*Q[target]; K1 = 1 + ma*(theta[i1 - 1]*(1 - theta[i1 - 1]) + theta[i2 - 1]*(1 - theta[i2 - 1])); K2 = ma*pow(theta[i1 - 1] - theta[i2 - 1], 2)/(ma + 1); d[target] = -0.5*K1*log(A) + K2*(1 - pow(A, 0.25*(ma + 1))); if (*variance) var[target] = pow(K1 + K2*0.5*(ma + 1)*pow(A, 0.25*(ma + 1)), 2)*Q[target]*(1 - Q[target])/(A*A*L[target]); target++; } } } #define DO_CONTINGENCY_NUCLEOTIDES\ switch (x[s1]) {\ case 136 : m = 0; break;\ case 72 : m = 1; break;\ case 40 : m = 2; break;\ case 24 : m = 3; break;\ }\ switch (x[s2]) {\ case 72 : m += 4; break;\ case 40 : m += 8; break;\ case 24 : m += 12; break;\ }\ Ntab[m]++; #define COMPUTE_DIST_LogDet\ for (k = 0; k < 16; k++) Ftab[k] = ((double) Ntab[k]/L);\ d[target] = -log(detFourByFour(Ftab))/4 - LN4;\ if (*variance) {\ /* For the inversion, we first make U an identity matrix */\ for (k = 1; k < 15; k++) U[k] = 0;\ U[0] = U[5] = U[10] = U[15] = 1;\ /* The matrix is not symmetric, so we use 'dgesv'. */\ /* This subroutine puts the result in U. */\ F77_CALL(dgesv)(&ndim, &ndim, Ftab, &ndim, ipiv, U, &ndim, &info);\ var[target] = (U[0]*U[0]*Ftab[0] + U[1]*U[1]*Ftab[4] +\ U[2]*U[2]*Ftab[8] + U[3]*U[3]*Ftab[12] +\ U[4]*U[4]*Ftab[1] + U[5]*U[5]*Ftab[5] +\ U[6]*U[6]*Ftab[9] + U[7]*U[7]*Ftab[13] +\ U[8]*U[8]*Ftab[2] + U[9]*U[9]*Ftab[6] +\ U[10]*U[10]*Ftab[10] + U[11]*U[11]*Ftab[14] +\ U[12]*U[12]*Ftab[3] + U[13]*U[13]*Ftab[7] +\ U[14]*U[14]*Ftab[11] + U[15]*U[15]*Ftab[15] - 16)/(L*16);\ } void distDNA_LogDet(unsigned char *x, int *n, int *s, double *d, int *variance, double *var) { int i1, i2, k, m, s1, s2, target, L, Ntab[16], ndim = 4, info, ipiv[16]; double Ftab[16], U[16]; L = *s; target = 0; for (i1 = 1; i1 < *n; i1++) { for (i2 = i1 + 1; i2 <= *n; i2++) { for (k = 0; k < 16; k++) Ntab[k] = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) { DO_CONTINGENCY_NUCLEOTIDES } COMPUTE_DIST_LogDet target++; } } } void distDNA_LogDet_pairdel(unsigned char *x, int *n, int *s, double *d, int *variance, double *var) { int i1, i2, k, m, s1, s2, target, L, Ntab[16], ndim = 4, info, ipiv[16]; double Ftab[16], U[16]; target = 0; for (i1 = 1; i1 < *n; i1++) { for (i2 = i1 + 1; i2 <= *n; i2++) { for (k = 0; k < 16; k++) Ntab[k] = 0; L = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) { CHECK_PAIRWISE_DELETION DO_CONTINGENCY_NUCLEOTIDES } COMPUTE_DIST_LogDet target++; } } } void distDNA_BH87(unsigned char *x, int *n, int *s, double *d, int *variance, double *var) /* For the moment there is no need to check for pairwise deletions since DO_CONTINGENCY_NUCLEOTIDES considers only the known nucleotides. In effect the pairwise deletion has possibly been done before. The sequence length(s) are used only to compute the variances, which is currently not available. */ { int i1, i2, k, kb, s1, s2, m, Ntab[16], ROWsums[4]; double P12[16], P21[16]; for (i1 = 1; i1 < *n; i1++) { for (i2 = i1 + 1; i2 <= *n; i2++) { for (k = 0; k < 16; k++) Ntab[k] = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) { DO_CONTINGENCY_NUCLEOTIDES } /* get the rowwise sums of Ntab */ ROWsums[0] = Ntab[0] + Ntab[4] + Ntab[8] + Ntab[12]; ROWsums[1] = Ntab[1] + Ntab[5] + Ntab[9] + Ntab[13]; ROWsums[2] = Ntab[2] + Ntab[6] + Ntab[10] + Ntab[14]; ROWsums[3] = Ntab[3] + Ntab[7] + Ntab[11] + Ntab[15]; for (k = 0; k < 16; k++) P12[k] = ((double) Ntab[k]); /* scale each element of P12 by its rowwise sum */ for (k = 0; k < 4; k++) for (kb = 0; kb < 16; kb += 4) P12[k + kb] = P12[k + kb]/ROWsums[k]; d[*n*(i2 - 1) + i1 - 1] = -log(detFourByFour(P12))/4; /* compute the columnwise sums of Ntab: these are the rowwise sums of its transpose */ ROWsums[0] = Ntab[0] + Ntab[1] + Ntab[2] + Ntab[3]; ROWsums[1] = Ntab[4] + Ntab[5] + Ntab[6] + Ntab[7]; ROWsums[2] = Ntab[8] + Ntab[9] + Ntab[10] + Ntab[11]; ROWsums[3] = Ntab[12] + Ntab[13] + Ntab[14] + Ntab[15]; /* transpose Ntab and store the result in P21 */ for (k = 0; k < 4; k++) for (kb = 0; kb < 4; kb++) P21[kb + 4*k] = Ntab[k + 4*kb]; /* scale as above */ for (k = 0; k < 4; k++) for (kb = 0; kb < 16; kb += 4) P21[k + kb] = P21[k + kb]/ROWsums[k]; d[*n*(i1 - 1) + i2 - 1] = -log(detFourByFour(P21))/4; } } } #define COMPUTE_DIST_ParaLin\ for (k = 0; k < 16; k++) Ftab[k] = ((double) Ntab[k]/L);\ d[target] = -log(detFourByFour(Ftab)/\ sqrt(find[0][i1 - 1]*find[1][i1 - 1]*find[2][i1 - 1]*find[3][i1 - 1]*\ find[0][i2 - 1]*find[1][i2 - 1]*find[2][i2 - 1]*find[3][i2 - 1]))/4;\ if (*variance) {\ /* For the inversion, we first make U an identity matrix */\ for (k = 1; k < 15; k++) U[k] = 0;\ U[0] = U[5] = U[10] = U[15] = 1;\ /* The matrix is not symmetric, so we use 'dgesv'. */\ /* This subroutine puts the result in U. */\ F77_CALL(dgesv)(&ndim, &ndim, Ftab, &ndim, ipiv, U, &ndim, &info);\ var[target] = (U[0]*U[0]*Ftab[0] + U[1]*U[1]*Ftab[4] +\ U[2]*U[2]*Ftab[8] + U[3]*U[3]*Ftab[12] +\ U[4]*U[4]*Ftab[1] + U[5]*U[5]*Ftab[5] +\ U[6]*U[6]*Ftab[9] + U[7]*U[7]*Ftab[13] +\ U[8]*U[8]*Ftab[2] + U[9]*U[9]*Ftab[6] +\ U[10]*U[10]*Ftab[10] + U[11]*U[11]*Ftab[14] +\ U[12]*U[12]*Ftab[3] + U[13]*U[13]*Ftab[7] +\ U[14]*U[14]*Ftab[11] + U[15]*U[15]*Ftab[15] -\ 4*(1/sqrt(find[0][i1 - 1]*find[0][i2 - 1]) +\ 1/sqrt(find[1][i1 - 1]*find[1][i2 - 1]) +\ 1/sqrt(find[2][i1 - 1]*find[2][i2 - 1]) +\ 1/sqrt(find[3][i1 - 1]*find[3][i2 - 1])))/(L*16);\ } void distDNA_ParaLin(unsigned char *x, int *n, int *s, double *d, int *variance, double *var) { int i1, i2, k, s1, s2, m, target, L, Ntab[16], ndim = 4, info, ipiv[16]; double Ftab[16], U[16], *find[4]; L = *s; for (k = 0; k < 4; k++) find[k] = (double*)R_alloc(*n, sizeof(double)); for (i1 = 0; i1 < *n; i1++) for (k = 0; k < 4; k++) find[k][i1] = 0.0; for (i1 = 0; i1 < *n; i1++) { for (s1 = i1; s1 < i1 + *n*(*s - 1) + 1; s1+= *n) { switch (x[s1]) { case 136 : find[0][i1]++; break; case 40 : find[1][i1]++; break; case 72 : find[2][i1]++; break; case 24 : find[3][i1]++; break; } } for (k = 0; k < 4; k++) find[k][i1] /= L; } target = 0; for (i1 = 1; i1 < *n; i1++) { for (i2 = i1 + 1; i2 <= *n; i2++) { for (k = 0; k < 16; k++) Ntab[k] = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) { DO_CONTINGENCY_NUCLEOTIDES } COMPUTE_DIST_ParaLin target++; } } } void distDNA_ParaLin_pairdel(unsigned char *x, int *n, int *s, double *d, int *variance, double *var) { int i1, i2, k, s1, s2, m, target, L, Ntab[16], ndim = 4, info, ipiv[16]; double Ftab[16], U[16], *find[4]; L = 0; for (k = 0; k < 4; k++) find[k] = (double*)R_alloc(*n, sizeof(double)); for (i1 = 0; i1 < *n; i1++) for (k = 0; k < 4; k++) find[k][i1] = 0.0; for (i1 = 0; i1 < *n; i1++) { L = 0; for (s1 = i1; s1 < i1 + *n*(*s - 1) + 1; s1+= *n) { if (KnownBase(x[s1])) { L++; switch (x[s1]) { case 136 : find[0][i1]++; break; case 40 : find[1][i1]++; break; case 72 : find[2][i1]++; break; case 24 : find[3][i1]++; break; } } } for (k = 0; k < 4; k++) find[k][i1] /= L; } target = 0; for (i1 = 1; i1 < *n; i1++) { for (i2 = i1 + 1; i2 <= *n; i2++) { L = 0; for (k = 0; k < 16; k++) Ntab[k] = 0; for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) { CHECK_PAIRWISE_DELETION DO_CONTINGENCY_NUCLEOTIDES } COMPUTE_DIST_ParaLin target++; } } } /* a hash table is much faster than switch (2012-01-10) */ SEXP BaseProportion(SEXP x) { long i; unsigned char *p; double n, count[256], *BF; SEXP res; PROTECT(x = coerceVector(x, RAWSXP)); memset(count, 0, 256*sizeof(double)); n = XLENGTH(x); p = RAW(x); for (i = 0; i < n; i++) count[p[i]]++; PROTECT(res = allocVector(REALSXP, 17)); BF = REAL(res); BF[0] = count[136]; BF[1] = count[40]; BF[2] = count[72]; BF[3] = count[24]; BF[4] = count[192]; BF[5] = count[160]; BF[6] = count[144]; BF[7] = count[96]; BF[8] = count[80]; BF[9] = count[48]; BF[10] = count[224]; BF[11] = count[176]; BF[12] = count[208]; BF[13] = count[112]; BF[14] = count[240]; BF[15] = count[4]; BF[16] = count[2]; UNPROTECT(2); return res; } #define SEGCOL seg[j] = 1; done = 1; break SEXP SegSites(SEXP DNASEQ) { int n, s, j, done, *seg; long i, end; unsigned char base, *x; SEXP ans; PROTECT(DNASEQ = coerceVector(DNASEQ, RAWSXP)); x = RAW(DNASEQ); n = nrows(DNASEQ); s = ncols(DNASEQ); PROTECT(ans = allocVector(INTSXP, s)); seg = INTEGER(ans); memset(seg, 0, s*sizeof(int)); for (j = 0; j < s; j++) { i = (long) n * j; /* start */ end = (long) i + n - 1; base = x[i]; done = 0; while (!KnownBase(base)) { /* in this while-loop, we are not yet sure that 'base' is known, so we must be careful with the comparisons */ i++; if (i > end) { done = 1; break; } if (base != x[i]) { if (base != 2 && x[i] != 2) { /* both should not be "?" */ if (base > 4) { if (x[i] == 4) { /* 'base' is not a gap but x[i] is one => this is a segregating site */ SEGCOL; } else { /* both are an ambiguous base */ if (DifferentBase(x[i], base)) { SEGCOL; } } } else { /* 'base' is a gap but x[i] is different => this is a segregating site */ SEGCOL; } } base = x[i]; } } if (done) continue; i++; while (i <= end) { if (x[i] != base) { if (x[i] == 4) { SEGCOL; } else { if (DifferentBase(x[i], base)) { SEGCOL; } } } i++; } } UNPROTECT(2); return ans; } void GlobalDeletionDNA(unsigned char *x, int *n, int *s, int *keep) { int i, j; for (j = 0; j < *s; j++) { i = *n * j; while (i < *n * (j + 1)) { if (KnownBase(x[i])) i++; else { keep[j] = 0; break; } } } } void dist_dna(unsigned char *x, int *n, int *s, int *model, double *d, double *BF, int *pairdel, int *variance, double *var, int *gamma, double *alpha) { switch (*model) { case 1 : if (pairdel) distDNA_raw_pairdel(x, n, s, d, 1); else distDNA_raw(x, n, s, d, 1); break; case 2 : if (pairdel) distDNA_JC69_pairdel(x, n, s, d, variance, var, gamma, alpha); else distDNA_JC69(x, n, s, d, variance, var, gamma, alpha); break; case 3 : if (pairdel) distDNA_K80_pairdel(x, n, s, d, variance, var, gamma, alpha); else distDNA_K80(x, n, s, d, variance, var, gamma, alpha); break; case 4 : if (pairdel) distDNA_F81_pairdel(x, n, s, d, BF, variance, var, gamma, alpha); else distDNA_F81(x, n, s, d, BF, variance, var, gamma, alpha); break; case 5 : if (pairdel) distDNA_K81_pairdel(x, n, s, d, variance, var); else distDNA_K81(x, n, s, d, variance, var); break; case 6 : if (pairdel) distDNA_F84_pairdel(x, n, s, d, BF, variance, var); else distDNA_F84(x, n, s, d, BF, variance, var); break; case 7 : if (pairdel) distDNA_T92_pairdel(x, n, s, d, BF, variance, var); else distDNA_T92(x, n, s, d, BF, variance, var); break; case 8 : if (pairdel) distDNA_TN93_pairdel(x, n, s, d, BF, variance, var, gamma, alpha); else distDNA_TN93(x, n, s, d, BF, variance, var, gamma, alpha); break; case 9 : if (pairdel) distDNA_GG95_pairdel(x, n, s, d, variance, var); else distDNA_GG95(x, n, s, d, variance, var); break; case 10 : if (pairdel) distDNA_LogDet_pairdel(x, n, s, d, variance, var); else distDNA_LogDet(x, n, s, d, variance, var); break; case 11 : distDNA_BH87(x, n, s, d, variance, var); break; case 12 : if (pairdel) distDNA_ParaLin_pairdel(x, n, s, d, variance, var); else distDNA_ParaLin(x, n, s, d, variance, var); break; case 13 : if (pairdel) distDNA_raw_pairdel(x, n, s, d, 0); else distDNA_raw(x, n, s, d, 0); break; case 14 : if (pairdel) distDNA_TsTv(x, n, s, d, 1, 1); else distDNA_TsTv(x, n, s, d, 1, 0); break; case 15 : if (pairdel) distDNA_TsTv(x, n, s, d, 0, 1); else distDNA_TsTv(x, n, s, d, 0, 0); break; case 16 : distDNA_indel(x, n, s, d); break; case 17 : distDNA_indelblock(x, n, s, d); break; } } SEXP C_where(SEXP DNASEQ, SEXP PAT) { int p, j, nans; double s, *buf, *a; long i, k; unsigned char *x, *pat; SEXP ans; PROTECT(DNASEQ = coerceVector(DNASEQ, RAWSXP)); PROTECT(PAT = coerceVector(PAT, RAWSXP)); x = RAW(DNASEQ); pat = RAW(PAT); s = XLENGTH(DNASEQ); p = LENGTH(PAT); nans = 0; buf = (double *)R_alloc(s, sizeof(double)); for (i = 0; i <= s - p; i++) { k = i; j = 0; while (1) { if (x[k] != pat[j]) break; j++; k++; if (j == p) { buf[nans++] = i + 1; break; } } } PROTECT(ans = allocVector(REALSXP, nans)); if (nans) { a = REAL(ans); for (i = 0; i < nans; i++) a[i] = buf[i]; } UNPROTECT(3); return ans; } unsigned char codon2aa_Code1(unsigned char x, unsigned char y, unsigned char z) { if (KnownBase(x)) { if (IsAdenine(x)) { if (KnownBase(y)) { if (IsAdenine(y)) { if (IsPurine(z)) return 0x4b; /* codon is AAR => 'K' */ if (IsPyrimidine(z)) return 0x4e; /* codon is AAY => 'N' */ return 0x58; /* 'X' */ } if (IsCytosine(y)) { if (z > 4) return 0x54; /* codon is ACN => 'T' */ return 0x58; } if (IsGuanine(y)) { if (IsPurine(z)) return 0x52; /* codon is AGR => 'R' */ if (IsPyrimidine(z)) return 0x53; /* codon is AGY => 'S' */ return 0x58; } if (IsThymine(y)) { if (IsGuanine(z)) return 0x4d; /* codon is ATG => 'M' */ if (z & 176) return 0x49; /* codon is ATH => 'I' */ return 0x58; } } return 0x58; } if (IsCytosine(x)) { if (IsAdenine(y)) { if (IsPurine(z)) return 0x51; /* codon is CAR => 'Q'*/ if (IsPyrimidine(z)) return 0x48; /* codon is CAY => 'H' */ return 0x58; } if (IsCytosine(y)) { if (z > 4) return 0x50; /* codon is CCN => 'P'*/ return 0x58; } if (IsGuanine(y)) { if (z > 4) return 0x52; /* codon is CGN => 'R' */ return 0x58; } if (IsThymine(y)) { if (z > 4) return 0x4c; /* codon is CTN => 'L' */ return 0x58; } return 0x58; } if (IsGuanine(x)) { if (IsAdenine(y)) { if (IsPurine(z)) return 0x45; /* codon is GAR => 'E' */ if (IsPyrimidine(z)) return 0x44; /* codon is GAY => 'D' */ return 0x58; } if (IsCytosine(y)) { if (z > 4) return 0x41; /* codon is GCN => 'A' */ return 0x58; } if (IsGuanine(y)) { if (z > 4) return 0x47; /* codon is GGN => 'G' */ return 0x58; } if (IsThymine(y)) { if (z > 4) return 0x56; /* codon is GTN => 'V' */ return 0x58; } return 0x58; } if (IsThymine(x)) { if (KnownBase(y)) { if (IsAdenine(y)) { if (IsPurine(z)) return 0x2a; /* codon is TAR => '*' */ if (IsPyrimidine(z)) return 0x59; /* codon is TAY => 'Y' */ return 0x58; } if (IsCytosine(y)) { if (z > 4) return 0x53; /* codon is TCN => 'S' */ return 0x58; } if (IsGuanine(y)) { if (IsAdenine(z)) return 0x2a; /* codon is TGA => '*' */ if (IsGuanine(z)) return 0x57; /* codon is TGG => 'W' */ if (IsPyrimidine(z)) return 0x43; /* codon is TGY => 'C' */ return 0x58; } if (IsThymine(y)) { if (IsPurine(z)) return 0x4c; /* codon is TTR => 'L' */ if (IsPyrimidine(z)) return 0x46; /* codon is TTY => 'F' */ return 0x58; } } else if (IsPurine(y) & IsAdenine(z)) return 0x2a; /* codon is TRA => '*' */ return 0x58; } } else { if (x == 144 & IsThymine(y) & IsPurine(z)) return 0x52; /* codon is MGR => 'R'*/ if (x == 48 & IsThymine(y) & IsPurine(z)) return 0x4c; /* codon is YTR => 'L'*/ } return 0x58; } unsigned char codon2aa_Code2(unsigned char x, unsigned char y, unsigned char z) { if (KnownBase(x)) { if (IsAdenine(x)) { if (KnownBase(y)) { if (IsAdenine(y)) { if (IsPurine(z)) return 0x4b; /* codon is AAR => 'K' */ if (IsPyrimidine(z)) return 0x4e; /* codon is AAY => 'N' */ return 0x58; /* 'X' */ } if (IsCytosine(y)) { if (z > 4) return 0x54; /* codon is ACN => 'T' */ return 0x58; } if (IsGuanine(y)) { if (IsPurine(z)) return 0x2a; /* codon is AGR => '*' */ if (IsPyrimidine(z)) return 0x53; /* codon is AGY => 'S' */ return 0x58; } if (IsThymine(y)) { if (IsPurine(z)) return 0x4d; /* codon is ATR => 'M' */ if (IsPyrimidine(z)) return 0x49; /* codon is ATY => 'I' */ return 0x58; } } return 0x58; } if (IsCytosine(x)) { if (IsAdenine(y)) { if (IsPurine(z)) return 0x51; /* codon is CAR => 'Q'*/ if (IsPyrimidine(z)) return 0x48; /* codon is CAY => 'H' */ return 0x58; } if (IsCytosine(y)) { if (z > 4) return 0x50; /* codon is CCN => 'P'*/ return 0x58; } if (IsGuanine(y)) { if (z > 4) return 0x52; /* codon is CGN => 'R' */ return 0x58; } if (IsThymine(y)) { if (z > 4) return 0x4c; /* codon is CTN => 'L' */ return 0x58; } return 0x58; } if (IsGuanine(x)) { if (IsAdenine(y)) { if (IsPurine(z)) return 0x45; /* codon is GAR => 'E' */ if (IsPyrimidine(z)) return 0x44; /* codon is GAY => 'D' */ return 0x58; } if (IsCytosine(y)) { if (z > 4) return 0x41; /* codon is GCN => 'A' */ return 0x58; } if (IsGuanine(y)) { if (z > 4) return 0x47; /* codon is GGN => 'G' */ return 0x58; } if (IsThymine(y)) { if (z > 4) return 0x56; /* codon is GTN => 'V' */ return 0x58; } return 0x58; } if (IsThymine(x)) { if (KnownBase(y)) { if (IsAdenine(y)) { if (IsPurine(z)) return 0x2a; /* codon is TAR => '*' */ if (IsPyrimidine(z)) return 0x59; /* codon is TAY => 'Y' */ return 0x58; } if (IsCytosine(y)) { if (z > 4) return 0x53; /* codon is TCN => 'S' */ return 0x58; } if (IsGuanine(y)) { if (IsPurine(z)) return 0x57; /* codon is TGR => 'W' */ if (IsPyrimidine(z)) return 0x43; /* codon is TGY => 'C' */ return 0x58; } if (IsThymine(y)) { if (IsPurine(z)) return 0x4c; /* codon is TTR => 'L' */ if (IsPyrimidine(z)) return 0x46; /* codon is TTY => 'F' */ return 0x58; } } return 0x58; } } else { if (x == 48 & IsThymine(y) & IsPurine(z)) return 0x4c; /* codon is YTR => 'L'*/ } return 0x58; } void trans_DNA2AA(unsigned char *x, int *s, unsigned char *res, int *code) { int i = 0, j = 0; unsigned char (*FUN)(unsigned char x, unsigned char y, unsigned char z); /* NOTE: using 'switch' provokes a memory leak */ if (*code == 1) { FUN = &codon2aa_Code1; } else { FUN = &codon2aa_Code2; } while (i < *s) { res[j] = FUN(x[i], x[i + 1], x[i + 2]); j++; i += 3; } } ape/src/BIONJ.c0000644000175100001440000002076713017516351012647 0ustar hornikusers/* BIONJ.c 2012-04-30 */ /* Copyright 2007-2008 Olivier Gascuel, Hoa Sien Cuong, R port by Vincent Lefort and Emmanuel Paradis */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ /* BIONJ program Olivier Gascuel GERAD - Montreal- Canada olivierg@crt.umontreal.ca LIRMM - Montpellier- France gascuel@lirmm.fr UNIX version, written in C by Hoa Sien Cuong (Univ. Montreal) */ #include "me.h" void Initialize(float **delta, double *X, int n); void C_bionj(double *X, int *N, int *edge1, int *edge2, double *el); float Distance(int i, int j, float **delta); float Variance(int i, int j, float **delta); int Emptied(int i, float **delta); float Sum_S(int i, float **delta); void Compute_sums_Sx(float **delta, int n); void Best_pair(float **delta, int r, int *a, int *b, int n); float Agglomerative_criterion(int i, int j, float **delta, int r); float Branch_length(int a, int b, float **delta, int r); float Reduction4(int a, float la, int b, float lb, int i, float lamda, float **delta); float Reduction10(int a, int b, int i, float lamda, float vab, float **delta); float Lamda(int a, int b, float vab, float **delta, int n, int r); /* INPUT, OUTPUT, INITIALIZATION The lower-half of the delta matrix is occupied by dissimilarities. The upper-half of the matrix is occupied by variances. The first column is initialized as 0; during the algorithm some indices are no more used, and the corresponding positions in the first column are set to 1. */ /* -- Initialize -- This function reads an input data and returns the delta matrix input: float **delta : delta matrix double *X : distances sent from R as a lower triangle matrix int n : number of taxa output: float **delta : delta matrix initialized */ void Initialize(float **delta, double *X, int n) { int i, j; /* matrix line and column indices */ int k = 0; /* index along X */ for (i = 1; i < n; i++) for (j = i + 1; j <= n; j++) delta[i][j] = delta[j][i] = X[k++]; for (i = 1; i <= n; i++) delta[i][i] = delta[i][0] = 0; } void C_bionj(double *X, int *N, int *edge1, int *edge2, double *el) { int *a, *b; /* pair to be agglomerated */ float **delta; /* delta matrix */ float la; /* first taxon branch-length */ float lb; /* second taxon branch-length */ float vab; /* variance of Dab */ float lamda = 0.5; int r; /* number of subtrees */ int n; /* number of taxa */ int i, x, y, curnod, k; int *ilab; /* indices of the tips (used as "labels") */ a = (int*)R_alloc(1, sizeof(int)); b = (int*)R_alloc(1, sizeof(int)); n = *N; /* Create the delta matrix */ delta = (float **)R_alloc(n + 1, sizeof(float*)); for (i = 1; i <= n; i++) delta[i] = (float *)R_alloc(n + 1, sizeof(float)); /* initialise */ r = n; *a = *b = 0; Initialize(delta, X, n); ilab = (int *)R_alloc(n + 1, sizeof(int)); for (i = 1; i <= n; i++) ilab[i] = i; curnod = 2 * n - 2; k = 0; while (r > 3) { Compute_sums_Sx(delta, n); /* compute the sum Sx */ Best_pair(delta, r, a, b, n); /* find the best pair by */ vab = Variance(*a, *b, delta); /* minimizing (1) */ la = Branch_length(*a, *b, delta, r); /* compute branch-lengths */ lb = Branch_length(*b, *a, delta, r); /* using formula (2) */ lamda = Lamda(*a, *b, vab, delta, n, r); /* compute lambda* using (9)*/ edge1[k] = edge1[k + 1] = curnod; edge2[k] = ilab[*a]; edge2[k + 1] = ilab[*b]; el[k] = la; el[k + 1] = lb; k = k + 2; for (i = 1; i <= n; i++) { if (Emptied(i,delta) || (i == *a) || (i == *b)) continue; if(*a > i) { x = *a; y = i; } else { x = i; y = *a; } /* apply reduction formulae 4 and 10 to delta */ delta[x][y] = Reduction4(*a, la, *b, lb, i, lamda, delta); delta[y][x] = Reduction10(*a, *b, i, lamda, vab, delta); } delta[*b][0] = 1.0; /* make the b line empty */ ilab[*a] = curnod; curnod--; r = r - 1; } /* finalise the three basal edges */ int last[3]; i = 1; k = 0; while (k < 3) { if (!Emptied(i, delta)) last[k++] = i; i++; } for (i = 0, k = 2 * n - 4; i < 3; i++, k--) { edge1[k] = curnod; /* <- the root at this stage */ edge2[k] = ilab[last[i]]; } double D[3]; D[0] = Distance(last[0], last[1], delta); D[1] = Distance(last[0], last[2], delta); D[2] = Distance(last[1], last[2], delta); el[2 * n - 4] = (D[0] + D[1] - D[2])/2; el[2 * n - 5] = (D[0] + D[2] - D[1])/2; el[2 * n - 6] = (D[2] + D[1] - D[0])/2; } /* -- Distance -- This function retrieves and returns the distance between taxa i and j from the delta matrix. input: int i : taxon i int j : taxon j float **delta : the delta matrix output: float distance : dissimilarity between the two taxa */ float Distance(int i, int j, float **delta) { if (i > j) return(delta[i][j]); else return(delta[j][i]); } /* -- Variance -- This function retrieves and returns the variance of the distance between i and j, from the delta matrix. input: int i : taxon i int j : taxon j float **delta : the delta matrix output: float distance : the variance of Dij */ float Variance(int i, int j, float **delta) { if (i > j) return(delta[j][i]); else return(delta[i][j]); } /* -- Emptied -- This function tests if a line is emptied or not. input: int i : subtree (or line) i float **delta : the delta matrix output: 0 : if not emptied 1 : if emptied */ int Emptied(int i, float **delta) { return((int)delta[i][0]); } /* -- Sum_S -- This function retrieves the sum Sx from the diagonal of the delta matrix input: int i : subtree i float **delta : the delta matrix output: float delta[i][i] : sum Si */ float Sum_S(int i, float **delta) { return(delta[i][i]); } /* -- Compute_sums_Sx -- This function computes the sums Sx and stores them in the diagonal the delta matrix. input: float **delta : the delta matrix int n : the number of taxa */ void Compute_sums_Sx(float **delta, int n) { float sum; int i, j; for (i = 1; i <= n ; i++) { if (Emptied(i, delta)) continue; sum = 0; for (j = 1; j <= n; j++) { if (i == j || Emptied(j, delta)) continue; sum += Distance(i, j, delta); /* compute the sum Si */ } delta[i][i] = sum; } } /* -- Best_pair -- This function finds the best pair to be agglomerated by minimizing the agglomerative criterion (1). input: float **delta : the delta matrix int r : number of subtrees int *a : contain the first taxon of the pair int *b : contain the second taxon of the pair int n : number of taxa output: int *a : the first taxon of the pair int *b : the second taxon of the pair */ void Best_pair(float **delta, int r, int *a, int *b, int n) { float Qxy; /* value of the criterion calculated */ int x, y; /* the pair which is tested */ float Qmin; /* current minimun of the criterion */ Qmin = 1.0e30; for (x = 1; x <= n; x++) { if (Emptied(x, delta)) continue; for (y = 1; y < x; y++) { if (Emptied(y, delta)) continue; Qxy = Agglomerative_criterion(x, y, delta, r); if (Qxy < Qmin - 0.000001) { Qmin = Qxy; *a = x; *b = y; } } } } /* Formulae */ /* Formula (1) */ float Agglomerative_criterion(int i, int j, float **delta, int r) { return((r - 2) * Distance(i, j, delta) - Sum_S(i, delta) - Sum_S(j, delta)); } /* Formula (2) */ float Branch_length(int a, int b, float **delta, int r) { return(0.5 * (Distance(a, b, delta) + (Sum_S(a, delta) - Sum_S(b, delta))/(r - 2))); } /* Formula (4) */ float Reduction4(int a, float la, int b, float lb, int i, float lamda, float **delta) { return(lamda * (Distance(a, i, delta) - la) + (1 - lamda) * (Distance(b, i, delta) - lb)); } /* Formula (10) */ float Reduction10(int a, int b, int i, float lamda, float vab, float **delta) { return(lamda * Variance(a, i, delta) + (1 - lamda) * Variance(b, i, delta) - lamda * (1 - lamda) * vab); } float Lamda(int a, int b, float vab, float **delta, int n, int r) { float lamda = 0.0; int i; if (vab == 0.0) lamda = 0.5; else { for (i = 1; i <= n ; i++) { if (a == i || b == i || Emptied(i, delta)) continue; lamda += (Variance(b, i, delta) - Variance(a, i, delta)); } lamda = 0.5 + lamda/(2 * (r - 2) * vab); /* Formula (9) */ } if (lamda > 1.0) lamda = 1.0; /* force 0 < lamda < 1 */ if (lamda < 0.0) lamda = 0.0; return(lamda); } ape/src/triangMtds.c0000644000175100001440000001355613017516351014120 0ustar hornikusers/* triangMtds.c 2012-04-02 */ /* Copyright 2011-2012 Andrei-Alin Popescu */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include "ape.h" void C_triangMtds(double* d, int* np, int* ed1,int* ed2, double* edLen) { int n=*np; int k=0; int i=0; int j=0; int ij=-1; int m[n+1]; int c[n+1]; int s[n+1]; int o[n+1]; for(i=1;i<=n;i++) {m[i]=0; c[i]=i; s[i]=0; for(j=1;j<=n;j++) { if(i==j){m[i]++;continue;} if(d[give_index(i,j,n)]==-1)continue; m[i]++; } } for(i=1;ik) { ed1[i]+=(n-k); } if(ed2[i]>k) { ed2[i]+=(n-k); } } for(i=0;i<2*k-3;i++) { if(ed2[i]<=k) { ed2[i]=o[ed2[i]]; } } for(i=1;i<=n;i++) { if(s[i]==0)continue;//take only leaves not in Y m[i]=0; for(j=1;j<=n;j++) { if(s[j]==1)continue;//take only leaves already in Y if(d[give_index(i,j,n)]==-1)continue;//igonore if distance unknown m[i]++; } } int numEdges=2*k-4;//0-based, so subtract 1 //Rprintf("numEdge=%i",numEdges); int nv=(k-2)+n; while(k i not added to tree int max=-1; int maxPos=-1; for(i=1;i<=n;i++) { if(s[i]==0)continue; if(m[i]>max) { max=m[i]; maxPos=i; } } s[maxPos]=0;//mark maxPos as added //calculate new m values for leaves not added, i.e we just increment any //already present value by 1 if we know the distance between i and maxPos for(i=1;i<=n;i++) { if(s[i]==0)continue; if(d[give_index(i,maxPos,n)]==-1)continue; m[i]++; } //find path to attach maxPos to, grow tree double minDist=1e50; int z=maxPos; int x=-1,y=-1; for(i=1;i %i ",p,ord[p]); p=ord[p]; prevSum=sum; for(i=0;i<=numEdges;i++) { if((ed1[i]==aux && ed2[i]==p)||(ed2[i]==aux && ed1[i]==p)) { if(ed1[i]==aux && ed2[i]==p){sw=1;} subdiv=i; sum+=edLen[i]; } } //if(cc>1000)error("failed to follow path between x=%i y=%i\n",x,y); } nv++; //subdivide subdiv with a node labelled nv //length calculation int edd=ed2[subdiv]; ed2[subdiv]=nv; edLen[subdiv]= (sw==1)?(lx-prevSum):(sum-lx);//check which 'half' of the //path the leaf belongs to //and updates accordingly //error("sum=%f, prevsum=%f\n",sum,prevSum); //error("lx-prevSum=%f, sum-lx=%f, minDist=%f",lx-prevSum,sum-lx,minDist); //Rprintf("adding %i on path %i %i, at distance %f from %i, and %f from tree\n",z,x,y,lx,x,minDist); // Rprintf("subdividing edge %i\n",subdiv); numEdges++; ed1[numEdges]=nv; ed2[numEdges]=edd; edLen[numEdges]= (sw==1)?(sum-lx):(lx-prevSum); numEdges++; edLen[numEdges]=minDist; ed1[numEdges]=nv; ed2[numEdges]=z; k++; } } ape/src/triangMtd.c0000644000175100001440000002402313017516351013724 0ustar hornikusers/* triangMtd.c 2012-04-02 */ /* Copyright 2011-2012 Andrei-Alin Popescu */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ /* * leafs labelled 1 to n. root labelled n+1. other nodes labelled n+1 to m */ #include int give_indexx(int i, int j, int n) { if (i == j) return 0; if (i > j) return(n*(j - 1) - j*(j - 1)/2 + i - j - 1); else return(n*(i - 1) - i*(i - 1)/2 + j - i - 1); } int pred(int k, int* ed1, int* ed2, int numEdges) /* find the predecesor of vertex k */ { int i = 0; for (i = 0; i <= numEdges; i++) if (ed2[i] == k) return ed1[i]; return -1; } int* getPathBetween(int x, int y, int n, int* ed1, int* ed2, int numEdges) //get the path between vertices x and y in an array ord. //ord[i]=j means that we go between i and j on the path between x and y { int i=0; int k=x; int ch[2*n-1];//ch[i]==1 implies {k,pred(k)} on path between x and y for(i=1;i<=2*n-2;i++) {ch[i]=0; } while(k!=n+1) { ch[k]=1; k=pred(k,ed1,ed2,numEdges); } k=y; while(k!=n+1) { ch[k]++; k=pred(k,ed1,ed2,numEdges); } int *ord=(int*)malloc(sizeof(int)*(2*n-1)); //starting from x, fill ord int p=x; while(ch[p]==1) { int aux=p; p=pred(p,ed1,ed2,numEdges); ord[aux]=p; } p=y; while(ch[p]==1) { int aux=p; p=pred(p,ed1,ed2,numEdges); ord[p]=aux;//other way } return ord; } int getLength(int x, int y, int* ed1, int* ed2, int numEdges, int* edLen) /* get length of edge {x,y}, -1 if edge does not exist */ { int i = 0; for (i = 0; i <= numEdges; i++) if ((ed1[i] == x && ed2[i] == y) || (ed1[i] == y && ed2[i] == x)) return edLen[i]; return -1; } void C_triangMtd(double* d, int* np, int* ed1,int* ed2, double* edLen) { int n=*np; int i=0; int j=0; int ij=-1; for(i=0;i%i of length:%f \n",ed1[i],ed2[i],edLen[i]); } Rprintf("end new tree\n");*/ //calculate distance of leaves not yet added to the star tree int s; for(s=1;s<=n;s++) {if(w[s])continue; for(i=1;i<=n;i++) { if(i==x3)continue; if(!w[i])continue; double newL=0.5*(d[give_indexx(i,s,n)]+d[give_indexx(s,x3,n)]-d[give_indexx(i,x3,n)]); if(newL %i ",p,ord[p]); p=ord[p]; prevSum=sum; for(i=0;i<=numEdges;i++) { if((ed1[i]==aux && ed2[i]==p)||(ed2[i]==aux && ed1[i]==p)) { if(ed1[i]==aux && ed2[i]==p){sw=1;} subdiv=i; sum+=edLen[i]; } } } nv++; //subdivide subdiv with a node labelled nv //length calculation //multifurcating vertices int edd=ed2[subdiv]; ed2[subdiv]=nv; edLen[subdiv]= (sw==1)?(lx-prevSum):(sum-lx);//check which 'half' of the //path the leaf belongs to //and updates accordingly //error("sum=%f, prevsum=%f\n",sum,prevSum); //error("lx-prevSum=%f, sum-lx=%f, minDist=%f",lx-prevSum,sum-lx,minDist); numEdges++; ed1[numEdges]=nv; ed2[numEdges]=edd; edLen[numEdges]= (sw==1)?(sum-lx):(lx-prevSum); numEdges++; edLen[numEdges]=minDist; ed1[numEdges]=nv; ed2[numEdges]=z; wSize++; w[z]=1; /*update distance matrix, only needed for incomplete distances int ii; for(ii=0;ii%i of length:%f \n",ed1[i],ed2[i],edLen[i]); } Rprintf("end new tree\n");*/ } //for(i=0;i<=numEdges;i++){ed1[i]++;ed2[i]++;} } ape/src/ape.h0000644000175100001440000000155613017516351012553 0ustar hornikusers/* ape.h 2014-01-02 */ /* Copyright 2011-2014 Emmanuel Paradis */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include #include #define DINDEX(i, j) n*(i - 1) - i*(i - 1)/2 + j - i - 1 /* in ape.c */ int give_index(int i, int j, int n); SEXP getListElement(SEXP list, char *str); /* in njs.c */ void choosePair(double* D, int n, double* R, int* s, int* sw, int* x, int* y, int fS); double cnxy(int x, int y, int n, double* D); int mxy(int x,int y, int n, double* D); double nxy(int x, int y, int n, double* D); int cxy(int x, int y, int n, double* D); /* in triangMtd.c */ void C_triangMtd(double* d, int* np, int* ed1, int* ed2, double* edLen); int * getPathBetween(int x, int y, int n, int* ed1, int* ed2, int numEdges); int give_indexx(int i, int j, int n); /* a variant of the above */ ape/src/ultrametric.c0000644000175100001440000000245413017516351014332 0ustar hornikusers/* ultrametric.c 2011-10-11 */ /* Copyright 2011 Andrei-Alin Popescu */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include "ape.h" void C_ultrametric(double *dd, int* np, int* mp, double *ret)//d received as dist object, -1 for missing entries { int n=*np; int m=*mp; int i=0,j=0; double max=dd[0]; double d[n][n]; for(i=1;imax) { max=dd[give_index(i,j,n)]; } } } d[n-1][n-1]=0; int entrCh=0; do{ entrCh=0; for(i=0;i d[j][k] ? d[i][k] : d[j][k]; if(mxfirstNode = NULL; species->secondNode = NULL; D = loadMatrix(X, labels, n, species); A = initDoubleMatrix(2*n - 2); for(slooper = species; NULL != slooper; slooper = slooper->secondNode) { addNode = copyNode(slooper->firstNode); T = BMEaddSpecies(T, addNode, D, A); } // Compute bNNI if (*nni) bNNI(T, A, &nniCount, D, n); assignBMEWeights(T,A); if (*spr) SPR(T, D, A, &nniCount); if (*tbr) TBR(T, D, A); tree2phylo(T, edge1, edge2, el, labels, n); freeMatrix(D,n); freeMatrix(A,2*n - 2); freeSet(species); freeTree(T); T = NULL; } void me_o(double *X, int *N, int *labels, int *nni, int *edge1, int *edge2, double *el) { double **D, **A; set *species, *slooper; node *addNode; tree *T; int n, nniCount; n = *N; T = NULL; nniCount = 0; species = (set *) malloc(sizeof(set)); species->firstNode = NULL; species->secondNode = NULL; D = loadMatrix (X, labels, n, species); A = initDoubleMatrix(2 * n - 2); for(slooper = species; NULL != slooper; slooper = slooper->secondNode) { addNode = copyNode(slooper->firstNode); T = GMEaddSpecies(T,addNode,D,A); } makeOLSAveragesTable(T,D,A); // Compute NNI if (*nni) NNI(T,A,&nniCount,D,n); assignOLSWeights(T,A); tree2phylo(T, edge1, edge2, el, labels, n); freeMatrix(D,n); freeMatrix(A,2*n - 2); freeSet(species); freeTree(T); T = NULL; } /* -- MATRIX FUNCTIONS -- */ double **initDoubleMatrix(int d) { int i,j; double **A; A = (double **) malloc(d*sizeof(double *)); for(i=0;iindex2 = i; S = addToSet(v,S); for (j=i; jfirstNode = v; X->secondNode = NULL; } else if (NULL == X->firstNode) X->firstNode = v; else X->secondNode = addToSet(v,X->secondNode); return(X); } //node *makeNewNode(char *label, int i) node *makeNewNode(int label, int i) { return(makeNode(label,NULL,i)); } //node *makeNode(char *label, edge *parentEdge, int index) node *makeNode(int label, edge *parentEdge, int index) { node *newNode; /*points to new node added to the graph*/ newNode = (node *) malloc(sizeof(node)); // strncpy(newNode->label,label,NODE_LABEL_LENGTH); newNode->label = label; newNode->index = index; newNode->index2 = -1; newNode->parentEdge = parentEdge; newNode->leftEdge = NULL; newNode->middleEdge = NULL; newNode->rightEdge = NULL; /*all fields have been initialized*/ return(newNode); } /*copyNode returns a copy of v which has all of the fields identical to those of v, except the node pointer fields*/ node *copyNode(node *v) { node *w; w = makeNode(v->label,NULL,v->index); w->index2 = v->index2; return(w); } edge *siblingEdge(edge *e) { if(e == e->tail->leftEdge) return(e->tail->rightEdge); else return(e->tail->leftEdge); } edge *makeEdge(char *label, node *tail, node *head, double weight) { edge *newEdge; newEdge = (edge *) malloc(sizeof(edge)); strncpy(newEdge->label,label,EDGE_LABEL_LENGTH); newEdge->tail = tail; newEdge->head = head; newEdge->distance = weight; newEdge->totalweight = 0.0; return(newEdge); } tree *newTree() { tree *T; T = (tree *) malloc(sizeof(tree)); T->root = NULL; T->size = 0; T->weight = -1; return(T); } void updateSizes(edge *e, int direction) { edge *f; switch(direction) { case UP: f = e->head->leftEdge; if (NULL != f) updateSizes(f,UP); f = e->head->rightEdge; if (NULL != f) updateSizes(f,UP); e->topsize++; break; case DOWN: f = siblingEdge(e); if (NULL != f) updateSizes(f,UP); f = e->tail->parentEdge; if (NULL != f) updateSizes(f,DOWN); e->bottomsize++; break; } } /*detrifurcate takes the (possibly trifurcated) input tree and reroots the tree to a leaf*/ /*assumes tree is only trifurcated at root*/ tree *detrifurcate(tree *T) { node *v, *w; edge *e, *f; v = T->root; if(leaf(v)) return(T); if (NULL != v->parentEdge) { error("root %d is poorly rooted.", v->label); } for(e = v->middleEdge, v->middleEdge = NULL; NULL != e; e = f ) { w = e->head; v = e->tail; e->tail = w; e->head = v; f = w->leftEdge; v->parentEdge = e; w->leftEdge = e; w->parentEdge = NULL; } T->root = w; return(T); } void compareSets(tree *T, set *S) { edge *e; node *v,*w; set *X; e = depthFirstTraverse(T,NULL); while (NULL != e) { v = e->head; for(X = S; NULL != X; X = X->secondNode) { w = X->firstNode; // if (0 == strcmp(v->label,w->label)) if (v->label == w->label) { v->index2 = w->index2; w->index2 = -1; break; } } e = depthFirstTraverse(T,e); } v = T->root; for(X = S; NULL != X; X = X->secondNode) { w = X->firstNode; // if (0 == strcmp(v->label,w->label)) if (v->label == w->label) { v->index2 = w->index2; w->index2 = -1; break; } } if (-1 == v->index2) { error("leaf %d in tree not in distance matrix.", v->label); } e = depthFirstTraverse(T,NULL); while (NULL != e) { v = e->head; if ((leaf(v)) && (-1 == v->index2)) { error("leaf %d in tree not in distance matrix.", v->label); } e = depthFirstTraverse(T,e); } for(X = S; NULL != X; X = X->secondNode) if (X->firstNode->index2 > -1) { error("node %d in matrix but not a leaf in tree.", X->firstNode->label); } return; } void partitionSizes(tree *T) { edge *e; e = depthFirstTraverse(T,NULL); while (NULL != e) { if (leaf(e->head)) e->bottomsize = 1; else e->bottomsize = e->head->leftEdge->bottomsize + e->head->rightEdge->bottomsize; e->topsize = (T->size + 2)/2 - e->bottomsize; e = depthFirstTraverse(T,e); } } /************************************************************************* TRAVERSE FUNCTIONS *************************************************************************/ edge *depthFirstTraverse(tree *T, edge *e) /*depthFirstTraverse returns the edge f which is least in T according to the depth-first order, but which is later than e in the search pattern. If e is null, f is the least edge of T*/ { edge *f; if (NULL == e) { f = T->root->leftEdge; if (NULL != f) f = findBottomLeft(f); return(f); /*this is the first edge of this search pattern*/ } else /*e is non-null*/ { if (e->tail->leftEdge == e) /*if e is a left-oriented edge, we skip the entire tree cut below e, and find least edge*/ f = moveRight(e); else /*if e is a right-oriented edge, we have already looked at its sibling and everything below e, so we move up*/ f = e->tail->parentEdge; } return(f); } edge *findBottomLeft(edge *e) /*findBottomLeft searches by gottom down in the tree and to the left.*/ { edge *f; f = e; while (NULL != f->head->leftEdge) f = f->head->leftEdge; return(f); } edge *moveRight(edge *e) { edge *f; f = e->tail->rightEdge; /*this step moves from a left-oriented edge to a right-oriented edge*/ if (NULL != f) f = findBottomLeft(f); return(f); } edge *topFirstTraverse(tree *T, edge *e) /*topFirstTraverse starts from the top of T, and from there moves stepwise down, left before right*/ /*assumes tree has been detrifurcated*/ { edge *f; if (NULL == e) return(T->root->leftEdge); /*first Edge searched*/ else if (!(leaf(e->head))) return(e->head->leftEdge); /*down and to the left is preferred*/ else /*e->head is a leaf*/ { f = moveUpRight(e); return(f); } } edge *moveUpRight(edge *e) { edge *f; f = e; while ((NULL != f) && ( f->tail->leftEdge != f)) f = f->tail->parentEdge; /*go up the tree until f is a leftEdge*/ if (NULL == f) return(f); /*triggered at end of search*/ else return(f->tail->rightEdge); /*and then go right*/ } /************************************************************************* FREE FUNCTIONS *************************************************************************/ void freeMatrix(double **D, int size) { int i; for(i=0;ifirstNode); /* added by EP 2014-03-04 */ freeSet(S->secondNode); } free(S); } void freeTree(tree *T) { node *v; v = T->root; if (NULL != v->leftEdge) freeSubTree(v->leftEdge); free(T->root); free(T); } void freeSubTree(edge *e) { node *v; edge *e1, *e2; v = e->head; e1 = v->leftEdge; if (NULL != e1) freeSubTree(e1); e2 = v->rightEdge; if (NULL != e2) freeSubTree(e2); free(v); e->tail = NULL; e->head = NULL; free(e); } ape/src/ape.c0000644000175100001440000001425213017516351012543 0ustar hornikusers/* ape.c 2016-06-21 */ /* Copyright 2011-2016 Emmanuel Paradis, and 2007 R Development Core Team */ /* This file is part of the R-package `ape'. */ /* See the file ../COPYING for licensing issues. */ #include #include "ape.h" int give_index(int i, int j, int n) { if (i > j) return(DINDEX(j, i)); else return(DINDEX(i, j)); } /* From R-ext manual (not the same than in library/stats/src/nls.c) */ SEXP getListElement(SEXP list, char *str) { SEXP elmt = R_NilValue, names = getAttrib(list, R_NamesSymbol); int i; for (i = 0; i < length(list); i++) if(strcmp(CHAR(STRING_ELT(names, i)), str) == 0) { elmt = VECTOR_ELT(list, i); break; } return elmt; } /* declare functions here to register them below */ void C_additive(double *dd, int* np, int* mp, double *ret); void BaseProportion(unsigned char *x, int *n, double *BF); void C_bionj(double *X, int *N, int *edge1, int *edge2, double *el); void C_bionjs(double *D, int *N, int *edge1, int *edge2, double *edge_length, int* fsS); void delta_plot(double *D, int *size, int *nbins, int *counts, double *deltabar); void dist_dna(unsigned char *x, int *n, int *s, int *model, double *d, double *BF, int *pairdel, int *variance, double *var, int *gamma, double *alpha); void dist_nodes(int *n, int *m, int *e1, int *e2, double *el, int *N, double *D); void C_ewLasso(double *D, int *N, int *e1, int *e2); void GlobalDeletionDNA(unsigned char *x, int *n, int *s, int *keep); void mat_expo(double *P, int *nr); void me_b(double *X, int *N, int *labels, int *nni, int *spr, int *tbr, int *edge1, int *edge2, double *el); void me_o(double *X, int *N, int *labels, int *nni, int *edge1, int *edge2, double *el); void C_mvr(double *D, double* v,int *N, int *edge1, int *edge2, double *edge_length); void C_mvrs(double *D, double* v, int *N, int *edge1, int *edge2, double *edge_length, int* fsS); void neworder_phylo(int *n, int *e1, int *e2, int *N, int *neworder, int *order); void neworder_pruningwise(int *ntip, int *nnode, int *edge1, int *edge2, int *nedge, int *neworder); void C_nj(double *D, int *N, int *edge1, int *edge2, double *edge_length); void C_njs(double *D, int *N, int *edge1, int *edge2, double *edge_length, int *fsS); void node_depth(int *ntip, int *nnode, int *e1, int *e2, int *nedge, double *xx, int *method); void node_depth_edgelength(int *ntip, int *nnode, int *edge1, int *edge2, int *nedge, double *edge_length, double *xx); void node_height(int *ntip, int *nnode, int *edge1, int *edge2, int *nedge, double *yy); void node_height_clado(int *ntip, int *nnode, int *edge1, int *edge2, int *nedge, double *xx, double *yy); void C_pic(int *ntip, int *nnode, int *edge1, int *edge2, double *edge_len, double *phe, double *contr, double *var_contr, int *var, int *scaled); void C_rTraitCont(int *model, int *Nedge, int *edge1, int *edge2, double *el, double *sigma, double *alpha, double *theta, double *x); void SegSites(unsigned char *x, int *n, int *s, int *seg); void C_treePop(int* splits, double* w,int* ncolp,int* np, int* ed1, int* ed2, double* edLen); void C_triangMtd(double* d, int* np, int* ed1,int* ed2, double* edLen); void C_triangMtds(double* d, int* np, int* ed1,int* ed2, double* edLen); void C_ultrametric(double *dd, int* np, int* mp, double *ret); void C_where(unsigned char *x, unsigned char *pat, int *s, int *p, int *ans, int *n); void bitsplits_phylo(int *n, int *m, int *e, int *N, int *nr, unsigned char *mat); void CountBipartitionsFromTrees(int *n, int *m, int *e, int *N, int *nr, int *nc, unsigned char *mat, double *freq); void DNAbin2indelblock(unsigned char *x, int *n, int *s, int *y); void trans_DNA2AA(unsigned char *x, int *s, unsigned char *res, int *code); SEXP bipartition(SEXP edge, SEXP nbtip, SEXP nbnode); SEXP prop_part(SEXP TREES, SEXP nbtree, SEXP keep_partitions); SEXP rawStreamToDNAbin(SEXP x); SEXP seq_root2tip(SEXP edge, SEXP nbtip, SEXP nbnode); SEXP treeBuildWithTokens(SEXP nwk); SEXP bitsplits_multiPhylo(SEXP x, SEXP n, SEXP nr); static R_CMethodDef C_entries[] = { {"C_additive", (DL_FUNC) &C_additive, 4}, {"C_bionj", (DL_FUNC) &C_bionj, 5}, {"C_bionjs", (DL_FUNC) &C_bionjs, 6}, {"delta_plot", (DL_FUNC) &delta_plot, 5}, {"dist_dna", (DL_FUNC) &dist_dna, 11}, {"dist_nodes", (DL_FUNC) &dist_nodes, 7}, {"C_ewLasso", (DL_FUNC) &C_ewLasso, 4}, {"GlobalDeletionDNA", (DL_FUNC) &GlobalDeletionDNA, 4}, {"mat_expo", (DL_FUNC) &mat_expo, 2}, {"me_b", (DL_FUNC) &me_b, 9}, {"me_o", (DL_FUNC) &me_o, 7}, {"C_mvr", (DL_FUNC) &C_mvr, 6}, {"C_mvrs", (DL_FUNC) &C_mvrs, 7}, {"neworder_phylo", (DL_FUNC) &neworder_phylo, 6}, {"neworder_pruningwise", (DL_FUNC) &neworder_pruningwise, 6}, {"C_nj", (DL_FUNC) &C_nj, 5}, {"C_njs", (DL_FUNC) &C_njs, 6}, {"node_depth", (DL_FUNC) &node_depth, 7}, {"node_depth_edgelength", (DL_FUNC) &node_depth_edgelength, 7}, {"node_height", (DL_FUNC) &node_height, 6}, {"node_height_clado", (DL_FUNC) &node_height_clado, 7}, {"C_pic", (DL_FUNC) &C_pic, 10}, {"C_rTraitCont", (DL_FUNC) &C_rTraitCont, 9}, {"C_treePop", (DL_FUNC) &C_treePop, 7}, {"C_triangMtd", (DL_FUNC) &C_triangMtd, 5}, {"C_triangMtds", (DL_FUNC) &C_triangMtds, 5}, {"C_ultrametric", (DL_FUNC) &C_ultrametric, 4}, {"bitsplits_phylo", (DL_FUNC) &bitsplits_phylo, 6}, {"CountBipartitionsFromTrees", (DL_FUNC) &CountBipartitionsFromTrees, 8}, {"DNAbin2indelblock", (DL_FUNC) &DNAbin2indelblock, 4}, {"trans_DNA2AA", (DL_FUNC) &trans_DNA2AA, 4}, {NULL, NULL, 0} }; static R_CallMethodDef Call_entries[] = { {"bipartition", (DL_FUNC) &bipartition, 3}, {"prop_part", (DL_FUNC) &prop_part, 3}, {"rawStreamToDNAbin", (DL_FUNC) &rawStreamToDNAbin, 1}, {"seq_root2tip", (DL_FUNC) &seq_root2tip, 3}, {"treeBuildWithTokens", (DL_FUNC) &treeBuildWithTokens, 1}, {"bitsplits_multiPhylo", (DL_FUNC) &bitsplits_multiPhylo, 3}, {"BaseProportion", (DL_FUNC) &BaseProportion, 1}, {"SegSites", (DL_FUNC) &SegSites, 1}, {"C_where", (DL_FUNC) &C_where, 2}, {NULL, NULL, 0} }; void R_init_ape(DllInfo *info) { R_registerRoutines(info, C_entries, Call_entries, NULL, NULL); R_useDynamicSymbols(info, FALSE); } ape/NAMESPACE0000644000175100001440000001255513010621254012256 0ustar hornikusersuseDynLib(ape, .registration = TRUE) exportPattern("^[^\\.]") export(.compressTipLabel, .uncompressTipLabel, .PlotPhyloEnv) importFrom(graphics, abline, arrows, axTicks, axis, barplot, boxplot, bxp, close.screen, identify, image, image.default, layout, lines, locator, mtext, par, plot, plot.default, points, polygon, rect, screen, segments, split.screen, strheight, strwidth, symbols, text, title, xinch, yinch) importFrom(grDevices, col2rgb, dev.cur, dev.new, dev.off, dev.set, devAskNewPage, grey, rainbow, rgb, topo.colors) importFrom(lattice, xyplot, panel.lines, panel.points) importFrom(methods, as, show) importFrom(nlme, corMatrix, Dim, getCovariate, getGroups, getGroupsFormula, gls, Initialize) importFrom(stats, AIC, as.dist, as.hclust, biplot, coef, complete.cases, cophenetic, cor, cor.test, cov, cov2cor, density, dgamma, dpois, drop1, formula, gaussian, glm, hclust, integrate, lm, mahalanobis, median, model.frame, model.matrix, model.response, na.fail, na.omit, nlm, nlminb, optim, optimize, p.adjust, pchisq, pf, pgamma, pnorm, ppois, printCoefmat, pt, qbinom, qnorm, qt, quantile, quasibinomial, rbinom, reorder, resid, rexp, rgamma, rnorm, runif, sd, setNames, terms, uniroot, var, wilcox.test) importFrom(utils, download.file, read.table, str) importFrom(parallel, mclapply) ## Methods for the classes defined in ape, including for the generics ## defined in ape (see also below). Some methods are exported above. S3method(is.binary, tree) # to delete when removing the function S3method("[", AAbin) S3method(as.character, AAbin) S3method(image, AAbin) S3method(labels, AAbin) S3method(print, AAbin) S3method(AIC, ace) S3method(anova, ace) S3method(deviance, ace) S3method(logLik, ace) S3method(print, ace) S3method(print, binaryPGLMM) S3method(as.prop.part, bitsplits) S3method(is.compatible, bitsplits) S3method(print, bitsplits) S3method(sort, bitsplits) S3method(drop1, compar.gee) S3method(predict, compar.gee) S3method(print, compar.gee) S3method(print, corphylo) S3method("[", DNAbin) S3method(all.equal, DNAbin) S3method(as.character, DNAbin) S3method(as.list, DNAbin) S3method(as.matrix, DNAbin) S3method(c, DNAbin) S3method(cbind, DNAbin) S3method(image, DNAbin) S3method(labels, DNAbin) S3method(makeLabel, DNAbin) S3method(print, DNAbin) S3method(rbind, DNAbin) S3method(as.phylo, evonet) S3method(plot, evonet) S3method(print, evonet) S3method("[", multiPhylo) S3method("[<-", multiPhylo) S3method("[[", multiPhylo) S3method("[[<-", multiPhylo) S3method("$", multiPhylo) S3method("$<-", multiPhylo) S3method(c, multiPhylo) S3method(di2multi, multiPhylo) S3method(is.binary, multiPhylo) S3method(is.rooted, multiPhylo) S3method(is.ultrametric, multiPhylo) S3method(makeLabel, multiPhylo) S3method(multi2di, multiPhylo) S3method(Nedge, multiPhylo) S3method(Nnode, multiPhylo) S3method(Ntip, multiPhylo) S3method(plot, multiPhylo) S3method(print, multiPhylo) S3method(reorder, multiPhylo) S3method(root, multiPhylo) S3method(str, multiPhylo) S3method(unique, multiPhylo) S3method(unroot, multiPhylo) S3method("+", phylo) S3method(all.equal, phylo) S3method(as.hclust, phylo) S3method(as.matching, phylo) S3method(coalescent.intervals, phylo) S3method(c, phylo) S3method(cophenetic, phylo) S3method(di2multi, phylo) S3method(identify, phylo) S3method(is.binary, phylo) S3method(is.rooted, phylo) S3method(is.ultrametric, phylo) S3method(makeLabel, phylo) S3method(multi2di, phylo) S3method(Nedge, phylo) S3method(Nnode, phylo) S3method(Ntip, phylo) S3method(plot, phylo) S3method(print, phylo) S3method(reorder, phylo) S3method(root, phylo) S3method(skyline, phylo) S3method(summary, phylo) S3method(unroot, phylo) S3method(vcv, phylo) S3method(plot, phymltest) S3method(print, phymltest) S3method(summary, phymltest) S3method(lines, popsize) S3method(plot, popsize) S3method(as.bitsplits, prop.part) S3method(plot, prop.part) S3method(print, prop.part) S3method(summary, prop.part) S3method(lines, skyline) S3method(plot, skyline) ## Methods for PGLS: ## methods of coef() from stats: S3method(coef, corBlomberg) S3method(coef, corBrownian) S3method(coef, corGrafen) S3method(coef, corMartins) S3method(coef, corPagel) ## methods to work with nlme: S3method(corMatrix, corBlomberg) S3method(corMatrix, corBrownian) S3method(corMatrix, corGrafen) S3method(corMatrix, corMartins) S3method(corMatrix, corPagel) S3method(Initialize, corPhyl) ## Miscellaneous classes for which there is only one method: S3method(biplot, pcoa) S3method(plot, correlogram) S3method(plot, correlogramList) S3method(plot, mst) S3method(plot, varcomp) S3method(print, birthdeath) S3method(print, bitsplits) S3method(print, chronos) S3method(print, lmorigin) S3method(print, parafit) ## Other methods of the generics defined in ape: S3method(as.AAbin, character) S3method(as.DNAbin, alignment) S3method(as.DNAbin, character) S3method(as.DNAbin, DNAMultipleAlignment) S3method(as.DNAbin, DNAString) S3method(as.DNAbin, DNAStringSet) S3method(as.DNAbin, list) S3method(as.DNAbin, PairwiseAlignmentsSingleSubject) S3method(as.phylo, formula) S3method(as.phylo, hclust) S3method(as.phylo, matching) S3method(as.phylo, phylog) S3method(coalescent.intervals, default) S3method(makeLabel, character) S3method(skyline, coalescentIntervals) S3method(skyline, collapsedIntervals) S3method(vcv, corPhyl) ape/NEWS0000644000175100001440000000004512361157701011536 0ustar hornikusersSee: http://ape-package.ird.fr/NEWS ape/data/0000755000175100001440000000000013017516351011750 5ustar hornikusersape/data/cynipids.rda0000644000175100001440000000132111576267471014275 0ustar hornikusersj0l0vQ lvӻ؎+؎8ic Tׄ6$P8/j?yQJ |qG?Ue^yُWe 4A! B*:)ZI6{Ie&/i,SC)r70vH]F-T)Y"EنK/+#0C IlR$Y0KU,f$2ϫM td|x6碻!qld;sĝox?<8RcKreO3ޛ7;ޮuw\qN,`z$,/K2Сj84x8 4/+: p x xb@<\:1`a<\^^'wˤw\:ʝwt[ĸUna0?Q=j2Í[]7 N&4doMoP@zn#&mT/o?خ _z @0:IoJ:ݯieyhj/&4W!{`,^Cܟ@WO rw6{xͣ{ xGv 4=L *J%L.`< L%Ij7t8,Z f3kkk3%lFktG,f^b/z:_d: ]_s%ft["%}LmL E4d;ZjCZ,=e!b2 YJp?j"d[l [W%L.=[@F)6RDd[񨭅P,$ܖND4V(q5y&cyR8"J[(M~eRM*vg?n+`-XE&W01m>xnUJ{V%pt6X2 vd#.Ǿ:FIgPOĈav6Nvps=;Zc_$>b|zZϩK tVwYe'ndNs-%< 'ſ%{ape/data/bird.families.rda0000644000175100001440000000471511576267143015171 0ustar hornikuserse |UI[MCQئMӓCQt{bIdvggx}xZE***߾ߛd?ơxvjǁ-%" ] {OSd*^\9h5_yj_2c^FM@]([oW1W3om@yN]@]y^Ԙ2#c@$)] >ς1gcס ̗2 U|oe̷0wռ273?7@9ϙ[[-%skp~nw0(#Pys PwZ8npP}dNw/ iԹУQzY"pP%Ze3,`@?%>J3:JİB7b?R`_:BDAlh t}IkҚA$u̩$u!i5c)i89fI]x(RiHk2Қf ֌0iXIucYCZ3֒֌uzҚq6׍ flnlf֌Սm9ՍsHké ֌GԍG1fF1fN]ݨ|dv֌^Қq!Қ1#~FZ3KZ3H43\DZ3.&#Hk㩫0O O$O"OfB]x*uubfIkMZ35!Ik f<֌֌fD55#&~hF´Ѥg@3ɴne̳fгfsfsffZ3Z3 fЋnЋfK2/c^0QŴ^_05uPOk^xuAgߔdnVe^k~ }CÛu`LK: 7!vFnW?x"W0ape/data/carnivora.csv.gz0000644000175100001440000000673013017516351015076 0ustar hornikusersZr8}`T@R|rTefR>-q&Ux=rƱ)9H6%G tW*L总SN?W뺢/%>}W?uG~oJW]]{ַ]W7WiQ3 oJLCLiWLMh[[*BRK`ػ*+UJ<8JReiR{LH}B)jadVy?qx'ΠեMx#KR WSek׵G!kAk hߚ(Y m8< SLWc t65ZO+Sazf9Xypn_=LҫKM`isqbsj.^ýR'\N},mMŰTL%Iy)Mn]SfWI XEE_ܝn 53jj-ae~?222@Pa>0dIw%ݠ#EH}d d&9`%DY3#S;PvM#U ϟg(3]c&_e9.XH+͜^v\Oѿ'Nyvww o„2k VFbtH#qY?}~7o;$]52A+)8>}ɷ7X;Eu QʕbM;f9VBB1VH rOe#泤}oTRQ03 _o>SC1^f1MF\?96n G 2kXإYT֯Dvuۍ&|WU[Ip vxȮƗm߹Jۙm:rϠFwNbݦz R +) ;`] Gܩܠn;e 2.}]1As\)OI()T9J$ܳR=1RQ%th%jD\ƥ%<6E{gHyL?R3f.,C% ϰ5g~\;ޝQSodesp' ?Ű=ezr9vp+ЈeKgbl$[YJ]6([pS ?S>M@s(fOΨ+B7k :Rٺ+b4Ԫ,Xʩ%0IBMzp:A3xZC~%ul(I6~?|v.ape/data/mat5M3ID.RData0000644000175100001440000014106511131662070014152 0ustar hornikusers\}UU> -tHt# ݈ 8}ν3߱y=mX1UT $H Qrgb$b0A )_S 9JJMI qfٟ؟xqt ېnްVZ+X/;?4(!)Ϯ(W\}E} cgPQ~Kro NJ47/B}SB[zq8=+.PkWp^M|&xl_tp^杠=Rp ʝ5'̓p*fj*pӝypW>ޮ6TxNnNqδO{7f_o,x^p v6el֔{`/m-nګYpFEػ/,xѷdzcB5`mn۶:SߚH׵I>:陆Z 򻾪vEvNƥ|EUe/`w u'̖aby9=͟[Xz__pq>]LOjJߘ7I~5+k=]rվY"t3nުqXx ^tС0ωbU"3B_UQJ=njkv\}8&;7Y >coPѻůf[+Fg~VZp~;늧ό௏rѶ+j]˯a蘡WkS3Gݻۥo/@hbߊ~/kUX9))۔Eo_vN*wk'cXꞹ]ԙIF5᫸_ljo)/'F % #K#΂ѣQ.C;n+%6zb~[ջ0V+_٬ӷrQ{atX0͆ w=Lu M0/nZlNtϜ I f'#47{n3Z 5rzxqu85n٥Oоn1+8voq=;hU)oMX G$Xzލ@WvISd;;IʱX֫Ca=x.Xe;^eJ~&wlp,l։TmvJKF[k.t>W/̾˻3~t~`|2f0A= ?]`Tɒ)驄l5tchYޔ|{۹n; wwaqèzIVǚYk:Gw}ڂދ?t`摍6vrNlU C%wQZZ,} j/m+)reV߷\ cL}U8o^m @̗5B#<*/m}ATŞs=i {J8v(4nO#؛a[aIU=ǻ?/0x5x{TkVQ Vg7&洞`w@;-J^$~}IBxókH }6JvlwG̖#64rߐt~\],GKY\g ɯ暇@My~O_A/3YGVl>|f[;^AeHSSa_GIq}ٔ_o+`==XyG40[~-_J̲}5{FZ$;#so8h'rfOT0{cx2NreF VZvdM(EEΏൟ۝o}V,^.b{~n&߰G wl#cͷ'DJeK>̥Ab] OH+G080'&*MY`=ڀ^GԞLM`}j.ݖ0¾4ڀgdM`xCCdqVY}M`.k5R!m~nHY3cW>m~H8Foyg U#a+|l7xv;SQMRE]8K%J BeoXQ#R7זF :.뱯N3ics`umS!'^>Iecx91iW^J#5ɴzv >n7s uaquWbL;`VYA5b+YqV_C_^;T9nԋkbt.#y?%sE2-3u_`ΏU/y?!w6fxIlX~P}ffp gi {M\S<B\[-Ny0cEIVkq'`Sio[O2g}1w<{Hތ0\Ƕ8ܖr?q:Zy;`HT"ᲇSY*˚F4w'ŏARk0\4jPݬCVZi>ncFkhΑɟ$k'oD˸'u8:]R1\!߬`u˳W՟W|I,1\d*ܹz5 9 9!ndpDT#n~l?aj`|Trt:k=?AΆ;3i.ky4qKe~&޹B㫝_Z=t Uˣz7B؋W 5ԅ(OŢ`8]Nx}w=[50DwyS־8S:}v&VXt  ̓]/V[V\)dToα~w4KnqL>C S=G!*/Oe r}g ~'>|b7_l#al?-\7`3T6 B +i209Y~(<G`ྻQ#*ο6bU'"q;"vGXmZbh=;kVo` ۿbѰ* |*~//WK?N|p'D u<^Cδ0K|K;>&2?;AvZŻ7>z?_{W N`ن;||4]<  66;& '-ϩG8rB!YRdKwhⵚ }5K\[KϠo.S[dO 6@wa\ڶ:+{tEܯwnv9< ?فCqP^P9}2Q?NG0 7,&oI|m%hڰ{|vh׋$ k_b%~UJ W7ޢ ܘ*WnrxL\8}S=ct@0FeJoW E^0/0bK |)={.)>\{Bx=pcN;3m _+#LT_ Xk3Oyi~.!+rJ?a#SH-'p(Mh)t7Pc+X{'I۹+6<:,{^k7Z -;`i m!m%8얀3i[etaa-3p/r;s[N]mCz?ťMK\jzGH]W|T#cm^NVġߔ|=ap6 c7Yw`r >}[O۵,k; ;{r46DZ |̂vF9:ЁVɭ<=' k:N n nt۰"&֧ݿ&V2;럞bGL^voNtYZnG@k#.NGoCݕ*mIvJOʛ SosYɑK7+RbGU?/V@}#M#gSO8?w] '?A,˰^1z`r4g;Hlq>}Rg?Q`k Yu{Y9S%gKt S=BpػD̼s_`j䇿٠'v`p>r$H\9r}y`xaxq| _5Ώ*aXj?<&_N_=u>^4zr\&^mwYXb[l.E!W'[15Y0`0|2Azg6HUv>>ü>SrVaDy4*M}b޳.g YG Cn떺%lG6<;~dC veåiR[{n֎ ÀeoNڸpŸ̼ʹE}/v* `!buw ?`.pL}X?P{f oӓ2W=Y P ^㴜6/؛Ve^xŷ+|NX+~c\5\~B|Wl ਫcM731qs?~wͰΆA|Ygo+ǐؓŋ/G !k%F3#~} 5ÒXnfO7(.+_% iA@3Θm9=e }߮9+yc.ZN.̥ڙxsE tgù;x\m]cW2 ۞  ]ȉax0:_3:kɕ'HOՋbSC%ݙ€c.xͅ`v^w,!kHī<}Z0[b#̅nAYY?M:-珰r gF n%,;ht`>%||9=|:|;?tnq&^?'=e=4Ry]Vז=B˂}W T4FP}3 Lq V]~iR;{z&(/9!>^,4!ǶYYf?5z?od ^Էq|+? m`%\3BK>3f>aǙL؜Ej>NSD?+qVg׼M%(4fu"X*`RT>zYwIaf? sUoxEy4۹導r!1~\;p^d:K&f9 d?-Z '>.0ApΏ%f}fa0$I(yrw%ߍg/_Cz_O4S0tOJ/_&ѣdxGFE$h!+NqvaC'i+^s>:&qz; y*BETl1co'rgB..gw[iV֔ zJ5`ނBkj.E# 9ϺZ=<SB܎6,=9%,N&{ C-~vϩGCOO/j^I`qI>xSA]ϣÖO@=/p~^LV wA~Rxc9 xsjj'ܬòѤz]Ye+]BqJ/{AmEz.q42=O_i#یY*^0J~*zC_د6Guo8_x#A ƾڗ~/g}K+)\ S=烋|*҇tXa3|ᙯ-lduUF塓fϙQrw9,~!O4]uBB[#Zkgi":m~D57O\pgE|jsü+7۳` 3R_O-ϙ38I'6Jp,[&ވ^^CK]gfIgZHO.xK+?߮9z8[x7oɛͽ*=\U&g-&6WV0H>0Z\0X_j(,AnuvIQm0,A^ȿ7 f)y$6eZ Z9yY*HeigN4p.ûPWoK}3x_-⥬~釴*<.5<V󄣟Uau=@.4xөʧ+?߮9\![܎S!t!umS]_|`4tEX\1-]$-QyX'R#J axY;ΊfcnG%Seft-B*m$ҿ󎏿Kʖv&^^\]N{}UxM\{J=T㮏\!t8$|߮pJ?W|T#aLQGnv:Wt{Ј [URvn>;S/v@ystW@pU-t̹"{5-aet!O#俸nDž* ;w ^lauʝ&}JWMR2 9VK=L~1N.nhp42̷o\Y"vS>z Ý0|H:.TaUCX?\g]1o]F?m@ $݉s- (߃M4 [mN^=X.{ Le}j.}̄Ѧwauh^?AѴ>Z/y ;x̗{<{bќB|j^Mە.߮9R)W`p:ubDsE`Il]&+XI ߎ?9j[C <տ75]rC%IUqr~I'~O2BxZ&i͂Nn!MZM蛱' '+7SE pi(@zZD0 l>‡K?FەNoWyd=4׹O*~,b} nvހ(GhN>d!?\|~!kAޣ ;Lk YU1oZ<;>MA%ghز*w~B7.|7 Ugx[kO+ݒ+"Ӡ\G@  Z0bމ/]-äW]`ʫ!ӑy5oW~8+]s}18bүOf8乪#o`i'|p04ڏAi}Bb}C xM>ƒ:kk}-G~Ӏ}[Bj!> &zJO^G#MX_hbP3B 팕ܰ?—O4m^Vyy~hGp6 >̫))\꿣z^ޥqZ\eI)bp# v71zΌ N KqX4g9d [N g%/7!aݐ>S+ybO`1}%UF +8F:7[z^o͍0G\mfMtB'FMԼ+?߮98̉Ѭ*K}_]4Itm=rNխNoSݭ~!Os@JX?LL گmۂBHl= Mw:bZaA>U;CWisFl`$=r0O'>Ks˜=w1|ۯ9Yɛa>X?G\!uxi^MەNoWyd}L5gE:Ew|*WvHphnLZSܤW'Z !$AK?l~>k}Osojp7T00}wO~ sH ~sٻ*Y"L1&Dշ0>:,y!o+ڂWٟ=ve҄{-䜦Y4B0tWSvS>z/vdChMЁ}HYo[ѱ_()ukNGٟmͻAi#/c`VkNw4),>m|{@|nۗ@ho(vjt#joH?W|T!p׭CҧЭip~.·Mb_e(ttN[ -4іCtzQhaReY]c~+{Ճ5z° =Ni: .!@M4Nm1'sà_YυXTŻ\v2w3ɫHE[8|O[~C1P?Wj߮pJ?W|TRW2Gl_HVS2Uc߱}@>iv^0HZ6G[-dnNӚyy͐ cx_|a p"m'iji Zn̙WvU|C8sk1|VoY !ٞU0-']4МI}ui4As5sŷ+|N<^]!V?>X;,cWU_=d_7^aBtu3| HGS?s6|N Hi:/_ [B m^ k7i>H#^Фa.i=&氖S TBnLeժ"z>.+H]Wy2j\ͫ))\ S='d@7.7@& }A#.l0ϣ0ˡ\t5ɮo} Vcʛx5c`/c yas0S-x^[2sd |ۤo㗜b n{X쾖V[}qy>I~y3OJV!X>.,0Nˬp:o i.ʺ́dOLLxVcW׹OG:Is*O&2Nj߮pJ?W|{$Gz_:lAhn¾-jh=&PE> .8CzM:o;18{O-{bū6Lp/ c|3.G; ok;77Dd"Lh'U*H? |Oq0A 6Ǹ0W*,#!ZD/ *'1{gZH?Wj߮pJ?W|T#aw?Ħ#wv;j /P~{~{?m_ⰸ^ &J8&"UOKsIry=wԭ](l=PaxW0wis껛ߟr- ߩ<1ows5 yxʇSy2j\ͫES>z~s cyVIԓsT6EQ hV ~:WL^e1&à[8<Z>})žd1L!2LFy 9Ϡs-a,Bt}9N (̚_p$i>Íq)Jé<5Ք]~vտR=绢03m2_Zi: -H|i~_, Щx&_i]|;&gI1\Ϻ^vHSU5![V_1xI4Z}0||`"@}r,zx` ͛Q>\$OF͟ӼZN~8+]s|9Q?<`hS\'KFp!lT=2صlD C[`P3 \Ș/MsyVbx|0-h4h0&+L/' "nbB箕dE rPBy\x=$D@csY+-܎χ<5Ք]~vϩǯ6NWD_y>`'q:5/r,1:,2W-Lt!(+I9<t,]UF,B+U;^v6Z^ni9m>`9n8E/\9*TX#s,x1DT?Wj߮pJ?W|T#I$(b@JX&CqW#hc7ϓ5V]#_SP~zaLrPb)?yGW#-G:~h}?u[4~a8f"&Fv$ňh"͸6J6bHrF #2begu^U>ʓQy5NoWyd}B䵒yQa:5^7cJ:>7`rtrUcv_(MI}amGבKK=}T߅v};bI!~!_2*2+yNáxZNo9t3g^U>ʓQj^MەNoWyzDK^+D>|\ k(A:MO wT74g74'ko,\ d ~*OxM:XW!TaCUOVb nS9/lt֝(ԺeΤ ayd[ov< J{Up*OF͟G߮pJ?W|T׃N!Du#v'Cr; F%%1`_GbN"8 JLY۔SaWmP)X}E8`{a AG,7%l gX)6MY}?g>XsAD{#Y6DfH]W*Ué<5Ք]~vϩG'.>R>CXz:SJ~P9ք' pބ6<س {r2:D~!]⭼ur߄oq艹zw7F/c07ovRAn*1(Bnx}j|$IݕGDG\ LJj>tȺ( W$\Mnb){?y,|9xxl~6+ʹbSr N>n\hUv^v{Up*OF͟y5Q~8+]sshե`eMqp(k<7n$6tٴg6 _<.֧=O&C O鿞3¯c  zPOß^k|Us>lbg\?2oq20ݒ^U>ʓQj^M#~8߮9~kE?yC|xz"ް #η\ nc7lFyVA$ª# ǻ!M,fKj^!(Cg<1nH9!dݱJ ė-Gf6}.dgSch,ۭұsI_>߮^U>ʓQj^MەN9z|h,0~*ӫ+\!|s"߈Ż^ աOrSY6Z1 O~$Jg^Ïe6q.aY/|=O_%,'r& G^b _杇ˉ@sѽ/g +BF"ۧ\`M},*]彪|H{y5oW~8+]s$HB#'xJ/sio_8EIȜ=,kda"īGF%.JP~k>xA7`!HqZ>þ$?M9oxjvhOw:j},*]彪|8'ռGp+]sp oeo""oD/@y%~M>wp ;; O@AyмyW>pk<+櫝$G,0Ze4P.-7r17!| <:lR?>sfC3J`{Ƒ o>^YuuE巫Wɓ!ܫՔ]~vϩ12'=S)/REjV,p>s},*]彪|8'ռ+?߮9xg&sC=n,fܟqF((!4"&Ke|S`Db?I'~"A;x򵥈p%^qqS 8=ּ讈Sf~܂إF6TՌG!KVXT~{Up*OF͟y5oW~8+]sKőQ;c ̟J͒pU *ǣ F&+ qx'@Q;Y&rVc2Okѹv2'v'W饖zkA#BTR}Ou&厚ڊ0a=R~g%|_oZtW} a[m8a="Y܆FRa|KV1㋿bknpY[;SdOݯcQ*Ué<5Ք]~vϩǯ\0}Yh/ M{o9G#g-sb \91"3@+19cr6k Pr^S˟McgS#٪A]02u|Mn q! ^fG\nWv"u]ݗWSvT?Wj߮pJ?W|T#cxȄpoT:3q:2֋)Sؾ'oegݹ'rY/am%7M7';ΟCRf{pvwr˄_(ٮ.sw<9`7Z,pͳr~Ľ&`W-p C8D-'o\c L"},*]F(OF͟y5oW~8+]s0:fo<)uٹ).JIAʳ|Nݯ &$2$ߞ%>N>ɞ?I%B&kIL:΀M}k<{6ᡈV:ڿ2ۤ{4tݗ2o}u__MǢUޫʇSy2j\ͫ))\ S=7d5=W%6;ۜL|yn;τyDm:4_n2Ɋ>6ﹼO*TNěڜf]Ö4آ#T%=u췄_{;a)Un7Eޣa=r__MǢUk$dWSvS>zYEp)ǕA8(1rE,uߊgUyM9KzHb Q۲m{? *LN'Iu=k`/!ȯ/7ác6M|ɯi+Rj>߮^U>ʓQj^MەNoWyd=t޶ފ(>U0n%n=j:櫻#M3Ap)]ZqwɈ:yߒGTuJgMea{+yt% p"EsA<|}K 'o:AGt>? .;S /RPuE巫Wd"4NoWy1L1ݑ($}K'ߐ\ ^IV`]$/G/khK<cpᶔN Ky(ԯI_O_Đ~<(05iO5[Ԕ-{]0 1́=k  ub@΍딻>4_`R.NVwmg3"|'[tsNG~.S b: cINTuE巫Wd"4sŷ+|N<~ӏ́oeH| P)#q]eA.6å</Qˌ0HPGܺ%}F>ruE5HJDEG0@#0@*@KܯG9]TQj߮pJ?W|T;i,3 b< -O3J[8-I]X [:Z_ p!J4#˷Wn$s?kE>0J~ ᡓ%BvClv^J^^UzN&ON[utu/UݯcQ*Uͱ<5Ք]~vϩʕF 1_}/1~19)OR _l.ɗu>cƖuخ&*lY[=]D1'^+sƜҲ_2c4ďX4og/5 b<1Hst[H=*TuE巫WdWS ŷ+|N<2sp0DLVEDm N8* VYq0;eAL&}oN^t`yi^Io!e~05șaomO?#(?G@G=Pq2MKUX"*T?Wj߮pJ?W|T*~='E6݃+˂K#5Tj翥G=.Wmk{ޣۼmw:+84~ 8ʻ>lLGK},*]彪|8'ϕsŷ+|N<o#ƕj0!os#}t\){Uo|C5#&hз~XQ6GXdfAfD*tWVq? jèzΈ'?fɜ堺wr2 hnУ{j4uOU?ܗJ8[ǢUޫʇSy2j\ͫ))\ S=*C؟L\Ny,&0ɟb {_#Dtq}wvo=IZ୐2QRetE3Gh/.Eοߝ(=ǡ%Au/~gVGB;e0E@'h>t *IT},*]彪|8'ռ+?߮9xQ(G:i+ocq5':. ~-CH?xC9V[G!QG#P_4RH?Ư~gWLX4g\#rܦRC8g+P 2@6#Rj>߮^U>ʓQj^MەNoWy<~]D tu6h~LSy @ sIcb:gOۊ ӽo^3 rvqS'rbS6k :qנO r(?ӼŠ1Y- 3 WooWuuSܵP@)n/ݭ@Bq/^$ +眭kϽ 5!={5לs03ϙ|5汐N+pNqy;syq6;IX$׾M[a.)x)#)yVo|df! 'Ҟ_6=v4k].)sG2\8tS5 8lG-#cL<11v^ɇ#Osըosٟ7ϣe0LOq&S1{ŒG6k:k?%'0&O>-S%r!\1;J#ϙ9a}{]~Z >xMKʷQ3_EƕK83} [V $0 2OJSQez "yWc 佒G QN=眷?G=Ul?AF8yhfφӼm I7^vmznϫJ9*A~ѽxۦ&?^=?Jgho;q{H /iBh'<%ഐHuHWf9R<{%<Wz89oosGP}1'çToگ rY3?R"0\3GߗcY [`9儏B &<}>?`:Wx.T1Y.Ŋ<,)ϙ|5汐N+p Osըoop؟s7ߚ_ wő?K6W$և? =}J޻v!Dx⸝u%t:x:˸U ,ȟeUݧ_€F2\{qq_ƷGNV齒?#]ۖw1?g^*՘B~;yÑ'C9jԷS9Qϛ{;k9y+|>/BT/kiⰷg4\2[ؾ#6WRR,Y_|y:D*:K:*Q],1}tzƷs,>v{Fbu$^ߚ$% }ϙ|5汐N+pqy;sN17~\}H?a}T8O {wPtGRX޳ѻLAu>R2V=[ 4osb!ʝb4:ϯڞ0KeXoox{O@ըosٟ%M. aב*4)\Ɯ\I\VP,x}29u5HL@4.g_q#:轊[L_X#StQ'oR {ݟ.2}l?gz!3/jc!Wȓ~5۩vmrcp3o?Q #}gc:#r楃29G?UY|p9A)|#/0vcNh)C\RxvaP ϙ|5ڍN+p4sըosٟ_[Z}o+9hx;-SeЩ8}^b^? e>t5;'9:]p7_lX%r p&c6//2cj.phZI178(^4>;>Gb9EW!}ĸ?g^*՘B~;yÑ'C9jԷS9Q{p APS^ = Ӱic|I#oZ rӿBΚ=|s7QD?c1>H[v_SV _$M]wV)cYKe |@?g^*՘B~;yÑ'ϱz89ogzƘ/dyc{;G/w>5.'wMaKG#U!mӁOc;Z&W0oٺh{OorPi?Z61ShۧE.u]B\k.JL]h6:/3/jc!Wȓ~5۩?zޫ'LA3r0ZPx?ࢷouL3%owaҁ/|pt8EqmCw ؆;Sim\VY2[{pxB}^$̙&Xǽu7.& oX%:P3/jc!Wȓ~5۩v@6J$!#_V@Wف4~}%N:,.õ{VͲ~j#̹Vp7l2k? %z2u7Ug~y?g^*՘B~{{<Wz89ogz<1I/3HIw\-6| .vATI[L\ݝl1rGD/un7y6e]9m^T͠aɐs2_y,䷓J>y2ӯF};pܟsW?/.0dKrR1o<}~7#(a9nU[Ys+2Mmpo&[K Ar/$_ q7(" 5hyLM]1ɇ[ `<.Q;R|4KeXo'Á'C9jԷSy3oGz<wqm_߄ov+y{XG}d{=NC.wNc z)-r;c>H M@M@~RPg?rJF;zڻ?g^*՘=&<Wz8ϛy;sMꉎ6\\}S<$`J> 7-v?ף7dI+I1gK90nJL]#tykvț]>m *M prm;9$aЪJi)x*8#/jM 佒G QN=ͼ|9a~VhdŽm8\\g&Ԓ3i0%ɑOK#+hP;݌0V=Og9a#Lgkw!ͽ%CB_k1%F^jϙ|5汐N+pՠoop0ogz<?,?/[6䒖?[p/w?D^^Y}SAZ;6/-7)C>KIdsu\ y} Og}k:c~[7fa3طf^f9R<{%<Wz89ogz< ~Ō'_~ǜ no~Az'-%kҒ}LP>KI ԟ!_LB)K+"N]N'*ߛ7_[A sIKaEU~$Ds2_y,䷓J>y2s.N};pܟsς)FꀱC%'!vq2\y*g|0c>()|28q}.`Ӈ%~!YH:FN |SvQe}?,͇0QX&dU&3/jc!Wȓ~5=i?G=݇[OQ0CHD$kHy?[ԅ g,D9u WСHiRlcaOнU5õg~'de O'$>KeZ~;yÑ'C9jԷ7z89ogzޫOM.u$,9x뗫6i-|$ '׫кsM9?ϔm&z M9I`׃_6nWy~)Rq$'ekځh|sWc 佒ǽ qQN=眷?G=W7Fs% /kOzܹ4ػw[\fƋ?YCO؍҅c oJvUvT%Zj޳ISaP<+4[?؞;`b6ࡠ6X5NJ,t1(ԱF/A7O utW!dTw'\QaPϗ7Y*?҇G{ɻ_Wt0d 1bo?oR<{%Ϗsըosۛyo>Ł*8h5ƑP~c~ KO&`{2%@u݁T=HD?s)y9dSB rZ^f|-.ćHSa""ОLy]On5KeXo'|8d?_v?缝9yo{/ >nsϯ+gJ俸(8_1wx0,Rf\|+5H1j:I2My *^P]2_YDJr.A:~GAJJ_5.ϙ|54vɇ#Osըosٟu\7% 6>s,%ں9Qb9ֹb~W;tQ#Iivxp*>cO)ꅿB6f ?oR<{%<Wz89ogz<"toM =0C59U%(]))q}PfKy*8e!6OdAE7[H1u|-EC_<Ȍl'H'Eߠ9AjK=vsR<{%<Wz89ogz;XYS2y/%m].Y9soA'涴9xkW?5YjaF/͟{s>Exs1)f!1Ŝ~QGc"p;LxѸ!{fIҁ#N~μT1v^ɇ#Osըos9w̑S-I:o&3*$zğ$R80, [,mUd̿_;gIM\mnf W%H6GSVEr݋`?N1=]#K6~d1yWc 佒G QN=眷7^}[r2] ')EbŽwqq ?+A~f!FX鑏=C}+_V}Oχ$9#cf~l:9w\?$T [wϷ]+~t#>s9$ӻ7DG cJ뿳0.`$O-J IN?u*C:Y6?x)tkp3/jc!Wȓ~5۩k瘷?G=oOΝ|)_Y<,_us#.!ϓ1μ,ǟW.HȊS,ٟ% Pߛ;E ʸwF_P4Mr8S_'3d^)YS=AfՓҏs34?t9L?g^*՘B~;yÑ'װz89ogz<)`lIzW@x?^#6Q,o-)rX' *XbuU&(w5?ƈ}ȡ۸ɛˆ5uCs2_y,䷓J>y2ӯF};pܟsyexf3ܠ<$[Gt s+h{◷{t:E J]8qERqs[a!ʨZIʒwßoz}8䌕o(\3/jc\R2!]s>+e^j>DC/wsM9R<ߎ{nÇOsըosٟsmd-%s7Ԅu_c#put[k]ZmpOyaayR"70Nd‹5K^B^xڂۮ 's]73yWc 佒G QN=眷?G=}?`>t=RS%|/)V@fpv/(^t(g ؗ9B0WNR ^ .r13̉c+.aI'؅vv _cKeXooxÑ'~~5۩vcs/ՉK^ć%AJv!bNN]%;Vo^$ rMo'ͿzRύB/׫UVh$AB-G\ 9|$e+4F$ RQ∺4g|a?g^*՘B~;y'C9jԷS9|Ri;X%F.}tSG)Ł4 -#.t0XbOcyGk>y~q7aۼR][t[ikcHM$_SRnXϙ|5汐N+pN휯ry;s.%r,Ump~msΖXmӋJ%üs K$TCCIJ'lF՘/S0w$ϽmNllLe'{J~1?:'?n+\_$]zwwB'V03JqrKs2_y,7|  Qssٟk[b>|՟E!f}< OAw%ud ;FEj%-C-+Jiso鸼hg~Tcr:L:FJ|;gXrPmǙ^.b"98p5n|Ls#6}Q:ȗL'4 'ϙ|^ x6|8+?_v?缝9yL>k)ARxy'BuuI;!Klqv722_y,䷓J>y2~5vn{o\y ^cV|~)2_x(sK}}7XU{S -]ˮQwSៈqj|[/.Kx7nX\3/jciདྷG 쇨osٟ_\=_Z VNoxDSOPtW×=8qۋorǙ?ouoNUOvdgSׅqݪВf>^L(˜' 9/1y >9u 2rTT_ƼT1v^ɇ#Osըosٟ7cE/CI=m:z 998:Sj5tq5u}hKi w]})16 됓në#Up/䥂ϭBϵ|Vߧml>iߦn'̱f9R<{%<Wz89ogzޫ/XWiTspMȟ.|r3uw(]爇bq'_]d{_^}Iy@qo7Y8vg'Z>R5 CT i%)s譪~`@tpX}{VW1Tnq'5Q~Xu M9Rg 佒G QN=眷?G=}?7WVHs9m/[ ^Z[2Ճ>NAq] ھ:D]KOt ۹wq[`;=z* 7Qf؟  ^Keu䷓J>y27~5۩vyZKkZ3srpTc*7Nrs<,޽뇋7RMC)N{SY R⾞myAgo<*=e{1;5c~ϹDVz֚_'s6jc!Wȓ~5۩㹣捳->8M2\Qr_ ӋѮ?71`[hF]s.%-Bϒ>£:HF,vzm>P:.uy_dz^8$/ǷTps^'2\o&yWc 佒G _vW?缝9y|xIm/A7US;}7vO CEO}s&Id/->)N7K-$1Hy@\ kÞ~ ><|mIb?O }.r-*s3/e汐N+pN5sٟ7cqB Ӷ6gؾzK% j%~r7ۗDӁW. 5R,oXOiimdb\Xp=ZRr230O0ݭljta}1yWc 佒G QN=\?Ǽ9y<@n`+`~UbM~z08-t'sm@ǫzYƏK0}A@^ynf}" ϼF,W׹dK^[t?sYAD}+TRn|ȵL/s2_y,䷓J>y2ӯF};pܟsy)n5)1$ӵ9YNG6x&K=▯/c;CI?Arx]@ō [cL6+`ܫ/\j|F_S @ugKeXo'|~F=眷?G=wŇ*5H9NAw䎵cT@o?+O?}%9Ӭ;WÚsD|h9itlL0\?,*T`tt]r Zn)?|>U9 ߨn#YbXqg}?g^*՘B~;yÑ'C9jԷS9Qϛ9^QttS˫ԡK' Zn6I.ЅM3*!FRpcS2qyu ĺήArY%A|n<~?ǯ9aR*q'[Z/f9R<{%<WzcyO+w҃GFs8˥Ӹ-l`Sp1b pZ:v]I |twȯ4zͱ:{=><qi!L%[(~UBatI3/jc!ὂG QN=眷?G=oGK}]`( J{E=S ̟>\ G--yN u]Ba)B3wMO"JE 9nnu1spOk^CI}- ks4[:$ 9>x~ ;c9R<{%<Wz89ogzޫ'Ћt=6ݿSY2s>M; O O]ϩ}NC6Pz)#Rp2Tǽ^@-+e "N_TK :y]` B7 ˀ#1rs2_y,CJ>y2ӯF};psx7<<|x|ڼmc%QLⰯM#"C elK ]b5jW,),ؕ|k :$ER\eHy2ӯF};pܟsy>äc,! k=?~)ƼaNUp$B㾔cE|jx'x~_qEMNqٜvr7CYHs<,uLu7^[!Tr#[S?"22yWc 佒G 5y89Q{QZSԀokk+f^sD1o9W˂`%WjRKv/J6 y/ou4=/yC)zOs =H{ӡVqI%lȍqZ=\8<-0/jc!Wȓ~5۩v I]_Qnbתs}t 0t3HϬa18+̽~/pC2| vY ݪ,OE?)PDա?D{1'nï;7KeXo'|8d?_v?缝9yyKqd*=Fc`([K58)_ }c({V3.AyS Ux ~B0χqO9N/RL4|eY[!IbH TK{ףm)dy?g^*՘B~;yÑ'C9jԷS9Q{oeyl+UgW~l5z\sL\9l[@/)ߋ׉7kt)ϝk t'P::_CU;L]Pr1|l9}ɶ?ϙ|5汐^ɇ#/sըoٟ_ez޻/pOPK=-—ɵd3> [v|x"ݶa\Ó~5۩v1.MŭG/K:.Qmh<N0BR,Oz~I }lLpOgE*3KQ%zmrma{*[]  ܉~k&Ih?) 2KEXo'|'jԷS9Q{ś+mg z{@ʿoGJyA99tq9􏺟3^9x [K2 (.ui&^CC ̎5KeXo'|8d?ojзS9y<Zp36/߈m$IB^rsOE}^b;?{sq;ZzcW %GnoG;=Oyx0O2zF?Oz73 )0:;?v.SolycmMWR37;oBM9R<{%<Wz89ogzO8rӯU-cpA~dk pdXm +"޸yӀeĆo3u;` %[}}G܌>Uz\m!CTck}y  }R<{%<Wk,?oQ{;8z־[6Y(=CPtː5 /IvU9O8JRWmw?/a!Ye9)xX_%w*W^%>n~%Νjrco Cq;̒XμT1v^ɇ#OsըofގX;Yy]!(OS9S-z^ނdBo~mrU [؎gJcn\ԁ :)m}kM9R<{%<Way;sxC IRYoI}~,up(E-ؽmćkD.;8"9 YR=C_ s&G \(vqכ/?tgqs]:dό|X1-:?J~,;3/jc!W QN=ͼ9y:wAs%ҁ+A%*]Sb揩.ɠIul;B>xb~|)+N6=t=X:ZBgIߋl*1?/=&l 󷿒a耻Nո'3@r;~1ORlwJGoI|KeXo'|8d?_v?缝9y|s>z|y4=AT# 2=PZWoKݦ(0(|~nJ~s|^vrKJpTOgA0_WpKK8ojϿHkkK˦*¢e?[seq-nhJμNc^|5汐N+p4sըosٟ7#;+Ju{}Jea@x8-Y;uV?̟۟L#;X`/۝N>_w~^IKtcVa.=H M{')g6R|bG;_Ҡ^j-g/`aׯB&yWc 佒GL?_v?缝9y<{N~Ε{湿Xp=}Lg9A_Y`Νdbb_fdaD_|~)I>&?n]?Щ%<AR3fӷiYC0/Wv^ɇ#OsըosٟcP4~AeCKۣ_Xs9na$9R[R8p=St_Krq/1/ I1|2j-q$j>]e-?g^*՘B~{{<qy;sy ԧҖ;^}r /1$aZ6])5LuwAFUƅV>AҰΞ9q[~efW%H D&%_L7oHʜ~}Z dз~\r؋a"IH{;}S4.#1Y`SμT1v^ɇ#Osըosٟ7';3HM$*ZI:OݣOIJlS$?I%IK'bpR]v3Dk SbqZIHO@9s,ؓ0Gr}mWp M:ȥD_oAA/䟣?eXo'Á'C9jz89ogzޫ[`s`h7$ =kPsC]GA~i8AҽW=e^|a~k帻5^" m䶮4t]~b9R<{%<Wk؏py;sCHHMmXDIv0e:WX(Ə'j=Z"8%~)P!ئM0.]k#َV=pΰw/noܱ$V'~%IaX;4)sP3|_G/6)}%M)TיB~;yÑ'C9jԷS1ogzޛϿmb Mc?SN!?+^J.GN*BEtUbύ#BCŇ՟?/_A.7F)6+KlG|}wo`9r0yWc 6|8d9jԷS9Q{U[%;S0RpM?^bs{s-OΎ:zG=[b~)9tKϠs|hN'UiZ6={)?ypTI j~ vulABn+IX7KeXo'|8d?_v?缝9y|5s=]N{qӠ a|'p{N|݄d7sH?L7"~9ACc+]CGწ˥ݶun:9~Hq$Mp쇞V@B`n,ϙy,䷓J>y2ӯF};pvF4఑B0{C~W\l>'GrGh?]eSq}g>Ʒ!Ţ@ug7WŃUa?0eZGS7RXIHz U~#xܛSyAP\Rb{$7/qǺ/"t6Nh|)@N-^Ε$NLm)`KytT;ϤE;9n/ e\k3/jc!Wȓ~5۩v8!>~ϔk޼3]msIj:^]Gݤ5/z憅b֖W ':>|JiR!^}/y?N}*激Y??v^3{H< H~Ϳe:_m{bw"P9?g^*՘B~;yÑ'C9jԷS9Q{yšɁR/0W CK@:m0>F|%gϗ+@CJi[N ,be<~)é4});vqy2ӯF};pܟsyȁuQ\H\ oΟ]jκ^=lUH|Gآ2E7m#Oû*@C/)@7\hh0qJJ|ngשs}k(Ĕ#ÅkBV^hHO+o-. ߧD^e*ԠF?a9R<{%<Wz89ogz rGg^c~8^cl{ S[}=[*헌Wց_?ϙ|5汐N+p4sըosٟg\^l{^kDvGq*<K.rN>K NJsw50Hĝ?%GO6k|*s'Sg?Ə@yI?З2yWc 佒G 5v?缝9y3LA'30!員#q:oO4fJgNu O"ԥzr])707n?nA]IT_r7\9҂y ko$>b'.V?g$zVμT1v^ɇkx2ӯGv}ϴl*j̧c>z[҇x;#ߢ|&mL_00 8#ڢO=ބ0k /֏|ڪsGZCԿS\s2_y,䷓J>\Ó~5۩vpl=߷C!/?m|WIe#/%?vi+foeXpֆwW_Z0p7hSܘH. ?@c?@F7_LO(r`Mϙ|5汐N=p O(ըosٟ^U1?Z:a;:vQ=|ʄZjbpp|*7?Psi:)o5)7y> t9%-7aY|m ǼmO)ZxpIf3yWc |8d?_ѷC9Q{5I?<{T9pIzV kR/8qH>_2oߋ_,>/oy.)m$_q.3Ư|8}|qc{?g>|p|Dzl/!'/*Aϙ汐N+pNqy;s^{:h?\b\'M]/Y_bsVn3yWc 佒G Q?缝9y|:[?yܷ0ӇKuJS+>2|me_$Cnq(^mhz|5bAq8Yf 1J\tM#2yWc ~Vd?_v?缝9y<>z]ErPr̷+RNkrUMTQj8xyV<ԓJ 90`Y //9Bq.ƿqY 9&K 4ra}zkqo?g^*՘B~;yÑ'C9jԷS9Q{ߏ{i`s{{yuDA>u⎴w㟮ǘ:fIkQoTfB]oN_4^|_--$ S͑36KeXo'|'{6jԷS9Q{;>v# :cuOT. 9yKMOGq[t [u1Y$ףۮj`Y@ <.8d;I$n\jg]Y'uU:s%G~hM]eqIW!4KeXox'C9jԷS9Qϛ&Lt_/i> ߏtWί N6x)QڍJ2pʍzzX/^1a>4|#','_ul܃8lÖI4x>1yWc 佒G QN=眷?G=oG8靧#iXm7I qMHgtI$TK%Yt>T+8'Aӭw:#u>#/F9lb~sra-'!eze%* /1yWcKo'7d?_v?缝9yyA~.xcV!]ó cۿ|*p[D)T.3Z7#o[ }b>]7>jwu=ԘS>пWp=x~0?Yg v{C/SB]ZΦB&yWc |8d?_v?缝9y}p׽wz D䯯d OI.L'!9tѦʴX{X^Bg?˵8 " \s?ǖ#F?= FT KI*n@ugaޚ>`Θ> &yWc 佒G Q?9y<~4,M/WIR]G/!>}ߖW:ɺD">(?RopyZ'V9t+ٍ|>(LIvY&LvadEIo7.Dx_s2_y,䷓J>y2ӯF}{c.Q{`n-w0]U,$Ï VARhaޞ*VI_Qtt md&u'c+h7 DZ{BTP&1x@1Qc9R<{%<Wz89ogz<y1nJ$删7Nzމ߯ /L~һS_M2އlLhLjd!`U%j<-C!fI3Cp t咑2]Tj뫈cs2_y,䷓J>}\D};p<9ogz/ҟғw )~;,-XqK0տ)+NKۆapӹ'̻P!%W@d~3KpsprCYPyؗt+ =t)QEμT1v^ɇ#Osըosٟ%l,0?!zp5P6G_WbUQ4=($K{M{͔pQf)BbBb2|IE? {D ( (ș53^߷7$8nqܽZ[_]`] gw)/.e:df=_Uv,M-AWTX>SJ}S1[yG\zFJ17/Ε;+4Q*0@k-ʁ,Nq wKXo'|8d8y5۩cv8ϸAXF软l;tXcAR;W7T?+ZZkl"x譾ǥs])};k.YzpÍ߯9yGfu7>Kjͼ%{ܠ:JTяv^ɇ#Oϟc^v?g9"f3Fu@SoMJٱsr/-|2?ZuՊ3-L9z9?4%sk|n>]uS@Huj (6祜@R<>GꏖҺWNTяv^ɇ#OWz8Yog~<ݵig:Ȏfo.3R=o NNy|'˗N>Tz9+H]Ӯ7[8%Qctz]_hܫ}́i-Vm/$p`:ځ=r29RSSMCª ,Ik-O#WgZ,(3~W]}GTJs_~,䷓J>y2?ñz;s硞渃\/PWNo`4YφNrB L!%7{ M.ޯ5J ]i%_Ovh7A~ٍ}|K }!:cIzߧWeym_ɳޟ9 z/v^ɇ#OWz8Yog~<'Gˢvωt̸i]\F5XO/Rb^F <+jxIϴ\;q$Nck\̻E%kWa{/zCٱY_K bW=$1I\;ݫnֵ8A0yrnKXo'0y2~jзS9_ -$ Hڴ %-R8%= y̆ +C9=:g*7dĜ/}+9g.{=/ym k\AEzM>~Y ߅jzsz5yÑ'sΫQN=笷3?y>vmRޤ\mj8?|Sy Oyߞ[d>L}{6o޹h7=YoWZzӣM>Z|Ւߍ {+C2M/,)BOZd糬Iqr~|'&xs_~,䷓J>y2~jԷS稷3?y{l>I6K5-vr#0ysH$Q |N|$aNrƦC\Kb&?*G8o(^kt쓧SO74)>vs)rNTяv^ɇ#OWz8cO賋{I8c κΜ ]޹lp tD ߫Uï&-~5ٯn)] oℰe#,'-a99,o BZV j!Z-DhBzV!Z=DhCzV!Z#Dkh5BF!Z#D4o¥mv>9Uo?oՊ]h_̗3gX%i?7جape/data/chiroptera.rda0000644000175100001440000002730311041442344014600 0ustar hornikusers}y$U^DdeI;t.00좕Y,cQVUtUngefVL 6m|ۀcsdn - /32EVJo7:^q{_Dּ>Y/}R( LR{5]dUZ*U*9D .1x9TȧAO|? ˟%N> >pºw?9',@XE/v8N/|@ E~W=+ _䫜|7',׏ o y;uB7;y78',t&ȷM_osCc ߐ| s;aB ?,aݏi!?g NXE'e'":"uo8ͧro;὿]'?tkHC ovO qHJ n N?gL'iw ºK]',9ay u9r GN\\u~',?巃 !qNN.Nֽws/8a=NX~/',68a}!A8a;!||?aNXp't?!ם !',?䣝'8}/%'uBnBsPw 򗝰b' y ?K'/ugU'uNXeBR'2 'NNx9y!KHrSB*!ºr݅l|o '@&o ߟ8^!iw? wނC',#! 'OvO!l ɿpk_;7#o|S|;pk> brg uw^uyo|;w:a b',ޏ}K|;¿_%AlNW z;_;!>Aa=b;8&!u NN ۂx{1Λo}+#Fa'{;仜NX',}o| ?r;aGB ?.tºrNX3N~ ~n º_tKBXN~ɯ:ׄ~7~ow'?Nx-b7 巄^oY댓饽y… NXFpNXFpNu .勝D^pa {B|C'Bp WK\&#vҾ흼wt2 9oF<᝝uDXnoA X{ u#mOQ ¿:a u#NXºrC|@NX!ÅooY$Iƴ>xR-_' ~NSU˰TiViVer JS{*ߒTY =|/*$yM$ GSL|>M{*yOQTP <Wa썼T1R'QgQy>삼=(M'07<]a>Ya{*"|O!7TAPr B^s yB^s BT {*=7\>r>>Tr@O!S=|N!ST˔>r9F!GSzS!S7\L!o#)g B>)a B{)X BNc)W=r*܊B>#Tȟ( BCSB3TȋrB.(><rG!!穐(: yNG!Qmrr B J~Gѷ>Gr<T% fR;pܧ$Q ^RpO1_RyS56hwt]{*=7tƎTxO[VxM;V ܧ =s Ua%DeOŸXTKݎTGcu퇱>m17B;m0vܧ-0)9f`<*ˎTOXX8>瓱/pQasyh_rMkr[5K}@mxa:SۄNۤxi:S7N5F8F |v \u \u \u \t ,q p n n χ5Z5Z59<ݡ-ۡ=جmMٱ]fM^6k`&k`k`k`krnpX_sܧkkc2rSsܧ.krdgMN@c8&iMcC CS52}j&W"/1qMFn c嚼>59/\ܧ&'1C>5]⸒5y.1]Xkx☓59-?9-́krY| { {MqWq^Uan4_h&75>5 'Oq~>5'̑&9X4_50_50_GܧkKX4$M> sد#9Sc X4Mq SchrCW5@5_ܧhA[ ~ O5@|kدxxO |؃kb=mXɩ64^ɣ8S50_a#< lD5 1ɍNk`&vq~lIpܧkr%5@=pܧzG45Aopܧڠ949.-0X# :p?6i)Kuqb5XS q{hWuj1Yu`0X? }a%O<7q6m}'}`!î `Xl7aý'}`! ;7^عl{aNy5oܧ`! 0k k 0_ pS p-rܧ|7 p/ # p?~d{A4O`!· [g3<38`!^/ 0xe75(C\`!_ pm 0sc5?6|1 W q~mG6 =:6 5m8a k <onn }x`~n\0o` }`׆ p}V)}ɽ? }GW +2/1{C?1C{ c3rud4ZjB}` @n`ۆM;F m $i`7 6H=юh?K} l> 6svA&`=ihvyO4_)yO9|4K!yO#i8OE}?ƞ Լ{< ¸$}ɷ 9 7!~WrԄ/05A?U  @K yr>hOBmpgBxsug|ޓ_>'|x'kYx؝<'vNKxtN 9;u 99r p8!M| `oM 7!wM{4!7C^xޒLsy&s{&/x|\w&xoxk&}&blw&s;nMɲ=;`oMII p7&NK&d 07L yO gBnLs`nBNXk1I>cr1_0O'EYF)^;L[Jt-maoWj]VNOmz?TOmbTQӢvLrۯXO7ꪜdE]Y`Ѩ|bmmݬJ)-Y7MSZhu{餬FfiE$ߔTo,7MӬox=⤬f]׮YJi6Cu/Z'USߞ:yY3GUqӅ9x4]m46C^w /ZXX}%^XdS'{]sW5&N׽u?ʎ,iN\Ez6UT=|W֫tMW< ھ`ڃݴCV߶Ӵ괩r]fۚ"CnkoMڽȊ}bc]l[\ʢSb>OtEY'ͽ/l,uYz{z/.ڮ1b^Ң{y9˺NieZxp6+a_6?k}YlZxM0[5F3SM0ZPGt7uׄrl`b`wv"Xҩ~&vyZ;3yxv9ɳLZUV` am)ۮ=݀J%챜EkgǏaH vW٬l^;[]yxU.N˓^7+',OO67i.#/, `_*l{..澓Rѭt9`Խ0RͳlNm=~*[z,x )z{iHW* ?~|3 Mz\ .,@a]IX٭LSG7X:_9ʴx K흲Gj+͖n]qg|aS+|&/mL6m^o{^0IC_c,Uvw떳ʂ\r m{O  ӭgۻcóK,6 k_o#Vdjꗹl;ӛpزr?UB0`ަ^K]0EǁP|+uD|lyբYfHD侯ǒ9rPO#sXkriӪ1Aie"@YXvQމeUEM}|b ycGΖ_wV/'iS4m^1K BR^k3[-wR^6M1˰\ٕpִU6eBlmmZ`'=]r|Iנs脩E!{(2=ͶG\,<\~LE5A`FzsO|I>@&>w3minղ"jFY n+lCjTfYUH]?3uE;MѮrXo-[f:-J*T VnTimqɟg77Qdte fwin֋ 펄\[ܽe0B կH~؛2UavrK:q *a+0\i}/=6SZ`"vSa'X3c!/2ġ<х_sڹBhM r@J]Y30Œ[ne#gedX7I*Lxu?ΰ ,V ҍ`b )I$Os:bQin|'r#Q^΅Gs>ڢ,Xބ=HYJפVUO5Y1L\ k6`Љ| L8@ԝLQQO&Z#oQ{XGhັb*VV5h^@ȧeqU:+?G`kB]yEeugշ+ D`g9Q[ r,ޙAE|cB~$'yO$Ɋb3 RX—aC.xyi^|`:״Qq(!fj֣]V6/FUKXwD L:DmQeZyٴHCN;D 40GR1%öma?ypbҟS%qq$EV Z@Ցd#Bu3+blEPnd { ޜ弌N6k,˰otk3w$s["\%e:sjx B;;P'k\\5?Ekլ;p:Dۺ׫u6 VWVy`W eė y6Ћ+N"пetgB x0,uR1gxh ]"*D;{Oa&cm*q1Px*$B-WP2*j_"I>-7mn(( Qt!RC/\G4q/4.E ,i5[.'G^C&1('X8g*}kS1%bn,ȌCqR^ם1/՘Zxj]fqU*+;ND墸X*ϲ,˕Myp1̰'^ݗ.4ffi7v`^Yvq?i ׂz]G@s EN2mi^Y[ȽÖ迫kc^Ryi }Z}q%Rb3`Ey81RU#X+Fjl1ͨԮI'Y.H22e͓r$!v5< Kt릓&繌zM >|59jxR˟_m,/)yBO,bg6߂I`~Ek\0~`(V^m$c6렯S|!X[UdWikWq]yvbR!6 /]).zX< )Mag꒫-!qt *|N?GNC\*۸I2ٮf<+T[i!?OjnM|%͑dHWQ5s~3>YF"բ eQo0>͸/5ґ[0Yf;$w3cȥݬͪvt7)I}l [zV[5jֽvK v]Z#S-u3}F)NG+7a~1.*ˏRݱCZ(,UNtksD(ʲQPQSlZdC.?2l^ӼŬ &4g#,-:b]16c KBA ]JHo kby司[ Xg٭8f7Dy=_?k?pB+jaU:|ݧq? [hq[2_6eI}GA*-L9GOHmՎ`hVuM6ݲ6餪nP r4+O`OYrA_ji6FNof,h"}{_SNtې. 2B9rm-1=@êϬbi2˔x?qi}*&f]~0 b[4 ^t{#~+I 3 \y8e àFV,VNVZ4k~PĿ}|;ƈhC%6/@<9 ޡN\*da[ރ4l"^xώ*3ڤĺX#[,Iî Pΐi-B> :#2P+K`cٞH! $p?DHu~ AGPHA1p'aI3!at&rM> LO %2^;~*B/ʹ5T\ _9G$">? YwM sx68{^J0~Aine7d5}B6B}!.-W+p !fp mYw@tVtAqKh >#:-< TxtԒ?%~B'%.&b8 mOdĞabGtҌ> >X}{^J6$C0}wD41C.I{Yi)@qSׂz,yMX˻UomɆ`aϛYOQdODz}U˼lA! ~H}t[4cLlӐFnj#)\/[웛WYe$ʐzg0=PZGfCyL X~bz g{Cπ #"7\%6[U~r֑񛻟RpcOk:ulT?'T'w (8[+ƈ[,1[jNAe. 1˧=ZO4;an9y2':wNKuJ;3_S3 mwB[>PxWj[G#eր(ӷd`n?JF`+}='vH5m~Tm˵Rhlc󕈻+P쉦+IIDŽ;1k]OUoOZP Y Lۊ?^$+y s`uF0,0^*lD%Ȓթ+rEճȊ3&W.uc*\'ƞz+󻱭̕"yc{b+ӟ< +͒W(%{.|fJ[,ڤ^K!ؙz+{6p{g/63>exGG6*3`YF1gYKgY:ttF!r8䌼KټNݕqq[Tޛa8hIKpqcĆOtV4 Nq[9یZ_i] \a@\Sn͍lߍ\lvWP Cf.<r\hW4kn#Ƽi6͈n~(ЫjkE!)zee3a_~TaRB;ko@ d nvg/V$O"]?cWA0Q5Zz.bh:RyJ y1 .7`1up nt]p#nOJ>\tsZi[Ӏ&тN:Wsimg6_?W?}u:^^~uzZ~Jӗӧo"Oh{ҷ\Ko{xek!Ny_ZVj~Dum£RKvBy?v= [[ $ )aϹrOy=C7;ԗYDfh"nok -p4;T~=CIIykkYm[revCi}a [(Tq&3mj=mya2ey-7USOmB-{4_l{q=g{!AaFqk@IFAVFi_>3{KZ8ມ4-BkHOoc-LIÄjk]g2bu. 6oQehyZfnk`P@5 ЄY$9} [Muu:{W8 :z'YCFd4eeY7DCr|W`Pu.HJ>fZޥu_9Y=^pf:8aH'x;2ǥhJ8@DcXGu<{V&|h8J`xIsfQ-\Q_{`W2mylb#Cϡ%'t`VGwj$c NjO`ֹmE+՝ʢN R9) AA֦`dX|[&,Ss}:zaDpSآrvpD h]F-jJIFtH ͩ l 6prx:6".]MIpfxB}d/7Qi T g$댻[\.I?Mj zm-&7zD+Oϒ(AHCZ f"pF) w]JZ~d":p}#69PsH;a<1֘kb7TE$,yj, 3/M!1A!t Bug6"ȶ4,+&d&.?1\GiY/}F;.{6R˷2O*tPꩺ\3}V<䃮Կ 1}q]*7'9Pd^v#4\ fmYa@1xvZ +>7LɗlŢCY fyE'QpCSڟɳ1FVmCi j {cDW|h OԖi?YdJA uR{Zv m`̫0eb^q/}dO'7={H<0G/s8# MO z|k/܂!wjX{ 87sKHyÃ|P WUQqyn'Tf#0hл>?~wǛ i?v^If%hcEwÜ6 yhj eJO/CzX `0uA>(KwN?{%eR1^^0jػx48"H>(Km7;뇆H wڀ}qbE@Wpf ;~ynAdEtɏBCD?P`sjO1cȀ/ V {lBS-;Pܮ( lTPZ'n*2Ŭౢhn1/S|P Ix؉%`:ߨHWդi_ߍ u&xNi, LSVo,߿F [)8ĞkksK, e=Asya>@]=8DI6V+P.]ljsš=7uSc?0)B8D\q6v-Pr鈖D}ܷp`>=rK>e0>zp\)O}ܷp`cba`n1/S|{[땤JV T}Z)c&ɗMr6i"&ɟN6J8G'8O'8Q *5>tXJQyL'Z gAEj.?ye ape/data/lmorigin.ex2.rda0000644000175100001440000000070711173564610014763 0ustar hornikusers r0b```b`bbf H020pi< #faZ> _$ 'NJ6΃y8<,y_%OOʊ22Ykśc-x"9|_Hvfm!ˣo ~Of}J{6u*S0m㏚2kޚ68O߫nM JO{1_3oU۹!.<ơ%7Ǻ,uWD8i;sïBR[W4JN- YsS H=Ln ̪Tt900AĒD"h9m 8%bac`bacX`XBE.4222229._Mx&ape/data/mat3.RData0000644000175100001440000000131211127122672013525 0ustar hornikuserseU;lA\IHC mh"-m"6)P 7' DB&ujhN*C7>ܮgowξy[[^_J\ɕB<[*877nŹKef+o9NO}cpww+qU~k[nj8|C}'nP|Ǭ' ~TÉߎpw}紻W{<'?#[S}o+V3K89A^i/~x/NT/yzpEB7>9yaaPꯌ?o;wćv0o/C&~~ ?~Ol~ڡ޼opc=}F1?8|Ss.~f5IK*K!馤[nKc(LvaQ~l^/h(?Fape/data/gopher.D.rda0000644000175100001440000000234711201266326014111 0ustar hornikuserseU PTe^xL8.<0N a@;@$ X(jZ(!% j>>p5@+@`@Qv߲;s={gg;8e%fm̖&|aYoL*؁m6=wA+n4nfjAKׯN^R[T)SzBs_ o)(%j0'Es|Oyh;d}D>K:TiA7TCaﯶo)>i_ jq^M FELظ^+՗MkY <LQ7NJ| .kGhcz4::Zu:>_W2BKoXTMBAU8 LHXO(, >8sFC43Zʅ>il3,i(orۀit,ZLbQ>(}zR;A|-b&op8gKpiDGYפ9Tn1L 0wWfu3чeο`K}"!G_8gKpi c#SXpqپ5|PT)nK^h]bPL7¿"仺LÖnarB}qȗ>Aip8A^e {nލ= K[}d{7u,JNqW/\GA&^]t=t{_yN2 _:嚭z#K(>/}✑/}tzn=T ];4WՑCwv^򺞾R| dP_3%Vcѩ =0(dWW X\pWb}xV/TsAB}qȗ>.վn Ҙc3r`T<'9yEs/3sF!5*{4 ͘7mOӺ&dŧ9I ywG+| .CƈG(-8OgI+ _GWD_3%.΂.GKϘ; _#3 9#?i蝤,{|(}JH+Z*VAZF &q/Wq+2+l|[( ǏE"LxO\ =^?ɾ6Өape/data/woodmouse.rda0000644000175100001440000000221011576267262014470 0ustar hornikusersNP](ABMK'P J]xŢݰR! T,>yTq}2Qb|sΙq|r=;>β ;8˃~]>~_OwYv8ɲ?jcbE,-˭-G}i|yͻkƗ߯0|?u v ; {˾OYQžvagy*w*#*IS {>9gݹ͟aO\6M13 `o{GМ/<BRHqoz9kyXS οz1Uo/U0Z/#~|zm2܈ռ)sMk~m6l^}Ye9:i"Ff\%M3c4^_'j/oV[.˺'@+A?zrD =[E_jcU;<'_bҕpe)^=Y<'W`ZX}rf-o8^$0;)[YvMwhci3O{OWǡY0x~Ə`>\v)4*|5||eR*oWRֆ魆Lgqc}knRWCa`f*Yۣ?P_c z߷{'._&ބS;xok? VWWI-URv]Js.W7$4o^+SGM=F7nU{nt}ܟr1q .5:$4ؿTU'dgx8%9 m9}5])UMȿ3sZ\fV8y nY/.}/oU8U}=BwZ> .'B'*dj1|O?}⏏a-ҳךr Aim.?:uܻCa$)݂a{6/j;aE; T.=}s`-4T0%^`""tǠ;XD>3pO%pٮ*~+zx\~Zž7mW{W-E{dk 쁟dHh|}m_.Mq$g~<v>x'FtҀ߲4c?=mun/)eBP`|hIF;ϼ }EJNm-V|u ΀%J^VN{3|&[Jmxuhg޺DӚ o5?9N#xaGŜcْ&ݣ´6.VcO'Y^AWb{h_A~,}0;X6 _b\C%|<"vwUF<-Uf iWǗxH%nY d24W۟Gu(I5q ?!nuZ?{Ď*8'tp;w(!XĞa2+O%d"ק^OYi]#5Y=#-Oϩ |_Gu#ooGl[qؓzʰ$/~b#4:W:So 0S{n4V^q[*fY_f~jvyXU~*83쐯hg.>=p~?88F(0^jw$B2NhevRNH9Џso+ 2F,?~gW>=n"EԦC?WO~YMWMKL C,C:X^d =G(? nev۔ua桁#`ST^1:YuEn+'ܦ04 2()_uo7s,qT=>Ιvf??!˻fu!":DžX3$Ңg_a? 83_\p6:{x:̓Ӯ&=w}s2:;ۢ<ֶjNڄ px7NOo#Ч73;_\}gy y-ߙO^ aߢ/6MWU?.Ň!.AGwIVA+V+mCv R$N8'Ec%#pL+qmI}~hwé΀0k3~>ybkግ]p hGٹ B~;r,_3թ"xWe=]> ]`ֵ(\J-fáϡ>e-s7w:tC1aj.jkӹj08m[:Z?Ǝ]g:_kM٫KŽY,p~<0A*8^~<9p݆mںNim mp⽂sr9aL>' {2z +m|;r#k`tı-U;Y[O=P=ke6G\myAxGiO\f&7rQS{DQ޹~X~쳱:k1D3V_1Y=>{.[J]`}- A %l?Iﰃ3-l~|t=wYǝV[b/Xʷk97{azSOT53?S?|Z~ nABи4 }S> 8g:&ܕָgj+|N<2DW *wn[h 2 8FQTR/pŇ#p;cy:5wMQ9KG}&(PK;ʺ}]QxT=_L DۢY-V?͙d|_59o-@ +)yc=&+=j!C&1ٜqWY^ey5_5.-O(:$6Wzf 5 6qEuqU 80t- 1Sk]pUn϶s+#V='ʾ Чr''%fݲ鞮5\5nش^#YS+B|lN:js cO AM?|;x'?Xq0iSXڜ]Jj0ku()?q~MVh x*JXꕚFFV̅#^=BEe|~j߾+'>H]W|TϓOKΞ0=I-]~|;0}\짜и ) -췎?>}:sn, I+|ﾯ=3Upn6|gw-P4pqջfֻFӟ}aCJp.H>>'=wpqZ+XXi#/s9Y79HYQx`nq4ER7և39;8,a i0 ̤_ Êz5 "|T#E,,^WM >>y/^U{'Qee-4ǖA;yʼnp+H>a f ‚X`=ö'\wOm\>5)I;(8¡}Gy#OU'ѼC>zhVpO<@soR8f3  LDp:߰}e oܗN! lAoOKuGȝiSb/d9zO/WqMZҼz*<+XW?b%'_O u-i~3Vy+ϥb!lj;E bR/>׺Atj*ʏFwa+CW>B[ȕ0>tG'q4q* oH6||_=Zσ.;߲_rwNtvFx[B/zQn2" BeK7moWy2(`Og_ϻY'" 3zg5G /׬q> !9N+軔{x?z\JΓPa>=c#+$^kd zahdzǪK?C(h~a-O՝^vs^)azZSp.pۼp3tvJuٹ:[ X ;!-WB'/1د ]|Vc}s"u]߮9V(~ýka v..+r>Ι+ Gs7a( 'F-xkC2 6!^"s7ZbUv-YħFo,.l/tdonanhm3O 8|bs h`48Щ6ݩX7+b')\*Ƥ9avb0?t2|ҹ9zpec}8lihnkqmVb\TQ|؏ ^o<Նl}Se!m!s'7d'["|fX}J7:XM|| QwY a;Y3s )0; W 0oo߉m(hbl01ģ0qhI]틳N0zsh^7?+<Q4&wz]&y)N\64yW?1"2?W|T#E; x-ABg Pgo> ex~^ `8o7  ~7j]zQ:1o7h5l +ʥYNxT?  Lc叡$l'!sOvGW;4Pp*I~IuSF@jmpv7ڴb_m~? vOAú{5<N^Ϋ__#H v#^v#Lph/_aMk!<3Άt[_ wy&b0 l®'둝ec3N΁!/8ěz\{4ie_BwIY.k] OfJȜx},Ŗf8-cwbe]w 4[;-忽{]Yأf(7gdHO'£ ^'V=^I)M~?i$t5ncգ.rh/a,v[0H`[-0u`){o`(\Ʋ]&lGQ{)Xaᤚ yCt&Q{,q7X ;s?éKaŏA'G]k)hpj~vϩ'[_ z)6gz kAe+>xjh#s#;PpU;b;@ \ex!vZֻzB'1M`%a}?M:p_ nsQ>(w~y$߭+^L^A#c΃hDMNem|'-hߗ\E`غ Kݡ+t:&#L<.`zN߮9dc_`)*:b O~FeH/đX{|Z;3;3"^s"| ! ;Owxݲ>[kۯӿY _ X_sڐHmApzexT{\\-:`oapH|=: uUNfy~MY]zZ?nPŪ-) :{w4s[ݰ>&7snܮ$Ssŷ+|N<<.N ZI51&9#n%q{?ap$/=!X?64uh*J\Is]JE‘kbQ8s!@}+rӡO~5_օ)E`Єl,.StSMRtT034Tl$LAOue -X{J߮pj~vϩGWYjH-17zf.9z~fۂZ9U\h ՗=e-Y0sqavbcg pzaoz a I^)C_1Mߞ T`uŬ!GWpA3 +I4]j328~>.߆Ӑc6@ڮ#vi]nܚ[+⶚ufӑ9xh;YYABoWz85?W|T#롯;aIXC.zi UoՀ~k_~+ji¤bs/am ~{1n{N88: zW-]뉅`}lܧ:qZh^vלp4WJ hn-趁Ѕu;1½VY*}.͹,_B/Y~D߮pj~vϩ'@-\'e)N6bVB4ͧ礿ps&ݽ\# ƻ%XbĐ,@k-EA!WȷYBPNj!(YhG>#W@Cy>O:FWFL?.o->X}/a2o?@΁H8Ex.Mn_/hRvSsŷ+|NK"Iu"g9sY%__(_Tߧs.4A7buE,skoz}V4߿>QΝ51~}Uݍ ,g e]"/|3h!6BmzCE"u]"vé>zO8 Eݟ L\6}f7lvT]^9`/&%Ϗ[o',t'UC#>n\; CеF4  &k]0Hc>+H|KzY6f)@xA\|O]j/;\wsf1-^aD殍J``#@]N[lTy!)}A#01ݖ.{/ATHgܲm+hafߐuy-<8}Mb1 V^ ioEjJ߮pj~vϩG#Qg>ޔ~o8{@憮_>)e@W֬eݼ:_ywgoi ^R7~ =}9qAK)H* {Yx$v lA+%҅Dټ]3uӵ#%9=*?ku`\'K/$ZsҾ?sKE~%WSNNyd=/}p'O83Rgx9h6AVz.? ڦ,q9M]9NeW7X%?/_AeEaF!dC`ԣ•!ꔈ H_AFICp-!e?ä.(`] jP&8u%ke:pr6v.I])XWOx`(BWyH/aϗvāybp{+)}é9>zY¤_K WdH.N]0vMɋ':ЮK*?W~5oWz85?W|Tϓ;/oDx8[{_];A ;k E[Dry d:5 K :ς`)JjM#TBPm{ ObDl3;UaO_^rzEݗ~,?W~5oWz85?ϩG#WN9e᎑:7K8M>`7P]F^ ✐|s@4Ǭ PvAn~af |? ba:5!'r=ro*O&?'ҷ+=+]stLS)v5 QK8^'k0k4 08î"ɏ5=kh|^Ƕ+9<h/|Oz:n5\5|9r~WQg8 c\oh$47;b-+$r h324H(ٸ^'\)Yc+Ty2jJ߮pj~vϩG`҅ca>,΁7pz61Wj|"]A'lq+IΫ2( wϐ t.o ƔswfU/~c&lMb7Dv8IY-n0AEmo<* L.__s$OFϕ_-o'=+]s+~ :OɔpYY"竏OG)zjCOGj7  igAnTy)o^Q c=$;pi!S؛vA.ϫz>w3ӥ.!ߋ̋7C1 ;Jhn慻)M/o@+.}wOuX+<H+ҷGp4?W|Tϓ+e)0f Wr{iw~`TO{>2@~^t)D#C_ƃMsk䁂Kx.sRbIGK~33ؐ]FHwq*+; 좨³~ X'8J,>\&}h/4>tQtn<?W~5oWz85?W|Tϓ_QR&zHu72+A"cD19gA,BMD<yNxKWyW˶ <ҵI땼O<^$]w>]?76oB"[ ?đ{R?pYsz ms;!A<Vs#砡 %oH\Ք]<·>zY{X˓b}H9H mnf.ͯqE| 8)hjc M>Lؠ8 nG:ofVd}nE~f F5bI}!Vque| ԧBP c+7]QnL .]=" 6Ǧ`D[ aM1֘wS #"p*OFϕ_MەN߮9~Vz¦$I åG{04>)pe}y0Ki\ƭ ?O4hnワ?'g``AQ)6uA![黳iP2|px_S $&/05ET+ҷ+=+]sI-(.c\H?72Qx!lIY'8<0;0 k.CL| Zpm$GQպKHR4zvCL}]xOX d(: em 'l썝RL>FdCwb34_xsi*8F"y24R~5oWz85?W|TϓFʱ`hi4hrA\6w $\/INǠQMNM:h#V-4}3@Qz~CwY- Hpcm0B\A YmS1/{<7_QSz L:'ȹc].é<?W~5oWz85?W|Tϓ_n{P Eq7yV/!^2!P ;iNO}o\G6MWpO`['}9V=vOC֎ CyOAVGx\*:L^k~Y֟[ ^VØ.swBd~|&'!-yH> v{+Z>{~Mq !9_Q+ZtɃ/M9v|xz7{Up*OFϕ_MەN߮9\% [s .炤&IͿ/ pL 4i3i} I7:km8[#B4 ~"L tr4A3WE>+XMyA_+ ,ʇXka YcH~M,S(Ué<?W~5oWz85?W|{zY\Ug )_j.C2LRyoƬװ2H'hQm7wcf>yfYAp#[pH4O9,xO0hn 3u^*?FEUj$ߣ|nA“TޫʇSy2jJ߮pj~vϩ'.gi ƧY񤻊%_Ny(0t>-),.NGLt'!_Isx!?D@ ?cbO{m;9. ~=߈!} ATEcq#jĐ9|\qğx+&_ F^U>ʓQsWSŷ+|N<A9u/_Y? Zk?$u&4o8O,>.""t*O2NOy~szbpi^|dibeE<;8dXnckCJҡH_OadN*Ué<?W~5s߮9yual]֕'1}R.Hk8n\S.Gi 9Wp6\\c|K[Szx%̕Jc\ [@x ]A"tφ㇗`}C%RNWKUAyA';kj?ۙ,oWy*N()}{DGspŷ+|Nt:v] j)_y+ 4J.maqh7m߮^U>ʓQsWSvSsŷ+|N<-%=m{RO+`EO5pE3 p`_|}F)]Y<ر0s]  :AO725L!G>vRGT-LR1Ѐ(]彪|8'ʯ?SsŷG|m OS.W=[^!.܁y/ʅsi;;xaMgOݍImn y wbK2OecGxpcQ~ՙ\19b_uJRkz*/vC;YWtӥ|zʁU۩vT+ҷ+=\d~N|{z?6B^̝vᒞ׹$!mv-YomIoX".HĠ\:tTk:+v\Յ-v뷹1SOh'rafc<3쉲2 0s$Om /N7芄{'ݞWy:DjuuoWy*N()}éyo'|N<>ܨ[ &s}}pHh\S;D1n:92цc 3gpm%WE1I/Z9hr_o "( X!WVK!%o&=0˜NSlwMb;OBIIx EZéÃL\| wTOvD|ny7,UʝёWSvT+ҷ+=+]sI+Za,ݹxty=JqCҫ VY&s44<[OeޑY| ?K84r\7),s-h:]h~qĵaῼ ٤k yM f#g('ܷ@已P{P_MǢUޫʇSy2jJ߮pj~vϩG=&/ϕ}J<>:-yd=|k.«-sYd> ;nspW]{\a:⢻oAdke!]^]CW3DS[_QnFx7~W_G"ۼ<9EA#i"}_-r 巫Wd\Ք]\ S=mM~+b(R x|r>'rc5@`p"߆!^ͤ}d&tclua u4TGsH㐾ޞ$}qgC\TCdަz/MZӼLݯcQ*Ué<?W~5oWz85?W|Tϓ`Mik O3czЊ %bI_FxӽU¢|ܠ爁b9wG27Gķ+h0hќsB +qY(;IDw]ZG]uajdFKxLC~5uoWy*N()}é>z\߉*I?+d?B?/̰KM0CN:'|&_Mz+h x-#9цC5n(J`p{AzV欪DL8x0Cqx2s[?=D:,.[-sTuE巫Wd\Ք]\ S=g~%^3A 2!\ÿzEXk""A; Iȭ!a H|& UHi V a!pFBe6iT/Ҽ/R~5[:TڢQ)#BWO=2O#NGs.3r]tFWTuE巫Wd\Ք]\ S={*A;x a2d^m4'+s߮^U>ʓQsWSvSsŷ+|N+"93Iy5c/C4 S~CzPg^_1} ugN9t*] T>ʓQsWSvSsŷ+|N Þ'u `"HFsbb 1F{4w)H8Rs38LdPtSĹiF/-u )Ԡ{o >낔ӭ?WFWX"T+ҷ+=+]s\(DXpx-oB<(W;> 8n!|dN"v̿q7ݘ,pg\{Cn+͈8ү"LbpĞ9gL~}*_ww֜HPGK},*]彪|8'ҷN߮9 @~}QMB>M.A`VTTϑ3eO/)صrfN3kbY}M\MW0͵7EIQR.xydz`אs2[w,`1Wrpi8S6+x}~5uoWy*N()}é#\ =R)أܣu:㖒/O@xC(a}^'1߮^U>ʓQsWSvSsŷ+|N<+l!~gŵԐ>C>mҘK0#[rIQ_6K ࡫{Cɗo_ܪ *[9J!ƺ&?K{@%sW L0)YU"u=k-}~},߮^U>ʓQsWIoWyQ# .g-FrhN7k%q  ifd%]ʋs|`ߐ],:K&:ǨIGWvSX?@sK=q=4vn&6vw?7^sF~p*-tGTuE巫Wd"s)}éyo'|N<J#N&lr8h?:G(ʟI^GgDDX%G掁_M<|#Jo8>k+ p&shǥ?Y(0IEs۳b=w!@WKUXT~{Up*OFϕ_MەN߮9xCO⍊ _X^P1'ex샣T6hsO{|1x|o.۩)G~&mP۰_1Hx2ӯF};pܟsy<&N}tQ1d\Aǣ)o|ÓI}%n<%Q rs9gwInZzY85WN2薻1z×nWá<1zZ_t]*0³xɑk|3/jc!Wȓ~5۩vʠw8=r3És$?Ԁ;~y\o\X_7Th"S4e])mHW^P`‡xʷIcK-$19=7*gzݳeւyKM9R<{%<Wzfy{ӟ}e[VEгI\(^ĝa(/.ήwЏ__ǜ$ȹyN/r¡Nؾ(JP*sP\Pc%of](INc9Vy27~5۩?ycsɡg#/o<4ۥ rvK.XWsbOo02l=T$[s3V H{H yEp[^KRaO[KBy?$rklrf޹9T\>7yWc 佒G O5>?缝9yx#)|qMRrU[0?s:N*qfПpKN[wu}s[dw#cW[HR4\A9l?uV!L7CJ fxZ^jZ:J[J)W`s2_y,䷓J>y2ӯF};pvϛ#<=׾?-ż/J>- kqc)p? EWgJ׻zC_`!+PM_qy5Ô #C>iTb?./~]< vސS)(3/jc!Wȓ~5۩vWpyls8֓y()ttmPR$+H#eה4ISMSĿT!t%rOTH+ %ZEA'A$CW뎿0W:TT_~qw\okyJ][ZyI2=( )8?g^*ըK&Wȓ~5۩vC۱~HaۣyM1a1ە`O$A( r,23U:A`>0m֪ϫYRĤlNUȇ4fPGr.,c {7)/ҁ$E?g^j<{%<Wz89ogC"aZ^\-[~CR'$eYH~n2T=_` q׫?g^*՘B~;yÑ'C9jԷS9q7#_-/k{(z?vCZoÎ9{8 [C񋚿*t>CԥAOҿ@ wXh%Hxm@]Lbi`U4ô`SgW \/-lq3/jc!Wȓ~5۩v-p"w1LUϭj܈Oս|8~= @ <xCˇq?{kk>7oP.9.-?*+8 N+ϙ|54v^ɇ#OïF};pv1>&Ge#KnRTU?MMp' UL>vu&x~/mCb']Ǯ R>.Jy z5}[[)Z9ܱʅm^a`s2_y,䷓iQN=眷71Z9uo|*tqx %tF0lxIcx$eo$sKgOksE.Іjؖ@Tc^6y2ӯF};pܟsy<"컙K 55W҂} 1bXo'|'9jԷSy3oG/>:j^<{A0u cv999̱F}RSOU$'O_csHJ;N]g/L0)yQM|a7O~5iϙ|5汐N+pNqџ>?=l'?}e?u?k|r-f:AK[TiB9 =oN?|s߂+>rqFw>&,tеuױ﹜.U*|8Gvdqz3]#ϙ|5汐NpNZoǼٟcy0?FA_a?>ʽ ;{\s2_y,䷓J>\C~5۩vϛA]\9կ*`?J]lneӣ_ o#ᇘf: >;1-2ΐ{<\,]3 __6.^AwT8.Dž?KDk sP=`>e3/Z汐N+pNqy{ӟ}?E8C/'| mS aݐ 'p4E2c^ n7Y.+jJ8&s/?̡S 0oNw}mOd[8H^"d9R<{%<W"眷?}>N2ߗjРG>g8wfRR {/B*Q/Kep l?_c1<_qEЁ*CWW`.06x*9]c,ίi|lNm+6j&yWc 佒G QN=眷?}>M}o [KDc2g>B87>縠N{{\r{7;};7!/솾6RGf,ė2P7u[u.ο,J1_y,䷓J>y2ӯF};pܟsy{.d1~~D(`KRL cE/ Nr9Nx1/ Osεa<&ݻgiݍcYw%}cf\4c[{*У&U ߆z>2_y,+pNqџ>[Ћvm@.] eJʃ$/4PI`X$ӵA_% Ե|O!W{Fָ%x:/++!18?Yϙ|&v^ɇ#Osըosٟ>_2ޟJ@頢:~gU'b=|Ӹ|KeXooxÑ'Cz89ogyc^Q:smh s)Js+4NwRrH:\*!^l,EIRБvxNs2_y,䷓J>y2\~5۩vߋy.88ZW_|bq)Wԅc:Þi+'~]>nqtѧ_RgsνVUs0 8k.$GV7ˑq'8= 5-L%W 8)/K_j뒁%kϛT䫱#Wȓ~5۩v~9Ƌ,`^INa7_ХQdo$@N7v.YGARd]~I57>TuDx IyD=Jn0$%sOٯCSk^_@uD?1櫑B~;yÑ'C9jԷS9q7#5,ߖy%ɫ+h)E_@y: yRC=c%Ryҁ.itV}?/=.I1_wIn1~IK/sJG.1x]yꂤ~Y 'ϙ|&v^ɇ#Osըosٟ>oG ~J=st\vvg|9F|$KH抻eJmvh|k~))UA/TW=;[5B3z8 x:XG|H\t _U7q+QAfs2/jc!Wȓ~5۩vr xNP1`n1Ǩ~a Dmu_Us-1ߑ!O:t18O^qHJ Z}Gyݖ+ǜo :5D | ( 7y1v^ɇ#Osըoop؟7vv|ynORW:W.+SKڑRg|RT^-x7_Y9XJrĊЅ.suh{"n.% \j;K}j-{嘟>,nUo?iϙ|+汐N+pNqy;s jB}RI2=ƸӐ͇xpg2"-J6PEfI_^Y :]#+œ{wUuV7KȷtGwA?So? | έGEM|3/jc!Wɓ~5۩vةW7n>u& ~:;CDg?ŸouNFk݇ؗd3лUZf+jܖ5:뎞șN.3d̍ܰbp9?Gȏpctt@F_a?g^*՘ByÑ'C9jnz89og?o|qp=j]O7}O;/q;\$?ĦKP$؛ONQ9uXmtd ;a˴A̍cp2䗶B<ٵ$e|v~1tYRp2[ۍk]Yr{_jR}f&yWc 佒G QN=眷?}<{"YV'xWݥCtA-N%?n!m ù莘t~6H }uXܡriw w-,X|ߓ 8(D~{о{3/jc!Wȓ~5=眷?}?0њǝ9q[-ϵxYa^ZP\~hRB/k .}o->)[j\w7g9zAd\\߹NR|WWkϙ|5汐N+pNsٟ>[/=so+dk#7 k'#a·${!QXCh$nϡ0$Qtwq<\|g<BGLW}ջ3KQ2=_۶Y{y2ӯF};pܟsy<4A4cz? ?.|:: XGw5@.J)#ږUE}l۽s[>WW^-1g27DNJ{]7):Yո*]5NzC4ٟ1/jc!Wȓ~5۩v8*hѷBrڊ?$R%sCaA*vrI>r&}h98#4n{r5z|z\͆ubm㗓hS͊9 wSc{μT1y24~5۩vϛ3xG3KgioM~9rzb}˭^m֐t!u\ ,sGdfL! KDc6=As*ˇϼdN>W|{z=c $ ]?4KeXo':8d?_v?缝9~SAU%8b,B8~ {U5~m!p߂j#T<$o"%-w*{]tT~~m5RK`Xx-BЅOcUq՟87Ŧ+逫?g^*՘B~;yÑ'C9jԷS9q7ϣkˠiAOGr"<*DsHSdy%^ͽqA46 N:0YS"ZiuɄ2]wK6KeXooxÑ'C9jԷS9q[!N>Εü"5n{W  >= F_⾲H尛I-IiU9WQ];2YqR3 dȝI07*QԂmb]'H6 X#nQM9|Wc 佒G QN=g؟>Bᥒ>y:q1tY96_B>eX]%ksOJ0^yRp.vq~jKKZ˞n d> SGd $޿aIU~y[bQ2pn*9rܲaKɃb)."`+%3/j䯒N+pՠosٟ>oO|K]>o!Cޤ h'/cuZxmyշ oNqJ\$^Nr`8CR}nuc'4ҿ"Yyz|iJWKQ`9R<{%<Wz89ogyml &u5MHr.n%½+5 ϓaw!=Ucz||i?YpKܑ`K3;Uh+m5}Az?=tM Jq#}(ޛ0m!yGL}~ڑRYM9R<{%<Wz89ogy=pOYaڼC P$.[˷z y]'= ϡLOq{g`: e +GVZ,#8B6GcMwRL׈0.I ە=?]q/ae9R<{%<Wz89og?D?Pqᵩ8yYapX;r<_ˎoO 9hjp&9.r(ݲ6#7uX_g~~# \{O,r)Bgѱĝ<7s2_y,䷓J>\Ó~F=眷?}޿ߑ<$w/_?|/mx;t(>z# ._uBpj7eII?_U!~Wyי>9{[V[D2Hh S%KRQrp `9R<{%<Wqy;sypn@ 녥C/"nztu][ZqtUS|33>ޤѦ4z1rOb9R<۩[opNZaN9q7c*ȗωV@ot}L잋 >0TOmx%*(}]Rpt:椩VSJR@/㙓LO8~b[>BxMu]cuos[ӹ6|e.%|s5KeZ~;yÑ'C9jԷS9Mny~(GMy~О~{$#{6kbXV[T ՙJ!LRE!oV\YƊ_xEΟx-/>ur3-VsJg)>A8O3x'>=D6v0w?g^*՘B~;y5<QpyߋXƶwȕHvUEM]GY`ޱ櫽CTY^sx<9'ِ6dXeaS IG2u_>R׃#d9*.Qhy} BZҏ[-=k14k޶}\m1"]*,9dLB$buA}rĽo#6[[beZ{s2_y, Wɓ~5۩vϛCD 5)ǑĊM_rSn|ᴾO-4\Kܖec_]q^=G䈎VȿԷỮvU^~tw=O _/ϛT1v^ɇ#Osըosٟ>Km펝3tb k'"?VBOe5.n 0F{҅Tat@]~+w=>7U2NRbBvM*Wv/iLcf\_37${=;0G`^*՘B~;yÑ'CyWz89og/¿=-cW=,9/oW?7$z?=4` ~^x D.) ϸ<XIK-ZNwu8yV[w^,2+2 fƈ9Kwc5?g^*՘B~;yÑ'C9jԷS9q7cDdv0]/L=N7` =.t`#L'~s3wT,IyqS]W,chQٶΑ\QφܸKLos2_y,Mn xÑ'C9jԷS9q]KIU<<5[) Dשi$\b=Q?rf_o&yWkXo|8d?_v?缽>Sx\jqHA?ܰ|"%'ףOz2r<jz?0:଴ЏC`O6SؗK^$b^q.%R&?s2_y,䷓J>y2ӯF};pvI^jF_VciwЉA޺G/O5~c2i ۷vnaŦ ŷd{QU!x?capcGC8gK0R[jas2_y,䷓J>y2ӯF};pܟsyD[:ZKBn2~RM9R|5o'|8dѯF};pܟsy<>ay.і0?u~{P-o==G$rSVZ^+8 |s~p(u*k>5߮C`/Ck0?~H~zO j&)j`jϙ|5汐N+pNqy;s~yrQGLgn1`TxNa~iCH!]5*kXg;:vH\P0(I S9CFU˸1yi\~0MRc&Vw.{EAig]/! ?i>1 _y,7Wȓ~5۩vɹ6H¯JïeTdz//Eώyб%ƴRx;._V}&a’H[/>º ({a1ѫR0V{f} +@çs2_y,䷓J>\ÓAN=眷?}ޟmUio%S,os ^12~48u4RQ*~weЧ~v{Wc*~ ׭ύMQܦAn~-C^OP/vC]c:"R͞6}nnC;O?g^j<&pNqy;snXK,K ^_tL4te:[2Ť\K?K2_Ё BͽNND8Zf%-Do(>!-mbz}~:m]/vR`9XHs د1yWkXo'|8d?_v?oԷN뵣 Iqo3kݬݸccoŐ@ߓ * .* 8u&2:=O0sfV$1sχ%g~)t)%t7ӯCXs2_y,䷓?Nqy;sz n|"2AGq*O `Ѕ$ C{)!Ł1.g}qq*{!sR o -eƊVg!7+n͸ϚsΘ<{%<Wz89ogyPיX'`J5IK=#)q? Ǧ2>O\׽۾`jA-؟ho9S܈g*xQ샻zv;{UR4}?M9R<{%<Wz89ogy;OMe@bݟ\`cI <{⴯J0dL=rpژgC]a !Rlo9|(>~Y2p"L #>&o=+8K}Ζbm|˩[s2_y,䷓J>y2ӯF};pܟsv? M]OE^_<5y(3KzG%^TכaSx6V&^cexG)i^̭M1+]rU읦YDR9eur#am}Q?^׈4KeXo'|8d?_v?缝9_hsJsZLRT)/0Q'B畩,~%Վdz~n4~m'N?6"18BQK._BlJEz>zagō'_5Qs2_zL{%<Wz8ϛy;sϛц2)_hAVߡ,_AV$n{_:sЁx+3NvlkIS$ 1bNob>6}Af8_](?ZEKn3ms㙶SaT3/WCKo|8d[_v?缝9}]i {7T çҲiAoku]mЙL_ O%+Mוt0dTrk65nC cDƇː> |kkZɺ#@Q.3Jy3/jc!Wȓ~5۩v/1-Qw'wc,׈mrcޖSf/%^+ [mG.#.w0ʡ+0W ϷX]Gͷa }z/|$+"OyX3/jc!Wȓ~5۩v?qsSCK ]lt38Dž]~=twQesS@ %|8= /،%N2p,O=D'k$?'&/jc!ὒ QN=眷?}<&U+5B:F [Ht'NQM xZ@|t>' *1@8՞qD{ a]=AUƺy~>>.80 0g?G^*9c!Wȓ~5۩k瘷?}?oS/^c0a H MoaO,riǻ]jz{Ts`iéˤ1Ш bBn#y.i_n3 L~9ϙ|5o'|8d?ojзS9MnQ<:ػpӶezdũC qpepNToY]xoHJ<ߑWkRLG< zsJFE$AOKVʒ+pO1`9R<{%<Wz89ogzD( BC~\&2?l$yDPX:r̡WL%80U~sBP0Xu SǁZU__=3/jN+pNqy;s&B˹H /b/2ao=|cuf(J>jvCUJ{?@=kM7P-w=>%P0TOǽ sOiϙ|5汐N+p Osըosٟ>?j/t?]5Ʃ.[^ kV&],q1,*t2`cL(pMԖ|%D#t+t8[ό1Z Jk&1᷃J>y2ӯF};pܟsyŹ-rВUŻ\s/8>wwl#ћ6#/anSL_2%ɿe>n_@#̐#(ߦ{>-C(ųxJȒk羓r>I諒.$Ky,䷓J>y2ӯF};pܟsy>=x++HVM $ES1gVKiˁLyic?Q{!ӉI Ԧn)C`N!_8q#.f p0C6|\%1xvŅ#WiD|VZs2_y,䷓J>y2ӯF};pܟsykE~֘\d?Vn&Kn=;M*}xO$n~aJN$z0wO:<яMSѩ2Rs>'m7_t!!V8d=c?[ʗH5`]ܥp9(v9pH/ @0Ksjݰx~,?Ѻ?g^*՘B~;yÑ'C9jԷS9qϯ'PrƳ2rc8Α̛uhpL?|%MUg: C=ZMb#upçӿiYg\'9Vc}[h8Ȼ؋CoR(ODN7ϙ|5汐N+p Osըosٟ>/h)_O0N졓#RivN?l}YyI>uV$AnȞjȐOdP/ IW͹sտ?5oڪ]Wȍ/؃ ?HW1Ȍ%MpPnd*9q"LܞKeXo'|8d?_v?缝9y"m%Cl6ƤgnP9SẈ*e/On^pO<>/m(lS߫wBG3\D"pbga1&yWkrNo'|8d?_v?缝9y3 sw|#ΠQ-?}rq:JmpRǸ@KsK T^OceCzOww^v X[<lh%]4KeXo'|8rA?_v?oq+ӡvOh1I!ggztw?HSRs*$gokA${bAG+fPq+\qԸSi^F1}9@9xkn8<#H1+=txѶjϙ|&v^>>ӯF};pܟ7v}s2~8rw-+s&77l(}])ײ9 i-cI)ƛ~S'y;IwHaR.]2 ԁUX%E^V3,oo]5,X;0yWc 佒G QN=眷?}?+(m*RT~q=?X۴S^i|"`vTv؃OO0L2$y|*E-X3;?*,1tWyRFLYlj}xny%)MXκq_QZNG{Z|ߏ>};/+J2P7'/|cl.R34 f$&wwlW#[{]U?wE令 8e$^KeXo'Á'CyWz89og?W†2wk]ExtEPS|)Fπ>d5=%RA3T*!j)^g4> ]H\y mB])F_[[[^J<7nSD_9?g^*՘B~;y $Wzfy;sy#om'c>cktq 3uμTQM~;yÑ'C9jԷS9qm)~_}6F,BƆ_ߩNhO M mT$xOR%<8&^Eb3S/q|INV' &yWc 佒G_>_ s 8_缝9~=~'"oekt-heJT7 =i(?n(8@]f@g AqG-y? w涹ӱb5Wh@t_ Y=ϙ|5汐N+pNqy;sHp_ǀ܂=4Lj]<}Wo4'e?(oxKWKAX QIM?tG9lN/nݱ-:(qμT1v^ɇ#Osըosٟ>oG|X~Ka;TK_׉]/+i,'{69ԩV#9TmJz1MGްO0_rͱmK0XFJHv6Yv Lŝb(G9 ؃iZ&-䟓;|5汐N+pNqy;?T6Gq?ztGdp$`ޱ}YswT}]7Yp.ǙoaR῰ r ]K|+U gx}Yle.)KeXooxÑ'C9jԷS9q;ެ_=ΧVcw ='ggw7?79$A~u%$ |1p>I0˸_-w x(9U]WD'GIkL2NH;ϙ|5;"|8?_vxsy9U>:xg9 Þ-n~GOHW t=uQ/Ӟ|DrCu9+kc%ݙk3$e]xi] O D[휿.L}Dܹap< W &yWc 佒G 5v?缽>o0meF=8GnHm9+KKeu6-Ϧ{B_]>E"3!zm[w2v}Bn"~9g(>7nT]i QK[s?!.$ӴB"?g^*՘B~;yÑ'C9jԷS:vC_9& 숓_[$IB(hiaA_W~mh>Svs3R:Qfg/8{{;T^D3zh}c sߞi|4]G9N|˻p)H*}z[*P]Ke䷓~5۩v- *pp{Wi!$ rO'iK:Z{[һ,u˕gW҃^t&CU5nt]GN ”UN qe(n];.zAy^ۈ:g&I:KE[HA}[VBc14{Klk}b$7c-wb=:GBUs2_y, WȓaEqy;s/҆A"oR[,/c-mYDt1$)}tF@{7YQGu` !M!G3揔\KYS䧴5d7Gm`\-1?g^*՘B~;yÑ'C9j ?z89ogyCOZѯȥqR )X\ >V'C$O=luQIspWնTN-k9: 7_Q|5TYRu}q[ΫC~觘μT1v^ɇ#Osըosٟ>ﳐ'e!b\b̅x~|D]%GşG )[{S}\>#ݶݷ]ظ%yzп-7.[V_d̩μTBN;yÑ'C9jԷS9q7ϣ*\q7#-hD [Dc+nhѧ%ѵ6=^ȟz<$CK]:2n +}E}eP}ݘIzbv9 Ivί_?ѐμT1v^ɇ#Osըosٟ>o 2rc& Njͽ?2vNfNE_rsq"kA`unöYv x)aXܘϗûGBYtCN|5汐N+pNZ㳄sٟ>`yZ2p?rna/g odrIz֪KqX +ns^w]&1c\juzs'QtmNC eŽnz~hovrt~0xw&^KWZnO5[m/ӡJ_TÛíB @9rɼW֔!lR^b~OW8S ցZ(xqmϑG QN=眷?}_aO ?<٥ᾏx7c0 J}}O|=Yb=;N7})@'mRCuugJ=|:^4KeXo'|8d?_v?缝9~1FnXN :V߫|ɑbtvzK|(<`~HQwЧS=t#0O602)?%\i}Ѥ9H_On T;x AQwp ~$\JtS Ue\21v^ɇ#Osըosٟ>@|׫m_IJ_p8b m9so_.4E'YݛC.^8QIïojpo,/y2ӯF};psȘs&w$g{;b F-d+ݷŃT0UPȥO /x5U{٥!#":CO|JmJϙ|5汐N+pNq9 sy 򊪵zz+؜7>p|=GWc%d{xJN-_` cӵ 9L4Ym>}+quuS$G_VPҗT/2ߝ_z\?g^*՘B~;yÑ'C9jԷS9Mny<һh(Ek}h@duClgll?R;8yH*f' (SaLZyB|pw=$&#){K9#S,Gb:"ȑ3#Pa_f!A eVA^tNU̥kZq2rݯ]+՘B~;yÑ'C9jԷS9qw|9f =9J^\[h7ɰw*xJ2R])wc./Dd0:1l˭xyd.ߤEcvx_)|w{/Uf?/O5pjGμT1v^ɇ#Osըosٟ>/pO>#u[R§}q7%).H \|'':XOr>^J,'#eQ|?;.,ckjGݨ~Bz¯Io2?羟jc!Wȓ~5۩k眷?}S_J׎υa}qmo;s7O5$ z }/5n_uGb+IݖqVySʽHW KAFC'M.[@ݒG}s2_y,䷓{G>y2ӯF};pܟsyނ0vfϋUx3R3ſZ}gQgWwHKqN>H^9Xce%87 ޑyڟa>1!בTuK_YI>| =:yFOUAMᑯ<{%Nqy;sy#Ӱ?H+c%oWlqp^#0u'w3oܩt]dv#dh%jXrk/MS~qnMJ<ưYY_V.^ ӯK%ָ$ s2_y,䷓J>y2ӯF};pܟs% ˤ?3=o|S9Η6(@"̇@<[/:1wra~MNV~@}os'MgQH~uk'.vMu= ~?:{sCK_׷A6-oϑ|&+yÑ'C9jԷS9q7ǁLX§^MX9:4@sЎ.A'N+EtTVxD^zRHz/%"[A4?;ݙ̗R!'2k{OUXP\J1ϙ䫡&:,ȓAN=\?Ǽ>oG>cG([8cmO݂<5})ۯWY?SAVR[kcS艓 ۺc/Ӂy\m{#!m!> qBcunNecs2_y,䷓J>y2)۩vot'KJjdZ4T9[z;S)JCt%R /fN x"e_7v:"-"YXǎ ?L}WiV +w)sd޻w)?сCs2_y,䷓J>y2ӯF}{cy;sO}|Հk@X[fvE. Ct9ўpwsbgaCWOor}BG+ t$`(s9X>AS@W%< @4K*[԰'3/jc!Wȓ~5۩vϛ1 C ʚ{re%ߣ G-?b&TQMMR3ٗ>aZ߷V803?o}Wb>Q'M 9tԋ*VU~%+ \ Q]e]$'vOZVQ:nwcu2#p/VX6sSp?9RF?SpNOՈowx89og|Edct4ߴz.I}jyLـKnVֻ}V1C:>KX;I_XH [С;$Ǿ+,oiS0go4ki^-~KXNW9=W#x8?Gf|,@8_ƌ ҷCRF3>gb -'\ezX 5d&%eя%_z%,Y[5%y긧ʿ>}s?K;7 bGL :)=D5Pzԇ N<眷?G>z i=˿mCU3DI9t2GR2C{tՕl`Sk vۀo}i ًMv4JB5;k/Kl`~Y*Levh^'!pcXSs8s_~,o+'C9jߎ9[5seYo6r6ɿt|y}La"JQЯ ?h*ڸ'N_، sٽK{Z\W5}7 ";ϡnM_8+'As_~,o+'C9jġ9ϑaSK5гSF  x1qF~PϤ2ZRC7 B2Z,|‹UFBx9a#p0?")+jַZ9gmbO8b/#fMYbr/jc~;^G=W#x8ݼ9> LԽ@ ~Ty,{H"#]Ƃ&3zmkՠe/Iz~XS/ؾq~@|s#5rx ~3䵍`?HէɆ14Wiw+^"9RF?Spԓ!|5ۉv~lʐ%~[[){$g~ļجDi(".fI|W>gl$Ğ*-;${07>yloan$W/ݮL?GD5Pzԇ 9?y?w6ϑMX>aDUO1'͡ЄCb.9ݩ83yBZ^Z֫}0r?Z6 ]Ь)nQ aYY#(#ЋT3B$?Z=2l12t w*c~W ۩J}8ɐNqy;ss|_azf%aiCN9s6p:uK %ERwj?X =~ IWl_M+<s~)1=wL vQ4Zp=,urNTя{>d?'_v?wzl5]{5L2O?6w^he;*Tuwueܝ4N^c㏽hhhhhV*>ZGhU|V*>ZGhUU}VѪ>ZGh=K/s<ѿw_xS Muް.lsM1999u^ 'ape/R/0000755000175100001440000000000013017516351011240 5ustar hornikusersape/R/plot.phylo.R0000644000175100001440000007517112735425636013521 0ustar hornikusers## plot.phylo.R (2016-07-01) ## Plot Phylogenies ## Copyright 2002-2016 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. plot.phylo <- function(x, type = "phylogram", use.edge.length = TRUE, node.pos = NULL, show.tip.label = TRUE, show.node.label = FALSE, edge.color = "black", edge.width = 1, edge.lty = 1, font = 3, cex = par("cex"), adj = NULL, srt = 0, no.margin = FALSE, root.edge = FALSE, label.offset = 0, underscore = FALSE, x.lim = NULL, y.lim = NULL, direction = "rightwards", lab4ut = NULL, tip.color = "black", plot = TRUE, rotate.tree = 0, open.angle = 0, node.depth = 1, align.tip.label = FALSE, ...) { Ntip <- length(x$tip.label) if (Ntip < 2) { warning("found less than 2 tips in the tree") return(NULL) } if (any(tabulate(x$edge[, 1]) == 1)) stop("there are single (non-splitting) nodes in your tree; you may need to use collapse.singles()") .nodeHeight <- function(Ntip, Nnode, edge, Nedge, yy) .C(node_height, as.integer(Ntip), as.integer(Nnode), as.integer(edge[, 1]), as.integer(edge[, 2]), as.integer(Nedge), as.double(yy))[[6]] .nodeDepth <- function(Ntip, Nnode, edge, Nedge, node.depth) .C(node_depth, as.integer(Ntip), as.integer(Nnode), as.integer(edge[, 1]), as.integer(edge[, 2]), as.integer(Nedge), double(Ntip + Nnode), as.integer(node.depth))[[6]] .nodeDepthEdgelength <- function(Ntip, Nnode, edge, Nedge, edge.length) .C(node_depth_edgelength, as.integer(Ntip), as.integer(Nnode), as.integer(edge[, 1]), as.integer(edge[, 2]), as.integer(Nedge), as.double(edge.length), double(Ntip + Nnode))[[7]] Nedge <- dim(x$edge)[1] Nnode <- x$Nnode if (any(x$edge < 1) || any(x$edge > Ntip + Nnode)) stop("tree badly conformed; cannot plot. Check the edge matrix.") ROOT <- Ntip + 1 type <- match.arg(type, c("phylogram", "cladogram", "fan", "unrooted", "radial")) direction <- match.arg(direction, c("rightwards", "leftwards", "upwards", "downwards")) if (is.null(x$edge.length)) { use.edge.length <- FALSE } else { if (use.edge.length && type != "radial") { tmp <- sum(is.na(x$edge.length)) if (tmp) { warning(paste(tmp, "branch length(s) NA(s): branch lengths ignored in the plot")) use.edge.length <- FALSE } } } if (is.numeric(align.tip.label)) { align.tip.label.lty <- align.tip.label align.tip.label <- TRUE } else { # assumes is.logical(align.tip.labels) == TRUE if (align.tip.label) align.tip.label.lty <- 3 } if (align.tip.label) { if (type %in% c("unrooted", "radial") || !use.edge.length || is.ultrametric(x)) align.tip.label <- FALSE } ## the order of the last two conditions is important: if (type %in% c("unrooted", "radial") || !use.edge.length || is.null(x$root.edge) || !x$root.edge) root.edge <- FALSE phyloORclado <- type %in% c("phylogram", "cladogram") horizontal <- direction %in% c("rightwards", "leftwards") xe <- x$edge # to save if (phyloORclado) { ## we first compute the y-coordinates of the tips. phyOrder <- attr(x, "order") ## make sure the tree is in cladewise order: if (is.null(phyOrder) || phyOrder != "cladewise") { x <- reorder(x) # fix from Klaus Schliep (2007-06-16) if (!identical(x$edge, xe)) { ## modified from Li-San Wang's fix (2007-01-23): ereorder <- match(x$edge[, 2], xe[, 2]) if (length(edge.color) > 1) { edge.color <- rep(edge.color, length.out = Nedge) edge.color <- edge.color[ereorder] } if (length(edge.width) > 1) { edge.width <- rep(edge.width, length.out = Nedge) edge.width <- edge.width[ereorder] } if (length(edge.lty) > 1) { edge.lty <- rep(edge.lty, length.out = Nedge) edge.lty <- edge.lty[ereorder] } } } ### By contrats to ape (< 2.4), the arguments edge.color, etc., are ### not elongated before being passed to segments(), except if needed ### to be reordered yy <- numeric(Ntip + Nnode) TIPS <- x$edge[x$edge[, 2] <= Ntip, 2] yy[TIPS] <- 1:Ntip } ## 'z' is the tree in postorder order used in calls to .C z <- reorder(x, order = "postorder") if (phyloORclado) { if (is.null(node.pos)) node.pos <- if (type == "cladogram" && !use.edge.length) 2 else 1 if (node.pos == 1) yy <- .nodeHeight(Ntip, Nnode, z$edge, Nedge, yy) else { ## node_height_clado requires the number of descendants ## for each node, so we compute `xx' at the same time ans <- .C(node_height_clado, as.integer(Ntip), as.integer(Nnode), as.integer(z$edge[, 1]), as.integer(z$edge[, 2]), as.integer(Nedge), double(Ntip + Nnode), as.double(yy)) xx <- ans[[6]] - 1 yy <- ans[[7]] } if (!use.edge.length) { if (node.pos != 2) xx <- .nodeDepth(Ntip, Nnode, z$edge, Nedge, node.depth) - 1 xx <- max(xx) - xx } else { xx <- .nodeDepthEdgelength(Ntip, Nnode, z$edge, Nedge, z$edge.length) } } else { twopi <- 2 * pi rotate.tree <- twopi * rotate.tree/360 if (type != "unrooted") { # for "fan" and "radial" trees (open.angle) ## if the tips are not in the same order in tip.label ## and in edge[, 2], we must reorder the angles: we ## use `xx' to store temporarily the angles TIPS <- x$edge[which(x$edge[, 2] <= Ntip), 2] xx <- seq(0, twopi * (1 - 1/Ntip) - twopi * open.angle/360, length.out = Ntip) theta <- double(Ntip) theta[TIPS] <- xx theta <- c(theta, numeric(Nnode)) } switch(type, "fan" = { theta <- .nodeHeight(Ntip, Nnode, z$edge, Nedge, theta) if (use.edge.length) { r <- .nodeDepthEdgelength(Ntip, Nnode, z$edge, Nedge, z$edge.length) } else { r <- .nodeDepth(Ntip, Nnode, z$edge, Nedge, node.depth) r <- 1/r } theta <- theta + rotate.tree if (root.edge) r <- r + x$root.edge xx <- r * cos(theta) yy <- r * sin(theta) }, "unrooted" = { nb.sp <- .nodeDepth(Ntip, Nnode, z$edge, Nedge, node.depth) XY <- if (use.edge.length) unrooted.xy(Ntip, Nnode, z$edge, z$edge.length, nb.sp, rotate.tree) else unrooted.xy(Ntip, Nnode, z$edge, rep(1, Nedge), nb.sp, rotate.tree) ## rescale so that we have only positive values xx <- XY$M[, 1] - min(XY$M[, 1]) yy <- XY$M[, 2] - min(XY$M[, 2]) }, "radial" = { r <- .nodeDepth(Ntip, Nnode, z$edge, Nedge, node.depth) r[r == 1] <- 0 r <- 1 - r/Ntip theta <- .nodeHeight(Ntip, Nnode, z$edge, Nedge, theta) + rotate.tree xx <- r * cos(theta) yy <- r * sin(theta) }) } if (phyloORclado) { if (!horizontal) { tmp <- yy yy <- xx xx <- tmp - min(tmp) + 1 } if (root.edge) { if (direction == "rightwards") xx <- xx + x$root.edge if (direction == "upwards") yy <- yy + x$root.edge } } if (no.margin) par(mai = rep(0, 4)) if (show.tip.label) nchar.tip.label <- nchar(x$tip.label) max.yy <- max(yy) if (is.null(x.lim)) { if (phyloORclado) { if (horizontal) { x.lim <- c(0, NA) pin1 <- par("pin")[1] # width of the device in inches strWi <- strwidth(x$tip.label, "inches", cex = cex) # id. for the tip labels ## 1.04 comes from that we are using a regular axis system ## with 4% on both sides of the range of x: xx.tips <- xx[1:Ntip] * 1.04 ## 'alp' is the conversion coefficient from ## user coordinates to inches: alp <- try(uniroot(function(a) max(a*xx.tips + strWi) - pin1, c(0, 1e6))$root, silent = TRUE) ## if the above fails, give 1/3 of the plot for the tip labels: if (is.character(alp)) { tmp <- max(xx.tips) if (show.tip.label) tmp <- tmp * 1.5 # fix by Liam Revell (2015-06-22) } else { tmp <- if (show.tip.label) max(xx.tips + strWi/alp) else max(xx.tips) } if (show.tip.label) tmp <- tmp + label.offset x.lim[2] <- tmp } else x.lim <- c(1, Ntip) } else switch(type, "fan" = { if (show.tip.label) { offset <- max(nchar.tip.label * 0.018 * max.yy * cex) x.lim <- range(xx) + c(-offset, offset) } else x.lim <- range(xx) }, "unrooted" = { if (show.tip.label) { offset <- max(nchar.tip.label * 0.018 * max.yy * cex) x.lim <- c(0 - offset, max(xx) + offset) } else x.lim <- c(0, max(xx)) }, "radial" = { if (show.tip.label) { offset <- max(nchar.tip.label * 0.03 * cex) x.lim <- c(-1 - offset, 1 + offset) } else x.lim <- c(-1, 1) }) } else if (length(x.lim) == 1) { x.lim <- c(0, x.lim) if (phyloORclado && !horizontal) x.lim[1] <- 1 if (type %in% c("fan", "unrooted") && show.tip.label) x.lim[1] <- -max(nchar.tip.label * 0.018 * max.yy * cex) if (type == "radial") x.lim[1] <- if (show.tip.label) -1 - max(nchar.tip.label * 0.03 * cex) else -1 } ## mirror the xx: if (phyloORclado && direction == "leftwards") xx <- x.lim[2] - xx if (is.null(y.lim)) { if (phyloORclado) { if (horizontal) y.lim <- c(1, Ntip) else { y.lim <- c(0, NA) pin2 <- par("pin")[2] # height of the device in inches strWi <- strwidth(x$tip.label, "inches", cex = cex) ## 1.04 comes from that we are using a regular axis system ## with 4% on both sides of the range of x: yy.tips <- yy[1:Ntip] * 1.04 ## 'alp' is the conversion coefficient from ## user coordinates to inches: alp <- try(uniroot(function(a) max(a*yy.tips + strWi) - pin2, c(0, 1e6))$root, silent = TRUE) ## if the above fails, give 1/3 of the device for the tip labels: if (is.character(alp)) { tmp <- max(yy.tips) if (show.tip.label) tmp <- tmp * 1.5 } else { tmp <- if (show.tip.label) max(yy.tips + strWi/alp) else max(yy.tips) } if (show.tip.label) tmp <- tmp + label.offset y.lim[2] <- tmp } } else switch(type, "fan" = { if (show.tip.label) { offset <- max(nchar.tip.label * 0.018 * max.yy * cex) y.lim <- c(min(yy) - offset, max.yy + offset) } else y.lim <- c(min(yy), max.yy) }, "unrooted" = { if (show.tip.label) { offset <- max(nchar.tip.label * 0.018 * max.yy * cex) y.lim <- c(0 - offset, max.yy + offset) } else y.lim <- c(0, max.yy) }, "radial" = { if (show.tip.label) { offset <- max(nchar.tip.label * 0.03 * cex) y.lim <- c(-1 - offset, 1 + offset) } else y.lim <- c(-1, 1) }) } else if (length(y.lim) == 1) { y.lim <- c(0, y.lim) if (phyloORclado && horizontal) y.lim[1] <- 1 if (type %in% c("fan", "unrooted") && show.tip.label) y.lim[1] <- -max(nchar.tip.label * 0.018 * max.yy * cex) if (type == "radial") y.lim[1] <- if (show.tip.label) -1 - max(nchar.tip.label * 0.018 * max.yy * cex) else -1 } ## mirror the yy: if (phyloORclado && direction == "downwards") yy <- y.lim[2] - yy # fix by Klaus if (phyloORclado && root.edge) { if (direction == "leftwards") x.lim[2] <- x.lim[2] + x$root.edge if (direction == "downwards") y.lim[2] <- y.lim[2] + x$root.edge } asp <- if (type %in% c("fan", "radial", "unrooted")) 1 else NA # fixes by Klaus Schliep (2008-03-28 and 2010-08-12) plot.default(0, type = "n", xlim = x.lim, ylim = y.lim, xlab = "", ylab = "", axes = FALSE, asp = asp, ...) if (plot) { if (is.null(adj)) adj <- if (phyloORclado && direction == "leftwards") 1 else 0 if (phyloORclado && show.tip.label) { MAXSTRING <- max(strwidth(x$tip.label, cex = cex)) loy <- 0 if (direction == "rightwards") { lox <- label.offset + MAXSTRING * 1.05 * adj } if (direction == "leftwards") { lox <- -label.offset - MAXSTRING * 1.05 * (1 - adj) ##xx <- xx + MAXSTRING } if (!horizontal) { psr <- par("usr") MAXSTRING <- MAXSTRING * 1.09 * (psr[4] - psr[3])/(psr[2] - psr[1]) loy <- label.offset + MAXSTRING * 1.05 * adj lox <- 0 srt <- 90 + srt if (direction == "downwards") { loy <- -loy ##yy <- yy + MAXSTRING srt <- 180 + srt } } } if (type == "phylogram") { phylogram.plot(x$edge, Ntip, Nnode, xx, yy, horizontal, edge.color, edge.width, edge.lty) } else { if (type == "fan") { ereorder <- match(z$edge[, 2], x$edge[, 2]) if (length(edge.color) > 1) { edge.color <- rep(edge.color, length.out = Nedge) edge.color <- edge.color[ereorder] } if (length(edge.width) > 1) { edge.width <- rep(edge.width, length.out = Nedge) edge.width <- edge.width[ereorder] } if (length(edge.lty) > 1) { edge.lty <- rep(edge.lty, length.out = Nedge) edge.lty <- edge.lty[ereorder] } circular.plot(z$edge, Ntip, Nnode, xx, yy, theta, r, edge.color, edge.width, edge.lty) } else cladogram.plot(x$edge, xx, yy, edge.color, edge.width, edge.lty) } if (root.edge) { rootcol <- if (length(edge.color) == 1) edge.color else "black" rootw <- if (length(edge.width) == 1) edge.width else 1 rootlty <- if (length(edge.lty) == 1) edge.lty else 1 if (type == "fan") { tmp <- polar2rect(x$root.edge, theta[ROOT]) segments(0, 0, tmp$x, tmp$y, col = rootcol, lwd = rootw, lty = rootlty) } else { switch(direction, "rightwards" = segments(0, yy[ROOT], x$root.edge, yy[ROOT], col = rootcol, lwd = rootw, lty = rootlty), "leftwards" = segments(xx[ROOT], yy[ROOT], xx[ROOT] + x$root.edge, yy[ROOT], col = rootcol, lwd = rootw, lty = rootlty), "upwards" = segments(xx[ROOT], 0, xx[ROOT], x$root.edge, col = rootcol, lwd = rootw, lty = rootlty), "downwards" = segments(xx[ROOT], yy[ROOT], xx[ROOT], yy[ROOT] + x$root.edge, col = rootcol, lwd = rootw, lty = rootlty)) } } if (show.tip.label) { if (is.expression(x$tip.label)) underscore <- TRUE if (!underscore) x$tip.label <- gsub("_", " ", x$tip.label) if (phyloORclado) { if (align.tip.label) { xx.tmp <- switch(direction, "rightwards" = max(xx[1:Ntip]), "leftwards" = min(xx[1:Ntip]), "upwards" = xx[1:Ntip], "downwards" = xx[1:Ntip]) yy.tmp <- switch(direction, "rightwards" = yy[1:Ntip], "leftwards" = yy[1:Ntip], "upwards" = max(yy[1:Ntip]), "downwards" = min(yy[1:Ntip])) segments(xx[1:Ntip], yy[1:Ntip], xx.tmp, yy.tmp, lty = align.tip.label.lty) } else { xx.tmp <- xx[1:Ntip] yy.tmp <- yy[1:Ntip] } text(xx.tmp + lox, yy.tmp + loy, x$tip.label, adj = adj, font = font, srt = srt, cex = cex, col = tip.color) } else { angle <- if (type == "unrooted") XY$axe else atan2(yy[1:Ntip], xx[1:Ntip]) # in radians lab4ut <- if (is.null(lab4ut)) { if (type == "unrooted") "horizontal" else "axial" } else match.arg(lab4ut, c("horizontal", "axial")) xx.tips <- xx[1:Ntip] yy.tips <- yy[1:Ntip] if (label.offset) { xx.tips <- xx.tips + label.offset * cos(angle) yy.tips <- yy.tips + label.offset * sin(angle) } if (lab4ut == "horizontal") { y.adj <- x.adj <- numeric(Ntip) sel <- abs(angle) > 0.75 * pi x.adj[sel] <- -strwidth(x$tip.label)[sel] * 1.05 sel <- abs(angle) > pi/4 & abs(angle) < 0.75 * pi x.adj[sel] <- -strwidth(x$tip.label)[sel] * (2 * abs(angle)[sel] / pi - 0.5) sel <- angle > pi / 4 & angle < 0.75 * pi y.adj[sel] <- strheight(x$tip.label)[sel] / 2 sel <- angle < -pi / 4 & angle > -0.75 * pi y.adj[sel] <- -strheight(x$tip.label)[sel] * 0.75 text(xx.tips + x.adj * cex, yy.tips + y.adj * cex, x$tip.label, adj = c(adj, 0), font = font, srt = srt, cex = cex, col = tip.color) } else { # if lab4ut == "axial" if (align.tip.label) { POL <- rect2polar(xx.tips, yy.tips) POL$r[] <- max(POL$r) REC <- polar2rect(POL$r, POL$angle) xx.tips <- REC$x yy.tips <- REC$y segments(xx[1:Ntip], yy[1:Ntip], xx.tips, yy.tips, lty = align.tip.label.lty) } if (type == "unrooted") { adj <- abs(angle) > pi/2 angle <- angle * 180/pi # switch to degrees angle[adj] <- angle[adj] - 180 adj <- as.numeric(adj) } else { s <- xx.tips < 0 angle <- angle * 180/pi angle[s] <- angle[s] + 180 adj <- as.numeric(s) } ## `srt' takes only a single value, so can't vectorize this: ## (and need to 'elongate' these vectors:) font <- rep(font, length.out = Ntip) tip.color <- rep(tip.color, length.out = Ntip) cex <- rep(cex, length.out = Ntip) for (i in 1:Ntip) text(xx.tips[i], yy.tips[i], x$tip.label[i], font = font[i], cex = cex[i], srt = angle[i], adj = adj[i], col = tip.color[i]) } } } if (show.node.label) text(xx[ROOT:length(xx)] + label.offset, yy[ROOT:length(yy)], x$node.label, adj = adj, font = font, srt = srt, cex = cex) } L <- list(type = type, use.edge.length = use.edge.length, node.pos = node.pos, node.depth = node.depth, show.tip.label = show.tip.label, show.node.label = show.node.label, font = font, cex = cex, adj = adj, srt = srt, no.margin = no.margin, label.offset = label.offset, x.lim = x.lim, y.lim = y.lim, direction = direction, tip.color = tip.color, Ntip = Ntip, Nnode = Nnode, root.time = x$root.time, align.tip.label = align.tip.label) assign("last_plot.phylo", c(L, list(edge = xe, xx = xx, yy = yy)), envir = .PlotPhyloEnv) invisible(L) } phylogram.plot <- function(edge, Ntip, Nnode, xx, yy, horizontal, edge.color, edge.width, edge.lty) { nodes <- (Ntip + 1):(Ntip + Nnode) if (!horizontal) { tmp <- yy yy <- xx xx <- tmp } ## un trait vertical a chaque noeud... x0v <- xx[nodes] y0v <- y1v <- numeric(Nnode) ## store the index of each node in the 1st column of edge: NodeInEdge1 <- vector("list", Nnode) e1 <- edge[, 1] for (i in seq_along(e1)) { j <- e1[i] - Ntip NodeInEdge1[[j]] <- c(NodeInEdge1[[j]], i) } for (i in 1:Nnode) { j <- NodeInEdge1[[i]] tmp <- range(yy[edge[j, 2]]) y0v[i] <- tmp[1] y1v[i] <- tmp[2] } ## ... et un trait horizontal partant de chaque tip et chaque noeud ## vers la racine x0h <- xx[edge[, 1]] x1h <- xx[edge[, 2]] y0h <- yy[edge[, 2]] nc <- length(edge.color) nw <- length(edge.width) nl <- length(edge.lty) if (nc + nw + nl == 3) { color.v <- edge.color width.v <- edge.width lty.v <- edge.lty } else { Nedge <- dim(edge)[1] edge.color <- rep(edge.color, length.out = Nedge) edge.width <- rep(edge.width, length.out = Nedge) edge.lty <- rep(edge.lty, length.out = Nedge) DF <- data.frame(edge.color, edge.width, edge.lty, stringsAsFactors = FALSE) color.v <- rep("black", Nnode) width.v <- rep(1, Nnode) lty.v <- rep(1, Nnode) for (i in 1:Nnode) { br <- NodeInEdge1[[i]] if (length(br) > 2) { x <- unique(DF[br, 1]) if (length(x) == 1) color.v[i] <- x x <- unique(DF[br, 2]) if (length(x) == 1) width.v[i] <- x x <- unique(DF[br, 3]) if (length(x) == 1) lty.v[i] <- x } else { A <- br[1] B <- br[2] if (any(DF[A, ] != DF[B, ])) { color.v[i] <- edge.color[B] width.v[i] <- edge.width[B] lty.v[i] <- edge.lty[B] ## add a new line: y0v <- c(y0v, y0v[i]) y1v <- c(y1v, yy[i + Ntip]) x0v <- c(x0v, x0v[i]) color.v <- c(color.v, edge.color[A]) width.v <- c(width.v, edge.width[A]) lty.v <- c(lty.v, edge.lty[A]) ## shorten the line: y0v[i] <- yy[i + Ntip] } else { color.v[i] <- edge.color[A] width.v[i] <- edge.width[A] lty.v[i] <- edge.lty[A] } } } } if (horizontal) { segments(x0h, y0h, x1h, y0h, col = edge.color, lwd = edge.width, lty = edge.lty) # draws horizontal lines segments(x0v, y0v, x0v, y1v, col = color.v, lwd = width.v, lty = lty.v) # draws vertical lines } else { segments(y0h, x0h, y0h, x1h, col = edge.color, lwd = edge.width, lty = edge.lty) # draws vertical lines segments(y0v, x0v, y1v, x0v, col = color.v, lwd = width.v, lty = lty.v) # draws horizontal lines } } cladogram.plot <- function(edge, xx, yy, edge.color, edge.width, edge.lty) segments(xx[edge[, 1]], yy[edge[, 1]], xx[edge[, 2]], yy[edge[, 2]], col = edge.color, lwd = edge.width, lty = edge.lty) circular.plot <- function(edge, Ntip, Nnode, xx, yy, theta, r, edge.color, edge.width, edge.lty) ### 'edge' must be in postorder order { r0 <- r[edge[, 1]] r1 <- r[edge[, 2]] theta0 <- theta[edge[, 2]] costheta0 <- cos(theta0) sintheta0 <- sin(theta0) x0 <- r0 * costheta0 y0 <- r0 * sintheta0 x1 <- r1 * costheta0 y1 <- r1 * sintheta0 segments(x0, y0, x1, y1, col = edge.color, lwd = edge.width, lty = edge.lty) tmp <- which(diff(edge[, 1]) != 0) start <- c(1, tmp + 1) Nedge <- dim(edge)[1] end <- c(tmp, Nedge) ## function dispatching the features to the arcs foo <- function(edge.feat, default) { if (length(edge.feat) == 1) return(as.list(rep(edge.feat, Nnode))) edge.feat <- rep(edge.feat, length.out = Nedge) feat.arc <- as.list(rep(default, Nnode)) for (k in 1:Nnode) { tmp <- edge.feat[start[k]] if (tmp == edge.feat[end[k]]) { # fix by Francois Michonneau (2015-07-24) feat.arc[[k]] <- tmp } else { if (nodedegree[k] == 2) feat.arc[[k]] <- rep(c(tmp, edge.feat[end[k]]), each = 50) } } feat.arc } nodedegree <- tabulate(edge[, 1L])[-seq_len(Ntip)] co <- foo(edge.color, "black") lw <- foo(edge.width, 1) ly <- foo(edge.lty, 1) for (k in 1:Nnode) { i <- start[k] j <- end[k] X <- rep(r[edge[i, 1]], 100) Y <- seq(theta[edge[i, 2]], theta[edge[j, 2]], length.out = 100) x <- X * cos(Y); y <- X * sin(Y) x0 <- x[-100]; y0 <- y[-100]; x1 <- x[-1]; y1 <- y[-1] segments(x0, y0, x1, y1, col = co[[k]], lwd = lw[[k]], lty = ly[[k]]) } } unrooted.xy <- function(Ntip, Nnode, edge, edge.length, nb.sp, rotate.tree) { foo <- function(node, ANGLE, AXIS) { ind <- which(edge[, 1] == node) sons <- edge[ind, 2] start <- AXIS - ANGLE/2 for (i in 1:length(sons)) { h <- edge.length[ind[i]] angle[sons[i]] <<- alpha <- ANGLE*nb.sp[sons[i]]/nb.sp[node] axis[sons[i]] <<- beta <- start + alpha/2 start <- start + alpha xx[sons[i]] <<- h*cos(beta) + xx[node] yy[sons[i]] <<- h*sin(beta) + yy[node] } for (i in sons) if (i > Ntip) foo(i, angle[i], axis[i]) } Nedge <- dim(edge)[1] yy <- xx <- numeric(Ntip + Nnode) ## `angle': the angle allocated to each node wrt their nb of tips ## `axis': the axis of each branch axis <- angle <- numeric(Ntip + Nnode) ## start with the root... foo(Ntip + 1L, 2*pi, 0 + rotate.tree) M <- cbind(xx, yy) axe <- axis[1:Ntip] # the axis of the terminal branches (for export) axeGTpi <- axe > pi ## insures that returned angles are in [-PI, +PI]: axe[axeGTpi] <- axe[axeGTpi] - 2*pi list(M = M, axe = axe) } node.depth <- function(phy, method = 1) { n <- length(phy$tip.label) m <- phy$Nnode N <- dim(phy$edge)[1] phy <- reorder(phy, order = "postorder") .C(node_depth, as.integer(n), as.integer(m), as.integer(phy$edge[, 1]), as.integer(phy$edge[, 2]), as.integer(N), double(n + m), as.integer(method))[[6]] } node.depth.edgelength <- function(phy) { n <- length(phy$tip.label) m <- phy$Nnode N <- dim(phy$edge)[1] phy <- reorder(phy, order = "postorder") .C(node_depth_edgelength, as.integer(n), as.integer(n), as.integer(phy$edge[, 1]), as.integer(phy$edge[, 2]), as.integer(N), as.double(phy$edge.length), double(n + m))[[7]] } node.height <- function(phy, clado.style = FALSE) { n <- length(phy$tip.label) m <- phy$Nnode N <- dim(phy$edge)[1] phy <- reorder(phy) yy <- numeric(n + m) e2 <- phy$edge[, 2] yy[e2[e2 <= n]] <- 1:n phy <- reorder(phy, order = "postorder") e1 <- phy$edge[, 1] e2 <- phy$edge[, 2] if (clado.style) .C(node_height_clado, as.integer(n), as.integer(m), as.integer(e1), as.integer(e2), as.integer(N), double(n + m), as.double(yy))[[7]] else .C(node_height, as.integer(n), as.integer(m), as.integer(e1), as.integer(e2), as.integer(N), as.double(yy))[[6]] } plot.multiPhylo <- function(x, layout = 1, ...) { layout(matrix(1:layout, ceiling(sqrt(layout)), byrow = TRUE)) if (!devAskNewPage() && !names(dev.cur()) %in% c("pdf", "postscript")) { devAskNewPage(TRUE) on.exit(devAskNewPage(FALSE)) } for (i in seq_along(x)) plot(x[[i]], ...) } trex <- function(phy, title = TRUE, subbg = "lightyellow3", return.tree = FALSE, ...) { lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv) devmain <- dev.cur() # where the main tree is plotted restore <- function() { dev.set(devmain) assign("last_plot.phylo", lastPP, envir = .PlotPhyloEnv) } on.exit(restore()) NEW <- TRUE cat("Click close to a node. Right-click to exit.\n") repeat { x <- identify.phylo(phy, quiet = TRUE) if (is.null(x)) return(invisible(NULL)) else { x <- x$nodes if (is.null(x)) cat("Try again!\n") else { if (NEW) { dev.new() par(bg = subbg) devsub <- dev.cur() NEW <- FALSE } else dev.set(devsub) tr <- extract.clade(phy, x) plot(tr, ...) if (is.character(title)) title(title) else if (title) { tl <- if (is.null(phy$node.label)) paste("From node #", x, sep = "") else paste("From", phy$node.label[x - Ntip(phy)]) title(tl) } if (return.tree) return(tr) restore() } } } } kronoviz <- function(x, layout = length(x), horiz = TRUE, ...) { par(mar = rep(0.5, 4), oma = rep(2, 4)) rts <- sapply(x, function(x) branching.times(x)[1]) maxrts <- max(rts) lim <- cbind(rts - maxrts, rts) Ntree <- length(x) Ntips <- sapply(x, Ntip) if (horiz) { nrow <- layout w <- 1 h <- Ntips } else { nrow <- 1 w <- Ntips h <- 1 } layout(matrix(1:layout, nrow), widths = w, heights = h) if (layout < Ntree && !devAskNewPage() && interactive()) { devAskNewPage(TRUE) on.exit(devAskNewPage(FALSE)) } if (horiz) { for (i in 1:Ntree) plot(x[[i]], x.lim = lim[i, ], ...) } else { for (i in 1:Ntree) plot(x[[i]], y.lim = lim[i, ], direction = "u", ...) } axisPhylo(if (horiz) 1 else 4) # better if the deepest tree is last ;) } ape/R/biplot.pcoa.R0000644000175100001440000000401612465112403013572 0ustar hornikusers'biplot.pcoa' <- function(x, Y=NULL, plot.axes = c(1,2), dir.axis1=1, dir.axis2=1, rn=NULL, ...) # x = output object from function pcoa.R # Y = optional sites-by-variables data table # plot.axes = the two axes to be plotted # rn = an optional vector, length n, of object labels # dir.axis.1 = -1 to revert axis 1 for the projection of points and variables # dir.axis.2 = -1 to revert axis 2 for the projection of points and variables # # Author: Pierre Legendre, January 2009 { k <- ncol(x$vectors) if(k < 2) stop("There is a single eigenvalue. No plot can be produced.") if(k < plot.axes[1]) stop("Axis",plot.axes[1],"does not exist.") if(k < plot.axes[2]) stop("Axis",plot.axes[2],"does not exist.") if(!is.null(rn)) rownames(x$vectors) <- rn labels = colnames(x$vectors[,plot.axes]) diag.dir <- diag(c(dir.axis1,dir.axis2)) x$vectors[,plot.axes] <- x$vectors[,plot.axes] %*% diag.dir if(is.null(Y)) { limits <- apply(x$vectors[,plot.axes], 2, range) ran.x <- limits[2,1] - limits[1,1] ran.y <- limits[2,2] - limits[1,2] xlim <- c((limits[1,1]-ran.x/10), (limits[2,1]+ran.x/5)) ylim <- c((limits[1,2]-ran.y/10), (limits[2,2]+ran.y/10)) par(mai = c(1.0, 1.0, 1.0, 0.5)) plot(x$vectors[,plot.axes], xlab=labels[1], ylab=labels[2], xlim=xlim, ylim=ylim, asp=1) text(x$vectors[,plot.axes], labels=rownames(x$vectors), pos=4, cex=1, offset=0.5) title(main = "PCoA ordination", line=2.5) } else { # Find positions of variables in biplot: # construct U from covariance matrix between Y and standardized point vectors # (equivalent to PCA scaling 1, since PCoA preserves distances among objects) n <- nrow(Y) points.stand <- scale(x$vectors[,plot.axes]) S <- cov(Y, points.stand) U <- S %*% diag((x$values$Eigenvalues[plot.axes]/(n-1))^(-0.5)) colnames(U) <- colnames(x$vectors[,plot.axes]) par(mai = c(1, 0.5, 1.4, 0)) biplot(x$vectors[,plot.axes], U, xlab=labels[1], ylab=labels[2]) title(main = c("PCoA biplot","Response variables projected","as in PCA with scaling 1"), line=4) } invisible() } ape/R/balance.R0000644000175100001440000000174112547235663012766 0ustar hornikusers## balance.R (2015-07-08) ## Balance of a Dichotomous Phylogenetic Tree ## Copyright 2002-2015 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. balance <- function(phy) { if (!inherits(phy, "phylo")) stop('object "phy" is not of class "phylo"') phy <- reorder(phy) # fix a bug reported by G. Valiente in January 2009 (2015-07-08) N <- length(phy$tip.label) nb.node <- phy$Nnode if (nb.node != N - 1) stop('"phy" is not rooted and fully dichotomous') ans <- matrix(NA, nb.node, 2) foo <- function(node, n) { s <- which(phy$edge[, 1] == node) desc <- phy$edge[s, 2] ans[node - N, 1] <<- n1 <- (s[2] - s[1] + 1)/2 ans[node - N, 2] <<- n2 <- n - n1 if (desc[1] > N) foo(desc[1], n1) if (desc[2] > N) foo(desc[2], n2) } foo(N + 1, N) rownames(ans) <- if (is.null(phy$node.label)) N + 1:nb.node else phy$node.label ans } ape/R/read.dna.R0000644000175100001440000001261712732270704013050 0ustar hornikusers## read.dna.R (2016-06-21) ## Read DNA Sequences in a File ## Copyright 2003-2016 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. read.FASTA <- function(file) { if (length(grep("^(ht|f)tp:", file))) { url <- file file <- tempfile() download.file(url, file) } sz <- file.size(file) x <- readBin(file, "raw", sz) ## if the file is larger than 2 Gb we assume that it is UNIX-encoded ## and skip the search-replacement of carriage returns if (sz < 1e9) { icr <- which(x == as.raw(0x0d)) # CR if (length(icr)) x <- x[-icr] } res <- .Call(rawStreamToDNAbin, x) names(res) <- sub("^ +", "", names(res)) # to permit phylosim class(res) <- "DNAbin" res } read.dna <- function(file, format = "interleaved", skip = 0, nlines = 0, comment.char = "#", as.character = FALSE, as.matrix = NULL) { findFirstNucleotide <- function(x) { ## actually find the 1st non-blank character ## just in case: pat.base <- "[-AaCcGgTtUuMmRrWwSsYyKkVvHhDdBbNn?]{10}" tmp <- regexpr("[[:blank:]]+", x[1]) # consider only a single string tmp[1] + attr(tmp, "match.length") } getTaxaNames <- function(x) { x <- sub("^['\" ]+", "", x) # remove the leading quotes and spaces x <- sub("['\" ]+$", "", x) # " " trailing " " " x } getNucleotide <- function(x) { x <- gsub(" ", "", x) x <- strsplit(x, NULL) tolower(unlist(x)) } formats <- c("interleaved", "sequential", "fasta", "clustal") format <- match.arg(format, formats) if (format == "fasta") { obj <- read.FASTA(file) } else { X <- scan(file = file, what = "", sep = "\n", quiet = TRUE, skip = skip, nlines = nlines, comment.char = comment.char) if (format %in% formats[1:2]) { ## need to remove the possible leading spaces and/or tabs in the first line fl <- gsub("^[[:blank:]]+", "", X[1]) fl <- as.numeric(unlist(strsplit(fl, "[[:blank:]]+"))) if (length(fl) != 2 || any(is.na(fl))) stop("the first line of the file must contain the dimensions of the data") n <- fl[1] s <- fl[2] obj <- matrix("", n, s) X <- X[-1] } switch(format, "interleaved" = { start.seq <- findFirstNucleotide(X[1]) one2n <- 1:n taxa <- getTaxaNames(substr(X[one2n], 1, start.seq - 1)) X[one2n] <- substr(X[one2n], start.seq, nchar(X[one2n])) nl <- length(X) for (i in one2n) obj[i, ] <- getNucleotide(X[seq(i, nl, n)]) }, "sequential" = { taxa <- character(n) j <- 1L # line number for (i in 1:n) { start.seq <- findFirstNucleotide(X[j]) taxa[i] <- getTaxaNames(substr(X[j], 1, start.seq - 1)) sequ <- getNucleotide(substr(X[j], start.seq, nchar(X[j]))) j <- j + 1L while (length(sequ) < s) { sequ <- c(sequ, getNucleotide(X[j])) j <- j + 1L } obj[i, ] <- sequ } taxa <- getTaxaNames(taxa) }, "clustal" = { X <- X[-1] # drop the line with "Clustal bla bla..." ## find where the 1st sequence starts start.seq <- findFirstNucleotide(X[1]) ## find the lines with *********.... nspaces <- paste("^ {", start.seq - 1, "}", sep = "", collapse = "") stars <- grep(nspaces, X) ## we now know how many sequences in the file: n <- stars[1] - 1 taxa <- getTaxaNames(substr(X[1:n], 1, start.seq - 1)) ## need to remove the sequence names before getting the sequences: X <- substr(X, start.seq, nchar(X)) nl <- length(X) ## find the length of the 1st sequence: tmp <- getNucleotide(X[seq(1, nl, n + 1)]) s <- length(tmp) obj <- matrix("", n, s) obj[1, ] <- tmp for (i in 2:n) obj[i, ] <- getNucleotide(X[seq(i, nl, n + 1)]) }) } if (format != "fasta") { rownames(obj) <- taxa if (!as.character) obj <- as.DNAbin(obj) } else { LENGTHS <- unique(lengths(obj, use.names = FALSE)) allSameLength <- length(LENGTHS) == 1 if (is.logical(as.matrix)) { if (as.matrix && !allSameLength) stop("sequences in FASTA file not of the same length") } else { as.matrix <- allSameLength } if (as.matrix) { taxa <- names(obj) n <- length(obj) y <- matrix(as.raw(0), n, LENGTHS) for (i in seq_len(n)) y[i, ] <- obj[[i]] obj <- y rownames(obj) <- taxa class(obj) <- "DNAbin" } if (as.character) obj <- as.character(obj) } obj } ape/R/read.nexus.data.R0000644000175100001440000001022412465112403014342 0ustar hornikusers"read.nexus.data" <- function (file) { # Simplified NEXUS data parser. # # Version: 09/13/2006 01:01:59 PM CEST # (modified by EP 2011-06-01) # # By: Johan Nylander, nylander @ scs.fsu.edu # # WARNING: This is parser reads a restricted nexus format, # see README for details. # # Argument (x) is a nexus formatted data file. # # Returns (Value) a list of data sequences each made of a single # vector of mode character where each element is a character. # # TODO: Error checking, gap/missing, find.datatype, etc. #------------------------------------------------------------------ "find.ntax" <- function (x) { for (i in 1:NROW(x)) { if(any(f <- grep("\\bntax", x[i], ignore.case = TRUE))) { ntax <- as.numeric(sub("(.+?)(ntax\\s*\\=\\s*)(\\d+)(.+)", "\\3", x[i], perl = TRUE, ignore.case = TRUE)) break } } ntax } "find.nchar" <- function (x) { for (i in 1:NROW(x)) { if(any(f <- grep("\\bnchar", x[i], ignore.case = TRUE))) { nchar <- as.numeric(sub("(.+?)(nchar\\s*\\=\\s*)(\\d+)(.+)", "\\3", x[i], perl = TRUE, ignore.case = TRUE)) break } } nchar } "find.matrix.line" <- function (x) { for (i in 1:NROW(x)) { if(any(f <- grep("\\bmatrix\\b", x[i], ignore.case = TRUE))) { matrix.line <- as.numeric(i) break } } matrix.line } "trim.whitespace" <- function (x) { gsub("\\s+", "", x) } "trim.semicolon" <- function (x) { gsub(";", "", x) } X <- scan(file = file, what = character(), sep = "\n", quiet = TRUE, comment.char = "[", strip.white = TRUE) ntax <- find.ntax(X) nchar <- find.nchar(X) matrix.line <- find.matrix.line(X) start.reading <- matrix.line + 1 Obj <- list() length(Obj) <- ntax i <- 1 pos <- 0 tot.nchar <- 0 tot.ntax <- 0 for (j in start.reading:NROW(X)) { Xj <- trim.semicolon(X[j]) if(Xj == "") { break } if(any(jtmp <- grep("\\bend\\b", X[j], perl = TRUE, ignore.case = TRUE))) { break } ts <- unlist(strsplit(Xj, "(?<=\\S)(\\s+)(?=\\S)", perl = TRUE)) if (length(ts) > 2) { stop("nexus parser does not handle spaces in sequences or taxon names (ts>2)") } if (length(ts) !=2) { stop("nexus parser failed to read the sequences (ts!=2)") } Seq <- trim.whitespace(ts[2]) Name <- trim.whitespace(ts[1]) nAME <- paste(c("\\b", Name, "\\b"), collapse = "") if (any(l <- grep(nAME, names(Obj)))) { tsp <- strsplit(Seq, NULL)[[1]] for (k in 1:length(tsp)) { p <- k + pos Obj[[l]][p] <- tsp[k] chars.done <- k } } else { names(Obj)[i] <- Name tsp <- strsplit(Seq, NULL)[[1]] for (k in 1:length(tsp)) { p <- k + pos Obj[[i]][p] <- tsp[k] chars.done <- k } } tot.ntax <- tot.ntax + 1 if (tot.ntax == ntax) { i <- 1 tot.ntax <- 0 tot.nchar <- tot.nchar + chars.done if (tot.nchar == nchar*ntax) { print("ntot was more than nchar*ntax") break } pos <- tot.nchar } else { i <- i + 1 } } if (tot.ntax != 0) { cat("ntax:",ntax,"differ from actual number of taxa in file?\n") stop("nexus parser did not read names correctly (tot.ntax!=0)") } for (i in 1:length(Obj)) { if (length(Obj[[i]]) != nchar) { cat(names(Obj[i]),"has",length(Obj[[i]]),"characters\n") stop("nchar differ from sequence length (length(Obj[[i]])!=nchar)") } } Obj <- lapply(Obj, tolower) Obj } ape/R/zoom.R0000644000175100001440000000230212465112403012340 0ustar hornikusers## zoom.R (2009-07-27) ## Zoom on a Portion of a Phylogeny ## Copyright 2003-2009 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. zoom <- function(phy, focus, subtree = FALSE, col = rainbow, ...) { if (!is.list(focus)) focus <- list(focus) n <- length(focus) for (i in 1:n) if (is.character(focus[[i]])) focus[[i]] <- which(phy$tip.label %in% focus[[i]]) # fix by Yan Wong if (is.function(col)) { col <- if (deparse(substitute(col)) == "grey") grey(1:n/n) else col(n) } ext <- vector("list", n) for (i in 1:n) ext[[i]] <- drop.tip(phy, phy$tip.label[-focus[[i]]], subtree = subtree, rooted = TRUE) nc <- round(sqrt(n)) + 1 nr <- ceiling(sqrt(n)) M <- matrix(0, nr, nc) x <- c(rep(1, nr), 2:(n + 1)) M[1:length(x)] <- x layout(M, c(1, rep(3/(nc - 1), nc - 1))) phy$tip.label <- rep("", length(phy$tip.label)) colo <- rep("black", dim(phy$edge)[1]) for (i in 1:n) colo[which.edge(phy, focus[[i]])] <- col[i] plot.phylo(phy, edge.color = colo, ...) for (i in 1:n) plot.phylo(ext[[i]], edge.color = col[i], ...) } ape/R/phymltest.R0000644000175100001440000001144212465112403013412 0ustar hornikusers## phymltest.R (2014-11-07) ## Fits a Bunch of Models with PhyML ## Copyright 2004-2014 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. .phymltest.model <- c("JC69", "JC69+I", "JC69+G", "JC69+I+G", "K80", "K80+I", "K80+G", "K80+I+G", "F81", "F81+I", "F81+G", "F81+I+G", "F84", "F84+I", "F84+G", "F84+I+G", "HKY85", "HKY85+I", "HKY85+G", "HKY85+I+G", "TN93", "TN93+I", "TN93+G", "TN93+I+G", "GTR", "GTR+I", "GTR+G", "GTR+I+G") .phymltest.nfp <- c(1, 2, 2, 3, 2, 3, 3, 4, 4, 5, 5, 6, 5, 6, 6, 7, 5, 6, 6, 7, 6, 7, 7, 8, 9, 10, 10, 11) phymltest <- function(seqfile, format = "interleaved", itree = NULL, exclude = NULL, execname = NULL, append = TRUE) { os <- Sys.info()[1] ## default names of PhyML: if (is.null(execname)) { execname <- switch(os, "Linux" = { ## PhyML location for Debian and Fedora packages and maybe for other distributions (fix by Dylan A\"issi) if (file.exists("/usr/bin/phyml")) "/usr/bin/phyml" else "phyml_3.0.1_linux32" }, "Darwin" = "phyml_3.0.1_macintel", "Windows" = "phyml_3.0.1_win32") } if (is.null(execname)) stop("you must give an executable file name for PHYML") N <- length(.phymltest.model) format <- match.arg(format, c("interleaved", "sequential")) fmt <- rep("", N) if (format != "interleaved") fmt[] <- "-q" boot <- rep("-b 0", N) # to avoid any testing mdl <- paste("-m", rep(c("JC69", "K80", "F81", "F84", "HKY85", "TN93", "GTR"), each = 4)) # fix by Luiz Max Fagundes de Carvalho tstv <- rep("-t e", N) # ignored by PhyML with JC69 or F81 inv <- rep(c("", "-v e"), length.out = N) ## no need to use the -c option of PhyML (4 categories by default if '-a e' is set): alpha <- rep(rep(c("-c 1", "-a e"), each = 2), length.out = N) tree <- rep("", N) if (!is.null(itree)) tree[] <- paste("-u ", itree) cmd <- paste(execname, "-i", seqfile, fmt, boot, mdl, tstv, inv, alpha, tree, "--append ") outfile <- paste(seqfile, "_phyml_stats.txt", sep = "") if (!append) { unlink(outfile) unlink(paste(seqfile, "_phyml_tree.txt", sep = "")) } imod <- 1:N if (!is.null(exclude)) imod <- imod[!.phymltest.model %in% exclude] for (i in imod) system(cmd[i]) l <- readLines(outfile) l <- grep("Log-likelihood:", l, value = TRUE) ## in case there were already some results in the output file: if (dd <- length(l) - length(imod)) l <- l[-(1:dd)] loglik <- as.numeric(sub(". Log-likelihood:", "", l)) names(loglik) <- .phymltest.model[imod] class(loglik) <- "phymltest" loglik } print.phymltest <- function(x, ...) { nfp <- .phymltest.nfp[.phymltest.model %in% names(x)] X <- cbind(nfp, x, 2 * (nfp - x)) rownames(X) <- names(x) colnames(X) <- c("nb.free.para", "loglik", "AIC") print(X) } summary.phymltest <- function(object, ...) { nfp <- .phymltest.nfp[.phymltest.model %in% names(object)] N <- length(object) model1 <- model2 <- character(0) chi2 <- df <- P.val <- numeric(0) for (i in 1:(N - 1)) { for (j in (i + 1):N) { if (nfp[i] >= nfp[j]) next m1 <- unlist(strsplit(names(object)[i], "\\+")) m2 <- unlist(strsplit(names(object)[j], "\\+")) if (m1[1] == "K80" && m2[1] == "F81") next ## a verifier que ds les 2 lignes suivantes les conversions ## se font bien correctement!!!! if (length(grep("\\+I", names(object)[i])) > 0 && length(grep("\\+I", names(object)[j])) == 0) next if (length(grep("\\+G", names(object)[i])) > 0 && length(grep("\\+G", names(object)[j])) == 0) next ## Now we should be sure that m1 is nested in m2. chi2 <- c(chi2, 2 * (object[j] - object[i])) df <- c(df, nfp[j] - nfp[i]) P.val <- c(P.val, 1 - pchisq(2 * (object[j] - object[i]), nfp[j] - nfp[i])) model1 <- c(model1, names(object)[i]) model2 <- c(model2, names(object)[j]) } } data.frame(model1, model2, chi2, df, P.val = round(P.val, 4)) } plot.phymltest <- function(x, main = NULL, col = "blue", ...) { nfp <- .phymltest.nfp[.phymltest.model %in% names(x)] N <- length(x) aic <- 2 * (nfp - x) if (is.null(main)) main <- paste("Akaike information criterion for", deparse(substitute(x))) plot(rep(1, N), aic, bty = "n", xaxt = "n", yaxt = "n", type = "n", xlab = "", ylab = "", main = main, ...) axis(side = 2, pos = 0.85, las = 2) abline(v = 0.85) y.lab <- seq(min(aic), max(aic), length = N) segments(0.85, sort(aic), 1.1, y.lab, col = col) text(1.1, y.lab, parse(text = sub("\\+G", "\\+Gamma", names(sort(aic)))), adj = 0) } ape/R/is.binary.tree.R0000644000175100001440000000142513006563031014214 0ustar hornikusers## is.binary.tree.R (2016-11-03) ## Test for Binary Tree ## Copyright 2016 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. is.binary <- function(phy) UseMethod("is.binary") is.binary.phylo <- function(phy) length(phy$tip.label) - phy$Nnode + is.rooted.phylo(phy) == 2 is.binary.tree <- function(phy) { ##warning("is.binary.tree() is deprecated; using is.binary() instead.\n\nis.binary.tree() will be removed soon: see ?is.binary and update your code.") is.binary(phy) } is.binary.multiPhylo <- function(phy) { phy <- unclass(phy) n <- length(attr(phy, "TipLabel")) if (n) n - sapply(phy, "[[", "Nnode") + is.rooted.multiPhylo(phy) == 2 else sapply(phy, is.binary.phylo) } ape/R/is.monophyletic.R0000644000175100001440000000275612465112403014515 0ustar hornikusers## is.monophyletic.R (2012-03-23) ## Test Monophyly ## Copyright 2009-2012 Johan Nylander and Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. is.monophyletic <- function(phy, tips, reroot = !is.rooted(phy), plot = FALSE, ...) { if (!inherits(phy, "phylo")) stop("object 'phy' is not of class 'phylo'") n <- length(phy$tip.label) if (length(tips) %in% c(1L, n)) return(TRUE) ROOT <- n + 1L if (is.numeric(tips)) { if (any(tips > n)) stop("incorrect tip#: should not be greater than the number of tips") tips <- sort(as.integer(tips)) } if (is.character(tips)) tips <- which(phy$tip.label %in% tips) if (reroot) { outgrp <- phy$tip.label[-tips][1] phy <- root(phy, outgroup = outgrp, resolve.root = TRUE) rerooted <- TRUE } else rerooted <- FALSE phy <- reorder(phy) seq.nod <- .Call(seq_root2tip, phy$edge, n, phy$Nnode) sn <- seq.nod[tips] newroot <- ROOT i <- 2 repeat { x <- unique(unlist(lapply(sn, "[", i))) if (length(x) != 1) break newroot <- x i <- i + 1 } desc <- which(unlist(lapply(seq.nod, function(x) any(x %in% newroot)))) if (plot) { zoom(phy, tips, subtree = FALSE, ...) if (rerooted) mtext("Input tree arbitrarily rerooted", side = 1, cex = 0.9) } ## assuming that both vectors are sorted: identical(tips, desc) } ape/R/ace.R0000644000175100001440000003513312725760432012126 0ustar hornikusers## ace.R (2016-06-08) ## Ancestral Character Estimation ## Copyright 2005-2016 Emmanuel Paradis and Ben Bolker ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. .getSEs <- function(out) { h <- out$hessian if (any(diag(h) == 0)) { warning("The likelihood gradient seems flat in at least one dimension (gradient null):\ncannot compute the standard-errors of the transition rates.\n") se <- rep(NaN, nrow(h)) } else { se <- sqrt(diag(solve(h))) } se } ace <- function(x, phy, type = "continuous", method = if (type == "continuous") "REML" else "ML", CI = TRUE, model = if (type == "continuous") "BM" else "ER", scaled = TRUE, kappa = 1, corStruct = NULL, ip = 0.1, use.expm = FALSE, use.eigen = TRUE, marginal = FALSE) { if (!inherits(phy, "phylo")) stop('object "phy" is not of class "phylo"') if (is.null(phy$edge.length)) stop("tree has no branch lengths") type <- match.arg(type, c("continuous", "discrete")) nb.tip <- length(phy$tip.label) nb.node <- phy$Nnode if (nb.node != nb.tip - 1) stop('"phy" is not rooted AND fully dichotomous.') if (length(x) != nb.tip) stop("length of phenotypic and of phylogenetic data do not match.") if (!is.null(names(x))) { if(all(names(x) %in% phy$tip.label)) x <- x[phy$tip.label] else warning("the names of 'x' and the tip labels of the tree do not match: the former were ignored in the analysis.") } obj <- list() if (kappa != 1) phy$edge.length <- phy$edge.length^kappa if (type == "continuous") { switch(method, "REML" = { minusLogLik <- function(sig2) { if (sig2 < 0) return(1e100) V <- sig2 * vcv(phy) ## next three lines borrowed from dmvnorm() in 'mvtnorm' distval <- mahalanobis(x, center = mu, cov = V) logdet <- sum(log(eigen(V, symmetric = TRUE, only.values = TRUE)$values)) (nb.tip * log(2 * pi) + logdet + distval)/2 } mu <- rep(ace(x, phy, method="pic")$ace[1], nb.tip) out <- nlm(minusLogLik, 1, hessian = TRUE) sigma2 <- out$estimate se_sgi2 <- sqrt(1/out$hessian) tip <- phy$edge[, 2] <= nb.tip minus.REML.BM <- function(p) { x1 <- p[phy$edge[, 1] - nb.tip] x2 <- numeric(length(x1)) x2[tip] <- x[phy$edge[tip, 2]] x2[!tip] <- p[phy$edge[!tip, 2] - nb.tip] -(-sum((x1 - x2)^2/phy$edge.length)/(2 * sigma2) - nb.node * log(sigma2)) } out <- nlm(function(p) minus.REML.BM(p), p = rep(mu[1], nb.node), hessian = TRUE) obj$resloglik <- -out$minimum obj$ace <- out$estimate names(obj$ace) <- nb.tip + 1:nb.node obj$sigma2 <- c(sigma2, se_sgi2) if (CI) { se <- .getSEs(out) tmp <- se * qt(0.025, nb.node) obj$CI95 <- cbind(obj$ace + tmp, obj$ace - tmp) } }, "pic" = { if (model != "BM") stop('the "pic" method can be used only with model = "BM".') ## See pic.R for some annotations. phy <- reorder(phy, "postorder") phenotype <- numeric(nb.tip + nb.node) phenotype[1:nb.tip] <- if (is.null(names(x))) x else x[phy$tip.label] contr <- var.con <- numeric(nb.node) ans <- .C(C_pic, as.integer(nb.tip), as.integer(nb.node), as.integer(phy$edge[, 1]), as.integer(phy$edge[, 2]), as.double(phy$edge.length), as.double(phenotype), as.double(contr), as.double(var.con), as.integer(CI), as.integer(scaled)) obj$ace <- ans[[6]][-(1:nb.tip)] names(obj$ace) <- nb.tip + 1:nb.node if (CI) { se <- sqrt(ans[[8]]) tmp <- se * qnorm(0.025) obj$CI95 <- cbind(obj$ace + tmp, obj$ace - tmp) } }, "ML" = { if (model == "BM") { tip <- phy$edge[, 2] <= nb.tip dev.BM <- function(p) { if (p[1] < 0) return(1e100) # in case sigma^2 is negative x1 <- p[-1][phy$edge[, 1] - nb.tip] x2 <- numeric(length(x1)) x2[tip] <- x[phy$edge[tip, 2]] x2[!tip] <- p[-1][phy$edge[!tip, 2] - nb.tip] -2 * (-sum((x1 - x2)^2/phy$edge.length)/(2*p[1]) - nb.node * log(p[1])) } out <- nlm(function(p) dev.BM(p), p = c(1, rep(mean(x), nb.node)), hessian = TRUE) obj$loglik <- -out$minimum / 2 obj$ace <- out$estimate[-1] names(obj$ace) <- (nb.tip + 1):(nb.tip + nb.node) se <- .getSEs(out) obj$sigma2 <- c(out$estimate[1], se[1]) if (CI) { tmp <- se[-1] * qt(0.025, nb.node) obj$CI95 <- cbind(obj$ace + tmp, obj$ace - tmp) } } }, "GLS" = { if (is.null(corStruct)) stop('you must give a correlation structure if method = "GLS".') if (class(corStruct)[1] == "corMartins") M <- corStruct[1] * dist.nodes(phy) if (class(corStruct)[1] == "corGrafen") phy <- compute.brlen(attr(corStruct, "tree"), method = "Grafen", power = exp(corStruct[1])) if (class(corStruct)[1] %in% c("corBrownian", "corGrafen")) { dis <- dist.nodes(attr(corStruct, "tree")) MRCA <- mrca(attr(corStruct, "tree"), full = TRUE) M <- dis[as.character(nb.tip + 1), MRCA] dim(M) <- rep(sqrt(length(M)), 2) } varAY <- M[-(1:nb.tip), 1:nb.tip] varA <- M[-(1:nb.tip), -(1:nb.tip)] V <- corMatrix(Initialize(corStruct, data.frame(x)), corr = FALSE) invV <- solve(V) o <- gls(x ~ 1, data.frame(x), correlation = corStruct) GM <- o$coefficients obj$ace <- drop(varAY %*% invV %*% (x - GM) + GM) names(obj$ace) <- (nb.tip + 1):(nb.tip + nb.node) if (CI) { se <- sqrt((varA - varAY %*% invV %*% t(varAY))[cbind(1:nb.node, 1:nb.node)]) tmp <- se * qnorm(0.025) obj$CI95 <- cbind(obj$ace + tmp, obj$ace - tmp) } }) } else { # type == "discrete" if (method != "ML") stop("only ML estimation is possible for discrete characters.") if (any(phy$edge.length <= 0)) stop("some branches have length zero or negative") if (!is.factor(x)) x <- factor(x) nl <- nlevels(x) lvls <- levels(x) x <- as.integer(x) if (is.character(model)) { rate <- matrix(NA, nl, nl) switch(model, "ER" = np <- rate[] <- 1, "ARD" = { np <- nl*(nl - 1) rate[col(rate) != row(rate)] <- 1:np }, "SYM" = { np <- nl * (nl - 1)/2 sel <- col(rate) < row(rate) rate[sel] <- 1:np rate <- t(rate) rate[sel] <- 1:np }) } else { if (ncol(model) != nrow(model)) stop("the matrix given as 'model' is not square") if (ncol(model) != nl) stop("the matrix 'model' must have as many rows as the number of categories in 'x'") rate <- model np <- max(rate) } index.matrix <- rate tmp <- cbind(1:nl, 1:nl) index.matrix[tmp] <- NA rate[tmp] <- 0 rate[rate == 0] <- np + 1 # to avoid 0's since we will use this as numeric indexing liks <- matrix(0, nb.tip + nb.node, nl) TIPS <- 1:nb.tip liks[cbind(TIPS, x)] <- 1 phy <- reorder(phy, "postorder") Q <- matrix(0, nl, nl) e1 <- phy$edge[, 1] e2 <- phy$edge[, 2] EL <- phy$edge.length if (use.eigen) { dev <- function(p, output.liks = FALSE) { if (any(is.nan(p)) || any(is.infinite(p))) return(1e+50) comp <- numeric(nb.tip + nb.node) Q[] <- c(p, 0)[rate] diag(Q) <- -rowSums(Q) decompo <- eigen(Q) lambda <- decompo$values GAMMA <- decompo$vectors invGAMMA <- solve(GAMMA) for (i in seq(from = 1, by = 2, length.out = nb.node)) { j <- i + 1L anc <- e1[i] des1 <- e2[i] des2 <- e2[j] v.l <- GAMMA %*% diag(exp(lambda * EL[i])) %*% invGAMMA %*% liks[des1, ] v.r <- GAMMA %*% diag(exp(lambda * EL[j])) %*% invGAMMA %*% liks[des2, ] v <- v.l * v.r comp[anc] <- sum(v) liks[anc, ] <- v/comp[anc] } if (output.liks) return(liks[-TIPS, ]) dev <- -2 * sum(log(comp[-TIPS])) if (is.na(dev)) Inf else dev } } else { if (!requireNamespace("expm", quietly = TRUE) && use.expm) { warning("package 'expm' not available; using function 'matexpo' from 'ape'") use.expm <- FALSE } E <- if (use.expm) expm::expm # to avoid Matrix::expm else matexpo dev <- function(p, output.liks = FALSE) { if (any(is.nan(p)) || any(is.infinite(p))) return(1e50) comp <- numeric(nb.tip + nb.node) # from Rich FitzJohn Q[] <- c(p, 0)[rate] diag(Q) <- -rowSums(Q) for (i in seq(from = 1, by = 2, length.out = nb.node)) { j <- i + 1L anc <- e1[i] des1 <- e2[i] des2 <- e2[j] v.l <- E(Q * EL[i]) %*% liks[des1, ] v.r <- E(Q * EL[j]) %*% liks[des2, ] v <- v.l * v.r comp[anc] <- sum(v) liks[anc, ] <- v/comp[anc] } if (output.liks) return(liks[-TIPS, ]) dev <- -2 * sum(log(comp[-TIPS])) if (is.na(dev)) Inf else dev } } out <- nlminb(rep(ip, length.out = np), function(p) dev(p), lower = rep(0, np), upper = rep(1e50, np)) obj$loglik <- -out$objective/2 obj$rates <- out$par oldwarn <- options("warn") options(warn = -1) out.nlm <- try(nlm(function(p) dev(p), p = obj$rates, iterlim = 1, stepmax = 0, hessian = TRUE), silent = TRUE) options(oldwarn) obj$se <- if (class(out.nlm) == "try-error") { warning("model fit suspicious: gradients apparently non-finite") rep(NaN, np) } else .getSEs(out.nlm) obj$index.matrix <- index.matrix if (CI) { lik.anc <- dev(obj$rates, TRUE) if (!marginal) { Q[] <- c(obj$rates, 0)[rate] diag(Q) <- -rowSums(Q) for (i in seq(to = 1, by = -2, length.out = nb.node)) { anc <- e1[i] - nb.tip des1 <- e2[i] - nb.tip if (des1 > 0) { P <- matexpo(Q * EL[i]) tmp <- lik.anc[anc, ] / (lik.anc[des1, ] %*% P) lik.anc[des1, ] <- (tmp %*% P) * lik.anc[des1, ] } j <- i + 1L des2 <- e2[j] - nb.tip if (des2 > 0) { P <- matexpo(Q * EL[j]) tmp <- lik.anc[anc, ] / (lik.anc[des2, ] %*% P) lik.anc[des2, ] <- (tmp %*% P) * lik.anc[des2, ] } lik.anc <- lik.anc / rowSums(lik.anc) } } colnames(lik.anc) <- lvls obj$lik.anc <- lik.anc } } obj$call <- match.call() class(obj) <- "ace" obj } logLik.ace <- function(object, ...) object$loglik deviance.ace <- function(object, ...) -2*object$loglik AIC.ace <- function(object, ..., k = 2) { if (is.null(object$loglik)) return(NULL) ## Trivial test of "type"; may need to be improved ## if other models are included in ace(type = "c") np <- if (!is.null(object$sigma2)) 1 else length(object$rates) -2*object$loglik + np*k } ### by BB: anova.ace <- function(object, ...) { X <- c(list(object), list(...)) df <- lengths(lapply(X, "[[", "rates")) ll <- sapply(X, "[[", "loglik") ## check if models are in correct order dev <- c(NA, 2*diff(ll)) ddf <- c(NA, diff(df)) table <- data.frame(ll, df, ddf, dev, pchisq(dev, ddf, lower.tail = FALSE)) dimnames(table) <- list(1:length(X), c("Log lik.", "Df", "Df change", "Resid. Dev", "Pr(>|Chi|)")) structure(table, heading = "Likelihood Ratio Test Table", class = c("anova", "data.frame")) } print.ace <- function(x, digits = 4, ...) { cat("\n Ancestral Character Estimation\n\n") cat("Call: ") print(x$call) cat("\n") if (!is.null(x$loglik)) cat(" Log-likelihood:", x$loglik, "\n\n") if (!is.null(x$resloglik)) cat(" Residual log-likelihood:", x$resloglik, "\n\n") ratemat <- x$index.matrix if (is.null(ratemat)) { # to be improved class(x) <- NULL x$resloglik <- x$loglik <- x$call <- NULL print(x) } else { dimnames(ratemat)[1:2] <- dimnames(x$lik.anc)[2] cat("Rate index matrix:\n") print(ratemat, na.print = ".") cat("\n") npar <- length(x$rates) estim <- data.frame(1:npar, round(x$rates, digits), round(x$se, digits)) cat("Parameter estimates:\n") names(estim) <- c("rate index", "estimate", "std-err") print(estim, row.names = FALSE) if (!is.null(x$lik.anc)) { cat("\nScaled likelihoods at the root (type '...$lik.anc' to get them for all nodes):\n") print(x$lik.anc[1, ]) } } } ape/R/rtree.R0000644000175100001440000001501612465112403012503 0ustar hornikusers## rtree.R (2013-04-02) ## Generates Trees ## Copyright 2004-2013 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. rtree <- function(n, rooted = TRUE, tip.label = NULL, br = runif, ...) { foo <- function(n, pos) { n1 <- sample.int(n - 1, 1, FALSE, NULL) n2 <- n - n1 po2 <- pos + 2*n1 - 1 edge[c(pos, po2), 1] <<- nod nod <<- nod + 1L if (n1 > 2) { edge[pos, 2] <<- nod foo(n1, pos + 1) } else if (n1 == 2) { edge[c(pos + 1, pos + 2), 1] <<- edge[pos, 2] <<- nod nod <<- nod + 1L } if (n2 > 2) { edge[po2, 2] <<- nod foo(n2, po2 + 1) } else if (n2 == 2) { edge[c(po2 + 1, po2 + 2), 1] <<- edge[po2, 2] <<- nod nod <<- nod + 1L } } if (n < 2) stop("a tree must have at least 2 tips.") nbr <- 2 * n - 3 + rooted edge <- matrix(NA, nbr, 2) n <- as.integer(n) if (n == 2) { if (rooted) edge[] <- c(3L, 3L, 1L, 2L) else stop("an unrooted tree must have at least 3 tips.") } else if (n == 3) { edge[] <- if (rooted) c(4L, 5L, 5L, 4L, 5L, 1:3) else c(4L, 4L, 4L, 1:3) } else if (n == 4 && !rooted) { edge[] <- c(5L, 6L, 6L, 5L, 5L, 6L, 1:4) } else { nod <- n + 1L if (rooted) { # n > 3 foo(n, 1) ## The following is slightly more efficient than affecting the ## tip numbers in foo(): the gain is 0.006 s for n = 1000. i <- which(is.na(edge[, 2])) edge[i, 2] <- 1:n } else { # n > 4 n1 <- sample.int(n - 2L, 1L) if (n1 == n - 2L) { n2 <- n3 <- 1L } else { n2 <- sample.int(n - n1 - 1L, 1L) n3 <- n - n1 - n2 } po2 <- 2L * n1 po3 <- 2L * (n1 + n2) - 1L edge[c(1, po2, po3), 1L] <- nod nod <- nod + 1L if (n1 > 2L) { edge[1L, 2L] <- nod foo(n1, 2L) } else if (n1 == 2L) { edge[2:3, 1L] <- edge[1L, 2L] <- nod nod <- nod + 1L } if (n2 > 2L) { edge[po2, 2L] <- nod foo(n2, po2 + 1L) } else if (n2 == 2L) { edge[c(po2 + 1L, po2 + 2), 1L] <- edge[po2, 2L] <- nod nod <- nod + 1L } if (n3 > 2) { edge[po3, 2L] <- nod foo(n3, po3 + 1L) } else if (n3 == 2L) { edge[c(po3 + 1L, po3 + 2), 1L] <- edge[po3, 2L] <- nod ## nod <- nod + 1L } i <- which(is.na(edge[, 2L])) edge[i, 2] <- 1:n } } phy <- list(edge = edge) phy$tip.label <- if (is.null(tip.label)) paste("t", sample(n), sep = "") else sample(tip.label) if (!is.null(br)) { phy$edge.length <- if (is.function(br)) br(nbr, ...) else rep(br, length.out = nbr) } phy$Nnode <- n - 2L + rooted class(phy) <- "phylo" attr(phy, "order") <- "cladewise" phy } rcoal <- function(n, tip.label = NULL, br = "coalescent", ...) { n <- as.integer(n) nbr <- 2*n - 2 edge <- matrix(NA, nbr, 2) ## coalescence times by default: x <- if (is.character(br)) 2*rexp(n - 1)/(as.double(n:2) * as.double((n - 1):1)) else if (is.numeric(br)) rep(br, length.out = n - 1) else br(n - 1, ...) if (n == 2) { edge[] <- c(3L, 3L, 1:2) edge.length <- rep(x, 2) } else if (n == 3) { edge[] <- c(4L, 5L, 5L, 4L, 5L, 1:3) edge.length <- c(x[c(2, 1, 1)], sum(x)) } else { edge.length <- numeric(nbr) h <- numeric(2*n - 1) node.height <- cumsum(x) pool <- 1:n nextnode <- 2L*n - 1L for (i in 1:(n - 1)) { y <- sample(pool, size = 2) ind <- (i - 1)*2 + 1:2 edge[ind, 2] <- y edge[ind, 1] <- nextnode edge.length[ind] <- node.height[i] - h[y] h[nextnode] <- node.height[i] pool <- c(pool[! pool %in% y], nextnode) nextnode <- nextnode - 1L } } phy <- list(edge = edge, edge.length = edge.length) if (is.null(tip.label)) tip.label <- paste("t", 1:n, sep = "") phy$tip.label <- sample(tip.label) phy$Nnode <- n - 1L class(phy) <- "phylo" phy <- reorder(phy) ## to avoid crossings when converting with as.hclust: phy$edge[phy$edge[, 2] <= n, 2] <- 1:n phy } rmtree <- function(N, n, rooted = TRUE, tip.label = NULL, br = runif, ...) { a <- replicate(N, rtree(n, rooted = rooted, tip.label = tip.label, br = br, ...), simplify = FALSE) class(a) <- "multiPhylo" a } stree <- function(n, type = "star", tip.label = NULL) { type <- match.arg(type, c("star", "balanced", "left", "right")) n <- as.integer(n) if (type == "star") { N <- n m <- 1L } else { m <- n - 1L N <- n + m - 1L } edge <- matrix(0L, N, 2) switch(type, "star" = { edge[, 1] <- n + 1L edge[, 2] <- 1:n }, "balanced" = { if (log2(n) %% 1) stop("'n' is not a power of 2: cannot make a balanced tree") foo <- function(node, size) { if (size == 2) { edge[c(i, i + 1L), 1L] <<- node edge[c(i, i + 1L), 2L] <<- c(nexttip, nexttip + 1L) nexttip <<- nexttip + 2L i <<- i + 2L } else { for (k in 1:2) { # do the 2 subclades edge[i, ] <<- c(node, nextnode) nextnode <<- nextnode + 1L i <<- i + 1L foo(nextnode - 1L, size/2) } } } i <- 1L nexttip <- 1L nextnode <- n + 2L foo(n + 1L, n) }, "left" = { edge[c(seq.int(from = 1, to = N - 1, by = 2), N), 2L] <- 1:n nodes <- (n + 1L):(n + m) edge[seq.int(from = 2, to = N - 1, by = 2), 2L] <- nodes[-1] edge[, 1L] <- rep(nodes, each = 2) }, "right" = { nodes <- (n + 1L):(n + m) edge[, 1L] <- c(nodes, rev(nodes)) edge[, 2L] <- c(nodes[-1], 1:n) }) if (is.null(tip.label)) tip.label <- paste("t", 1:n, sep = "") phy <- list(edge = edge, tip.label = tip.label, Nnode = m) class(phy) <- "phylo" attr(phy, "order") <- "cladewise" phy } ape/R/compute.brtime.R0000644000175100001440000000323012465112403014312 0ustar hornikusers## compute.brtime.R (2012-03-02) ## Compute and Set Branching Times ## Copyright 2011-2012 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. compute.brtime <- function(phy, method = "coalescent", force.positive = NULL) { if (!inherits(phy, "phylo")) stop('object "phy" is not of class "phylo"') n <- length(phy$tip.label) m <- phy$Nnode N <- Nedge(phy) ## x: branching times (aka, node ages, depths, or heights) if (identical(method, "coalescent")) { # the default x <- 2 * rexp(m)/(as.double((m + 1):2) * as.double(m:1)) ## x <- 2 * rexp(n - 1)/(as.double(n:2) * as.double((n - 1):1)) if (is.null(force.positive)) force.positive <- TRUE } else if (is.numeric(method)) { x <- as.vector(method) if (length(x) != m) stop("number of branching times given is not equal to the number of nodes") if (is.null(force.positive)) force.positive <- FALSE } y <- c(rep(0, n), x) # for all nodes (terminal and internal) e1 <- phy$edge[, 1L] # local copies of the pointers e2 <- phy$edge[, 2L] # if (force.positive) { o <- .Call(seq_root2tip, phy$edge, n, m) list.nodes <- list(n + 1L) i <- 2L repeat { z <- sapply(o, "[", i) z <- unique(z[!(z <= n | is.na(z))]) if (!length(z)) break list.nodes[[i]] <- z i <- i + 1L } nodes <- unlist(lapply(list.nodes, function(x) x[sample(length(x))])) y[nodes] <- sort(x, decreasing = TRUE) } phy$edge.length <- y[e1] - y[e2] phy } ape/R/dbd.R0000644000175100001440000000732612465140136012124 0ustar hornikusers## dbd.R (2015-02-06) ## Probability Density Under Birth--Death Models ## Copyright 2012-2015 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. dyule <- function(x, lambda = 0.1, t = 1, log = FALSE) { tmp <- exp(-lambda * t) res <- if (log) log(tmp) + (x - 1) * log(1 - tmp) else tmp * (1 - tmp)^(x - 1) out.of.range <- x <= 0 if (any(out.of.range)) res[out.of.range] <- if (log) -Inf else 0 res } dbd <- function(x, lambda, mu, t, conditional = FALSE, log = FALSE) { if (length(lambda) > 1) { lambda <- lambda[1] warning("only the first value of 'lambda' was considered") } if (length(mu) > 1) { mu <- mu[1] warning("only the first value of 'mu' was considered") } if (mu == 0) return(dyule(x, lambda, t, log)) ## for the unconditional case, we have to consider x=0 separately: if (!conditional) { zero <- x == 0 out.of.range <- x < 0 } else { out.of.range <- x <= 0 } res <- numeric(length(x)) ## the situation were speciation and extinction probabilities are equal: if (lambda == mu) { tmp <- lambda * t eta <- tmp/(1 + tmp) if (conditional) { res[] <- if (log) log(1 - eta) + (x - 1) * log(eta) else (1 - eta) * eta^(x - 1) } else { # the unconditional case: if (length(zero)) { res[zero] <- eta res[!zero] <- (1 - eta)^2 * eta^(x[!zero] - 1) } else res[] <- (1 - eta)^2 * eta^(x - 1) } } else { # the general case with lambda != mu ## this expression is common to the conditional and unconditional cases: Ent <- exp((lambda - mu) * t) if (conditional) { if (log) { res[] <- log(lambda - mu) - log(lambda * Ent - mu) + (x - 1) * (log(lambda) + log(Ent - 1) - log(lambda * Ent - mu)) } else { eta <- lambda * (Ent - 1)/(lambda * Ent - mu) res[] <- (1 - eta) * eta^(x - 1) } } else { # finally, the unconditional case: eta <- lambda * (Ent - 1)/(lambda * Ent - mu) if (length(zero)) { res[zero] <- eta * mu / lambda res[!zero] <- (1 - mu * eta / lambda) * (1 - eta) * eta^(x[!zero] - 1) } else res[] <- (1 - mu * eta / lambda) * (1 - eta) * eta^(x - 1) } } if (any(out.of.range)) res[out.of.range] <- if (log) -Inf else 0 res } dbdTime <- function(x, birth, death, t, conditional = FALSE, BIRTH = NULL, DEATH = NULL, fast = FALSE) { if (length(t) > 1) { t <- t[1] warning("only the first value of 't' was considered") } if (conditional) { PrNt <- function(t, T, x) { tmp <- exp(-RHO(t, T)) Wt <- tmp * (1 + INT(t)) out <- (1/Wt)*(1 - 1/Wt)^(x - 1) zero <- x == 0 if (length(zero)) out[zero] <- 0 out } } else { # the unconditional case: PrNt <- function(t, T, x) { tmp <- exp(-RHO(t, T)) Wt <- tmp * (1 + INT(t)) out <- numeric(length(x)) zero <- x == 0 if (length(zero)) { out[zero] <- 1 - tmp/Wt out[!zero] <- (tmp/Wt^2)*(1 - 1/Wt)^(x[!zero] - 1) } else out[] <- (tmp/Wt^2)*(1 - 1/Wt)^(x - 1) out } } case <- .getCase(birth, death, BIRTH, DEATH) ff <- .getRHOetINT(birth, death, BIRTH, DEATH, case = case, fast = fast) RHO <- ff[[1]] INT <- ff[[2]] environment(RHO) <- environment(INT) <- environment() Tmax <- t PrNt(0, t, x) } ape/R/me.R0000644000175100001440000000432312465112403011762 0ustar hornikusers## me.R (2012-09-14) ## Tree Estimation Based on Minimum Evolution Algorithm ## Copyright 2007 Vincent Lefort with modifications by ## Emmanuel Paradis (2008-2012) ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. fastme.bal <- function(X, nni = TRUE, spr = TRUE, tbr = TRUE) { if (is.matrix(X)) X <- as.dist(X) N <- as.integer(attr(X, "Size")) nedge <- 2L * N - 3L ans <- .C(me_b, as.double(X), N, 1:N, as.integer(nni), as.integer(spr), as.integer(tbr), integer(nedge), integer(nedge), double(nedge), NAOK = TRUE) labels <- attr(X, "Labels") if (is.null(labels)) labels <- as.character(1:N) labels <- labels[ans[[3]]] obj <- list(edge = cbind(ans[[7]], ans[[8]]), edge.length = ans[[9]], tip.label = labels, Nnode = N - 2L) class(obj) <- "phylo" attr(obj, "order") <- "cladewise" obj } fastme.ols <- function(X, nni = TRUE) { if (is.matrix(X)) X <- as.dist(X) N <- as.integer(attr(X, "Size")) nedge <- 2L * N - 3L ans <- .C(me_o, as.double(X), N, 1:N, as.integer(nni), integer(nedge), integer(nedge), double(nedge), NAOK = TRUE) labels <- attr(X, "Labels") if (is.null(labels)) labels <- as.character(1:N) labels <- labels[ans[[3]]] obj <- list(edge = cbind(ans[[5]], ans[[6]]), edge.length = ans[[7]], tip.label = labels, Nnode = N - 2L) class(obj) <- "phylo" attr(obj, "order") <- "cladewise" obj } bionj <- function(X) { if (is.matrix(X)) X <- as.dist(X) if (any(is.na(X))) stop("missing values are not allowed in the distance matrix.\nConsider using bionjs()") if (any(X > 100)) stop("at least one distance was greater than 100") N <- as.integer(attr(X, "Size")) ans <- .C(C_bionj, as.double(X), N, integer(2 * N - 3), integer(2 * N - 3), double(2*N - 3), NAOK = TRUE) labels <- attr(X, "Labels") if (is.null(labels)) labels <- as.character(1:N) obj <- list(edge = cbind(ans[[3]], ans[[4]]), edge.length = ans[[5]], tip.label = labels, Nnode = N - 2L) class(obj) <- "phylo" reorder(obj) } ape/R/Cheverud.R0000644000175100001440000000666712465112403013143 0ustar hornikusers## Cheverud.R (2004-10-29) ## Cheverud's 1985 Autoregression Model ## Copyright 2004 Julien Dutheil ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. # This function is adapted from a MatLab code from # Rholf, F. J. (2001) Comparative Methods for the Analysis of Continuous Variables: Geometric Interpretations. # Evolution 55(11): 2143-2160 compar.cheverud <- function(y, W, tolerance=1e-6, gold.tol=1e-4) { ## fix by Michael Phelan diag(W) <- 0 # ensure diagonal is zero ## end of fix y <- as.matrix(y) if(dim(y)[2] != 1) stop("Error: y must be a single column vector.") D <- solve(diag(apply(t(W),2,sum))) Wnorm <- D %*% W #Row normalize W matrix n <- dim(y)[1] m <- dim(y)[2] y <- y-matrix(rep(1, n)) %*% apply(y,2,mean) # Deviations from mean Wy <- Wnorm %*% y Wlam <- eigen(Wnorm)$values # eigenvalues of W # Find distinct eigenvalues sorted <- sort(Wlam) # Check real: for (ii in 1:n) { if(abs(Im(sorted[ii])) > 1e-12) { warning(paste("Complex eigenvalue coerced to real:", Im(sorted[ii]))) } sorted[ii] <- Re(sorted[ii]) # Remove imaginary part } sorted <- as.double(sorted) Distinct <- numeric(0) Distinct[1] <- -Inf Distinct[2] <- sorted[1] nDistinct <- 2 for(ii in 2:n) { if(sorted[ii] - Distinct[nDistinct] > tolerance) { nDistinct <- nDistinct + 1 Distinct[nDistinct] <- sorted[ii] } } # Search for minimum of LL likelihood <- function(rhohat) { DetProd <- 1 for(j in 1:n) { prod <- 1 - rhohat * Wlam[j] DetProd <- DetProd * prod } absValDet <- abs(DetProd) #[abs to allow rho > 1] logDet <- log(absValDet) LL <- log(t(y) %*% y - 2 * rhohat * t(y) %*% Wy + rhohat * rhohat * t(Wy) %*% Wy) - logDet*2/n return(LL) } GoldenSearch <- function(ax, cx) { # Golden section search over the interval ax to cx # Return rhohat and likelihood value. r <- 0.61803399 x0 <- ax x3 <- cx bx <- (ax + cx)/2 if(abs(cx - bx) > abs(bx - ax)) { x1 <- bx x2 <- bx + (1-r)*(cx - bx) } else { x2 <- bx x1 <- bx - (1-r)*(bx - ax) } f1 <- likelihood(x1) f2 <- likelihood(x2) while(abs(x3 - x0) > gold.tol*(abs(x1) + abs(x2))) { if(f2 < f1) { x0 <- x1 x1 <- x2 x2 <- r * x1 + (1 - r) * x3 f1 <- f2 f2 <- likelihood(x2) } else { x3 <- x2 x2 <- x1 x1 <- r * x2 + (1 - r) * x0 f2 <- f1 f1 <- likelihood(x1) } } if(f1 < f2) { likelihood <- f1 xmin <- x1 } else { likelihood <- f2 xmin <- x2 } return(list(rho=xmin, LL=likelihood)) } LL <- Inf for(ii in 2:(nDistinct -1)) {# Search between pairs of roots # [ constrain do not use positive roots < 1] ax <- 1/Distinct[ii] cx <- 1/Distinct[ii+1] GS <- GoldenSearch(ax, cx) if(GS$LL < LL) { LL <- GS$LL rho <- GS$rho } } # Compute residuals: res <- y - rho * Wy return(list(rhohat=rho, Wnorm=Wnorm, residuals=res)) } #For debugging: #W<- matrix(c( # 0,1,1,2,0,0,0,0, # 1,0,1,2,0,0,0,0, # 1,1,0,2,0,0,0,0, # 2,2,2,0,0,0,0,0, # 0,0,0,0,0,1,1,2, # 0,0,0,0,1,0,1,2, # 0,0,0,0,1,1,0,2, # 0,0,0,0,2,2,2,0 #),8) #W <- 1/W #W[W == Inf] <- 0 #y<-c(-0.12,0.36,-0.1,0.04,-0.15,0.29,-0.11,-0.06) #compar.cheverud(y,W) # #y<-c(10,8,3,4) #W <- matrix(c(1,1/6,1/6,1/6,1/6,1,1/2,1/2,1/6,1/2,1,1,1/6,1/2,1,1), 4) #compar.cheverud(y,W) ape/R/skylineplot.R0000644000175100001440000000321012465112403013730 0ustar hornikusers## skylineplot.R (2004-07-4) ## Various methods to plot skyline objects (= skyline plots) ## Copyright 2002-2004 Korbinian Strimmer ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. # plot skyline plot.skyline <- function(x, show.years=FALSE, subst.rate, present.year, ...) { if (class(x) != "skyline") stop("object \"x\" is not of class \"skyline\"") t <- x$time m <- x$population.size lm <- length(m) if (show.years) { plot((-c(0,t))/subst.rate+present.year,c(m,m[lm]),type="s", xlab="time (years)",ylab="effective population size",log="y", ...) } else { plot(c(0,t),c(m,m[lm]),type="s", xlim=c(t[lm],0), xlab="time (past to present in units of substitutions)",ylab="effective population size",log="y", ...) } } # plot another skyline plot on top lines.skyline <- function(x, show.years=FALSE, subst.rate, present.year, ...) { if (class(x) != "skyline") stop("object \"x\" is not of class \"skyline\"") t <- x$time m <- x$population.size lm <- length(m) if (show.years) { lines((-c(0,t))/subst.rate+present.year,c(m,m[lm]),type="s", ...) } else { lines(c(0,t),c(m,m[lm]),type="s", ...) } } # convenience short cut (almost compatible with APE 0.1) skylineplot <- function(z, ...) plot(skyline(z, ...)) #input: phylogenetic tree skylineplot.deluxe <- function(tree, ...) { if (class(tree) != "phylo") stop("object \"tree\" is not of class \"phylo\"") ci <- coalescent.intervals(tree) classic <- skyline(ci) generalized <- skyline(ci, -1) plot(classic,col=grey(.8), ...) lines(generalized, ...) return(generalized) } ape/R/def.R0000644000175100001440000000122312465112403012113 0ustar hornikusers## def.R (2014-10-24) ## Definition of Vectors for Plotting or Annotating ## Copyright 2014 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. def <- function(x, ..., default = NULL, regexp = FALSE) { dots <- list(...) if (is.null(default)) { if (is.numeric(dots[[1L]])) default <- 1 if (is.character(dots[[1L]])) default <- "black" } foo <- if (regexp) function(vec, y) grep(y, vec) else function(vec, y) which(vec == y) res <- rep(default, length(x)) nms <- names(dots) for (i in seq_along(nms)) res[foo(x, nms[i])] <- dots[[i]] res } ape/R/compar.lynch.R0000644000175100001440000000433412465112403013760 0ustar hornikusers## compar.lynch.R (2002-08-28) ## Lynch's Comparative Method ## Copyright 2002 Julien Claude ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. compar.lynch <- function(x, G, eps = 1e-4) { if (is.vector(x) || is.data.frame(x)) x <- as.matrix(x) alea <- runif(1, 0, 1) z <- as.vector(x) uz <- apply(x, 2, mean) vcvz <- var(x) vz <- diag(vcvz) nsp <- nrow(x) k <- ncol(x) X1 <- matrix(0, k, k) diag(X1) <- 1 I <- matrix(0, nsp, nsp) diag(I) <- 1 vara <- trvare <- matrix(NA, k, k) nsp1 <- rep(1, nsp) X <- X1 %x% nsp1 compteur <- 0 vara <- A0 <- alea * vcvz vare <- E0 <- (1 - alea) * vcvz newu <- u0 <- uz Ginv <- solve(G) V0 <- vcvz %x% G a0 <- e0 <- matrix(0, nsp, k) a1 <- e1 <- matrix(1, nsp, k) while (any(abs((rbind(a1, e1) - rbind(a0, e0))) > eps)) { a1 <- a0 e1 <- e0 compteur <- compteur + 1 Rinv <- solve(E0 %x% I) Dinv <- solve(A0 %x% G) info <- solve(Rinv + Dinv) newa <- solve(Rinv + Dinv) %*% Rinv %*% (z - X %*% u0) newe <- z - X %*% u0 - newa e0 <- mnewe <- matrix(newe, nsp, k) a0 <- mnewa <- matrix(newa, nsp, k) for (i in 1:k) { for (j in 1:k) { trvare[i, j] <- sum(diag(info[(((i - 1) * nsp) + 1):(i * nsp), (((j - 1) * nsp) + 1):(j * nsp)]))} } vare <- ((nsp - 1) * var(mnewe) + trvare) / nsp for (i in 1:k) { for (j in 1:k) { vara[i, j] <- (t(mnewa[, i]) %*% Ginv %*% mnewa[, j] + sum(diag(Ginv %*% info[(((i - 1) * nsp) + 1):(i * nsp), (((j - 1) * nsp) + 1):(j * nsp)]))) / nsp } } newu <- apply(x - mnewa, 2, mean) V <- vara %x% G + vare %x% I p <- (2 * pi)^(-nsp) * det(V)^(-0.5) * exp(-0.5 * t(z - (X %*% newu)) %*% solve(V) %*% (z - (X %*% newu))) E0 <- vare A0 <- vara u0 <- newu } dimnames(vare) <- dimnames(vara) list(vare = vare, vara = vara, A = mnewa, E = mnewe, u = newu, lik = log(p)) } ape/R/CDF.birth.death.R0000644000175100001440000005430512737133564014172 0ustar hornikusers## CDF.birth.death.R (2016-07-06) ## Functions to Simulate and Fit Time-Dependent Birth-Death Models ## Copyright 2010-2016 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. integrateTrapeze <- function(FUN, from, to, nint = 10) ## compute an integral with a simple trapeze method ## (apparently, Vectorize doesn't give faster calculation) { x <- seq(from = from, to = to, length.out = nint + 1) ## reorganized to minimize the calls to FUN: out <- FUN(x[1]) + FUN(x[length(x)]) for (i in 2:nint) out <- out + 2 * FUN(x[i]) (x[2] - x[1]) * out/2 # (x[2] - x[1]) is the width of the trapezes } ## case: ## 1: birth and death rates constant ## 2: no primitive available ## 3: primitives are available ## 4: death rate constant, no primitive available ## 5: birth rate constant, no primitive available ## 6: death rate constant, primitive available for birth(t) ## 7: birth rate constant, primitive available for death(t) .getCase <- function(birth, death, BIRTH = NULL, DEATH = NULL) { if (is.numeric(birth)) { if (is.numeric(death)) 1 else { if (is.null(DEATH)) 5 else 7 } } else { if (is.numeric(death)) { if (is.null(BIRTH)) 4 else 6 } else if (is.null(BIRTH) || is.null(DEATH)) 2 else 3 } } if(getRversion() >= "2.15.1") utils::globalVariables("Tmax") .getRHOetINT <- function(birth, death, BIRTH = NULL, DEATH = NULL, case, fast) { ## build the RHO(), \rho(t), and INT(), I(t), functions switch (case, { # case 1: RHO <- function(t1, t2) (t2 - t1)*(death - birth) INT <- function(t) { rho <- death - birth death*(exp(rho*(Tmax - t)) - 1)/rho } },{ # case 2: if (fast) { RHO <- function(t1, t2) integrateTrapeze(function(t) death(t) - birth(t), t1, t2) INT <- function(t) { FOO <- function(u) exp(RHO(t, u)) * death(u) integrateTrapeze(FOO, t, Tmax) } } else { RHO <- function(t1, t2) integrate(function(t) death(t) - birth(t), t1, t2)$value INT <- function(t) { FOO <- function(u) exp(RHO(t, u)) * death(u) integrate(Vectorize(FOO), t, Tmax)$value # Vectorize required } } },{ # case 3: RHO <- function(t1, t2) DEATH(t2) - BIRTH(t2) - DEATH(t1) + BIRTH(t1) INT <- function(t) { # vectorized FOO <- function(u) exp(RHO(tt, u)) * death(u) out <- t for (i in 1:length(t)) { tt <- t[i] out[i] <- integrate(FOO, tt, Tmax)$value } out } },{ # case 4: if (fast) { RHO <- function(t1, t2) death * (t2 - t1) - integrateTrapeze(birth, t1, t2) INT <- function(t) { FOO <- function(u) exp(RHO(t, u)) * death integrateTrapeze(Vectorize(FOO), t, Tmax) } } else { RHO <- function(t1, t2) death * (t2 - t1) - integrate(birth, t1, t2)$value INT <- function(t) { FOO <- function(u) exp(RHO(t, u)) * death integrate(Vectorize(FOO), t, Tmax)$value } } },{ # case 5: RHO <- function(t1, t2) integrate(death, t1, t2)$value - birth * (t2 - t1) if (fast) { INT <- function(t) { FOO <- function(u) exp(RHO(t, u)) * death(u) integrateTrapeze(FOO, t, Tmax) } } else { INT <- function(t) { FOO <- function(u) exp(RHO(t, u)) * death(u) integrate(Vectorize(FOO), t, Tmax)$value } } },{ # case 6: RHO <- function(t1, t2) death * (t2 - t1) - BIRTH(t2) + BIRTH(t1) INT <- function(t) { # vectorized FOO <- function(u) exp(RHO(tt, u)) * death out <- t for (i in 1:length(t)) { tt <- t[i] out[i] <- integrate(FOO, tt, Tmax)$value } out } },{ # case 7: RHO <- function(t1, t2) DEATH(t2) - DEATH(t1) - birth * (t2 - t1) if (fast) { INT <- function(t) { FOO <- function(u) exp(RHO(t, u)) * death(u) integrateTrapeze(FOO, t, Tmax) } } else { INT <- function(t) { FOO <- function(u) exp(RHO(t, u)) * death(u) integrate(Vectorize(FOO), t, Tmax)$value } } }) list(RHO, INT) } CDF.birth.death <- function(birth, death, BIRTH = NULL, DEATH = NULL, Tmax, x, case, fast = FALSE) { ff <- .getRHOetINT(birth, death, BIRTH, DEATH, case, fast) RHO <- ff[[1]] INT <- ff[[2]] environment(INT) <- environment() # so that INT() can find Tmax .CDF.birth.death2(RHO, INT, birth, death, BIRTH, DEATH, Tmax, x, case, fast) } .CDF.birth.death2 <- function(RHO, INT, birth, death, BIRTH, DEATH, Tmax, x, case, fast) { Pi <- if (case %in% c(1, 5, 7)) function(t) (1/(1 + INT(t)))^2 * 2 * exp(-RHO(0, t)) * birth else function(t) (1/(1 + INT(t)))^2 * 2 * exp(-RHO(0, t)) * birth(t) if (!case %in% c(1, 3, 6)) Pi <- Vectorize(Pi) denom <- if (fast) integrateTrapeze(Pi, 0, Tmax) else integrate(Pi, 0, Tmax)$value n <- length(x) p <- numeric(n) if (fast) { for (i in 1:n) p[i] <- integrateTrapeze(Pi, 0, x[i]) } else { for (i in 1:n) p[i] <- integrate(Pi, 0, x[i])$value } p/denom } .makePhylo <- function(edge, edge.length, i) { NODES <- edge > 0 edge[NODES] <- edge[NODES] + i + 1L edge[!NODES] <- 1:(i + 1L) phy <- list(edge = edge, edge.length = edge.length, tip.label = paste("t", 1:(i + 1), sep = ""), Nnode = i) class(phy) <- "phylo" attr(phy, "order") <- "cladewise" phy } rlineage <- function(birth, death, Tmax = 50, BIRTH = NULL, DEATH = NULL, eps = 1e-6) { case <- .getCase(birth, death, BIRTH, DEATH) rTimeToEvent <- function(t) { ## CDF of the times to event (speciation or extinction): switch (case, { # case 1: Foo <- function(t, x) 1 - exp(-(birth + death)*(x - t)) },{ # case 2: Foo <- function(t, x) { if (t == x) return(0) 1 - exp(-integrate(function(t) birth(t) + death(t), t, x)$value) } },{ # case 3: Foo <- function(t, x) { if (t == x) return(0) 1 - exp(-(BIRTH(x) - BIRTH(t) + DEATH(x) - DEATH(t))) } },{ # case 4: Foo <- function(t, x) { if (t == x) return(0) 1 - exp(-(integrate(function(t) birth(t), t, x)$value + death*(x - t))) } },{ # case 5: Foo <- function(t, x) { if (t == x) return(0) 1 - exp(-(birth*(x - t) + integrate(function(t) death(t), t, x)$value)) } },{ # case 6: Foo <- function(t, x) { if (t == x) return(0) 1 - exp(-(BIRTH(x) - BIRTH(t) + death*(x - t))) } },{ # case 7: Foo <- function(t, x) { if (t == x) return(0) 1 - exp(-(birth*(x - t) + DEATH(x) - DEATH(t))) } }) ## generate a random time to event by the inverse method: P <- runif(1) ## in case speciation probability is so low ## that time to speciation is infinite: if (Foo(t, Tmax) < P) return(Tmax + 1) inc <- 10 x <- t + inc while (inc > eps) { # la precision influe sur le temps de calcul if (Foo(t, x) > P) { x <- x - inc inc <- inc/10 } else x <- x + inc } x - t } if (case == 1) speORext <- function(t) birth/(birth + death) if (case == 2 || case == 3) speORext <- function(t) birth(t)/(birth(t) + death(t)) if (case == 4 || case == 6) speORext <- function(t) birth(t)/(birth(t) + death) if (case == 5 || case == 7) speORext <- function(t) birth/(birth + death(t)) ## the recursive function implementing algorithm 1 foo <- function(node) { for (k in 0:1) { X <- rTimeToEvent(t[node]) tmp <- t[node] + X ## is the event a speciation or an extinction? if (tmp >= Tmax) { Y <- 0 tmp <- Tmax } else Y <- rbinom(1, size = 1, prob = speORext(tmp)) j <<- j + 1L edge.length[j] <<- tmp - t[node] if (Y) { i <<- i + 1L t[i] <<- tmp ## set internal edge: edge[j, ] <<- c(node, i) foo(i) } else ## set terminal edge: edge[j, ] <<- c(node, 0L) } } edge <- matrix(0L, 1e5, 2) edge.length <- numeric(1e5) j <- 0L; i <- 1; t <- 0 foo(1L) .makePhylo(edge[1:j, ], edge.length[1:j], i) } drop.fossil <- function(phy, tol = 1e-8) { n <- Ntip(phy) x <- dist.nodes(phy)[n + 1, ][1:n] drop.tip(phy, which(x < max(x) - tol)) } rbdtree <- function(birth, death, Tmax = 50, BIRTH = NULL, DEATH = NULL, eps = 1e-6) { case <- .getCase(birth, death, BIRTH, DEATH) ff <- .getRHOetINT(birth, death, BIRTH, DEATH, case, FALSE) RHO <- ff[[1]] INT <- ff[[2]] ## so that RHO() and INT() can find Tmax: environment(RHO) <- environment(INT) <- environment() rtimetospe <- function(t) { ## CDF of the times to speciation: Foo <- if (case %in% c(1, 5, 7)) function(t, x) 1 - exp(-birth*(x - t)) else { if (case %in% c(3, 6)) function(t, x) 1 - exp(-(BIRTH(x) - BIRTH(t))) else { function(t, x) { if (t == x) return(0) 1 - exp(-integrate(birth, t, x)$value) } } } ## generate a random time to speciation by the inverse method: P <- runif(1) ## in case speciation probability is so low ## that time to speciation is infinite: if (Foo(t, Tmax) < P) return(Tmax + 1) inc <- 10 x <- t + inc while (inc > eps) { # la precision influe sur le temps de calcul if (Foo(t, x) > P) { x <- x - inc inc <- inc/10 } else x <- x + inc } x - t } ## the recursive function implementing algorithm 2 foo <- function(node, start) { node <- node # make a local copy for (k in 0:1) { tau <- start # because tau is changed below NoDesc <- TRUE X <- rtimetospe(tau) while (X < Tmax - tau) { tau <- tau + X ## does the new lineage survive until Tmax? Y <- rbinom(1, size = 1, prob = 1/(1 + INT(tau))) if (Y) { i <<- i + 1L t[i] <<- tau ## set internal edge: j <<- j + 1L edge[j, ] <<- c(node, i) edge.length[j] <<- tau - t[node] foo(i, t[i]) NoDesc <- FALSE break } X <- rtimetospe(tau) } ## set terminal edge: if (NoDesc) { j <<- j + 1L edge[j, 1] <<- node # the 2nd column is already set to 0 edge.length[j] <<- Tmax - t[node] } } } edge <- matrix(0L, 1e5, 2) edge.length <- numeric(1e5) j <- 0L; i <- 1L; t <- 0 foo(1L, 0) .makePhylo(edge[1:j, ], edge.length[1:j], i) } bd.time <- function(phy, birth, death, BIRTH = NULL, DEATH = NULL, ip, lower, upper, fast = FALSE, boot = 0, trace = 0) { guess.bounds <- if (missing(lower)) TRUE else FALSE BIG <- 1e10 PrNt <- function(t, T, x) { tmp <- exp(-RHO(t, T)) Wt <- tmp * (1 + INT(t)) out <- numeric(length(x)) zero <- x == 0 if (length(zero)) { out[zero] <- 1 - tmp/Wt out[!zero] <- (tmp/Wt^2)*(1 - 1/Wt)^(x[!zero] - 1) } else out[] <- (tmp/Wt^2)*(1 - 1/Wt)^(x - 1) out } case <- .getCase(birth, death, BIRTH, DEATH) if (is.function(birth)) { paranam <- names(formals(birth)) if (guess.bounds) { upper <- rep(BIG, length(paranam)) lower <- -upper } formals(birth) <- alist(t=) environment(birth) <- environment() if (!is.null(BIRTH)) environment(BIRTH) <- environment() } else { paranam <- "birth" if (guess.bounds) { upper <- 1 lower <- 0 } } if (is.function(death)) { tmp <- names(formals(death)) np2 <- length(tmp) if (guess.bounds) { upper <- c(upper, rep(BIG, np2)) lower <- c(lower, rep(-BIG, np2)) } paranam <- c(paranam, tmp) formals(death) <- alist(t=) environment(death) <- environment() if (!is.null(DEATH)) environment(DEATH) <- environment() } else { paranam <- c(paranam, "death") if (guess.bounds) { upper <- c(upper, .1) lower <- c(lower, 0) } } np <- length(paranam) ff <- .getRHOetINT(birth, death, BIRTH, DEATH, case = case, fast = fast) RHO <- ff[[1]] INT <- ff[[2]] environment(RHO) <- environment(INT) <- environment() x <- branching.times(phy) n <- length(x) Tmax <- x[1] x <- Tmax - x # change the time scale so the root is t=0 x <- sort(x) foo <- function(para) { for (i in 1:np) assign(paranam[i], para[i], pos = sys.frame(1)) p <- CDF.birth.death(birth, death, BIRTH, DEATH, Tmax = Tmax, x = x, case = case, fast = fast) ## w is the probability of the observed tree size (= number of tips) w <- PrNt(0, Tmax, Ntip(phy)) ## p is the expected CDF of branching times ## ecdf(x)(x) is the observed CDF sum((1:n/n - p)^2)/w # faster than sum((ecdf(x)(x) - p)^2)/w } if (missing(ip)) ip <- (upper - lower)/2 out <- nlminb(ip, foo, control = list(trace = trace, eval.max = 500), upper = upper, lower = lower) names(out$par) <- paranam names(out)[2] <- "SS" if (boot) { # nonparametric version PAR <- matrix(NA, boot, np) i <- 1L while (i <= boot) { cat("\rDoing bootstrap no.", i, "\n") x <- sort(sample(x, replace = TRUE)) o <- try(nlminb(ip, foo, control = list(trace = 0, eval.max = 500), upper = upper, lower = lower)) if (class(o) == "list") { PAR[i, ] <- o$par i <- i + 1L } } out$boot <- PAR } out } LTT <- function(birth = 0.1, death = 0, N = 100, Tmax = 50, PI = 95, scaled = TRUE, eps = 0.1, add = FALSE, backward = TRUE, ltt.style = list("black", 1, 1), pi.style = list("blue", 1, 2)) { case <- .getCase(birth, death, NULL, NULL) Time <- seq(0, Tmax, eps) F <- CDF.birth.death(birth, death, BIRTH = NULL, DEATH = NULL, Tmax = Tmax, x = Time, case = case, fast = TRUE) if (PI) { i <- (1 - PI/100)/2 Flow <- qbinom(i, N - 2, F) Fup <- qbinom(1 - i, N - 2, F) if (scaled) { Flow <- Flow/N Fup <- Fup/N } } if (!scaled) F <- F * N if (backward) Time <- Time - Tmax if (add) lines(Time, F, "l", col = ltt.style[[1]], lwd = ltt.style[[2]], lty = ltt.style[[3]]) else plot(Time, F, "l", col = ltt.style[[1]], lwd = ltt.style[[2]], lty = ltt.style[[3]], ylab = "Number of lineages") if (PI) lines(c(Time, NA, Time), c(Flow, NA, Fup), col = pi.style[[1]], lwd = pi.style[[2]], lty = pi.style[[3]]) } rphylo <- function(n, birth, death, BIRTH = NULL, DEATH = NULL, T0 = 50, fossils = FALSE, eps = 1e-6) { case <- .getCase(birth, death, BIRTH, DEATH) ## Foo(): CDF of the times to event (speciation or extinction) ## rTimeToEvent(): generate a random time to event by the inverse method switch(case, { # case 1: rTimeToEvent <- function(t) t - rexp(1, N * (birth + death)) # much faster than using Foo() speORext <- function(t) birth/(birth + death) ## Foo <- function(t, x) ## 1 - exp(-N*(birth + death)*(x - t)) },{ # case 2: Foo <- function(t, x) { if (t == x) return(0) 1 - exp(-integrate(function(t) birth(t) + death(t), t, x)$value * N) } speORext <- function(t) birth(t)/(birth(t) + death(t)) },{ # case 3: Foo <- function(t, x) { if (t == x) return(0) 1 - exp(-N*(BIRTH(x) - BIRTH(t) + DEATH(x) - DEATH(t))) } speORext <- function(t) birth(t)/(birth(t) + death(t)) },{ # case 4: Foo <- function(t, x) { if (t == x) return(0) 1 - exp(-N*(integrate(function(t) birth(t), t, x)$value + death*(x - t))) } speORext <- function(t) birth(t)/(birth(t) + death) },{ # case 5: Foo <- function(t, x) { if (t == x) return(0) 1 - exp(-N*(birth*(x - t) + integrate(function(t) death(t), t, x)$value)) } speORext <- function(t) birth/(birth + death(t)) },{ # case 6: Foo <- function(t, x) { if (t == x) return(0) 1 - exp(-N*(BIRTH(x) - BIRTH(t) + death*(x - t))) } speORext <- function(t) birth(t)/(birth(t) + death) },{ # case 7: Foo <- function(t, x) { if (t == x) return(0) 1 - exp(-N*(birth*(x - t) + DEATH(x) - DEATH(t))) } speORext <- function(t) birth/(birth + death(t)) }) if (case != 1) { rTimeToEvent <- function(t) { P <- runif(1) inc <- 10 x <- t - inc while (inc > eps) { if (Foo(t, x) > P) { # fixed by Niko Yasui (2016-07-06) x <- x + inc inc <- inc/10 } x <- x - inc } x } } storage.mode(n) <- "integer" N <- n t <- T0 j <- 0L # number of edges already created POOL <- seq_len(N) # initial pool (only tips at start) if (!fossils) { Nedge <- 2L * N - 2L nextnode <- 2L * N - 1L e1 <- integer(Nedge) e2 <- integer(Nedge) TIME <- numeric(nextnode) # record the times TIME[POOL] <- T0 # the times of the n tips are the present time while (j < Nedge) { X <- rTimeToEvent(t) ## is the event a speciation or an extinction? Y <- rbinom(1, size = 1, prob = speORext(X)) if (Y) { # speciation i <- sample.int(N, 2) fossil <- POOL[i] == 0 if (any(fossil)) { ## we drop the fossil lineage, or the first one if both are fossils POOL <- POOL[-i[which(fossil)[1]]] } else { # create a node and an edge j <- j + 2L k <- c(j - 1, j) e1[k] <- nextnode e2[k] <- POOL[i] TIME[nextnode] <- X POOL <- c(POOL[-i], nextnode) nextnode <- nextnode - 1L } N <- N - 1L } else { # extinction => create a tip, store it in POOL but don't create an edge ## fossil lineages are numbered 0 to find them if Y = 1 N <- N + 1L POOL <- c(POOL, 0L) } t <- X } Nnode <- n - 1L } else { # fossils = TRUE nextnode <- -1L # nodes are numbered with negatives nexttip <- N + 1L # tips are numbered with positives e1 <- integer(1e5) e2 <- integer(1e5) time.tips <- numeric(1e5) # accessed with positive indices time.nodes <- numeric(1e5) # accessed with negative indices time.tips[POOL] <- T0 # the times of the n living tips are the present time while (N > 1) { X <- rTimeToEvent(t) ## is the event a speciation or an extinction? Y <- rbinom(1, size = 1, prob = speORext(X)) if (Y) { # speciation => create a node i <- sample.int(N, 2) j <- j + 2L k <- c(j - 1, j) e1[k] <- nextnode e2[k] <- POOL[i] time.nodes[-nextnode] <- X POOL <- c(POOL[-i], nextnode) nextnode <- nextnode - 1L N <- N - 1L } else { # extinction => create a tip N <- N + 1L time.tips[nexttip] <- X POOL <- c(POOL, nexttip) nexttip <- nexttip + 1L } t <- X } n <- nexttip - 1L # update n Nnode <- n - 1L EDGE <- seq_len(j) e1 <- e1[EDGE] e2 <- e2[EDGE] e1 <- e1 + n + Nnode + 1L # e1 has only nodes... NODES <- e2 < 0 # ... so this is needed only on e2 e2[NODES] <- e2[NODES] + n + Nnode + 1L ## concatenate the vectors of times after dropping the extra 0's: TIME <- c(time.tips[seq_len(n)], rev(time.nodes[seq_len(Nnode)])) } obj <- list(edge = cbind(e1, e2, deparse.level = 0), edge.length = TIME[e2] - TIME[e1], tip.label = paste0("t", seq_len(n)), Nnode = Nnode) class(obj) <- "phylo" reorder(obj) } ape/R/gammaStat.R0000644000175100001440000000115012465112403013272 0ustar hornikusers## gammaStat.R (2009-05-10) ## Gamma-Statistic of Pybus and Harvey ## Copyright 2002-2009 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. gammaStat <- function(phy) { if (!inherits(phy, "phylo")) stop('object "phy" is not of class "phylo"') N <- length(phy$tip.label) bt <- sort(branching.times(phy)) g <- rev(c(bt[1], diff(bt))) # internode intervals are from past to present ST <- sum((2:N) * g) stat <- sum(cumsum((2:(N - 1)) * g[-(N - 1)]))/(N - 2) m <- ST/2 s <- ST * sqrt(1/(12 * (N - 2))) (stat - m)/s } ape/R/chronopl.R0000644000175100001440000002172412465112403013211 0ustar hornikusers## chronopl.R (2012-02-09) ## Molecular Dating With Penalized Likelihood ## Copyright 2005-2012 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. chronopl <- function(phy, lambda, age.min = 1, age.max = NULL, node = "root", S = 1, tol = 1e-8, CV = FALSE, eval.max = 500, iter.max = 500, ...) { n <- length(phy$tip.label) ROOT <- n + 1L if (identical(node, "root")) node <- ROOT if (any(node <= n)) stop("node numbers should be greater than the number of tips") zerobl <- which(phy$edge.length <= 0) if (length(zerobl)) { if (any(phy$edge[zerobl, 2] <= n)) stop("at least one terminal branch is of length zero: you should remove it to have a meaningful estimation.") else { warning("at least one internal branch is of length zero: it was collapsed and some nodes have been deleted.") if (length(node) == 1 && node == ROOT) phy <- di2multi(phy) else { tmp <- FALSE if (is.null(phy$node.label)) { tmp <- !tmp phy$node.label <- paste("node", 1:phy$Nnode) } node.lab <- phy$node.label[node - n] phy <- di2multi(phy) node <- match(node.lab, phy$node.label) + n if (tmp) phy$node.label <- NULL } } } m <- phy$Nnode el <- phy$edge.length e1 <- phy$edge[, 1L] e2 <- phy$edge[, 2L] N <- length(e1) TIPS <- 1:n EDGES <- 1:N ini.rate <- el el <- el/S ## `basal' contains the indices of the basal edges ## (ie, linked to the root): basal <- which(e1 == ROOT) Nbasal <- length(basal) ## `ind' contains in its 1st column the index of all nonbasal ## edges, and in its second column the index of the edges ## where these edges come from (ie, this matrix contains pairs ## of contiguous edges), eg: ## ___b___ ind: ## | | | | ## ___a___| | b | a | ## | | c | a | ## |___c___ | | | ind <- matrix(0L, N - Nbasal, 2) ind[, 1] <- EDGES[-basal] ind[, 2] <- match(e1[EDGES[-basal]], e2) age <- numeric(n + m) ############################################################################# ### This bit sets 'ini.time' and should result in no negative branch lengths seq.nod <- .Call("seq_root2tip", phy$edge, n, phy$Nnode, PACKAGE = "ape") ini.time <- age ini.time[ROOT:(n + m)] <- NA ini.time[node] <- if (is.null(age.max)) age.min else (age.min + age.max) / 2 ## if no age given for the root, find one approximately: if (is.na(ini.time[ROOT])) ini.time[ROOT] <- if (is.null(age.max)) 3 * max(age.min) else 3 * max(age.max) ISnotNA.ALL <- unlist(lapply(seq.nod, function(x) sum(!is.na(ini.time[x])))) o <- order(ISnotNA.ALL, decreasing = TRUE) for (y in seq.nod[o]) { ISNA <- is.na(ini.time[y]) if (any(ISNA)) { i <- 2L # we know the 1st value is not NA, so we start at the 2nd one while (i <= length(y)) { if (ISNA[i]) { # we stop at the next NA j <- i + 1L while (ISNA[j]) j <- j + 1L # look for the next non-NA nb.val <- j - i by <- (ini.time[y[i - 1L]] - ini.time[y[j]]) / (nb.val + 1) ini.time[y[i:(j - 1L)]] <- ini.time[y[i - 1L]] - by * seq_len(nb.val) i <- j + 1L } else i <- i + 1L } } } real.edge.length <- ini.time[e1] - ini.time[e2] if (any(real.edge.length <= 0)) stop("some initial branch lengths are zero or negative; maybe you need to adjust the given dates -- see '?chronopl' for details") ############################################################################# ## because if (!is.null(age.max)), 'node' is modified, ## so we copy it in case CV = TRUE: node.bak <- node ## `unknown.ages' will contain the index of the nodes of unknown age: unknown.ages <- n + 1:m ## define the bounds for the node ages: lower <- rep(tol, length(unknown.ages)) upper <- rep(1/tol, length(unknown.ages)) if (!is.null(age.max)) { # are some nodes known within some intervals? lower[node - n] <- age.min upper[node - n] <- age.max ## find nodes known within an interval: interv <- which(age.min != age.max) ## drop them from the 'node' since they will be estimated: node <- node[-interv] if (length(node)) age[node] <- age.min[-interv] # update 'age' } else age[node] <- age.min if (length(node)) { unknown.ages <- unknown.ages[n - node] # 'n - node' is simplification for '-(node - n)' lower <- lower[n - node] upper <- upper[n - node] } ## `known.ages' contains the index of all nodes (internal and ## terminal) of known age: known.ages <- c(TIPS, node) ## concatenate the bounds for the rates: lower <- c(rep(tol, N), lower) upper <- c(rep(1 - tol, N), upper) minusploglik.gr <- function(rate, node.time) { grad <- numeric(N + length(unknown.ages)) age[unknown.ages] <- node.time real.edge.length <- age[e1] - age[e2] if (any(real.edge.length < 0)) { grad[] <- 0 return(grad) } ## gradient for the rates: ## the parametric part can be calculated without a loop: grad[EDGES] <- real.edge.length - el/rate if (Nbasal == 2) { # the simpler formulae if there's a basal dichotomy grad[basal[1]] <- grad[basal[1]] + lambda*(rate[basal[1]] - rate[basal[2]]) grad[basal[2]] <- grad[basal[2]] + lambda*(rate[basal[2]] - rate[basal[1]]) } else { # the general case for (i in 1:Nbasal) grad[basal[i]] <- grad[basal[i]] + lambda*(2*rate[basal[i]]*(1 - 1/Nbasal) - 2*sum(rate[basal[-i]])/Nbasal)/(Nbasal - 1) } for (i in EDGES) { ii <- c(which(e2 == e1[i]), which(e1 == e2[i])) if (!length(ii)) next grad[i] <- grad[i] + lambda*(2*length(ii)*rate[i] - 2*sum(rate[ii])) } ## gradient for the 'node times' for (i in 1:length(unknown.ages)) { nd <- unknown.ages[i] ii <- which(e1 == nd) grad[i + N] <- sum(rate[ii] - el[ii]/real.edge.length[ii])#, na.rm = TRUE) if (nd != ROOT) { ii <- which(e2 == nd) grad[i + N] <- grad[i + N] - rate[ii] + el[ii]/real.edge.length[ii] } } grad } minusploglik <- function(rate, node.time) { age[unknown.ages] <- node.time real.edge.length <- age[e1] - age[e2] if (any(real.edge.length < 0)) return(1e50) B <- rate*real.edge.length loglik <- sum(-B + el*log(B) - lfactorial(el)) -(loglik - lambda*(sum((rate[ind[, 1]] - rate[ind[, 2]])^2) + var(rate[basal]))) } out <- nlminb(c(ini.rate, ini.time[unknown.ages]), function(p) minusploglik(p[EDGES], p[-EDGES]), function(p) minusploglik.gr(p[EDGES], p[-EDGES]), control = list(eval.max = eval.max, iter.max = iter.max, ...), lower = lower, upper = upper) attr(phy, "ploglik") <- -out$objective attr(phy, "rates") <- out$par[EDGES] attr(phy, "message") <- out$message age[unknown.ages] <- out$par[-EDGES] if (CV) ophy <- phy phy$edge.length <- age[e1] - age[e2] if (CV) attr(phy, "D2") <- chronopl.cv(ophy, lambda, age.min, age.max, node.bak, n, S, tol, eval.max, iter.max, ...) phy } chronopl.cv <- function(ophy, lambda, age.min, age.max, nodes, n, S, tol, eval.max, iter.max, ...) ### ophy: the original phylogeny ### n: number of tips ### Note that we assume here that the order of the nodes ### in node.label are not modified by the drop.tip operation { cat("Doing cross-validation\n") BT <- branching.times(ophy) D2 <- numeric(n) for (i in 1:n) { cat("\r dropping tip ", i, " / ", n, sep = "") tr <- drop.tip(ophy, i) j <- which(ophy$edge[, 2] == i) if (ophy$edge[j, 1] %in% nodes) { k <- which(nodes == ophy$edge[j, 1]) node <- nodes[-k] agemin <- age.min[-k] agemax <- age.max[-k] } else node <- nodes if (length(node)) { chr <- chronopl(tr, lambda, age.min, age.max, node, S, tol, FALSE, eval.max, iter.max, ...) tmp <- if (Nnode(chr) == Nnode(ophy)) BT else BT[-(ophy$edge[j, 1] - n)] D2[i] <- sum((tmp - branching.times(chr))^2 / tmp) } else D2[i] <- 0 } cat("\n") D2 } ape/R/cophyloplot.R0000644000175100001440000001650712465112403013744 0ustar hornikusers## cophyloplot.R (2014-04-07) ## Plots two phylogenetic trees face to ## face with the links between the tips ## Copyright 2008-2010 Damien de Vienne ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. cophyloplot <- function(x, y, assoc = NULL, use.edge.length = FALSE, space = 0, length.line = 1, gap = 2, type = "phylogram", rotate = FALSE, col = par("fg"), lwd = par("lwd"), lty = par("lty"), show.tip.label = TRUE, font = 3, ...) { if (is.null(assoc)) { assoc <- matrix(ncol = 2) print("No association matrix specified. Links will be omitted.") } if (rotate == TRUE) { cat("\n Click on a node to rotate (right click to exit)\n\n") repeat { res <- plotCophylo2(x, y, assoc = assoc, use.edge.length = use.edge.length, space = space, length.line = length.line, gap = gap, type = type, return = TRUE, col = col, lwd=lwd, lty=lty, show.tip.label = show.tip.label, font = font) click <- identify(res$c[, 1], res$c[, 2], n = 1) if (click < length(res$a[, 1]) + 1) { if (click > res$N.tip.x) x <- rotate(x, click) } else if (click < length(res$c[, 1]) + 1) { if (click > length(res$a[, 1]) + res$N.tip.y) y <- rotate(y, click - length(res$a[, 1])) } } on.exit(cat("done\n")) } else plotCophylo2(x, y, assoc = assoc, use.edge.length = use.edge.length, space = space, length.line = length.line, gap = gap, type = type, return = FALSE, col = col, lwd=lwd, lty=lty, show.tip.label = show.tip.label, font = font) } plotCophylo2 <- function(x, y, assoc = assoc, use.edge.length = use.edge.length, space = space, length.line = length.line, gap = gap, type = type, return = return, col = col, lwd=lwd, lty=lty, show.tip.label = show.tip.label, font = font, ...) { res <- list() ###choice of the minimum space between the trees left <- max(nchar(x$tip.label, type = "width")) + length.line right <- max(nchar(y$tip.label, type = "width")) + length.line space.min <- left + right + gap * 2 if ((space <= 0) || (space < space.min)) space <- space.min N.tip.x <- Ntip(x) N.tip.y <- Ntip(y) res$N.tip.x <- N.tip.x res$N.tip.y <- N.tip.y a <- plotPhyloCoor(x, use.edge.length = use.edge.length, type = type) res$a <- a b <- plotPhyloCoor(y, use.edge.length = use.edge.length, direction = "leftwards", type = type) ###for the two trees to have the extreme leaves at the same ordinate. a[, 2] <- a[, 2] - min(a[, 2]) b[, 2] <- b[, 2] - min(b[, 2]) res$b <- b b2 <- b b2[, 1] <- b[1:nrow(b), 1] * (max(a[, 1])/max(b[, 1])) + space + max(a[, 1]) b2[, 2] <- b[1:nrow(b), 2] * (max(a[, 2])/max(b[, 2])) res$b2 <- b2 c <- matrix(ncol = 2, nrow = nrow(a) + nrow(b)) c[1:nrow(a), ] <- a[1:nrow(a), ] c[nrow(a) + 1:nrow(b), 1] <- b2[, 1] c[nrow(a) + 1:nrow(b), 2] <- b2[, 2] res$c <- c plot(c, type = "n", xlim = NULL, ylim = NULL, log = "", main = NULL, sub = NULL, xlab = NULL, ylab = NULL, ann = FALSE, axes = FALSE, frame.plot = FALSE) ###segments for cladograms if (type == "cladogram") { for (i in 1:(nrow(a) - 1)) segments(a[x$edge[i, 1], 1], a[x$edge[i, 1], 2], a[x$edge[i, 2], 1], a[x$edge[i, 2], 2], col="red") for (i in 1:(nrow(b) - 1)) segments(b2[y$edge[i, 1], 1], b2[y$edge[i, 1], 2], b2[y$edge[i, 2], 1], b2[y$edge[i, 2], 2]) } ###segments for phylograms if (type == "phylogram") { for (i in (N.tip.x + 1):nrow(a)) { l <- length(x$edge[x$edge[, 1] == i, ][, 1]) for (j in 1:l) { segments(a[x$edge[x$edge[, 1] == i, ][1, 1], 1], a[x$edge[x$edge[, 1] == i, 2], 2][1], a[x$edge[x$edge[, 1] == i, ][1, 1], 1], a[x$edge[x$edge[, 1] == i, 2], 2][j]) segments(a[x$edge[x$edge[, 1] == i, ][1, 1], 1], a[x$edge[x$edge[, 1] == i, 2], 2][j], a[x$edge[x$edge[, 1] == i, 2], 1][j], a[x$edge[x$edge[, 1] == i, 2], 2][j]) } } for (i in (N.tip.y + 1):nrow(b)) { l <- length(y$edge[y$edge[, 1] == i, ][, 1]) for (j in 1:l) { segments(b2[y$edge[y$edge[, 1] == i, ][1, 1], 1], b2[y$edge[y$edge[, 1] == i, 2], 2][1], b2[y$edge[y$edge[, 1] == i, ][1, 1], 1], b2[y$edge[y$edge[, 1] == i, 2], 2][j]) segments(b2[y$edge[y$edge[, 1] == i, ][1, 1], 1], b2[y$edge[y$edge[, 1] == i, 2], 2][j], b2[y$edge[y$edge[, 1] == i, 2], 1][j], b2[y$edge[y$edge[, 1] == i, 2], 2][j]) } } } if (show.tip.label) { text(a[1:N.tip.x, ], cex = 0, font = font, pos = 4, labels = x$tip.label) text(b2[1:N.tip.y, ], cex = 1, font = font, pos = 2, labels = y$tip.label) } ###links between associated taxa. Takes into account the size of the character strings of the taxa names. lsa <- 1:N.tip.x lsb <- 1:N.tip.y decx <- array(nrow(assoc)) decy <- array(nrow(assoc)) #colors if (length(col)==1) colors<-c(rep(col, nrow(assoc))) else if (length(col)>=nrow(assoc)) colors<-col else colors<-c(rep(col, as.integer(nrow(assoc)/length(col))+1)) #lwd if (length(lwd)==1) lwidths<-c(rep(lwd, nrow(assoc))) else if (length(lwd)>=nrow(assoc)) lwidths<-lwd else lwidths<-c(rep(lwd, as.integer(nrow(assoc)/length(lwd))+1)) #lty if (length(lty) == 1) ltype <- c(rep(lty, nrow(assoc))) else if (length(lty) >= nrow(assoc)) ltype <- lty else ltype <- c(rep(lty, as.integer(nrow(assoc)/length(lty))+1)) for (i in 1:nrow(assoc)) { if (show.tip.label) { decx[i] <- strwidth(x$tip.label[lsa[x$tip.label == assoc[i, 1]]]) decy[i] <- strwidth(y$tip.label[lsb[y$tip.label == assoc[i, 2]]]) } else { decx[i] <- decy[i] <- 0 } if (length.line) { # added by EP (2014-04-07) segments(a[lsa[x$tip.label == assoc[i, 1]], 1] + decx[i] + gap, a[lsa[x$tip.label == assoc[i, 1]], 2], a[lsa[x$tip.label == assoc[i, 1]], 1] + gap + left, a[lsa[x$tip.label == assoc[i, 1]], 2], col = colors[i], lwd = lwidths[i], lty = ltype[i]) segments(b2[lsb[y$tip.label == assoc[i, 2]], 1] - (decy[i] + gap), b2[lsb[y$tip.label == assoc[i, 2]], 2], b2[lsb[y$tip.label == assoc[i, 2]], 1] - (gap + right), b2[lsb[y$tip.label == assoc[i, 2]], 2], col = colors[i], lwd = lwidths[i], lty = ltype[i]) } segments(a[lsa[x$tip.label == assoc[i, 1]], 1] + gap + left, a[lsa[x$tip.label == assoc[i, 1]], 2], b2[lsb[y$tip.label == assoc[i, 2]], 1] - (gap + right), b2[lsb[y$tip.label == assoc[i, 2]], 2], col = colors[i], lwd = lwidths[i], lty = ltype[i]) } if (return == TRUE) return(res) } ape/R/corphylo.R0000644000175100001440000002434312520630121013216 0ustar hornikusers## corphylo.R (2015-05-01) ## Ancestral Character Estimation ## Copyright 2015 Anthony R. Ives ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. corphylo <- function(X, U = list(), SeM = NULL, phy = NULL, REML = TRUE, method = c("Nelder-Mead", "SANN"), constrain.d = FALSE, reltol = 10^-6, maxit.NM = 1000, maxit.SA = 1000, temp.SA = 1, tmax.SA = 1, verbose = FALSE) { # Begin corphylo.LL corphylo.LL <- function(par, XX, UU, MM, tau, Vphy, REML, constrain.d, verbose) { n <- nrow(X) p <- ncol(X) L.elements <- par[1:(p + p * (p - 1)/2)] L <- matrix(0, nrow = p, ncol = p) L[lower.tri(L, diag = T)] <- L.elements R <- t(L) %*% L if (constrain.d == TRUE) { logit.d <- par[(p + p * (p - 1)/2 + 1):length(par)] if (max(abs(logit.d)) > 10) return(10^10) d <- 1/(1 + exp(-logit.d)) } else { d <- par[(p + p * (p - 1)/2 + 1):length(par)] if (max(d) > 10) return(10^10) } # OU transform C <- matrix(0, nrow = p * n, ncol = p * n) for (i in 1:p) for (j in 1:p) { Cd <- (d[i]^tau * (d[j]^t(tau)) * (1 - (d[i] * d[j])^Vphy))/(1 - d[i] * d[j]) C[(n * (i - 1) + 1):(i * n), (n * (j - 1) + 1):(j * n)] <- R[i, j] * Cd } V <- C + diag(as.numeric(MM)) if (is.nan(rcond(V)) || rcond(V) < 10^-10) return(10^10) iV <- solve(V) denom <- t(UU) %*% iV %*% UU if (is.nan(rcond(denom)) || rcond(denom) < 10^-10) return(10^10) num <- t(UU) %*% iV %*% XX B <- solve(denom, num) B <- as.matrix(B) H <- XX - UU %*% B logdetV <- -determinant(iV)$modulus[1] if (is.infinite(logdetV)) return(10^10) if (REML == TRUE) { # REML likelihood function LL <- 0.5 * (logdetV + determinant(t(UU) %*% iV %*% UU)$modulus[1] + t(H) %*% iV %*% H) } else { # ML likelihood function LL <- 0.5 * (logdetV + t(H) %*% iV %*% H) } if (verbose == T) show(c(as.numeric(LL), par)) return(as.numeric(LL)) } # End corphylo.LL # Main program if (!inherits(phy, "phylo")) stop("Object \"phy\" is not of class \"phylo\".") if (is.null(phy$edge.length)) stop("The tree has no branch lengths.") if (is.null(phy$tip.label)) stop("The tree has no tip labels.") phy <- reorder(phy, "postorder") n <- length(phy$tip.label) # Input X if (dim(X)[1] != n) stop("Number of rows of the data matrix does not match the length of the tree.") if (is.null(rownames(X))) { warning("No tip labels on X; order assumed to be the same as in the tree.\n") data.names = phy$tip.label } else data.names = rownames(X) order <- match(data.names, phy$tip.label) if (sum(is.na(order)) > 0) { warning("Data names do not match with the tip labels.\n") rownames(X) <- data.names } else { temp <- X rownames(X) <- phy$tip.label X[order, ] <- temp[1:nrow(temp), ] } p <- dim(X)[2] # Input SeM if (!is.null(SeM)) { if (dim(SeM)[1] != n) stop("Number of rows of the SeM matrix does not match the length of the tree.") if (is.null(rownames(SeM))) { warning("No tip labels on SeM; order assumed to be the same as in the tree.\n") data.names = phy$tip.label } else data.names = rownames(SeM) order <- match(data.names, phy$tip.label) if (sum(is.na(order)) > 0) { warning("SeM names do not match with the tip labels.\n") rownames(SeM) <- data.names } else { temp <- SeM rownames(SeM) <- phy$tip.label SeM[order, ] <- temp[1:nrow(temp), ] } } else { SeM <- matrix(0, nrow = n, ncol = p) } # Input U if (length(U) > 0) { if (length(U) != p) stop("Number of elements of list U does not match the number of columns in X.") for (i in 1:p) { if (!is.null(U[[i]])){ if (dim(U[[i]])[1] != n) stop("Number of rows of an element of U does not match the tree.") if (is.null(rownames(U[[i]]))) { warning("No tip labels on U; order assumed to be the same as in the tree.\n") data.names = phy$tip.label } else data.names = rownames(U[[i]]) order <- match(data.names, phy$tip.label) if (sum(is.na(order)) > 0) { warning("U names do not match with the tip labels.\n") rownames(U[[i]]) <- data.names } else { temp <- U[[i]] rownames(U[[i]]) <- phy$tip.label U[[i]][order, ] <- temp[1:nrow(temp), ] } } else { U[[i]] <- matrix(0, nrow=n, ncol=1) rownames(U[[i]]) <- phy$tip.label } } } # Standardize all variables Xs <- X for (i in 1:p) Xs[, i] <- (X[, i] - mean(X[, i]))/sd(X[, i]) if (!is.null(SeM)) { SeMs <- SeM for (i in 1:p) SeMs[, i] <- SeM[, i]/sd(X[, i]) } if (length(U) > 0) { Us <- U for (i in 1:p) for (j in 1:ncol(U[[i]])) { if (sd(U[[i]][, j]) > 0) { Us[[i]][, j] <- (U[[i]][, j] - mean(U[[i]][, j]))/sd(U[[i]][, j]) } else { Us[[i]][, j] <- U[[i]][, j] - mean(U[[i]][, j]) } } } # Set up matrices Vphy <- vcv(phy) Vphy <- Vphy/max(Vphy) Vphy <- Vphy/exp(determinant(Vphy)$modulus[1]/n) XX <- matrix(as.matrix(Xs), ncol = 1) MM <- matrix(as.matrix(SeMs^2), ncol = 1) UU <- kronecker(diag(p), matrix(1, nrow = n, ncol = 1)) if (length(U) > 0) { zeros <- 0 * (1:p) for (i in 1:p) { dd <- zeros dd[i] <- 1 u <- kronecker(dd, as.matrix(Us[[i]])) for (j in 1:dim(u)[2]) if (sd(u[, j]) > 0) UU <- cbind(UU, u[, j]) } } # Compute initial estimates assuming no phylogeny if not provided if (length(U) > 0) { eps <- matrix(nrow = n, ncol = p) for (i in 1:p) { if (ncol(U[[i]]) > 0) { u <- as.matrix(Us[[i]]) z <- lm(Xs[, i] ~ u) eps[, i] <- resid(z) } else { eps[, i] <- Xs[, i] - mean(Xs[, i]) } } L <- t(chol(cov(eps))) } else { L <- t(chol(cov(Xs))) } L.elements <- L[lower.tri(L, diag = T)] par <- c(L.elements, array(0.5, dim = c(1, p))) tau <- matrix(1, nrow = n, ncol = 1) %*% diag(Vphy) - Vphy if (method == "Nelder-Mead") opt <- optim(fn = corphylo.LL, par = par, XX = XX, UU = UU, MM = MM, tau = tau, Vphy = Vphy, REML = REML, verbose = verbose, constrain.d = constrain.d, method = "Nelder-Mead", control = list(maxit = maxit.NM, reltol = reltol)) if (method == "SANN") { opt <- optim(fn = corphylo.LL, par = par, XX = XX, UU = UU, MM = MM, tau = tau, Vphy = Vphy, REML = REML, verbose = verbose, constrain.d = constrain.d, method = "SANN", control = list(maxit = maxit.SA, temp = temp.SA, tmax = tmax.SA, reltol = reltol)) par <- opt$par opt <- optim(fn = corphylo.LL, par = par, XX = XX, UU = UU, MM = MM, tau = tau, Vphy = Vphy, REML = REML, verbose = verbose, constrain.d = constrain.d, method = "Nelder-Mead", control = list(maxit = maxit.NM, reltol = reltol)) } # Extract parameters par <- Re(opt$par) LL <- opt$value L.elements <- par[1:(p + p * (p - 1)/2)] L <- matrix(0, nrow = p, ncol = p) L[lower.tri(L, diag = T)] <- L.elements R <- t(L) %*% L Rd <- diag(diag(R)^-0.5) cor.matrix <- Rd %*% R %*% Rd if (constrain.d == TRUE) { logit.d <- par[(p + p * (p - 1)/2 + 1):length(par)] d <- 1/(1 + exp(-logit.d)) } else { d <- par[(p + p * (p - 1)/2 + 1):length(par)] } # OU transform C <- matrix(0, nrow = p * n, ncol = p * n) for (i in 1:p) for (j in 1:p) { Cd <- (d[i]^tau * (d[j]^t(tau)) * (1 - (d[i] * d[j])^Vphy))/(1 - d[i] * d[j]) C[(n * (i - 1) + 1):(i * n), (n * (j - 1) + 1):(j * n)] <- R[i, j] * Cd } V <- C + diag(MM) iV <- solve(V) denom <- t(UU) %*% iV %*% UU num <- t(UU) %*% iV %*% XX B <- solve(denom, num) B <- as.matrix(B) B.cov <- solve(t(UU) %*% iV %*% UU) H <- XX - UU %*% B # Back-transform B counter <- 0 sd.list <- matrix(0, nrow = dim(UU)[2], ncol = 1) for (i in 1:p) { counter <- counter + 1 B[counter] <- B[counter] + mean(X[, i]) sd.list[counter] <- sd(X[, i]) if (length(U) > 0) { for (j in 1:ncol(U[[i]])) { if (sd(U[[i]][, j]) > 0) { counter <- counter + 1 B[counter] <- B[counter] * sd(X[, i])/sd(U[[i]][, j]) sd.list[counter] <- sd(X[, i])/sd(U[[i]][, j]) } } } } B.cov <- diag(as.numeric(sd.list)) %*% B.cov %*% diag(as.numeric(sd.list)) B.se <- as.matrix(diag(B.cov))^0.5 B.zscore <- B/B.se B.pvalue <- 2 * pnorm(abs(B/B.se), lower.tail = FALSE) # RowNames for B if (length(U) > 0) { B.rownames <- NULL for (i in 1:p) { B.rownames <- c(B.rownames, paste("B", i, ".0", sep = "")) if (ncol(U[[i]]) > 0) for (j in 1:ncol(U[[i]])) if (sd(U[[i]][, j]) > 0) { if (is.null(colnames(U[[i]])[j])) B.rownames <- c(B.rownames, paste("B", i, ".", j, sep = "")) if (!is.null(colnames(U[[i]])[j])) B.rownames <- c(B.rownames, paste("B", i, ".", colnames(U[[i]])[j], sep = "")) } } } else { B.rownames <- NULL for (i in 1:p) { B.rownames <- c(B.rownames, paste("B", i, ".0", sep = "")) } } rownames(B) <- B.rownames rownames(B.cov) <- B.rownames colnames(B.cov) <- B.rownames rownames(B.se) <- B.rownames rownames(B.zscore) <- B.rownames rownames(B.pvalue) <- B.rownames if (REML == TRUE) { logLik <- -0.5 * ((n * p) - ncol(UU)) * log(2 * pi) + 0.5 * determinant(t(XX) %*% XX)$modulus[1] - LL } else { logLik <- -0.5 * (n * p) * log(2 * pi) - LL } k <- length(par) + ncol(UU) AIC <- -2 * logLik + 2 * k BIC <- -2 * logLik + k * (log(n) - log(pi)) results <- list(cor.matrix = cor.matrix, d = d, B = B, B.se = B.se, B.cov = B.cov, B.zscore = B.zscore, B.pvalue = B.pvalue, logLik = logLik, AIC = AIC, BIC = BIC, REML = REML, constrain.d = constrain.d, XX = XX, UU = UU, MM = MM, Vphy = Vphy, R = R, V = V, C = C, convcode = opt$convergence, niter = opt$counts) class(results) <- "corphylo" return(results) } # Printing corphylo objects print.corphylo <- function(x, digits = max(3, getOption("digits") - 3), ...) { cat("Call to corphylo\n\n") logLik = x$logLik AIC = x$AIC BIC = x$BIC names(logLik) = "logLik" names(AIC) = "AIC" names(BIC) = "BIC" print(c(logLik, AIC, BIC), digits = digits) cat("\ncorrelation matrix:\n") rownames(x$cor.matrix) <- 1:dim(x$cor.matrix)[1] colnames(x$cor.matrix) <- 1:dim(x$cor.matrix)[1] print(x$cor.matrix, digits = digits) cat("\nfrom OU process:\n") d <- data.frame(d = x$d) print(d, digits = digits) if (x$constrain.d == TRUE) cat("\nvalues of d constrained to be in [0, 1]\n") cat("\ncoefficients:\n") coef <- data.frame(Value = x$B, Std.Error = x$B.se, Zscore = x$B.zscore, Pvalue = x$B.pvalue) rownames(coef) <- rownames(x$B) printCoefmat(coef, P.values = TRUE, has.Pvalue = TRUE) cat("\n") if (x$convcode != 0) cat("\nWarning: convergence in optim() not reached\n") } ape/R/dist.gene.R0000644000175100001440000000306112465112403013237 0ustar hornikusers## dist.gene.R (2012-04-02) ## Pairwise Distances from Genetic Data ## Copyright 2002-2012 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. dist.gene <- function(x, method = "pairwise", pairwise.deletion = FALSE, variance = FALSE) { if (is.data.frame(x)) x <- as.matrix(x) else { # suggestion by Markus Schlegel if (!is.matrix(x)) stop("'x' should be a matrix or a data.frame") } method <- match.arg(method, c("pairwise", "percentage")) if (!pairwise.deletion) { ## delete the columns with at least one NA: del <- apply(x, 2, function(xx) any(is.na(xx))) x <- x[, !del] } n <- dim(x) L <- n[2] n <- n[1] D <- double(n * (n - 1)/2) if (pairwise.deletion) L <- D k <- 1L for (i in 1:(n - 1)) { for (j in (i + 1):n) { y <- x[i, ] != x[j, ] if (pairwise.deletion) L[k] <- sum(!is.na(y)) D[k] <- sum(y, na.rm = TRUE) k <- k + 1L } } ## L is either a single integer value if pairwise.deletion = FALSE, ## or a vector of integers if pairwise.deletion = TRUE if (method == "percentage") D <- D/L attr(D, "Size") <- n attr(D, "Labels") <- dimnames(x)[[1]] attr(D, "Diag") <- attr(D, "Upper") <- FALSE attr(D, "call") <- match.call() attr(D, "method") <- method class(D) <- "dist" if (variance) { y <- if (method == "pairwise") L else 1 attr(D, "variance") <- D * (y - D)/L } D } ape/R/cophenetic.phylo.R0000644000175100001440000000144112465112403014632 0ustar hornikusers## cophenetic.phylo.R (2012-08-14) ## Pairwise Distances from a Phylogenetic Tree ## Copyright 2006-2012 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. dist.nodes <- function(x) { x <- reorder(x) # required for the C code n <- Ntip(x) m <- x$Nnode nm <- n + m d <- .C(dist_nodes, as.integer(n), as.integer(m), as.integer(x$edge[, 1] - 1L), as.integer(x$edge[, 2] - 1L), as.double(x$edge.length), as.integer(Nedge(x)), double(nm * nm), NAOK = TRUE)[[7]] dim(d) <- c(nm, nm) dimnames(d) <- list(1:nm, 1:nm) d } cophenetic.phylo <- function(x) { n <- length(x$tip.label) ans <- dist.nodes(x)[1:n, 1:n] dimnames(ans)[1:2] <- list(x$tip.label) ans } ape/R/makeNodeLabel.R0000644000175100001440000000355112465112403014046 0ustar hornikusers## makeNodeLabel.R (2009-03-22) ## Makes Node Labels ## Copyright 2009 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. makeNodeLabel <- function(phy, method = "number", prefix = "Node", nodeList = list(), ...) { method <- sapply(method, match.arg, c("number", "md5sum", "user"), USE.NAMES = FALSE) if ("number" %in% method) phy$node.label <- paste(prefix, 1:phy$Nnode, sep = "") if ("md5sum" %in% method) { nl <- character(phy$Nnode) pp <- prop.part(phy, check.labels = FALSE) labs <- attr(pp, "labels") fl <- tempfile() for (i in seq_len(phy$Nnode)) { cat(sort(labs[pp[[i]]]), sep = "\n", file = fl) nl[i] <- tools::md5sum(fl) } unlink(fl) phy$node.label <- nl } if ("user" %in% method) { if (is.null(phy$node.label)) phy$node.label <- character(phy$Nnode) nl <- names(nodeList) if (is.null(nl)) stop("argument 'nodeList' has no names") Ntip <- length(phy$tip.label) seq.nod <- .Call(seq_root2tip, phy$edge, Ntip, phy$Nnode) ## a local version to avoid the above call many times: .getMRCA <- function(seq.nod, tip) { sn <- seq.nod[tip] MRCA <- Ntip + 1 i <- 2 repeat { x <- unique(unlist(lapply(sn, "[", i))) if (length(x) != 1) break MRCA <- x i <- i + 1 } MRCA } for (i in seq_along(nodeList)) { tips <- sapply(nodeList[[i]], grep, phy$tip.label, ..., USE.NAMES = FALSE) j <- .getMRCA(seq.nod, unique(unlist(tips))) phy$node.label[j - Ntip] <- nl[i] } } phy } ape/R/diversi.gof.R0000644000175100001440000000455012465112403013602 0ustar hornikusers## diversi.gof.R (2006-10-16) ## Tests of Constant Diversification Rates ## Copyright 2002-2006 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. diversi.gof <- function(x, null = "exponential", z = NULL) { n <- length(x) if (null == "exponential") { delta <- n/sum(x) z <- 1 - exp(-delta * sort(x)) } else { nmsz <- deparse(substitute(z)) z <- sort(z) # utile ??? } i <- 1:n W2 <- sum((z - (2*i - 1)/(2*n))^2) + 1/12*n A2 <- -sum((2*i - 1)*(log(z) + log(1 - rev(z))))/n - n if (null == "exponential") { W2 <- W2*(1 - 0.16/n) A2 <- A2*(1 + 0.6/n) } else W2 <- (W2 - 0.4/n + 0.6/n^2)/(1 + 1/n) cat("\nTests of Constant Diversification Rates\n\n") cat("Data:", deparse(substitute(x)), "\n") cat("Number of branching times:", n, "\n") cat("Null model: ") if (null == "exponential") cat("exponential\n\n") else cat(nmsz, "(user-specified)\n\n") cat("Cramer-von Mises test: W2 =", round(W2, 3)) if (null == "exponential") { if (W2 < 0.177) cat(" P > 0.1\n") if (W2 >= 0.177 && W2 < 0.224) cat(" 0.05 < P < 0.1\n") if (W2 >= 0.224 && W2 < 0.273) cat(" 0.025 < P < 0.05\n") if (W2 >= 0.273 && W2 < 0.337) cat(" 0.01 < P < 0.025\n") if (W2 > 0.337) cat(" P < 0.01\n") } else { if (W2 < 0.347) cat(" P > 0.1\n") if (W2 >= 0.347 && W2 < 0.461) cat(" 0.05 < P < 0.1\n") if (W2 >= 0.461 && W2 < 0.581) cat(" 0.025 < P < 0.05\n") if (W2 >= 0.581 && W2 < 0.743) cat(" 0.01 < P < 0.025\n") if (W2 > 0.743) cat(" P < 0.01\n") } cat("Anderson-Darling test: A2 =", round(A2, 3)) if (null == "exponential") { if (A2 < 1.078) cat(" P > 0.1\n") if (A2 >= 1.078 && A2 < 1.341) cat(" 0.05 < P < 0.1\n") if (A2 >= 1.341 && A2 < 1.606) cat(" 0.025 < P < 0.05\n") if (A2 >= 1.606 && A2 < 1.957) cat(" 0.01 < P < 0.025\n") if (A2 > 1.957) cat(" P < 0.01\n") } else { if (A2 < 1.933) cat(" P > 0.1\n") if (A2 >= 1.933 && A2 < 2.492) cat(" 0.05 < P < 0.1\n") if (A2 >= 2.492 && A2 < 3.070) cat(" 0.025 < P < 0.05\n") if (A2 >= 3.070 && A2 < 3.857) cat(" 0.01 < P < 0.025\n") if (A2 > 3.857) cat(" P < 0.01\n") } } ape/R/treePop.R0000644000175100001440000000132012465112403012771 0ustar hornikusers## treePop.R (2011-10-11) ## Tree Popping ## Copyright 2011 Andrei-Alin Popescu ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. treePop <- function(obj) { mf <- obj$matsplit labels <- obj$labels n <- length(labels) imf <- as.integer(mf) freq <- obj$freq mimf <- matrix(imf, nrow(mf), ncol(mf)) ans <- .C(C_treePop, mimf, as.double(freq), as.integer(ncol(mf)), as.integer(n), integer(2*n - 3), integer(2*n - 3), double(2*n - 3), NAOK = TRUE) obj <- list(edge = cbind(ans[[5]], ans[[6]]), edge.length = ans[[7]], tip.label = labels, Nnode = n - 2L) class(obj) <- "phylo" reorder(obj) } ape/R/lmorigin.R0000644000175100001440000001206112465112403013177 0ustar hornikusers'lmorigin' <- function(formula, data=NULL, origin=TRUE, nperm=999, method=NULL, silent=FALSE) # # This program computes a multiple linear regression and performs tests # of significance of the equation parameters using permutations. # # origin=TRUE: the regression line can be forced through the origin. Testing # the significance in that case requires a special permutation procedure. # # Permutation methods: raw data or residuals of full model # Default method in regression through the origin: raw data # Default method in ordinary multiple regression: residuals of full model # - In ordinary multiple regression when m = 1: raw data # # Pierre Legendre, March 2009 { if(!is.null(method)) method <- match.arg(method, c("raw", "residuals")) if(is.null(method) & origin==TRUE) method <- "raw" if(is.null(method) & origin==FALSE) method <- "residuals" if(nperm < 0) stop("Incorrect value for 'nperm'") ## From the formula, find the variables and the number of observations 'n' toto <- lm(formula, data) mf <- match.call(expand.dots = FALSE) m <- match(c("formula", "data", "offset"), names(mf), 0) mf <- mf[c(1, m)] mf$drop.unused.levels <- TRUE mf[[1]] <- as.name("model.frame") mf <- eval(mf, parent.frame()) var.names = colnames(mf) # Noms des variables y <- as.matrix(mf[,1]) colnames(y) <- var.names[1] X <- as.matrix(mf[,-1]) n <- nrow(mf) m <- ncol(X) a <- system.time({ mm<- m # No. regression coefficients, possibly including the intercept if(m == 1) method <- "raw" if(nrow(X) != n) stop("Unequal number of rows in y and X") if(origin) { if(!silent) cat("Regression through the origin",'\n') reg <- lm(y ~ 0 + X) } else { if(!silent) cat("Multiple regression with estimation of intercept",'\n') reg <- lm(y ~ X) mm <- mm+1 } if(!silent) { if(nperm > 0) { if(method == "raw") { cat("Permutation method =",method,"data",'\n') } else { cat("Permutation method =",method,"of full model",'\n') } } } t.vec <- summary(reg)$coefficients[,3] p.param.t <- summary(reg)$coefficients[,4] df1 <- summary(reg)$fstatistic[[2]] df2 <- summary(reg)$fstatistic[[3]] F <- summary(reg)$fstatistic[[1]] y.res <- summary(reg)$residuals # b.vec <- summary(reg)$coefficients[,1] # r.sq <- summary(reg)$r.squared # adj.r.sq <- summary(reg)$adj.r.squared # p.param.F <- pf(F, df1, df2, lower.tail=FALSE) if(df1 < m) stop("\nCollinearity among the X variables. Check using 'lm'") # Permutation tests if(nperm > 0) { nGT.F <- 1 nGT1.t <- rep(1,mm) nGT2.t <- rep(1,mm) sign.t <- sign(t.vec) for(i in 1:nperm) # Permute raw data. Always use this method for F-test { if(origin) { # Regression through the origin dia.bin <- diag((rbinom(n,1,0.5)*2)-1) y.perm <- dia.bin %*% sample(y) reg.perm <- lm(y.perm ~ 0 + X) } else { # Multiple linear regression y.perm <- sample(y,n) reg.perm <- lm(y.perm ~ X) } # Permutation test of the F-statistic F.perm <- summary(reg.perm)$fstatistic[1] if(F.perm >= F) nGT.F <- nGT.F+1 # Permutation tests of the t-statistics: permute raw data if(method == "raw") { t.perm <- summary(reg.perm)$coefficients[,3] if(nperm <= 5) cat(t.perm,'\n') for(j in 1:mm) { # One-tailed test in direction of sign if(t.perm[j]*sign.t[j] >= t.vec[j]*sign.t[j]) nGT1.t[j] <- nGT1.t[j]+1 # Two-tailed test if( abs(t.perm[j]) >= abs(t.vec[j]) ) nGT2.t[j] <- nGT2.t[j]+1 } } } if(method == "residuals") { # Permute residuals of full model for(i in 1:nperm) { if(origin) { # Regression through the origin dia.bin <- diag((rbinom(n,1,0.5)*2)-1) y.perm <- dia.bin %*% sample(y.res) reg.perm <- lm(y.perm ~ 0 + X) } else { # Multiple linear regression y.perm <- sample(y.res,n) reg.perm <- lm(y.perm ~ X) } # Permutation tests of the t-statistics: permute residuals t.perm <- summary(reg.perm)$coefficients[,3] if(nperm <= 5) cat(t.perm,'\n') for(j in 1:mm) { # One-tailed test in direction of sign if(t.perm[j]*sign.t[j] >= t.vec[j]*sign.t[j]) nGT1.t[j] <- nGT1.t[j]+1 # Two-tailed test if( abs(t.perm[j]) >= abs(t.vec[j]) ) nGT2.t[j] <- nGT2.t[j]+1 } } } # Compute the permutational probabilities p.perm.F <- nGT.F/(nperm+1) p.perm.t1 <- nGT1.t/(nperm+1) p.perm.t2 <- nGT2.t/(nperm+1) ### Do not test intercept by permutation of residuals in multiple regression if(!origin & method=="residuals") { if(silent) { # Note: silent==TRUE in simulation programs p.perm.t1[1] <- p.perm.t2[1] <- 1 } else { p.perm.t1[1] <- p.perm.t2[1] <- NA } } } }) a[3] <- sprintf("%2f",a[3]) if(!silent) cat("Computation time =",a[3]," sec",'\n') # if(nperm == 0) { out <- list(reg=reg, p.param.t.2tail=p.param.t, p.param.t.1tail=p.param.t/2, origin=origin, nperm=nperm, var.names=var.names, call=match.call()) } else { out <- list(reg=reg, p.param.t.2tail=p.param.t, p.param.t.1tail=p.param.t/2, p.perm.t.2tail=p.perm.t2, p.perm.t.1tail=p.perm.t1, p.perm.F=p.perm.F, origin=origin, nperm=nperm, method=method, var.names=var.names, call=match.call()) } # class(out) <- "lmorigin" out } ape/R/MPR.R0000644000175100001440000000404013002744256012020 0ustar hornikusers## MPR.R (2010-08-10) ## Most Parsimonious Reconstruction ## Copyright 2010 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. MPR <- function(x, phy, outgroup) { if (is.rooted(phy)) stop("the tree must be unrooted") if (!is.binary.phylo(phy)) stop("the tree must be fully dichotomous") if (length(outgroup) > 1L) stop("outgroup must be a single tip") if (is.character(outgroup)) outgroup <- which(phy$tip.label == outgroup) if (!is.null(names(x))) { if (all(names(x) %in% phy$tip.label)) x <- x[phy$tip.label] else warning("the names of 'x' and the tip labels of the tree do not match: the former were ignored in the analysis.") } n <- length(phy$tip.label) if (is.null(phy$node.label)) phy$node.label <- n + 1:(phy$Nnode) phy <- drop.tip(root(phy, outgroup), outgroup) n <- n - 1L m <- phy$Nnode phy <- reorder(phy, "postorder") root.state <- x[outgroup] I <- as.integer(x[-outgroup]) I[n + 1:m] <- NA I <- cbind(I, I) # interval map med <- function(x) { i <- length(x)/2 sort(x)[c(i, i + 1L)] } ## 1st pass s <- seq(from = 1, by = 2, length.out = m) anc <- phy$edge[s, 1] des <- matrix(phy$edge[, 2], ncol = 2, byrow = TRUE) for (i in 1:m) I[anc[i], ] <- med(I[des[i, ], ]) ## 2nd pass out <- matrix(NA, m, 2) colnames(out) <- c("lower", "upper") ## do the most basal node before looping Iw <- as.vector(I[des[m, ], ]) # interval maps of the descendants out[anc[m] - n, ] <- range(med(c(root.state, root.state, Iw))) for (i in (m - 1):1) { j <- anc[i] Iw <- as.vector(I[des[i, ], ]) # interval maps of the descendants k <- which(phy$edge[, 2] == j) # find the ancestor tmp <- out[phy$edge[k, 1] - n, ] out[j - n, 1] <- min(med(c(tmp[1], tmp[1], Iw))) out[j - n, 2] <- max(med(c(tmp[2], tmp[2], Iw))) } rownames(out) <- phy$node.label out } ape/R/CADM.global.R0000644000175100001440000001742512465112403013333 0ustar hornikusers`CADM.global` <- function(Dmat, nmat, n, nperm=99, make.sym=TRUE, weights=NULL, silent=FALSE) { ### Function to test the overall significance of the congruence among ### a group of distance matrices using Kendall's coefficient of concordance W. ### ### copyleft - Pierre Legendre, December 2008 ### ### Reference - ### Legendre, P. and F.-J. Lapointe. 2004. Assessing congruence among distance ### matrices: single malt Scotch whiskies revisited. Australian and New Zealand ### Journal of Statistics 46: 615-629. ### ### Parameters of the function -- ### ### Dmat = A text file listing the distance matrices one after the other, with ### or without blank lines. ### Each matrix is in the form of a square distance matrix with 0's ### on the diagonal. ### ### nmat = number of distance matrices in file Dmat. ### ### n = number of objects in each distance matrix. All matrices have same n. ### ### nperm = number of permutations for the tests. ### ### make.sym = TRUE: turn asymmetric matrices into symmetric matrices by ### averaging the two triangular portions. ### = FALSE: analyse asymmetric matrices as they are. ### ### weights = a vector of positive weights for the distance matrices. ### Example: weights = c(1,2,3) ### = NULL (default): all matrices have same weight in calculation of W. ### ### silent = TRUE: informative messages will not be printed, except stopping ### messages. Option useful for simulation work. ### = FALSE: informative messages will be printed. ### ################################################################################ if(nmat < 2) stop("Analysis requested for a single D matrix: CADM is useless") a <- system.time({ ## Check the input file if(ncol(Dmat) != n) stop("Error in the value of 'n' or in the D matrices themselves") nmat2 <- nrow(Dmat)/n if(nmat2 < nmat) # OK if 'nmat' < number of matrices in the input file stop("Number of input D matrices = ",nmat2,"; this value is < nmat") nd <- n*(n-1)/2 if(is.null(weights)) { w <- rep(1,nmat) } else { if(length(weights) != nmat) stop("Incorrect number of values in vector 'weights'") if(length(which(weights < 0)) > 0) stop("Negative weights are not permitted") w <- weights*nmat/sum(weights) if(!silent) cat("Normalized weights =",w,'\n') } ## Are asymmetric D matrices present? asy <- rep(FALSE, nmat) asymm <- FALSE end <- 0 for(k in 1:nmat) { begin <- end+1 end <- end+n D.temp <- Dmat[begin:end,] if(sum(abs(diag(as.matrix(D.temp)))) > 0) stop("Diagonal not 0: matrix #",k," is not a distance matrix") vec1 <- as.vector(as.dist(D.temp)) vec2 <- as.vector(as.dist(t(D.temp))) if(sum(abs((vec1-vec2))) > 0) { if(!silent) cat("Matrix #",k," is asymmetric",'\n') asy[k] <- TRUE asymm <- TRUE } } D1 <- as.list(1:nmat) if(asymm) { if(make.sym) { if(!silent) cat("\nAsymmetric matrices were transformed to be symmetric",'\n') } else { nd <- nd*2 if(!silent) cat("\nAnalysis carried out on asymmetric matrices",'\n') D2 <- as.list(1:nmat) } } else { if(!silent) cat("Analysis of symmetric matrices",'\n') } Y <- rep(NA,nd) ## String out the distance matrices (vec) and assemble them as columns into matrix 'Y' ## Construct also matrices of ranked distances D1[[k]] and D2[[k]] for permutation test end <- 0 for(k in 1:nmat) { begin <- end+1 end <- end+n D.temp <- as.matrix(Dmat[begin:end,]) vec <- as.vector(as.dist(D.temp)) if(asymm) { if(!make.sym) { ## Analysis carried out on asymmetric matrices: ## The ranks are computed on the whole matrix except the diagonal values. ## The two halves are stored as symmetric matrices in D1[[k]] and D2[[k]] vec <- c(vec, as.vector(as.dist(t(D.temp)))) diag(D.temp) <- NA D.temp2 <- rank(D.temp) diag(D.temp2) <- 0 # cat("nrow =",nrow(D.temp2)," ncol =",ncol(D.temp2),'\n') # cat("Matrix ",k," min =",min(D.temp2)," max =",max(D.temp2),'\n') # cat("Matrix ",k," max values #",which(D.temp2 == max(D.temp2)),'\n') D1[[k]] <- as.matrix(as.dist(D.temp2)) D2[[k]] <- as.matrix(as.dist(t(D.temp2))) } else { ## Asymmetric matrices transformed to be symmetric, stored in D1[[k]] vec <- (vec + as.vector(as.dist(t(D.temp)))) / 2 D.temp2 <- (D.temp + t(D.temp)) / 2 D.temp2 <- as.dist(D.temp2) D.temp2[] <- rank(D.temp2) D.temp2 <- as.matrix(D.temp2) D1[[k]] <- D.temp2 } } else { ## Symmetric matrices are stored in D1[[k]] D.temp2 <- as.dist(D.temp) D.temp2[] <- rank(D.temp2) D1[[k]] <- as.matrix(D.temp2) } Y <- cbind(Y, vec) } Y <- as.matrix(Y[,-1]) colnames(Y) <- colnames(Y,do.NULL = FALSE, prefix = "Dmat.") ## Begin calculations for global test ## Compute the reference values of the statistics: W and Chi2 ## Transform the distances to ranks, by column Rmat <- apply(Y,2,rank) ## Correction factors for tied ranks (eq. 3.3) t.ranks <- apply(Rmat, 2, function(x) summary(as.factor(x), maxsum=nd)) TT <- sum(unlist(lapply(t.ranks, function(x) sum((x^3)-x)))) # if(!silent) cat("TT = ",TT,'\n') ## Compute the S = Sum-of-Squares of the row-marginal sums of ranks (eq. 1a) ## The ranks are weighted during the sum by the vector of matrix weights 'w' ## Eq. 1b cannot be used with weights; see formula for W below sumRanks <- as.vector(Rmat%*%w) S <- (nd-1)*var(sumRanks) ## Compute Kendall's W (eq. 2a) ## Eq. 2b cannot be used with weights ## because the sum of all ranks is not equal to m*n*(n+1)/2 in that case W <- (12*S)/(((nmat^2)*((nd^3)-nd))-(nmat*TT)) ## Calculate Friedman's Chi-square (Kendall W paper, 2005, eq. 3.4) Chi2 <- nmat*(nd-1)*W ## Test the Chi2 statistic by permutation counter <- 1 for(j in 1:nperm) { # Each matrix is permuted independently # There is no need to permute the last matrix Rmat.perm <- rep(NA,nd) ## if(asymm & !make.sym) { ## For asymmetric matrices: permute the values within each triangular ## portion, stored as square matrices in D1[[]] and D2[[]] for(k in 1:(nmat-1)) { order <- sample(n) vec <- as.vector(as.dist(D1[[k]][order,order])) vec <- c(vec, as.vector(as.dist(D2[[k]][order,order]))) Rmat.perm <- cbind(Rmat.perm, vec) } vec <- as.vector(as.dist(D1[[nmat]])) vec <- c(vec, as.vector(as.dist(D2[[nmat]]))) Rmat.perm <- cbind(Rmat.perm, vec) } else { for(k in 1:(nmat-1)) { order <- sample(n) vec <- as.vector(as.dist(D1[[k]][order,order])) Rmat.perm <- cbind(Rmat.perm, vec) } vec <- as.vector(as.dist(D1[[nmat]])) Rmat.perm <- cbind(Rmat.perm, vec) } # Remove the first column of Rmat.perm containing NA # The test is based on the comparison of S and S.perm instead of the comparison of # Chi2 and Chi2.perm: it is faster that way. # S, W, and Chi2 are equivalent statistics for permutation tests. Rmat.perm <- as.matrix(Rmat.perm[,-1]) S.perm <- (nd-1)*var(as.vector(Rmat.perm%*%w)) if(S.perm >= S) counter <- counter+1 } prob.perm.gr <- counter/(nperm+1) table <- rbind(W, Chi2, prob.perm.gr) colnames(table) <- "Statistics" rownames(table) <- c("W", "Chi2", "Prob.perm") }) a[3] <- sprintf("%2f",a[3]) if(!silent) cat("\nTime to compute global test =",a[3]," sec",'\n') # # if(asymm & !make.sym) { out <- list(congruence_analysis=table, D1=D1, D2=D2) # } else { out <- list(congruence_analysis=table) # } # out$nperm <- nperm class(out) <- "CADM.global" out } ape/R/speciesTree.R0000644000175100001440000000164712465112403013642 0ustar hornikusers## speciesTree.R (2013-08-12) ## Species Trees ## Copyright 2010-2013 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. speciesTree <- function(x, FUN = min) ### FUN = min => MAXTREE (Liu et al. 2010) ### FUN = sum => shallowest divergence (Maddison & Knowles 2006) { test.ultra <- which(!unlist(lapply(x, is.ultrametric))) if (length(test.ultra)) stop(paste("the following trees were not ultrametric:\n", paste(test.ultra, collapse = " "))) Ntree <- length(x) D <- lapply(x, cophenetic.phylo) nms <- rownames(D[[1]]) n <- length(nms) M <- matrix(0, n*(n - 1)/2, Ntree) for (i in 1:Ntree) M[, i] <- as.dist(D[[i]][nms, nms]) Y <- apply(M, 1, FUN) attributes(Y) <- list(Size = n, Labels = nms, Diag = FALSE, Upper = FALSE, class = "dist") as.phylo(hclust(Y, "single")) } ape/R/read.tree.R0000644000175100001440000001356112465112403013236 0ustar hornikusers## read.tree.R (2015-01-12) ## Read Tree Files in Parenthetic Format ## Copyright 2002-2012 Emmanuel Paradis, Daniel Lawson and Klaus Schliep ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. tree.build <- function(tp) { add.internal <- function() { edge[j, 1] <<- current.node edge[j, 2] <<- current.node <<- node <<- node + 1L index[node] <<- j # set index j <<- j + 1L } add.terminal <- function() { edge[j, 1] <<- current.node edge[j, 2] <<- tip index[tip] <<- j # set index X <- unlist(strsplit(tpc[k], ":")) tip.label[tip] <<- X[1] edge.length[j] <<- as.numeric(X[2]) k <<- k + 1L tip <<- tip + 1L j <<- j + 1L } go.down <- function() { l <- index[current.node] X <- unlist(strsplit(tpc[k], ":")) node.label[current.node - nb.tip] <<- X[1] edge.length[l] <<- as.numeric(X[2]) k <<- k + 1L current.node <<- edge[l, 1] } if (!length(grep(",", tp))) { obj <- list(edge = matrix(c(2L, 1L), 1, 2)) tp <- unlist(strsplit(tp, "[\\(\\):;]")) obj$edge.length <- as.numeric(tp[3]) obj$Nnode <- 1L obj$tip.label <- tp[2] if (tp[4] != "") obj$node.label <- tp[4] class(obj) <- "phylo" return(obj) } tpc <- unlist(strsplit(tp, "[\\(\\),;]")) tpc <- tpc[nzchar(tpc)] ## the following 2 lines are (slightly) faster than using gsub() tsp <- unlist(strsplit(tp, NULL)) skeleton <- tsp[tsp %in% c("(", ")", ",", ";")] nsk <- length(skeleton) nb.node <- sum(skeleton == ")") nb.tip <- sum(skeleton == ",") + 1 ## We will assume there is an edge at the root; ## if so, it will be removed and put into a vector nb.edge <- nb.node + nb.tip node.label <- character(nb.node) tip.label <- character(nb.tip) edge.length <- numeric(nb.edge) edge <- matrix(0L, nb.edge, 2) current.node <- node <- as.integer(nb.tip + 1) # node number edge[nb.edge, 2] <- node index <- numeric(nb.edge + 1) # hash index to avoid which index[node] <- nb.edge ## j: index of the line number of edge ## k: index of the line number of tpc ## tip: tip number j <- k <- tip <- 1L for (i in 2:nsk) { if (skeleton[i] == "(") add.internal() # add an internal branch (on top) if (skeleton[i] == ",") { if (skeleton[i - 1] != ")") add.terminal() # add a terminal branch } if (skeleton[i] == ")") { if (skeleton[i - 1] == ",") { # add a terminal branch and go down one level add.terminal() go.down() } if (skeleton[i - 1] == ")") go.down() # go down one level } } edge <- edge[-nb.edge, ] obj <- list(edge = edge, Nnode = nb.node, tip.label = tip.label) root.edge <- edge.length[nb.edge] edge.length <- edge.length[-nb.edge] if (!all(is.na(edge.length))) # added 2005-08-18 obj$edge.length <- edge.length if (is.na(node.label[1])) node.label[1] <- "" if (any(nzchar(node.label))) obj$node.label <- node.label if (!is.na(root.edge)) obj$root.edge <- root.edge class(obj) <- "phylo" attr(obj, "order") <- "cladewise" obj } read.tree <- function(file = "", text = NULL, tree.names = NULL, skip = 0, comment.char = "#", keep.multi = FALSE, ...) { unname <- function(treetext) { nc <- nchar(treetext) tstart <- 1 while (substr(treetext, tstart, tstart) != "(" && tstart <= nc) tstart <- tstart + 1 if (tstart > 1) return(c(substr(treetext, 1, tstart - 1), substr(treetext, tstart, nc))) return(c("", treetext)) } if (!is.null(text)) { if (!is.character(text)) stop("argument `text' must be of mode character") tree <- text } else { tree <- scan(file = file, what = "", sep = "\n", quiet = TRUE, skip = skip, comment.char = comment.char, ...) } ## Suggestion from Eric Durand and Nicolas Bortolussi (added 2005-08-17): if (identical(tree, character(0))) { warning("empty character string.") return(NULL) } tree <- gsub("[ \t]", "", tree) tree <- unlist(strsplit(tree, NULL)) y <- which(tree == ";") Ntree <- length(y) x <- c(1, y[-Ntree] + 1) ## Suggestion from Olivier Francois (added 2006-07-15): if (is.na(y[1])) return(NULL) STRING <- character(Ntree) for (i in 1:Ntree) { tmp <- paste(tree[x[i]:y[i]], sep = "", collapse = "") STRING[i] <- gsub("\\[[^]]*\\]", "", tmp) # delete comments (fix 2015-01-12) } tmp <- unlist(lapply(STRING, unname)) tmpnames <- tmp[c(TRUE, FALSE)] STRING <- tmp[c(FALSE, TRUE)] if (is.null(tree.names) && any(nzchar(tmpnames))) tree.names <- tmpnames colon <- grep(":", STRING) if (!length(colon)) { obj <- lapply(STRING, clado.build) } else if (length(colon) == Ntree) { obj <- lapply(STRING, tree.build) } else { obj <- vector("list", Ntree) obj[colon] <- lapply(STRING[colon], tree.build) nocolon <- (1:Ntree)[!1:Ntree %in% colon] obj[nocolon] <- lapply(STRING[nocolon], clado.build) } for (i in 1:Ntree) { ## Check here that the root edge is not incorrectly represented ## in the object of class "phylo" by simply checking that there ## is a bifurcation at the root ROOT <- length(obj[[i]]$tip.label) + 1 if(sum(obj[[i]]$edge[, 1] == ROOT) == 1 && dim(obj[[i]]$edge)[1] > 1) stop(paste("The tree has apparently singleton node(s): cannot read tree file.\n Reading Newick file aborted at tree no.", i)) } if (Ntree == 1 && !keep.multi) obj <- obj[[1]] else { if (!is.null(tree.names)) names(obj) <- tree.names class(obj) <- "multiPhylo" } obj } ape/R/drop.tip.R0000644000175100001440000002023212555726644013137 0ustar hornikusers## drop.tip.R (2015-07-28) ## Remove Tips in a Phylogenetic Tree ## Copyright 2003-2015 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. extract.clade <- function(phy, node, root.edge = 0, interactive = FALSE) { Ntip <- length(phy$tip.label) ROOT <- Ntip + 1 Nedge <- dim(phy$edge)[1] wbl <- !is.null(phy$edge.length) if (interactive) node <- identify(phy)$nodes else { if (length(node) > 1) { node <- node[1] warning("only the first value of 'node' has been considered") } if (is.character(node)) { if (is.null(phy$node.label)) stop("the tree has no node labels") node <- which(phy$node.label %in% node) + Ntip } if (node <= Ntip) stop("node number must be greater than the number of tips") } if (node == ROOT) return(phy) phy <- reorder(phy) # insure it is in cladewise order root.node <- which(phy$edge[, 2] == node) start <- root.node + 1 # start of the clade looked for anc <- phy$edge[root.node, 1] # the ancestor of 'node' next.anc <- which(phy$edge[-(1:start), 1] <= anc) # find the next occurence of 'anc' or an 'older' node keep <- if (length(next.anc)) start + 0:(next.anc[1] - 1) else start:Nedge if (root.edge) { NewRootEdge <- phy$edge.length[root.node] root.edge <- root.edge - 1 while (root.edge) { if (anc == ROOT) break i <- which(phy$edge[, 2] == anc) NewRootEdge <- NewRootEdge + phy$edge.length[i] root.edge <- root.edge - 1 anc <- phy$edge[i, 1] } if (root.edge && !is.null(phy$root.edge)) NewRootEdge <- NewRootEdge + phy$root.edge phy$root.edge <- NewRootEdge } phy$edge <- phy$edge[keep, ] if (wbl) phy$edge.length <- phy$edge.length[keep] TIPS <- phy$edge[, 2] <= Ntip tip <- phy$edge[TIPS, 2] ## Fix by Ludovic Mallet and Mahendra Mariadassou (2011-11-21): name <- vector("character", length(tip)) name[order(tip)] <- phy$tip.label[tip] phy$tip.label <- name ## End of fix ## keep the ordering so no need to reorder tip.label: phy$edge[TIPS, 2] <- order(tip) if (!is.null(phy$node.label)) phy$node.label <- phy$node.label[sort(unique(phy$edge[, 1])) - Ntip] Ntip <- length(phy$tip.label) phy$Nnode <- dim(phy$edge)[1] - Ntip + 1L ## The block below renumbers the nodes so that they conform ## to the "phylo" format -- same as in root() newNb <- integer(Ntip + phy$Nnode) newNb[node] <- Ntip + 1L sndcol <- phy$edge[, 2] > Ntip ## executed from right to left, so newNb is modified before phy$edge: phy$edge[sndcol, 2] <- newNb[phy$edge[sndcol, 2]] <- (Ntip + 2):(Ntip + phy$Nnode) phy$edge[, 1] <- newNb[phy$edge[, 1]] phy } drop.tip <- function(phy, tip, trim.internal = TRUE, subtree = FALSE, root.edge = 0, rooted = is.rooted(phy), interactive = FALSE) { if (!inherits(phy, "phylo")) stop('object "phy" is not of class "phylo"') Ntip <- length(phy$tip.label) ## find the tips to drop: if (interactive) { cat("Left-click close to the tips you want to drop; right-click when finished...\n") xy <- locator() nToDrop <- length(xy$x) tip <- integer(nToDrop) lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv) for (i in 1:nToDrop) { d <- sqrt((xy$x[i] - lastPP$xx)^2 + (xy$y[i] - lastPP$yy)^2) tip[i] <- which.min(d) } } else { if (is.character(tip)) tip <- which(phy$tip.label %in% tip) } out.of.range <- tip > Ntip if (any(out.of.range)) { warning("some tip numbers were larger than the number of tips: they were ignored") tip <- tip[!out.of.range] } if (!length(tip)) return(phy) if (length(tip) == Ntip) { warning("drop all tips of the tree: returning NULL") return(NULL) } wbl <- !is.null(phy$edge.length) if (!rooted && subtree) { phy <- root(phy, (1:Ntip)[-tip][1]) root.edge <- 0 } phy <- reorder(phy) NEWROOT <- ROOT <- Ntip + 1 Nnode <- phy$Nnode Nedge <- dim(phy$edge)[1] if (subtree) { trim.internal <- TRUE tr <- reorder(phy, "postorder") N <- .C(node_depth, as.integer(Ntip), as.integer(Nnode), as.integer(tr$edge[, 1]), as.integer(tr$edge[, 2]), as.integer(Nedge), double(Ntip + Nnode), 1L)[[6]] } edge1 <- phy$edge[, 1] # local copies edge2 <- phy$edge[, 2] # keep <- !logical(Nedge) ## delete the terminal edges given by `tip': keep[match(tip, edge2)] <- FALSE if (trim.internal) { ints <- edge2 > Ntip ## delete the internal edges that do not have anymore ## descendants (ie, they are in the 2nd col of `edge' but ## not in the 1st one) repeat { sel <- !(edge2 %in% edge1[keep]) & ints & keep if (!sum(sel)) break keep[sel] <- FALSE } if (subtree) { ## keep the subtending edge(s): subt <- edge1 %in% edge1[keep] & edge1 %in% edge1[!keep] keep[subt] <- TRUE } if (root.edge && wbl) { degree <- tabulate(edge1[keep]) if (degree[ROOT] == 1) { j <- integer(0) # will store the indices of the edges below the new root repeat { i <- which(edge1 == NEWROOT & keep) j <- c(i, j) NEWROOT <- edge2[i] degree <- tabulate(edge1[keep]) if (degree[NEWROOT] > 1) break } keep[j] <- FALSE if (length(j) > root.edge) j <- 1:root.edge NewRootEdge <- sum(phy$edge.length[j]) if (length(j) < root.edge && !is.null(phy$root.edge)) NewRootEdge <- NewRootEdge + phy$root.edge phy$root.edge <- NewRootEdge } } } if (!root.edge) phy$root.edge <- NULL ## drop the edges phy$edge <- phy$edge[keep, ] if (wbl) phy$edge.length <- phy$edge.length[keep] ## find the new terminal edges (works whatever 'subtree' and 'trim.internal'): TERMS <- !(phy$edge[, 2] %in% phy$edge[, 1]) ## get the old No. of the nodes and tips that become tips: oldNo.ofNewTips <- phy$edge[TERMS, 2] ## in case some tips are dropped but kept because of 'subtree = TRUE': if (subtree) { i <- which(tip %in% oldNo.ofNewTips) if (length(i)) { phy$tip.label[tip[i]] <- "[1_tip]" tip <- tip[-i] } } n <- length(oldNo.ofNewTips) # the new number of tips in the tree ## the tips may not be sorted in increasing order in the ## 2nd col of edge, so no need to reorder $tip.label phy$edge[TERMS, 2] <- rank(phy$edge[TERMS, 2]) phy$tip.label <- phy$tip.label[-tip] ## make new tip labels if necessary: if (subtree || !trim.internal) { ## get the numbers of the nodes that become tips: node2tip <- oldNo.ofNewTips[oldNo.ofNewTips > Ntip] new.tip.label <- if (subtree) { paste("[", N[node2tip], "_tips]", sep = "") } else { if (is.null(phy$node.label)) rep("NA", length(node2tip)) else phy$node.label[node2tip - Ntip] } # if (!is.null(phy$node.label)) # phy$node.label <- phy$node.label[-(node2tip - Ntip)] phy$tip.label <- c(phy$tip.label, new.tip.label) } phy$Nnode <- dim(phy$edge)[1] - n + 1L # update phy$Nnode ## The block below renumbers the nodes so that they conform ## to the "phylo" format newNb <- integer(Ntip + Nnode) newNb[NEWROOT] <- n + 1L sndcol <- phy$edge[, 2] > n newNb[sort(phy$edge[sndcol, 2])] <- (n + 2):(n + phy$Nnode) phy$edge[sndcol, 2] <- newNb[phy$edge[sndcol, 2]] phy$edge[, 1] <- newNb[phy$edge[, 1]] storage.mode(phy$edge) <- "integer" if (!is.null(phy$node.label)) # update node.label if needed phy$node.label <- phy$node.label[which(newNb > 0) - Ntip] collapse.singles(phy) } ape/R/read.gff.R0000644000175100001440000000127012775465654013062 0ustar hornikusers## read.gff.R (2016-10-06) ## Read GFF Files ## Copyright 2016 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. read.gff <- function(file, na.strings = c(".", "?")) { w <- list("", "", "", 0L, 0L, 0, "", "", "") x <- scan(file, w, sep = "\t", quote = "", quiet = TRUE, na.strings = na.strings, comment.char = "#") for (i in c(1, 2, 3, 7, 8)) x[[i]] <- factor(x[[i]]) names(x) <- c("seqid", "source", "type", "start", "end", "score", "strand", "phase", "attributes") n <- length(x[[1]]) attr(x, "row.names") <- as.character(seq_len(n)) class(x) <- "data.frame" x } ape/R/ewLasso.R0000644000175100001440000000127712465112403013003 0ustar hornikusers## ewLasso.R (2013-04-02) ## Lasso Tree ## Copyright 2013 Andrei-Alin Popescu ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. ewLasso <- function(X, phy) { if (is.matrix(X)) X <- as.dist(X) X[is.na(X)] <- -1 X[X < 0] <- -1 X[is.nan(X)] <- -1 if (is.rooted(phy)) { phy <- unroot(phy) warning("'phy' is rooted: it was unrooted for this operation") } N <- attr(X, "Size") labels <- attr(X, "Labels") if (is.null(labels)) labels <- as.character(1:N) ans <- .C(C_ewLasso, as.double(X), as.integer(N), as.integer(phy$edge[, 1]), as.integer(phy$edge[, 2]), NAOK = TRUE) } ape/R/DNA.R0000644000175100001440000007553013017515161011775 0ustar hornikusers## DNA.R (2016-11-26) ## Manipulations and Comparisons of DNA and AA Sequences ## Copyright 2002-2016 Emmanuel Paradis, 2015 Klaus Schliep ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. DNAbin2indel <- function(x) { if (is.list(x)) x <- as.matrix(x) d <- dim(x) s <- as.integer(d[2]) n <- as.integer(d[1]) if (s * n > 2^31 - 1) stop("DNAbin2indel() cannot handle more than 2^31 - 1 bases") res <- .C(DNAbin2indelblock, x, n, s, integer(n*s), NAOK = TRUE)[[4]] dim(res) <- d rownames(res) <- rownames(x) res } labels.DNAbin <- function(object, ...) { if (is.list(object)) return(names(object)) if (is.matrix(object)) return(rownames(object)) NULL } del.gaps <- function(x) { deleteGaps <- function(x) { i <- which(x == 4) if (length(i)) x[-i] else x } if (!inherits(x, "DNAbin")) x <- as.DNAbin(x) if (is.matrix(x)) { n <- dim(x)[1] y <- vector("list", n) for (i in 1:n) y[[i]] <- x[i, ] names(y) <- rownames(x) x <- y rm(y) } if (!is.list(x)) return(deleteGaps(x)) x <- lapply(x, deleteGaps) class(x) <- "DNAbin" x } del.rowgapsonly <- function(x, threshold = 1, freq.only = FALSE) { if (!inherits(x, "DNAbin")) x <- as.DNAbin(x) if (!is.matrix(x)) stop("DNA sequences not in a matrix") foo <- function(x) sum(x == 4) g <- apply(x, 1, foo) if (freq.only) return(g) i <- which(g / ncol(x) >= threshold) if (length(i)) x <- x[-i, ] x } del.colgapsonly <- function(x, threshold = 1, freq.only = FALSE) { if (!inherits(x, "DNAbin")) x <- as.DNAbin(x) if (!is.matrix(x)) stop("DNA sequences not in a matrix") foo <- function(x) sum(x == 4) g <- apply(x, 2, foo) if (freq.only) return(g) i <- which(g / nrow(x) >= threshold) if (length(i)) x <- x[, -i] x } as.alignment <- function(x) { if (is.list(x)) n <- length(x) if (is.matrix(x)) n <- dim(x)[1] seq <- character(n) if (is.list(x)) { nam <- names(x) for (i in 1:n) seq[i] <- paste(x[[i]], collapse = "") } if (is.matrix(x)) { nam <- dimnames(x)[[1]] for (i in 1:n) seq[i] <- paste(x[i, ], collapse = "") } obj <- list(nb = n, seq = seq, nam = nam, com = NA) class(obj) <- "alignment" obj } "[.DNAbin" <- function(x, i, j, drop = FALSE) { ans <- NextMethod("[", drop = drop) class(ans) <- "DNAbin" ans } as.matrix.DNAbin <- function(x, ...) { if (is.matrix(x)) return(x) if (is.vector(x)) { dim(x) <- c(1, length(x)) return(x) } s <- unique(lengths(x, use.names = FALSE)) if (length(s) != 1) stop("DNA sequences in list not of the same length.") n <- length(x) y <- matrix(raw(), n, s) for (i in seq_len(n)) y[i, ] <- x[[i]] rownames(y) <- names(x) class(y) <- "DNAbin" y } as.list.DNAbin <- function(x, ...) { if (is.list(x)) return(x) if (is.null(dim(x))) obj <- list(x) # cause is.vector() doesn't work else { # matrix n <- nrow(x) obj <- vector("list", n) for (i in seq_len(n)) obj[[i]] <- x[i, , drop = TRUE] names(obj) <- rownames(x) } class(obj) <- "DNAbin" obj } rbind.DNAbin <- function(...) ### works only with matrices for the moment { obj <- list(...) n <- length(obj) if (n == 1) return(obj[[1]]) for (i in 1:n) if (!is.matrix(obj[[1]])) stop("the 'rbind' method for \"DNAbin\" accepts only matrices") NC <- unlist(lapply(obj, ncol)) if (length(unique(NC)) > 1) stop("matrices do not have the same number of columns.") for (i in 1:n) class(obj[[i]]) <- NULL for (i in 2:n) obj[[1]] <- rbind(obj[[1]], obj[[i]]) structure(obj[[1]], class = "DNAbin") } cbind.DNAbin <- function(..., check.names = TRUE, fill.with.gaps = FALSE, quiet = FALSE) ### works only with matrices for the moment { obj <- list(...) n <- length(obj) if (n == 1) return(obj[[1]]) for (i in 1:n) if (!is.matrix(obj[[1]])) stop("the 'cbind' method for \"DNAbin\" accepts only matrices") NR <- unlist(lapply(obj, nrow)) for (i in 1:n) class(obj[[i]]) <- NULL if (check.names) { nms <- unlist(lapply(obj, rownames)) if (fill.with.gaps) { NC <- unlist(lapply(obj, ncol)) nms <- unique(nms) ans <- matrix(as.raw(4), length(nms), sum(NC)) rownames(ans) <- nms from <- 1 for (i in 1:n) { to <- from + NC[i] - 1 tmp <- rownames(obj[[i]]) nmsi <- tmp[tmp %in% nms] ans[nmsi, from:to] <- obj[[i]][nmsi, , drop = FALSE] from <- to + 1 } } else { tab <- table(nms) ubi <- tab == n nms <- names(tab)[which(ubi)] ans <- obj[[1]][nms, , drop = FALSE] for (i in 2:n) ans <- cbind(ans, obj[[i]][nms, , drop = FALSE]) if (!quiet && !all(ubi)) warning("some rows were dropped.") } } else { if (length(unique(NR)) > 1) stop("matrices do not have the same number of rows.") ans <- matrix(unlist(obj), NR) rownames(ans) <- rownames(obj[[1]]) } class(ans) <- "DNAbin" ans } c.DNAbin <- function(..., recursive = FALSE) { if (!all(unlist(lapply(list(...), is.list)))) stop("the 'c' method for \"DNAbin\" accepts only lists") structure(NextMethod("c"), class = "DNAbin") } print.DNAbin <- function(x, printlen = 6, digits = 3, ...) { if (is.list(x)) { n <- length(x) nms <- names(x) if (n == 1) { cat("1 DNA sequence in binary format stored in a list.\n\n") nTot <- length(x[[1]]) cat("Sequence length:", nTot, "\n\n") cat("Label:", nms, "\n\n") } else { cat(n, "DNA sequences in binary format stored in a list.\n\n") tmp <- lengths(x, use.names = FALSE) nTot <- sum(as.numeric(tmp)) mini <- range(tmp) maxi <- mini[2] mini <- mini[1] if (mini == maxi) cat("All sequences of same length:", maxi, "\n") else { cat("Mean sequence length:", round(mean(tmp), 3), "\n") cat(" Shortest sequence:", mini, "\n") cat(" Longest sequence:", maxi, "\n") } TAIL <- "\n\n" if (printlen < n) { nms <- nms[1:printlen] TAIL <- "...\n\n" } cat("\nLabels:", paste(nms, collapse = " "), TAIL) } } else { nTot <- length(x) if (is.matrix(x)) { nd <- dim(x) nms <- rownames(x) cat(nd[1], "DNA sequences in binary format stored in a matrix.\n\n") cat("All sequences of same length:", nd[2], "\n") TAIL <- "\n\n" if (printlen < nd[1]) { nms <- nms[1:printlen] TAIL <- "...\n\n" } cat("\nLabels:", paste(nms, collapse = " "), TAIL) } else { cat("1 DNA sequence in binary format stored in a vector.\n\n") cat("Sequence length:", nTot, "\n\n") } } if (nTot <= 1e6) { cat("Base composition:\n") print(round(base.freq(x), digits)) } else cat("More than 1 million nucleotides: not printing base composition\n") } as.DNAbin <- function(x, ...) UseMethod("as.DNAbin") ._cs_ <- c("a", "g", "c", "t", "r", "m", "w", "s", "k", "y", "v", "h", "d", "b", "n", "-", "?") ._bs_ <- c(136, 72, 40, 24, 192, 160, 144, 96, 80, 48, 224, 176, 208, 112, 240, 4, 2) ## by Klaus: as.DNAbin.character <- function(x, ...) { ans <- as.raw(._bs_)[match(tolower(x), ._cs_)] if (is.matrix(x)) { dim(ans) <- dim(x) dimnames(ans) <- dimnames(x) } class(ans) <- "DNAbin" ans } as.DNAbin.alignment <- function(x, ...) { n <- x$nb x$seq <- tolower(x$seq) ans <- matrix("", n, nchar(x$seq[1])) for (i in 1:n) ans[i, ] <- strsplit(x$seq[i], "")[[1]] rownames(ans) <- gsub(" +$", "", gsub("^ +", "", x$nam)) as.DNAbin.character(ans) } as.DNAbin.list <- function(x, ...) { obj <- lapply(x, as.DNAbin) class(obj) <- "DNAbin" obj } as.character.DNAbin <- function(x, ...) { f <- function(xx) { ans <- ._cs_[match(as.numeric(xx), ._bs_)] if (is.matrix(xx)) { dim(ans) <- dim(xx) dimnames(ans) <- dimnames(xx) } ans } if (is.list(x)) lapply(x, f) else f(x) } base.freq <- function(x, freq = FALSE, all = FALSE) { if (!inherits(x, "DNAbin")) stop('base.freq requires an object of class "DNAbin"') f <- function(x) .Call(BaseProportion, x) if (is.list(x)) { BF <- rowSums(sapply(x, f)) n <- sum(as.double(lengths(x, use.names = FALSE))) } else { n <- length(x) BF <- f(x) } names(BF) <- c("a", "c", "g", "t", "r", "m", "w", "s", "k", "y", "v", "h", "d", "b", "n", "-", "?") if (all) { if (!freq) BF <- BF / n } else { BF <- BF[1:4] if (!freq) BF <- BF / sum(BF) } BF } Ftab <- function(x, y = NULL) { if (is.null(y)) { if (is.list(x)) { y <- x[[2]] x <- x[[1]] if (length(x) != length(y)) stop("'x' and 'y' not of the same length") } else { # 'x' is a matrix y <- x[2, , drop = TRUE] x <- x[1, , drop = TRUE] } } else { x <- as.vector(x) y <- as.vector(y) if (length(x) != length(y)) stop("'x' and 'y' not of the same length") } out <- matrix(0, 4, 4) k <- c(136, 40, 72, 24) for (i in 1:4) { a <- x == k[i] for (j in 1:4) { b <- y == k[j] out[i, j] <- sum(a & b) } } dimnames(out)[1:2] <- list(c("a", "c", "g", "t")) out } GC.content <- function(x) sum(base.freq(x)[2:3]) seg.sites <- function(x) { if (is.list(x)) x <- as.matrix(x) if (is.vector(x)) return(integer(0)) if (nrow(x) == 1) return(integer(0)) ans <- .Call(SegSites, x) which(as.logical(ans)) } dist.dna <- function(x, model = "K80", variance = FALSE, gamma = FALSE, pairwise.deletion = FALSE, base.freq = NULL, as.matrix = FALSE) { MODELS <- c("RAW", "JC69", "K80", "F81", "K81", "F84", "T92", "TN93", "GG95", "LOGDET", "BH87", "PARALIN", "N", "TS", "TV", "INDEL", "INDELBLOCK") imod <- pmatch(toupper(model), MODELS) if (is.na(imod)) stop(paste("'model' must be one of:", paste("\"", MODELS, "\"", sep = "", collapse = " "))) if (imod == 11 && variance) { warning("computing variance not available for model BH87") variance <- FALSE } if (gamma && imod %in% c(1, 5:7, 9:17)) { warning(paste("gamma-correction not available for model", model)) gamma <- FALSE } if (is.list(x)) x <- as.matrix(x) nms <- dimnames(x)[[1]] n <- dim(x) s <- n[2] n <- n[1] if (s * n > 2^31 - 1) stop("dist.dna() cannot handle more than 2^31 - 1 bases") if (imod %in% c(4, 6:8)) { BF <- if (is.null(base.freq)) base.freq(x) else base.freq } else BF <- 0 if (imod %in% 16:17) pairwise.deletion <- TRUE if (!pairwise.deletion) { keep <- .C(GlobalDeletionDNA, x, n, s, rep(1L, s))[[4]] x <- x[, as.logical(keep)] s <- dim(x)[2] } Ndist <- if (imod == 11) n*n else n*(n - 1)/2 var <- if (variance) double(Ndist) else 0 if (!gamma) gamma <- alpha <- 0 else { alpha <- gamma gamma <- 1 } d <- .C(dist_dna, x, as.integer(n), as.integer(s), imod, double(Ndist), BF, as.integer(pairwise.deletion), as.integer(variance), var, as.integer(gamma), as.double(alpha), NAOK = TRUE) if (variance) var <- d[[9]] d <- d[[5]] if (imod == 11) { dim(d) <- c(n, n) dimnames(d) <- list(nms, nms) } else { attr(d, "Size") <- n attr(d, "Labels") <- nms attr(d, "Diag") <- attr(d, "Upper") <- FALSE attr(d, "call") <- match.call() attr(d, "method") <- model class(d) <- "dist" if (as.matrix) d <- as.matrix(d) } if (variance) attr(d, "variance") <- var d } image.DNAbin <- function(x, what, col, bg = "white", xlab = "", ylab = "", show.labels = TRUE, cex.lab = 1, legend = TRUE, ...) { what <- if (missing(what)) c("a", "g", "c", "t", "n", "-") else tolower(what) if (missing(col)) col <- c("red", "yellow", "green", "blue", "grey", "black") x <- as.matrix(x) # tests if all sequences have the same length n <- (dx <- dim(x))[1] # number of sequences s <- dx[2] # number of sites y <- integer(N <- length(x)) ncl <- length(what) col <- rep(col, length.out = ncl) brks <- 0.5:(ncl + 0.5) sm <- 0L for (i in ncl:1) { k <- ._bs_[._cs_ == what[i]] sel <- which(x == k) if (L <- length(sel)) { y[sel] <- i sm <- sm + L } else { what <- what[-i] col <- col[-i] brks <- brks[-i] } } dim(y) <- dx ## if there's no 0 in y, must drop 'bg' from the cols passed to image: if (sm == N) { leg.co <- co <- col leg.txt <- toupper(what) } else { co <- c(bg, col) leg.txt <- c(toupper(what), "others") leg.co <- c(col, bg) brks <- c(-0.5, brks) } yaxt <- if (show.labels) "n" else "s" image.default(1:s, 1:n, t(y[n:1, ]), col = co, xlab = xlab, ylab = ylab, yaxt = yaxt, breaks = brks, ...) if (show.labels) mtext(rownames(x), side = 2, line = 0.1, at = n:1, cex = cex.lab, adj = 1, las = 1) if (legend) { psr <- par("usr") xx <- psr[2]/2 yy <- psr[4] * (0.5 + 0.5/par("plt")[4]) legend(xx, yy, legend = leg.txt, pch = 22, pt.bg = leg.co, pt.cex = 2, bty = "n", xjust = 0.5, yjust = 0.5, horiz = TRUE, xpd = TRUE) } } alview <- function(x, file = "", uppercase = TRUE) { if (is.list(x)) x <- as.matrix(x) taxa <- formatC(labels(x), width = -1) x <- as.character(x) s <- ncol(x) if (nrow(x) > 1) { for (j in seq_len(s)) { q <- which(x[-1L, j] == x[1L, j]) + 1L x[q, j] <- "." } } x <- apply(x, 1L, paste, collapse = "") if (uppercase) x <- toupper(x) res <- paste(taxa, x) hdr <- formatC(s, width = nchar(res[1])) cat(hdr, file = file, sep = "\n") cat(res, file = file, sep = "\n", append = TRUE) } where <- function(x, pattern) { pat <- as.DNAbin(strsplit(pattern, NULL)[[1]]) p <- length(pat) f <- function(x, pat, p) { s <- length(x) if (s < p) stop("sequence shorter than the pattern") .Call(C_where, x, pat) } if (is.list(x)) return(lapply(x, f, pat = pat, p = p)) if (is.matrix(x)) { n <- nrow(x) res <- vector("list", n) for (i in seq_len(n)) res[[i]] <- f(x[i, , drop = TRUE], pat, p) names(res) <- rownames(x) return(res) } f(x, pat, p) # if x is a vector } ## conversions from BioConductor: .DNAString2DNAbin <- function(from) as.DNAbin.character(strsplit(tolower(as.character(from)), "")[[1]]) .DNAStringSet2DNAbin <- function(from) structure(lapply(from, .DNAString2DNAbin), class = "DNAbin") .DNAAlignment2DNAbinMatrix <- function(from) as.matrix(.DNAStringSet2DNAbin(as(from, "DNAStringSet"))) ## S3 versions: as.DNAbin.DNAString <- function(x, ...) .DNAString2DNAbin(x) as.DNAbin.DNAStringSet <- function(x, ...) .DNAStringSet2DNAbin(x) as.DNAbin.PairwiseAlignmentsSingleSubject <- function(x, ...) .DNAAlignment2DNAbinMatrix(x) as.DNAbin.DNAMultipleAlignment <- function(x, ...) .DNAAlignment2DNAbinMatrix(x) ## S4 versions: ## setAs("DNAString", "DNAbin", .DNAString2DNAbin) ## setAs("DNAStringSet", "DNAbin", .DNAStringSet2DNAbin) ## setAs("PairwiseAlignmentsSingleSubject", "DNAbin", .DNAAlignment2DNAbinMatrix) ## setAs("DNAMultipleAlignment", "DNAbin", .DNAAlignment2DNAbinMatrix) complement <- function(x) { f <- function(x) { ## reorder the vector of raws to match the complement: comp <- as.raw(._bs_[c(4:1, 10:9, 7:8, 6:5, 14:11, 15:17)]) ans <- comp[match(as.integer(x), ._bs_)] rev(ans) # reverse before returning } if (is.matrix(x)) { for (i in 1:nrow(x)) x[i, ] <- f(x[i, ]) return(x) } else if (is.list(x)) { x <- lapply(x, f) } else x <- f(x) class(x) <- "DNAbin" x } trans <- function(x, code = 1, codonstart = 1) { f <- function(x, s, code) .C(trans_DNA2AA, x, as.integer(s), raw(s/3), as.integer(code), NAOK = TRUE)[[3]] if (code > 2) stop("only the standard and the vertebrate mitochondrial codes are available for now") if (codonstart > 1) { del <- -(1:(codonstart - 1)) if (is.list(x)) { for (i in seq_along(x)) x[[i]] <- x[[i]][del] } else { x <- if (is.matrix(x)) x[, del] else x[del] } } if (is.list(x)) { res <- lapply(x, trans, code = code) } else { s <- if (is.matrix(x)) ncol(x) else length(x) rest <- s %% 3 if (rest != 0) { s <- s - rest x <- if (is.matrix(x)) x[, 1:s] else x[1:s] msg <- paste("sequence length not a multiple of 3:", rest, "nucleotide") if (rest == 2) msg <- paste0(msg, "s") warning(paste(msg, "dropped")) } res <- if (is.matrix(x)) t(apply(x, 1, f, s = s, code = code)) else f(x, s, code) } class(res) <- "AAbin" res } print.AAbin <- function(x, ...) { if (is.list(x)) { n <- length(x) cat(n, "amino acid sequence") if (n > 1) cat("s") cat(" in a list\n\n") tmp <- lengths(x, use.names = FALSE) maxi <- max(tmp) mini <- min(tmp) if (mini == maxi) cat("All sequences of the same length:", maxi, "\n") else { cat("Mean sequence length:", round(mean(tmp), 3), "\n Shortest sequence:", mini, "\n Longest sequence:", maxi, "\n") } } else if (is.matrix(x)) { n <- nrow(x) cat(n, "amino acid sequence") if (n > 1) cat("s") cat(" in a matrix\n") if (n == 1) cat("Sequence length: ") else cat("All sequences of the same length: ") cat(ncol(x), "\n") } else { cat("1 amino acid sequence in a vector:\n\n", rawToChar(x)) } cat("\n") } "[.AAbin" <- function (x, i, j, drop = FALSE) { ans <- NextMethod("[", drop = drop) class(ans) <- "AAbin" ans } as.character.AAbin <- function(x, ...) { f <- function(x) strsplit(rawToChar(x), "")[[1]] if (is.list(x)) return(lapply(x, f)) if (is.matrix(x)) return(t(apply(x, 1, f))) f(x) } as.AAbin <- function(x, ...) UseMethod("as.AAbin") as.AAbin.character <- function(x, ...) { f <- function(x) charToRaw(paste(x, collapse = "")) res <- if (is.vector(x)) f(x) else t(apply(x, 1, f)) class(res) <- "AAbin" res } labels.AAbin <- function(object, ...) labels.DNAbin(object, ...) if (getRversion() >= "2.15.1") utils::globalVariables("phyDat") as.phyDat.AAbin <- function(x, ...) phyDat(as.character(x), type = "AA") dist.aa <- function(x, pairwise.deletion = FALSE, scaled = FALSE) { n <- nrow(x) d <- numeric(n*(n - 1)/2) X <- charToRaw("X") k <- 0L if (!pairwise.deletion) { del <- apply(x, 2, function(y) any(y == X)) if (any(del)) x <- x[, !del] for (i in 1:(n - 1)) { for (j in (i + 1):n) { k <- k + 1L d[k] <- sum(x[i, ] != x[j, ]) } } if (scaled) d <- d/ncol(x) } else { for (i in 1:(n - 1)) { a <- x[i, ] for (j in (i + 1):n) { b <- x[j, ] del <- a == X | b == X p <- length(b <- b[!del]) tmp <- sum(a[!del] != b) k <- k + 1L d[k] <- if (scaled) tmp/p else tmp } } } attr(d, "Size") <- n attr(d, "Labels") <- rownames(x) attr(d, "Diag") <- attr(d, "Upper") <- FALSE attr(d, "call") <- match.call() class(d) <- "dist" d } AAsubst <- function(x) { X <- charToRaw("X") f <- function(y) length(unique.default(y[y != X])) which(apply(x, 2, f) > 1) } .AA_3letter <- c("Ala", "Cys", "Asp", "Glu", "Phe", "Gly", "His", "Ile", "Lys", "Leu", "Met", "Asn", "Pro", "Gln", "Arg", "Ser", "Thr", "Val", "Trp", "Tyr", "Xaa", "Stp") .AA_1letter <- c("A", "C", "D", "E", "F", "G", "H", "I", "K", "L", "M", "N", "P", "Q", "R", "S", "T", "V", "W", "Y", "X", "*") .AA_raw <- sapply(.AA_1letter, charToRaw) .AA_3cat <- list(Hydrophobic = .AA_raw[c("V", "I", "L", "F", "W", "Y", "M")], Small = .AA_raw[c("P", "G", "A", "C")], Hydrophilic = .AA_raw[c("S", "T", "H", "N", "Q", "D", "E", "K", "R")]) image.AAbin <- function(x, what, col, bg = "white", xlab = "", ylab = "", show.labels = TRUE, cex.lab = 1, legend = TRUE, ...) { if (missing(what)) what <- c("Hydrophobic", "Small", "Hydrophilic") if (missing(col)) col <- c("red", "yellow", "blue") n <- (dx <- dim(x))[1] s <- dx[2] y <- integer(N <- length(x)) ncl <- length(what) col <- rep(col, length.out = ncl) brks <- 0.5:(ncl + 0.5) sm <- 0L for (i in ncl:1) { k <- .AA_3cat[[i]] sel <- which(x %in% k) if (L <- length(sel)) { y[sel] <- i sm <- sm + L } else { what <- what[-i] col <- col[-i] brks <- brks[-i] } } dim(y) <- dx if (sm == N) { leg.co <- co <- col leg.txt <- what } else { co <- c(bg, col) leg.txt <- c(what, "Unknown") leg.co <- c(col, bg) brks <- c(-0.5, brks) } yaxt <- if (show.labels) "n" else "s" image.default(1:s, 1:n, t(y[n:1, ]), col = co, xlab = xlab, ylab = ylab, yaxt = yaxt, breaks = brks, ...) if (show.labels) mtext(rownames(x), side = 2, line = 0.1, at = n:1, cex = cex.lab, adj = 1, las = 1) if (legend) { psr <- par("usr") xx <- psr[2]/2 yy <- psr[4] * (0.5 + 0.5/par("plt")[4]) legend(xx, yy, legend = leg.txt, pch = 22, pt.bg = leg.co, pt.cex = 2, bty = "n", xjust = 0.5, yjust = 0.5, horiz = TRUE, xpd = TRUE) } } checkAlignment <- function(x, check.gaps = TRUE, plot = TRUE, what = 1:4) { cat("\nNumber of sequences:", n <- nrow(x), "\nNumber of sites:", s <- ncol(x), "\n") if (check.gaps) { cat("\n") y <- DNAbin2indel(x) gap.length <- sort(unique.default(y))[-1] if (!length(gap.length)) cat("No gap in alignment.\n") else { rest <- gap.length %% 3 if (any(cond <- rest > 0)) { cat("Some gap lengths are not multiple of 3:", gap.length[cond]) } else cat("All gap lengths are multiple of 3.") tab <- tabulate(y, gap.length[length(gap.length)]) tab <- tab[gap.length] cat("\n\nFrequencies of gap lengths:\n") names(tab) <- gap.length print(tab) ## find gaps on the borders: col1 <- unique(y[, 1]) if (!col1[1]) col1 <- col1[-1] if (length(col1)) cat(" => length of gaps on the left border of the alignment:", unique(col1), "\n") else cat(" => no gap on the left border of the alignment\n") i <- which(y != 0, useNames = FALSE) jcol <- i %/% nrow(y) + 1 yi <- y[i] j <- yi == s - jcol + 1 if (any(j)) cat(" => length of gaps on the right border of the alignment:", yi[j], "\n") else cat(" => no gap on the right border of the alignment\n") ## find base segments: A <- B <- numeric() for (i in seq_len(n)) { j <- which(y[i, ] != 0) # j: start of each gap in the i-th sequence if (!length(j)) next k <- j + y[i, j] # k: start of each base segment in the i-th sequence if (j[1] != 1) k <- c(1, k) else j <- j[-1] if (k[length(k)] > s) k <- k[-length(k)] else j <- c(j, s + 1) A <- c(A, j) B <- c(B, k) } AB <- unique(cbind(A, B)) not.multiple.of.3 <- (AB[, 1] - AB[, 2]) %% 3 != 0 left.border <- AB[, 2] == 1 right.border <- AB[, 1] == s + 1 Nnot.mult3 <- sum(not.multiple.of.3) cat("\nNumber of unique contiguous base segments defined by gaps:", nrow(AB), "\n") if (!Nnot.mult3) cat("All segment lengths multiple of 3.\n") else { Nleft <- sum(not.multiple.of.3 & left.border) Nright <- sum(not.multiple.of.3 & right.border) cat("Number of segment lengths not multiple of 3:", Nnot.mult3, "\n", " => on the left border of the alignement:", Nleft, "\n", " => on the right border :", Nright, "\n") if (Nright + Nleft < Nnot.mult3) { cat(" => positions of these segments inside the alignment: ") sel <- not.multiple.of.3 & !left.border & !right.border cat(paste(AB[sel, 2], AB[sel, 1] - 1, sep = ".."), "\n") } } } } else gap.length <- numeric() ss <- seg.sites(x) cat("\nNumber of segregating sites (including gaps):", length(ss)) BF.col <- matrix(NA_real_, length(ss), 4) for (i in seq_along(ss)) BF.col[i, ] <- base.freq(x[, ss[i]])#, freq = TRUE) tmp <- apply(BF.col, 1, function(x) sum(x > 0)) cat("\nNumber of sites with at least one substitution:", sum(tmp > 1)) cat("\nNumber of sites with 1, 2, 3 or 4 observed bases:\n") tab2 <- tabulate(tmp, 4L) tab2[1] <- s - sum(tab2) names(tab2) <- 1:4 print(tab2) cat("\n") H <- numeric(s) H[ss] <- apply(BF.col, 1, function(x) {x <- x[x > 0]; -sum(x * log(x))}) G <- rep(1, s) G[ss] <- tmp if (plot) { if (length(what) == 4) { mat <- if (length(gap.length)) 1:4 else c(1, 0, 2, 3) layout(matrix(mat, 2, 2)) } else { if (length(what) != 1) { what <- what[1] warning("argument 'what' has length > 1: the first value is taken") } } if (1 %in% what) image(x) if (2 %in% what && length(gap.length)) barplot(tab, xlab = "Gap length") if (3 %in% what) plot(1:s, H, "h", xlab = "Sequence position", ylab = "Shannon index (H)") if (4 %in% what) plot(1:s, G, "h", xlab = "Sequence position", ylab = "Number of observed bases") } } all.equal.DNAbin <- function(target, current, plot = FALSE, ...) { if (identical(target, current)) return(TRUE) name.target <- deparse(substitute(target)) name.current <- deparse(substitute(current)) st1 <- "convert list as matrix for further comparison." # st2 <- "" st3 <- "Subset your data for further comparison." isali1 <- is.matrix(target) isali2 <- is.matrix(current) if (isali1 && !isali2) return(c("1st object is a matrix, 2nd object is a list:", st1)) if (!isali1 && isali2) return(c("1st object is a list, 2nd object is a matrix:", st1)) if (!isali1 && !isali2) return(c("Both objects are lists:", "convert them as matrices for further comparison.")) # n1 <- if (isali1) nrow(target) else length(target) # n2 <- if (isali2) nrow(current) else length(current) if (ncol(target) != ncol(current)) return("Numbers of columns different: comparison stopped here.") foo <- function(n) ifelse(n == 1, "sequence", "sequences") doComparison <- function(target, current) which(target != current, arr.ind = TRUE, useNames = FALSE) n1 <- nrow(target) n2 <- nrow(current) labs1 <- labels(target) labs2 <- labels(current) if (identical(labs1, labs2)) { res <- "Labels in both objects identical." res <- list(messages = res, different.sites = doComparison(target, current)) } else { in12 <- labs1 %in% labs2 in21 <- labs2 %in% labs1 if (n1 != n2) { res <- c("Number of sequences different:", paste(n1, foo(n1), "in 1st object;", n2, foo(n2), "in 2nd object."), st3) plot <- FALSE } else { # n1 == n2 if (any(!in12)) { res <- c("X: 1st object (target), Y: 2nd object (current).", paste("labels in X not in Y:", paste(labs1[!in12], collapse = ", ")), paste("labels in X not in Y:", paste(labs2[!in21], collapse = ", ")), st3) plot <- FALSE } else { res <- c("Labels in both objects identical but not in the same order.", "Comparing sequences after reordering rows of the second matrix.") current <- current[labs1, ] if (identical(target, current)) { res <- c(res, "Sequences are identical.") plot <- FALSE } else { res <- list(messages = res, different.sites = doComparison(target, current)) } } } } if (plot) { cols <- unique(res$different.sites[, 2]) diff.cols <- diff(cols) j <- which(diff.cols != 1) end <- c(cols[j], cols[length(cols)]) start <- c(cols[1], cols[j + 1]) v <- cumsum(end - start + 1) + 0.5 f <- function(lab) { axis(2, at = seq_len(n1), labels = FALSE) axis(1, at = seq_along(cols), labels = cols) mtext(lab, line = 1, adj = 0, font = 2) } layout(matrix(1:2, 2)) par(xpd = TRUE) image(target[, cols], show.labels = FALSE, axes = FALSE, ...) f(name.target) xx <- c(0.5, v) segments(xx, 0.5, xx, n1, lty = 2, col = "white", lwd = 2) segments(xx, 0.5, xx, -1e5, lty = 2, lwd = 2) image(current[, cols], show.labels = FALSE, axes = FALSE, ...) f(name.current) segments(xx, 0.5, xx, n2, lty = 2, col = "white", lwd = 2) segments(xx, 1e5, xx, n2, lty = 2, lwd = 2) #segments(0.5, -5, length(cols) + 0.5, -5, lwd = 5, col = "grey") #rect(0.5, -4, length(cols) + 0.5, -3, col = "grey") #segments(0.5, 0.5, 10, -3) } res } ape/R/identify.phylo.R0000644000175100001440000000253512465112403014331 0ustar hornikusers## identify.phylo.R (2011-03-23) ## Graphical Identification of Nodes and Tips ## Copyright 2008-2011 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. identify.phylo <- function(x, nodes = TRUE, tips = FALSE, labels = FALSE, quiet = FALSE, ...) { if (!quiet) cat("Click close to a node of the tree...\n") xy <- locator(1) if (is.null(xy)) return(NULL) lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv) ## rescale the coordinates (especially if the x- and ## y-scales are very different): pin <- par("pin") rescaleX <- pin[1]/max(lastPP$xx) xx <- rescaleX * lastPP$xx rescaleY <- pin[2]/max(lastPP$yy) yy <- rescaleY * lastPP$yy xy$x <- rescaleX * xy$x xy$y <- rescaleY * xy$y ## end of rescaling d <- (xy$x - xx)^2 + (xy$y - yy)^2 # no need to sqrt() NODE <- which.min(d) res <- list() if (NODE <= lastPP$Ntip) { res$tips <- if (labels) x$tip.label[NODE] else NODE return(res) } if (tips) { TIPS <- prop.part(x)[[NODE - lastPP$Ntip]] res$tips <- if (labels) x$tip.label[TIPS] else TIPS } if (nodes) { if (is.null(x$node.label)) labels <- FALSE res$nodes <- if (labels) x$node.label[NODE - lastPP$Ntip] else NODE } res } ape/R/binaryPGLMM.R0000644000175100001440000002111012477255231013445 0ustar hornikusers## binaryPGLMM.R (2015-03-04) ## Phylogenetic Generalized Linear Mixed Model for Binary Data ## Copyright 2015 Anthony R. Ives ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. binaryPGLMM <- function(formula, data = list(), phy, s2.init = 0.1, B.init = NULL, tol.pql = 10^-6, maxit.pql = 200, maxit.reml = 100) { # Begin pglmm.reml pglmm.reml <- function(par, tinvW, tH, tVphy, tX) { n <- dim(tX)[1] p <- dim(tX)[2] ss2 <- abs(Re(par)) Cd <- ss2 * tVphy V <- tinvW + Cd LL <- 10^10 if (sum(is.infinite(V)) == 0) { # & rcond(V) < 10^10) { if (all(eigen(V)$values > 0)) { #if(rcond(V) > 10^-10 & all(eigen(V)$values > 0)) { invV <- solve(V) logdetV <- determinant(V)$modulus[1] if (is.infinite(logdetV)) { cholV <- chol(V) logdetV <- 2 * sum(log(diag(chol(V)))) } LL <- logdetV + t(tH) %*% invV %*% tH + determinant(t(tX) %*% invV %*% tX)$modulus[1] } } return(LL) } # End pglmm.reml if (!inherits(phy, "phylo")) stop("Object \"phy\" is not of class \"phylo\".") if (is.null(phy$edge.length)) stop("The tree has no branch lengths.") if (is.null(phy$tip.label)) stop("The tree has no tip labels.") phy <- reorder(phy, "postorder") n <- length(phy$tip.label) mf <- model.frame(formula = formula, data = data) if (nrow(mf) != length(phy$tip.label)) stop("Number of rows of the design matrix does not match with length of the tree.") if (is.null(rownames(mf))) { warning("No tip labels, order assumed to be the same as in the tree.\n") data.names = phy$tip.label } else data.names = rownames(mf) order <- match(data.names, phy$tip.label) if (sum(is.na(order)) > 0) { warning("Data names do not match with the tip labels.\n") rownames(mf) <- data.names } else { tmp <- mf rownames(mf) <- phy$tip.label mf[order, ] <- tmp[1:nrow(tmp), ] } X <- model.matrix(attr(mf, "terms"), data = mf) y <- model.response(mf) if (sum(!(y %in% c(0, 1)))) { stop("PGLMM.binary requires a binary response (dependent variable).") } if (var(y) == 0) { stop("The response (dependent variable) is always 0 or always 1.") } p <- ncol(X) Vphy <- vcv(phy) Vphy <- Vphy/max(Vphy) Vphy/exp(determinant(Vphy)$modulus[1]/n) # Compute initial estimates if not provided assuming no phylogeny if (!is.null(B.init) & length(B.init) != p) { warning("B.init not correct length, so computed B.init using glm()") } if (is.null(B.init) | (!is.null(B.init) & length(B.init) != p)) { B.init <- t(matrix(glm(formula = formula, data = data, family = "binomial")$coefficients, ncol = p)) } B <- B.init s2 <- s2.init b <- matrix(0, nrow = n) beta <- rbind(B, b) mu <- exp(X %*% B)/(1 + exp(X %*% B)) XX <- cbind(X, diag(1, nrow = n, ncol = n)) C <- s2 * Vphy est.s2 <- s2 est.B <- B oldest.s2 <- 10^6 oldest.B <- matrix(10^6, nrow = length(est.B)) iteration <- 0 exitflag <- 0 rcondflag <- 0 while (((t(est.s2 - oldest.s2) %*% (est.s2 - oldest.s2) > tol.pql^2) | (t(est.B - oldest.B) %*% (est.B - oldest.B)/length(B) > tol.pql^2)) & (iteration <= maxit.pql)) { iteration <- iteration + 1 oldest.s2 <- est.s2 oldest.B <- est.B est.B.m <- B oldest.B.m <- matrix(10^6, nrow = length(est.B)) iteration.m <- 0 # mean component while ((t(est.B.m - oldest.B.m) %*% (est.B.m - oldest.B.m)/length(B) > tol.pql^2) & (iteration.m <= maxit.pql)) { iteration.m <- iteration.m + 1 oldest.B.m <- est.B.m invW <- diag(as.vector((mu * (1 - mu))^-1)) V <- invW + C # This flags cases in which V has a very high condition number, which will cause solve() to fail. if (sum(is.infinite(V)) > 0 | rcond(V) < 10^-10) { rcondflag <- rcondflag + 1 B <- 0 * B.init + 0.001 b <- matrix(0, nrow = n) beta <- rbind(B, b) mu <- exp(X %*% B)/(1 + exp(X %*% B)) oldest.B.m <- matrix(10^6, nrow = length(est.B)) invW <- diag(as.vector((mu * (1 - mu))^-1)) V <- invW + C } invV <- solve(V) Z <- X %*% B + b + (y - mu)/(mu * (1 - mu)) denom <- t(X) %*% invV %*% X num <- t(X) %*% invV %*% Z B <- as.matrix(solve(denom, num)) b <- C %*% invV %*% (Z - X %*% B) beta <- rbind(B, b) mu <- exp(XX %*% beta)/(1 + exp(XX %*% beta)) est.B.m <- B } # variance component H <- Z - X %*% B opt <- optim(fn = pglmm.reml, par = s2, tinvW = invW, tH = H, tVphy = Vphy, tX = X, method = "BFGS", control = list(factr = 1e+12, maxit = maxit.reml)) s2 <- abs(opt$par) C <- s2 * Vphy est.s2 <- s2 est.B <- B } convergeflag <- "converged" if (iteration >= maxit.pql | rcondflag >= 3) { convergeflag <- "Did not converge; try increasing maxit.pql or starting with B.init values of .001" } converge.test.s2 <- (t(est.s2 - oldest.s2) %*% (est.s2 - oldest.s2))^0.5 converge.test.B <- (t(est.B - oldest.B) %*% (est.B - oldest.B))^0.5/length(est.B) # Extract parameters invW <- diag(as.vector((mu * (1 - mu))^-1)) V <- invW + C invV <- solve(V) Z <- X %*% B + b + (y - mu)/(mu * (1 - mu)) denom <- t(X) %*% invV %*% X num <- t(X) %*% invV %*% Z B <- solve(denom, num) b <- C %*% invV %*% (Z - X %*% B) beta <- rbind(B, b) mu <- exp(XX %*% beta)/(1 + exp(XX %*% beta)) H <- Z - X %*% B B.cov <- solve(t(X) %*% invV %*% X) B.se <- as.matrix(diag(B.cov))^0.5 B.zscore <- B/B.se B.pvalue <- 2 * pnorm(abs(B/B.se), lower.tail = FALSE) LL <- opt$value lnlike.cond.reml <- -0.5 * (n - p) * log(2 * pi) + 0.5 * determinant(t(X) %*% X)$modulus[1] - 0.5 * LL LL0 <- pglmm.reml(par = 0, tinvW = invW, tH = H, tVphy = Vphy, tX = X) lnlike.cond.reml0 <- -0.5 * (n - p) * log(2 * pi) + 0.5 * determinant(t(X) %*% X)$modulus[1] - 0.5 * LL0 P.H0.s2 <- pchisq(2 * (lnlike.cond.reml - lnlike.cond.reml0), df = 1, lower.tail = F)/2 results <- list(formula = formula, B = B, B.se = B.se, B.cov = B.cov, B.zscore = B.zscore, B.pvalue = B.pvalue, s2 = s2, P.H0.s2 = P.H0.s2, mu = mu, b = b, B.init = B.init, X = X, H = H, VCV = Vphy, V = V, convergeflag = convergeflag, iteration = iteration, converge.test.s2 = converge.test.s2, converge.test.B = converge.test.B, rcondflag = rcondflag) class(results) <- "binaryPGLMM" results } ###################################################### ###################################################### # binaryPGLMM.sim ###################################################### ###################################################### binaryPGLMM.sim <- function(formula, data = list(), phy, s2 = NULL, B = NULL, nrep = 1) { if (!inherits(phy, "phylo")) stop("Object \"phy\" is not of class \"phylo\".") if (is.null(phy$edge.length)) stop("The tree has no branch lengths.") if (is.null(phy$tip.label)) stop("The tree has no tip labels.") phy <- reorder(phy, "postorder") n <- length(phy$tip.label) mf <- model.frame(formula = formula, data = data) if (nrow(mf) != length(phy$tip.label)) stop("Number of rows of the design matrix does not match with length of the tree.") if (is.null(rownames(mf))) { warning("No tip labels, order assumed to be the same as in the tree.\n") data.names = phy$tip.label } else data.names = rownames(mf) order <- match(data.names, phy$tip.label) if (sum(is.na(order)) > 0) { warning("Data names do not match with the tip labels.\n") rownames(mf) <- data.names } else { tmp <- mf rownames(mf) <- phy$tip.label mf[order, ] <- tmp[1:nrow(tmp), ] } if (is.null(s2)) stop("You must specify s2") if (is.null(B)) stop("You must specify B") X <- model.matrix(attr(mf, "terms"), data = mf) n <- nrow(X) p <- ncol(X) V <- vcv(phy) V <- V/max(V) V <- vcv(phy) V <- V/max(V) V/exp(determinant(V)$modulus[1]/n) V <- s2 * V if (s2 > 10^-8) { iD <- t(chol(V)) } else { iD <- matrix(0, nrow = n, ncol = n) } Y <- matrix(0, nrow = n, ncol = nrep) y <- matrix(0, nrow = n, ncol = nrep) for (i in 1:nrep) { y[, i] <- X %*% B + iD %*% rnorm(n = n) p <- 1/(1 + exp(-y[, i])) Y[, i] <- as.numeric(runif(n = n) < p) } results <- list(Y = Y, y = y, X = X, s2 = s2, B = B, V = V) return(results) } ###################################################### ###################################################### # print.binaryPGLMM ###################################################### ###################################################### print.binaryPGLMM <- function(x, digits = max(3, getOption("digits") - 3), ...) { cat("\n\nCall:") print(x$formula) cat("\n") cat("Random effect (phylogenetic signal s2):\n") w <- data.frame(s2 = x$s2, Pr = x$P.H0.s2) print(w, digits = digits) cat("\nFixed effects:\n") coef <- data.frame(Value = x$B, Std.Error = x$B.se, Zscore = x$B.zscore, Pvalue = x$B.pvalue) printCoefmat(coef, P.values = TRUE, has.Pvalue = TRUE) cat("\n") } ape/R/delta.plot.R0000644000175100001440000000220212465112403013421 0ustar hornikusers## delta.plot.R (2010-01-12) ## Delta Plots ## Copyright 2010 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. delta.plot <- function(X, k = 20, plot = TRUE, which = 1:2) { if (is.matrix(X)) X <- as.dist(X) n <- attr(X, "Size") if (n < 4) stop("need at least 4 observations") ## add a category for the cases delta = 1 ans <- .C(delta_plot, as.double(X), as.integer(n), as.integer(k), integer(k + 1), double(n), NAOK = TRUE) counts <- ans[[4]] ## add the counts of delta=1 to the last category: counts[k] <- counts[k] + counts[k + 1] counts <- counts[-(k + 1)] delta.bar <- ans[[5]]/choose(n - 1, 3) if (plot) { if (length(which) == 2) layout(matrix(1:2, 1, 2)) if (1 %in% which) { barplot(counts, space = 0, xlab = expression(delta[q])) a <- axTicks(1) axis(1, at = a, labels = a/k) } if (2 %in% which) plot(delta.bar, type = "h", ylab = expression(bar(delta))) } invisible(list(counts = counts, delta.bar = delta.bar)) } ape/R/vcv2phylo.R0000644000175100001440000001205312465112403013314 0ustar hornikusers## vcv2phylo.R (2014-11-27) ## Variance-Covariance Matrix to Tree ## Copyright 2014 Simon Blomberg ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. vcv2phylo <- function (mat, tolerance = 1e-7) { ######################################################### ## Program to reconstruct a phylogenetic tree ## ## from a phylogenetic variance-covariance matrix. ## ## Input: mat (is tested for positive-definiteness) ## ## Output: phylo (in phylo format as in package "ape") ## ## If numerical issues occur, adjust the tolerance. ## ## Author: S. P. Blomberg ## ## Date: 12th November 2010 ## ######################################################### make.node <- function (left, right, value, lbrlen, rbrlen) { # function to make a node, using lists the.node <- list(left=left, right=right, value=value, lbrlen=lbrlen, rbrlen=rbrlen) class(the.node) <- c("node", "list") return(the.node) } divide.matrix <- function (mat) { # function to decompose a block-diagonal matrix into # upper and lower blocks dims <- dim(mat)[1] end.of.block <- which(mat[1,] < tolerance)[1]-1 if (is.na(end.of.block)) stop("Matrix is not block-diagonal") matlist <- list(upper=mat[1:end.of.block, 1:end.of.block], lower=mat[(end.of.block+1):dims,(end.of.block+1):dims]) if (length(matlist$upper)==1) names(matlist$upper) <- rownames(mat)[1] if (length(matlist$lower)==1) names(matlist$lower) <- rownames(mat)[dims] return(matlist) } make.tree.rec <- function (mat) { # Recursive function to create a tree made of nodes # from a phylogenetic matrix matlist <- divide.matrix(mat) if (is.vector(matlist$upper) && is.vector(matlist$lower)) { left <- as.numeric(names(matlist$upper)) right <- as.numeric(names(matlist$lower)) value <- i lbrlen <- matlist$upper rbrlen <- matlist$lower } if (is.vector(matlist$upper) && is.matrix(matlist$lower)) { min.lower <- min(matlist$lower) left <- as.numeric(names(matlist$upper)) value <- i i <<- i+1 right <- Recall(matlist$lower-min.lower) lbrlen <- matlist$upper rbrlen <- min.lower } if (is.matrix(matlist$upper) && is.vector(matlist$lower)) { min.upper <- min(matlist$upper) value <- i i <<- i+1 left <- Recall(matlist$upper-min.upper) right <- as.numeric(names(matlist$lower)) lbrlen <- min.upper rbrlen <- matlist$lower } if (is.matrix(matlist$upper) && is.matrix(matlist$lower)) { min.upper <- min(matlist$upper) min.lower <- min(matlist$lower) value <- i i <<- i+1 left <- Recall(matlist$upper-min.upper) i <<- i+1 right <- Recall(matlist$lower-min.lower) lbrlen <- min.upper rbrlen <- min.lower } return(make.node(left, right, value, lbrlen, rbrlen)) } make.phylo.rec <- function (the.list) { # Recursive function to construct the edge matrix and collect the # branch length information from the tree brlens <<- c(brlens, the.list$lbrlen, the.list$rbrlen) if (is.numeric(the.list$left) && is.numeric(the.list$right)) { the.matrix <<- rbind(the.matrix, c(the.list$value, the.list$left), c(the.list$value, the.list$right)) } if (is.numeric(the.list$left) && inherits(the.list$right, "node")) { the.matrix <<- rbind(the.matrix, c(the.list$value, the.list$left), c(the.list$value, the.list$right$value)) Recall(the.list$right) } if (inherits(the.list$left, "node") && is.numeric(the.list$right)) { the.matrix <<- rbind(the.matrix, c(the.list$value, the.list$left$value), c(the.list$value, the.list$right)) Recall(the.list$left) } if (inherits(the.list$left, "node") && inherits(the.list$right, "node")) { the.matrix <<- rbind(the.matrix, c(the.list$value, the.list$left$value), c(the.list$value, the.list$right$value)) Recall(the.list$left) Recall(the.list$right) } } # main body #require(matrixcalc) #if (!is.positive.definite(mat)) stop("Matrix is not positive-definite") if (!isSymmetric(mat)) stop("Matrix is not symmetric") if (any(eigen(mat, only.values = TRUE)$values < -tolerance)) stop("Matrix is not positive-definite") sp.names <- rownames(mat) dims <- dim(mat)[1] rownames(mat) <- colnames(mat) <- 1:dims i <- dims+1 the.list <- make.tree.rec(mat) # side effect: calculate i the.matrix <- matrix(NA, 0, ncol=2) # initialise the edge matrix brlens <- vector(mode="numeric", length=0) #initialise branch length vector make.phylo.rec(the.list) # side effects: calculate the.matrix and brlens names(brlens) <- NULL phylo <- list(edge=the.matrix, tip.label=sp.names, edge.length=brlens, Nnode=i-dims) storage.mode(phylo$edge) <- "integer" storage.mode(phylo$Nnode) <- "integer" class(phylo) <- "phylo" return(phylo) } ape/R/mrca.R0000644000175100001440000000656412465112403012314 0ustar hornikusers## mrca.R (2009-05-10) ## Find Most Recent Common Ancestors Between Pairs ## Copyright 2005-2009 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. mrca <- function(phy, full = FALSE) { if (!inherits(phy, "phylo")) stop('object "phy" is not of class "phylo"') ## if (!is.rooted(phy)) stop("the tree must be rooted.") ## Get all clades: nb.tip <- length(phy$tip.label) nb.node <- phy$Nnode BP <- .Call(bipartition, phy$edge, nb.tip, nb.node) N <- nb.tip + nb.node ROOT <- nb.tip + 1 ## In the following matrix, numeric indexing will be used: M <- numeric(N * N) dim(M) <- c(N, N) ## We start at the root: next.node <- ROOT while (length(next.node)) { tmp <- numeric(0) for (anc in next.node) { ## Find the branches which `anc' is the ancestor...: id <- which(phy$edge[, 1] == anc) ## ... and get their descendants: desc <- phy$edge[id, 2] ## `anc' is itself the MRCA of its direct descendants: M[anc, desc] <- M[desc, anc] <- anc ## Find all 2-by-2 combinations of `desc': `anc' ## is their MRCA: for (i in 1:length(desc)) M[cbind(desc[i], desc[-i])] <- anc ## If one element of `desc' is a node, then the tips it ## leads to and the other elements of `desc' have also ## `anc' as MRCA! for (i in 1:length(desc)) { if (desc[i] < ROOT) next ## (get the tips:) tips <- BP[[desc[i] - nb.tip]] ## Same thing for the nodes... node.desc <- numeric(0) for (k in 1:nb.node) { if (k == desc[i] - nb.tip) next ## If the clade of the current node is a ## subset of desc[i], then it is one of its ## descendants: if (all(BP[[k]] %in% tips)) node.desc <- c(node.desc, k) } ## all nodes and tips which are descendants of ## `desc[i]': ALLDESC <- c(tips, node.desc + nb.tip) M[ALLDESC, desc[-i]] <- M[desc[-i], ALLDESC] <- anc for (j in 1:length(desc)) { if (j == i || desc[j] < ROOT) next tips2 <- BP[[desc[j] - nb.tip]] node.desc <- numeric(0) for (k in 1:nb.node) { if (k == desc[j] - nb.tip) next if (all(BP[[k]] %in% tips2)) node.desc <- c(node.desc, k) } ALLDESC2 <- c(tips2, node.desc + nb.tip) M[ALLDESC, ALLDESC2] <- M[ALLDESC2, ALLDESC] <- anc } ## `anc' is also the MRCA of itself and its descendants: M[ALLDESC, anc] <- M[anc, ALLDESC] <- anc } ## When it is done, `desc' i stored to become ## the new `next.node', if they are nodes: tmp <- c(tmp, desc[desc > nb.tip]) } next.node <- tmp } M[cbind(1:N, 1:N)] <- 1:N if (full) dimnames(M)[1:2] <- list(as.character(1:N)) else { M <- M[1:nb.tip, 1:nb.tip] dimnames(M)[1:2] <- list(phy$tip.label) } M } ape/R/node.dating.R0000644000175100001440000002412713002725161013556 0ustar hornikusers## node.dating.R (2016-06-21) ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. # Copyright (c) 2016, Bradley R. Jones, BC Centre for Excellence in HIV/AIDS # All rights reserved. # # Redistribution and use in source and binary forms, with or without # modification, are permitted provided that the following conditions are met: # * Redistributions of source code must retain the above copyright # notice, this list of conditions and the following disclaimer. # * Redistributions in binary form must reproduce the above copyright # notice, this list of conditions and the following disclaimer in the # documentation and/or other materials provided with the distribution. # * Neither the name of the BC Centre for Excellence in HIV/AIDS nor the # names of its contributors may be used to endorse or promote products # derived from this software without specific prior written permission. # # THIS SOFTWARE IS PROVIDED BY THE COPYRIGHT HOLDERS AND CONTRIBUTORS "AS IS" AND # ANY EXPRESS OR IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED # WARRANTIES OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE # DISCLAIMED. IN NO EVENT SHALL The BC Centre for Excellence in HIV/AIDS BE LIABLE FOR ANY # DIRECT, INDIRECT, INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES # (INCLUDING, BUT NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; # LOSS OF USE, DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND # ON ANY THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT # (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF THIS # SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE. # Estimate the mutation rate and node dates based on tip dates. # # Felsenstein, Joseph. "Evolutionary trees from DNA sequences: A maximum # likelihood approach." Journal of Molecular Evolution 17 (1981):368-376. # # Rambaut, Andrew. "Estimating the rate of molecular evolution: incorporating # non-contemporaneous sequences into maximum likelihood phylogenies." # Bioinformatics 16.4 (2000): 395-399. # Estimate the mutation rate of a phylogenetic tree from the tip dates using # linear regression. This model assumes that the tree follows a molecular # clock. It will produce a warning if the regression cannot reject the null # hypothesis. # # t: rooted tree with edge lengths equal to genetic distance # # tip.dates: vector of dates for the tips, in the same order as t$tip.label. # Tip dates can be censored with NA values # # p: p-value cutoff for failed regression (default=0.05) # # returns the mutation rate as a double estimate.mu <- function(t, node.dates, p = 0.05) { # fit linear model g <- glm(node.depth.edgelength(t)[1:length(node.dates)] ~ node.dates, na.action=na.omit) null.g <- glm(node.depth.edgelength(t)[1:length(node.dates)] ~ 1, na.action=na.omit) # test fit if ((1 - pchisq(AIC(null.g) - AIC(g) + 2, df=1)) > p) { warning(paste("Cannot reject null hypothesis (p=", (1 - pchisq(AIC(null.g) - AIC(g) + 2, df=1)), ")", sep="")) } coef(g)[[2]] } # Estimate the dates of the internal nodes of a phylogenetic tree. # # t: rooted tree with edge lengths equal to genetic distance # # node.dates: either a vector of dates for the tips, in the same order as # t$tip.label; or a vector of dates to initalize each node # # mu: mutation rate # # min.date: the minimum date that a node can have (needed for optimize()). The # default is -.Machine$double.xmax # # show.steps: set to print the log likelihood every show.steps. Set to 0 to # supress output # # opt.tol: tolerance for optimization precision. By default, the optimize() # function uses a tolerance of .Machine$double.eps^0.25 (see ?optimize) # # lik.tol: tolerance for likelihood comparison. estimate.dates will stop when # the log likelihood between successive trees is less than like.tol. If # 0 will stop after nsteps steps. # # nsteps: the maximum number of steps to run. If 0 will run until the log # likelihood between successive runs is less than lik.tol. The default # is 1000. # # is.binary: if the phylogentic tree is binary, setting is.binary to TRUE, will # run a optimization method # # If lik.tol and nsteps are both 0 then estimate.dates will only run the inital # step. # # returns a vector of all of the dates of the tips and nodes estimate.dates <- function(t, node.dates, mu = estimate.mu(t, node.dates), min.date = -.Machine$double.xmax, show.steps = 0, opt.tol = 1e-8, nsteps = 1000, lik.tol = if (nsteps <= 0) opt.tol else 0, is.binary = is.binary.phylo(t)) { if (mu < 0) stop(paste("mu (", mu, ") less than 0", sep="")) # init vars n.tips <- length(t$tip.label) nodes <- unique(reorder(t)$edge[,1]) dates <- if (length(node.dates) == n.tips) { c(node.dates, rep(NA, t$Nnode)) } else { node.dates } # Don't count initial step if all values are seeded iter.step <- if (any(is.na(dates))) { 0 } else { 1 } children <- lapply(1:t$Nnode, function(x) { t$edge[,1] == x + n.tips }) parent <- lapply(1:t$Nnode, function(x) { t$edge[,2] == x + n.tips }) # to process children before parents nodes <- c(1) i <- 1 while (i <= length(nodes)) { nodes <- c(nodes, t$edge[t$edge[,1] == nodes[i] + n.tips, 2] - n.tips) i <- i + 1 } nodes <- nodes[nodes > 0] nodes <- rev(nodes) # calculate likelihood scale.lik <- sum(-lgamma(t$edge.length+1)+(t$edge.length+1)*log(mu)) calc.Like <- function(ch.node, ch.edge, x) { tim <- ch.node - x ch.edge*log(tim)-mu*tim } opt.fun <- function(x, ch, p, ch.edge.length, p.edge.length, use.parent=T) { sum(if (!use.parent || length(dates[p]) == 0 || is.na(dates[p])) { calc.Like(dates[ch], ch.edge.length, x) } else { calc.Like(c(dates[ch], x), c(ch.edge.length, p.edge.length), c(rep(x, length(dates[ch])), dates[p])) }) } solve.bin <- function(bounds, ch.times, ch.edge.length) { a <- 2 * mu b <- ch.edge.length[1] + ch.edge.length[2] - 2 * mu * (ch.times[1] + ch.times[2]) c.0 <- 2*mu*ch.times[1] * ch.times[2] - ch.times[1] * ch.edge.length[2] - ch.times[2] * ch.edge.length[1] b ^ 2 - 4 * a * c.0 < 0 if (b ^ 2 - 4 * a * c.0 < 0) { return(bounds[1 + (sum(calc.Like(ch.times, ch.edge.length, bounds[2] - opt.tol)) > sum(calc.Like(ch.times, ch.edge.length, bounds[1] + opt.tol)))]) } else { x.1 <- (-b + sqrt(b ^ 2 - 4 * a * c.0)) / (2 * a) x.2 <- (-b - sqrt(b ^ 2 - 4 * a * c.0)) / (2 * a) x <- c(bounds[1] + opt.tol, bounds[2] - opt.tol) if (bounds[1] < x.1 && x.1 < bounds[2]) x <- c(x, x.1) if (bounds[1] < x.2 && x.2 < bounds[2]) x <- c(x, x.2) return(x[which.max(unlist(lapply(x, function(y) sum(calc.Like(ch.times, ch.edge.length, y)))))]) } } solve.cube <- function(bounds, ch.times, ch.edge.length, par.time, par.edge.length) { a <- mu b <- sum(ch.edge.length) + par.edge.length - mu * (sum(ch.times) + par.time) c.0 <- mu * (ch.times[1] * ch.times[2] + ch.times[1] * par.time + ch.times[2] * par.time) - (ch.times[1] + ch.times[2]) * par.edge.length - (ch.times[1] + par.time) * ch.edge.length[2] - (ch.times[2] + par.time) * ch.edge.length[1] d <- ch.edge.length[1] * ch.times[2] * par.time + ch.edge.length[2] * ch.times[1] * par.time + par.edge.length * ch.times[1] * ch.times[2] - mu * prod(ch.times) * par.time delta.0 <- complex(real=b^2 - 3 * a * c.0) delta.1 <- complex(real=2 * b^3 - 9 * a * b * c.0 + 27 * a^2 * d) C <- ((delta.1 + sqrt(delta.1^2 - 4 * delta.0^3)) / 2)^(1/3) x.1 <- Re(-1 / (3 * a) * (b + complex(real=1) * C + delta.0 / (complex(real=1) * C))) x.2 <- Re(-1 / (3 * a) * (b + complex(real=-1/2, imaginary=sqrt(3)/2) * C + delta.0 / (complex(real=-1/2, imaginary=sqrt(3)/2) * C))) x.3 <- Re(-1 / (3 * a) * (b + complex(real=-1/2, imaginary=-sqrt(3)/2) * C + delta.0 / (complex(real=-1/2, imaginary=-sqrt(3)/2) * C))) x <- c(bounds[1] + opt.tol, bounds[2] - opt.tol) if (x.1 && bounds[1] < x.1 && x.1 < bounds[2]) x <- c(x, x.1) if (bounds[1] < x.2 && x.2 < bounds[2]) x <- c(x, x.2) if (bounds[1] < x.3 && x.3 < bounds[2]) x <- c(x, x.3) return(x[which.max(unlist(lapply(x, function(y) sum(calc.Like(c(ch.times, y), c(ch.edge.length, par.edge.length), c(y, y, par.time))))))]) } estimate <- function(node) { ch <- t$edge[children[[node]], 2] ch.edge.length <- t$edge.length[children[[node]]] p <- t$edge[parent[[node]], 1] p.edge.length <- t$edge.length[parent[[node]]] m <- if (length(p) == 0 || is.na(dates[p])) { min.date } else { dates[p] } if (is.binary) { if (length(dates[p]) == 0 || is.na(dates[p])) solve.bin(c(m, min(dates[ch])), dates[ch], ch.edge.length) else solve.cube(c(m, min(dates[ch])), dates[ch], ch.edge.length, dates[p], p.edge.length) } else { res <- optimize(opt.fun, c(m, min(dates[ch])), ch, p, ch.edge.length, p.edge.length, maximum=T) res$maximum } } # iterate to estimate dates lik <- NA repeat { for (n in nodes) { dates[n + n.tips] <- estimate(n) } new.lik <- sum(unlist(lapply(nodes, function(node) { ch <- t$edge[children[[node]], 2] ch.edge.length <- t$edge.length[children[[node]]] p <- t$edge[parent[[node]], 1] p.edge.length <- t$edge.length[parent[[node]]] opt.fun(dates[node+n.tips], ch, p, ch.edge.length, p.edge.length, use.parent=F) }))) + scale.lik if (show.steps > 0 && ((iter.step %% show.steps) == 0)) { cat(paste("Step: ", iter.step, ", Likelihood: ", new.lik, "\n", sep="")) } if ((lik.tol > 0 && (!is.na(lik) && (is.infinite(lik) || is.infinite(new.lik) || new.lik - lik < lik.tol))) || (nsteps > 0 && iter.step >= nsteps) || (lik.tol <= 0 && nsteps <= 0)) { if (is.infinite(lik) || is.infinite(new.lik)) { warning("Likelihood infinite") } else if (!is.na(lik) && new.lik < lik - lik.tol) { warning("Likelihood less than previous estimate") } break } else { lik <- new.lik } iter.step <- iter.step + 1 } if (show.steps > 0) { cat(paste("Step: ", iter.step, ", Likelihood: ", new.lik, "\n", sep="")) } dates } ape/R/write.nexus.data.R0000644000175100001440000001104212465112647014572 0ustar hornikusers## write.nexus.data.R (2015-02-04) ## Write Character Data in NEXUS Format ## Copyright 2006-2015 Johan Nylander, Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. write.nexus.data <- function(x, file, format = "dna", datablock = TRUE, interleaved = TRUE, charsperline = NULL, gap = NULL, missing = NULL) { ### TODO: Standard data, mixed data, nice indent format <- match.arg(toupper(format), c("DNA", "PROTEIN")) indent <- " " # Two blanks maxtax <- 5 # Max nr of taxon names to be printed on a line defcharsperline <- 80 # Default nr of characters per line if interleaved defgap <- "-" # Default gap character defmissing <- "?" # Default missing data character if (is.matrix(x)) { if (inherits(x, "DNAbin")) x <- as.list(x) else { xbak <- x x <- vector("list", nrow(xbak)) for (i in seq_along(x)) x[[i]] <- xbak[i, ] names(x) <- rownames(xbak) rm(xbak) } } ntax <- length(x) nchars <- length(x[[1]]) zz <- file(file, "w") if (is.null(names(x))) names(x) <- as.character(1:ntax) fcat <- function(..., file = zz) cat(..., file = file, sep = "", append = TRUE) find.max.length <- function(x) max(nchar(x)) print.matrix <- function(x, dindent = " ") { Names <- names(x) printlength <- find.max.length(Names) + 2 if (!interleaved) { for (i in seq_along(x)) { sequence <- paste(x[[i]], collapse = "") taxon <- Names[i] thestring <- sprintf("%-*s%s%s", printlength, taxon, dindent, sequence) fcat(indent, indent, thestring, "\n") } } else { ntimes <- ceiling(nchars/charsperline) start <- 1 end <- charsperline for (j in seq_len(ntimes)) { for (i in seq_along(x)) { sequence <- paste(x[[i]][start:end], collapse = "") taxon <- Names[i] thestring <- sprintf("%-*s%s%s", printlength, taxon, dindent, sequence) fcat(indent, indent, thestring, "\n") } if (j < ntimes) fcat("\n") start <- start + charsperline end <- end + charsperline if (end > nchars) end <- nchars } } } fcat("#NEXUS\n[Data written by write.nexus.data.R, ", date(), "]\n") NCHAR <- paste("NCHAR=", nchars, sep = "") NTAX <- paste0("NTAX=", ntax) DATATYPE <- paste0("DATATYPE=", format) # fix by Robin Cristofari (2015-02-04) if (is.null(charsperline)) { if (nchars <= defcharsperline) { charsperline <- nchars interleaved <- FALSE } else charsperline <- defcharsperline } if (is.null(missing)) missing <- defmissing MISSING <- paste0("MISSING=", missing) if (is.null(gap)) gap <- defgap GAP <- paste0("GAP=", gap) INTERLEAVE <- if (interleaved) "INTERLEAVE=YES" else "INTERLEAVE=NO" if (datablock) { fcat("BEGIN DATA;\n") fcat(indent, "DIMENSIONS ", NTAX, " ", NCHAR, ";\n") ## only DNA and PROTEIN is supported for the moment, so the ## following 'if' is not needed ## if (format %in% c("DNA", "PROTEIN")) # from Francois Michonneau (2009-10-02) fcat(indent, "FORMAT", " ", DATATYPE, " ", MISSING, " ", GAP, " ", INTERLEAVE, ";\n") ## fcat(indent, "MATRIX\n") print.matrix(x) fcat(indent, ";\nEND;\n\n") } else { fcat("BEGIN TAXA;\n") fcat(indent, "DIMENSIONS", " ", NTAX, ";\n") fcat(indent, "TAXLABELS\n") fcat(indent, indent) j <- 0 for (i in seq_len(ntax)) { fcat(names(x[i]), " ") j <- j + 1 if (j == maxtax) { fcat("\n", indent, indent) j <- 0 } } fcat("\n", indent, ";\n") fcat("END;\n\nBEGIN CHARACTERS;\n") fcat(indent, "DIMENSIONS", " ", NCHAR, ";\n") ## only DNA and PROTEIN is supported for the moment, so the ## following 'if' is not needed ## if (format %in% c("DNA", "PROTEIN")) fcat(indent, "FORMAT", " ", MISSING, " ", GAP, " ", DATATYPE, " ", INTERLEAVE, ";\n") ## fcat(indent,"MATRIX\n") print.matrix(x) fcat(indent, ";\nEND;\n\n") } close(zz) } ape/R/compar.gee.R0000644000175100001440000001432412520626433013410 0ustar hornikusers## compar.gee.R (2015-05-01) ## Comparative Analysis with GEEs ## Copyright 2002-2015 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. compar.gee <- function(formula, data = NULL, family = gaussian, phy, corStruct, scale.fix = FALSE, scale.value = 1) { if (requireNamespace("gee", quietly = TRUE)) gee <- gee::gee else stop("package 'gee' not available") if (!missing(corStruct)) { if (!missing(phy)) warning("the phylogeny was ignored because you gave a 'corStruct' object") R <- vcv(corStruct, corr = TRUE) } else { R <- vcv(phy, corr = TRUE) } if (is.null(data)) data <- parent.frame() else { nmsR <- rownames(R) if (!identical(rownames(data), nmsR)) { if (!any(is.na(match(rownames(data), nmsR)))) data <- data[nmsR, ] else { msg <- if (missing(corStruct)) "the tip labels of the tree" else "those of the correlation structure" msg <- paste("the rownames of the data.frame and", msg, "do not match: the former were ignored in the analysis") warning(msg) } } } effect.assign <- attr(model.matrix(formula, data = data), "assign") for (i in all.vars(formula)) { if (any(is.na(eval(parse(text = i), envir = data)))) stop("the present method cannot be used with missing data: you may consider removing the species with missing data from your tree with the function 'drop.tip'.") } id <- rep(1, dim(R)[1]) geemod <- do.call("gee", list(formula, id, data = data, family = family, R = R, corstr = "fixed", scale.fix = scale.fix, scale.value = scale.value)) W <- geemod$naive.variance fname <- if (is.function(family)) deparse(substitute(family)) else if (is.list(family)) family$family else family if (fname == "binomial") W <- summary(glm(formula, family = quasibinomial, data = data))$cov.scaled N <- geemod$nobs ## ## maybe need to refine below in case of non-Brownian corStruct if (!missing(corStruct)) phy <- attr(corStruct, "tree") dfP <- sum(phy$edge.length)*N / sum(diag(vcv(phy))) # need the variances ## ## compute QIC: Y <- geemod$y MU <- geemod$fitted.values Qlik <- switch(fname, "gaussian" = -sum((Y - MU)^2)/2, "binomial" = sum(Y*log(MU/(1 - MU)) + log(1 - MU)), "poisson" = sum(Y*log(MU) - MU), "Gamma" = sum(Y/MU + log(MU)), "inverse.gaussian" = sum(-Y/(2*MU^2) + 1/MU)) Ai <- do.call("gee", list(formula, id, data = data, family = family, corstr = "independence", scale.fix = scale.fix, scale.value = scale.value))$naive.variance QIC <- -2*Qlik + 2*sum(diag(solve(Ai) %*% W)) obj <- list(call = match.call(), effect.assign = effect.assign, nobs = N, QIC = QIC, coefficients = geemod$coefficients, residuals = geemod$residuals, fitted.values = MU, family = geemod$family$family, link = geemod$family$link, scale = geemod$scale, W = W, dfP = dfP) class(obj) <- "compar.gee" obj } print.compar.gee <- function(x, ...) { nas <- is.na(x$coef) coef <- x$coef[!nas] cnames <- names(coef) coef <- matrix(rep(coef, 4), ncol = 4) dimnames(coef) <- list(cnames, c("Estimate", "S.E.", "t", "Pr(T > |t|)")) df <- x$dfP - dim(coef)[1] coef[, 2] <- sqrt(diag(x$W)) coef[, 3] <- coef[, 1]/coef[, 2] if (df < 0) { warning("not enough degrees of freedom to compute P-values.") coef[, 4] <- NA } else coef[, 4] <- 2 * (1 - pt(abs(coef[, 3]), df)) residu <- quantile(as.vector(x$residuals)) names(residu) <- c("Min", "1Q", "Median", "3Q", "Max") cat("Call: ") print(x$call) cat("Number of observations: ", x$nobs, "\n") cat("Model:\n") cat(" Link:", x$link, "\n") cat(" Variance to Mean Relation:", x$family, "\n") cat("\nQIC:", x$QIC, "\n") cat("\nSummary of Residuals:\n") print(residu) if (any(nas)) cat("\n\nCoefficients: (", sum(nas), " not defined because of singularities)\n", sep = "") else cat("\n\nCoefficients:\n") print(coef) cat("\nEstimated Scale Parameter: ", x$scale) cat("\n\"Phylogenetic\" df (dfP): ", x$dfP, "\n") } drop1.compar.gee <- function(object, scope, quiet = FALSE, ...) { fm <- formula(object$call) trm <- terms(fm) z <- attr(trm, "term.labels") ind <- object$effect.assign n <- length(z) ans <- matrix(NA, n, 3) for (i in 1:n) { wh <- which(ind == i) ans[i, 1] <- length(wh) ans[i, 2] <- t(object$coefficients[wh]) %*% solve(object$W[wh, wh]) %*% object$coefficients[wh] } df <- object$dfP - length(object$coefficients) if (df < 0) warning("not enough degrees of freedom to compute P-values.") else ans[, 3] <- pf(ans[, 2], ans[, 1], df, lower.tail = FALSE) colnames(ans) <- c("df", "F", "Pr(>F)") rownames(ans) <- z if (any(attr(trm, "order") > 1) && !quiet) warning("there is at least one interaction term in your model: you should be careful when interpreting the significance of the main effects.") class(ans) <- "anova" attr(ans, "heading") <- paste("Single term deletions\n\n Model:", as.character(as.expression(fm)), "\n") ans } predict.compar.gee <- function(object, newdata = NULL, type = c("link", "response"), ...) { type <- match.arg(type) pred <- if (is.null(newdata)) object$fitted.values else { frm <- formula(object$call$formula)[-2] X <- model.matrix(frm, data = newdata) beta <- object$coefficients X[, names(beta), drop = FALSE] %*% beta } if (type == "link") return(pred) f <- match.fun(object$family) f(link = object$link)$linkinv(pred) } ape/R/cherry.R0000644000175100001440000000374712465112403012666 0ustar hornikusers## cherry.R (2009-05-10) ## Number of Cherries and Null Models of Trees ## Copyright 2002-2009 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. cherry <- function(phy) { if (!inherits(phy, "phylo")) stop('object "phy" is not of class "phylo"') n <- length(phy$tip.label) nb.node <- phy$Nnode if (nb.node != n - 1) stop('"phy" is not fully dichotomous') if (n < 4) stop("not enough tips in your phylogeny for this analysis") cherry <- sum(tabulate(phy$edge[, 1][phy$edge[, 2] <= n]) == 2) small.n <- n < 20 if (small.n) { P.yule <- f.cherry.yule(n, cherry) P.uniform <- f.cherry.uniform(n, cherry) } else { P.yule <- 2*(1 - pnorm(abs(cherry - n/3)/sqrt(2*n/45))) mu.unif <- n*(n - 1)/(2*(2*n - 5)) sigma2.unif <- n*(n - 1)*(n - 4)*(n - 5)/(2*(2*n - 5)^2 * (2*n -7)) P.uniform <- 2*(1 - pnorm(abs(cherry - mu.unif)/sqrt(sigma2.unif))) } cat("\nAnalysis of the Number of Cherries in a Tree\n\n") cat("Phylogenetic tree:", deparse(substitute(phy)), "\n") cat("Number of tips:", n, "\n") cat("Number of cherries:", cherry, "\n\n") cat("Null hypothesis: Yule model\n") cat(" P-value =", round(P.yule, 4), "\n\n") cat("Null hypothesis: uniform model\n") cat(" P-value =", round(P.uniform, 4), "\n\n") if (!small.n) cat("(P-values were computed using normal approximations)\n") } f.cherry.yule <- function(n, k) { if (k == 0 || k > floor(n/2)) 0 else if (n == 4) if (k == 1) 2/3 else if (k == 2) 1/3 else 0 else (1 - 2*(k - 1)/(n - 1))*f.cherry.yule(n - 1, k - 1) + 2*k/(n - 1)*f.cherry.yule(n - 1, k) } f.cherry.uniform <- function(n, k) { if (k == 0 || k > floor(n/2)) 0 else if (n == 4) if (k == 1) 4/5 else if (k == 2) 1/5 else 0 else if (k == 1) 0 else (gamma(n + 1)*gamma(n - 2 + 1)*gamma(n - 4 + 1) * 2^(n-2*k)) / (gamma(n - 2*k + 1)*gamma(2*n - 4 + 1)*gamma(k + 1)*gamma(k - 2 + 1)) } ape/R/as.phylo.formula.R0000644000175100001440000000327312465112403014565 0ustar hornikusers## as.phylo.formula.R (2005-12-10) ## Conversion from Taxonomy Variables to Phylogenetic Trees ## Copyright 2005 Julien Dutheil ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. as.phylo.formula <- function(x, data=parent.frame(), ...) { # Testing formula syntax: err <- "Formula must be of the kind \"~A1/A2/.../An\"." if(length(x) != 2) stop(err) if(x[[1]] != "~") stop(err) f <- x[[2]] taxo <- list() while(length(f) == 3) { if(f[[1]] != "/") stop(err) if(!is.factor(data[[deparse(f[[3]])]])) stop(paste("Variable", deparse(f[[3]]), "must be a factor.")) taxo[[deparse(f[[3]])]] <- data[[deparse(f[[3]])]] if(length(f) > 1) f <- f[[2]] } if(!is.factor(data[[deparse(f)]])) stop(paste("Variable", deparse(f), "must be a factor.")) taxo[[deparse(f)]] <- data[[deparse(f)]] taxo.data <- as.data.frame(taxo) leaves.names <- as.character(taxo.data[,1]) taxo.data[,1] <- 1:nrow(taxo.data) # Now builds the phylogeny: f.rec <- function(subtaxo) { # Recurrent utility function u <- ncol(subtaxo) levels <- unique(subtaxo[,u]) if(u == 1) { if(length(levels) != nrow(subtaxo)) warning("Error, leaves names are not unique.") return(as.character(subtaxo[,1])) } t <- character(length(levels)) for(l in 1:length(levels)) { x <- f.rec(subtaxo[subtaxo[,u] == levels[l],][1:(u-1)]) if(length(x) == 1) t[l] <- x else t[l] <- paste("(", paste(x, collapse=","), ")", sep="") } return(t) } string <- paste("(", paste(f.rec(taxo.data), collapse=","), ");", sep="") phy<-read.tree(text=string) phy$tip.label <- leaves.names[as.numeric(phy$tip.label)] return(phy) } ape/R/howmanytrees.R0000644000175100001440000000264012465112403014106 0ustar hornikusers## howmanytrees.R (2004-12-23) ## Calculate Numbers of Phylogenetic Trees ## Copyright 2004 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. howmanytrees <- function(n, rooted = TRUE, binary = TRUE, labeled = TRUE, detail = FALSE) { if (!labeled && !(rooted & binary)) stop("can compute number of unlabeled trees only for rooted binary cases.") if (n < 3) N <- 1 else { if (labeled) { if (!rooted) n <- n - 1 if (binary) N <- prod(seq(1, (2*n - 3), by = 2)) else { N <- matrix(0, n, n - 1) N[1:n, 1] <- 1 for (i in 3:n) for (j in 2:(i - 1)) N[i, j] <- (i + j - 2)*N[i - 1, j - 1] + j*N[i - 1, j] if (detail) { rownames(N) <- 1:n colnames(N) <- 1:(n - 1) } else N <- sum(N[n, ]) } } else { N <- numeric(n) N[1] <- 1 for (i in 2:n) if (i %% 2) N[i] <- sum(N[1:((i - 1)/2)]*N[(i - 1):((i + 1)/2)]) else { x <- N[1:(i/2)] y <- N[(i - 1):(i/2)] y[length(y)] <- (y[length(y)] + 1)/2 N[i] <- sum(x*y) } if (detail) names(N) <- 1:n else N <- N[n] } } N } ape/R/as.phylo.R0000644000175100001440000000755113002744114013122 0ustar hornikusers## as.phylo.R (2015-10-16) ## Conversion Among Tree Objects ## Copyright 2005-2015 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. old2new.phylo <- function(phy) { mode(phy$edge) <- "numeric" phy$Nnode <- -min(phy$edge) n <- length(phy$tip.label) NODES <- phy$edge < 0 phy$edge[NODES] <- n - phy$edge[NODES] phy } new2old.phylo <- function(phy) { NTIP <- length(phy$tip.label) NODES <- phy$edge > NTIP phy$edge[NODES] <- NTIP - phy$edge[NODES] mode(phy$edge) <- "character" phy$Nnode <- NULL phy } as.phylo <- function (x, ...) { if (identical(class(x), "phylo")) return(x) UseMethod("as.phylo") } as.phylo.hclust <- function(x, ...) { N <- dim(x$merge)[1] edge <- matrix(0L, 2*N, 2) edge.length <- numeric(2*N) ## `node' gives the number of the node for the i-th row of x$merge node <- integer(N) node[N] <- N + 2L cur.nod <- N + 3L j <- 1L for (i in N:1) { edge[j:(j + 1), 1] <- node[i] for (l in 1:2) { k <- j + l - 1L y <- x$merge[i, l] if (y > 0) { edge[k, 2] <- node[y] <- cur.nod cur.nod <- cur.nod + 1L edge.length[k] <- x$height[i] - x$height[y] } else { edge[k, 2] <- -y edge.length[k] <- x$height[i] } } j <- j + 2L } if (is.null(x$labels)) x$labels <- as.character(1:(N + 1)) obj <- list(edge = edge, edge.length = edge.length / 2, tip.label = x$labels, Nnode = N) class(obj) <- "phylo" reorder(obj) } as.phylo.phylog <- function(x, ...) { tr <- read.tree(text = x$tre) n <- length(tr$tip.label) edge.length <- numeric(dim(tr$edge)[1]) term <- which(tr$edge[, 2] <= n) inte <- which(tr$edge[, 2] > n) edge.length[term] <- x$leaves[tr$tip.label] edge.length[inte] <- x$nodes[tr$node.label][-1] tr$edge.length <- edge.length if (x$nodes["Root"] != 0) { tr$edge.root <- x$nodes["Root"] names(tr$edge.root) <- NULL } tr } as.hclust.phylo <- function(x, ...) { if (!is.ultrametric(x)) stop("the tree is not ultrametric") if (!is.binary.phylo(x)) stop("the tree is not binary") if (!is.rooted(x)) stop("the tree is not rooted") n <- length(x$tip.label) x$node.label <- NULL # by Jinlong Zhang (2010-12-15) bt <- branching.times(x) N <- n - 1L x <- reorder(x, "postorder") m <- matrix(x$edge[, 2], N, 2, byrow = TRUE) anc <- x$edge[c(TRUE, FALSE), 1] bt <- sort(bt[as.character(anc)]) o <- match(names(bt), anc) m <- m[o, ] ## first renumber the tips: TIPS <- m <= n m[TIPS] <- -m[TIPS] ## then renumber the nodes: oldnodes <- as.numeric(names(bt))[-N] m[match(oldnodes, m)] <- 1:(N - 1) names(bt) <- NULL obj <- list(merge = m, height = 2*bt, order = 1:n, labels = x$tip.label, call = match.call(), method = "unknown") class(obj) <- "hclust" obj } if (getRversion() >= "2.15.1") utils::globalVariables(c("network", "network.vertex.names<-")) as.network.phylo <- function(x, directed = is.rooted(x), ...) { if (is.null(x$node.label)) x <- makeNodeLabel(x) res <- network(x$edge, directed = directed, ...) network.vertex.names(res) <- c(x$tip.label, x$node.label) res } if (getRversion() >= "2.15.1") utils::globalVariables("graph.edgelist") as.igraph.phylo <- function(x, directed = is.rooted(x), use.labels = TRUE, ...) { ## local copy because x will be changed before evaluating is.rooted(x): directed <- directed if (use.labels) { if (is.null(x$node.label)) x <- makeNodeLabel(x) x$edge <- matrix(c(x$tip.label, x$node.label)[x$edge], ncol = 2) } else x$edge <- x$edge - 1L graph.edgelist(x$edge, directed = directed, ...) } ape/R/summary.phylo.R0000644000175100001440000002023513015523664014217 0ustar hornikusers## summary.phylo.R (2016-11-24) ## Print Summary of a Phylogeny and "multiPhylo" operators ## Copyright 2003-2016 Emmanuel Paradis, 2006 Ben Bolker, and Klaus Schliep 2016 ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. Ntip <- function(phy) UseMethod("Ntip") Ntip.phylo <- function(phy) length(phy$tip.label) Ntip.multiPhylo <- function(phy) { labs <- attr(phy, "TipLabel") if (is.null(labs)) sapply(unclass(phy), Ntip.phylo) else setNames(rep(length(labs), length(phy)), names(phy)) } Nnode <- function(phy, ...) UseMethod("Nnode") Nnode.phylo <- function(phy, internal.only = TRUE, ...) { if (internal.only) return(phy$Nnode) phy$Nnode + length(phy$tip.label) } Nnode.multiPhylo <- function(phy, internal.only = TRUE, ...) { res <- sapply(unclass(phy), "[[", "Nnode") if (internal.only) return(res) res + Ntip.multiPhylo(phy) } Nedge <- function(phy) UseMethod("Nedge") Nedge.phylo <- function(phy) dim(phy$edge)[1] Nedge.multiPhylo <- function(phy) sapply(unclass(phy), Nedge.phylo) summary.phylo <- function(object, ...) { cat("\nPhylogenetic tree:", deparse(substitute(object)), "\n\n") nb.tip <- length(object$tip.label) nb.node <- object$Nnode cat(" Number of tips:", nb.tip, "\n") cat(" Number of nodes:", nb.node, "\n") if (is.null(object$edge.length)) cat(" No branch lengths.\n") else { cat(" Branch lengths:\n") cat(" mean:", mean(object$edge.length), "\n") cat(" variance:", var(object$edge.length), "\n") cat(" distribution summary:\n") print(summary(object$edge.length)[-4]) } if (is.null(object$root.edge)) cat(" No root edge.\n") else cat(" Root edge:", object$root.edge, "\n") if (nb.tip <= 10) { cat(" Tip labels:", object$tip.label[1], "\n") cat(paste(" ", object$tip.label[-1]), sep = "\n") } else { cat(" First ten tip labels:", object$tip.label[1], "\n") cat(paste(" ", object$tip.label[2:10]), sep = "\n") } if (is.null(object$node.label)) cat(" No node labels.\n") else { if (nb.node <= 10) { cat(" Node labels:", object$node.label[1], "\n") cat(paste(" ", object$node.label[-1]), sep = "\n") } else { cat(" First ten node labels:", object$node.label[1], "\n") cat(paste(" ", object$node.label[2:10]), sep = "\n") } } } ### by BB: print.phylo <- function(x, printlen = 6,...) { nb.tip <- length(x$tip.label) nb.node <- x$Nnode cat(paste("\nPhylogenetic tree with", nb.tip, "tips and", nb.node, "internal nodes.\n\n")) cat("Tip labels:\n") if (nb.tip > printlen) { cat(paste("\t", paste(x$tip.label[1:printlen], collapse=", "), ", ...\n", sep = "")) } else print(x$tip.label) if (!is.null(x$node.label)) { cat("Node labels:\n") if (nb.node > printlen) { cat(paste("\t", paste(x$node.label[1:printlen], collapse=", "), ", ...\n", sep = "")) } else print(x$node.label) } rlab <- if (is.rooted(x)) "Rooted" else "Unrooted" cat("\n", rlab, "; ", sep="") blen <- if (is.null(x$edge.length)) "no branch lengths." else "includes branch lengths." cat(blen, "\n", sep = "") } print.multiPhylo <- function(x, details = FALSE, ...) { N <- length(x) cat(N, "phylogenetic trees\n") if (details) for (i in 1:N) cat("tree", i, ":", length(x[[i]]$tip.label), "tips\n") } "[[.multiPhylo" <- function(x, i) { class(x) <- NULL phy <- x[[i]] if (!is.null(attr(x, "TipLabel"))) phy$tip.label <- attr(x, "TipLabel") phy } `$.multiPhylo` <- function(x, name) x[[name]] "[.multiPhylo" <- function(x, i) { oc <- oldClass(x) class(x) <- NULL structure(x[i], TipLabel = attr(x, "TipLabel"), class = oc) } str.multiPhylo <- function(object, ...) { class(object) <- NULL cat('Class "multiPhylo"\n') str(object, ...) } .c_phylo_single <- function(phy) structure(list(phy), class = "multiPhylo") c.phylo <- function(..., recursive = TRUE) { obj <- list(...) classes <- lapply(obj, class) isphylo <- sapply(classes, function(x) "phylo" %in% x) if (all(isphylo)) { class(obj) <- "multiPhylo" return(obj) } if (!recursive) return(obj) ismulti <- sapply(classes, function(x) "multiPhylo" %in% x) if (all(isphylo | ismulti)) { for (i in which(isphylo)) obj[[i]] <- .c_phylo_single(obj[[i]]) ## added by Klaus: for (i in which(ismulti)) obj[[i]] <- .uncompressTipLabel(obj[[i]]) obj <- .makeMultiPhyloFromObj(obj) } else { warning('some objects not of class "phylo" or "multiPhylo": argument recursive=TRUE ignored') } obj } # this is an option to avoid growing the list, better check it also # not really as important as long the list of trees is short (by Klaus) .makeMultiPhyloFromObj <- function(obj) { n <- length(obj) N <- lengths(obj, FALSE) cs <- c(0, cumsum(N)) x <- vector("list", cs[length(cs)]) for (i in 1:n) { a <- cs[i] + 1L b <- cs[i + 1L] x[a:b] <- obj[[i]] } class(x) <- "multiPhylo" x } ## the original code: ##.makeMultiPhyloFromObj <- function(obj) ##{ ## n <- length(obj) ## x <- obj[[1L]] ## N <- length(x) ## i <- 2L ## while (i <= n) { ## a <- N + 1L ## N <- N + length(obj[[i]]) ## ## x is of class "multiPhylo", so this uses the operator below: ## x[a:N] <- obj[[i]] ## i <- i + 1L ## } ## x ##} c.multiPhylo <- function(..., recursive = TRUE) { obj <- list(...) if (!recursive) return(obj) classes <- lapply(obj, class) isphylo <- sapply(classes, function(x) "phylo" %in% x) ismulti <- sapply(classes, function(x) "multiPhylo" %in% x) if (!all(isphylo | ismulti)) { warning('some objects not of class "phylo" or "multiPhylo": argument recursive=TRUE ignored') return(obj) } for (i in which(isphylo)) obj[[i]] <- .c_phylo_single(obj[[i]]) ## added by Klaus for (i in which(ismulti)) obj[[i]] <- .uncompressTipLabel(obj[[i]]) .makeMultiPhyloFromObj(obj) } .uncompressTipLabel <- function(x) { Lab <- attr(x, "TipLabel") if (is.null(Lab)) return(x) class(x) <- NULL for (i in 1:length(x)) x[[i]]$tip.label <- Lab class(x) <- "multiPhylo" attr(x, "TipLabel") <- NULL x } `[<-.multiPhylo` <- function(x, ..., value) { ## recycling is allowed so no need to check: length(value) != length(..1) ## check that all elements in 'value' inherit class "phylo" test <- unlist(lapply(value, function(xx) !inherits(xx, "phylo"))) if (any(test)) stop("at least one element in 'value' is not of class \"phylo\".") oc <- oldClass(x) class(x) <- NULL if (is.null(attr(x, "TipLabel"))) { x[..1] <- value class(x) <- oc return(x) } x[..1] <- 0L # in case x needs to be elongated class(x) <- oc j <- 1L for (i in ..1) { ## x is of class "multiPhylo", so this uses the operator below: x[[i]] <- value[[j]] j <- j + 1L } x } `[[<-.multiPhylo` <- function(x, ..., value) { if (!inherits(value, "phylo")) stop('trying to assign an object not of class "phylo" into an object of class "multiPhylo".') oc <- oldClass(x) class(x) <- NULL Lab <- attr(x, "TipLabel") if (!is.null(Lab)) { n <- length(Lab) if (n != length(value$tip.label)) stop("tree with different number of tips than those in the list (which all have the same labels; maybe you want to uncompress them)") o <- match(value$tip.label, Lab) if (any(is.na(o))) stop("tree tip labels do not match with those in the list; maybe you want to uncompress them.") value$tip.label <- NULL ie <- match(o, value$edge[, 2]) value$edge[ie, 2] <- 1:n } x[[..1]] <- value class(x) <- oc x } `$<-.multiPhylo` <- function(x, ..., value) { x[[..1]] <- value x } ape/R/birthdeath.R0000644000175100001440000001215312465112403013477 0ustar hornikusers## birthdeath.R (2012-04-20) ## Estimation of Speciation and Extinction Rates ## with Birth-Death Models ## birthdeath: standard model ## bd.ext: extended version ## Copyright 2002-2012 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. birthdeath <- function(phy) { if (!inherits(phy, "phylo")) stop('object "phy" is not of class "phylo"') N <- length(phy$tip.label) x <- c(NA, branching.times(phy)) dev <- function(a, r) { if (r < 0 || a > 1) return(1e100) -2 * (lfactorial(N - 1) + (N - 2) * log(r) + r * sum(x[3:N]) + N * log(1 - a) - 2 * sum(log(exp(r * x[2:N]) - a))) } out <- nlm(function(p) dev(p[1], p[2]), c(0.1, 0.2), hessian = TRUE) if (out$estimate[1] < 0) { out <- nlm(function(p) dev(0, p), 0.2, hessian = TRUE) para <- c(0, out$estimate) inv.hessian <- try(solve(out$hessian)) se <- if (class(inv.hessian) == "try-error") NA else sqrt(diag(inv.hessian)) se <- c(0, se) } else { para <- out$estimate inv.hessian <- try(solve(out$hessian)) se <- if (class(inv.hessian) == "try-error") c(NA, NA) else sqrt(diag(inv.hessian)) } Dev <- out$minimum ## 95% profile likelihood CIs ## which: index of the parameter (1 or 2) ## s: sign of the increment (-1 or +1) foo <- function(which, s) { i <- 0.1 if (which == 1) { p <- para[1] + s * i bar <- function() dev(p, para[2]) } else { # which == 2 p <- para[2] + s * i bar <- function() dev(para[1], p) } while (i > 1e-9) { while (bar() < Dev + 3.84) p <- p + s * i p <- p - s * i i <- i / 10 } p } CI <- mapply(foo, c(1, 2, 1, 2), c(-1, -1, 1, 1)) dim(CI) <- c(2, 2) names(para) <- names(se) <- rownames(CI) <- c("d/b", "b-d") colnames(CI) <- c("lo", "up") obj <- list(tree = deparse(substitute(phy)), N = N, dev = Dev, para = para, se = se, CI = CI) class(obj) <- "birthdeath" obj } print.birthdeath <- function(x, ...) { cat("\nEstimation of Speciation and Extinction Rates\n") cat(" with Birth-Death Models\n\n") cat(" Phylogenetic tree:", x$tree, "\n") cat(" Number of tips:", x$N, "\n") cat(" Deviance:", x$dev, "\n") cat(" Log-likelihood:", -(x$dev)/2, "\n") cat(" Parameter estimates:\n") cat(" d / b =", x$para[1], " StdErr =", x$se[1], "\n") cat(" b - d =", x$para[2], " StdErr =", x$se[2], "\n") cat(" (b: speciation rate, d: extinction rate)\n") cat(" Profile likelihood 95% confidence intervals:\n") cat(" d / b: [", x$CI[1, 1], ", ", x$CI[1, 2], "]", "\n", sep = "") cat(" b - d: [", x$CI[2, 1], ", ", x$CI[2, 2], "]", "\n\n", sep = "") } bd.ext <- function(phy, S, conditional = TRUE) { if (!inherits(phy, "phylo")) stop('object "phy" is not of class "phylo"') if (!is.null(names(S))) { if (all(names(S) %in% phy$tip.label)) S <- S[phy$tip.label] else warning('the names of argument "S" and the tip labels did not match: the former were ignored.') } N <- length(S) x <- branching.times(phy) x <- c(x[1], x) trm.br <- phy$edge.length[phy$edge[, 2] <= N] if (conditional) { dev <- function(a, r) { if (a >= 1 || a < 0 || r <= 0) return(1e50) ert <- exp(r * trm.br) zeta <- (ert - 1)/(ert - a) -2 * (lfactorial(N - 1) + (N - 2) * log(r) + N * log(1 - a) + 2 * r * sum(x[2:N]) - 2 * sum(log(exp(r * x[2:N]) - a)) + sum(log(1 - zeta) + (S - 1)*log(zeta))) } } else { dev <- function(a, r) { if (a >= 1 || a < 0 || r <= 0) return(1e50) -2 * (lfactorial(N - 1) + (N - 2) * log(r) + (3 * N) * log(1 - a) + 2 * r * sum(x[2:N]) - 2 * sum(log(exp(r * x[2:N]) - a)) + r * sum(trm.br) + sum((S - 1) * log(exp(r * trm.br) - 1)) - sum((S + 1) * log(exp(r * trm.br) - a))) } } out <- nlm(function(p) dev(p[1], p[2]), c(0.1, 0.2), hessian = TRUE) para <- out$estimate se <- sqrt(diag(solve(out$hessian))) Dev <- out$minimum cat("\nExtended Version of the Birth-Death Models to\n") cat(" Estimate Speciation and Extinction Rates\n\n") cat(" Data: phylogenetic:", deparse(substitute(phy)), "\n") cat(" taxonomic:", deparse(substitute(S)), "\n") cat(" Number of tips:", N, "\n") cat(" Deviance:", Dev, "\n") cat(" Log-likelihood:", -Dev/2, "\n") cat(" Parameter estimates:\n") cat(" d / b =", para[1], " StdErr =", se[1], "\n") cat(" b - d =", para[2], " StdErr =", se[2], "\n") cat(" (b: speciation rate, d: extinction rate)\n") } ape/R/subtreeplot.R0000644000175100001440000000261712465112403013735 0ustar hornikusers## subtreeplot.R (2008-04-30) ## Zoom on a Portion of a Phylogeny by Successive Clicks ## Copyright 2008 Damien de Vienne ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. subtreeplot<-function(x, wait=FALSE, ...) { sub<-subtrees(x, wait=wait) y<-NULL plot.default(0, type="n",axes=FALSE, ann=FALSE) repeat { split.screen(c(1,2)) screen(2) if (is.null(y)) plot(x,...) else plot(y,sub=paste("Node :", click),...) screen(1) plot(x,sub="Complete tree",main="Type ESC or right click to exit", cex.main=0.9, ...) N.tip<-Ntip(x) N.node<-Nnode(x) coor<-plotPhyloCoor(x) tips<-x$tip.label nodes<-x$node.label if (is.null(x$node.label)) nodes<-(N.tip+1):(N.tip+N.node) labs<-c(rep("",N.tip), nodes) click<-identify(coor[,1], coor[,2], labels=labs, n=1) if (length(click) == 0) {return(y)} if (click > N.tip) { close.screen(c(1,2),all.screens = TRUE) split.screen(c(1,2)) screen(1) #selects the screen to plot in plot(x, sub="Complete tree", ...) # plots x in screen 1 (left) screen(2) for (i in 1:length(sub)) if (sub[[i]]$name==click) break y<-sub[[i]] } else cat("this is a tip, you have to choose a node\n") } on.exit(return(y)) } ape/R/nodepath.R0000644000175100001440000000303012465112403013155 0ustar hornikusers## nodepath.R (2014-11-06) ## Find Paths of Nodes ## Copyright 2014 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. nodepath <- function(phy, from = NULL, to = NULL) { if (!inherits(phy, "phylo")) stop("object \"phy\" is not of class \"phylo\"") n <- length(phy$tip.label) m <- phy$Nnode root2tip <- .Call(seq_root2tip, phy$edge, n, m) if (is.null(from) || is.null(to)) return(root2tip) if (from < 1 || from > n + m) stop("'from' out of range") if (to < 1 || to > n + m) stop("'to' out of range") if (from == to) return(to) ## find the first occurrence of 'x' in the list root2tip foo <- function(x) { if (x <= n) return(x) # if x is a tip if (x == n + 1L) return(1L) # if x is the root i <- 1L repeat { if (any(root2tip[[i]] == x)) break i <- i + 1L } i } i <- foo(from) j <- foo(to) ## find path of nodes in a single vector 'seq' from root2tip findPath <- function(from, to, seq) { i <- which(seq == from) j <- which(seq == to) seq[i:j] } if (i == j) return(findPath(from, to, root2tip[[i]])) ## find the MRCA of 'from' and 'to' A <- root2tip[[i]] B <- root2tip[[j]] MRCA <- n + 1L # start from the root k <- 2L repeat { if (A[k] != B[k]) break MRCA <- A[k] k <- k + 1L } x <- findPath(MRCA, from, A) y <- findPath(MRCA, to, B) c(rev(x), y[-1]) } ape/R/all.equal.phylo.R0000644000175100001440000000644512465112403014400 0ustar hornikusers## all.equal.phylo.R (2009-07-05) ## ## Global Comparison of two Phylogenies ## Copyright 2006 Benoit Durand ## modified by EP for the new coding of "phylo" (2006-10-04) ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. ## Recherche de la correspondance entre deux arbres ## Parcours en profondeur et en parallele des deux arbres (current et target) ## current, target: les deux arbres a comparer ## use.edge.length: faut-il comparer les longueurs de branches ? ## use.tip.label: faut-il comparer les etiquettes de feuilles ou seulement la ## topologie des deux arbres ? ## index.return: si TRUE, retourner la matrice de correspondance entre noeuds ## et feuilles, une matrice a deux colonnes (current et target) avec pour ## chaque ligne des paires d'identifiants de noeuds/feuilles, tels qu'ils ## apparaissent dans l'attribut 'edge' des objets phylo ## tolerance, scale: parametres de comparaison des longueurs de branches ## (voir 'all.equal') all.equal.phylo <- function(target, current, use.edge.length = TRUE, use.tip.label = TRUE, index.return = FALSE, tolerance = .Machine$double.eps ^ 0.5, scale = NULL, ...) { same.node <- function(i, j) { # Comparaison de un noeud et une feuille if (xor(i > Ntip1, j > Ntip2)) return(NULL) # Comparaison de deux feuilles if (i <= Ntip1) { if (!use.tip.label) return(c(i, j)) if (current$tip.label[i] == target$tip.label[j]) return(c(i, j)) return(NULL) } # Comparaison de deux noeuds i.children <- which(current$edge[, 1] == i) j.children <- which(target$edge[, 1] == j) if (length(i.children) != length(j.children)) return(NULL) correspondance <- NULL for (i.child in i.children) { corresp <- NULL for (j.child in j.children) { if (!use.edge.length || isTRUE(all.equal(current$edge.length[i.child], target$edge.length[j.child], tolerance = tolerance, scale = scale))) corresp <- same.node(current$edge[i.child, 2], target$edge[j.child, 2]) if (!is.null(corresp)) break } if (is.null(corresp)) return(NULL) correspondance <- c(correspondance, i, j, corresp) j.children <- j.children[j.children != j.child] } return(correspondance) } Ntip1 <- length(target$tip.label) Ntip2 <- length(current$tip.label) root1 <- Ntip1 + 1 root2 <- Ntip2 + 1 if (root1 != root2) return(FALSE) ## Fix by EP so that unrooted trees are correctly compared: if (!is.rooted(target) && !is.rooted(current)) { outg <- target$tip.label[1] if (! outg %in% current$tip.label) return(FALSE) target <- root(target, outg) current <- root(current, outg) } ## End result <- same.node(root1, root2) if (!isTRUE(index.return)) return(!is.null(result)) if (is.null(result)) return(result) result <- t(matrix(result, nrow = 2)) colnames(result) = c('current', 'target') return(result) } ape/R/which.edge.R0000644000175100001440000000261012465112403013363 0ustar hornikusers## which.edge.R (2014-07-15) ## Identifies Edges of a Tree ## Copyright 2004-2014 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. getMRCA <- function(phy, tip) ### Find the MRCA of the tips given as `tip' ### (see `root.R' for comments on the code) { if (!inherits(phy, "phylo")) stop('object "phy" is not of class "phylo"') if (is.character(tip)) tip <- which(phy$tip.label %in% tip) if (length(tip) < 2) return(NULL) Ntip <- length(phy$tip.label) seq.nod <- .Call(seq_root2tip, phy$edge, Ntip, phy$Nnode) sn <- seq.nod[tip] MRCA <- Ntip + 1 i <- 2 repeat { x <- unique(unlist(lapply(sn, "[", i))) if (length(x) != 1) break MRCA <- x i <- i + 1 } MRCA } which.edge <- function(phy, group) { if (!inherits(phy, "phylo")) stop('object "phy" is not of class "phylo"') if (is.character(group)) group <- which(phy$tip.label %in% group) if (length(group) == 1) return(match(group, phy$edge[, 2])) n <- length(phy$tip.label) sn <- .Call(seq_root2tip, phy$edge, n, phy$Nnode)[group] i <- 2L repeat { x <- unique(unlist(lapply(sn, "[", i))) if (length(x) != 1) break i <- i + 1L } d <- -(1:(i - 1L)) x <- unique(unlist(lapply(sn, function(x) x[d]))) match(x, phy$edge[, 2L]) } ape/R/MoranI.R0000644000175100001440000001561612465112403012555 0ustar hornikusers## MoranI.R (2008-01-14) ## Moran's I Autocorrelation Index ## Copyright 2004 Julien Dutheil, 2007-2008 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. ## code cleaned-up by EP (Dec. 2007) Moran.I <- function(x, weight, scaled = FALSE, na.rm = FALSE, alternative = "two.sided") { if(dim(weight)[1] != dim(weight)[2]) stop("'weight' must be a square matrix") n <- length(x) if(dim(weight)[1] != n) stop("'weight' must have as many rows as observations in 'x'") ## Expected mean: ei <- -1/(n - 1) nas <- is.na(x) if (any(nas)) { if (na.rm) { x <- x[!nas] n <- length(x) weight <- weight[!nas, !nas] } else { warning("'x' has missing values: maybe you wanted to set na.rm=TRUE?") return(list(observed = NA, expected = ei, sd = NA, p.value = NA)) } } ## normaling the weights: ## Note that we normalize after possibly removing the ## missing data. ROWSUM <- rowSums(weight) ## the following is useful if an observation has no "neighbour": ROWSUM[ROWSUM == 0] <- 1 weight <- weight/ROWSUM # ROWSUM is properly recycled s <- sum(weight) m <- mean(x) y <- x - m # centre the x's cv <- sum(weight * y %o% y) v <- sum(y^2) obs <- (n/s) * (cv/v) ## Scaling: if (scaled) { i.max <- (n/s) * (sd(rowSums(weight) * y)/sqrt(v/(n - 1))) obs <- obs/i.max } ## Expected sd: S1 <- 0.5 * sum((weight + t(weight))^2) S2 <- sum((apply(weight, 1, sum) + apply(weight, 2, sum))^2) ## the above is the same than: ##S2 <- 0 ##for (i in 1:n) ## S2 <- S2 + (sum(weight[i, ]) + sum(weight[, i]))^2 s.sq <- s^2 k <- (sum(y^4)/n) / (v/n)^2 sdi <- sqrt((n*((n^2 - 3*n + 3)*S1 - n*S2 + 3*s.sq) - k*(n*(n - 1)*S1 - 2*n*S2 + 6*s.sq))/ ((n - 1)*(n - 2)*(n - 3)*s.sq) - 1/((n - 1)^2)) alternative <- match.arg(alternative, c("two.sided", "less", "greater")) pv <- pnorm(obs, mean = ei, sd = sdi) if (alternative == "two.sided") pv <- if (obs <= ei) 2*pv else 2*(1 - pv) if (alternative == "greater") pv <- 1 - pv list(observed = obs, expected = ei, sd = sdi, p.value = pv) } weight.taxo <- function(x) { d <- outer(x, x, "==") diag(d) <- 0 # implicitly converts 'd' into numeric d } weight.taxo2 <- function(x, y) { d <- outer(x, x, "==") & outer(y, y, "!=") diag(d) <- 0 d } correlogram.formula <- function(formula, data = NULL, use = "all.obs") { err <- 'formula must be of the form "y1+...+yn ~ x1/x2/../xn"' use <- match.arg(use, c("all.obs", "complete.obs", "pairwise.complete.obs")) if (formula[[1]] != "~") stop(err) lhs <- formula[[2]] y.nms <- if (length(lhs) > 1) unlist(strsplit(as.character(as.expression(lhs)), " \\+ ")) else as.character(as.expression(lhs)) rhs <- formula[[3]] gr.nms <- if (length(rhs) > 1) rev(unlist(strsplit(as.character(as.expression(rhs)), "/"))) else as.character(as.expression(rhs)) if (is.null(data)) { ## we 'get' the variables in the .GlobalEnv: y <- as.data.frame(sapply(y.nms, get)) gr <- as.data.frame(sapply(gr.nms, get)) } else { y <- data[y.nms] gr <- data[gr.nms] } if (use == "all.obs") { na.fail(y) na.fail(gr) } if (use == "complete.obs") { sel <- complete.cases(y, gr) y <- y[sel] gr <- gr[sel] } na.rm <- use == "pairwise.complete.obs" foo <- function(x, gr, na.rm) { res <- data.frame(obs = NA, p.values = NA, labels = colnames(gr)) for (i in 1:length(gr)) { sel <- if (na.rm) !is.na(x) & !is.na(gr[, i]) else TRUE xx <- x[sel] g <- gr[sel, i] w <- if (i > 1) weight.taxo2(g, gr[sel, i - 1]) else weight.taxo(g) o <- Moran.I(xx, w, scaled = TRUE) res[i, 1] <- o$observed res[i, 2] <- o$p.value } ## We need to specify the two classes; if we specify ## only "correlogram", 'res' is coerced as a list ## (data frames are of class "data.frame" and mode "list") structure(res, class = c("correlogram", "data.frame")) } if (length(y) == 1) foo(y[[1]], gr, na.rm) else structure(lapply(y, foo, gr = gr, na.rm = na.rm), names = y.nms, class = "correlogramList") } plot.correlogram <- function(x, legend = TRUE, test.level = 0.05, col = c("grey", "red"), type = "b", xlab = "", ylab = "Moran's I", pch = 21, cex = 2, ...) { BG <- col[(x$p.values < test.level) + 1] if (pch > 20 && pch < 26) { bg <- col col <- CO <- "black" } else { CO <- BG BG <- bg <- NULL } plot(1:length(x$obs), x$obs, type = type, xaxt = "n", xlab = xlab, ylab = ylab, col = CO, bg = BG, pch = pch, cex = cex, ...) axis(1, at = 1:length(x$obs), labels = x$labels) if (legend) legend("top", legend = paste(c("P >=", "P <"), test.level), pch = pch, col = col, pt.bg = bg, pt.cex = cex, horiz = TRUE) } plot.correlogramList <- function(x, lattice = TRUE, legend = TRUE, test.level = 0.05, col = c("grey", "red"), xlab = "", ylab = "Moran's I", type = "b", pch = 21, cex = 2, ...) { n <- length(x) obs <- unlist(lapply(x, "[[", "obs")) pval <- unlist(lapply(x, "[[", "p.values")) gr <- factor(unlist(lapply(x, "[[", "labels")), ordered = TRUE, levels = x[[1]]$labels) vars <- gl(n, nlevels(gr), labels = names(x)) BG <- col[(pval < test.level) + 1] if (lattice) { ## trellis.par.set(list(plot.symbol=list(pch=19))) xyplot(obs ~ gr | vars, xlab = xlab, ylab = ylab, panel = function(x, y) { panel.lines(x, y, lty = 2) panel.points(x, y, cex = cex, pch = 19, col = BG) ##lattice::panel.abline(h = 0, lty = 3) }) } else { if (pch > 20 && pch < 26) { bg <- col CO <- rep("black", length(obs)) col <- "black" } else { CO <- BG BG <- bg <- NULL } plot(as.numeric(gr), obs, type = "n", xlab = xlab, ylab = ylab, xaxt = "n") for (i in 1:n) { sel <- as.numeric(vars) == i lines(as.numeric(gr[sel]), obs[sel], type = type, lty = i, col = CO[sel], bg = BG[sel], pch = pch, cex = cex, ...) } axis(1, at = 1:length(x[[i]]$obs), labels = x[[i]]$labels) if (legend) { legend("topright", legend = names(x), lty = 1:n, bty = "n") legend("top", legend = paste(c("P >=", "P <"), test.level), pch = pch, col = col, pt.bg = bg, pt.cex = cex, horiz = TRUE) } } } ape/R/evonet.R0000644000175100001440000000603512465112403012663 0ustar hornikusers## evonet.R (2012-09-14) ## Evolutionary Networks ## Copyright 2011-2012 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. evonet <- function(phy, from, to = NULL) { if (!inherits(phy, "phylo")) stop('object "phy" is not of class "phylo".') if (!is.rooted(phy)) warning("the tree is unrooted") x <- phy if (is.null(to)) { if (is.data.frame(from)) from <- as.matrix(from) if (!is.matrix(from)) stop("'from' must be a matrix or a data frame if 'to' is not given") if (ncol(from) > 2) { warning("'from' has more than two columns: only the first two will be used.") ret <- from[, 1:2] } else if (ncol(from) < 2) { stop("'from' must have at least two columns") } else ret <- from } else { from <- as.vector(from) to <- as.vector(to) if (length(from) != length(to)) stop("'from' and 'to' not of the same length after coercing as vectors") ret <- cbind(from, to) } ## check that values are not out of range: storage.mode(ret) <- "integer" if (any(is.na(ret))) stop("some values are NA's after coercing as integers") if (any(ret < 0) || any(ret > Ntip(phy) + phy$Nnode)) stop("some values are out of range") x$reticulation <- ret class(x) <- c("evonet", "phylo") x } as.phylo.evonet <- function(x, ...) { x$reticulation <- NULL class(x) <- "phylo" x } plot.evonet <- function(x, col = "blue", lty = 1, lwd = 1, alpha = 0.5, arrows = 0, arrow.type = "classical", ...) { plot.phylo(as.phylo(x), ...) edges(x$reticulation[, 1], x$reticulation[, 2], col = rgb(t(col2rgb(col)), alpha = 255 * alpha, maxColorValue = 255), lty = lty, lwd = lwd, arrows = arrows, type = arrow.type) } as.networx.evonet <- function(x, weight = NA, ...) { if (any(x$reticulation <= Ntip(x))) stop("some tips are involved in reticulations: cannot convert to \"networx\"") x <- reorder(x, "postorder") ned <- Nedge(x) nrt <- nrow(x$reticulation) x$edge <- rbind(x$edge, x$reticulation) colnames(x$edge) <- c("oldNodes", "newNodes") x$reticulation <- NULL x$edge.length <- c(x$edge.length, rep(weight, length.out = nrt)) x$split <- c(1:ned, 1:nrt) class(x) <- c("networx", "phylo") x } as.network.evonet <- function(x, directed = TRUE, ...) { class(x) <- NULL x$edge <- rbind(x$edge, x$reticulation) as.network.phylo(x, directed = directed, ...) } as.igraph.evonet <- function(x, directed = TRUE, use.labels = TRUE, ...) { class(x) <- NULL x$edge <- rbind(x$edge, x$reticulation) as.igraph.phylo(x, directed = directed, use.labels = use.labels, ...) } print.evonet <- function(x, ...) { nr <- nrow(x$reticulation) cat("\n Evolutionary network with", nr, "reticulation") if (nr > 1) cat("s") cat("\n\n --- Base tree ---") print.phylo(as.phylo(x)) } ape/R/nj.R0000644000175100001440000000141412465112403011766 0ustar hornikusers## nj.R (2009-11-23) ## Neighbor-Joining Tree Estimation ## Copyright 2004-2009 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. nj <- function(X) { if (is.matrix(X)) X <- as.dist(X) if (any(is.na(X))) stop("missing values are not allowed in the distance matrix\nConsider using njs()") N <- attr(X, "Size") labels <- attr(X, "Labels") if (is.null(labels)) labels <- as.character(1:N) ans <- .C(C_nj, as.double(X), as.integer(N), integer(2*N - 3), integer(2*N - 3), double(2*N - 3), NAOK = TRUE) obj <- list(edge = cbind(ans[[3]], ans[[4]]), edge.length = ans[[5]], tip.label = labels, Nnode = N - 2L) class(obj) <- "phylo" reorder(obj) } ape/R/is.compatible.R0000644000175100001440000000147512465112403014117 0ustar hornikusers## is.compatible.R (2011-10-11) ## Check Compatibility of Splits ## Copyright 2011 Andrei-Alin Popescu ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. is.compatible <- function(obj) UseMethod("is.compatible") is.compatible.bitsplits <- function(obj) { m <- obj$matsplit n <- ncol(m) ntaxa <- length(obj$labels) for (i in 1:(n - 1)) for (j in (i + 1):n) if (!arecompatible(m[, i], m[, j], ntaxa)) return(FALSE) TRUE } arecompatible <-function(x, y, n) { msk <- !as.raw(2^(8 - (n %% 8)) - 1) foo <- function(v) { lv <- length(v) v[lv] <- v[lv] & msk as.integer(all(v == as.raw(0))) } nE <- foo(x & y) + foo(x & !y) + foo(!x & y) + foo(!x & !y) if (nE == 1) TRUE else FALSE } ape/R/mvr.R0000644000175100001440000000313712465112403012167 0ustar hornikusers## mvr.R (2012-03-30) ## Minimum Variance Reduction ## Copyright 2011 Andrei-Alin Popescu ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. mvr <- function(X, V) { if (is.matrix(X)) X <- as.dist(X) if (is.matrix(V)) V <- as.dist(V) if (any(is.na(X))) stop("missing values are not allowed in the distance matrix") if (any(is.na(V))) stop("missing values are not allowed in the variance matrix") N <- attr(X, "Size") labels <- attr(X, "Labels") if (is.null(labels)) labels <- as.character(1:N) ans <- .C(C_mvr, as.double(X), as.double(V), as.integer(N), integer(2*N - 3), integer(2*N - 3), double(2*N - 3), NAOK = TRUE) obj <- list(edge = cbind(ans[[4]], ans[[5]]), edge.length = ans[[6]], tip.label = labels, Nnode = N - 2L) class(obj) <- "phylo" reorder(obj) } mvrs <- function(X, V, fs = 15) { if (fs < 1) stop("argument 'fs' must be a non-zero positive integer") if (is.matrix(X)) X <- as.dist(X) if (is.matrix(V)) V <- as.dist(V) X[is.na(X)] <- -1 X[X < 0] <- -1 X[is.nan(X)] <- -1 N <- attr(X, "Size") labels <- attr(X, "Labels") if (is.null(labels)) labels <- as.character(1:N) ans <- .C(C_mvrs, as.double(X), as.double(V), as.integer(N), integer(2*N - 3), integer(2*N - 3), double(2*N - 3), as.integer(fs), NAOK = TRUE) obj <- list(edge = cbind(ans[[4]], ans[[5]]), edge.length = ans[[6]], tip.label = labels, Nnode = N - 2L) class(obj) <- "phylo" reorder(obj) } ape/R/rTrait.R0000644000175100001440000001224212465112403012625 0ustar hornikusers## rTrait.R (2014-03-06) ## Trait Evolution ## Copyright 2010-2014 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. rTraitDisc <- function(phy, model = "ER", k = if (is.matrix(model)) ncol(model) else 2, rate = 0.1, states = LETTERS[1:k], freq = rep(1/k, k), ancestor = FALSE, root.value = 1, ...) { if (is.null(phy$edge.length)) stop("tree has no branch length") if (any(phy$edge.length < 0)) stop("at least one branch length negative") if (is.character(model)) { switch(toupper(model), "ER" = { if (length(rate) != 1) stop("`rate' must have one element") Q <- matrix(rate, k, k) }, "ARD" = { if (length(rate) != k*(k - 1)) stop("`rate' must have k(k - 1) elements") Q <- matrix(0, k, k) Q[col(Q) != row(Q)] <- rate }, "SYM" = { if (length(rate) != k*(k - 1)/2) stop("`rate' must have k(k - 1)/2 elements") Q <- matrix(0, k, k) sel <- col(Q) < row(Q) Q[sel] <- rate Q <- t(Q) Q[sel] <- rate }) } if (is.matrix(model)) { Q <- model if (ncol(Q) != nrow(Q)) stop("the matrix given as `model' must be square") } phy <- reorder(phy, "postorder") n <- length(phy$tip.label) N <- dim(phy$edge)[1] ROOT <- n + 1L x <- integer(n + phy$Nnode) x[ROOT] <- as.integer(root.value) anc <- phy$edge[, 1] des <- phy$edge[, 2] el <- phy$edge.length if (is.function(model)) { environment(model) <- environment() # to find 'k' for (i in N:1) x[des[i]] <- model(x[anc[i]], el[i], ...) } else { freq <- rep(freq, each = k) Q <- Q * freq diag(Q) <- 0 diag(Q) <- -rowSums(Q) for (i in N:1) { p <- matexpo(Q * el[i])[x[anc[i]], ] x[des[i]] <- sample.int(k, size = 1, FALSE, prob = p) } } if (ancestor) { if (is.null(phy$node.label)) phy <- makeNodeLabel(phy) names(x) <- c(phy$tip.label, phy$node.label) } else { x <- x[1:n] names(x) <- phy$tip.label } class(x) <- "factor" levels(x) <- states x } rTraitCont <- function(phy, model = "BM", sigma = 0.1, alpha = 1, theta = 0, ancestor = FALSE, root.value = 0, ...) { if (is.null(phy$edge.length)) stop("tree has no branch length") if (any(phy$edge.length < 0)) stop("at least one branch length negative") phy <- reorder(phy, "postorder") n <- length(phy$tip.label) N <- dim(phy$edge)[1] ROOT <- n + 1L x <- numeric(n + phy$Nnode) x[ROOT] <- root.value anc <- phy$edge[, 1] des <- phy$edge[, 2] el <- phy$edge.length if (is.function(model)) { environment(model) <- environment() for (i in N:1) x[des[i]] <- model(x[anc[i]], el[i], ...) } else { model <- pmatch(toupper(model), c("BM", "OU")) if (length(sigma) == 1) sigma <- rep(sigma, N) else if (length(sigma) != N) stop("'sigma' must have one or Nedge(phy) elements") if (model == 2) { # "OU" if (length(alpha) == 1) alpha <- rep(alpha, N) else if (length(alpha) != N) stop("'alpha' must have one or Nedge(phy) elements") if (length(theta) == 1) theta <- rep(theta, N) else if (length(theta) != N) stop("'theta' must have one or Nedge(phy) elements") } x <- .C(C_rTraitCont, as.integer(model), as.integer(N), as.integer(anc - 1L), as.integer(des - 1L), el, as.double(sigma), as.double(alpha), as.double(theta), x = x, NAOK = TRUE)$x } if (ancestor) { if (is.null(phy$node.label)) phy <- makeNodeLabel(phy) names(x) <- c(phy$tip.label, phy$node.label) } else { x <- x[1:n] names(x) <- phy$tip.label } x } rTraitMult <- function(phy, model, p = 1, root.value = rep(0, p), ancestor = FALSE, asFactor = NULL, trait.labels = paste("x", 1:p, sep = ""), ...) { phy <- reorder(phy, "postorder") n <- length(phy$tip.label) m <- phy$Nnode N <- dim(phy$edge)[1] ROOT <- n + 1L x <- matrix(0, n + m, p) x[ROOT, ] <- root.value anc <- phy$edge[, 1] des <- phy$edge[, 2] el <- phy$edge.length if (is.null(el)) el <- numeric(N) environment(model) <- environment() # to find 'p' for (i in N:1) x[des[i], ] <- model(x[anc[i], ], el[i], ...) if (ancestor) { if (is.null(phy$node.label)) phy <- makeNodeLabel(phy) rownames(x) <- c(phy$tip.label, phy$node.label) } else { x <- x[1:n, , drop = FALSE] rownames(x) <- phy$tip.label } x <- as.data.frame(x) names(x) <- trait.labels if (!is.null(asFactor)) { for (i in asFactor) { y <- x[, i] x[, i] <- factor(y, labels = LETTERS[1:length(unique(y))]) } } x } ape/R/ltt.plot.R0000644000175100001440000001115513002744232013141 0ustar hornikusers## ltt.plot.R (2012-03-05) ## Lineages Through Time Plot ## Copyright 2002-2012 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. ltt.plot.coords <- function(phy, backward = TRUE, tol = 1e-6) { if (is.ultrametric(phy, tol)) { if (is.binary.phylo(phy)) { N <- numeric(phy$Nnode + 1) N[] <- 1 } else { node.order <- tabulate(phy$edge[, 1]) N <- node.order[-(1:length(phy$tip.label))] - 1 } bt <- branching.times(phy) names(bt) <- NULL o <- order(bt, decreasing = TRUE) time <- c(-bt[o], 0) if (!is.binary.phylo(phy)) N <- c(1, N[o]) } else { if (!is.binary.phylo(phy)) phy <- multi2di(phy) n <- Ntip(phy) m <- phy$Nnode ROOT <- n + 1L event <- time.event <- numeric(n + m) time.event[ROOT] <- 0 phy <- reorder(phy) for (i in 1:nrow(phy$edge)) time.event[phy$edge[i, 2]] <- time.event[phy$edge[i, 1]] + phy$edge.length[i] present <- max(time.event) event[1:n] <- -1 event[ROOT:(n + m)] <- 1 ## delete the events that are too close to present: past.event <- present - time.event > tol event <- event[past.event] time.event <- time.event[past.event] ## reorder wrt time: o <- order(time.event) time.event <- time.event[o] event <- event[o] time <- c(time.event - present, 0) N <- c(1, event) } N <- cumsum(N) if (!is.null(phy$root.edge)) { time <- c(time[1] - phy$root.edge, time) N <- c(1, N) } if (!backward) time <- time - time[1] cbind(time, N) } ltt.plot <- function(phy, xlab = "Time", ylab = "N", backward = TRUE, tol = 1e-6, ...) { if (!inherits(phy, "phylo")) stop("object \"phy\" is not of class \"phylo\"") xy <- ltt.plot.coords(phy, backward, tol) plot.default(xy, xlab = xlab, ylab = ylab, xaxs = "r", yaxs = "r", type = "S", ...) } ltt.lines <- function(phy, backward = TRUE, tol = 1e-6, ...) { xy <- ltt.plot.coords(phy, backward, tol) lines(xy, type = "S", ...) } mltt.plot <- function(phy, ..., dcol = TRUE, dlty = FALSE, legend = TRUE, xlab = "Time", ylab = "N", log = "", backward = TRUE, tol = 1e-6) { if (inherits(phy, "phylo")) { # if a tree of class "phylo" TREES <- list(ltt.plot.coords(phy, backward, tol)) names(TREES) <- deparse(substitute(phy)) } else { # a list of trees TREES <- lapply(phy, ltt.plot.coords, backward = backward, tol = tol) names(TREES) <- names(phy) if (is.null(names(TREES))) names(TREES) <- paste(deparse(substitute(phy)), "-", 1:length(TREES)) } dts <- list(...) n <- length(dts) if (n) { mc <- as.character(match.call())[-(1:2)] nms <- mc[1:n] for (i in 1:n) { if (inherits(dts[[i]], "phylo")) { a <- list(ltt.plot.coords(dts[[i]], backward, tol)) names(a) <- nms[i] } else { # a list of trees a <- lapply(dts[[i]], ltt.plot.coords, backward = backward, tol = tol) names(a) <- names(dts[[i]]) if (is.null(names(a))) names(a) <- paste(deparse(substitute(phy)), "-", seq_along(a)) } TREES <- c(TREES, a) } } n <- length(TREES) range.each.tree <- sapply(TREES, function(x) range(x[, 1])) xl <- range(range.each.tree) yl <- c(1, max(sapply(TREES, function(x) max(x[, 2])))) ## if backward is FALSE, we have to rescale the time scales of each tree: if (!backward) { for (i in seq_along(TREES)) { tmp <- TREES[[i]] tmp[, 1] <- tmp[, 1] + xl[2] - range.each.tree[2, i] TREES[[i]] <- tmp } } plot.default(NA, type = "n", xlim = xl, ylim = yl, xaxs = "r", yaxs = "r", xlab = xlab, ylab = ylab, log = log) lty <- if (!dlty) rep(1, n) else 1:n col <- if (!dcol) rep(1, n) else topo.colors(n) for (i in 1:n) lines(TREES[[i]], col = col[i], lty = lty[i], type = "S") if (legend) legend(xl[1], yl[2], legend = names(TREES), lty = lty, col = col, bty = "n") } ltt.coplot <- function(phy, backward = TRUE, ...) { layout(matrix(1:2, 2)) par(mar = c(0, 3, 0.5, 0.5)) o <- plot(phy, root.edge = TRUE, ...) par(mar = c(3, 3, 0, 0.5)) ltt.plot(phy, xlim = o$x.lim, backward = FALSE, xaxt = "n") if (backward) axisPhylo() else axis(1) } ape/R/collapsed.intervals.R0000644000175100001440000000243412465112403015336 0ustar hornikusers## collapsed.intervals.R (2002-09-12) ## Collapsed coalescent intervals (e.g. for the skyline plot) ## Copyright 2002 Korbinian Strimmer ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. # construct collapsed intervals from coalescent intervals collapsed.intervals <- function(ci, epsilon=0.0) { if (class(ci) != "coalescentIntervals") stop("object \"ci\" is not of class \"coalescentIntervals\"") sz <- ci$interval.length lsz <- length(sz) idx <- c <- 1:lsz p <- 1 w <- 0 # starting from tips collapes intervals # until total size is >= epsilon for (i in 1:lsz) { idx[[i]] <- p w <- w + sz[[i]] if (w >= epsilon) { p <- p+1 w <- 0 } } # if last interval is smaller than epsilon merge # with second last interval lastInterval <- idx==p if ( sum(sz[lastInterval]) < epsilon ) { p <- p-1 idx[lastInterval] <- p } obj <- list( lineages=ci$lineages, interval.length=ci$interval.length, collapsed.interval=idx, # collapsed intervals (via reference) interval.count=ci$interval.count, collapsed.interval.count = idx[[ci$interval.count]], total.depth =ci$total.depth, epsilon = epsilon ) class(obj) <- "collapsedIntervals" return(obj) } ape/R/rotate.R0000644000175100001440000001117212465112403012657 0ustar hornikusers## rotate.R (2014-06-05) ## Ancestral Character Estimation ## Copyright 2007 Christoph Heibl ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. rotate <- function(phy, node, polytom = c(1,2)){ # load DESCENDANTS function DESCENDANTS <- function(tree, node){ tips <- length(tree$tip.label) x <- tree$edge[,2][tree$edge[,1] == node] while(max(x) > tips){ x <- x[x > tips] for(h in 1:length(x)) tree$edge <- tree$edge[!tree$edge[,2] == x[h],] for(i in 1:length(x)) tree$edge[,1][tree$edge[,1] == x[i]] <- node x <- tree$edge[,2][tree$edge[,1] == node] } x } if (!inherits(phy, "phylo")) # is phy of class phylo? stop("object \"phy\" is not of class \"phylo\"") phy <- reorder(phy) # added by EP 2014-06-05 nb.tips <- length(phy$tip.label) # number of tiplabels max.int.node <- phy$Nnode+nb.tips # number of last internal node nb.edges <- dim(phy$edge)[1] # number of branches if (length(node) == 2){ # get MRCA if tips are given for node if (mode(node) == "character"){ if (any(!node %in% phy$tip.label)) # do tiplabels correspond stop("object \"node\" contains tiplabels not present in object \"phy\"") tips <- cbind(phy$tip.label, 1:nb.tips) node[1] <- tips[,2][tips[,1] == node[1]] node[2] <- tips[,2][tips[,1] == node[2]] node <- as.numeric(node) } if (any(!node %in% 1:nb.tips)) stop("object \"node\" does not contain terminal nodes") node <- getMRCA(phy, node) } if (node <= nb.tips || node > max.int.node) # is node really internal? stop("object \"node\" is not an internal node of object \"phy\"") with.br.length <- !is.null(phy$edge.length) # does phy contain brlength? G <- cbind(phy$edge, 1:(length(phy$edge)/2)) N <- phy$edge[phy$edge[,1] == node] N <- N[N != node] if (length(N) > 2) N <- N[polytom] CLADE1 <- N[1] CLADE2 <- N[2] # do clades comprise interior nodes? if (CLADE1 > nb.tips) CLADE11 <- DESCENDANTS(phy, CLADE1) if (CLADE2 > nb.tips) CLADE22 <- DESCENDANTS(phy, CLADE2) # calculate inidices of clades in phy.edge if (CLADE1 > nb.tips){ c1 <- G[,3][G[,2] == CLADE1] c2 <- G[,3][G[,2] == max(CLADE11)] } else { c1 <- G[,3][G[,2] == CLADE1] c2 <- G[,3][G[,2] == CLADE1] } if (CLADE2 > nb.tips){ c3 <- G[,3][G[,2] == CLADE2] c4 <- G[,3][G[,2] == max(CLADE22)] } else { c3 <- G[,3][G[,2] == CLADE2] c4 <- G[,3][G[,2] == CLADE2] } # create new phy$edge and phy$edge.length if (c2+1 == c3){ if (c1 == 1 && c4 != nb.edges){ phy$edge <- rbind(phy$edge[c3:c4,], phy$edge[c1:c2,], phy$edge[(c4+1):nb.edges,]) if (with.br.length) phy$edge.length <- c(phy$edge.length[c3:c4], phy$edge.length[c1:c2], phy$edge.length[(c4+1):nb.edges]) } if (c1 !=1 && c4 == nb.edges){ phy$edge <- rbind(phy$edge[1:(c1-1),], phy$edge[c3:c4,], phy$edge[c1:c2,]) if (with.br.length) phy$edge.length <- c(phy$edge.length[1:(c1-1)], phy$edge.length[c3:c4], phy$edge.length[c1:c2]) } if (c1 !=1 && c4 != nb.edges){ phy$edge <- rbind(phy$edge[1:(c1-1),], phy$edge[c3:c4,], phy$edge[c1:c2,], phy$edge[(c4+1):nb.edges,]) if (with.br.length) phy$edge.length <- c(phy$edge.length[1:(c1-1)], phy$edge.length[c3:c4], phy$edge.length[c1:c2], phy$edge.length[(c4+1):nb.edges]) } if (c1 ==1 && c4 == nb.edges){ phy$edge <- rbind(phy$edge[c3:c4,], phy$edge[c1:c2,]) if (with.br.length) phy$edge.length <- c(phy$edge.length[c3:c4], phy$edge.length[c1:c2]) } } else { if (c1 == 1 && c4 != nb.edges){ phy$edge <- rbind(phy$edge[c3:c4,], phy$edge[(c2+1):(c3-1),], phy$edge[c1:c2,], phy$edge[(c4+1):nb.edges,]) if (with.br.length) phy$edge.length <- c(phy$edge.length[c3:c4], phy$edge.length[(c2+1):(c3-1)], phy$edge.length[c1:c2], phy$edge.length[(c4+1):nb.edges]) } if (c1 !=1 && c4 == nb.edges){ phy$edge <- rbind(phy$edge[1:(c1-1),], phy$edge[c3:c4,], phy$edge[(c2+1):(c3-1),], phy$edge[c1:c2,]) if (with.br.length) phy$edge.length <- c(phy$edge.length[1:(c1-1)], phy$edge.length[c3:c4], phy$edge.length[(c2+1):(c3-1)], phy$edge.length[c1:c2]) } if (c1 !=1 && c4 != nb.edges){ phy$edge <- rbind(phy$edge[1:(c1-1),], phy$edge[c3:c4,], phy$edge[(c2+1):(c3-1),], phy$edge[c1:c2,], phy$edge[(c4+1):nb.edges,]) if (with.br.length) phy$edge.length <- c(phy$edge.length[1:(c1-1)], phy$edge.length[c3:c4], phy$edge.length[(c2+1):(c3-1)], phy$edge.length[c1:c2], phy$edge.length[(c4+1):nb.edges]) } if (c1 ==1 && c4 == nb.edges){ phy$edge <- rbind(phy$edge[c3:c4,], phy$edge[(c2+1):(c3-1),], phy$edge[c1:c2,]) if (with.br.length) phy$edge.length <- c(phy$edge.length[c3:c4], phy$edge.length[(c2+1):(c3-1)], phy$edge.length[c1:c2]) } } phy } ape/R/extract.popsize.R0000644000175100001440000000520012465112403014516 0ustar hornikusers## extract.popsize.R (2004-07-4) ## Extract table with population size in dependence of time ## from mcmc output generated by mcmc.popsize ## Copyright 2004 Rainer Opgen-Rhein and Korbinian Strimmer ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. extract.popsize<-function(mcmc.out, credible.interval=0.95, time.points=200, thinning=1, burn.in=0) { # construct a matrix with the positions of the jumps b<-burn.in+1 i<-1 k<-array(dim=ceiling((length(mcmc.out$pos)-burn.in)/thinning)) while(i<=length(k)) { k[i]<-length(mcmc.out$pos[[b]]); (i<-i+1); b<-b+thinning } o<-max(k) b<-burn.in+1 i<-1 pos.m<-matrix(nrow=length(k), ncol=o) while(i<=length(k)) { pos.m[i,]<-c(mcmc.out$pos[[b]], array(dim=o-length(mcmc.out$pos[[b]]))); i<-i+1; b<-b+thinning } # construct a matrix with the heights of the jumps b<-burn.in+1 i<-1 h.m<-matrix(nrow=length(k), ncol=o) while(i<=length(k)) { h.m[i,]<-c(mcmc.out$h[[b]], array(dim=o-length(mcmc.out$h[[b]]))); i<-i+1; b<-b+thinning } prep<-list("pos"=pos.m, "h"=h.m) #################### step <- (max(prep$pos, na.rm=TRUE)-min(prep$pos, na.rm=TRUE))/(time.points-1) nr <- time.points p<-min(prep$pos, na.rm=TRUE) i<-1 me<-matrix(nrow=nr, ncol=5) prep.l<-prep prep.l$pos<-cbind(prep$pos,prep$pos[,length(prep$pos[1,])]) prep.l$h<-cbind(prep$h,prep$h[,length(prep$h[1,])]) while (p<=max(prep$pos, na.rm=TRUE)) { #Vector with position of heights l.prep<-prep$pos<=p l.prep[is.na(l.prep)]<-FALSE pos.of.h<-l.prep%*% array(data=1, dim=dim(prep$pos)[2]) #Vector with heights z<-array(data=(1:dim(prep$pos)[1]), dim=dim(prep$pos)[1]) index.left<-cbind(z,pos.of.h) index.right<-cbind(z, pos.of.h+1) mixed.heights<-((((p-prep$pos[index.left])/(prep$pos[index.right]-prep$pos[index.left]))* (prep$h[index.right]-prep$h[index.left]))+prep$h[index.left]) me[i,2]<-mean(mixed.heights) #library(MASS) #me[i,2]<-huber(mixed.heights)$mu me[i,3]<-median(mixed.heights) me[i,4]<-quantile(mixed.heights, probs=(1-credible.interval)/2, na.rm=TRUE) me[i,5]<-quantile(mixed.heights, probs=(1+credible.interval)/2, na.rm=TRUE) me[i,1]<-p p<-p+step i<-i+1 } #av.jumps<-round((length(prep$pos)-sum(is.na(prep$pos)))/length(prep$pos[,1])-2,2) #print("average jumps") #print((length(prep$pos)-sum(is.na(prep$pos)))/length(prep$pos[,1])-2) colnames(me) <- c("time", "mean", "median", "lower CI", "upper CI") class(me) <- "popsize" return(me) } ape/R/skyline.R0000644000175100001440000000632012465112403013036 0ustar hornikusers## skyline.R (2002-09-12) ## Methods to construct skyline objects (data underlying skyline plot) ## Copyright 2002 Korbinian Strimmer ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. skyline <- function(x, ...) UseMethod("skyline") # input: phylogenetic tree skyline.phylo <- function(x, ...) { if (class(x) != "phylo") stop("object \"x\" is not of class \"phylo\"") skyline(coalescent.intervals(x), ...) } # input: coalescent intervals and epsilon skyline.coalescentIntervals <- function(x, epsilon=0, ...) { if (class(x) != "coalescentIntervals") stop("object \"x\" is not of class \"coalescentIntervals\"") if (epsilon < 0) { eps <- find.skyline.epsilon(x, ...) } else eps <- epsilon skyline(collapsed.intervals(x, epsilon=eps), ...) } # input: collapsed intervals skyline.collapsedIntervals <- function(x, old.style=FALSE, ...) { if (class(x) != "collapsedIntervals") stop("object \"x\" is not of class \"collapsedIntervals\"") link <- x$collapsed.interval params <- x$collapsed.interval.count l <- x$lineages w <- x$interval.length b <- choose(l,2) # binomial coefficients sg <- rep(0,params) # sizes of collapsed intervals cg <- rep(0,params) # coalescent events in interval if(old.style) ng <- rep(0,params) # lineages at beginning of an in interval else { ng <- rep(0,params) # sum of classic skp estimates in an interval m.classic <- w*b } for (i in 1:params) { group <- link==i sgr <- w[group] sg[[i]] <- sum(sgr) cg[[i]] <- length(sgr) if(old.style) ng[[i]] <- l[group][[1]] else ng[[i]] <- sum(m.classic[group]) } # generalized skp estimate t <- cumsum(sg) if (old.style) m <- sg*(ng*(ng-cg)/(2.0*cg) ) else m <- ng/cg # log-likelihood logL <- sum(log(b/m[link]) - b/m[link]*w) # AICc corrected log-likelihood K <- x$collapsed.interval.count S <- x$interval.count if (S-K > 1) logL.AICc <- logL - K- K*(K+1)/(S-K-1) else logL.AICc <- NA obj <- list( time=t, interval.length=sg, population.size=m, parameter.count=length(t), epsilon = x$epsilon, logL = logL, logL.AICc = logL.AICc ) class(obj) <- "skyline" return(obj) } # grid search for finding optimal epsilon parameter find.skyline.epsilon <- function(ci, GRID=1000, MINEPS=1e-6, ...) { # Why MINEPS? # Because most "clock-like" trees are not properly # clock-like for a variety of reasons, i.e. the heights # of the tips are not exactly zero. cat("Searching for the optimal epsilon... ") # a grid search is a naive way but still effective of doing this ... size <- ci$interval.count besteps <- ci$total.depth eps <- besteps cli <- collapsed.intervals(ci,eps) skpk <- skyline(cli, ...) bestaicc <- skpk$ logL.AICc params <- skpk$parameter.count delta <- besteps/GRID eps <- eps-delta while(eps > MINEPS) { cli <- collapsed.intervals(ci,eps) skpk <- skyline(cli, ...) aicc <- skpk$ logL.AICc params <- skpk$parameter.count if (aicc > bestaicc && params < size-1) { besteps <- eps bestaicc <- aicc } eps <- eps-delta } cat("epsilon =", besteps, "\n") besteps } ape/R/makeLabel.R0000644000175100001440000001071112732270767013253 0ustar hornikusers## makeLabel.R (2016-06-08) ## Label Management ## Copyright 2010-2016 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. makeLabel <- function(x, ...) UseMethod("makeLabel") makeLabel.character <- function(x, len = 99, space = "_", make.unique = TRUE, illegal = "():;,[]", quote = FALSE, ...) { x <- gsub("[[:space:]]", space, x) if (illegal != "") { illegal <- unlist(strsplit(illegal, NULL)) for (i in illegal) x <- gsub(i, "", x, fixed = TRUE) } if (quote) len <- len - 2 nc <- nchar(x) > len if (any(nc)) x[nc] <- substr(x[nc], 1, len) tab <- table(x) if (all(tab == 1)) make.unique <- FALSE if (make.unique) { dup <- tab[which(tab > 1)] nms <- names(dup) for (i in 1:length(dup)) { j <- which(x == nms[i]) end <- nchar(x[j][1]) ## w: number of characters to be added as suffix w <- floor(log10(dup[i])) + 1 suffix <- formatC(1:dup[i], width = w, flag = "0") if (end + w > len) { start <- end - w + 1 substr(x[j], start, end) <- suffix } else x[j] <- paste(x[j], suffix, sep = "") } } if (quote) x <- paste('"', x, '"', sep = "") x } makeLabel.phylo <- function(x, tips = TRUE, nodes = TRUE, ...) { if (tips) x$tip.label <- makeLabel.character(x$tip.label, ...) if (!is.null(x$node.label) && nodes) x$node.label <- makeLabel.character(x$node.label, ...) x } makeLabel.multiPhylo <- function(x, tips = TRUE, nodes = TRUE, ...) { y <- attr(x, "TipLabel") if (is.null(y)) { for (i in 1:length(x)) x[[i]] <- makeLabel.phylo(x[[i]], tips = tips, nodes = nodes, ...) } else { attr(x, "TipLabel") <- makeLabel.character(y, ...) } x } makeLabel.DNAbin <- function(x, ...) { if (is.vector(x) || is.list(x)) names(x) <- makeLabel.character(names(x), ...) else rownames(x) <- makeLabel.character(rownames(x), ...) x } mixedFontLabel <- function(..., sep = " ", italic = NULL, bold = NULL, parenthesis = NULL, always.upright = c("sp.", "spp.", "ssp.")) { x <- list(...) n <- length(x) if (!is.null(italic)) { for (i in italic) { y <- x[[i]] s <- ! y %in% always.upright y[s] <- paste("italic(\"", y[s], "\")", sep = "") if (any(!s)) y[!s] <- paste("plain(\"", y[!s], "\")", sep = "") x[[i]] <- y } } if (!is.null(bold)) { for (i in bold) { y <- x[[i]] s <- logical(length(y)) s[grep("^italic", y)] <- TRUE y[s] <- sub("^italic", "bolditalic", y[s]) y[!s] <- paste("bold(\"", y[!s], "\")", sep = "") x[[i]] <- y } } k <- which(! 1:n %in% c(italic, bold)) # those in upright if (length(k)) for (i in k) x[[i]] <- paste("plain(\"", x[[i]], "\")", sep = "") if (!is.null(parenthesis)) for (i in parenthesis) x[[i]] <- paste("(", x[[i]], ")", sep = "") res <- x[[1L]] if (n > 1) { sep <- rep(sep, length.out = n - 1L) for (i in 2:n) res <- paste(res, "*\"", sep[i - 1L], "\"*", x[[i]], sep = "") } parse(text = res) } .getSeparatorTaxaLabels <- function(x) { if (length(grep("_", x))) "_" else " " } label2table <- function(x, sep = NULL, as.is = FALSE) { n <- length(x) if (is.null(sep)) sep <- .getSeparatorTaxaLabels(x) x <- strsplit(x, sep) x <- unlist(lapply(x, "[", 1:3)) x <- matrix(x, n, 3, byrow = TRUE) x <- as.data.frame(x, as.is = as.is) names(x) <- c("genus", "species", "subspecies") x } stripLabel <- function(x, species = FALSE, subsp = TRUE, sep = NULL) { if (is.null(sep)) sep <- .getSeparatorTaxaLabels(x) n <- 0 if (species) n <- 1 else if (subsp) n <- 2 if (!n) return(x) x <- strsplit(x, sep) x <- lapply(x, "[", 1:n) sapply(x, paste, collapse = sep) } abbreviateGenus <- function(x, genus = TRUE, species = FALSE, sep = NULL) { if (is.null(sep)) sep <- .getSeparatorTaxaLabels(x) if (genus) x <- sub(paste0("[[:lower:]]{1,}", sep), paste0(".", sep), x) if (!species) return(x) x <- strsplit(x, sep) k <- which(lengths(x, use.names = FALSE) > 1) for (i in k) x[[i]][2] <- paste0(substr(x[[i]][2], 1, 1), ".") sapply(x, paste, collapse = sep) } ape/R/matexpo.R0000644000175100001440000000066612465112403013044 0ustar hornikusers## ladderize.R (2007-10-08) ## Matrix Exponential ## Copyright 2007 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. matexpo <- function(x) { if (!is.matrix(x)) stop('"x" must be a matrix') nr <- dim(x)[1] if (nr != dim(x)[2]) stop('"x" must be a square matrix') ans <- .C(mat_expo, as.double(x), as.integer(nr))[[1]] dim(ans) <- c(nr, nr) ans } ape/R/parafit.R0000644000175100001440000001212112535263333013011 0ustar hornikusers'parafit' <- function(host.D, para.D, HP, nperm=999, test.links=FALSE, seed=NULL, correction="none", silent=FALSE) # # Test of host-parasite coevolution # host.D = host distance or patristic matrix (class dist or matrix) # para.D = parasite distance or patristic matrix (class dist or matrix) # HP = host-parasite link matrix (n.host, n.para) # # Pierre Legendre, May 2009 { epsilon <- sqrt(.Machine$double.eps) if(is.null(seed)) { runif(1) seed <- .Random.seed[trunc(runif(1,1,626))] } HP <- as.matrix(HP) host.D <- as.matrix(host.D) host.pc <- pcoa(host.D, correction=correction) if(host.pc$correction[2] == 1) { if(min(host.pc$values[,2]) < -epsilon) stop('Host D matrix has negative eigenvalues. Rerun with correction="lingoes" or correction="cailliez"') sum.host.values.sq <- sum(host.pc$values[,1]^2) host.vectors <- host.pc$vectors } else { sum.host.values.sq <- sum(host.pc$values[,2]^2) host.vectors <- host.pc$vectors.cor } n.host <- nrow(host.D) para.D <- as.matrix(para.D) para.pc <- pcoa(para.D, correction=correction) if(para.pc$correction[2] == 1) { if(min(para.pc$values[,2]) < -epsilon) stop('Parasite D matrix has negative eigenvalues. Rerun with correction="lingoes" or correction="cailliez"') sum.para.values.sq <- sum(para.pc$values[,1]^2) para.vectors <- para.pc$vectors } else { sum.para.values.sq <- sum(para.pc$values[,2]^2) para.vectors <- para.pc$vectors.cor } n.para <- nrow(para.D) if(!silent) cat("n.hosts =", n.host, ", n.parasites =", n.para,'\n') a <- system.time({ tracemax <- max(sum.host.values.sq, sum.para.values.sq) if(n.host == n.para) { if(!silent) cat("The function cannot check if matrix HP has been entered in the right way.",'\n') if(!silent) cat("It will assume that the rows of HP are the hosts.",'\n') } else { temp <- dim(HP) if(temp[1] == n.host) { if(temp[2] != n.para) stop("Matrices host.D, para.D and HP not comformable") } else if(temp[2] == n.host) { if(temp[1] != n.para) stop("Matrices host.D, para.D and HP not comformable") HP <- t(HP) if(!silent) cat("Matrix HP has been transposed for comformity with host.D and para.D.",'\n') } else { stop("Matrices host.D, para.D and HP not comformable") } } p.per.h <- apply(HP, 1, sum) h.per.p <- apply(HP, 2, sum) # # Compute and test the global statistics mat.4 <- t(host.vectors) %*% HP %*% para.vectors global <- sum(mat.4^2) if(nperm > 0) { set.seed(seed) nGT <- 1 global.perm <- NA for(i in 1:nperm) { HP.perm <- apply(HP, 2, sample) mat.4.perm <- t(host.vectors) %*% HP.perm %*% para.vectors global.perm <- c(global.perm, sum(mat.4.perm^2)) if(global.perm[i+1] >= global) nGT <- nGT+1 } global.perm <- global.perm[-1] p.global <- nGT/(nperm+1) } else { p.global <- NA } # # Test individual H-P links if(test.links) { # 1. Create the list of H-P pairs list.hp <- which( t(cbind(HP,rep(0,n.host))) > 0) HP.list <- cbind((list.hp %/% (n.para+1))+1, list.hp %% (n.para+1)) colnames(HP.list) <- c("Host","Parasite") n.links <- length(list.hp) stat1 <- NA stat2 <- NA p.stat1 <- NA p.stat2 <- NA for(k in 1:n.links) { # # 2. Compute reference values of link statistics HP.k <- HP HP.k[HP.list[k,1], HP.list[k,2]] <- 0 mat.4.k <- t(host.vectors) %*% HP.k %*% para.vectors trace.k <- sum(mat.4.k^2) stat1 <- c(stat1, (global-trace.k)) den <- tracemax-global if(den > epsilon) { stat2 <- c(stat2, stat1[k+1]/den) } else { stat2 <- c(stat2, NA) } # # 3. Test link statistics by permutations if(nperm > 0) { set.seed(seed) nGT1 <- 1 nGT2 <- 1 nperm2 <- nperm # for(i in 1:nperm) { HP.k.perm <- apply(HP.k, 2, sample) mat.4.k.perm <- t(host.vectors) %*% HP.k.perm %*% para.vectors trace.k.perm <- sum(mat.4.k.perm^2) stat1.perm <- global.perm[i]-trace.k.perm if(stat1.perm >= stat1[k+1]) nGT1 <- nGT1+1 # if(!is.na(stat2[k+1])) { den <- tracemax-global.perm[i] if(den > epsilon) { stat2.perm <- stat1.perm/den if(stat2.perm >= stat2[k+1]) nGT2 <- nGT2+1 } else { nperm2 <- nperm2-1 # if(!silent) cat("In permutation #",i,"den < epsilon",'\n') } } } p.stat1 <- c(p.stat1, nGT1/(nperm+1)) if(!is.na(stat2[k+1])) { p.stat2 <- c(p.stat2, nGT2/(nperm2+1)) } else { p.stat2 <- c(p.stat2, NA) ### Error in previous version, corrected here } } else { p.stat1 <- c(p.stat1, NA) ### Error in previous version, corrected here p.stat2 <- c(p.stat2, NA) ### Error in previous version, corrected here } } # link.table <- cbind(HP.list, stat1[-1], p.stat1[-1], stat2[-1], p.stat2[-1]) colnames(link.table) = c("Host","Parasite","F1.stat","p.F1","F2.stat","p.F2") out <-list(ParaFitGlobal=global, p.global=p.global, link.table=link.table, para.per.host=p.per.h, host.per.para=h.per.p, nperm=nperm) } else { if(!silent) cat("Rerun the program with option 'test.links=TRUE' to test the individual H-P links",'\n') out <-list(ParaFitGlobal=global, p.global=p.global, para.per.host=p.per.h, host.per.para=h.per.p, nperm=nperm) } # }) a[3] <- sprintf("%2f",a[3]) if(!silent) cat("Computation time =",a[3]," sec",'\n') # class(out) <- "parafit" out } ape/R/pcoa.R0000644000175100001440000001406512465112403012307 0ustar hornikuserspcoa <- function(D, correction="none", rn=NULL) # # Principal coordinate analysis (PCoA) of a square distance matrix D # with correction for negative eigenvalues. # # References: # Gower, J. C. 1966. Some distance properties of latent root and vector methods # used in multivariate analysis. Biometrika. 53: 325-338. # Gower, J. C. and P. Legendre. 1986. Metric and Euclidean properties of # dissimilarity coefficients. J. Classif. 3: 5-48. # Legendre, P. and L. Legendre. 1998. Numerical ecology, 2nd English edition. # Elsevier Science BV, Amsterdam. [PCoA: Section 9.2] # # Pierre Legendre, October 2007 { centre <- function(D,n) # Centre a square matrix D by matrix algebra # mat.cen = (I - 11'/n) D (I - 11'/n) { One <- matrix(1,n,n) mat <- diag(n) - One/n mat.cen <- mat %*% D %*% mat } bstick.def <- function (n, tot.var = 1, ...) # 'bstick.default' from vegan { res <- rev(cumsum(tot.var/n:1)/n) names(res) <- paste("Stick", seq(len = n), sep = "") return(res) } # ===== The PCoA function begins here ===== # Preliminary actions D <- as.matrix(D) n <- nrow(D) epsilon <- sqrt(.Machine$double.eps) if(length(rn)!=0) { names <- rn } else { names <- rownames(D) } CORRECTIONS <- c("none","lingoes","cailliez") correct <- pmatch(correction, CORRECTIONS) if(is.na(correct)) stop("Invalid correction method") # cat("Correction method =",correct,'\n') # Gower centring of matrix D # delta1 = (I - 11'/n) [-0.5 d^2] (I - 11'/n) delta1 <- centre((-0.5*D^2),n) trace <- sum(diag(delta1)) # Eigenvalue decomposition D.eig <- eigen(delta1) # Negative eigenvalues? min.eig <- min(D.eig$values) zero.eig <- which(abs(D.eig$values) < epsilon) D.eig$values[zero.eig] <- 0 # No negative eigenvalue if(min.eig > -epsilon) { # Curly 1 correct <- 1 eig <- D.eig$values k <- length(which(eig > epsilon)) rel.eig <- eig[1:k]/trace cum.eig <- cumsum(rel.eig) vectors <- sweep(D.eig$vectors[,1:k], 2, sqrt(eig[1:k]), FUN="*") bs <- bstick.def(k) cum.bs <- cumsum(bs) res <- data.frame(eig[1:k], rel.eig, bs, cum.eig, cum.bs) colnames(res) <- c("Eigenvalues","Relative_eig","Broken_stick","Cumul_eig","Cumul_br_stick") rownames(res) <- 1:nrow(res) rownames(vectors) <- names colnames(vectors) <- colnames(vectors, do.NULL = FALSE, prefix = "Axis.") note <- paste("There were no negative eigenvalues. No correction was applied") out <- (list(correction=c(correction,correct), note=note, values=res, vectors=vectors, trace=trace)) # Negative eigenvalues present } else { # Curly 1 k <- n eig <- D.eig$values rel.eig <- eig/trace rel.eig.cor <- (eig - min.eig)/(trace - (n-1)*min.eig) # Eq. 9.27 for a single dimension rel.eig.cor = c(rel.eig.cor[1:(zero.eig[1]-1)], rel.eig.cor[(zero.eig[1]+1):n], 0) cum.eig.cor <- cumsum(rel.eig.cor) k2 <- length(which(eig > epsilon)) k3 <- length(which(rel.eig.cor > epsilon)) vectors <- sweep(D.eig$vectors[,1:k2], 2, sqrt(eig[1:k2]), FUN="*") # Only the eigenvectors with positive eigenvalues are shown # Negative eigenvalues: three ways of handling the situation if((correct==2) | (correct==3)) { # Curly 2 if(correct == 2) { # Curly 3 # Lingoes correction: compute c1, then the corrected D c1 <- -min.eig note <- paste("Lingoes correction applied to negative eigenvalues: D' = -0.5*D^2 -",c1,", except diagonal elements") D <- -0.5*(D^2 + 2*c1) # Cailliez correction: compute c2, then the corrected D } else if(correct == 3) { delta2 <- centre((-0.5*D),n) upper <- cbind(matrix(0,n,n), 2*delta1) lower <- cbind(-diag(n), -4*delta2) sp.matrix <- rbind(upper, lower) c2 <- max(Re(eigen(sp.matrix, symmetric=FALSE, only.values=TRUE)$values)) note <- paste("Cailliez correction applied to negative eigenvalues: D' = -0.5*(D +",c2,")^2, except diagonal elements") D <- -0.5*(D + c2)^2 } # End curly 3 diag(D) <- 0 mat.cor <- centre(D,n) toto.cor <- eigen(mat.cor) trace.cor <- sum(diag(mat.cor)) # Negative eigenvalues present? min.eig.cor <- min(toto.cor$values) zero.eig.cor <- which((toto.cor$values < epsilon) & (toto.cor$values > -epsilon)) toto.cor$values[zero.eig.cor] <- 0 # No negative eigenvalue after correction: result OK if(min.eig.cor > -epsilon) { # Curly 4 eig.cor <- toto.cor$values rel.eig.cor <- eig.cor[1:k]/trace.cor cum.eig.cor <- cumsum(rel.eig.cor) k2 <- length(which(eig.cor > epsilon)) vectors.cor <- sweep(toto.cor$vectors[,1:k2], 2, sqrt(eig.cor[1:k2]), FUN="*") # bs <- broken.stick(k2)[,2] bs <- bstick.def(k2) bs <- c(bs, rep(0,(k-k2))) cum.bs <- cumsum(bs) # Negative eigenvalues still present after correction: incorrect result } else { if(correct == 2) cat("Problem! Negative eigenvalues are still present after Lingoes",'\n') if(correct == 3) cat("Problem! Negative eigenvalues are still present after Cailliez",'\n') rel.eig.cor <- cum.eig.cor <- bs <- cum.bs <- rep(NA,n) vectors.cor <- matrix(NA,n,2) } # End curly 4 res <- data.frame(eig[1:k], eig.cor[1:k], rel.eig.cor, bs, cum.eig.cor, cum.bs) colnames(res) <- c("Eigenvalues", "Corr_eig", "Rel_corr_eig", "Broken_stick", "Cum_corr_eig", "Cum_br_stick") rownames(res) <- 1:nrow(res) rownames(vectors) <- names colnames(vectors) <- colnames(vectors, do.NULL = FALSE, prefix = "Axis.") out <- (list(correction=c(correction,correct), note=note, values=res, vectors=vectors, trace=trace, vectors.cor=vectors.cor, trace.cor=trace.cor)) } else { # Curly 2 note <- "No correction was applied to the negative eigenvalues" bs <- bstick.def(k3) bs <- c(bs, rep(0,(k-k3))) cum.bs <- cumsum(bs) res <- data.frame(eig[1:k], rel.eig, rel.eig.cor, bs, cum.eig.cor, cum.bs) colnames(res) <- c("Eigenvalues","Relative_eig","Rel_corr_eig","Broken_stick","Cum_corr_eig","Cumul_br_stick") rownames(res) <- 1:nrow(res) rownames(vectors) <- names colnames(vectors) <- colnames(vectors, do.NULL = FALSE, prefix = "Axis.") out <- (list(correction=c(correction,correct), note=note, values=res, vectors=vectors, trace=trace)) } # End curly 2: three ways of handling the situation } # End curly 1 class(out) <- "pcoa" out } # End of PCoA ape/R/write.nexus.R0000644000175100001440000000434412465112403013657 0ustar hornikusers## write.nexus.R (2014-12-10) ## Write Tree File in Nexus Format ## Copyright 2003-2014 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. write.nexus <- function(..., file = "", translate = TRUE) { obj <- .getTreesFromDotdotdot(...) ntree <- length(obj) cat("#NEXUS\n", file = file) cat(paste("[R-package APE, ", date(), "]\n\n", sep = ""), file = file, append = TRUE) N <- length(obj[[1]]$tip.label) cat("BEGIN TAXA;\n", file = file, append = TRUE) cat(paste("\tDIMENSIONS NTAX = ", N, ";\n", sep = ""), file = file, append = TRUE) cat("\tTAXLABELS\n", file = file, append = TRUE) cat(paste("\t\t", obj[[1]]$tip.label, sep = ""), sep = "\n", file = file, append = TRUE) cat("\t;\n", file = file, append = TRUE) cat("END;\n", file = file, append = TRUE) cat("BEGIN TREES;\n", file = file, append = TRUE) if (translate) { cat("\tTRANSLATE\n", file = file, append = TRUE) obj <- .compressTipLabel(obj) X <- paste("\t\t", 1:N, "\t", attr(obj, "TipLabel"), ",", sep = "") ## We remove the last comma: X[length(X)] <- gsub(",", "", X[length(X)]) cat(X, file = file, append = TRUE, sep = "\n") cat("\t;\n", file = file, append = TRUE) class(obj) <- NULL for (i in 1:ntree) obj[[i]]$tip.label <- as.character(1:N) } else { if (is.null(attr(obj, "TipLabel"))) { for (i in 1:ntree) obj[[i]]$tip.label <- checkLabel(obj[[i]]$tip.label) } else { attr(obj, "TipLabel") <- checkLabel(attr(obj, "TipLabel")) obj <- .uncompressTipLabel(obj) } } title <- names(obj) if (is.null(title)) title <- rep("UNTITLED", ntree) else { if (any(s <- title == "")) title[s] <- "UNTITLED" } for (i in 1:ntree) { if (class(obj[[i]]) != "phylo") next root.tag <- if (is.rooted(obj[[i]])) "= [&R] " else "= [&U] " cat("\tTREE *", title[i], root.tag, file = file, append = TRUE) cat(write.tree(obj[[i]], file = ""), "\n", sep = "", file = file, append = TRUE) } cat("END;\n", file = file, append = TRUE) } ape/R/print.parafit.R0000644000175100001440000000111712465112403014140 0ustar hornikusers'print.parafit' <- function(x, ...) { cat("\nTest of host-parasite coevolution",'\n','\n') cat("Global test: ParaFitGlobal =",x$ParaFitGlobal,", p-value =", x$p.global, "(", x$nperm,"permutations)",'\n','\n') n.links <- nrow(x$link.table) cat("There are",n.links,"host-parasite links in matrix HP",'\n','\n') cat("Test of individual host-parasite links", "(", x$nperm, "permutations)",'\n','\n') print(x$link.table) cat('\n',"Number of parasites per host",'\n') print(x$para.per.host) cat('\n',"Number of hosts per parasite",'\n') print(x$host.per.para) invisible(x) } ape/R/yule.R0000644000175100001440000000561513002744275012352 0ustar hornikusers## yule.R (2011-11-03) ## Fits Yule Model to a Phylogenetic Tree ## yule: standard Yule model (constant birth rate) ## yule.cov: Yule model with covariates ## Copyright 2003-2011 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. yule <- function(phy, use.root.edge = FALSE) { if (!is.binary.phylo(phy)) stop("tree must be dichotomous to fit the Yule model.") X <- sum(phy$edge.length) nb.node <- phy$Nnode if (!is.null(phy$root.edge) && use.root.edge) X <- X + phy$root.edge else nb.node <- nb.node - 1 lambda <- nb.node/X se <- lambda/sqrt(nb.node) loglik <- -lambda * X + lfactorial(phy$Nnode) + nb.node * log(lambda) obj <- list(lambda = lambda, se = se, loglik = loglik) class(obj) <- "yule" obj } yule.cov <- function(phy, formula, data = NULL) { if (is.null(data)) data <- parent.frame() n <- length(phy$tip.label) nb.node <- phy$Nnode if (!is.null(phy$node.label)) phy$node.label <- NULL bt <- sort(branching.times(phy)) # branching times (from present to past) bt <- rev(bt) # branching times from past to present ni <- cumsum(rev(table(bt))) + 1 X <- model.matrix(formula, data) Xi <- X[phy$edge[, 1], , drop = FALSE] Xj <- X[phy$edge[, 2], , drop = FALSE] dev <- function(b) { 2 * sum(((1/(1 + exp(-(Xi %*% b)))) + (1/(1 + exp(-(Xj %*% b))))) * phy$edge.length/2) - 2 * (sum(log(ni[-length(ni)])) + sum(log((1/(1 + exp(-(X[-(1:(n + 1)), , drop = FALSE] %*% b))))))) } out <- nlm(function(p) dev(p), p = c(rep(0, ncol(X) - 1), -1), hessian = TRUE) Dev <- out$minimum para <- matrix(NA, ncol(X), 2) para[, 1] <- out$estimate if (any(out$gradient == 0)) warning("The likelihood gradient seems flat in at least one dimension (null gradient):\ncannot compute the standard-errors of the parameters.\n") else para[, 2] <- sqrt(diag(solve(out$hessian))) rownames(para) <- colnames(X) colnames(para) <- c("Estimate", "StdErr") ## fit the intercept-only model: X <- model.matrix(~ 1, data = data.frame(X)) Xi <- X[phy$edge[, 1], , drop = FALSE] Xj <- X[phy$edge[, 2], , drop = FALSE] Dev.null <- nlm(function(p) dev(p), p = -1)$minimum cat("\n---- Yule Model with Covariates ----\n\n") cat(" Phylogenetic tree:", deparse(substitute(phy)), "\n") cat(" Number of tips:", n, "\n") cat(" Number of nodes:", nb.node, "\n") cat(" Deviance:", Dev, "\n") cat(" Log-likelihood:", -Dev/2, "\n\n") cat(" Parameter estimates:\n") print(para) cat("\n") cat("Null Deviance:", Dev.null, "\n") cat(" Test of the fitted model: ") chi <- Dev.null - Dev df <- nrow(para) - 1 cat("chi^2 =", round(chi, 3), " df =", df, " P =", round(1 - pchisq(chi, df), 3), "\n") } ape/R/as.bitsplits.R0000644000175100001440000000675312465112403014011 0ustar hornikusers## as.bitsplits.R (2014-12-11) ## Conversion Among Split Classes ## Copyright 2011-2014 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. as.bitsplits <- function(x) UseMethod("as.bitsplits") as.bitsplits.prop.part <- function(x) { foo <- function(vect, RAWVECT) { res <- RAWVECT for (y in vect) { i <- ceiling(y/8) res[i] <- res[i] | as.raw(2^(8 - ((y - 1) %% 8) - 1)) } res } N <- length(x) # number of splits n <- length(x[[1]]) # number of tips nr <- ceiling(n/8) mat <- raw(N * nr) dim(mat) <- c(nr, N) RAWVECT <- raw(nr) for (i in 1:N) mat[, i] <- foo(x[[i]], RAWVECT) ## add the n trivial splits of size 1... : mat.bis <- raw(n * nr) dim(mat.bis) <- c(nr, n) for (i in 1:n) mat.bis[, i] <- foo(i, RAWVECT) ## ... drop the trivial split of size n... : mat <- cbind(mat.bis, mat[, -1, drop = FALSE]) ## ... update the split frequencies... : freq <- attr(x, "number") freq <- c(rep(freq[1L], n), freq[-1L]) ## ... and numbers: N <- N + n - 1L structure(list(matsplit = mat, labels = attr(x, "labels"), freq = freq), class = "bitsplits") } print.bitsplits <- function(x, ...) { cat('Object of class "bitsplits"\n') cat(' ', length(x$labels), 'tips\n') cat(' ', length(x$freq), 'partitions\n') } sort.bitsplits <- function(x, decreasing = FALSE, ...) { o <- order(x$freq, decreasing = decreasing) x$matsplit <- x$matsplit[, o] x$freq <- x$freq[o] x } as.prop.part <- function(x) UseMethod("as.prop.part") as.prop.part.bitsplits <- function(x) { decodeBitsplits <- function(x) { f <- function(y) rev(rawToBits(y)) == as.raw(1) which(unlist(lapply(x, f))) } res <- apply(x$matsplit, 2, decodeBitsplits) attr(res, "number") <- x$freq attr(res, "labels") <- x$labels class(res) <- "prop.part" res } bitsplits <- function(x) { if (inherits(x, "phylo")) { x <- reorder(x, "postorder") labs <- x$tip.label n <- length(labs) m <- x$Nnode N <- dim(x$edge)[1] nr <- ceiling(n/8) nc <- N - n # number of internal edges o <- .C(bitsplits_phylo, as.integer(n), as.integer(m), as.integer(x$edge), as.integer(N), as.integer(nr), raw(nr * nc), NAOK = TRUE)[[6]] freq <- rep(1L, nc) } else { if (!inherits(x, "multiPhylo")) stop('x is not of class "phylo" or "multiPhylo"') x <- .compressTipLabel(x) labs <- attr(x, "TipLabel") n <- length(labs) nr <- ceiling(n/8) ans <- .Call(bitsplits_multiPhylo, x, n, nr) nc <- ans[[3]] o <- ans[[1]][1:(nr * nc)] freq <- ans[[2]][1:nc] } dim(o) <- c(nr, nc) structure(list(matsplit = o, labels = labs, freq = freq), class = "bitsplits") } countBipartitions <- function(phy, X) { n <- Ntip(phy) m <- phy$Nnode N <- Nedge(phy) SPLIT <- bitsplits(phy) nr <- nrow(SPLIT$matsplit) nc <- ncol(SPLIT$matsplit) freq <- rep(0, nc) for (tr in X) { tr <- ape::reorder.phylo(tr, "postorder") e <- tr$edge freq <- .C(CountBipartitionsFromTrees, as.integer(n), as.integer(m), as.integer(e), as.integer(N), as.integer(nr), as.integer(nc), as.raw(SPLIT$matsplit), as.double(freq), NAOK = TRUE)[[8]] } freq } ape/R/mst.R0000644000175100001440000000511712465112403012166 0ustar hornikusers## mst.R (2006-11-08) ## Minimum Spanning Tree ## Copyright 2002-2006 Yvonnick Noel, Julien Claude, and Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. mst <- function(X) { if (class(X) == "dist") X <- as.matrix(X) n <- dim(X)[1] N <- matrix(0, n, n) tree <- NULL large.value <- max(X) + 1 diag(X) <- large.value index.i <- 1 for (i in 1:(n - 1)) { tree <- c(tree, index.i) m <- apply(as.matrix(X[, tree]), 2, min) #calcul les minimum par colonne a <- sortIndex(X[, tree])[1, ] b <- sortIndex(m)[1] index.j <- tree[b] index.i <- a[b] N[index.i, index.j] <- 1 N[index.j, index.i] <- 1 for (j in tree) { X[index.i, j] <- large.value X[j, index.i] <- large.value } } dimnames(N) <- dimnames(X) class(N) <- "mst" return(N) } ### Function returning an index matrix for an increasing sort sortIndex <- function(X) { if(length(X) == 1) return(1) # sorting a scalar? if(!is.matrix(X)) X <- as.matrix(X) # force vector into matrix ## n <- nrow(X) apply(X, 2, function(v) order(rank(v))) # find the permutation } plot.mst <- function(x, graph = "circle", x1 = NULL, x2 = NULL, ...) { n <- nrow(x) if (is.null(x1) || is.null(x2)) { if (graph == "circle") { ang <- seq(0, 2 * pi, length = n + 1) x1 <- cos(ang) x2 <- sin(ang) plot(x1, x2, type = "n", xlab = "", ylab = "", xaxt = "n", yaxt = "n", bty = "n", ...) } if (graph == "nsca") { XY <- nsca(x) x1 <- XY[, 1] x2 <- XY[, 2] plot(XY, type = "n", xlab = "\"nsca\" -- axis 1", ylab = "\"nsca\" -- axis 2", ...) } } else plot(x1, x2, type = "n", xlab = deparse(substitute(x1)), ylab = deparse(substitute(x2)), ...) for (i in 1:n) { w1 <- which(x[i, ] == 1) segments(x1[i], x2[i], x1[w1], x2[w1]) } points(x1, x2, pch = 21, col = "black", bg = "white", cex = 3) text(x1, x2, 1:n, cex = 0.8) } nsca <- function(A) { Dr <- apply(A, 1, sum) Dc <- apply(A, 2, sum) eig.res <- eigen(diag(1 / sqrt(Dr)) %*% A %*% diag(1 / sqrt(Dc))) r <- diag(1 / Dr) %*% (eig.res$vectors)[, 2:4] ## The next line has been changed by EP (20-02-2003), since ## it does not work if 'r' has no dimnames already defined ## dimnames(r)[[1]] <- dimnames(A)[[1]] rownames(r) <- rownames(A) r } ape/R/checkValidPhylo.R0000644000175100001440000001003512745753705014450 0ustar hornikusers## checkValidPhylo.R (2016-07-26) ## Check the Structure of a "phylo" Object ## Copyright 2015-2016 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. checkValidPhylo <- function(phy) { cat("Starting checking the validity of ", deparse(substitute(phy)), "...\n", sep = "") n <- m <- NULL if (is.null(phy$tip.label)) { cat(" FATAL: no element named 'tip.label' in the tree -- did you extract this tree from a \"multiPhylo\" object?\n") } else { if (!is.vector(phy$tip.label)) { cat(" FATAL: 'tip.label' is not a vector\n") } else { if (!is.character(phy$tip.label)) cat(" MODERATE: 'tip.label' is not of mode \"character\"\n") n <- length(phy$tip.label) cat("Found number of tips: n =", n, "\n") } } if (is.null(n)) cat(" FATAL: cannot determine the number of tips\n") if (is.null(phy$Nnode)) { cat(" FATAL: no element named 'Nnode' in the tree\n") } else { if (!is.vector(phy$Nnode)) cat(" MODERATE: 'Nnode' is not a vector\n") if (length(phy$Nnode) != 1) cat(" FATAL: 'Nnode' is not of length 1\n") if (!is.numeric(phy$Nnode)) { cat(" FATAL: 'Nnode' is not numeric\n") } else { if (storage.mode(phy$Nnode) != "integer") cat(" MODERATE: 'Nnode' is not stored as an integer\n") } if (length(phy$Nnode) == 1 && is.numeric(phy$Nnode)) { m <- phy$Nnode cat("Found number of nodes: m =", m, "\n") } } if (is.null(m)) cat(" FATAL: cannot determine the number of nodes\n") if (is.null(phy$edge)) { cat(" FATAL: no element named 'edge' in the tree\n") } else { if (!is.matrix(phy$edge)) { cat(" FATAL: 'edge' is not a matrix\n") } else { nc <- ncol(phy$edge) if (nc != 2) cat(" FATAL: 'edge' has", nc, "columns: it MUST have 2\n") if (!is.numeric(phy$edge)) { cat(" FATAL: 'edge' is not a numeric matrix\n") } else { if (storage.mode(phy$edge) != "integer") cat(" MODERATE: the matrix 'edge' is not stored as integers\n") if (nc == 2) { if (any(phy$edge <= 0)) cat(" FATAL: some elements in 'edge' are negative or zero\n") if (is.null(n) || is.null(m)) { cat("The number of tips and/or nodes was not found: cannot check completely the 'edge' matrix\n") } else { tab <- tabulate(phy$edge) if (length(tab) > n + m) cat(" FATAL: some numbers in 'edge' are larger than 'n + m'\n") if (length(tab) < n + m) cat(" MODERATE: some nodes are missing in 'edge'\n") if (any(tab[1:n] != 1)) cat(" FATAL: each tip must appear once in 'edge'\n") if (any(tab[n + 1:m] < 2)) cat(" FATAL: all nodes should appear at least twice in 'edge'\n") if (m > 1) if (any(tab[n + 2:m] < 3)) cat(" MODERATE: only the root can be of degree 2, all other nodes should be of degree 3 or higher\n") if (any(phy$edge[, 1] <= n & phy$edge[, 1] > 0)) cat(" FATAL: tips should not appear in the 1st column of 'edge'\n") if (any(table(phy$edge[, 2]) > 1)) cat(" FATAL: nodes and tips should appear only once in the 2nd column of 'edge'\n") if (any(phy$edge[, 2] == n + 1L)) cat(" FATAL: the root node should not appear in the 2nd column of 'edge'\n") } } } } } cat("Done.\n") } ape/R/yule.time.R0000644000175100001440000000421712465112403013276 0ustar hornikusers## yule.time.R (2009-02-20) ## Fits the Time-Dependent Yule Model ## Copyright 2009 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. yule.time <- function(phy, birth, BIRTH = NULL, root.time = 0, opti = "nlm", start = 0.01) { opti <- pmatch(opti, c("nlm", "nlminb", "optim")) if (is.na(opti)) stop("ambiguous argument 'opti'") LAMBDA <- function() x body(LAMBDA) <- body(birth) formals(LAMBDA) <- alist(t=) BT <- branching.times(phy) T <- BT[1] x <- BT[1] - BT + root.time m <- phy$Nnode paranam <- c(names(formals(birth))) np <- length(paranam) start <- rep(start, length.out = np) ## Foo is always vectorized if (is.null(BIRTH)) { Foo <- function(x) { n <- length(x) res <- numeric(n) for (i in 1:n) res[i] <- integrate(LAMBDA, x[i], T)$value res } } else { environment(BIRTH) <- environment() Foo <- function(x) BIRTH(T) - BIRTH(x) } half.dev <- function(p) { for (i in 1:np) assign(paranam[i], p[i], pos = sys.frame(1)) root.term <- if (is.null(BIRTH)) integrate(LAMBDA, x[1], T)$value else BIRTH(T) - BIRTH(x[1]) sum(Foo(x)) + root.term - sum(log(LAMBDA(x[2:m]))) } switch(opti, { out <- nlm(half.dev, start, hessian = TRUE) est <- out$estimate se <- sqrt(diag(solve(out$hessian))) loglik <- lfactorial(m) - out$minimum },{ out <- nlminb(start, half.dev) est <- out$par se <- NULL loglik <- lfactorial(m) - out$objective },{ out <- optim(start, half.dev, hessian = TRUE, control = list(maxit = 1000), method = "BFGS") est <- out$par se <- sqrt(diag(solve(out$hessian))) loglik <- lfactorial(m) - out$value }) names(est) <- paranam if (!is.null(se)) names(se) <- paranam structure(list(estimate = est, se = se, loglik = loglik), class = "yule") } ape/R/branching.times.R0000644000175100001440000000155112465112403014434 0ustar hornikusers## branching.times.R (2013-09-24) ## Branching Times of a Phylogenetic Tree ## Copyright 2002-2013 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. branching.times <- function(phy) { if (!inherits(phy, "phylo")) stop('object "phy" is not of class "phylo"') phy <- reorder(phy) n <- length(phy$tip.label) e1 <- phy$edge[, 1] e2 <- phy$edge[, 2] EL <- phy$edge.length N <- length(e1) xx <- numeric(phy$Nnode) interns <- which(e2 > n) ## we loop only on the internal edges, this assumes ## that `xx' is already set with 0 for (i in interns) xx[e2[i] - n] <- xx[e1[i] - n] + EL[i] depth <- xx[e1[N] - n] + EL[N] xx <- depth - xx names(xx) <- if (is.null(phy$node.label)) (n + 1):(n + phy$Nnode) else phy$node.label xx } ape/R/compar.ou.R0000644000175100001440000000573212465112403013271 0ustar hornikusers## compar.ou.R (2010-11-04) ## Ornstein--Uhlenbeck Model for Continuous Characters ## Copyright 2005-2010 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. compar.ou <- function(x, phy, node = NULL, alpha = NULL) { if (!inherits(phy, "phylo")) stop('object "phy" is not of class "phylo".') if (!is.numeric(x)) stop("'x' must be numeric.") if (!is.null(names(x))) { if (all(names(x) %in% phy$tip.label)) x <- x[phy$tip.label] else warning('the names of argument "x" and the tip labels of the tree did not match: the former were ignored in the analysis.') } n <- length(phy$tip.label) root <- n + 1L if (is.null(node)) node <- numeric(0) if (is.character(node)) { if (is.null(phy$node.label)) stop("argument 'node' is character but 'phy' has no node labels") node <- match(node, phy$node.label) + n phy$node.label <- NULL } if (root %in% node) node <- node[-1] bt <- branching.times(phy) Tmax <- bt[1] Wend <- matrix(0, n, length(node) + 1) colnames(Wend) <- c(names(sort(bt[node - n])), as.character(root)) Wstart <- Wend Wstart[, ncol(Wstart)] <- Tmax root2tip <- .Call(seq_root2tip, phy$edge, n, phy$Nnode) for (i in 1:n) { last.change <- names(Tmax) for (j in root2tip[[i]]) { if (j %in% node) { jb <- as.character(j) Wend[i, last.change] <- Wstart[i, jb] <- bt[jb] last.change <- jb } } } W <- cophenetic.phylo(phy) dev <- function(p) { alpha <- p[1] sigma2 <- p[2] if (sigma2 <= 0) return(1e100) theta <- p[-(1:2)] ## fixed a bug below: must be '%*% theta' instead of '* theta' (2010-03-15) M <- rowSums((exp(-alpha * Wend) - exp(-alpha * Wstart)) %*% theta) V <- exp(-alpha * W) * (1 - exp(-2 * alpha * (Tmax - W/2))) R <- chol(V) # correction by Cecile Ane (2010-11-04) n * log(2 * pi * sigma2) + 2 * sum(log(diag(R))) + (t(x - M) %*% chol2inv(R) %*% (x - M)) / sigma2 } out <- if (is.null(alpha)) nlm(function(p) dev(p), p = c(0.1, 1, rep(mean(x), ncol(Wstart))), hessian = TRUE) else nlm(function(p) dev(c(alpha, p)), p = c(1, rep(mean(x), ncol(Wstart))), hessian = TRUE) ## if alpha is estimated it may be that the Hessian matrix has the ## corresponding column and row filled with 0, making solve() fail se <- if (is.null(alpha) && all(out$hessian[1, ] == 0)) c(NA, sqrt(diag(solve(out$hessian[-1, -1])))) else sqrt(diag(solve(out$hessian))) para <- cbind(out$estimate, se) nms <- c("sigma2", paste("theta", 1:ncol(Wstart), sep = "")) if (is.null(alpha)) nms <- c("alpha", nms) dimnames(para) <- list(nms, c("estimate", "stderr")) obj <- list(deviance = out$minimum, para = para, call = match.call()) class(obj) <- "compar.ou" obj } ape/R/plot.popsize.R0000644000175100001440000000272412465112403014032 0ustar hornikusers## plot.popsize.R (2004-07-4) ## Plot population size in dependence of time ## Copyright 2004 Rainer Opgen-Rhein and Korbinian Strimmer ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. plot.popsize <- function(x, show.median=TRUE, show.years=FALSE, subst.rate, present.year, ...) { if (class(x) != "popsize") stop("object \"x\" is not of class \"popsize\"") ylim <- c(min(popsize[,2:5]),max(popsize[,2:5])) if (show.years) { x1 <- -x[,1]/subst.rate+present.year xlab <- "time (years)" xlim <- c(min(x1),max(x1)) } else { x1 <- x[,1] xlab <- "time (past to present in units of substitutions)" xlim <- c(max(x1),min(x1)) } if (show.median) plot(x1,x[,3],type="s", xlim=xlim, ylim=ylim, xlab=xlab,ylab="effective population size",log="y", lwd=2.5, ...) #median else plot(x1,x[,2],type="s", xlim=xlim, ylim=ylim, xlab=xlab,ylab="effective population size",log="y", lwd=2.5, ...) #median lines(x1,x[,4], ...) lines(x1,x[,5], ...) } lines.popsize <- function(x, show.median=TRUE, show.years=FALSE, subst.rate, present.year, ...) { if (class(x) != "popsize") stop("object \"x\" is not of class \"popsize\"") if (show.years) { x1 <- -x[,1]/subst.rate+present.year } else { x1 <- x[,1] } if (show.median) lines(x1,x[,3], lwd=2.5, ...) #median else lines(x1,x[,2], lwd=2.5, ...) #median lines(x1,x[,4], ...) lines(x1,x[,5], ...) } ape/R/clustal.R0000644000175100001440000001064713017303436013040 0ustar hornikusers## clustal.R (2016-11-29) ## Multiple Sequence Alignment with External Applications ## Copyright 2011-2016 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. .errorAlignment <- function(exec, prog) { dirs <- strsplit(Sys.getenv("PATH"), .Platform$path.sep)[[1]] paste0("\n cannot find executable ", sQuote(exec), " on your computer.\n", " It is recommended that you place the executable of ", prog, "\n", " in a directory on the PATH of your computer which is:\n", paste(sort(dirs), collapse = "\n")) } clustalomega <- function(x, exec = NULL, MoreArgs = "", quiet = TRUE) { os <- Sys.info()[1] if (is.null(exec)) { exec <- switch(os, "Linux" = "clustalo", "Darwin" = "clustalo", "Windows" = "clustalo.exe") } if (missing(x)) { out <- system(paste(exec, "-h")) if (out == 127) stop(.errorAlignment(exec, "Clustal-Omega")) return(invisible(NULL)) } x <- as.list(x) labels.bak <- names(x) names(x) <- paste0("Id", 1:length(x)) d <- tempdir() inf <- paste(d, "input_clustalo.fas", sep = "/") outf <- paste(d, "output_clustalo.fas", sep = "/") write.dna(x, inf, "fasta") opts <- paste("-i", inf, "-o", outf, "--force") if (!quiet) opts <- paste(opts, "-v") opts <- paste(opts, MoreArgs) out <- system(paste(exec, opts), ignore.stdout = quiet) if (out == 127) stop(.errorAlignment(exec, "Clustal-Omega")) res <- read.dna(outf, "fasta") rownames(res) <- labels.bak res } clustal <- function(x, pw.gapopen = 10, pw.gapext = 0.1, gapopen = 10, gapext = 0.2, exec = NULL, MoreArgs = "", quiet = TRUE, original.ordering = TRUE) { os <- Sys.info()[1] if (is.null(exec)) { exec <- switch(os, "Linux" = "clustalw", "Darwin" = "clustalw2", "Windows" = "clustalw2.exe") } if (missing(x)) { out <- system(paste(exec, "-help")) if (out == 127) stop(.errorAlignment(exec, "Clustal")) return(invisible(NULL)) } x <- as.list(x) labels.bak <- names(x) names(x) <- paste0("Id", 1:length(x)) d <- tempdir() inf <- paste(d, "input_clustal.fas", sep = "/") outf <- paste(d, "input_clustal.aln", sep = "/") write.dna(x, inf, "fasta") prefix <- c("-INFILE", "-PWGAPOPEN", "-PWGAPEXT", "-GAPOPEN", "-GAPEXT") suffix <- c(inf, pw.gapopen, pw.gapext, gapopen, gapext) opts <- paste(prefix, suffix, sep = "=", collapse = " ") opts <- paste(opts, MoreArgs) out <- system(paste(exec, opts), ignore.stdout = quiet) if (out == 127) stop(.errorAlignment(exec, "Clustal")) res <- read.dna(outf, "clustal") if (original.ordering) res <- res[labels(x), ] rownames(res) <- labels.bak res } muscle <- function(x, exec = "muscle", MoreArgs = "", quiet = TRUE, original.ordering = TRUE) { if (missing(x)) { out <- system(exec) if (out == 127) stop(.errorAlignment(exec, "MUSCLE")) return(invisible(NULL)) } x <- as.list(x) labels.bak <- names(x) names(x) <- paste0("Id", 1:length(x)) d <- tempdir() inf <- paste(d, "input_muscle.fas", sep = "/") outf <- paste(d, "output_muscle.fas", sep = "/") write.dna(x, inf, "fasta") opts <- paste("-in", inf, "-out", outf) if (quiet) opts <- paste(opts, "-quiet") opts <- paste(opts, MoreArgs) out <- system(paste(exec, opts)) if (out == 127) stop(.errorAlignment(exec, "MUSCLE")) res <- read.dna(outf, "fasta") if (original.ordering) res <- res[labels(x), ] rownames(res) <- labels.bak res } tcoffee <- function(x, exec = "t_coffee", MoreArgs = "", quiet = TRUE, original.ordering = TRUE) { if (missing(x)) { out <- system(exec) if (out == 127) stop(.errorAlignment(exec, "T-Coffee")) return(invisible(NULL)) } x <- as.list(x) labels.bak <- names(x) names(x) <- paste0("Id", 1:length(x)) d <- tempdir() od <- setwd(d) on.exit(setwd(od)) inf <- "input_tcoffee.fas" write.dna(x, inf, "fasta") opts <- paste(inf, MoreArgs) if (quiet) opts <- paste(opts, "-quiet=nothing") out <- system(paste(exec, opts)) if (out == 127) stop(.errorAlignment(exec, "T-Coffee")) res <- read.dna("input_tcoffee.aln", "clustal") if (original.ordering) res <- res[labels(x), ] rownames(res) <- labels.bak res } ape/R/root.R0000644000175100001440000002372113013027313012342 0ustar hornikusers## root.R (2016-11-16) ## Roots Phylogenetic Trees ## Copyright 2004-2016 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. is.rooted <- function(phy) UseMethod("is.rooted") .is.rooted_ape <- function(phy, ntips) { if (!is.null(phy$root.edge)) return(TRUE) if (tabulate(phy$edge[, 1])[ntips + 1] > 2) FALSE else TRUE } is.rooted.phylo <- function (phy) .is.rooted_ape(phy, length(phy$tip.label)) is.rooted.multiPhylo <- function(phy) { phy <- unclass(phy) labs <- attr(phy, "TipLabel") if (is.null(labs)) sapply(phy, is.rooted.phylo) else sapply(phy, .is.rooted_ape, ntips = length(labs)) } unroot <- function(phy) UseMethod("unroot") .unroot_ape <- function(phy, n) { ## n: number of tips of phy N <- dim(phy$edge)[1] if (N < 3) stop("cannot unroot a tree with less than three edges.") ## delete FIRST the root.edge (in case this is sufficient to ## unroot the tree, i.e. there is a multichotomy at the root) if (!is.null(phy$root.edge)) phy$root.edge <- NULL if (!.is.rooted_ape(phy, n)) return(phy) ROOT <- n + 1L ### EDGEROOT[1]: the edge to be deleted ### EDGEROOT[2]: the target where to stick the edge to be deleted ### If the tree is in pruningwise (or postorder) order, then ### the last two edges are those connected to the root; the node ### situated in phy$edge[N - 2L, 1L] will be the new root... ophy <- attr(phy, "order") if (!is.null(ophy) && ophy != "cladewise") { NEWROOT <- phy$edge[N - 2L, 1L] EDGEROOT <- c(N, N - 1L) ## make sure EDGEROOT is ordered as described above: if (phy$edge[EDGEROOT[1L], 2L] != NEWROOT) EDGEROOT <- EDGEROOT[2:1] } else { ### ... otherwise, we remove one of the edges coming from ### the root, and eventually adding the branch length to ### the other one also coming from the root. ### In all cases, the node deleted is the 2nd one (numbered ### nb.tip+2 in 'edge'), so we simply need to renumber the ### nodes by adding 1, except the root (this remains the ### origin of the tree). EDGEROOT <- which(phy$edge[, 1L] == ROOT) ##### NEWROOT <- ROOT + 1L ## make sure EDGEROOT is ordered as described above: if (phy$edge[EDGEROOT[1L], 2L] <= n) EDGEROOT <- EDGEROOT[2:1] NEWROOT <- phy$edge[EDGEROOT[1L], 2L] } phy$edge <- phy$edge[-EDGEROOT[1L], ] s <- phy$edge == NEWROOT # renumber the new root phy$edge[s] <- ROOT s <- phy$edge > NEWROOT # renumber all nodes greater than the new root phy$edge[s] <- phy$edge[s] - 1L if (!is.null(phy$edge.length)) { phy$edge.length[EDGEROOT[2L]] <- phy$edge.length[EDGEROOT[2L]] + phy$edge.length[EDGEROOT[1L]] phy$edge.length <- phy$edge.length[-EDGEROOT[1L]] } phy$Nnode <- phy$Nnode - 1L if (!is.null(phy$node.label)) { if (NEWROOT == n + 2L) phy$node.label <- phy$node.label[-1] else { lbs <- phy$node.label tmp <- lbs[NEWROOT - n] lbs <- lbs[-c(1, NEWROOT)] phy$node.label <- c(tmp, lbs) } } phy } unroot.phylo <- function(phy) .unroot_ape(phy, length(phy$tip.label)) unroot.multiPhylo <- function(phy) { oc <- oldClass(phy) class(phy) <- NULL labs <- attr(phy, "TipLabel") if (is.null(labs)) phy <- lapply(phy, unroot.phylo) else { phy <- lapply(phy, .unroot_ape, n = length(labs)) attr(phy, "TipLabel") <- labs } class(phy) <- oc phy } root <- function(phy, ...) UseMethod("root") root.phylo <- function(phy, outgroup, node = NULL, resolve.root = FALSE, interactive = FALSE, edgelabel = FALSE, ...) { if (!inherits(phy, "phylo")) stop('object not of class "phylo"') phy <- reorder(phy) n <- length(phy$tip.label) ROOT <- n + 1L if (interactive) { node <- identify(phy)$nodes cat("You have set resolve.root =", resolve.root, "\n") } e1 <- phy$edge[, 1L] e2 <- phy$edge[, 2L] wbl <- !is.null(phy$edge.length) if (!is.null(node)) { if (node <= n) stop("incorrect node#: should be greater than the number of taxa") outgroup <- NULL newroot <- node } else { if (is.numeric(outgroup)) { if (any(outgroup > n)) stop("incorrect taxa#: should not be greater than the number of taxa") } if (is.character(outgroup)) { outgroup <- match(outgroup, phy$tip.label) if (anyNA(outgroup)) stop("specified outgroup not in labels of the tree") } if (length(outgroup) == n) return(phy) outgroup <- sort(outgroup) # used below ## First check that the outgroup is monophyletic, unless it has only one tip if (length(outgroup) > 1) { pp <- prop.part(phy) ingroup <- (1:n)[-outgroup] newroot <- 0L for (i in 2:phy$Nnode) { if (identical(pp[[i]], ingroup)) { ## inverted with the next if (... (2013-06-16) newroot <- e1[which(e2 == i + n)] break } if (identical(pp[[i]], outgroup)) { newroot <- i + n break } } if (!newroot) stop("the specified outgroup is not monophyletic") MRCA.outgroup <- i + n } else newroot <- e1[which(e2 == outgroup)] } N <- Nedge(phy) oldNnode <- phy$Nnode Nclade <- tabulate(e1)[ROOT] # degree of the root node ## if only 2 edges connect to the root, we have to fuse them: fuseRoot <- Nclade == 2 if (newroot == ROOT) { if (!resolve.root) return(phy) # else (resolve.root == TRUE) if (length(outgroup) > 1) outgroup <- MRCA.outgroup if (!is.null(node)) stop("ambiguous resolution of the root node: please specify an explicit outgroup") k <- which(e1 == ROOT) # find the basal edges if (length(k) > 2) { i <- which(e2 == outgroup) # outgroup is always of length 1 here j <- k[k != i] newnod <- oldNnode + n + 1L phy$edge[j, 1] <- newnod phy$edge <- rbind(c(ROOT, newnod), phy$edge) if (wbl) phy$edge.length <- c(0, phy$edge.length) phy$Nnode <- phy$Nnode + 1L } } else { phy$root.edge <- NULL # just in case INV <- logical(N) w <- which(e2 == newroot) anc <- e1[w] i <- w nod <- anc if (nod != ROOT) { INV[w] <- TRUE i <- w - 1L repeat { if (e2[i] == nod) { if (e1[i] == ROOT) break INV[i] <- TRUE nod <- e1[i] } i <- i - 1L } } ## we keep the edge leading to the old root if needed: if (!fuseRoot) INV[i] <- TRUE ## bind the other clades... if (fuseRoot) { # do we have to fuse the two basal edges? k <- which(e1 == ROOT) k <- if (k[2] > w) k[2] else k[1] phy$edge[k, 1] <- phy$edge[i, 2] if (wbl) phy$edge.length[k] <- phy$edge.length[k] + phy$edge.length[i] } if (fuseRoot) phy$Nnode <- oldNnode - 1L ## added after discussion with Jaime Huerta Cepas (2016-07-30): if (edgelabel) { phy$node.label[e1[INV] - n] <- phy$node.label[e2[INV] - n] phy$node.label[newroot - n] <- "" } phy$edge[INV, ] <- phy$edge[INV, 2:1] if (fuseRoot) { phy$edge <- phy$edge[-i, ] if (wbl) phy$edge.length <- phy$edge.length[-i] N <- N - 1L } if (resolve.root) { newnod <- oldNnode + n + 1L if (length(outgroup) == 1L) { wh <- which(phy$edge[, 2] == outgroup) #phy$edge[1] <- newnod k <- which(phy$edge[, 1] == newroot) # wh should be among k phy$edge[k[k != wh], 1] <- newnod o <- c((1:N)[-wh], wh) phy$edge <- rbind(c(newroot, newnod), phy$edge[o, ]) if (wbl) phy$edge.length <- c(0, phy$edge.length[o]) } else { wh <- which(phy$edge[, 1] == newroot) phy$edge[wh[-1], 1] <- newnod s1 <- 1:(wh[2] - 1) s2 <- wh[2]:N phy$edge <- rbind(phy$edge[s1, ], c(newroot, newnod), phy$edge[s2, ]) if (wbl) phy$edge.length <- c(phy$edge.length[s1], 0, phy$edge.length[s2]) } phy$Nnode <- phy$Nnode + 1L } } ## The block below renumbers the nodes so that they conform ## to the "phylo" format newNb <- integer(n + phy$Nnode) newNb[newroot] <- n + 1L sndcol <- phy$edge[, 2] > n newNb[sort(phy$edge[sndcol, 2])] <- n + 2:phy$Nnode phy$edge[sndcol, 2] <- newNb[phy$edge[sndcol, 2]] phy$edge[, 1] <- newNb[phy$edge[, 1]] if (!is.null(phy$node.label)) { newNb <- newNb[-(1:n)] if (fuseRoot) { newNb <- newNb[-1] phy$node.label <- phy$node.label[-1] } phy$node.label <- phy$node.label[order(newNb)] if (resolve.root) { phy$node.label[is.na(phy$node.label)] <- phy$node.label[1] phy$node.label[1] <- "Root" } } attr(phy, "order") <- NULL reorder.phylo(phy) } root.multiPhylo <- function(phy, outgroup, ...) { oc <- oldClass(phy) class(phy) <- NULL labs <- attr(phy, "TipLabel") if (!is.null(labs)) for (i in seq_along(phy)) phy[[i]]$tip.label <- labs phy <- lapply(phy, root.phylo, outgroup = outgroup, ...) if (!is.null(labs)) { for (i in seq_along(phy)) phy[[i]]$tip.label <- NULL attr(phy, "TipLabel") <- labs } class(phy) <- oc phy } ape/R/write.dna.R0000644000175100001440000001130712732270631013261 0ustar hornikusers## write.dna.R (2012-06-22) ## Write DNA Sequences in a File ## Copyright 2003-2012 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. write.dna <- function(x, file, format = "interleaved", append = FALSE, nbcol = 6, colsep = " ", colw = 10, indent = NULL, blocksep = 1) { format <- match.arg(format, c("interleaved", "sequential", "fasta")) phylip <- if (format %in% c("interleaved", "sequential")) TRUE else FALSE if (inherits(x, "DNAbin")) x <- as.character(x) aligned <- TRUE if (is.matrix(x)) { N <- dim(x) S <- N[2] N <- N[1] xx <- vector("list", N) for (i in 1:N) xx[[i]] <- x[i, ] names(xx) <- rownames(x) x <- xx rm(xx) } else { N <- length(x) S <- unique(lengths(x, use.names = FALSE)) if (length(S) > 1) aligned <- FALSE } if (is.null(names(x))) names(x) <- as.character(1:N) if (is.null(indent)) indent <- if (phylip) 10 else 0 if (is.numeric(indent)) indent <- paste(rep(" ", indent), collapse = "") if (format == "interleaved") { blocksep <- paste(rep("\n", blocksep), collapse = "") if (nbcol < 0) format <- "sequential" } zz <- if (append) file(file, "a") else file(file, "w") on.exit(close(zz)) if (phylip) { if (!aligned) stop("sequences must have the same length for interleaved or sequential format.") cat(N, " ", S, "\n", sep = "", file = zz) if (nbcol < 0) { nb.block <- 1 nbcol <- totalcol <- ceiling(S/colw) } else { nb.block <- ceiling(S/(colw * nbcol)) totalcol <- ceiling(S/colw) } ## Prepare the sequences in a matrix whose elements are ## strings with `colw' characters. SEQ <- matrix("", N, totalcol) for (i in 1:N) { X <- paste(x[[i]], collapse = "") for (j in 1:totalcol) SEQ[i, j] <- substr(X, 1 + (j - 1)*colw, colw + (j - 1)*colw) } ## Prepare the names so that they all have the same nb of chars max.nc <- max(nchar(names(x))) ## always put a space between the sequences and the taxa names fmt <- paste("%-", max.nc + 1, "s", sep = "") names(x) <- sprintf(fmt, names(x)) } switch(format, "interleaved" = { ## Write the first block with the taxon names colsel <- if (nb.block == 1) 1:totalcol else 1:nbcol for (i in 1:N) { cat(names(x)[i], file = zz) cat(SEQ[i, colsel], sep = colsep, file = zz) cat("\n", file = zz) } ## Write eventually the other blocks if (nb.block > 1) { for (k in 2:nb.block) { cat(blocksep, file = zz) endcolsel <- if (k == nb.block) totalcol else nbcol + (k - 1)*nbcol for (i in 1:N) { cat(indent, file = zz) cat(SEQ[i, (1 + (k - 1)*nbcol):endcolsel], sep = colsep, file = zz) cat("\n", file = zz) } } } }, "sequential" = { if (nb.block == 1) { for (i in 1:N) { cat(names(x)[i], file = zz) cat(SEQ[i, ], sep = colsep, file = zz) cat("\n", file = zz) } } else { for (i in 1:N) { cat(names(x)[i], file = zz) cat(SEQ[i, 1:nbcol], sep = colsep, file = zz) cat("\n", file = zz) for (k in 2:nb.block) { endcolsel <- if (k == nb.block) totalcol else nbcol + (k - 1)*nbcol cat(indent, file = zz) cat(SEQ[i, (1 + (k - 1)*nbcol):endcolsel], sep = colsep, file = zz) cat("\n", file = zz) } } } }, "fasta" = { for (i in 1:N) { cat(">", names(x)[i], file = zz, sep = "") cat("\n", file = zz) X <- paste(x[[i]], collapse = "") S <- length(x[[i]]) totalcol <- ceiling(S/colw) if (nbcol < 0) nbcol <- totalcol nb.lines <- ceiling(totalcol/nbcol) SEQ <- character(totalcol) for (j in 1:totalcol) SEQ[j] <- substr(X, 1 + (j - 1) * colw, colw + (j - 1) * colw) for (k in 1:nb.lines) { endsel <- if (k == nb.lines) length(SEQ) else nbcol + (k - 1)*nbcol cat(indent, file = zz) cat(SEQ[(1 + (k - 1)*nbcol):endsel], sep = colsep, file = zz) cat("\n", file = zz) } } }) } ape/R/collapse.singles.R0000644000175100001440000000326612542002172014630 0ustar hornikusers## collapse.singles.R (2015-06-22) ## Collapse "Single" Nodes ## Copyright 2015 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. collapse.singles <- function(tree, root.edge = FALSE) { n <- length(tree$tip.label) e1 <- tree$edge[, 1] e2 <- tree$edge[, 2] tab <- tabulate(e1) if (all(tab > 1)) return(tree) if (is.null(tree$edge.length)) { root.edge <- FALSE wbl <- FALSE } else { wbl <- TRUE el <- tree$edge.length } if (root.edge) ROOTEDGE <- 0 ## start with the root node: ROOT <- n + 1L while (tab[ROOT] == 1) { i <- which(e1 == ROOT) ROOT <- e2[i] if (wbl) { if (root.edge) ROOTEDGE <- ROOTEDGE + el[i] el <- el[-i] } e1 <- e1[-i] e2 <- e2[-i] } singles <- which(tabulate(e1) == 1) while (length(singles)) { i <- which(e1 == singles[1]) j <- which(e2 == e1[i]) e2[j] <- e2[i] if (wbl) { el[j] <- el[j] + el[i] el <- el[-i] } e1 <- e1[-i] e2 <- e2[-i] singles <- which(tabulate(e1) == 1) } Nnode <- length(e1) - n + 1L oldnodes <- unique(e1) if (!is.null(tree$node.label)) tree$node.label <- tree$node.label[oldnodes - n] newNb <- integer(max(oldnodes)) newNb[ROOT] <- n + 1L sndcol <- e2 > n e2[sndcol] <- newNb[e2[sndcol]] <- n + 2:Nnode e1 <- newNb[e1] tree$edge <- cbind(e1, e2, deparse.level = 0) tree$Nnode <- Nnode if (wbl) { if (root.edge) tree$root.edge <- ROOTEDGE tree$edge.length <- el } tree } ape/R/read.GenBank.R0000644000175100001440000000354413010627646013613 0ustar hornikusers## read.GenBank.R (2016-07-27) ## Read DNA Sequences from GenBank via Internet ## Copyright 2002-2016 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. read.GenBank <- function(access.nb, seq.names = access.nb, species.names = TRUE, gene.names = FALSE, as.character = FALSE) { N <- length(access.nb) ## if more than 400 sequences, we break down the requests a <- 1L b <- if (N > 400) 400L else N fl <- tempfile() repeat { URL <- paste0("https://eutils.ncbi.nlm.nih.gov/entrez/eutils/efetch.fcgi?db=nucleotide&id=", paste(access.nb[a:b], collapse = ","), "&rettype=fasta&retmode=text") X <- scan(file = URL, what = "", sep = "\n", quiet = TRUE) cat(X, sep = "\n", file = fl, append = TRUE) if (b == N) break a <- b + 1L b <- b + 400L if (b > N) b <- N } res <- read.FASTA(fl) attr(res, "description") <- names(res) names(res) <- access.nb if (as.character) res <- as.character(res) if (species.names) { a <- 1L b <- if (N > 400) 400L else N sp <- character(0) repeat { URL <- paste("https://eutils.ncbi.nlm.nih.gov/entrez/eutils/efetch.fcgi?db=nucleotide&id=", paste(access.nb[a:b], collapse = ","), "&rettype=gb&retmode=text", sep = "") X <- scan(file = URL, what = "", sep = "\n", quiet = TRUE, n = -1) sp <- c(sp, gsub(" +ORGANISM +", "", grep("ORGANISM", X, value = TRUE))) if (b == N) break a <- b + 1L b <- b + 400L if (b > N) b <- N } attr(res, "species") <- gsub(" ", "_", sp) } if (gene.names) warning("you used 'gene.names = TRUE': this option is obsolete; please update your code.") res } ape/R/triangMtd.R0000644000175100001440000000244012465112403013310 0ustar hornikusers## treePop.R (2011-10-11) ## Tree Reconstruction With the Triangles Method ## Copyright 2011 Andrei-Alin Popescu ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. triangMtd <- function(X) { if (is.matrix(X)) X <- as.dist(X) if (any(is.na(X))) stop("missing values are not allowed in the distance matrix") N <- attr(X, "Size") labels <- attr(X, "Labels") if (is.null(labels)) labels <- as.character(1:N) ans <- .C(C_triangMtd, as.double(X), as.integer(N), integer(2*N - 3), integer(2*N - 3), double(2*N - 3), NAOK = TRUE) obj <- list(edge = cbind(ans[[3]], ans[[4]]), edge.length = ans[[5]], tip.label = labels, Nnode = N - 2L) class(obj) <- "phylo" reorder(obj) } triangMtds <- function(X) { if (is.matrix(X)) X <- as.dist(X) X[is.na(X)] <- -1 X[X < 0] <- -1 N <- attr(X, "Size") labels <- attr(X, "Labels") if (is.null(labels)) labels <- as.character(1:N) ans <- .C(C_triangMtds, as.double(X), as.integer(N), integer(2*N - 3), integer(2*N - 3), double(2*N - 3), NAOK = TRUE) obj <- list(edge = cbind(ans[[3]], ans[[4]]), edge.length = ans[[5]], tip.label = labels, Nnode = N - 2L) class(obj) <- "phylo" reorder(obj) } ape/R/rtt.R0000644000175100001440000000404712726154765012216 0ustar hornikusers## rtt.R (2015-07-16) ## Root a tree by root-to-tip regression ## Copyright (c) 2014-2015, Rosemary McCloskey, BC Centre for Excellence in HIV/AIDS ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. rtt <- function (t, tip.dates, ncpu = 1, objective = "correlation", opt.tol = .Machine$double.eps^0.25) { if (objective == "correlation") objective <- function(x, y) cor.test(y, x)$estimate else if (objective == "rsquared") objective <- function(x, y) summary(lm(y ~ x))$r.squared else if (objective == "rms") objective <- function(x, y) -summary(lm(y ~ x))$sigma^2 else stop("objective must be one of \"correlation\", \"rsquared\", or \"rms\"") ut <- unroot(t) dist <- dist.nodes(ut)[, 1:(ut$Nnode + 2)] f <- function (x, parent, child) { edge.dist <- x * dist[parent, ] + (1 - x) * dist[child,] objective(tip.dates, edge.dist) } obj.edge <- if (ncpu > 1) unlist(mclapply(1:nrow(ut$edge), function (e) { opt.fun <- function (x) f(x, ut$edge[e,1], ut$edge[e,2]) optimize(opt.fun, c(0, 1), maximum = TRUE, tol = opt.tol)$objective }, mc.cores=ncpu)) else apply(ut$edge, 1, function (e) { opt.fun <- function (x) f(x, e[1], e[2]) optimize(opt.fun, c(0, 1), maximum = TRUE, tol = opt.tol)$objective }) best.edge <- which.max(obj.edge) best.edge.parent <- ut$edge[best.edge, 1] best.edge.child <- ut$edge[best.edge, 2] best.edge.length <- ut$edge.length[best.edge] opt.fun <- function (x) f(x, best.edge.parent, best.edge.child) best.pos <- optimize(opt.fun, c(0, 1), maximum = TRUE, tol = opt.tol)$maximum new.root <- list(edge = matrix(c(2L, 1L), 1, 2), tip.label = "new.root", edge.length = 1, Nnode = 1L, root.edge = 1) class(new.root) <- "phylo" ut <- bind.tree(ut, new.root, where = best.edge.child, position = best.pos * best.edge.length) ut <- collapse.singles(ut) ut <- root(ut, "new.root") drop.tip(ut, "new.root") } ape/R/pic.R0000644000175100001440000001325512725761777012167 0ustar hornikusers## pic.R (2013-02-18) ## Phylogenetically Independent Contrasts ## Copyright 2002-2013 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. pic <- function(x, phy, scaled = TRUE, var.contrasts = FALSE, rescaled.tree = FALSE) { if (!inherits(phy, "phylo")) stop("object 'phy' is not of class \"phylo\"") if (is.null(phy$edge.length)) stop("your tree has no branch lengths") nb.tip <- length(phy$tip.label) nb.node <- phy$Nnode if (nb.node != nb.tip - 1) stop("'phy' is not rooted and fully dichotomous") if (length(x) != nb.tip) stop("length of phenotypic and of phylogenetic data do not match") if (any(is.na(x))) stop("missing data in 'x': you may consider removing the species with missing data from your tree with the function 'drop.tip'.") phy <- reorder(phy, "postorder") phenotype <- numeric(nb.tip + nb.node) if (is.null(names(x))) { phenotype[1:nb.tip] <- x } else { if (all(names(x) %in% phy$tip.label)) phenotype[1:nb.tip] <- x[phy$tip.label] else { phenotype[1:nb.tip] <- x warning("the names of argument 'x' and the tip labels of the tree did not match: the former were ignored in the analysis.") } } ## No need to copy the branch lengths: they are rescaled ## in the C code, so it's important to leave the default ## `DUP = TRUE' of .C. ans <- .C(C_pic, as.integer(nb.tip), as.integer(nb.node), as.integer(phy$edge[, 1]), as.integer(phy$edge[, 2]), as.double(phy$edge.length), as.double(phenotype), double(nb.node), double(nb.node), as.integer(var.contrasts), as.integer(scaled)) contr <- ans[[7]] lbls <- if (is.null(phy$node.label)) as.character(1:nb.node + nb.tip) else phy$node.label if (var.contrasts) { contr <- cbind(contr, ans[[8]]) dimnames(contr) <- list(lbls, c("contrasts", "variance")) } else names(contr) <- lbls if (rescaled.tree) { phy$edge.length <- ans[[5]] contr <- list(contr = contr, rescaled.tree = phy) } contr } pic.ortho <- function(x, phy, var.contrasts = FALSE, intra = FALSE) { n <- length(x) m <- n - 1L # number of nodes phy <- reorder(phy, "postorder") xx <- unlist(lapply(x, mean)) # 'x' in Felsenstein's paper xx <- c(xx, numeric(m)) delta.v <- numeric(n + m) s <- 1/lengths(x) s <- c(s, numeric(m)) contrast <- var.cont <- numeric(m) i <- 1L while (i < m + n) { d1 <- phy$edge[i, 2] d2 <- phy$edge[i + 1L, 2] a <- phy$edge[i, 1] tmp1 <- 1/(phy$edge.length[i] + delta.v[d1]) tmp2 <- 1/(phy$edge.length[i + 1L] + delta.v[d2]) xx[a] <- (tmp1 * xx[d1] + tmp2 * xx[d2])/(tmp1 + tmp2) delta.v[a] <- 1/(tmp1 + tmp2) f1 <- tmp1/(tmp1 + tmp2) f2 <- tmp2/(tmp1 + tmp2) s[a] <- f1*f1 * s[d1] + f2*f2 * s[d2] tmp <- 1/(s[d1] + s[d2]) contrast[a - n] <- (xx[d1] - xx[d2]) * sqrt(tmp) var.cont[a - n] <- (1/tmp1 + 1/tmp2) * tmp i <- i + 2L } lbls <- if (is.null(phy$node.label)) as.character(1:m + n) else phy$node.label if (var.contrasts) { contrast <- cbind(contrast, var.cont) dimnames(contrast) <- list(lbls, c("contrasts", "variance")) } else names(contrast) <- lbls if (intra) { intraspe.ctr <- function(x) { k <- length(x) - 1L if (!k) return(NULL) ctr <- numeric(k) ctr[1L] <- x[1L] - x[2L] if (k > 1) for (i in 2:k) ctr[i] <- x[i + 1L] - mean(x[1:i]) sqrt((1:k)/(1:k + 1)) * ctr } tmp <- lapply(x, intraspe.ctr) names(tmp) <- phy$tip.label attr(contrast, "intra") <- tmp } contrast } varCompPhylip <- function(x, phy, exec = NULL) { n <- Ntip(phy) if (is.vector(x)) x <- as.list(x) if (is.matrix(x) || is.data.frame(x)) { tmpx <- vector("list", n) for (i in 1:n) tmpx[[i]] <- x[i, , drop = FALSE] names(tmpx) <- rownames(x) x <- tmpx } p <- if (is.vector(x[[1]])) 1L else ncol(x[[1]]) if (!is.null(names(x))) x <- x[phy$tip.label] phy <- makeLabel(phy, len = 10) lbs <- phy$tip.label ni <- sapply(x, function(xx) if (is.vector(xx)) 1L else nrow(xx)) pfx <- tempdir() write.tree(phy, file = paste(pfx, "intree", sep = "/")) infile <- paste(pfx, "infile", sep = "/") file.create(infile) cat(n, " ", p, "\n", sep = "", file = infile, append = TRUE) for (i in 1:n) { cat(lbs[i], file = infile, append = TRUE) ## can surely be better but OK for the moment: cat(paste(rep(" ", 11 - nchar(lbs[i])), collapse = ""), file = infile, append = TRUE) cat(ni[i], "\n", sep = "", file = infile, append = TRUE) if (ni[i] == 1) { cat(x[[i]], sep = " ", file = infile, append = TRUE) cat("\n", file = infile, append = TRUE) } else write(t(x[[i]]), file = infile, ncolumns = p, append = TRUE) } if (is.null(exec)) exec <- if (.Platform$OS.type == "unix") "phylip contrast" else "contrast" odir <- setwd(pfx) on.exit(setwd(odir)) if (file.exists("outfile")) unlink("outfile") system(exec, intern = TRUE, input = c("W", "A", "Y")) varA <- scan("outfile", skip = 7, nlines = p, quiet = TRUE) varE <- scan("outfile", skip = 11 + p, nlines = p, quiet = TRUE) if (p > 1) { varA <- matrix(varA, p, p, byrow = TRUE) varE <- matrix(varE, p, p, byrow = TRUE) } list(varA = varA, varE = varE) } ape/R/CADM.post.R0000644000175100001440000002371412465112403013056 0ustar hornikusers`CADM.post` <- function(Dmat, nmat, n, nperm=99, make.sym=TRUE, weights=NULL, mult="holm", mantel=FALSE, silent=FALSE) { ### Function to carry out a posteriori tests of the contribution of individual ### matrices to the congruence of a group of distance matrices. ### ### copyleft - Pierre Legendre, December 2008 ### ### Reference - ### Legendre, P. and F.-J. Lapointe. 2004. Assessing congruence among distance ### matrices: single malt Scotch whiskies revisited. Australian and New Zealand ### Journal of Statistics 46: 615-629. ### ### Parameters of the function -- ### ### Dmat = A text file listing the distance matrices one after the other, with ### or without blank lines. ### Each matrix is in the form of a square distance matrix with 0's ### on the diagonal. ### ### nmat = number of distance matrices in file Dmat. ### ### n = number of objects in each distance matrix. All matrices have same n. ### ### nperm = number of permutations for the tests. ### ### make.sym = TRUE: turn asymmetric matrices into symmetric matrices by ### averaging the two triangular portions. ### = FALSE: analyse asymmetric matrices as they are. ### ### weights = a vector of positive weights for the distance matrices. ### Example: weights = c(1,2,3) ### = NULL (default): all matrices have same weight in calculation of W. ### ### mult = method for correcting P-values due to multiple testing. The methods ### are "holm" (default), "sidak", and "bonferroni". The Bonferroni ### correction is overly conservative; it is not recommended. It is ### included to allow comparisons with the other methods. ### ### mantel = TRUE: Mantel statistics are computed from ranked distances, ### as well as permutational P-values. ### = FALSE (default): Mantel statistics and tests are not computed. ### ### silent = TRUE: informative messages will not be printed, except stopping ### messages. Option useful for simulation work. ### = FALSE: informative messages will be printed. ### ################################################################################ mult <- match.arg(mult, c("sidak", "holm", "bonferroni")) if(nmat < 2) stop("Analysis requested for a single D matrix: CADM is useless") a <- system.time({ ## Check the input file if(ncol(Dmat) != n) stop("Error in the value of 'n' or in the D matrices themselves") nmat2 <- nrow(Dmat)/n if(nmat2 < nmat) # OK if 'nmat' < number of matrices in the input file stop("Number of input D matrices = ",nmat2,"; this value is < nmat") nd <- n*(n-1)/2 if(is.null(weights)) { w <- rep(1,nmat) } else { if(length(weights) != nmat) stop("Incorrect number of values in vector 'weights'") if(length(which(weights < 0)) > 0) stop("Negative weights are not permitted") w <- weights*nmat/sum(weights) if(!silent) cat("Normalized weights =",w,'\n') } ## Are asymmetric D matrices present? asy <- rep(FALSE, nmat) asymm <- FALSE end <- 0 for(k in 1:nmat) { begin <- end+1 end <- end+n D.temp <- Dmat[begin:end,] if(sum(abs(diag(as.matrix(D.temp)))) > 0) stop("Diagonal not 0: matrix #",k," is not a distance matrix") vec1 <- as.vector(as.dist(D.temp)) vec2 <- as.vector(as.dist(t(D.temp))) if(sum(abs((vec1-vec2))) > 0) { if(!silent) cat("Matrix #",k," is asymmetric",'\n') asy[k] <- TRUE asymm <- TRUE } } D1 <- as.list(1:nmat) if(asymm) { if(make.sym) { if(!silent) cat("\nAsymmetric matrices were transformed to be symmetric",'\n') } else { nd <- nd*2 if(!silent) cat("\nAnalysis carried out on asymmetric matrices",'\n') D2 <- as.list(1:nmat) } } else { if(!silent) cat("Analysis of symmetric matrices",'\n') } Y <- rep(NA,nd) ## String out the distance matrices (vec) and assemble them as columns into matrix 'Y' ## Construct also matrices of ranked distances D1[[k]] and D2[[k]] for permutation test end <- 0 for(k in 1:nmat) { begin <- end+1 end <- end+n D.temp <- as.matrix(Dmat[begin:end,]) vec <- as.vector(as.dist(D.temp)) if(asymm) { if(!make.sym) { ## Analysis carried out on asymmetric matrices: ## The ranks are computed on the whole matrix except the diagonal values. ## The two halves are stored as symmetric matrices in D1[[k]] and D2[[k]] vec <- c(vec, as.vector(as.dist(t(D.temp)))) diag(D.temp) <- NA D.temp2 <- rank(D.temp) diag(D.temp2) <- 0 # cat("nrow =",nrow(D.temp2)," ncol =",ncol(D.temp2),'\n') # cat("Matrix ",k," min =",min(D.temp2)," max =",max(D.temp2),'\n') # cat("Matrix ",k," max values #",which(D.temp2 == max(D.temp2)),'\n') D1[[k]] <- as.matrix(as.dist(D.temp2)) D2[[k]] <- as.matrix(as.dist(t(D.temp2))) } else { ## Asymmetric matrices transformed to be symmetric, stored in D1[[k]] vec <- (vec + as.vector(as.dist(t(D.temp)))) / 2 D.temp2 <- (D.temp + t(D.temp)) / 2 D.temp2 <- as.dist(D.temp2) D.temp2[] <- rank(D.temp2) D.temp2 <- as.matrix(D.temp2) D1[[k]] <- D.temp2 } } else { ## Symmetric matrices are stored in D1[[k]] D.temp2 <- as.dist(D.temp) D.temp2[] <- rank(D.temp2) D1[[k]] <- as.matrix(D.temp2) } Y <- cbind(Y, vec) } Y <- as.matrix(Y[,-1]) colnames(Y) <- colnames(Y,do.NULL = FALSE, prefix = "Dmat.") ## Begin calculations: compute reference value of S ## Transform the distances to ranks, by column Rmat <- apply(Y,2,rank) ## Compute the S = Sum-of-Squares of the row-marginal sums of ranks (eq. 1a) ## The ranks are weighted during the sum by the vector of matrix weights 'w' sumRanks <- as.vector(Rmat%*%w) S <- (nd-1)*var(sumRanks) ## Begin a posteriori tests of individual matrices ## Statistics displayed for each matrix: "Mantel.mean" and "W.per.matrix" ## Calculate the mean of the Mantel correlations on ranks for each matrix Mantel.cor <- cor(Rmat) diag(Mantel.cor) <- 0 spear.mean <- as.vector(Mantel.cor%*%w)/(nmat-1) ## Calculate Kendall's W for each variable ## W.var <- ((nmat-1)*spear.mean+1)/nmat ## P-value for each matrix: test of S, permuting values in matrix[[k]] only ## as in program CADM.f (2004) ## Initialize the counters counter <- rep(1,nmat) ## Test each matrix 'k' in turn for(k in 1:nmat) { ## Create a new Rmat table where the permuted column has been removed Rmat.mod <- Rmat[,-k] ## Permutation loop: string out permuted matrix 'k' only for(j in 1:nperm) { order <- sample(n) if(asymm & !make.sym) { ## For asymmetric matrices: permute the values within each triangular ## portion, stored as square matrices in D1[[]] and D2[[]] vec <- as.vector(as.dist(D1[[k]][order,order])) vec <- c(vec, as.vector(as.dist(D2[[k]][order,order]))) } else { vec <- as.vector(as.dist(D1[[k]][order,order])) } Rmat.perm <- cbind(Rmat.mod, vec) S.perm <- (nd-1)*var(as.vector(Rmat.perm%*%w)) if(S.perm >= S) counter[k] <- counter[k]+1 } } ## Calculate P-values counter <- counter/(nperm+1) ## Correction to P-values for multiple testing if(mult == "sidak") { vec.corr = NA for(i in 1:nmat) vec.corr = c(vec.corr, (1-(1-counter[i])^nmat)) vec.corr <- vec.corr[-1] } if(mult == "holm") vec.corr <- p.adjust(counter, method="holm") if(mult == "bonferroni") vec.corr <- p.adjust(counter, method="bonferroni") ## Create a data frame containing the results # table <- rbind(spear.mean, W.var, counter, vec.corr) # rownames(table) <- c("Mantel.mean", "W.per.matrix", "Prob", "Corrected prob") table <- rbind(spear.mean, counter, vec.corr) rownames(table) <- c("Mantel.mean", "Prob", "Corrected.prob") colnames(table) <- colnames(table,do.NULL = FALSE, prefix = "Dmat.") ## Mantel tests if(mantel) { diag(Mantel.cor) <- 1 rownames(Mantel.cor) <- colnames(table) colnames(Mantel.cor) <- colnames(table) Mantel.prob <- matrix(1,nmat,nmat) rownames(Mantel.prob) <- colnames(table) colnames(Mantel.prob) <- colnames(table) for(j in 1:nperm) { # Each matrix is permuted independently # There is no need to permute the last matrix Rmat.perm <- rep(NA,nd) ## if(asymm & !make.sym) { ## For asymmetric matrices: permute the values within each triangular ## portion, stored as square matrices in D1[[]] and D2[[]] for(k in 1:(nmat-1)) { order <- sample(n) vec <- as.vector(as.dist(D1[[k]][order,order])) vec <- c(vec, as.vector(as.dist(D2[[k]][order,order]))) Rmat.perm <- cbind(Rmat.perm, vec) } vec <- as.vector(as.dist(D1[[nmat]])) vec <- c(vec, as.vector(as.dist(D2[[nmat]]))) Rmat.perm <- cbind(Rmat.perm, vec) } else { for(k in 1:(nmat-1)) { order <- sample(n) vec <- as.vector(as.dist(D1[[k]][order,order])) Rmat.perm <- cbind(Rmat.perm, vec) } vec <- as.vector(as.dist(D1[[nmat]])) Rmat.perm <- cbind(Rmat.perm, vec) } # Remove the first column of Rmat.perm containing NA Rmat.perm <- as.matrix(Rmat.perm[,-1]) # Compute Mantel correlations on ranks under permutation Mantel.cor.perm <- cor(Rmat.perm) for(j2 in 1:(nmat-1)) { # Compute prob in the upper tail for(j1 in (j2+1):nmat) { if(Mantel.cor.perm[j1,j2] >= Mantel.cor[j1,j2]) Mantel.prob[j1,j2] <- Mantel.prob[j1,j2]+1 } } } Mantel.prob <- as.matrix(as.dist(Mantel.prob/(nperm+1))) diag(Mantel.prob) <- NA # Corrected 08feb13 } }) a[3] <- sprintf("%2f",a[3]) if(!silent) cat("Time to compute a posteriori tests (per matrix) =",a[3]," sec",'\n') out <- list(A_posteriori_tests=table, Correction.type=mult) if(mantel) { out$Mantel.cor <- Mantel.cor out$Mantel.prob <- Mantel.prob } out$nperm <- nperm class(out) <- "CADM.post" out } ape/R/print.lmorigin.R0000644000175100001440000000441212465112403014333 0ustar hornikusers'print.lmorigin' <- function(x, ...) { if(x$origin) { cat("\nRegression through the origin",'\n') } else { cat("\nMultiple regression with estimation of intercept",'\n') } cat("\nCall:\n") cat(deparse(x$call),'\n') if(x$origin) { names <- x$var.names[-1] } else { names <- c("(Intercept)",x$var.names[-1]) } cat("\nCoefficients and parametric test results \n",'\n') res <- as.data.frame(cbind(summary(x$reg)$coefficients[,1], summary(x$reg)$coefficients[,2], summary(x$reg)$coefficients[,3], summary(x$reg)$coefficients[,4])) rownames(res) <- names colnames(res) <- c("Coefficient","Std_error","t-value","Pr(>|t|)") printCoefmat(res, P.values=TRUE, signif.stars=TRUE) if(x$nperm > 0) { cat("\nTwo-tailed tests of regression coefficients\n",'\n') res2 <- as.data.frame(cbind(summary(x$reg)$coefficients[,1], x$p.param.t.2tail, x$p.perm.t.2tail)) rownames(res2) <- names colnames(res2) <- c("Coefficient","p-param","p-perm") nc <- 3 printCoefmat(res2, P.values=TRUE, signif.stars=TRUE, has.Pvalue = 3 && substr(colnames(res2)[3],1,6) == "p-perm") cat("\nOne-tailed tests of regression coefficients:",'\n') cat("test in the direction of the sign of the coefficient\n",'\n') res1 <- as.data.frame(cbind(summary(x$reg)$coefficients[,1], x$p.param.t.1tail, x$p.perm.t.1tail)) rownames(res1) <- names colnames(res1) <- c("Coefficient","p-param","p-perm") nc <- 3 printCoefmat(res1, P.values=TRUE, signif.stars=TRUE, has.Pvalue = 3 && substr(colnames(res1)[3],1,6) == "p-perm") } cat("\nResidual standard error:", summary(x$reg)$sigma, "on", summary(x$reg)$df[2],"degrees of freedom",'\n') cat("Multiple R-square:", summary(x$reg)$r.squared," Adjusted R-square:", summary(x$reg)$adj.r.squared,'\n') F <- summary(x$reg)$fstatistic[[1]] df1 <- summary(x$reg)$fstatistic[[2]] df2 <- summary(x$reg)$fstatistic[[3]] p.param.F <- pf(F, df1, df2, lower.tail=FALSE) cat("\nF-statistic:", F, "on", df1, "and", df2, "DF:\n") cat(" parametric p-value :", p.param.F,'\n') if(x$nperm > 0) { cat(" permutational p-value:", x$p.perm.F,'\n') if(x$method == "raw") { cat("after",x$nperm,"permutations of",x$method,"data",'\n','\n') } else { cat("after",x$nperm,"permutations of",x$method,"of full model",'\n','\n') } } invisible(x) } ape/R/reconstruct.R0000644000175100001440000003500712742174001013737 0ustar hornikusers## reconstruct.R (2016-07-15) ## Ancestral Character Estimation ## Copyright 2014-2016 Manuela Royer-Carenzi, Didier Gilles ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. #renvoie la racine d'arbre racine <- function(arbre) { Ntip(arbre) + 1 } # renvoie une liste dont la premiere composante est l'arbre renumerote # de telle sorte que l'index d'un enfant est superieur a celui de son pere, # la seconde compopsante est la fonction de l'index initial vers le second, # et la troisieme son inverse # (attention probleme pour l'image de 0 mise a l'image du max) # renumeroteArbre <- function(arbre) { m <- Ntip(arbre) + Nnode(arbre) v<-numeric(m) t<-numeric(m) stack<-numeric(m) istack<-1 stack[istack]<-racine(arbre) codeI<-1 codeL<-Nnode(arbre)+1 while(istack>0){ cour<-stack[istack] istack<-istack-1 l <- which(arbre$edge[, 1] == cour) if(length(l)>0){ v[cour] <- codeI t[codeI] <- cour codeI <- codeI+1 for(i in 1:length(l)) { istack<-istack+1 stack[istack] <- arbre$edge[l[i], 2] } } else { v[cour] <- codeL t[codeL] <- cour codeL <- codeL+1 } } arbrebis<-arbre #renumeroter les noms for(i in 1:Nedge(arbre)) { arbrebis$edge[i,1] <- v[arbre$edge[i,1]] arbrebis$edge[i,2] <- v[arbre$edge[i,2]] } l <- list(arbre = arbrebis, cod = v, dec = t) l } #calcule la matrice C selon le modele BM ou ABM # calculeC_ABM <- function(arbre) { m <- max(arbre[["edge"]]) C <- matrix(0,nrow=m,ncol=m) for(i in 1:(m)) { l <- which(arbre$edge[, 2] == i) if(length(l)>0){ for(j in 1:(m)) { C[j,i] <- C[j, arbre$edge[l[1], 1]] } } C[i,i]<-1; } t(C) } #calcule la matrice C selon le modele OU ou OU* # calculeC_OU <- function(arbre, a) { m <- max(arbre[["edge"]]) C <- matrix(0,nrow=m,ncol=m) for(i in 1:(m)) { l <- which(arbre$edge[, 2] == i) if(length(l)>0){ for(j in 1:(m)) { C[j,i] <- C[j, arbre$edge[l[1], 1]]*exp(-a*arbre$edge.length[l[1]]) } } C[i,i]<-1; } t(C) } #calcule la matrice C selon le modele type qui vaut ABM ou OU calculeC <- function(type, arbre, a) { switch(type, ABM = calculeC_ABM(arbre), OU = calculeC_OU(arbre, a)) } ######################### #calcul Variance ######################### getSumSquare <- function(value, arbre) { sum <- 0. for(eu in 1:Nedge(arbre)) sum <- sum + (value[arbre$edge[eu,2]]-value[arbre$edge[eu,1]])^2/arbre$edge.length[eu] sum } getMLHessian <- function(value, arbre) { sumSqu <- getSumSquare(value, arbre) nI <- Nnode(arbre) nT <- length(arbre$tip.label) nE <- nI+nT-1 sizeH<-nI+1 hessian <- matrix(0., nrow=sizeH, ncol=sizeH) var <- sumSqu/nE sd <- sqrt(var) hessian[1,1] <- -nE/(2*var^2)+sumSqu/var^3 for(i in 1:nI) { child <- which(arbre$edge[, 1] == nT+i) if(length(child)>0) { for(j in 1:length(child)) { hessian[1,i+1] <- hessian[1,i+1]-(value[arbre$edge[child[j],2]]-value[nT+i])/arbre$edge.length[child[j]] hessian[i+1,i+1] <- hessian[i+1,i+1]+1./arbre$edge.length[child[j]] if(arbre$edge[child[j],2]>nT) hessian[i+1,arbre$edge[child[j],2]-nT+1] <- -1./(var*arbre$edge.length[child[j]]) } } anc <- which(arbre$edge[, 2] == nT+i) if(length(anc)>0) { for(j in 1:length(anc)) { hessian[1,i+1] <- hessian[1,i+1]+(value[nT+i]-value[arbre$edge[anc[j],1]])/arbre$edge.length[anc[j]] hessian[i+1,i+1] <- hessian[i+1,i+1]+1./arbre$edge.length[anc[j]] hessian[i+1,arbre$edge[anc[j],1]-nT+1] <- -1./(var*arbre$edge.length[anc[j]]) } } hessian[1,i+1] <- -hessian[1,i+1]/sd^2 hessian[i+1,1] <- hessian[1,i+1] hessian[i+1,i+1] <- hessian[i+1,i+1]/var } hessian } getREMLHessian <- function(value, arbre, sigma2) { nI <- Nnode(arbre) nT <- length(arbre$tip.label) sizeH<-nI hessian <- matrix(0., nrow=sizeH, ncol=sizeH) for(i in 1:nI) { child <- which(arbre$edge[, 1] == nT+i) if(length(child)>0) { for(j in 1:length(child)) { hessian[i,i] <- hessian[i,i]+1./arbre$edge.length[child[j]] if(arbre$edge[child[j],2]>nT) hessian[i,arbre$edge[child[j],2]-nT] <- -1./(sigma2*arbre$edge.length[child[j]]) } } anc <- which(arbre$edge[, 2] == nT+i) if(length(anc)>0) { for(j in 1:length(anc)) { hessian[i,i] <- hessian[i,i]+1./arbre$edge.length[anc[j]] hessian[i,arbre$edge[anc[j],1]-nT] <- -1./(sigma2*arbre$edge.length[anc[j]]) } } hessian[i,i] <- hessian[i,i]/sigma2 } hessian } glsBM <- function (phy, x, CI=TRUE) { obj <- list() nb.tip <- length(phy$tip.label) nb.node <- phy$Nnode nbTotN <- nb.tip+nb.node sigmaMF <- 1 TsTemps <- dist.nodes(phy) TempsRacine <- TsTemps[(nb.tip+1),] IndicesMRCA <- mrca(phy, full=T) M <- matrix(NA, ncol=nbTotN, nrow=nbTotN) for (i in 1:nbTotN) { for (j in 1:nbTotN) { M[i,j] <- sigmaMF^2 * TempsRacine[IndicesMRCA[i,j]] } } # M = SigmaZ varAL <- M[-(1:nb.tip), 1:nb.tip] varAA <- M[-(1:nb.tip), -(1:nb.tip)] varLL <- M[(1:nb.tip), 1:nb.tip] invVarLL <- solve(varLL) UL <- rep(1, length=nb.tip) UA <- rep(1, length=nb.node) TL <- TempsRacine[1:nb.tip] TA <- TempsRacine[(nb.tip+1):(nb.tip+nb.node)] # IVL_Z <- invVarLL %*% x IVL_T <- invVarLL %*% TL IVL_U <- invVarLL %*% UL U_IVL_U <- t(UL) %*% IVL_U U_IVL_Z <- t(UL) %*% IVL_Z DeltaU <- UA - varAL %*% IVL_U # Racine_chap <- solve(U_IVL_U) %*% U_IVL_Z Racine_chap <- as.numeric(Racine_chap) Anc_chap <- Racine_chap * DeltaU + varAL %*% IVL_Z Anc_chap <- as.vector(Anc_chap) obj$ace <- Anc_chap names(obj$ace) <- (nb.tip + 1):(nb.tip + nb.node) # if (CI) { Vec <- x - Racine_chap Num <- t(Vec) %*% invVarLL %*% Vec Num <- as.numeric(Num) sigma2_chap <- Num / (nb.tip-1) obj$sigma2 <- sigma2_chap se <- sqrt((varAA - varAL %*% invVarLL %*% t(varAL))[cbind(1:nb.node, 1:nb.node)]) se <- se * sqrt(sigma2_chap) tmp <- se * qt(0.025, df=nb.tip-1) obj$CI95 <- cbind(lower=obj$ace + tmp, upper=obj$ace - tmp) } obj } glsABM <- function (phy, x, CI=TRUE) { obj <- list() nb.tip <- length(phy$tip.label) nb.node <- phy$Nnode nbTotN <- nb.tip+nb.node sigmaMF <- 1 TsTemps <- dist.nodes(phy) TempsRacine <- TsTemps[(nb.tip+1),] IndicesMRCA <- mrca(phy, full=T) M <- matrix(NA, ncol=nbTotN, nrow=nbTotN) for (i in 1:nbTotN) { for (j in 1:nbTotN) { M[i,j] <- sigmaMF^2 * TempsRacine[IndicesMRCA[i,j]] } } # M = SigmaZ varAL <- M[-(1:nb.tip), 1:nb.tip] varAA <- M[-(1:nb.tip), -(1:nb.tip)] varLL <- M[(1:nb.tip), 1:nb.tip] invVarLL <- solve(varLL) UL <- rep(1, length=nb.tip) UA <- rep(1, length=nb.node) TL <- TempsRacine[1:nb.tip] TA <- TempsRacine[(nb.tip+1):(nb.tip+nb.node)] # IVL_Z <- invVarLL %*% x IVL_T <- invVarLL %*% TL IVL_U <- invVarLL %*% UL U_IVL_U <- t(UL) %*% IVL_U T_IVL_T <- t(TL) %*% IVL_T U_IVL_T <- t(UL) %*% IVL_T U_IVL_Z <- t(UL) %*% IVL_Z T_IVL_Z <- t(TL) %*% IVL_Z DeltaT <- TA - varAL %*% IVL_T DeltaU <- UA - varAL %*% IVL_U # Den <- U_IVL_U * T_IVL_T - U_IVL_T^2 Den <- as.numeric(Den) Mu_chap <- (U_IVL_U * T_IVL_Z - U_IVL_T * U_IVL_Z) / Den Mu_chap <- as.numeric(Mu_chap) Racine_chap <- (T_IVL_T * U_IVL_Z - U_IVL_T * T_IVL_Z) / Den Racine_chap <- as.numeric(Racine_chap) Anc_chap <- Mu_chap * DeltaT + Racine_chap * DeltaU + varAL %*% IVL_Z Anc_chap <- as.vector(Anc_chap) obj$ace <- Anc_chap names(obj$ace) <- (nb.tip + 1):(nb.tip + nb.node) obj$mu <- Mu_chap # if (CI) { Vec <- x - Racine_chap - Mu_chap * TL Num <- t(Vec) %*% invVarLL %*% Vec Num <- as.numeric(Num) sigma2_chap <- Num / (nb.tip-2) obj$sigma2 <- sigma2_chap se <- sqrt((varAA - varAL %*% invVarLL %*% t(varAL))[cbind(1:nb.node, 1:nb.node)]) se <- se * sqrt(sigma2_chap) tmp <- se * qt(0.025, df=nb.tip-2) obj$CI95 <- cbind(lower=obj$ace + tmp, upper=obj$ace - tmp) } obj } # theta = z0 glsOUv1 <- function (phy, x, alpha, CI=TRUE) { obj <- list() nb.tip <- length(phy$tip.label) nb.node <- phy$Nnode nbTotN <- nb.tip+nb.node sigmaMF <- 1 alphaM <- alpha nbTotN <- nb.tip+nb.node TsTemps <- dist.nodes(phy) TempsRacine <- TsTemps[(nb.tip+1),] IndicesMRCA <- mrca(phy, full=T) M <- matrix(NA, ncol=nbTotN, nrow=nbTotN) for (i in 1:nbTotN) { for (j in 1:nbTotN) { Tempsm <- TempsRacine[IndicesMRCA[i,j]] Tempsi <- TempsRacine[i] Tempsj <- TempsRacine[j] M[i,j] <- sigmaMF^2 * exp(-alphaM * (Tempsi+Tempsj-2*Tempsm)) * (1-exp(-2*alphaM * Tempsm)) / (2 * alphaM) } } # M = SigmaZ varAL <- M[-(1:nb.tip), 1:nb.tip] varAA <- M[-(1:nb.tip), -(1:nb.tip)] varLL <- M[(1:nb.tip), 1:nb.tip] invVarLL <- solve(varLL) UL <- rep(1, length=nb.tip) UA <- rep(1, length=nb.node) TL <- TempsRacine[1:nb.tip] TA <- TempsRacine[(nb.tip+1):(nb.tip+nb.node)] # IVL_Z <- invVarLL %*% x IVL_T <- invVarLL %*% TL IVL_U <- invVarLL %*% UL U_IVL_U <- t(UL) %*% IVL_U U_IVL_Z <- t(UL) %*% IVL_Z DeltaU <- UA - varAL %*% IVL_U # Racine_chap <- solve(U_IVL_U) %*% U_IVL_Z Racine_chap <- as.numeric(Racine_chap) Anc_chap <- Racine_chap * DeltaU + varAL %*% IVL_Z Anc_chap <- as.vector(Anc_chap) obj$ace <- Anc_chap names(obj$ace) <- (nb.tip + 1):(nb.tip + nb.node) # # vraisemblance # mL <- Racine_chap Num <- t(x-mL) %*% invVarLL %*% (x-mL) Num <- as.numeric(Num) sigma2_chap <- Num / (nb.tip-1) obj$sigma <- sqrt(sigma2_chap) VL <- sigma2_chap * varLL invVL <- invVarLL / sigma2_chap LVrais <- - t(x-mL) %*% invVL %*% (x-mL) /2 - nb.tip * log(2*pi)/2 - log(det(VL))/2 obj$LLik <- as.numeric(LVrais) # if (CI) { se <- sqrt((varAA - varAL %*% invVarLL %*% t(varAL))[cbind(1:nb.node, 1:nb.node)]) se <- se * sqrt(sigma2_chap) tmp <- se * qt(0.025, df=nb.tip-1) obj$CI95 <- cbind(lower=obj$ace + tmp, upper=obj$ace - tmp) } obj } # theta pas egal a z0 glsOUv2 <- function (phy, x, alpha, CI=TRUE) { obj <- list() nb.tip <- length(phy$tip.label) nb.node <- phy$Nnode nbTotN <- nb.tip+nb.node sigmaMF <- 1 nbTotN <- nb.tip+nb.node TsTemps <- dist.nodes(phy) TempsRacine <- TsTemps[(nb.tip+1),] IndicesMRCA <- mrca(phy, full=T) M <- matrix(NA, ncol=nbTotN, nrow=nbTotN) for (i in 1:nbTotN) { for (j in 1:nbTotN) { Tempsm <- TempsRacine[IndicesMRCA[i,j]] Tempsi <- TempsRacine[i] Tempsj <- TempsRacine[j] M[i,j] <- sigmaMF^2 * exp(-alpha * (Tempsi+Tempsj-2*Tempsm)) * (1-exp(-2*alpha * Tempsm)) / (2 * alpha) } } # M = SigmaZ varAL <- M[-(1:nb.tip), 1:nb.tip] varAA <- M[-(1:nb.tip), -(1:nb.tip)] varLL <- M[(1:nb.tip), 1:nb.tip] invVarLL <- solve(varLL) vecW <- exp(-alpha * TempsRacine) UL <- vecW[1:nb.tip] UA <- vecW[(nb.tip+1):(nb.tip+nb.node)] TL <- 1-UL TA <- 1-UA # # IVL_Z <- invVarLL %*% x IVL_T <- invVarLL %*% TL IVL_U <- invVarLL %*% UL U_IVL_U <- t(UL) %*% IVL_U T_IVL_T <- t(TL) %*% IVL_T U_IVL_T <- t(UL) %*% IVL_T U_IVL_Z <- t(UL) %*% IVL_Z T_IVL_Z <- t(TL) %*% IVL_Z DeltaT <- TA - varAL %*% IVL_T DeltaU <- UA - varAL %*% IVL_U # Den <- U_IVL_U * T_IVL_T - U_IVL_T^2 Den <- as.numeric(Den) Theta_chap <- (U_IVL_U * T_IVL_Z - U_IVL_T * U_IVL_Z) / Den Theta_chap <- as.numeric(Theta_chap) Racine_chap <- (T_IVL_T * U_IVL_Z - U_IVL_T * T_IVL_Z) / Den Racine_chap <- as.numeric(Racine_chap) Anc_chap <- Theta_chap * DeltaT + Racine_chap * DeltaU + varAL %*% IVL_Z Anc_chap <- as.vector(Anc_chap) obj$ace <- Anc_chap names(obj$ace) <- (nb.tip + 1):(nb.tip + nb.node) obj$theta <- Theta_chap # # vraisemblance # mL <- (Racine_chap * UL + Theta_chap * TL) Num <- t(x-mL) %*% invVarLL %*% (x-mL) Num <- as.numeric(Num) sigma2_chap <- Num / (nb.tip-2) obj$sigma <- sqrt(sigma2_chap) VL <- sigma2_chap * varLL invVL <- invVarLL / sigma2_chap LVrais <- - t(x-mL) %*% invVL %*% (x-mL) /2 - nb.tip * log(2*pi)/2 - log(det(VL))/2 obj$LLik <- as.numeric(LVrais) # if (CI) { se <- sqrt((varAA - varAL %*% invVarLL %*% t(varAL))[cbind(1:nb.node, 1:nb.node)]) se <- se * sqrt(sigma2_chap) tmp <- se * qt(0.025, df=nb.tip-2) obj$CI95 <- cbind(lower=obj$ace + tmp, upper=obj$ace - tmp) } obj } reconstruct <- function (x, phyInit, method = "ML", alpha = NULL, CI = TRUE) { if(!is.null(alpha)) { if(alpha<=0) stop("alpha has to be positive.") } if (!inherits(phyInit, "phylo")) stop("object \"phy\" is not of class \"phylo\"") if (is.null(phyInit$edge.length)) stop("tree has no branch lengths") nN <- phyInit$Nnode nT <- length(x) switch(method, ML = { Intern <- glsBM(phy=phyInit, x=x, CI=F)$ace Value <- c(x, Intern) Hessian <- getMLHessian(Value, phyInit) se <- sqrt(diag(solve(Hessian))) se <- se[-1] tmp <- se*qt(0.025, nN) CI95 <- cbind(lower=Intern+tmp, upper=Intern-tmp) }, REML={ minusLogLik <- function(sig2) { if (sig2 < 0) return(1e+100) V <- sig2 * vcv(phyInit) distval <- stats::mahalanobis(x, center = mu, cov = V) logdet <- sum(log(eigen(V, symmetric = TRUE, only.values = TRUE)$values)) (nT * log(2 * pi) + logdet + distval)/2 } Intern <- glsBM(phy=phyInit, x=x, CI=F)$ace Value <- c(x, Intern) GM <- Intern[1] mu <- rep(GM, nT) out <- nlm(minusLogLik, 1, hessian = FALSE) sigma2 <- out$estimate Hessian <- getREMLHessian(Value, phyInit, sigma2) se <- sqrt(diag(solve(Hessian))) tmp <- se*qt(0.025, nN) CI95 <- cbind(lower=Intern+tmp, upper=Intern-tmp) }, GLS = { result <- glsBM(phy=phyInit, x=x, CI=T) Intern <- result$ace CI95 <- result$CI95 }, GLS_ABM = { result <- glsABM(phy=phyInit, x=x, CI=T) Intern <- result$ace CI95 <- result$CI95 }, GLS_OUS = { if(is.null(alpha)) { funOpt1 <- function(alpha) { -glsOUv1(phy=phyInit, x=x, alpha, CI=F)$LLik } calOp <- optim(par=0.25, fn=funOpt1, method="Brent", lower=0.001, upper=1) if (calOp$convergence == 0) { alpha <- calOp$par } else { stop("Estimation error for alpha") } } result <- glsOUv1(phy=phyInit, x=x, alpha=alpha, CI=T) Intern <- result$ace CI95 <- result$CI95 }, GLS_OU = { if(is.null(alpha)) { funOpt2 <- function(alpha) { -glsOUv2(phy=phyInit, x=x, alpha, CI=F)$LLik } calOp <- optim(par=0.25, fn=funOpt2, method="Brent", lower=0.001, upper=1) if (calOp$convergence == 0) { alpha <- calOp$par } else { stop("Estimation error for alpha") } } result <- glsOUv2(phy=phyInit, x=x, alpha=alpha, CI=T) Intern <- result$ace CI95 <- result$CI95 } ) if (CI==TRUE) list(ace=Intern, CI95=CI95) else list(ace=Intern) } ape/R/ladderize.R0000644000175100001440000000252412604322731013327 0ustar hornikusers## ladderize.R (2015-10-04) ## Ladderize a Tree ## Copyright 2007-2015 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. ladderize <- function(phy, right = TRUE) { foo <- function(node, END, where) { start <- which(phy$edge[, 1] == node) end <- c(start[-1] - 1, END) size <- end - start + 1 desc <- phy$edge[start, 2] Nclade <- length(desc) n <- N[desc] o <- order(n, decreasing = right) newpos <- c(0, cumsum(size[o][-Nclade])) + where desc <- desc[o] end <- end[o] start <- start[o] neworder[newpos] <<- start for (i in 1:Nclade) if (desc[i] > nb.tip) foo(desc[i], end[i], newpos[i] + 1) } phy <- reorder(phy) # fix by Klaus (2015-10-04) nb.tip <- length(phy$tip.label) nb.node <- phy$Nnode nb.edge <- dim(phy$edge)[1] tmp <- reorder(phy, "postorder") N <- .C(node_depth, as.integer(nb.tip), as.integer(nb.node), as.integer(tmp$edge[, 1]), as.integer(tmp$edge[, 2]), as.integer(nb.edge), double(nb.tip + nb.node), 1L)[[6]] neworder <- integer(nb.edge) foo(nb.tip + 1, nb.edge, 1) phy$edge <- phy$edge[neworder, ] if (!is.null(phy$edge.length)) phy$edge.length <- phy$edge.length[neworder] phy } ape/R/subtrees.R0000644000175100001440000000207612465112403013220 0ustar hornikusers## subtrees.R (2008-04-14) ## All subtrees of a Phylogenetic Tree ## Copyright 2008 Damien de Vienne ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. subtrees<-function(tree, wait = FALSE) { N.tip<-Ntip (tree) N.node<-Nnode(tree) limit<-N.tip+N.node sub<-list(N.node) u<-0 for (k in (N.tip+1):limit) { u<-u+1 if (wait==TRUE) cat("wait... Node",u,"out of", N.node, "treated\n") fils<-NULL pere<-res <- k repeat { for (i in 1: length(pere)) fils<-c(fils, tree$edge[,2][tree$edge[,1]==pere[i]]) res<-c(res, fils) pere<-fils fils<-NULL if (length(pere)==0) break } len<-res[res>N.tip] if (u==1) { tree2<-tree len<-(N.tip+1):limit } else { len.tip<-res[res= "2.15.1") utils::globalVariables(c("loglik", "b.lin", "popsize")) mcmc.popsize <- function(tree, nstep, thinning = 1, burn.in = 0, progress.bar = TRUE, method.prior.changepoints = c("hierarchical", "fixed.lambda"), max.nodes = 30, lambda = 0.5, # "fixed.lambda" method.prior.changepoints gamma.shape = 0.5, gamma.scale = 2, # gamma distribution from which lambda is drawn (for "hierarchical" method) method.prior.heights = c("skyline", "constant", "custom"), prior.height.mean, prior.height.var) { method.prior.changepoints <- match.arg(method.prior.changepoints) method.prior.heights <- match.arg(method.prior.heights) ## Calculate skylineplot, coalescent intervals ## and estimated population sizes if (inherits(tree, "phylo")) { ci <- coalescent.intervals(tree) sk1 <- skyline(ci) } else if (class(tree) == "coalescentIntervals") { ci <- tree sk1 <- skyline(ci) } else stop("tree must be an object of class phylo or coalescentIntervals") ## consider possibility of more than one lineage ci$lineages <- ci$lineages[sk1$interval.length > 0] ci$interval.length <- ci$interval.length[sk1$interval.length > 0] data <- sk1$time <- sk1$time[sk1$interval.length > 0] sk1$population.size <- sk1$population.size[sk1$interval.length > 0] sk1$interval.length <- sk1$interval.length[sk1$interval.length > 0] ## constant prior for heights if (method.prior.heights == "constant") { prior.height.mean <- function(position) mean(sk1$population.size) prior.height.var <- function(position) (mean(sk1$population.size))^2 } ## skyline plot prior for heights if (method.prior.heights == "skyline") { TIME <- sk1$time numb.interv <- 10 prior.change.times <- abs((0:numb.interv) * max(TIME)/numb.interv) prior.height.mean.all <- prior.height.var.all <- vector(length = numb.interv) for (p.int in 1:(numb.interv)) { left <- p.int right <- p.int + 1 sample.pop <- sk1$population.size[sk1$time >= prior.change.times[left] & sk1$time <= prior.change.times[right]] while (length(sample.pop) < 10) { if (left > 1) left <- left - 1 if (right < length(prior.change.times)) right <- right + 1 sample.pop <- sk1$population.size[sk1$time >= prior.change.times[left] & sk1$time <= prior.change.times[right]] } prior.height.mean.all[p.int] <- sum(sample.pop)/length(sample.pop) prior.height.var.all[p.int] <- sum((sample.pop-prior.height.mean.all[p.int])^2)/(length(sample.pop) - 1) } prior.height.mean <- function(position) { j <- sum(prior.change.times <= position) if (j >= length(prior.height.mean.all)) j <- length(prior.height.mean.all) prior.mean <- prior.height.mean.all[j] prior.mean } prior.height.var <- function(position) { j <- sum(prior.change.times <= position) if (j >= length(prior.height.var.all)) j <- length(prior.height.var.all) prior.var <- prior.height.var.all[j] prior.var } } if (method.prior.heights == "custom") { if (missing(prior.height.mean) || missing(prior.height.var)) stop("custom priors not specified") } ## set prior prior <- vector(length = 4) prior[4] <- max.nodes ## set initial position of markov chain and likelihood pos <- c(0, max(data)) h <- c(rep(mean(sk1$population.size), 2)) b.lin <- choose(ci$lineages, 2) ## loglik <<- loglik.pop # modified by EP ## set lists for data count.it <- floor((nstep - burn.in)/thinning) save.pos <- save.h <- vector("list", count.it) save.loglik <- 1:count.it save.steptype <- 1:count.it save.accept <- 1:count.it ## calculate jump probabilities for given lambda of the prior if (method.prior.changepoints == "fixed.lambda") { prior[1] <- lambda jump.prob <- matrix(ncol = 4, nrow = prior[4] + 1) p <- dpois(0:prior[4], prior[1])/ppois(prior[4] + 1, prior[1]) bk <- c(p[-1]/p[-length(p)], 0) bk[bk > 1] <- 1 dk <- c(0, p[-length(p)]/p[-1]) dk[dk > 1] <- 1 mx <- max(bk + dk) bk <- bk/mx*0.9 dk <- dk/mx*0.9 bk[is.na(bk)] <- 0 # added dk[is.na(dk)] <- 0 # added jump.prob[, 3] <- bk jump.prob[, 4] <- dk jump.prob[1, 2] <- 0 jump.prob[1, 1] <- 1 - bk[1] - dk[1] jump.prob[-1, 1] <- jump.prob[-1, 2] <- (1 - jump.prob[-1, 3] - jump.prob[-1, 4])/2 } ## calculate starting loglik curloglik <- loglik.pop(data, pos, h, b.lin, sk1, ci) count.i <- 1 ## set progress bar if (progress.bar == TRUE) { dev.new(width = 3, height = 0.7) par(mar = c(0.5, 0.5, 2, 0.5)) plot(x = c(0, 0), y = c(0, 1), type = "l", xlim = c(0, 1), ylim = c(0, 1), main = "rjMCMC in progress", ylab = "", xlab = "", xaxs = "i", yaxs = "i", xaxt = "n", yaxt = "n") } ## BEGIN CALCULATION for (i in (1:nstep + 1)) { if (progress.bar == TRUE) { if (i %% 100 == 0) { z <- i/nstep zt <- (i - 100)/(nstep) polygon(c(zt, zt, z, z), c(1, 0, 0, 1), col = "black") } } ## calculate jump probabilities without given lamda if (method.prior.changepoints == "hierarchical") { prior[1] <- rgamma(1, shape = gamma.shape, scale = gamma.scale) jump.prob <- matrix(ncol = 4, nrow = prior[4] + 1) p <- dpois(0:prior[4], prior[1]) / ppois(prior[4] + 1, prior[1]) bk <- c(p[-1]/p[-length(p)], 0) bk[bk > 1] <- 1 dk <- c(0, p[-length(p)]/p[-1]) dk[dk > 1] <- 1 mx <- max(bk + dk) bk <- bk/mx*0.9 dk <- dk/mx*0.9 bk[is.na(bk)] <- 0 # added dk[is.na(dk)] <- 0 # added jump.prob[, 3] <- bk jump.prob[, 4] <- dk jump.prob[1, 2] <- 0 jump.prob[1, 1] <- 1 - bk[1] - dk[1] jump.prob[-1, 1] <- jump.prob[-1, 2] <- (1 - jump.prob[-1, 3] - jump.prob[-1, 4])/2 } ## determine what type of jump to make wh <- sample(1:4, 1, prob = jump.prob[length(h)-1, ]) if (i %% thinning == 0 & i > burn.in) save.steptype[[count.i]] <- wh if (wh == 1) { step <- ht.move(data, pos, h, curloglik, prior, b.lin, sk1, ci, prior.height.mean, prior.height.var) h <- step[[1]] curloglik <- step[[2]] if (i %% thinning == 0 & i > burn.in) { save.pos[[count.i]] <- pos save.h[[count.i]] <- h save.loglik[[count.i]] <- step[[2]] save.accept[[count.i]] <- step[[3]] } } else if (wh == 2) { step <- pos.move(data, pos, h, curloglik, b.lin, sk1, ci) pos <- step[[1]] curloglik <- step[[2]] if (i %% thinning == 0 & i > burn.in) { save.pos[[count.i]] <- pos save.h[[count.i]] <- h save.loglik[[count.i]] <- step[[2]] save.accept[[count.i]] <- step[[3]] } } else if (wh == 3) { step <- birth.step(data, pos, h, curloglik, prior, jump.prob, b.lin, sk1, ci, prior.height.mean, prior.height.var) pos <- step[[1]] h <- step[[2]] curloglik <- step[[3]] if (i %% thinning == 0 & i > burn.in) { save.pos[[count.i]] <- pos save.h[[count.i]] <- h save.loglik[[count.i]] <- step[[3]] save.accept[[count.i]] <- step[[4]] } } else { step <- death.step(data, pos, h, curloglik, prior, jump.prob, b.lin, sk1, ci, prior.height.mean, prior.height.var) pos <- step[[1]] h <- step[[2]] curloglik <- step[[3]] if (i %% thinning == 0 & i > burn.in) { save.pos[[count.i]] <- pos save.h[[count.i]] <- h save.loglik[[count.i]] <- step[[3]] save.accept[[count.i]] <- step[[4]] } } if (i %% thinning == 0 & i > burn.in) count.i <- count.i + 1 } if (progress.bar == TRUE) dev.off() list(pos = save.pos, h = save.h, loglik = save.loglik, steptype = save.steptype, accept = save.accept) } ## private functions ht.move <- function(data, pos, h, curloglik, prior, b.lin, sk1, ci, prior.height.mean, prior.height.var) { j <- sample(1:length(h), 1) prior.mean <- prior.height.mean(pos[j]) prior.var <- prior.height.var(pos[j]) prior[3] <- prior.mean/prior.var prior[2] <- (prior.mean^2)/prior.var newh <- h newh[j] <- h[j] * exp(runif(1, -0.5, 0.5)) newloglik <- loglik.pop(data, pos, newh, b.lin, sk1, ci) lr <- newloglik - curloglik ratio <- exp(lr + prior[2] * (log(newh[j]) - log(h[j])) - prior[3] * (newh[j] - h[j])) if (runif(1, 0, 1) < ratio) return(list(newh, newloglik, 1)) else return(list(h, curloglik, 0)) } pos.move <- function(data, pos, h, curloglik, b.lin, sk1, ci) { j <- if (length(pos) == 3) 2 else sample(2:(length(pos)-1), 1) newpos <- pos left <- pos[j - 1] right <- pos[j + 1] newpos[j] <- runif(1, left, right) newloglik <- loglik.pop(data, newpos, h, b.lin, sk1, ci) lr <- newloglik - curloglik ratio <- exp(lr) * (right - newpos[j])*(newpos[j]- left)/ (right - pos[j])/(pos[j] - left) if (runif(1, 0, 1) < ratio) return(list(newpos, newloglik, 1)) else return(list(pos, curloglik, 0)) } birth.step <- function(data, pos, h, curloglik, prior, jump.prob, b.lin, sk1, ci, prior.height.mean, prior.height.var) { newpos <- runif(1, 0, pos[length(pos)]) j <- sum(pos < newpos) left <- pos[j] right <- pos[j + 1] prior.mean <- prior.height.mean(pos[j]) prior.var <- prior.height.var(pos[j]) prior[3] <- prior.mean/prior.var prior[2] <- (prior.mean^2)/prior.var u <- runif(1, -0.5, 0.5) oldh <- (((newpos - left)/(right - left))*(h[j + 1] - h[j]) + h[j]) newheight <- oldh*(1 + u) ## ratio ## recall that prior = (lambda, alpha, beta, maxk) k <- length(pos) - 2 L <- max(pos) prior.logratio <- log(prior[1]) - log(k+1) + log((2*k + 3)*(2*k + 2)) - 2*log(L) + log(newpos - left) + log(right - newpos) - log(right - left) + prior[2]*log(prior[3]) - lgamma(prior[2]) + (prior[2] - 1) * log(newheight) + prior[3]*(newheight) proposal.ratio <- jump.prob[k + 2, 4]*L/jump.prob[k + 1, 3]/(k + 1) jacobian <- (((newpos - left)/(right - left))*(h[j + 1] - h[j])) + h[j] ## form new parameters newpos <- sort(c(pos, newpos)) newh <- c(h[1:j], newheight, h[(j + 1):length(h)]) newloglik <- loglik.pop(data, newpos, newh, b.lin, sk1, ci) lr <- newloglik - curloglik ratio <- exp(lr + prior.logratio) * proposal.ratio * jacobian if (runif(1, 0, 1) < ratio) return(list(newpos, newh, newloglik, 1)) else return(list(pos, h, curloglik, 0)) } death.step <- function(data, pos, h, curloglik, prior, jump.prob, b.lin, sk1, ci, prior.height.mean, prior.height.var) { ## position to drop if (length(pos) == 3) j <- 2 else j <- sample(2:(length(pos) - 1), 1) left <- pos[j - 1] right <- pos[j + 1] prior.mean <- prior.height.mean(pos[j]) prior.var <- prior.height.var(pos[j]) prior[3] <- prior.mean/prior.var prior[2] <- (prior.mean^2)/prior.var ## get new height h.left <- h[j - 1] h.right <- h[j + 1] newheight <- (((pos[j] - left)/(right - left))*(h.right - h.left) + h.left) ## ratio ## recall that prior = (lambda, alpha, beta, maxk) k <- length(pos) - 3 L <- max(pos) prior.logratio <- log(k+1) - log(prior[1]) - log(2*(k + 1)*(2*k + 3)) + 2*log(L) - log(pos[j] - left) - log(right - pos[j]) + log(right - left) - prior[2]*log(prior[3]) + lgamma(prior[2]) - (prior[2]-1) * log(newheight) - prior[3]*(newheight) proposal.ratio <- (k + 1)*jump.prob[k + 1, 3]/jump.prob[k + 2, 4]/L jacobian <- ((pos[j] - left)/(right - left))*(h[j + 1] - h[j - 1]) + h[j - 1] ## form new parameters newpos <- pos[-j] newh <- h[-j] newloglik <- loglik.pop(data, newpos, newh, b.lin, sk1, ci) lr <- newloglik - curloglik ratio <- exp(lr + prior.logratio) * proposal.ratio * (jacobian^(-1)) if (runif(1, 0, 1) < ratio) return(list(newpos, newh, newloglik, 1)) else return(list(pos, h, curloglik, 0)) } # calculate the log likelihood for a set of data loglik.pop <- function(time = sk1$time, pos = c(0, max(sk1$time)), h = mean(sk1$population.size), b = b.lin, sk1, ci) { data.time <- c(0, time) leftside <- 0 i <- 1 h1 <- c(h, h[length(h)]) pos1 <- c(pos, pos[length(pos)]) while (i < length(time)) { left.pos <- sum(data.time[i + 1] >= pos) right.pos <- left.pos + 1 h.mix <- (((data.time[i + 1] - pos[left.pos])/(pos[right.pos] - pos[left.pos]))*(h[right.pos] - h[left.pos])) + h[left.pos] leftside <- leftside + log(b[i]/h.mix) i <- i + 1 } rightside <- 0 time1 <- c(0, time) time.count <- 1 ## heigths of jumps jumps <- sort(c(time1, pos)) h.jumps <- jumps while (time.count <= length(jumps)) { left.pos <- sum(jumps[time.count] >= pos) right.pos <- left.pos + 1 h.jumps[time.count] <- (((jumps[time.count] - pos[left.pos])/(pos[right.pos] - pos[left.pos]))*(h[right.pos] - h[left.pos])) + h[left.pos] if (is.na(h.jumps[time.count])) h.jumps[time.count] <- h[left.pos] time.count <- time.count + 1 } ## Vector for lineages i <- 1 lineages.jumps <- jumps while (i <= length(jumps)) { lineages.jumps[i] <- sum(jumps[i] >= time) if (lineages.jumps[i] == 0) lineages.jumps[i] <- 1 i <- i + 1 } lineage <- ci$lineages[lineages.jumps] b1 <- choose(lineage, 2) ## Integral a <- (h.jumps[-1] - h.jumps[-length(h.jumps)])/(jumps[-1] - jumps[-length(jumps)]) c <- h.jumps[-1] - jumps[-1] * a area <- (1/a) * log(a*jumps[-1] + c) - (1/a)*log(a * jumps[-length(jumps)] + c) stepfunction <- (jumps[-1] - jumps[-length(jumps)])/h.jumps[-1] area[is.na(area)] <- stepfunction[is.na(area)] rightside <- sum(area * b1[-1]) loglik <- leftside - rightside loglik } ape/R/bind.tree.R0000644000175100001440000001711312465112403013234 0ustar hornikusers## bind.tree.R (2012-02-13) ## Bind Trees ## Copyright 2003-2012 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. `+.phylo` <- function(x, y) { p <- if (is.null(x$root.edge)) 0 else x$root.edge bind.tree(x, y, position = p) } bind.tree <- function(x, y, where = "root", position = 0, interactive = FALSE) { nx <- length(x$tip.label) mx <- x$Nnode ROOTx <- nx + 1L ny <- length(y$tip.label) my <- y$Nnode if (interactive) { lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv) if (lastPP$type != "phylogram" || lastPP$direction != "rightwards") stop("you must plot tree 'x' as a 'rightward phylogram'") cat("Click where you want to graft tree 'y'...\n") xy <- locator(1) d <- abs(xy$y - lastPP$yy) d[lastPP$xx - xy$x < 0] <- Inf where <- which.min(d) position <- lastPP$xx[where] - xy$x if (position < 0) position <- 0 cat("The following parameters are used:\n") cat(" where =", where, " position =", position, "\n") } else { if (where == 0 || where == "root") where <- ROOTx if (position < 0) position <- 0 if (where > nx + mx) stop("argument 'where' out of range for tree 'x'") } ## check whether both trees have branch lengths: switch(is.null(x$edge.length) + is.null(y$edge.length) + 1L, wbl <- TRUE, { x$edge.length <- y$edge.length <- NULL wbl <- FALSE warning("one tree has no branch lengths, they have been ignored") }, wbl <- FALSE) yHasNoRootEdge <- is.null(y$root.edge) xHasNoRootEdge <- is.null(x$root.edge) ## find the row of 'where' before renumbering if (where == ROOTx) case <- 1 else { i <- which(x$edge[, 2] == where) case <- if (where <= nx) 2 else 3 } ## case = 1 -> y is bound on the root of x ## case = 2 -> y is bound on a tip of x ## case = 3 -> y is bound on a node of x ## check that 'position' is correct if (position && wbl) { ### New in ape 3.0-1: this makes possible binding 'y' below ### a node of 'x' thus creating a new node in 'x' ### if (!wbl) ### stop("'position' is non-null but trees have no branch lengths") if (case == 1) { if (xHasNoRootEdge) stop("tree 'x' has no root edge") if (position > x$root.edge) stop("'position' is larger than x's root edge") } else { if (x$edge.length[i] < position) stop("'position' is larger than the branch length") } } ## the special case of substituting two tips: if (case == 2 && ny == 1 && !position) { x$tip.label[x$edge[i, 2]] <- y$tip.label if (wbl) x$edge.length[i] <- x$edge.length[i] + y$edge.length return(x) } x <- reorder(x) y <- reorder(y) ### because in all situations internal nodes need to be ### renumbered, they are changed to negatives first, and ### nodes eventually added will be numbered sequentially nodes <- x$edge > nx x$edge[nodes] <- -(x$edge[nodes] - nx) # -1, ..., -mx nodes <- y$edge > ny y$edge[nodes] <- -(y$edge[nodes] - ny + mx) # -(mx+1), ..., -(mx+my) ROOT <- -1L # may change later next.node <- -(mx + my) - 1L ## renumber now the tips in y: new.nx <- if (where <= nx && !position) nx - 1L else nx y$edge[!nodes] <- y$edge[!nodes] + new.nx ## if 'y' as a root edge, use it: if (!yHasNoRootEdge) { y$edge <- rbind(c(0, y$edge[1]), y$edge) ## ^ will be filled later next.node <- next.node - 1L if (wbl) y$edge.length <- c(y$root.edge, y$edge.length) } switch(case, { # case = 1 if (position) { x$root.edge <- x$root.edge - position x$edge <- rbind(c(next.node, x$edge[1]), x$edge) ROOT <- next.node if (wbl) x$edge.length <- c(position, x$edge.length) } if (yHasNoRootEdge) { j <- which(y$edge[, 1] == y$edge[1]) y$edge[j, 1] <- ROOT } else y$edge[1] <- ROOT x$edge <- rbind(x$edge, y$edge) if (wbl) x$edge.length <- c(x$edge.length, y$edge.length) }, { # case = 2 if (position) { x$edge[i, 2] <- next.node x$edge <- rbind(x$edge[1:i, ], c(next.node, where), x$edge[-(1:i), ]) if (wbl) { x$edge.length[i] <- x$edge.length[i] - position x$edge.length <- c(x$edge.length[1:i], position, x$edge.length[-(1:i)]) } i <- i + 1L if (yHasNoRootEdge) { j <- which(y$edge[, 1] == y$edge[1]) y$edge[j, 1] <- x$edge[i, 1] } else y$edge[1] <- x$edge[i, 1] } else { if (yHasNoRootEdge) x$edge[i, 2] <- y$edge[1] else { ## the root edge of y is fused with the terminal edge of x if (wbl) y$edge.length[1] <- y$edge.length[1] + x$edge.length[i] y$edge[1] <- x$edge[i, 1] ## delete i-th edge in x: x$edge <- x$edge[-i, ] if (wbl) x$edge.length <- x$edge.length[-i] i <- i - 1L } x$tip.label <- x$tip.label[-where] ## renumber the tips that need to: ii <- which(x$edge[, 2] > where & x$edge[, 2] <= nx) x$edge[ii, 2] <- x$edge[ii, 2] - 1L } x$edge <- rbind(x$edge[1:i, ], y$edge, x$edge[-(1:i), ]) if (wbl) x$edge.length <- c(x$edge.length[1:i], y$edge.length, x$edge.length[-(1:i)]) }, { # case = 3 if (position) { if (yHasNoRootEdge) { j <- which(y$edge[, 1] == y$edge[1]) y$edge[j, 1] <- next.node } else y$edge[1] <- next.node x$edge <- rbind(x$edge[1:i, ], c(next.node, x$edge[i, 2]), x$edge[-(1:i), ]) x$edge[i, 2] <- next.node if (wbl) { x$edge.length[i] <- x$edge.length[i] - position x$edge.length <- c(x$edge.length[1:i], position, x$edge.length[-(1:i)]) } i <- i + 1L } else { if (yHasNoRootEdge) { j <- which(y$edge[, 1] == y$edge[1]) y$edge[j, 1] <- x$edge[i, 2] } else y$edge[1] <- x$edge[i, 2] } x$edge <- rbind(x$edge[1:i, ], y$edge, x$edge[-(1:i), ]) if (wbl) x$edge.length <- c(x$edge.length[1:i], y$edge.length, x$edge.length[-(1:i)]) }) x$tip.label <- c(x$tip.label, y$tip.label) if (is.null(x$node.label)) { if (!is.null(y$node.label)) x$node.label <- c(rep(NA, mx), y$node.label) } else { x$node.label <- if (is.null(y$node.label)) c(x$node.label, rep(NA, my)) else c(x$node.label, y$node.label) } n <- length(x$tip.label) x$Nnode <- dim(x$edge)[1] + 1L - n ## update the node labels before renumbering (this adds NA for ## the added nodes, and drops the label for those deleted) if (!is.null(x$node.label)) x$node.label <- x$node.label[sort(-unique(x$edge[, 1]))] ## renumber nodes: newNb <- integer(x$Nnode) newNb[-ROOT] <- n + 1L sndcol <- x$edge[, 2] < 0 ## executed from right to left, so newNb is modified before x$edge: x$edge[sndcol, 2] <- newNb[-x$edge[sndcol, 2]] <- n + 2:x$Nnode x$edge[, 1] <- newNb[-x$edge[, 1]] if (!is.null(x$node.label)) x$node.label <- x$node.label[order(newNb[newNb > 0])] x } ape/R/chronoMPL.R0000644000175100001440000000315013002744140013214 0ustar hornikusers## chronoMPL.R (2007-08-29) ## Molecular Dating with Mean Path Lengths ## Copyright 2007 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. chronoMPL <- function(phy, se = TRUE, test = TRUE) { if (!is.binary.phylo(phy)) stop("the tree is not dichotomous.") n <- length(phy$tip.label) m <- phy$Nnode N <- dim(phy$edge)[1] obj <- reorder(phy, "postorder") ndesc <- .C(node_depth, as.integer(n), as.integer(m), as.integer(obj$edge[, 1]), as.integer(obj$edge[, 2]), as.integer(N), double(n + m), 1L)[[6]] s <- numeric(n + m) # sum of path lengths if (se) ss <- s if (test) Pval <- numeric(m) for (i in seq(1, N - 1, 2)) { j <- i + 1 a <- obj$edge[i, 2] b <- obj$edge[j, 2] o <- obj$edge[i, 1] A <- s[a] + ndesc[a]*obj$edge.length[i] B <- s[b] + ndesc[b]*obj$edge.length[j] s[o] <- A + B if (se) ss[o] <- ss[a] + ndesc[a]^2 * obj$edge.length[i] + ss[b] + ndesc[b]^2 * obj$edge.length[j] if (test) { z <- abs(A/ndesc[a] - B/ndesc[b]) tmp <- (ss[a] + ndesc[a]^2 * obj$edge.length[i])/ndesc[a]^2 tmp <- tmp + (ss[b] + ndesc[b]^2 * obj$edge.length[j])/ndesc[b]^2 z <- z/sqrt(tmp) Pval[o - n] <- 2*pnorm(z, lower.tail = FALSE) } } node.age <- s/ndesc phy$edge.length <- node.age[phy$edge[, 1]] - node.age[phy$edge[, 2]] if (se) attr(phy, "stderr") <- sqrt(ss[-(1:n)]/ndesc[-(1:n)]^2) if (test) attr(phy, "Pval") <- Pval phy } ape/R/is.ultrametric.R0000644000175100001440000000331012775152333014333 0ustar hornikusers## is.ultrametric.R (2016-10-04) ## Test if a Tree is Ultrametric ## Copyright 2003-2016 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. is.ultrametric <- function(phy, ...) UseMethod("is.ultrametric") ## the main driver code (n = number of tips): .is.ultrametric_ape <- function(phy, tol, option, n) { if (is.null(phy$edge.length)) stop("the tree has no branch lengths") e1 <- phy$edge[, 1] e2 <- phy$edge[, 2] EL <- phy$edge.length ## xx: distance from a node or a tip to the root xx <- numeric(n + phy$Nnode) ## the following must start at the root and follow the ## edges contiguously; so the tree must be either in cladewise ## order (or in pruningwise but the for loop must start from ## the bottom of the edge matrix) for (i in seq_len(length(e1))) xx[e2[i]] <- xx[e1[i]] + EL[i] xx.tip <- xx[1:n] crit <- switch(option, { mn <- min(xx.tip) mx <- max(xx.tip) (mx - mn)/mx }, var(xx.tip)) isTRUE(all.equal.numeric(crit, 0, tolerance = tol)) } is.ultrametric.phylo <- function(phy, tol = .Machine$double.eps^0.5, option = 1, ...) { phy <- reorder.phylo(phy) .is.ultrametric_ape(phy, tol, option, length(phy$tip.label)) } is.ultrametric.multiPhylo <- function(phy, tol = .Machine$double.eps^0.5, option = 1, ...) { phy <- reorder.multiPhylo(phy) labs <- attr(phy, "TipLabel") if (is.null(labs)) sapply(phy, is.ultrametric.phylo, tol = tol, option = option) else sapply(phy, .is.ultrametric_ape, tol = tol, option = option, n = length(labs)) } ape/R/read.nexus.R0000644000175100001440000002265012677434234013456 0ustar hornikusers## read.nexus.R (2014-10-20) ## Read Tree File in Nexus Format ## Copyright 2003-2014 Emmanuel Paradis and 2010 Klaus Schliep ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. .treeBuildWithTokens <- function(x) { phy <- .Call(treeBuildWithTokens, x) dim(phy[[1]]) <- c(length(phy[[1]])/2, 2) nms <- c("edge", "edge.length", "Nnode", "node.label", "root.edge") if (length(phy) == 4) nms <- nms[-5] names(phy) <- nms if (all(phy$node.label == "")) phy$node.label <- NULL class(phy) <- "phylo" attr(phy, "order") <- "cladewise" phy } clado.build <- function(tp) { add.internal <- function() { edge[j, 1L] <<- current.node node <<- node + 1L edge[j, 2L] <<- current.node <<- node index[node] <<- j # set index j <<- j + 1L } add.terminal <- function() { edge[j, 1L] <<- current.node edge[j, 2L] <<- tip index[tip] <<- j # set index tip.label[tip] <<- tpc[k] k <<- k + 1L tip <<- tip + 1L j <<- j + 1L } go.down <- function() { l <- index[current.node] node.label[current.node - nb.tip] <<- tpc[k] k <<- k + 1L current.node <<- edge[l, 1L] } if (!length(grep(",", tp))) { obj <- list(edge = matrix(c(2L, 1L), 1L, 2L), Nnode = 1L) tp <- unlist(strsplit(tp, "[\\(\\);]")) obj$tip.label <- tp[2] if (tp[3] != "") obj$node.label <- tp[3] class(obj) <- "phylo" return(obj) } tsp <- unlist(strsplit(tp, NULL)) tp <- gsub(")", ")NA", tp) tp <- gsub(" ", "", tp) tpc <- unlist(strsplit(tp, "[\\(\\),;]")) tpc <- tpc[tpc != ""] skeleton <- tsp[tsp == "(" | tsp == ")" | tsp == "," | tsp == ";"] nsk <- length(skeleton) nb.node <- length(skeleton[skeleton == ")"]) nb.tip <- length(skeleton[skeleton == ","]) + 1L ## We will assume there is an edge at the root; ## if so, it will be removed and put in a vector nb.edge <- nb.node + nb.tip node.label <- character(nb.node) tip.label <- character(nb.tip) edge <- matrix(NA_integer_, nb.edge, 2L) current.node <- node <- nb.tip + 1L # node number edge[nb.edge, 1L] <- 0L # see comment above edge[nb.edge, 2L] <- node # index <- numeric(nb.edge + 1L) index[node] <- nb.edge ## j: index of the line number of edge ## k: index of the line number of tpc ## tip: tip number j <- k <- tip <- 1L for (i in 2:nsk) { if (skeleton[i] == "(") add.internal() # add an internal branch (on top) if (skeleton[i] == ",") { if (skeleton[i - 1] != ")") add.terminal() # add a terminal branch } if (skeleton[i] == ")") { if (skeleton[i - 1] == ",") { # add a terminal branch and go down one level add.terminal() go.down() } if (skeleton[i - 1] == ")") go.down() # go down one level } } edge <- edge[-nb.edge, ] obj <- list(edge = edge, tip.label = tip.label, Nnode = nb.node, node.label = node.label) obj$node.label <- if (all(obj$node.label == "NA", na.rm = TRUE)) NULL else gsub("^NA", "", obj$node.label) class(obj) <- "phylo" attr(obj, "order") <- "cladewise" obj } read.nexus <- function(file, tree.names = NULL) { X <- scan(file = file, what = "", sep = "\n", quiet = TRUE) ## remove all comments ## (this might not work if there are square brackets within the comments) LEFT <- grep("\\[", X) RIGHT <- grep("\\]", X) if (length(LEFT)) { # in case there are no comments at all w <- LEFT == RIGHT if (any(w)) { # in case all comments use at least 2 lines s <- LEFT[w] X[s] <- gsub("\\[[^]]*\\]", "", X[s]) ## The above regexp was quite tough to find: it makes ## possible to delete series of comments on the same line: ## ...[...]xxx[...]... ## without deleting the "xxx". This regexp is in three parts: ## \\[ [^]]* \\] ## where [^]]* means "any character, except "]", repeated zero ## or more times" (note that the ']' is not escaped here). ## The previous version was: ## X[s] <- gsub("\\[.*\\]", "", X[s]) ## which deleted the "xxx". (EP 2008-06-24) } w <- !w if (any(w)) { s <- LEFT[w] X[s] <- gsub("\\[.*", "", X[s]) sb <- RIGHT[w] X[sb] <- gsub(".*\\]", "", X[sb]) if (any(s < sb - 1)) X <- X[-unlist(mapply(":", (s + 1), (sb - 1)))] } } endblock <- grep("END;|ENDBLOCK;", X, ignore.case = TRUE) semico <- grep(";", X) i1 <- grep("BEGIN TREES;", X, ignore.case = TRUE) i2 <- grep("TRANSLATE", X, ignore.case = TRUE) translation <- if (length(i2) == 1 && i2 > i1) TRUE else FALSE if (translation) { end <- semico[semico > i2][1] x <- X[(i2 + 1):end] # assumes there's a 'new line' after "TRANSLATE" ## x <- gsub("TRANSLATE", "", x, ignore.case = TRUE) x <- unlist(strsplit(x, "[,; \t]")) x <- x[nzchar(x)] TRANS <- matrix(x, ncol = 2, byrow = TRUE) TRANS[, 2] <- gsub("['\"]", "", TRANS[, 2]) n <- dim(TRANS)[1] } start <- if (translation) semico[semico > i2][1] + 1 else i1 + 1 # semico[semico > i1][1] ## fix done on 2014-08-25 end <- endblock[endblock > i1][1] - 1 tree <- X[start:end] rm(X) ## check whether there are empty lines from the above manips: tree <- tree[tree != ""] semico <- grep(";", tree) Ntree <- length(semico) # provisional -- some ";" may actually mark end of commands ## are some trees on several lines? ## -- this actually 'packs' all characters ending with a ";" in a single string -- if (Ntree == 1 && length(tree) > 1) STRING <- paste(tree, collapse = "") else { if (any(diff(semico) != 1)) { STRING <- character(Ntree) s <- c(1, semico[-Ntree] + 1) j <- mapply(":", s, semico) if (is.list(j)) { for (i in 1:Ntree) STRING[i] <- paste(tree[j[[i]]], collapse = "") } else { for (i in 1:Ntree) STRING[i] <- paste(tree[j[, i]], collapse = "") } } else STRING <- tree } rm(tree) ## exclude the possible command lines ending with ";": STRING <- STRING[grep("^[[:blank:]]*tree.*= *", STRING, ignore.case = TRUE)] Ntree <- length(STRING) # update Ntree ## get the tree names: nms.trees <- sub(" *= *.*", "", STRING) # only the first occurence of "=" nms.trees <- sub("^[[:blank:]]*tree[[:blank:]\\*]*", "", nms.trees, ignore.case = TRUE) # fix by Graham Gower (2014-10-20) STRING <- sub("^.*= *", "", STRING) # delete title and 'TREE' command with 'sub' STRING <- gsub(" ", "", STRING) # delete all white spaces colon <- grep(":", STRING) if (!length(colon)) { trees <- lapply(STRING, clado.build) } else if (length(colon) == Ntree) { trees <- if (translation) lapply(STRING, .treeBuildWithTokens) else lapply(STRING, tree.build) } else { trees <- vector("list", Ntree) trees[colon] <- lapply(STRING[colon], tree.build) nocolon <- (1:Ntree)[!1:Ntree %in% colon] trees[nocolon] <- lapply(STRING[nocolon], clado.build) if (translation) { for (i in 1:Ntree) { tr <- trees[[i]] for (j in 1:n) { ind <- which(tr$tip.label[j] == TRANS[, 1]) tr$tip.label[j] <- TRANS[ind, 2] } if (!is.null(tr$node.label)) { for (j in 1:length(tr$node.label)) { ind <- which(tr$node.label[j] == TRANS[, 1]) tr$node.label[j] <- TRANS[ind, 2] } } trees[[i]] <- tr } translation <- FALSE } } for (i in 1:Ntree) { tr <- trees[[i]] ## Check here that the root edge is not incorrectly represented ## in the object of class "phylo" by simply checking that there ## is a bifurcation at the root if (!translation) n <- length(tr$tip.label) ROOT <- n + 1 if (sum(tr$edge[, 1] == ROOT) == 1 && dim(tr$edge)[1] > 1) { stop(paste("The tree has apparently singleton node(s): cannot read tree file.\n Reading NEXUS file aborted at tree no.", i, sep = "")) } } if (Ntree == 1) { trees <- trees[[1]] if (translation) { trees$tip.label <- if (length(colon)) TRANS[, 2] else TRANS[, 2][as.numeric(trees$tip.label)] } } else { if (!is.null(tree.names)) names(trees) <- tree.names if (translation) { if (length(colon) == Ntree) # .treeBuildWithTokens() was used attr(trees, "TipLabel") <- TRANS[, 2] else { # reassign the tip labels then compress for (i in 1:Ntree) trees[[i]]$tip.label <- TRANS[, 2][as.numeric(trees[[i]]$tip.label)] trees <- .compressTipLabel(trees) } } class(trees) <- "multiPhylo" if (!all(nms.trees == "")) names(trees) <- nms.trees } trees } ape/R/nodelabels.R0000644000175100001440000002621012556705133013501 0ustar hornikusers## nodelabels.R (2014-07-31) ## Labelling Trees ## Copyright 2004-2014 Emmanuel Paradis, 2006 Ben Bolker, and 2006 Jim Lemon ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. ## from JL: ## floating.pie() from plotrix with two changes: ## (1) aspect ratio fixed, so pies will appear circular ## (`radius' is the radius in user coordinates along the x axis); ## (2) zero values allowed (but not negative). floating.pie.asp <- function(xpos, ypos, x, edges = 200, radius = 1, col = NULL, startpos = 0, ...) { u <- par("usr") user.asp <- diff(u[3:4])/diff(u[1:2]) p <- par("pin") inches.asp <- p[2]/p[1] asp <- user.asp/inches.asp if (!is.numeric(x) || any(is.na(x) | x < 0)) stop("floating.pie: x values must be non-negative") x <- c(0, cumsum(x)/sum(x)) dx <- diff(x) nx <- length(dx) col <- if (is.null(col)) rainbow(nx) else rep_len(col, nx) ## next a fix from Klaus to avoid a "3-o'clock" segment on pies with ## only one proportion equal to 1: if (length(i <- which(dx == 1))) { symbols(xpos, ypos, circles = radius, inches = FALSE, add = TRUE, fg = par("fg"), bg = col[i]) # suggested by Liam } else { bc <- 2 * pi * (x[1:nx] + dx/2) + startpos for (i in seq_len(nx)) { n <- max(2, floor(edges * dx[i])) t2p <- 2 * pi * seq(x[i], x[i + 1], length = n) + startpos xc <- c(cos(t2p) * radius + xpos, xpos) yc <- c(sin(t2p) * radius*asp + ypos, ypos) polygon(xc, yc, col = col[i], ...) } } } BOTHlabels <- function(text, sel, XX, YY, adj, frame, pch, thermo, pie, piecol, col, bg, horiz, width, height, ...) { if (missing(text)) text <- NULL if (length(adj) == 1) adj <- c(adj, 0.5) if (is.null(text) && is.null(pch) && is.null(thermo) && is.null(pie)) text <- as.character(sel) frame <- match.arg(frame, c("rect", "circle", "none")) args <- list(...) CEX <- if ("cex" %in% names(args)) args$cex else par("cex") if (frame != "none" && !is.null(text)) { if (frame == "rect") { width <- strwidth(text, units = "inches", cex = CEX) height <- strheight(text, units = "inches", cex = CEX) if ("srt" %in% names(args)) { args$srt <- args$srt %% 360 # just in case srt >= 360 if (args$srt == 90 || args$srt == 270) { tmp <- width width <- height height <- tmp } else if (args$srt != 0) warning("only right angle rotation of frame is supported;\n try `frame = \"n\"' instead.\n") } width <- xinch(width) height <- yinch(height) xl <- XX - width*adj[1] - xinch(0.03) xr <- xl + width + xinch(0.03) yb <- YY - height*adj[2] - yinch(0.02) yt <- yb + height + yinch(0.05) rect(xl, yb, xr, yt, col = bg) } if (frame == "circle") { radii <- 0.8*apply(cbind(strheight(text, units = "inches", cex = CEX), strwidth(text, units = "inches", cex = CEX)), 1, max) symbols(XX, YY, circles = radii, inches = max(radii), add = TRUE, bg = bg) } } if (!is.null(thermo)) { parusr <- par("usr") if (is.null(width)) { width <- CEX * (parusr[2] - parusr[1]) width <- if (horiz) width/15 else width/40 } if (is.null(height)) { height <- CEX * (parusr[4] - parusr[3]) height <- if (horiz) height/40 else height/15 } if (is.vector(thermo)) thermo <- cbind(thermo, 1 - thermo) thermo <- if (horiz) width * thermo else height * thermo if (is.null(piecol)) piecol <- rainbow(ncol(thermo)) xl <- XX - width/2 + adj[1] - 0.5 # added 'adj' from Janet Young (2009-09-30) xr <- xl + width yb <- YY - height/2 + adj[2] - 0.5 yt <- yb + height if (horiz) { ## draw the first rectangle: rect(xl, yb, xl + thermo[, 1], yt, border = NA, col = piecol[1]) for (i in 2:ncol(thermo)) rect(xl + rowSums(thermo[, 1:(i - 1), drop = FALSE]), yb, xl + rowSums(thermo[, 1:i]), yt, border = NA, col = piecol[i]) } else { ## draw the first rectangle: rect(xl, yb, xr, yb + thermo[, 1], border = NA, col = piecol[1]) for (i in 2:ncol(thermo)) rect(xl, yb + rowSums(thermo[, 1:(i - 1), drop = FALSE]), xr, yb + rowSums(thermo[, 1:i]), border = NA, col = piecol[i]) } ## check for NA's before drawing the borders s <- apply(thermo, 1, function(xx) any(is.na(xx))) xl[s] <- xr[s] <- NA rect(xl, yb, xr, yt, border = "black") if (!horiz) { segments(xl, YY, xl - width/5, YY) segments(xr, YY, xr + width/5, YY) } } ## from BB: if (!is.null(pie)) { if (is.vector(pie)) pie <- cbind(pie, 1 - pie) xrad <- CEX * diff(par("usr")[1:2]) / 50 xrad <- rep(xrad, length(sel)) XX <- XX + adj[1] - 0.5 YY <- YY + adj[2] - 0.5 for (i in seq_along(sel)) { if (any(is.na(pie[i, ]))) next floating.pie.asp(XX[i], YY[i], pie[i, ], radius = xrad[i], col = piecol) } } if (!is.null(text)) text(XX, YY, text, adj = adj, col = col, ...) if (!is.null(pch)) points(XX + adj[1] - 0.5, YY + adj[2] - 0.5, pch = pch, col = col, bg = bg, ...) } nodelabels <- function(text, node, adj = c(0.5, 0.5), frame = "rect", pch = NULL, thermo = NULL, pie = NULL, piecol = NULL, col = "black", bg = "lightblue", horiz = FALSE, width = NULL, height = NULL, ...) { lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv) if (missing(node)) node <- (lastPP$Ntip + 1):length(lastPP$xx) XX <- lastPP$xx[node] YY <- lastPP$yy[node] BOTHlabels(text, node, XX, YY, adj, frame, pch, thermo, pie, piecol, col, bg, horiz, width, height, ...) } tiplabels <- function(text, tip, adj = c(0.5, 0.5), frame = "rect", pch = NULL, thermo = NULL, pie = NULL, piecol = NULL, col = "black", bg = "yellow", horiz = FALSE, width = NULL, height = NULL, ...) { lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv) if (missing(tip)) tip <- 1:lastPP$Ntip XX <- lastPP$xx[tip] YY <- lastPP$yy[tip] BOTHlabels(text, tip, XX, YY, adj, frame, pch, thermo, pie, piecol, col, bg, horiz, width, height, ...) } edgelabels <- function(text, edge, adj = c(0.5, 0.5), frame = "rect", pch = NULL, thermo = NULL, pie = NULL, piecol = NULL, col = "black", bg = "lightgreen", horiz = FALSE, width = NULL, height = NULL, date = NULL, ...) { lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv) if (missing(edge)) { sel <- 1:dim(lastPP$edge)[1] subedge <- lastPP$edge } else { sel <- edge subedge <- lastPP$edge[sel, , drop = FALSE] } xx <- lastPP$xx yy <- lastPP$yy if (lastPP$type == "phylogram") { if (lastPP$direction %in% c("rightwards", "leftwards")) { XX <- (xx[subedge[, 1]] + xx[subedge[, 2]]) / 2 YY <- yy[subedge[, 2]] } else { XX <- xx[subedge[, 2]] YY <- (yy[subedge[, 1]] + yy[subedge[, 2]]) / 2 } } else { if (lastPP$type == "fan") { # fix by Klaus Schliep (2015-07-31) r <- sqrt(xx^2 + yy^2) tmp <- (r[subedge[, 2]] + r[subedge[, 1]]) / (r[subedge[, 2]] * 2) XX <- xx[subedge[, 2]] * tmp YY <- yy[subedge[, 2]] * tmp } else { XX <- (xx[subedge[, 1]] + xx[subedge[, 2]]) / 2 YY <- (yy[subedge[, 1]] + yy[subedge[, 2]]) / 2 } } ## suggestion by Rob Lanfear: if (!is.null(date)) XX[] <- max(lastPP$xx) - date BOTHlabels(text, sel, XX, YY, adj, frame, pch, thermo, pie, piecol, col, bg, horiz, width, height, ...) } edges <- function(nodes0, nodes1, arrows = 0, type = "classical", ...) { type <- match.arg(type, c("classical", "triangle", "harpoon")) lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv) ## we do the recycling if necessary: if (length(nodes0) != length(nodes1)) { tmp <- cbind(nodes0, nodes1) nodes0 <- tmp[, 1] nodes1 <- tmp[, 2] } x0 <- lastPP$xx[nodes0] y0 <- lastPP$yy[nodes0] x1 <- lastPP$xx[nodes1] y1 <- lastPP$yy[nodes1] if (arrows) if (type == "classical") arrows(x0, y0, x1, y1, code = arrows, ...) else fancyarrows(x0, y0, x1, y1, code = arrows, type = type, ...) else segments(x0, y0, x1, y1, ...) } fancyarrows <- function(x0, y0, x1, y1, length = 0.25, angle = 30, code = 2, col = par("fg"), lty = par("lty"), lwd = par("lwd"), type = "triangle", ...) { foo <- function(x0, y0, x1, y1) { ## important to correct with these parameters cause ## the coordinate system will likely not be Cartesian pin <- par("pin") usr <- par("usr") A1 <- pin[1]/diff(usr[1:2]) A2 <- pin[2]/diff(usr[3:4]) x0 <- x0 * A1 y0 <- y0 * A2 x1 <- x1 * A1 y1 <- y1 * A2 atan2(y1 - y0, x1 - x0) } arrow.triangle <- function(x, y) { beta <- alpha - angle/2 xa <- xinch(length * cos(beta)) + x ya <- yinch(length * sin(beta)) + y beta <- beta + angle xb <- xinch(length * cos(beta)) + x yb <- yinch(length * sin(beta)) + y n <- length(x) col <- rep(col, length.out = n) for (i in 1:n) polygon(c(x[i], xa[i], xb[i]), c(y[i], ya[i], yb[i]), col = col[i], border = col[i]) list((xa + xb)/2, (ya + yb)/2) } arrow.harpoon <- function(x, y) { beta <- alpha - angle/2 xa <- xinch(length * cos(beta)) + x ya <- yinch(length * sin(beta)) + y beta <- alpha + angle/2 xb <- xinch(length * cos(beta)) + x yb <- yinch(length * sin(beta)) + y xc <- x/2 + (xa + xb)/4 yc <- y/2 + (ya + yb)/4 n <- length(x) col <- rep(col, length.out = n) for (i in 1:n) polygon(c(x[i], xa[i], xc[i], xb[i]), c(y[i], ya[i], yc[i], yb[i]), col = col[i], border = col[i]) list(xc, yc) } type <- match.arg(type, c("triangle", "harpoon")) angle <- pi*angle/180 # degree -> radian alpha <- foo(x0, y0, x1, y1) # angle of segment with x-axis ## alpha is in [-pi, pi] FUN <- if (type == "triangle") arrow.triangle else arrow.harpoon XY0 <- if (code == 1 || code == 3) FUN(x0, y0) else list(x0, y0) if (code >= 2) { alpha <- (alpha + pi) %% (2 * pi) XY1 <- FUN(x1, y1) } else XY1 <- list(x1, y1) segments(XY0[[1]], XY0[[2]], XY1[[1]], XY1[[2]], col = col, lty = lty, lwd = lwd, ...) } ape/R/vcv.phylo.R0000644000175100001440000000407212465112403013312 0ustar hornikusers## vcv.phylo.R (2012-02-21) ## Phylogenetic Variance-Covariance or Correlation Matrix ## Copyright 2002-2012 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. vcv <- function(phy, ...) UseMethod("vcv") vcv.phylo <- function(phy, model = "Brownian", corr = FALSE, ...) { if (is.null(phy$edge.length)) stop("the tree has no branch lengths") pp <- prop.part(phy) phy <- reorder(phy, "postorder") n <- length(phy$tip.label) e1 <- phy$edge[, 1] e2 <- phy$edge[, 2] EL <- phy$edge.length ## xx: vecteur donnant la distance d'un noeud ## ou d'un tip a partir de la racine ## (same than in is.ultrametric) xx <- numeric(n + phy$Nnode) vcv <- matrix(0, n, n) ## the loop below starts from the bottom of the edge matrix, so ## from the root for (i in length(e1):1) { var.cur.node <- xx[e1[i]] xx[e2[i]] <- var.cur.node + EL[i] # sets the variance j <- i - 1L while (e1[j] == e1[i] && j > 0) { left <- if (e2[j] > n) pp[[e2[j] - n]] else e2[j] right <- if (e2[i] > n) pp[[e2[i] - n]] else e2[i] vcv[left, right] <- vcv[right, left] <- var.cur.node # sets the covariance j <- j - 1L } } diag.elts <- 1 + 0:(n - 1)*(n + 1) vcv[diag.elts] <- xx[1:n] if (corr) { ## This is inspired from the code of cov2cor (2005-09-08): Is <- sqrt(1 / vcv[diag.elts]) ## below 'vcv[] <- ...' has been changed to 'vcv <- ...' ## which seems to be twice faster for n = 1000 and ## respects the additional attributes (2012-02-21): vcv <- Is * vcv * rep(Is, each = n) vcv[diag.elts] <- 1 } dimnames(vcv)[1:2] <- list(phy$tip.label) vcv } vcv.corPhyl <- function(phy, corr = FALSE, ...) { labels <- attr(phy, "tree")$tip.label dummy.df <- data.frame(seq_along(labels), row.names = labels) res <- corMatrix(Initialize.corPhyl(phy, dummy.df), corr = corr) dimnames(res) <- list(labels, labels) res } ape/R/phydataplot.R0000644000175100001440000001600212622146734013720 0ustar hornikusers## phydataplot.R (2015-07-16) ## Annotate Phylogenies ## Copyright 2014-2015 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. polar2rect <- function(r, angle) list(x = r * cos(angle), y = r * sin(angle)) rect2polar <- function(x, y) list(r = sqrt(x^2 + y^2), angle = atan2(y, x)) .matchDataPhylo <- function(x, phy) { msg <- "'x' has no (row)names: data are assumed to be in the same order than the tips of the tree" labs <- phy$tip.label if (is.vector(x)) { # also for lists if (is.null(names(x))) warning(msg) else x <- x[labs] } else { if (is.null(rownames(x))) warning(msg) else x <- x[labs, ] } x } ring <- function(x, phy, style = "ring", offset = 1, ...) { style <- match.arg(style, c("ring", "segments", "arrows")) x <- .matchDataPhylo(x, phy) lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv) n <- lastPP$Ntip one2n <- seq_len(n) tmp <- rect2polar(lastPP$xx[one2n], lastPP$yy[one2n]) theta <- tmp$angle r0 <- max(tmp$r) + offset r1 <- r0 + x s0 <- polar2rect(rep.int(r0, 100L), seq(0, 2*pi, length.out = 100L)) s1 <- polar2rect(r1, theta) switch(style, ring = { if (length(x) < n) x <- rep_len(x, n) dx <- dim(x) if (is.null(dx)) dim(x) <- dx <- c(n, 1L) nc <- dx[2] col <- list(...)$col if (is.null(col)) col <- "grey" if (nc == 1) { col <- rep_len(col, n) } else { colvar <- col col <- rep(col[1], n) } iangle <- min(diff(sort(theta))) iangle2 <- iangle / 2 for (i in one2n) { R <- rep(r0, 100) THETA <- seq(theta[i] - iangle2, theta[i] + iangle2, length.out = 100) xy1 <- polar2rect(R, THETA) xy2 <- polar2rect(R + x[i, 1], THETA) polygon(c(xy1$x, rev(xy2$x)), c(xy1$y, rev(xy2$y)), col = col[i], border = NA) if (nc > 1) { for (j in 2:nc) { xy1 <- xy2 xy2 <- polar2rect(R + sum(x[i, 1:j]), THETA) polygon(c(xy1$x, rev(xy2$x)), c(xy1$y, rev(xy2$y)), col = colvar[j], border = NA) } } } ##polypath(c(s0$x, NA, s0$x), c(s0$y, NA, s1$y), rule = "evenodd", ## border = 1, col = "transparent") }, segments = { s0 <- polar2rect(rep.int(r0, n), theta) segments(s0$x, s0$y, s1$x, s1$y, ...) }, arrows = { s0 <- polar2rect(rep.int(r0, n), theta) fancyarrows(s0$x, s0$y, s1$x, s1$y, ...) }) } phydataplot <- function(x, phy, style = "bars", offset = 1, scaling = 1, continuous = FALSE, width = NULL, legend = "below", funcol = rainbow, ...) { style <- match.arg(style, c("bars", "segments", "image", "arrows", "boxplot", "dotchart", "mosaic")) lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv) circular <- if (lastPP$type %in% c("radial", "fan")) TRUE else FALSE n <- length(phy$tip.label) one2n <- seq_len(n) x <- .matchDataPhylo(x, phy) if (scaling != 1) x <- if (is.list(x)) lapply(x, "*", scaling) else scaling * x if (!circular) { if (lastPP$direction != "rightwards") stop("for the moment, only rightwards trees are supported") x0 <- max(lastPP$xx[one2n]) + offset if (style %in% c("bars", "segments", "arrows")) x1 <- x0 + x y1 <- lastPP$yy[one2n] if (style %in% c("bars", "image", "boxplot", "dotchart", "mosaic")) { o <- order(y1) x <- if (style == "image") x[o, o] else if (is.vector(x)) x[o] else x[o, ] } } else { if (style %in% c("image", "boxplot", "dotchart", "mosaic")) stop(paste(dQuote(style), "not implemented with circular trees")) } switch(style, bars = { if (circular) stop("style = \"bars\" not implemented with circular trees; see function 'ring'") if (!is.null(dim(x))) x <- t(x) barplot(x, width = 1, add = TRUE, horiz = TRUE, offset = x0, axes = FALSE, axisnames = FALSE, space = c(0.5, rep(0, n - 1)), ...) px <- pretty(c(0, x)) axis(1, px + x0, labels = px / scaling, line = 1) }, segments = { if (circular) ring(x, phy, style, offset, ...) else segments(x0, y1, x1, y1, ...) }, image = { if (inherits(x, "DNAbin")) stop('object of class "DNAbin" not supported: use type="mosaic"') x1 <- seq(x0, lastPP$x.lim[2], length.out = n) image(x1, y1[o], x, add = TRUE, ...) mtext(phy$tip.label[o], 1, 1, at = x1, font = lastPP$font, cex = lastPP$cex, col = lastPP$tip.color) }, arrows = { if (circular) ring(x, phy, style, offset, ...) else fancyarrows(rep(x0, length(y1)), y1, x1, y1, ...) }, boxplot = { if (is.matrix(x)) x <- t(x) o <- boxplot(x, plot = FALSE) mini <- min(o$stats) maxi <- max(o$stats) if (length(o$out)) { # in case there is no outlier mini <- min(o$out, mini) maxi <- max(o$out, maxi) } px <- pretty(c(mini, maxi)) x0 <- x0 - mini o$stats <- o$stats + x0 o$out <- o$out + x0 bxp(o, horizontal = TRUE, add = TRUE, axes = FALSE, ...) axis(1, px + x0, labels = px / scaling, line = 1) }, dotchart = { mini <- min(x) maxi <- max(x) x0 <- x0 - mini segments(mini + x0, one2n, maxi + x0, one2n, lty = 3, col = "gray") points(x + x0, 1:n, ...) px <- pretty(x) axis(1, px + x0, labels = px / scaling, line = 1) }, mosaic = { p <- ncol(x) if (is.null(width)) { x1 <- lastPP$x.lim[2] width <- (x1 - x0)/p } else x1 <- x0 + width * p xx <- seq(x0, x1, width) xl <- rep(xx[-length(xx)], each = n) yb <- rep(one2n - 0.5, p) xr <- xl + width yt <- yb + 1 if (!is.null(labx <- colnames(x))) text(xx[-length(xx)] + width/2, max(yt), labx, adj = c(0.5, -0.5), xpd = TRUE) if (continuous) { nux <- if (is.logical(continuous)) 10 else continuous sq <- seq(min(x), max(x), length.out = nux + 1) x <- .bincode(x, sq, FALSE, TRUE) lgd <- paste0("[", sq[-length(sq)], "-", sq[-1], ")") } else { if (is.raw(x)) x <- toupper(as.character(x)) # for DNAbin objects nux <- length(ux <- unique.default(x)) x <- match(x, ux) lgd <- as.character(ux) } co <- funcol(nux) rect(xl, yb, xr, yt, col = co[x], xpd = TRUE, ...) if (legend == "below") legend((x0 + x1)/2, -yinch(0.1), lgd, pch = 22, pt.bg = co, pt.cex = 2, bty = "n", xjust = 0.5, yjust = 0.5, horiz = TRUE, xpd = TRUE) else legend(x1, n, lgd, pch = 22, pt.bg = co, pt.cex = 2, bty = "n", yjust = 1, xpd = TRUE) }) } ape/R/varcomp.R0000644000175100001440000000222212465112403013024 0ustar hornikusers## varcomp.R (2004-10-29) ## Variance Component of Mixed-Effect Linear Model ## Copyright 2004 Julien Dutheil ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. varcomp <- function(x, scale = FALSE, cum = FALSE) { if (!("lme" %in% class(x))) stop("Object \"x\" is not of class \"lme\"") res <- seq(along = x$modelStruct$reStruct) var <- vector(length = length(res) + 1) for(i in res) { var[length(var) - i] <- attr(summary(x$modelStruct$reStruct[[i]]),"stdDev")[1]*x$sigma } var[length(var)] <- x$sigma var <- var^2 if(scale) var <- var/sum(var) if(cum) var <- cumsum(var) names(var) <- c(rev(names(x$modelStruct$reStruct)), "Within") class(var) <- "varcomp" return(var) } plot.varcomp <- function(x, xlab = "Levels", ylab = "Variance", type = "b", ...) { if (!("varcomp" %in% class(x))) stop("Object \"x\" is not of class \"varcomp\"") return(xyplot(x ~ ordered(names(x), levels=rev(names(x))), xlab=xlab, ylab=ylab, type=type, ...)) } # For debuging: #data(carnivora) #m <- lme(log10(SW) ~ 1, random = ~ 1|Order/SuperFamily/Family/Genus, data=carnivora) #v <- varcomp(m,T,T) #plot(v) ape/R/chronos.R0000644000175100001440000004206612465112403013042 0ustar hornikusers## chronos.R (2014-05-15) ## Molecular Dating With Penalized and Maximum Likelihood ## Copyright 2013-2014 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. .chronos.ctrl <- list(tol = 1e-8, iter.max = 1e4, eval.max = 1e4, nb.rate.cat = 10, dual.iter.max = 20) makeChronosCalib <- function(phy, node = "root", age.min = 1, age.max = age.min, interactive = FALSE, soft.bounds = FALSE) { n <- Ntip(phy) if (interactive) { plot(phy) cat("Click close to a node and enter the ages (right-click to exit)\n\n") node <- integer() age.min <- age.max <- numeric() repeat { ans <- identify(phy, quiet = TRUE) if (is.null(ans)) break NODE <- ans$nodes nodelabels(node = NODE, col = "white", bg = "blue") cat("constraints for node ", NODE, sep = "") cat("\n youngest age: ") AGE.MIN <- as.numeric(readLines(n = 1)) cat(" oldest age (ENTER if not applicable): ") AGE.MAX <- as.numeric(readLines(n = 1)) node <- c(node, NODE) age.min <- c(age.min, AGE.MIN) age.max <- c(age.max, AGE.MAX) } s <- is.na(age.max) if (any(s)) age.max[s] <- age.min[s] } else { if (identical(node, "root")) node <- n + 1L } if (any(node <= n)) stop("node numbers should be greater than the number of tips") diff.age <- which(age.max < age.min) if (length(diff.age)) { msg <- "'old age' less than 'young age' for node" if (length(diff.age) > 1) msg <- paste(msg, "s", sep = "") stop(paste(msg, paste(node[diff.age], collapse = ", "))) } data.frame(node, age.min, age.max, soft.bounds = soft.bounds) } chronos.control <- function(...) { dots <- list(...) x <- .chronos.ctrl if (length(dots)) { chk.nms <- names(dots) %in% names(x) if (any(!chk.nms)) { warning("some control parameter names do not match: they were ignored") dots <- dots[chk.nms] } x[names(dots)] <- dots } x } chronos <- function(phy, lambda = 1, model = "correlated", quiet = FALSE, calibration = makeChronosCalib(phy), control = chronos.control()) { model <- match.arg(tolower(model), c("correlated", "relaxed", "discrete")) n <- Ntip(phy) ROOT <- n + 1L m <- phy$Nnode el <- phy$edge.length if (any(el < 0)) stop("some branch lengths are negative") e1 <- phy$edge[, 1L] e2 <- phy$edge[, 2L] N <- length(e1) TIPS <- 1:n EDGES <- 1:N tol <- control$tol node <- calibration$node age.min <- calibration$age.min age.max <- calibration$age.max if (model == "correlated") { ### `basal' contains the indices of the basal edges ### (ie, linked to the root): basal <- which(e1 == ROOT) Nbasal <- length(basal) ### 'ind1' contains the index of all nonbasal edges, and 'ind2' the ### index of the edges where these edges come from (ie, they contain ### pairs of contiguous edges), eg: ### ___b___ ind1 ind2 ### | | || | ### ___a___| | b || a | ### | | c || a | ### |___c___ | || | ind1 <- EDGES[-basal] ind2 <- match(e1[EDGES[-basal]], e2) } age <- numeric(n + m) ### This bit sets 'ini.time' and should result in no negative branch lengths if (!quiet) cat("\nSetting initial dates...\n") seq.nod <- .Call(seq_root2tip, phy$edge, n, phy$Nnode) ii <- 1L repeat { ini.time <- age ini.time[ROOT:(n + m)] <- NA ini.time[node] <- if (is.null(age.max)) age.min else runif(length(node), age.min, age.max) # (age.min + age.max) / 2 ## if no age given for the root, find one approximately: if (is.na(ini.time[ROOT])) ini.time[ROOT] <- if (is.null(age.max)) 3 * max(age.min) else 3 * max(age.max) ISnotNA.ALL <- unlist(lapply(seq.nod, function(x) sum(!is.na(ini.time[x])))) o <- order(ISnotNA.ALL, decreasing = TRUE) for (y in seq.nod[o]) { ISNA <- is.na(ini.time[y]) if (any(ISNA)) { i <- 2L # we know the 1st value is not NA, so we start at the 2nd one while (i <= length(y)) { if (ISNA[i]) { # we stop at the next NA j <- i + 1L while (ISNA[j]) j <- j + 1L # look for the next non-NA nb.val <- j - i by <- (ini.time[y[i - 1L]] - ini.time[y[j]]) / (nb.val + 1) ini.time[y[i:(j - 1L)]] <- ini.time[y[i - 1L]] - by * seq_len(nb.val) i <- j + 1L } else i <- i + 1L } } } if (all(ini.time[e1] - ini.time[e2] >= 0)) break ii <- ii + 1L if (ii > 1000) stop("cannot find reasonable starting dates after 1000 tries: maybe you need to adjust the calibration dates") } ### 'ini.time' set #ini.time[ROOT:(n+m)] <- branching.times(chr.dis) ## ini.time[ROOT:(n+m)] <- ini.time[ROOT:(n+m)] + rnorm(m, 0, 5) #print(ini.time) ### Setting 'ini.rate' ini.rate <- el/(ini.time[e1] - ini.time[e2]) if (model == "discrete") { Nb.rates <- control$nb.rate.cat minmax <- range(ini.rate) if (Nb.rates == 1) { ini.rate <- sum(minmax)/2 } else { inc <- diff(minmax)/Nb.rates ini.rate <- seq(minmax[1] + inc/2, minmax[2] - inc/2, inc) ini.freq <- rep(1/Nb.rates, Nb.rates - 1) lower.freq <- rep(0, Nb.rates - 1) upper.freq <- rep(1, Nb.rates - 1) } } else Nb.rates <- N ## 'ini.rate' set ### Setting bounds for the node ages ## `unknown.ages' will contain the index of the nodes of unknown age: unknown.ages <- 1:m + n ## initialize vectors for all nodes: lower.age <- rep(tol, m) upper.age <- rep(1/tol, m) lower.age[node - n] <- age.min upper.age[node - n] <- age.max ## find nodes known within an interval: ii <- which(age.min != age.max) ## drop them from 'node' since they will be estimated: if (length(ii)) { node <- node[-ii] if (length(node)) age[node] <- age.min[-ii] # update 'age' } else age[node] <- age.min ## finally adjust the 3 vectors: if (length(node)) { unknown.ages <- unknown.ages[n - node] # 'n - node' is simplification for '-(node - n)' lower.age <- lower.age[n - node] upper.age <- upper.age[n - node] } ### Bounds for the node ages set ## 'known.ages' contains the index of all nodes ## (internal and terminal) of known age: known.ages <- c(TIPS, node) ## the bounds for the rates: lower.rate <- rep(tol, Nb.rates) upper.rate <- rep(100 - tol, Nb.rates) # needs to be adjusted to higher values? ### Gradient degree_node <- tabulate(phy$edge) eta_i <- degree_node[e1] eta_i[e2 <= n] <- 1L ## eta_i[i] is the number of contiguous branches for branch 'i' ## use of a list of indices is slightly faster than an incidence matrix ## and takes much less memory (60 Kb vs. 8 Mb for n = 500) X <- vector("list", N) for (i in EDGES) { j <- integer() if (e1[i] != ROOT) j <- c(j, which(e2 == e1[i])) if (e2[i] >= n) j <- c(j, which(e1 == e2[i])) X[[i]] <- j } ## X is a list whose i-th element gives the indices of the branches ## that are contiguous to branch 'i' ## D_ki and A_ki are defined in the SI of the paper D_ki <- match(unknown.ages, e2) A_ki <- lapply(unknown.ages, function(x) which(x == e1)) gradient.poisson <- function(rate, node.time) { age[unknown.ages] <- node.time real.edge.length <- age[e1] - age[e2] ## gradient for the rates: gr <- el/rate - real.edge.length ## gradient for the dates: tmp <- el/real.edge.length - rate tmp2 <- tmp[D_ki] tmp2[is.na(tmp2)] <- 0 gr.dates <- sapply(A_ki, function(x) sum(tmp[x])) - tmp2 c(gr, gr.dates) } ## gradient of the penalized lik (must be multiplied by -1 before calling nlminb) gradient <- switch(model, "correlated" = function(rate, node.time) { gr <- gradient.poisson(rate, node.time) #if (all(gr == 0)) return(gr) ## contribution of the penalty for the rates: gr[RATE] <- gr[RATE] - lambda * 2 * (eta_i * rate - sapply(X, function(x) sum(rate[x]))) ## the contribution of the root variance term: if (Nbasal == 2) { # the simpler formulae if there's a basal dichotomy i <- basal[1] j <- basal[2] gr[i] <- gr[i] - lambda * (rate[i] - rate[j]) gr[j] <- gr[j] - lambda * (rate[j] - rate[i]) } else { # the general case for (i in 1:Nbasal) j <- basal[i] gr[j] <- gr[j] - lambda*2*(rate[j]*(1 - 1/Nbasal) - sum(rate[basal[-i]])/Nbasal)/(Nbasal - 1) } gr }, "relaxed" = function(rate, node.time) { gr <- gradient.poisson(rate, node.time) #if (all(gr == 0)) return(gr) ## contribution of the penalty for the rates: mean.rate <- mean(rate) ## rank(rate)/Nb.rates is the same than ecdf(rate)(rate) but faster gr[RATE] <- gr[RATE] + lambda*2*dgamma(rate, mean.rate)*(rank(rate)/Nb.rates - pgamma(rate, mean.rate)) gr }, "discrete" = NULL) log.lik.poisson <- function(rate, node.time) { age[unknown.ages] <- node.time real.edge.length <- age[e1] - age[e2] if (isTRUE(any(real.edge.length < 0))) return(-1e100) B <- rate * real.edge.length sum(el * log(B) - B - lfactorial(el)) } ### penalized log-likelihood penal.loglik <- switch(model, "correlated" = function(rate, node.time) { loglik <- log.lik.poisson(rate, node.time) if (!is.finite(loglik)) return(-1e100) loglik - lambda * (sum((rate[ind1] - rate[ind2])^2) + var(rate[basal])) }, "relaxed" = function(rate, node.time) { loglik <- log.lik.poisson(rate, node.time) if (!is.finite(loglik)) return(-1e100) mu <- mean(rate) ## loglik - lambda * sum((1:N/N - pbeta(sort(rate), mu/(1 + mu), 1))^2) # avec loi beta ## loglik - lambda * sum((1:N/N - pcauchy(sort(rate)))^2) # avec loi Cauchy loglik - lambda * sum((1:N/N - pgamma(sort(rate), mean(rate)))^2) # avec loi Gamma }, "discrete" = if (Nb.rates == 1) function(rate, node.time) log.lik.poisson(rate, node.time) else function(rate, node.time, freq) { if (isTRUE(sum(freq) > 1)) return(-1e100) rate.freq <- sum(c(freq, 1 - sum(freq)) * rate) log.lik.poisson(rate.freq, node.time) }) opt.ctrl <- list(eval.max = control$eval.max, iter.max = control$iter.max) ## the following capitalized vectors give the indices of ## the parameters once they are concatenated in 'p' RATE <- 1:Nb.rates AGE <- Nb.rates + 1:length(unknown.ages) if (model == "discrete") { if (Nb.rates == 1) { start.para <- c(ini.rate, ini.time[unknown.ages]) f <- function(p) -penal.loglik(p[RATE], p[AGE]) g <- NULL LOW <- c(lower.rate, lower.age) UP <- c(upper.rate, upper.age) } else { FREQ <- length(RATE) + length(AGE) + 1:(Nb.rates - 1) start.para <- c(ini.rate, ini.time[unknown.ages], ini.freq) f <- function(p) -penal.loglik(p[RATE], p[AGE], p[FREQ]) g <- NULL LOW <- c(lower.rate, lower.age, lower.freq) UP <- c(upper.rate, upper.age, upper.freq) } } else { start.para <- c(ini.rate, ini.time[unknown.ages]) f <- function(p) -penal.loglik(p[RATE], p[AGE]) g <- function(p) -gradient(p[RATE], p[AGE]) LOW <- c(lower.rate, lower.age) UP <- c(upper.rate, upper.age) } k <- length(LOW) # number of free parameters if (!quiet) cat("Fitting in progress... get a first set of estimates\n") out <- nlminb(start.para, f, g, control = opt.ctrl, lower = LOW, upper = UP) if (model == "discrete") { if (Nb.rates == 1) { f.rates <- function(p) -penal.loglik(p, current.ages) f.ages <- function(p) -penal.loglik(current.rates, p) } else { f.rates <- function(p) -penal.loglik(p, current.ages, current.freqs) f.ages <- function(p) -penal.loglik(current.rates, p, current.freqs) f.freqs <- function(p) -penal.loglik(current.rates, current.ages, p) g.freqs <- NULL } g.rates <- NULL g.ages <- NULL } else { f.rates <- function(p) -penal.loglik(p, current.ages) g.rates <- function(p) -gradient(p, current.ages)[RATE] f.ages <- function(p) -penal.loglik(current.rates, p) g.ages <- function(p) -gradient(current.rates, p)[AGE] } current.ploglik <- -out$objective current.rates <- out$par[RATE] current.ages <- out$par[AGE] if (model == "discrete" && Nb.rates > 1) current.freqs <- out$par[FREQ] dual.iter.max <- control$dual.iter.max i <- 0L if (!quiet) cat(" Penalised log-lik =", current.ploglik, "\n") repeat { if (dual.iter.max < 1) break if (!quiet) cat("Optimising rates...") out.rates <- nlminb(current.rates, f.rates, g.rates,# h.rates, control = list(eval.max = 1000, iter.max = 1000, step.min = 1e-8, step.max = .1), lower = lower.rate, upper = upper.rate) new.rates <- out.rates$par if (-out.rates$objective > current.ploglik) current.rates <- new.rates if (model == "discrete" && Nb.rates > 1) { if (!quiet) cat(" frequencies...") out.freqs <- nlminb(current.freqs, f.freqs, control = list(eval.max = 1000, iter.max = 1000, step.min = .001, step.max = .5), lower = lower.freq, upper = upper.freq) new.freqs <- out.freqs$par } if (!quiet) cat(" dates...") out.ages <- nlminb(current.ages, f.ages, g.ages,# h.ages, control = list(eval.max = 1000, iter.max = 1000, step.min = .001, step.max = 100), lower = lower.age, upper = upper.age) new.ploglik <- -out.ages$objective if (!quiet) cat("", current.ploglik, "\n") if (new.ploglik - current.ploglik > 1e-6 && i <= dual.iter.max) { current.ploglik <- new.ploglik current.rates <- new.rates current.ages <- out.ages$par if (model == "discrete" && Nb.rates > 1) current.freqs <- new.freqs out <- out.ages i <- i + 1L } else break } if (!quiet) cat("\nDone.\n") # browser() if (model == "discrete") { rate.freq <- if (Nb.rates == 1) current.rates else mean(c(current.freqs, 1 - sum(current.freqs)) * current.rates) logLik <- log.lik.poisson(rate.freq, current.ages) PHIIC <- list(logLik = logLik, k = k, PHIIC = - 2 * logLik + 2 * k) } else { logLik <- log.lik.poisson(current.rates, current.ages) PHI <- switch(model, "correlated" = (current.rates[ind1] - current.rates[ind2])^2 + var(current.rates[basal]), "relaxed" = (1:N/N - pgamma(sort(current.rates), mean(current.rates)))^2) # avec loi Gamma PHIIC <- list(logLik = logLik, k = k, lambda = lambda, PHIIC = - 2 * logLik + 2 * k + lambda * svd(PHI)$d) } attr(phy, "call") <- match.call() attr(phy, "ploglik") <- -out$objective attr(phy, "rates") <- current.rates #out$par[EDGES] if (model == "discrete" && Nb.rates > 1) attr(phy, "frequencies") <- current.freqs attr(phy, "message") <- out$message attr(phy, "PHIIC") <- PHIIC age[unknown.ages] <- current.ages #out$par[-EDGES] phy$edge.length <- age[e1] - age[e2] class(phy) <- c("chronos", class(phy)) phy } print.chronos <- function(x, ...) { cat("\n Chronogram\n\n") cat("Call: ") print(attr(x, "call")) cat("\n") NextMethod("print") } ape/R/mantel.test.R0000644000175100001440000000246512465112403013624 0ustar hornikusers## mantel.test.R (2012-03-16) ## Mantel Test for Similarity of Two Matrices ## Copyright 2002-2011 Ben Bolker and Julien Claude ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. perm.rowscols <- function(m1, n) { s <- sample(1:n) m1[s, s] } ### calculate the Mantel z-statistic for two square matrices m1 and m2 mant.zstat <- function(m1, m2) sum(lower.triang(m1 * m2)) lower.triang <- function(m) { if (diff(dim(m))) print("Warning: non-square matrix") m[col(m) <= row(m)] } mantel.test <- function(m1, m2, nperm = 999, graph = FALSE, alternative = "two.sided", ...) { alternative <- match.arg(alternative, c("two.sided", "less", "greater")) n <- nrow(m1) realz <- mant.zstat(m1, m2) nullstats <- replicate(nperm, mant.zstat(m1, perm.rowscols(m2, n))) pval <- switch(alternative, "two.sided" = 2 * min(sum(nullstats >= realz), sum(nullstats <= realz)), "less" = sum(nullstats <= realz), "greater" = sum(nullstats >= realz)) pval <- (pval + 1) / (nperm + 1) # 'realz' is included in 'nullstats' if (graph) { plot(density(nullstats), type = "l", ...) abline(v = realz) } list(z.stat = realz, p = pval, alternative = alternative) } ape/R/multi2di.R0000644000175100001440000001257113000662652013120 0ustar hornikusers## multi2di.R (2016-10-16) ## Collapse or Resolve Multichotomies ## Copyright 2005-2016 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. multi2di <- function(phy, ...) UseMethod("multi2di") .multi2di_ape <- function(phy, random, n) { ## n: number of tips of phy degree <- tabulate(phy$edge[, 1]) target <- which(degree > 2) if (!length(target)) return(phy) nb.edge <- dim(phy$edge)[1] nextnode <- n + phy$Nnode + 1L new.edge <- edge2delete <- NULL wbl <- FALSE if (!is.null(phy$edge.length)) { wbl <- TRUE new.edge.length <- NULL } for (node in target) { ind <- which(phy$edge[, 1] == node) N <- length(ind) desc <- phy$edge[ind, 2] if (random) { ## if we shuffle the descendants, we need to eventually ## reorder the corresponding branch lenghts (see below) ## so we store the result of sample() tmp <- sample(length(desc)) desc <- desc[tmp] res <- rtree(N)$edge } else { res <- matrix(0L, 2*N - 2, 2) res[, 1] <- N + rep(1:(N - 1), each = 2) res[, 2] <- N + rep(2:N, each = 2) res[seq(1, by = 2, length.out = N - 1), 2] <- 1:(N - 1) res[length(res)] <- N } if (wbl) { ## keep the branch lengths coming from `node' el <- numeric(dim(res)[1]) # initialized with 0's el[res[, 2] <= N] <- if (random) phy$edge.length[ind][tmp] else phy$edge.length[ind] } ## now substitute the nodes in `res' ## `node' stays at the "root" of these new ## edges whereas their "tips" are `desc' Nodes <- c(node, nextnode:(nextnode + N - 3L)) res[, 1] <- Nodes[res[, 1] - N] tmp <- res[, 2] > N res[tmp, 2] <- Nodes[res[tmp, 2] - N] res[!tmp, 2] <- desc[res[!tmp, 2]] new.edge <- rbind(new.edge, res) edge2delete <- c(edge2delete, ind) if (wbl) new.edge.length <- c(new.edge.length, el) nextnode <- nextnode + N - 2L phy$Nnode <- phy$Nnode + N - 2L } phy$edge <- rbind(phy$edge[-edge2delete, ], new.edge) if (wbl) phy$edge.length <- c(phy$edge.length[-edge2delete], new.edge.length) if (!is.null(attr(phy, "order"))) attr(phy, "order") <- NULL if (!is.null(phy$node.label)) phy$node.label <- c(phy$node.label, rep("", phy$Nnode - length(phy$node.label))) phy <- reorder(phy) ## the node numbers are not in increasing order in edge[, 2]: this ## will confuse drop.tip and other functions (root), so renumber them newNb <- integer(phy$Nnode) newNb[1] <- n + 1L sndcol <- phy$edge[, 2] > n ## reorder node labels before changing edge: if (!is.null(phy$node.label)) { o <- 1 + rank(phy$edge[sndcol, 2]) ## the root's label is not changed: phy$node.label <- phy$node.label[c(1, o)] } ## executed from right to left, so newNb is modified before phy$edge: phy$edge[sndcol, 2] <- newNb[phy$edge[sndcol, 2] - n] <- n + 2:phy$Nnode phy$edge[, 1] <- newNb[phy$edge[, 1] - n] phy } multi2di.phylo <- function (phy, random = TRUE, ...) .multi2di_ape(phy, random, length(phy$tip.label)) multi2di.multiPhylo <- function(phy, random = TRUE, ...) { labs <- attr(phy, "TipLabel") oc <- oldClass(phy) class(phy) <- NULL if (is.null(labs)) phy <- lapply(phy, multi2di.phylo, random = random) else { phy <- lapply(phy, .multi2di_ape, random = random, n = length(labs)) attr(phy, "TipLabel") <- labs } class(phy) <- oc phy } di2multi <- function(phy, ...) UseMethod("di2multi") .di2multi_ape <- function(phy, tol = 1e-8, ntips) { if (is.null(phy$edge.length)) stop("the tree has no branch length") ## We select only the internal branches which are ## significantly small: ind <- which(phy$edge.length < tol & phy$edge[, 2] > ntips) n <- length(ind) if (!n) return(phy) ## recursive function to `propagate' node #'s in case ## there is a series of consecutive edges to remove foo <- function(ancestor, des2del) { wh <- which(phy$edge[, 1] == des2del) for (k in wh) { if (phy$edge[k, 2] %in% node2del) foo(ancestor, phy$edge[k, 2]) else phy$edge[k, 1] <<- ancestor } } node2del <- phy$edge[ind, 2] anc <- phy$edge[ind, 1] for (i in 1:n) { if (anc[i] %in% node2del) next foo(anc[i], node2del[i]) } phy$edge <- phy$edge[-ind, ] phy$edge.length <- phy$edge.length[-ind] phy$Nnode <- phy$Nnode - n ## Now we renumber the nodes that need to be: sel <- phy$edge > min(node2del) for (i in which(sel)) phy$edge[i] <- phy$edge[i] - sum(node2del < phy$edge[i]) if (!is.null(phy$node.label)) phy$node.label <- phy$node.label[-(node2del - ntips)] phy } di2multi.phylo <- function (phy, tol = 1e-08, ...) .di2multi_ape(phy, tol, length(phy$tip.label)) di2multi.multiPhylo <- function(phy, tol = 1e-08, ...) { labs <- attr(phy, "TipLabel") oc <- oldClass(phy) class(phy) <- NULL if (is.null(labs)) phy <- lapply(phy, di2multi.phylo, tol = tol) else { phy <- lapply(phy, .di2multi_ape, tol = tol, ntips = length(labs)) attr(phy, "TipLabel") <- labs } class(phy) <- oc phy } ape/R/unique.multiPhylo.R0000644000175100001440000000157712465112403015044 0ustar hornikusers## unique.multiPhylo.R (2014-01-15) ## Revomes Duplicate Trees from a List ## Copyright 2007-2014 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. unique.multiPhylo <- function(x, incomparables = FALSE, use.edge.length = FALSE, use.tip.label = TRUE, ...) { n <- length(x) keep <- 1L old.index <- seq_len(n) for (i in 2:n) { already.seen <- FALSE for (j in keep) { if (all.equal(x[[j]], x[[i]], use.edge.length = use.edge.length, use.tip.label = use.tip.label)) { already.seen <- TRUE old.index[i] <- j break } } if (!already.seen) keep <- c(keep, i) } res <- x[keep] attr(res, "old.index") <- old.index res } ape/R/plot.phyloExtra.R0000644000175100001440000000352512752423073014507 0ustar hornikusers## plot.phyloExtra.R (2016-08-09) ## Extra Functions for Plotting and Annotating ## Copyright 2016 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. plotBreakLongEdges <- function(phy, n = 1, ...) { o <- order(phy$edge.length, decreasing = TRUE) i <- o[seq_len(n)] phy$edge.length[i] <- max(phy$edge.length[-i]) plot.phylo(phy, ...) edgelabels(edge = i, pch = 19, col = "white") edgelabels("//", i, frame = "n") } drawSupportOnEdges <- function(value, ...) { lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv) n <- lastPP$Ntip m <- lastPP$Nnode if (length(value) == m) value <- value[-1] else if (length(value) != m - 1) stop("incorrect number of support values") nodes <- 2:m + n i <- match(nodes, lastPP$edge[, 2]) edgelabels(value, i, ...) } plotTreeTime <- function(phy, tip.dates, show.tip.label = FALSE, y.lim = NULL, ...) { n <- Ntip(phy) if (length(tip.dates) != n) stop("number of dates does not match number of tips of the tree") if (is.null(y.lim)) y.lim <- c(-n/4, n) plot(phy, show.tip.label = show.tip.label, y.lim = y.lim, ...) psr <- par("usr") if (anyNA(tip.dates)) { s <- which(!is.na(tip.dates)) tip.dates <- tip.dates[s] } else s <- 1:n range.dates <- range(as.numeric(tip.dates)) diff.range <- range.dates[2] - range.dates[1] footrans <- function(x) psr[2] * (as.numeric(x) - range.dates[1]) / diff.range x1 <- footrans(tip.dates) y1 <- psr[3] lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv) x2 <- lastPP$xx[s] y2 <- lastPP$yy[s] x1.scaled <- x1 / max(x1) segments(x1, y1, x2, y2, col = rgb(x1.scaled, 0, 1 - x1.scaled, alpha = .5)) at <- pretty(tip.dates) axis(1, at = footrans(at), labels = at) } ape/R/additive.R0000644000175100001440000000173312465112403013154 0ustar hornikusers## additive.R (2013-10-04) ## Incomplete Distance Matrix Filling ## Copyright 2011-2013 Andrei-Alin Popescu ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. additive <- function(X) { if (is.matrix(X)) X <- as.dist(X) X[is.na(X)] <- -1 X[X < 0] <- -1 X[is.nan(X)] <- -1 N <- attr(X, "Size") labels <- attr(X, "Labels") if (is.null(labels)) labels <- as.character(1:N) m <- sum(X == -1) ans <- .C(C_additive, as.double(X), as.integer(N), as.integer(m), double(N*N)) matrix(ans[[4]], N, N) } ultrametric <- function(X) { if (is.matrix(X)) X <- as.dist(X) X[is.na(X)] <- -1 X[X < 0] <- -1 X[is.nan(X)] <- -1 N <- attr(X, "Size") labels <- attr(X, "Labels") if (is.null(labels)) labels <- as.character(1:N) m <- sum(X == -1) ans <- .C(C_ultrametric, as.double(X), as.integer(N), as.integer(m), double(N*N)) matrix(ans[[4]], N, N) } ape/R/coalescent.intervals.R0000644000175100001440000000272613002744162015515 0ustar hornikusers## coalescent.intervals.R (2002-09-12) ## Constructs objects with information on coalescent intervals ## Copyright 2002 Korbinian Strimmer ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. coalescent.intervals <- function(x) UseMethod("coalescent.intervals") # set up coalescent interval object (from NH tree) coalescent.intervals.phylo <- function(x) { if (class(x) != "phylo") stop("object \"x\" is not of class \"phylo\"") # ensure we have a BINARY tree if (!is.binary.phylo(x)) stop("object \"x\" is not a binary tree") # ordered branching times t <- sort(branching.times(x)) lt <- length(t) # interval widths w <- numeric(lt) w[1] <- t[1] for (i in 2:lt) w[i] <- t[i] - t[i - 1] l <- (lt+1):2 # number of lineages obj <- list( lineages=l, interval.length=w, interval.count=lt, total.depth =sum(w)) class(obj) <- "coalescentIntervals" return(obj) } # set up coalescent interval object from vector of interval length coalescent.intervals.default <- function(x) { if (!is.vector(x)) stop("argument \"x\" is not a vector of interval lengths") # x = list of the widths of each interval lt <- length(x) l <- (lt+1):2 # number of lineages at the beginning of each interval obj <- list( lineages=l, interval.length=x, interval.count=lt, total.depth =sum(x)) class(obj) <- "coalescentIntervals" return(obj) } ape/R/alex.R0000644000175100001440000000230112465112403012304 0ustar hornikusers## alex.R (2012-03-27) ## Alignment Explorer With Multiple Devices ## Copyright 2012 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. alex <- function(x, ...) { n <- nrow(x) s <- ncol(x) devmain <- dev.cur() on.exit(dev.set(devmain)) NEW <- TRUE cat("Click on two opposite corners of the zone you want to zoom-in. Right-click to exit.\n") repeat { xy <- locator(2) if (is.null(xy)) break xy <- lapply(xy, function(x) sort(round(x))) i1 <- xy$y[1L]; i2 <- xy$y[2L] j1 <- xy$x[1L]; j2 <- xy$x[2L] if (i1 > n || j1 > s) cat("Try again!\n") else { if (i1 <= 0) i1 <- 1L if (j1 <= 0) j1 <- 1L if (i2 > n) i2 <- n if (j2 > s) j2 <- s if (NEW) { dev.new() devsub <- dev.cur() NEW <- FALSE } else dev.set(devsub) image(x[i1:i2, j1:j2], xaxt = "n", ...) atx <- axTicks(1) axis(1, atx, labels = (j1:j2)[atx]) title(sub = paste("From", sQuote(deparse(substitute(x))))) dev.set(devmain) } } } ape/R/plotPhyloCoor.R0000644000175100001440000001243712465112403014203 0ustar hornikusers## plotPhyloCoor.R (2013-03-30) ## Coordinates of a Tree Plot ## Copyright 2008 Damien de Vienne, 2013 Klaus Schliep ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. plotPhyloCoor <- function (x, type = "phylogram", use.edge.length = TRUE, node.pos = NULL, direction = "rightwards", tip.order = NULL, ...) { Ntip <- length(x$tip.label) if (Ntip == 1) stop("found only one tip in the tree!") Nedge <- dim(x$edge)[1] if (any(tabulate(x$edge[, 1]) == 1)) stop("there are single (non-splitting) nodes in your tree; you may need to use collapse.singles().") Nnode <- x$Nnode if (is.null(x$edge.length)) use.edge.length <- FALSE phyloORclado <- type %in% c("phylogram", "cladogram") horizontal <- direction %in% c("rightwards", "leftwards") if (phyloORclado) { ## changed by KS: yy <- numeric(Ntip + Nnode) if (!is.null(tip.order)) { yy[tip.order] <- 1:length(tip.order) } else { x <- reorder(x) TIPS <- x$edge[x$edge[, 2] <= Ntip, 2] yy[TIPS] <- 1:Ntip } } xe <- x$edge ## first reorder the tree in cladewise order to avoid cophyloplot() hanging: ## x <- reorder(reorder(x), order = "pruningwise") ... maybe not needed anymore (EP) x <- reorder(x, order = "postorder") ereorder <- match(x$edge[, 2], xe[, 2]) if (phyloORclado) { if (is.null(node.pos)) { node.pos <- 1 if (type == "cladogram" && !use.edge.length) node.pos <- 2 } if (node.pos == 1) yy <- .C("node_height", as.integer(Ntip), as.integer(Nnode), as.integer(x$edge[, 1]), as.integer(x$edge[, 2]), as.integer(Nedge), as.double(yy), PACKAGE = "ape")[[6]] else { ans <- .C("node_height_clado", as.integer(Ntip), as.integer(Nnode), as.integer(x$edge[, 1]), as.integer(x$edge[, 2]), as.integer(Nedge), double(Ntip + Nnode), as.double(yy), PACKAGE = "ape") xx <- ans[[6]] - 1 yy <- ans[[7]] } if (!use.edge.length) { if (node.pos != 2) xx <- .C("node_depth", as.integer(Ntip), as.integer(Nnode), as.integer(x$edge[, 1]), as.integer(x$edge[, 2]), as.integer(Nedge), double(Ntip + Nnode), 1L, PACKAGE = "ape")[[6]] - 1 xx <- max(xx) - xx } else { xx <- .C("node_depth_edgelength", as.integer(Ntip), as.integer(Nnode), as.integer(x$edge[, 1]), as.integer(x$edge[, 2]), as.integer(Nedge), as.double(x$edge.length), double(Ntip + Nnode), PACKAGE = "ape")[[7]] } } ##if (type == "fan") { ## TIPS <- xe[which(xe[, 2] <= Ntip), 2] ## xx <- seq(0, 2 * pi * (1 - 1/Ntip), 2 * pi/Ntip) ## theta <- double(Ntip) ## theta[TIPS] <- xx ## theta <- c(theta, numeric(Nnode)) ## theta <- .C("node_height", as.integer(Ntip), as.integer(Nnode), ## as.integer(x$edge[, 1]), as.integer(x$edge[, 2]), ## as.integer(Nedge), theta, DUP = FALSE, PACKAGE = "ape")[[6]] ## if (use.edge.length) { ## r <- .C("node_depth_edgelength", as.integer(Ntip), ## as.integer(Nnode), as.integer(x$edge[, 1]), as.integer(x$edge[, ## 2]), as.integer(Nedge), as.double(x$edge.length), ## double(Ntip + Nnode), DUP = FALSE, PACKAGE = "ape")[[7]] ## } ## else { ## r <- .C("node_depth", as.integer(Ntip), as.integer(Nnode), ## as.integer(x$edge[, 1]), as.integer(x$edge[, ## 2]), as.integer(Nedge), double(Ntip + Nnode), ## DUP = FALSE, PACKAGE = "ape")[[6]] ## r <- 1/r ## } ## xx <- r * cos(theta) ## yy <- r * sin(theta) ##} ##if (type == "unrooted") { ## XY <- if (use.edge.length) ## unrooted.xy(Ntip, Nnode, x$edge, x$edge.length) ## else unrooted.xy(Ntip, Nnode, x$edge, rep(1, Nedge)) ## xx <- XY$M[, 1] - min(XY$M[, 1]) ## yy <- XY$M[, 2] - min(XY$M[, 2]) ##} ##if (type == "radial") { ## X <- .C("node_depth", as.integer(Ntip), as.integer(Nnode), ## as.integer(x$edge[, 1]), as.integer(x$edge[, 2]), ## as.integer(Nedge), double(Ntip + Nnode), DUP = FALSE, ## PACKAGE = "ape")[[6]] ## X[X == 1] <- 0 ## X <- 1 - X/Ntip ## yy <- c((1:Ntip) * 2 * pi/Ntip, rep(0, Nnode)) ## Y <- .C("node_height", as.integer(Ntip), as.integer(Nnode), ## as.integer(x$edge[, 1]), as.integer(x$edge[, 2]), ## as.integer(Nedge), as.double(yy), DUP = FALSE, PACKAGE = "ape")[[6]] ## xx <- X * cos(Y) ## yy <- X * sin(Y) ##} if (phyloORclado && direction != "rightwards") { if (direction == "leftwards") { xx <- -xx xx <- xx - min(xx) } if (!horizontal) { tmp <- yy yy <- xx xx <- tmp - min(tmp) + 1 if (direction == "downwards") { yy <- -yy yy <- yy - min(yy) } } } cbind(xx, yy) } ape/R/PGLS.R0000644000175100001440000002062612465112403012132 0ustar hornikusers## PGLS.R (2014-12-11) ## Phylogenetic Generalized Least Squares ## Copyright 2004 Julien Dutheil, and 2006-2014 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. corBrownian <- function(value = 1, phy, form = ~1) { if (!inherits(phy, "phylo")) stop('object "phy" is not of class "phylo"') attr(value, "formula") <- form attr(value, "fixed") <- TRUE attr(value, "tree") <- phy class(value) <- c("corBrownian", "corPhyl", "corStruct") value } corMartins <- function(value, phy, form = ~1, fixed = FALSE) { if (length(value) > 1) stop("only one parameter is allowed") if (value < 0) stop("the parameter alpha must be positive") if (!inherits(phy, "phylo")) stop('object "phy" is not of class "phylo"') attr(value, "formula") <- form attr(value, "fixed") <- fixed attr(value, "tree") <- phy class(value) <- c("corMartins", "corPhyl", "corStruct") value } corGrafen <- function(value, phy, form = ~1, fixed = FALSE) { if (length(value) > 1) stop("only one parameter is allowed") if (value < 0) stop("parameter rho must be positive") value <- log(value) # Optimization under constraint, use exponential transform. if (!inherits(phy, "phylo")) stop('object "phy" is not of class "phylo"') attr(value, "formula") <- form attr(value, "fixed") <- fixed attr(value, "tree") <- phy class(value) <- c("corGrafen", "corPhyl", "corStruct") value } Initialize.corPhyl <- function(object, data, ...) { ## The same as in Initialize corStruct: form <- formula(object) ## Obtaining the group information, if any if (!is.null(getGroupsFormula(form))) { attr(object, "groups") <- getGroups(object, form, data = data) attr(object, "Dim") <- Dim(object, attr(object, "groups")) } else { # no groups attr(object, "Dim") <- Dim(object, as.factor(rep(1, nrow(data)))) } ## Obtaining the covariate(s) attr(object, "covariate") <- getCovariate(object, data = data) ## Specific to corPhyl: phy <- attr(object, "tree") if (is.null(data)) data <- parent.frame() ## Added by EP 29 May 2006: if (nrow(data) != length(phy$tip.label)) stop("number of observations and number of tips in the tree are not equal.") ## END if (is.null(rownames(data))) { warning("No rownames supplied in data frame, data taken to be in the same order than in tree") attr(object, "index") <- 1:dim(data)[1] } else { index <- match(rownames(data), phy$tip.label) if (any(is.na(index))) { warning("Rownames in data frame do not match tree tip names; data taken to be in the same order as in tree") attr(object, "index") <- 1:dim(data)[1] } else { attr(object, "index") <- index } } object } corMatrix.corBrownian <- function(object, covariate = getCovariate(object), corr = TRUE, ...) { if (!("corBrownian" %in% class(object))) stop('object is not of class "corBrownian"') if (!any(attr(object, "index"))) stop("object has not been initialized.") tree <- attr(object, "tree") mat <- vcv.phylo(tree, corr = corr) ## reorder matrix: index <- attr(object, "index") mat[index, index] } corMatrix.corMartins <- function(object, covariate = getCovariate(object), corr = TRUE, ...) { if (!("corMartins" %in% class(object))) stop('object is not of class "corMartins"') if (!any(attr(object, "index"))) stop("object has not been initialized.") tree <- attr(object, "tree") dist <- cophenetic.phylo(tree) mat <- exp(-object[1] * dist) if (corr) mat <- cov2cor(mat) ## reorder matrix: index <- attr(object, "index") mat[index, index] } corMatrix.corGrafen <- function(object, covariate = getCovariate(object), corr = TRUE, ...) { if (!("corGrafen" %in% class(object))) stop('object is not of class "corGrafen"') if (!any(attr(object, "index"))) stop("object has not been initialized.") tree <- compute.brlen(attr(object, "tree"), method = "Grafen", power = exp(object[1])) mat <- vcv.phylo(tree, corr = corr) ## reorder matrix: index <- attr(object, "index") mat[index, index] } coef.corBrownian <- function(object, unconstrained = TRUE, ...) { if (!("corBrownian" %in% class(object))) stop('object is not of class "corBrownian"') numeric(0) } coef.corMartins <- function(object, unconstrained = TRUE, ...) { if (!("corMartins" %in% class(object))) stop('object is not of class "corMartins"') if (unconstrained) { if (attr(object, "fixed")) { return(numeric(0)) } else { return(as.vector(object)) } } aux <- as.vector(object) names(aux) <- "alpha" aux } coef.corGrafen <- function(object, unconstrained = TRUE, ...) { if (!("corGrafen" %in% class(object))) stop('object is not of class "corGrafen"') if (unconstrained) { if (attr(object, "fixed")) { return(numeric(0)) } else { return(as.vector(object)) } } aux <- exp(as.vector(object)) names(aux) <- "rho" aux } ### removed node.sons() and node.leafnumber() (2006-10-12) ### changed by EP (2006-10-12): compute.brlen <- function(phy, method = "Grafen", power = 1, ...) { if (!inherits(phy, "phylo")) stop('object "phy" is not of class "phylo"') Ntip <- length(phy$tip.label) Nnode <- phy$Nnode Nedge <- dim(phy$edge)[1] if (is.numeric(method)) { phy$edge.length <- rep(method, length.out = Nedge) return(phy) } if (is.function(method)) { phy$edge.length <- method(Nedge, ...) return(phy) } if (is.character(method)) { # == "Grafen" tr <- reorder(phy, "postorder") xx <- .C(node_depth, as.integer(Ntip), as.integer(Nnode), as.integer(tr$edge[, 1]), as.integer(tr$edge[, 2]), as.integer(Nedge), double(Ntip + Nnode), 1L)[[6]] - 1 m <- Ntip - 1 phy$edge.length <- (xx[phy$edge[, 1]]/m)^power - (xx[phy$edge[, 2]]/m)^power return(phy) } } ## by EP: corPagel <- function(value, phy, form = ~1, fixed = FALSE) { if (value < 0 || value > 1) stop("the value of lambda must be between 0 and 1.") if (!inherits(phy, "phylo")) stop('object "phy" is not of class "phylo"') attr(value, "formula") <- form attr(value, "fixed") <- fixed attr(value, "tree") <- phy class(value) <- c("corPagel", "corPhyl", "corStruct") value } corMatrix.corPagel <- function(object, covariate = getCovariate(object), corr = TRUE, ...) { if (!any(attr(object, "index"))) stop("object has not been initialized") mat <- vcv.phylo(attr(object, "tree"), corr = corr) index <- attr(object, "index") mat <- mat[index, index] tmp <- diag(mat) mat <- object[1]*mat diag(mat) <- tmp mat } coef.corPagel <- function(object, unconstrained = TRUE, ...) { if (unconstrained) { if (attr(object, "fixed")) return(numeric(0)) else return(object[1]) } aux <- object[1] names(aux) <- "lambda" aux } corBlomberg <- function(value, phy, form = ~1, fixed = FALSE) { if (value <= 0) stop("the value of g must be greater than 0.") if (!inherits(phy, "phylo")) stop('object "phy" is not of class "phylo"') attr(value, "formula") <- form attr(value, "fixed") <- fixed attr(value, "tree") <- phy class(value) <- c("corBlomberg", "corPhyl", "corStruct") value } corMatrix.corBlomberg <- function(object, covariate = getCovariate(object), corr = TRUE, ...) { index <- attr(object, "index") if (is.null(index)) stop("object has not been initialized") if (object[1] <= 0) stop("the optimization has reached a value <= 0 for parameter 'g': probably need to set 'fixed = TRUE' in corBlomberg().") phy <- attr(object, "tree") d <- (dist.nodes(phy)[length(phy$tip.label) + 1, ])^(1/object[1]) phy$edge.length <- d[phy$edge[, 2]] - d[phy$edge[, 1]] mat <- vcv.phylo(phy, corr = corr) mat[index, index] } coef.corBlomberg <- function(object, unconstrained = TRUE, ...) { if (unconstrained) { if (attr(object, "fixed")) return(numeric(0)) else return(object[1]) } aux <- object[1] names(aux) <- "g" aux } ape/R/diversi.time.R0000644000175100001440000000643312465112403013767 0ustar hornikusers## diversi.time.R (2007-09-22) ## Analysis of Diversification with Survival Models ## Copyright 2002-2007 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. diversi.time <- function(x, census = NULL, censoring.codes = c(1, 0), Tc = NULL) { n <- length(x) if (is.null(census)) { k <- n census <- rep(censoring.codes[1], n) } else k <- sum(census == censoring.codes[1]) u <- n - k S <- sum(x) delta <- k / S var.delta <- delta^2 / k loglik.A <- k * log(delta) - delta * S tk <- x[census == censoring.codes[1]] tu <- x[census == censoring.codes[2]] fb <- function(b) 1/b - sum(x^b * log(x))/sum(x^b) + sum(log(tk))/k beta <- uniroot(fb, interval = c(1e-7, 10))$root Sp <- sum(x^beta) alpha <- (k / Sp)^(1/beta) var.alpha <- 1/ ((k * beta / alpha^2) + beta * (beta - 1) * alpha^(beta - 2) * Sp) ax <- alpha * x var.beta <- 1 / (k / beta^2 + sum(ax^beta * log(ax))) loglik.B <- k*(log(alpha) + log(beta)) + (beta - 1)*(k*log(alpha) + sum(log(tk)))- Sp * alpha^beta if (is.null(Tc)) Tc <- median(x) tk1 <- tk[tk < Tc] tk2 <- tk[tk >= Tc] tu1 <- tu[tu < Tc] tu2 <- tu[tu >= Tc] k1 <- length(tk1) k2 <- k - k1 u1 <- length(tu1) u2 <- u - u1 tmp <- (k2 + u2) * Tc delta1 <- k1 / (sum(tk1) + sum(tu1) + tmp) delta2 <- k2 / (sum(tk2) + sum(tu2) - tmp) var.delta1 <- delta1^2 / k1 var.delta2 <- delta2^2 / k2 tmp <- Tc * (delta2 - delta1) loglik.C <- k1 * log(delta1) - delta1 * sum(tk1) + k2 * log(delta2) + k2 * tmp - delta2 * sum(tk2) - delta1 * sum(tu1) + u2 * tmp - delta2 * sum(tu2) cat("\nAnalysis of Diversification with Survival Models\n\n") cat("Data:", deparse(substitute(x)), "\n") cat("Number of branching times:", n, "\n") cat(" accurately known:", k, "\n") cat(" censored:", u, "\n\n") cat("Model A: constant diversification\n") cat(" log-likelihood =", round(loglik.A, 3), " AIC =", round(-2 * loglik.A + 2, 3), "\n") cat(" delta =", round(delta, 6), " StdErr =", round(sqrt(var.delta), 6), "\n\n") cat("Model B: diversification follows a Weibull law\n") cat(" log-likelihood =", round(loglik.B, 3), " AIC =", round(-2 * loglik.B + 4, 3), "\n") cat(" alpha =", round(alpha, 6), " StdErr =", round(sqrt(var.alpha), 6), "\n") cat(" beta =", round(beta, 6), " StdErr =", round(sqrt(var.beta), 6), "\n\n") cat("Model C: diversification changes with a breakpoint at time =", Tc, "\n") cat(" log-likelihood =", round(loglik.C, 3), " AIC =", round(-2 * loglik.C + 4, 3), "\n") cat(" delta1 =", round(delta1, 6), " StdErr =", round(sqrt(var.delta1), 6), "\n") cat(" delta2 =", round(delta2, 6), " StdErr =", round(sqrt(var.delta2), 6), "\n\n") cat("Likelihood ratio tests:\n") c1 <- 2 * (loglik.B - loglik.A) p1 <- round(1 - pchisq(c1, 1), 4) c2 <- 2 * (loglik.C - loglik.A) p2 <- round(1 - pchisq(c2, 1), 4) cat(" Model A vs. Model B: chi^2 =", round(c1, 3), " df = 1, P =", p1, "\n") cat(" Model A vs. Model C: chi^2 =", round(c2, 3), " df = 1, P =", p2, "\n") } ape/R/njs.R0000644000175100001440000000301512465112403012150 0ustar hornikusers## njs.R (2013-10-04) ## Tree Reconstruction from Incomplete Distances With NJ* or bio-NJ* ## Copyright 2011-2013 Andrei-Alin Popescu ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. njs <- function(X, fs = 15) { if (fs < 1) stop("argument 'fs' must be a non-zero positive integer") if (is.matrix(X)) X <- as.dist(X) X[is.na(X)] <- -1 X[X < 0] <- -1 X[is.nan(X)] <- -1 N <- attr(X, "Size") labels <- attr(X, "Labels") if (is.null(labels)) labels <- as.character(1:N) ans <- .C(C_njs, as.double(X), as.integer(N), integer(2*N - 3), integer(2*N - 3), double(2*N - 3), as.integer(fs), NAOK = TRUE) obj <- list(edge = cbind(ans[[3]], ans[[4]]), edge.length = ans[[5]], tip.label = labels, Nnode = N - 2L) class(obj) <- "phylo" reorder(obj) } bionjs <- function(X, fs = 15) { if (fs < 1) stop("argument 'fs' must be a non-zero positive integer") if (is.matrix(X)) X <- as.dist(X) X[is.na(X)] <- -1 X[X < 0] <- -1 X[is.nan(X)] <- -1 N <- attr(X, "Size") labels <- attr(X, "Labels") if (is.null(labels)) labels <- as.character(1:N) ans <- .C(C_bionjs, as.double(X), as.integer(N), integer(2*N - 3), integer(2*N - 3), double(2*N - 3), as.integer(fs), NAOK = TRUE) obj <- list(edge = cbind(ans[[3]], ans[[4]]), edge.length = ans[[5]], tip.label = labels, Nnode = N - 2L) class(obj) <- "phylo" reorder(obj) } ape/R/dist.topo.R0000644000175100001440000002740213015620710013304 0ustar hornikusers## dist.topo.R (2016-11-24) ## Topological Distances, Tree Bipartitions, ## Consensus Trees, and Bootstrapping Phylogenies ## Copyright 2005-2016 Emmanuel Paradis, 2016 Klaus Schliep ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. .getTreesFromDotdotdot <- function(...) { obj <- list(...) if (length(obj) == 1 && !inherits(obj[[1]], "phylo")) obj <- obj[[1]] obj } dist.topo <- function(x, y = NULL, method = "PH85") { if (!is.null(y)) { res <- .dist.topo(x, y, method = method) } else { n <- length(x) # number of trees res <- numeric(n * (n - 1) /2) nms <- names(x) if (is.null(nms)) nms <- paste0("tree", 1:n) k <- 0L for (i in 1:(n - 1)) { for (j in (i + 1):n) { k <- k + 1L res[k] <- .dist.topo(x[[i]], x[[j]], method = method) } } attr(res, "Size") <- n attr(res, "Labels") <- nms attr(res, "Diag") <- attr(res, "Upper") <- FALSE attr(res, "method") <- method class(res) <- "dist" } res } .dist.topo <- function(x, y, method = "PH85") { if (method == "PH85") { bs <- bitsplits(unroot.multiPhylo(c(x, y))) return(sum(bs$freq == 1)) } ## method == "score": if (is.null(x$edge.length) || is.null(y$edge.length)) stop("trees must have branch lengths for branch score distance.") nx <- length(x$tip.label) x <- unroot(x) y <- unroot(y) bp1 <- .Call(bipartition, x$edge, nx, x$Nnode) bp1 <- lapply(bp1, function(xx) sort(x$tip.label[xx])) ny <- length(y$tip.label) # fix by Otto Cordero ## fix by Tim Wallstrom: bp2.tmp <- .Call(bipartition, y$edge, ny, y$Nnode) bp2 <- lapply(bp2.tmp, function(xx) sort(y$tip.label[xx])) bp2.comp <- lapply(bp2.tmp, function(xx) setdiff(1:ny, xx)) bp2.comp <- lapply(bp2.comp, function(xx) sort(y$tip.label[xx])) ## End q1 <- length(bp1) q2 <- length(bp2) dT <- 0 found1 <- FALSE found2 <- logical(q2) found2[1] <- TRUE for (i in 2:q1) { for (j in 2:q2) { if (identical(bp1[[i]], bp2[[j]]) | identical(bp1[[i]], bp2.comp[[j]])) { dT <- dT + (x$edge.length[which(x$edge[, 2] == nx + i)] - y$edge.length[which(y$edge[, 2] == ny + j)])^2 found1 <- found2[j] <- TRUE break } } if (found1) found1 <- FALSE else dT <- dT + (x$edge.length[which(x$edge[, 2] == nx + i)])^2 } if (!all(found2)) dT <- dT + sum((y$edge.length[y$edge[, 2] %in% (ny + which(!found2))])^2) sqrt(dT) } .compressTipLabel <- function(x, ref = NULL) { ## 'x' is a list of objects of class "phylo" possibly with no class if (!is.null(attr(x, "TipLabel"))) return(x) if (is.null(ref)) ref <- x[[1]]$tip.label n <- length(ref) if (length(unique(ref)) != n) stop("some tip labels are duplicated in tree no. 1") ## serious improvement by Joseph W. Brown! relabel <- function (y) { label <- y$tip.label if (!identical(label, ref)) { if (length(label) != length(ref)) stop("one tree has a different number of tips") ilab <- match(label, ref) if (any(is.na(ilab))) stop("one tree has different tip labels") ie <- match(1:n, y$edge[, 2]) y$edge[ie, 2] <- ilab } y$tip.label <- NULL y } x <- unclass(x) # another killer improvement by Tucson's hackathon (1/2/2013) x <- lapply(x, relabel) attr(x, "TipLabel") <- ref class(x) <- "multiPhylo" x } prop.part <- function(..., check.labels = TRUE) { obj <- .getTreesFromDotdotdot(...) ntree <- length(obj) if (ntree == 1) check.labels <- FALSE if (check.labels) obj <- .compressTipLabel(obj) # fix by Klaus Schliep (2011-02-21) class(obj) <- NULL # fix by Klaus Schliep (2014-03-06) for (i in 1:ntree) storage.mode(obj[[i]]$Nnode) <- "integer" class(obj) <- "multiPhylo" obj <- .uncompressTipLabel(obj) # fix a bug (2010-11-18) clades <- .Call(prop_part, obj, ntree, TRUE) attr(clades, "number") <- attr(clades, "number")[1:length(clades)] attr(clades, "labels") <- obj[[1]]$tip.label class(clades) <- "prop.part" clades } print.prop.part <- function(x, ...) { if (is.null(attr(x, "labels"))) { for (i in 1:length(x)) { cat("==>", attr(x, "number")[i], "time(s):") print(x[[i]], quote = FALSE) } } else { for (i in 1:length(attr(x, "labels"))) cat(i, ": ", attr(x, "labels")[i], "\n", sep = "") cat("\n") for (i in 1:length(x)) { cat("==>", attr(x, "number")[i], "time(s):") print(x[[i]], quote = FALSE) } } } summary.prop.part <- function(object, ...) attr(object, "number") plot.prop.part <- function(x, barcol = "blue", leftmar = 4, col = "red", ...) { if (is.null(attr(x, "labels"))) stop("cannot plot this partition object; see ?prop.part for details.") L <- length(x) n <- length(attr(x, "labels")) layout(matrix(1:2, 2, 1), heights = c(1, 3)) par(mar = c(0.1, leftmar, 0.1, 0.1)) one2L <- seq_len(L) plot(one2L, attr(x, "number"), type = "h", col = barcol, xlim = c(0.5, L), xaxs = "i", xlab = "", ylab = "Frequency", xaxt = "n", bty = "n", ...) M <- matrix(0L, L, n) for (i in one2L) M[i, x[[i]]] <- 1L image.default(one2L, 1:n, M, col = c("white", col), xlab = "", ylab = "", yaxt = "n") mtext(attr(x, "labels"), side = 2, at = 1:n, las = 1) } ### by Klaus (2016-03-23): prop.clades <- function(phy, ..., part = NULL, rooted = FALSE) { if (is.null(part)) { obj <- .getTreesFromDotdotdot(...) ## avoid double counting of edges if trees are rooted if (!rooted) obj <- lapply(obj, unroot) part <- prop.part(obj, check.labels = TRUE) } LABS <- attr(part, "labels") if (!identical(phy$tip.label, LABS)) { i <- match(phy$tip.label, LABS) j <- match(seq_len(Ntip(phy)), phy$edge[, 2]) phy$edge[j, 2] <- i phy$tip.label <- LABS } bp <- prop.part(phy) if (!rooted) { ## avoid messing up the order and length if phy is rooted in some cases bp <- ONEwise(bp) part <- postprocess.prop.part(part) } pos <- match(bp, part) tmp <- which(!is.na(pos)) n <- rep(NA_real_, phy$Nnode) n[tmp] <- attr(part, "number")[pos[tmp]] n } boot.phylo <- function(phy, x, FUN, B = 100, block = 1, trees = FALSE, quiet = FALSE, rooted = is.rooted(phy), jumble = TRUE, mc.cores = 1) { if (is.null(dim(x)) || length(dim(x)) != 2) stop("the data 'x' must have two dimensions (e.g., a matrix or a data frame)") if (anyDuplicated(rownames(x))) stop("some labels are duplicated in the data: you won't be able to analyse tree bipartitions") boot.tree <- vector("list", B) y <- nc <- ncol(x) nr <- nrow(x) if (block > 1) { a <- seq(1, nc - 1, block) b <- seq(block, nc, block) y <- mapply(":", a, b, SIMPLIFY = FALSE) getBootstrapIndices <- function() unlist(sample(y, replace = TRUE)) } else getBootstrapIndices <- function() sample.int(y, replace = TRUE) if (!quiet) { prefix <- "\rRunning bootstraps: " suffix <- paste("/", B) updateProgress <- function(i) cat(prefix, i, suffix) } if (mc.cores == 1) { for (i in 1:B) { boot.samp <- x[, getBootstrapIndices()] if (jumble) boot.samp <- boot.samp[sample.int(nr), ] boot.tree[[i]] <- FUN(boot.samp) if (!quiet && !(i %% 100)) updateProgress(i) } } else { if (!quiet) cat("Running parallel bootstraps...") foo <- function(i) { boot.samp <- x[, getBootstrapIndices()] if (jumble) boot.samp <- boot.samp[sample.int(nr), ] FUN(boot.samp) } boot.tree <- mclapply(1:B, foo, mc.cores = mc.cores) if (!quiet) cat(" done.") } if (!quiet) cat("\nCalculating bootstrap values...") ## sort labels after mixed them up if (jumble) { boot.tree <- .compressTipLabel(boot.tree, ref = phy$tip.label) boot.tree <- .uncompressTipLabel(boot.tree) boot.tree <- unclass(boot.tree) # otherwise countBipartitions crashes } if (rooted) { pp <- prop.part(boot.tree) ans <- prop.clades(phy, part = pp, rooted = rooted) } else { phy <- reorder(phy, "postorder") ints <- phy$edge[, 2] > Ntip(phy) ans <- countBipartitions(phy, boot.tree) ans <- c(B, ans[order(phy$edge[ints, 2])]) } if (!quiet) cat(" done.\n") if (trees) { class(boot.tree) <- "multiPhylo" ans <- list(BP = ans, trees = boot.tree) } ans } ### The next function transforms an object of class "prop.part" so ### that the vectors which are identical in terms of split are aggregated. ### For instance if n = 5 tips, 1:2 and 3:5 actually represent the same ### split though they are different clades. The aggregation is done ### arbitrarily. The call to ONEwise() insures that all splits include ### the first tip. ### (rewritten by Klaus) postprocess.prop.part <- function(x) { w <- attr(x, "number") labels <- attr(x, "labels") x <- ONEwise(x) drop <- duplicated(x) if (any(drop)) { ind1 <- match(x[drop], x) ind2 <- which(drop) for (i in seq_along(ind2)) w[ind1[i]] <- w[ind1[i]] + w[ind2[i]] x <- x[!drop] w <- w[!drop] } attr(x, "number") <- w attr(x, "labels") <- labels class(x) <- "prop.part" x } ### This function changes an object of class "prop.part" so that they ### all include the first tip. For instance if n = 5 tips, 3:5 is ### changed to 1:2. ONEwise <- function(x) { v <- seq_along(x[[1L]]) for (i in 2:length(x)) { y <- x[[i]] if (y[1] != 1) x[[i]] <- v[-y] } x } consensus <- function(..., p = 1, check.labels = TRUE) { foo <- function(ic, node) { ## ic: index of 'pp' ## node: node number in the final tree pool <- pp[[ic]] if (ic < m) { for (j in (ic + 1):m) { wh <- match(pp[[j]], pool) if (!any(is.na(wh))) { edge[pos, 1] <<- node pool <- pool[-wh] edge[pos, 2] <<- nextnode <<- nextnode + 1L pos <<- pos + 1L foo(j, nextnode) } } } size <- length(pool) if (size) { ind <- pos:(pos + size - 1) edge[ind, 1] <<- node edge[ind, 2] <<- pool pos <<- pos + size } } obj <- .getTreesFromDotdotdot(...) if (!is.null(attr(obj, "TipLabel"))) labels <- attr(obj, "TipLabel") else { labels <- obj[[1]]$tip.label if (check.labels) obj <- .compressTipLabel(obj) } ntree <- length(obj) ## Get all observed partitions and their frequencies: pp <- prop.part(obj, check.labels = FALSE) ## Drop the partitions whose frequency is less than 'p': if (p == 0.5) p <- 0.5000001 # avoid incompatible splits pp <- pp[attr(pp, "number") >= p * ntree] ## Get the order of the remaining partitions by decreasing size: ind <- order(lengths(pp), decreasing = TRUE) pp <- pp[ind] n <- length(labels) m <- length(pp) edge <- matrix(0L, n + m - 1, 2) if (m == 1) { edge[, 1] <- n + 1L edge[, 2] <- 1:n } else { nextnode <- n + 1L pos <- 1L foo(1, nextnode) } structure(list(edge = edge, tip.label = labels, Nnode = m), class = "phylo") } ape/R/write.tree.R0000644000175100001440000000733312465112403013455 0ustar hornikusers## write.tree.R (2010-12-07) ## Write Tree File in Parenthetic Format ## Copyright 2002-2010 Emmanuel Paradis, Daniel Lawson, and Klaus Schliep ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. checkLabel <- function(x, ...) { ## delete all leading and trailing spaces and tabs, and ## the leading left and trailing right parentheses: ## (the syntax will work with any mix of these characters, ## e.g., " ( ( (( " will correctly be deleted) x <- gsub("^[[:space:]\\(]+", "", x) x <- gsub("[[:space:]\\)]+$", "", x) ## replace all spaces and tabs by underscores: x <- gsub("[[:space:]]", "_", x) ## remove all commas, colons, and semicolons x <- gsub("[,:;]", "", x) ## replace left and right parentheses with dashes: x <- gsub("[\\(\\)]", "-", x) ## delete extra underscores and extra dashes: x <- gsub("_{2,}", "_", x) x <- gsub("-{2,}", "-", x) x } write.tree <- function(phy, file = "", append = FALSE, digits = 10, tree.names = FALSE) { if (!(inherits(phy, c("phylo", "multiPhylo")))) stop("object \"phy\" has no trees") if (inherits(phy, "phylo")) phy <- c(phy) N <- length(phy) res <- character(N) if (is.logical(tree.names)) { if (tree.names) { tree.names <- if (is.null(names(phy))) character(N) else names(phy) } else tree.names <- character(N) } for (i in 1:N) res[i] <- .write.tree2(phy[[i]], digits = digits, tree.prefix = tree.names[i]) if (file == "") return(res) else cat(res, file = file, append = append, sep = "\n") } .write.tree2 <- function(phy, digits = 10, tree.prefix = "") { brl <- !is.null(phy$edge.length) nodelab <- !is.null(phy$node.label) phy$tip.label <- checkLabel(phy$tip.label) if (nodelab) phy$node.label <- checkLabel(phy$node.label) f.d <- paste("%.", digits, "g", sep = "") cp <- function(x){ STRING[k] <<- x k <<- k + 1 } add.internal <- function(i) { cp("(") desc <- kids[[i]] for (j in desc) { if (j > n) add.internal(j) else add.terminal(ind[j]) if (j != desc[length(desc)]) cp(",") } cp(")") if (nodelab && i > n) cp(phy$node.label[i - n]) # fixed by Naim Matasci (2010-12-07) if (brl) { cp(":") cp(sprintf(f.d, phy$edge.length[ind[i]])) } } add.terminal <- function(i) { cp(phy$tip.label[phy$edge[i, 2]]) if (brl) { cp(":") cp(sprintf(f.d, phy$edge.length[i])) } } n <- length(phy$tip.label) ## borrowed from phangorn: parent <- phy$edge[, 1] children <- phy$edge[, 2] kids <- vector("list", n + phy$Nnode) for (i in 1:length(parent)) kids[[parent[i]]] <- c(kids[[parent[i]]], children[i]) ind <- match(1:max(phy$edge), phy$edge[, 2]) LS <- 4*n + 5 if (brl) LS <- LS + 4*n if (nodelab) LS <- LS + n STRING <- character(LS) k <- 1 cp(tree.prefix) cp("(") getRoot <- function(phy) phy$edge[, 1][!match(phy$edge[, 1], phy$edge[, 2], 0)][1] root <- getRoot(phy) # replaced n+1 with root - root has not be n+1 desc <- kids[[root]] for (j in desc) { if (j > n) add.internal(j) else add.terminal(ind[j]) if (j != desc[length(desc)]) cp(",") } if (is.null(phy$root.edge)) { cp(")") if (nodelab) cp(phy$node.label[1]) cp(";") } else { cp(")") if (nodelab) cp(phy$node.label[1]) cp(":") cp(sprintf(f.d, phy$root.edge)) cp(";") } paste(STRING, collapse = "") } ape/R/as.matching.R0000644000175100001440000000377112465112403013563 0ustar hornikusers## as.matching.R (2011-02-26) ## Conversion Between Phylo and Matching Objects ## Copyright 2005-2011 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. as.matching <- function(x, ...) UseMethod("as.matching") as.matching.phylo <- function(x, labels = TRUE, ...) { nb.tip <- length(x$tip.label) nb.node <- x$Nnode if (nb.tip != nb.node + 1) stop("the tree must be dichotomous AND rooted.") x <- reorder(x, "pruningwise") # cannot use "postorder" here! mat <- matrix(x$edge[, 2], ncol = 2, byrow = TRUE) nodes <- x$edge[seq(by = 2, length.out = nb.node), 1] ## we can use match() becoz each node appears once in `mat' O <- match(mat, nodes) new.nodes <- 1:nb.node + nb.tip sel <- !is.na(O) mat[sel] <- new.nodes[O[sel]] mat <- t(apply(mat, 1, sort)) obj <- list(matching = mat) if (!is.null(x$edge.length)) warning("branch lengths have been ignored") if (labels) { obj$tip.label <- x$tip.label if (!is.null(x$node.label)) obj$node.label <- x$node.label[match(new.nodes, nodes)] } class(obj) <- "matching" obj } as.phylo.matching <- function(x, ...) { nb.node <- dim(x$matching)[1] nb.tip <- nb.node + 1 N <- 2 * nb.node edge <- matrix(NA, N, 2) new.nodes <- numeric(N + 1) new.nodes[N + 1] <- nb.tip + 1 nextnode <- nb.tip + 2 j <- 1 for (i in nb.node:1) { edge[j:(j + 1), 1] <- new.nodes[i + nb.tip] for (k in 1:2) { if (x$matching[i, k] > nb.tip) { edge[j + k - 1, 2] <- new.nodes[x$matching[i, k]] <- nextnode nextnode <- nextnode + 1 } else edge[j + k - 1, 2] <- x$matching[i, k] } j <- j + 2 } obj <- list(edge = edge) if (!is.null(x$tip.label)) obj$tip.label <- x$tip.label else obj$tip.label <- as.character(1:nb.tip) obj$Nnode <- nb.node class(obj) <- "phylo" read.tree(text = write.tree(obj)) } ape/R/SDM.R0000644000175100001440000001644712725765216012035 0ustar hornikusers## SDM.R (2012-04-02) ## Construction of Consensus Distance Matrix With SDM ## Copyright 2011-2012 Andrei-Alin Popescu ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. SDM <- function(...) { st <- list(...) # first half contains matrices, second half s_p k <- length(st)/2 ONEtoK <- seq_len(k) ## make sure we have only matrices: for (i in ONEtoK) st[[i]] <- as.matrix(st[[i]]) ## store the rownames of each matrix in a list because they are often called: ROWNAMES <- lapply(st[ONEtoK], rownames) ## the number of rows of each matrix: NROWS <- lengths(ROWNAMES) tot <- sum(NROWS) labels <- unique(unlist(ROWNAMES)) sp <- unlist(st[k + ONEtoK]) astart <- numeric(tot) # start of aip, astart[p] is start of aip astart[1] <- k for (i in 2:k) astart[i] <- astart[i - 1] + NROWS[i - 1] ## apparently erased by the operation below so no need to initialize: ## a <- mat.or.vec(1, k + tot + k + length(labels)) ## first k are alphas, subsequent ones aip ## each matrix p starting at astart[p], next are ## Lagrange multipliers, miu, niu, lambda in that order n <- length(labels) miustart <- k + tot niustart <- miustart + n lambstart <- niustart + k - 1 X <- matrix(0, n, n, dimnames = list(labels, labels)) V <- w <- X tmp <- 2 * k + tot + n col <- numeric(tmp) # free terms of system for (i in 1:(n - 1)) { for (j in (i + 1):n) { for (p in ONEtoK) { ## d <- st[[p]] # not needed anymore if (is.element(labels[i], ROWNAMES[[p]]) && is.element(labels[j], ROWNAMES[[p]])) { w[i, j] <- w[j, i] <- w[i, j] + sp[p] } } } } ONEtoN <- seq_len(n) Q <- matrix(0, tmp, tmp) ## first decompose first sum in paper for (p in ONEtoK) { d_p <- st[[p]] for (l in ONEtoK) { # first compute coefficients of alphas d <- st[[l]] sum <- 0 dijp <- -1 if (l == p) { # calculate alpha_p for (i in ONEtoN) { for (j in ONEtoN) { # check if {i,j}\subset L_l if (i == j) next # make sure i != j ## d <- st[[l]] # <- moved-up pos <- match(labels[c(i, j)], ROWNAMES[[l]]) # <- returns NA if not in this matrix if (all(!is.na(pos))) { ipos <- pos[1L] jpos <- pos[2L] dij <- d[ipos, jpos] sum <- sum + dij * dij - sp[l] * dij * dij / w[i,j] tmp2 <- dij - sp[l] * dij / w[i,j] Q[p, astart[l] + ipos] <- Q[p, astart[l] + ipos] + tmp2 Q[p, astart[l] + jpos] <- Q[p, astart[l] + jpos] + tmp2 } } } } else { for (i in ONEtoN) { for (j in ONEtoN) { # check if {i,j}\subset L_l if (i == j) next ## d <- st[[l]] # <- moved-up pos <- match(labels[c(i, j)], ROWNAMES[[l]]) posp <- match(labels[c(i, j)], ROWNAMES[[p]]) if (all(!is.na(pos)) && all(!is.na(posp))) { ipos <- pos[1L] jpos <- pos[2L] dij <- d[ipos, jpos] dijp <- d_p[posp[1L], posp[2L]] sum <- sum - sp[l] * dij * dijp / w[i, j] tmp2 <- sp[l] * dijp / w[i, j] Q[p,astart[l] + ipos] <- Q[p, astart[l] + ipos] - tmp2 Q[p,astart[l] + jpos] <- Q[p, astart[l] + jpos] - tmp2 } } } } Q[p, l] <- sum } Q[p, lambstart + 1] <- 1 } r <- k for (p in ONEtoK) { dp <- st[[p]] for (i in ONEtoN) { if (is.element(labels[i], ROWNAMES[[p]])) { r <- r + 1 for (l in ONEtoK) { d <- st[[l]] if (l == p) { ipos <- match(labels[i], ROWNAMES[[p]]) for (j in ONEtoN) { if (i == j) next jpos <- match(labels[j], ROWNAMES[[p]]) if (!is.na(jpos)) { dij <- d[ipos, jpos] Q[r, l] <- Q[r, l] + dij - sp[l] * dij / w[i, j] tmp2 <- 1 - sp[l] / w[i, j] Q[r, astart[l] + ipos] <- Q[r, astart[l] + ipos] + tmp2 Q[r, astart[l] + jpos] <- Q[r, astart[l] + jpos] + tmp2 } } } else { for (j in ONEtoN) { if (i == j) next if (!is.element(labels[j], rownames(dp))) next pos <- match(labels[c(i, j)], ROWNAMES[[l]]) if (all(!is.na(pos))) { ipos <- pos[1L] jpos <- pos[2L] dij <- d[ipos, jpos] Q[r, l] <- Q[r, l] - sp[l] * dij / w[i, j] tmp2 <- sp[l]/w[i, j] Q[r, astart[l] + ipos] <- Q[r, astart[l] + ipos] - tmp2 Q[r, astart[l] + jpos] <- Q[r, astart[l] + jpos] - tmp2 } } } } if (p < k) Q[r, ] <- Q[r, ] * sp[p] Q[r, miustart + i] <- 1 if (p < k) Q[r, niustart + p] <- 1 } } } r <- r + 1 col[r] <- k Q[r, ONEtoK] <- 1 ## for (i in 1:k) Q[r, i] <- 1 for (i in ONEtoN) { r <- r + 1 for (p in ONEtoK) { ## d <- st[[p]] # not needed ipos <- match(labels[i], ROWNAMES[[p]]) if (!is.na(ipos)) Q[r, astart[p] + ipos] <- 1 } } for (p in 1:(k - 1)) { r <- r + 1 for (i in ONEtoN) { ## d <- st[[p]] ipos <- match(labels[i], ROWNAMES[[p]]) if (!is.na(ipos)) Q[r, astart[p] + ipos] <- 1 } } a <- solve(Q, col, 1e-19) for (i in ONEtoN) { for (j in ONEtoN) { if (i == j) { X[i, j] <- V[i, j] <- 0 next } sum <- 0 sumv <- 0 for (p in ONEtoK) { d <- st[[p]] pos <- match(labels[c(i, j)], ROWNAMES[[p]]) if (all(!is.na(pos))) { ipos <- pos[1L] jpos <- pos[2L] dij <- d[ipos, jpos] sum <- sum + sp[p] * (a[p] * dij + a[astart[p] + ipos] + a[astart[p] + jpos]) sumv <- sumv + sp[p] * (a[p] * dij)^2 } } X[i, j] <- sum / w[i, j] V[i, j] <- sumv / (w[i, j])^2 } } list(X, V) } ape/R/SlowinskiGuyer.R0000644000175100001440000000657213003217100014354 0ustar hornikusers## SlowinskiGuyer.R (2016-10-23) ## Tests of Diversification Shifts with Sister-Clades ## Copyright 2011-2016 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. slowinskiguyer.test <- function(x, detail = FALSE) { r <- x[, 1] n <- x[, 1] + x[, 2] pp <- (n - r)/(n - 1) chi <- -2 * sum(log(pp)) df <- as.integer(2 * length(pp)) pval <- pchisq(chi, df, lower.tail = FALSE) res <- data.frame("chisq" = chi, "df" = df, "P.val" = pval, row.names = "") if (detail) res <- list(res, individual_Pvalues = pp) res } mcconwaysims.test <- function(x) { LRTp <- function(x) { f <- function(x) ifelse(x == 0, 0, x * log(x)) n1 <- x[1] n2 <- x[2] 1.629*(f(n1 - 1) - f(n1) + f(n2 - 1) - f(n2) - f(2) - f(n1 + n2 - 2) + f(n1 + n2)) } chi <- sum(apply(x, 1, LRTp)) pval <- pchisq(chi, df <- nrow(x), lower.tail = FALSE) data.frame("chisq" = chi, "df" = df, "P.val" = pval, row.names = "") } richness.yule.test <- function(x, t) { n1 <- x[, 1] n2 <- x[, 2] n <- c(n1, n2) tb <- c(t, t) .PrNt.Yule <- function(N, age, birth) { tmp <- -birth * age tmp + (N - 1) * log(1 - exp(tmp)) # on a log-scale } ## the functions to minimize: minusloglik0 <- function(l) -sum(.PrNt.Yule(n, tb, l)) minusloglika <- function(l) -sum(.PrNt.Yule(n1, t, l[1])) - sum(.PrNt.Yule(n2, t, l[2])) ## initial values (moment estimators): ipa <- c(mean(log(n1)/t), mean(log(n2)/t)) ip0 <- mean(ipa) out0 <- nlminb(ip0, minusloglik0, lower = 0, upper = 1) outa <- nlminb(ipa, minusloglika, lower = c(0, 0), upper = c(1, 1)) chi <- 2 * (out0$objective - outa$objective) pval <- pchisq(chi, 1, lower.tail = FALSE) data.frame(chisq = chi, df = 1, P.val = pval, row.names = "") } diversity.contrast.test <- function(x, method = "ratiolog", alternative = "two.sided", nrep = 0, ...) { method <- match.arg(method, c("ratiolog", "proportion", "difference", "logratio")) alternative <- match.arg(alternative, c("two.sided", "less", "greater")) minmax <- t(apply(x, 1, sort)) # sort all rows DIFF <- x[, 1] - x[, 2] SIGN <- sign(DIFF) CONTRAST <- switch(method, "ratiolog" = { if (any(minmax == 1)) minmax <- minmax + 1 # prevent division by 0 ## Note: if min = max, no need to set the contrast ## to zero since this is done with sign() log(minmax[, 2]) / log(minmax[, 1]) }, "proportion" = minmax[, 2] / (minmax[, 2] + minmax[, 1]), "difference" = abs(DIFF), "logratio" = log(minmax[, 1] / minmax[, 2])) y <- SIGN * CONTRAST # the signed contrasts if (nrep) { n <- length(SIGN) RND <- replicate(nrep, sum(sample(c(-1, 1), size = n, replace = TRUE) * CONTRAST)) cases <- switch(alternative, "two.sided" = sum(abs(RND) > sum(y)), "less" = sum(RND < sum(y)), "greater" = sum(RND > sum(y))) cases/nrep } else wilcox.test(x = y, alternative = alternative, ...)$p.value } ape/R/zzz.R0000644000175100001440000000032012465112403012207 0ustar hornikusers## zzz.R (2009-01-12) ## Library Loading ## Copyright 2003-2009 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. .PlotPhyloEnv <- new.env() ape/R/scales.R0000644000175100001440000001116212465112403012632 0ustar hornikusers## scales.R (2014-08-21) ## Add a Scale Bar or Axis to a Phylogeny Plot ## add.scale.bar: add a scale bar to a phylogeny plot ## axisPhylo: add a scale axis on the side of a phylogeny plot ## Copyright 2002-2014 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. add.scale.bar <- function(x, y, length = NULL, ask = FALSE, lwd = 1, lcol = "black", ...) { lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv) direc <- lastPP$direction if (is.null(length)) { nb.digit <- if (direc %in% c("rightwards", "leftwards")) diff(range(lastPP$xx)) else diff(range(lastPP$yy)) length <- pretty(c(0, nb.digit) / 6, 1)[2] # by Klaus } if (ask) { cat("\nClick where you want to draw the bar\n") x <- unlist(locator(1)) y <- x[2] x <- x[1] } else if (missing(x) || missing(y)) { if (lastPP$type %in% c("phylogram", "cladogram")) { switch(direc, "rightwards" = { x <- 0 y <- 1 }, "leftwards" = { x <- max(lastPP$xx) y <- 1 }, "upwards" = { x <- max(lastPP$xx) y <- 0 }, "downwards" = { x <- 1 y <- max(lastPP$yy) }) } else { direc <- "rightwards" # just to be sure for below x <- lastPP$x.lim[1] y <- lastPP$y.lim[1] } } switch(direc, "rightwards" = { segments(x, y, x + length, y, col = lcol, lwd = lwd) text(x + length * 1.1, y, as.character(length), adj = c(0, 0.5), ...) }, "leftwards" = { segments(x - length, y, x, y, col = lcol, lwd = lwd) text(x - length * 1.1, y, as.character(length), adj = c(1, 0.5), ...) }, "upwards" = { segments(x, y, x, y + length, col = lcol, lwd = lwd) text(x, y + length * 1.1, as.character(length), adj = c(0, 0.5), srt = 90, ...) }, "downwards" = { segments(x, y - length, x, y, col = lcol, lwd = lwd) text(x, y - length * 1.1, as.character(length), adj = c(0, 0.5), srt = 270, ...) }) } axisPhylo <- function(side = 1, root.time = NULL, backward = TRUE, ...) { lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv) type <- lastPP$type if (type == "unrooted") stop("axisPhylo() not available for unrooted plots; try add.scale.bar()") if (type == "radial") stop("axisPhylo() not meaningful for this type of plot") if (is.null(root.time)) root.time <- lastPP$root.time if (type %in% c("phylogram", "cladogram")) { xscale <- if (lastPP$direction %in% c("rightwards", "leftwards")) range(lastPP$xx) else range(lastPP$yy) tmp <- lastPP$direction %in% c("leftwards", "downwards") tscale <- c(0, xscale[2] - xscale[1]) if (xor(backward, tmp)) tscale <- tscale[2:1] if (!is.null(root.time)) { tscale <- tscale + root.time if (backward) tscale <- tscale - xscale[2] } ## the linear transformation between the x-scale and the time-scale: beta <- diff(xscale) / diff(tscale) alpha <- xscale[1] - beta * tscale[1] lab <- pretty(tscale) x <- beta * lab + alpha axis(side = side, at = x, labels = lab, ...) } else { # type == "fan" n <- lastPP$Ntip xx <- lastPP$xx[1:n]; yy <- lastPP$yy[1:n] r0 <- max(sqrt(xx^2 + yy^2)) firstandlast <- c(1, n) theta0 <- mean(atan2(yy[firstandlast], xx[firstandlast])) x0 <- r0 * cos(theta0); y0 <- r0 * sin(theta0) inc <- diff(pretty(c(0, r0))[1:2]) srt <- 360*theta0/(2*pi) coef <- -1 if (abs(srt) > 90) { srt <- srt + 180 coef <- 1 } len <- 0.025 * r0 # the length of tick marks r <- r0 while (r > 1e-8) { x <- r * cos(theta0); y <- r * sin(theta0) if (len/r < 1) { ra <- sqrt(len^2 + r^2); thetaa <- theta0 + coef * asin(len/r) xa <- ra * cos(thetaa); ya <- ra * sin(thetaa) segments(xa, ya, x, y) text(xa, ya, r0 - r, srt = srt, adj = c(0.5, 1.1), ...) } r <- r - inc } segments(x, y, x0, y0) } } ape/R/reorder.phylo.R0000644000175100001440000000611213013630750014153 0ustar hornikusers## reorder.phylo.R (2016-10-04) ## Internal Reordering of Trees ## Copyright 2006-2016 Emmanuel Paradis ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. .reorder_ape <- function(x, order, index.only, nb.tip, io) { nb.edge <- dim(x$edge)[1] if (!is.null(attr(x, "order"))) if (attr(x, "order") == order) if (index.only) return(1:nb.edge) else return(x) nb.node <- x$Nnode if (nb.node == 1) if (index.only) return(1:nb.edge) else return(x) ## I'm adding the next check for badly conformed trees to avoid R ## crashing (2013-05-17): if (nb.node >= nb.tip) stop("tree apparently badly conformed") if (io == 3) { x <- reorder(x) neworder <- .C(neworder_pruningwise, as.integer(nb.tip), as.integer(nb.node), as.integer(x$edge[, 1]), as.integer(x$edge[, 2]), as.integer(nb.edge), integer(nb.edge))[[6]] } else { neworder <- .C(neworder_phylo, as.integer(nb.tip), as.integer(x$edge[, 1]), as.integer(x$edge[, 2]), as.integer(nb.edge), integer(nb.edge), io, NAOK = TRUE)[[5]] } if (index.only) return(neworder) x$edge <- x$edge[neworder, ] if (!is.null(x$edge.length)) x$edge.length <- x$edge.length[neworder] attr(x, "order") <- order x } reorder.phylo <- function(x, order = "cladewise", index.only = FALSE, ...) { ORDER <- c("cladewise", "postorder", "pruningwise") io <- pmatch(order, ORDER) if (is.na(io)) stop("ambiguous order") order <- ORDER[io] .reorder_ape(x, order, index.only, length(x$tip.label), io) } reorder.multiPhylo <- function(x, order = "cladewise", ...) { ORDER <- c("cladewise", "postorder", "pruningwise") io <- pmatch(order, ORDER) if (is.na(io)) stop("ambiguous order") order <- ORDER[io] oc <- oldClass(x) class(x) <- NULL labs <- attr(x, "TipLabel") x <- if (is.null(labs)) lapply(x, reorder.phylo, order = order) else lapply(x, .reorder_ape, order = order, nb.tip = length(labs), io = io) class(x) <- oc x } rotateConstr <- function(phy, constraint) { D <- match(phy$tip.label, constraint) n <- Ntip(phy) P <- c(as.list(1:n), prop.part(phy)) e1 <- phy$edge[, 1L] e2 <- phy$edge[, 2L] foo <- function(node) { i <- which(e1 == node) # the edges where 'node' is ancestral desc <- e2[i] # the descendants of 'node' ## below, min() seems to work better than median() which ## seems to work better than mean() which seems to work ## better than sum() o <- order(sapply(desc, function(x) min(D[P[[x]]]))) for (k in o) { j <<- j + 1L neworder[j] <<- i[k] if ((dk <- desc[k]) > n) foo(dk) } } neworder <- integer(Nedge(phy)) j <- 0L foo(n + 1L) phy$edge <- phy$edge[neworder, ] if (!is.null(phy$edge.length)) phy$edge.length <- phy$edge.length[neworder] attr(phy, "order") <- "cladewise" phy } ape/R/read.caic.R0000644000175100001440000000416112465112403013172 0ustar hornikusers## read.caic.R (2005-09-21) ## Read Tree File in CAIC Format ## Copyright 2005 Julien Dutheil ## This file is part of the R-package `ape'. ## See the file ../COPYING for licensing issues. read.caic <- function(file, brlen=NULL, skip = 0, comment.char="#", ...) { text <- scan(file = file, what = character(), sep="\n", skip = skip, comment.char = comment.char, ...) # Parse the whole file: n <- length(text) / 2 nodes <- 1:n; leaf.names <- character(n) patterns <- character(n) lengths <- numeric(n) for(i in 1:n) { leaf.names[i] <- text[2*i] patterns[i] <- text[2*i-1] lengths[i] <- nchar(patterns[i]) } # Sort all patterns if not done: i <- order(patterns); leaf.names <- leaf.names[i] patterns <- patterns[i] lengths <- lengths[i] # This inner function compares two patterns: test.patterns <- function(p1, p2) { t1 <- strsplit(p1, split="")[[1]] t2 <- strsplit(p2, split="")[[1]] if(length(t1) == length(t2)) { l <- length(t1) if(l==1) return(TRUE) return(all(t1[1:(l-1)]==t2[1:(l-1)]) & t1[l] != t2[l]) } return(FALSE) } # The main loop: while(length(nodes) > 1) { # Recompute indexes: index <- logical(length(nodes)) maxi <- max(lengths) for(i in 1:length(nodes)) { index[i] <- lengths[i] == maxi } i <- 1 while(i <= length(nodes)) { if(index[i]) { p <- paste("(",nodes[i],sep="") c <- i+1 while(c <= length(nodes) && index[c] && test.patterns(patterns[i], patterns[c])) { p <- paste(p, nodes[c], sep=",") c <- c+1 } if(c-i < 2) stop("Unvalid format.") p <- paste(p, ")", sep="") nodes[i] <- p patterns[i]<- substr(patterns[i],1,nchar(patterns[i])-1) lengths[i] <- lengths[i]-1 nodes <- nodes [-((i+1):(c-1))] lengths <- lengths [-((i+1):(c-1))] patterns <- patterns[-((i+1):(c-1))] index <- index [-((i+1):(c-1))] } i <- i+1 } } # Create a 'phylo' object and return it: phy <- read.tree(text=paste(nodes[1],";", sep="")) phy$tip.label <- leaf.names; if(!is.null(brlen)) { br <- read.table(file=brlen) phy$edge.length <- br[,1] } return(phy) } ape/vignettes/0000755000175100001440000000000013017516351013047 5ustar hornikusersape/vignettes/ape.bib0000644000175100001440000000264210775732360014306 0ustar hornikusers@STRING{Ev = {Evolution}} @STRING{SZ = {Systematic Zoology}} @STRING{ny = {New York}} @book{Cliff1973, Author = {Cliff, A. D. and Ord, J. K.}, Title = {{Spatial Autocorrelation}}, Publisher = {Pion}, Address = {London}, Year = 1973} @incollection{Cliff1981, Author = {Cliff, A. D. and Ord, J. K.}, Title = {{Spatial and temporal analysis: autocorrelation in space and time}}, BookTitle = {{Quantitative Geography: A British View}}, Editor = {Wrigley, E. N. and Bennett, R. J.}, Publisher = {Routledge \& Kegan Paul}, Address = {London}, Pages = {104-110}, Year = 1981} @article{Cheverud1985, Author = {Cheverud, J. M. and Dow, M. M. and Leutenegger, W.}, Title = {{The quantitative assessment of phylogenetic constraints in comparative analyses: sexual dimorphism in body weight among primates}}, Journal = Ev, Volume = {39}, Pages = {1335-1351}, Year = 1985} @article{Gittleman1990, Author = {Gittleman, J. L. and Kot, M.}, Title = {{Adaptation: statistics and a null model for estimating phylogenetic effects}}, Journal = SZ, Volume = {39}, Pages = {227-241}, Year = 1990} @article{Moran1950, Author = {Moran, P. A. P.}, Title = {{Notes on continuous stochastic phenomena}}, Journal = {Biometrika}, Volume = {37}, Pages = {17-23}, Year = 1950} @book{Paradis2006, Author = {Paradis, E.}, Title = {{Analysis of Phylogenetics and Evolution with R}}, Publisher = {Springer}, Address = ny, Year = 2006} ape/vignettes/MoranI.Rnw0000644000175100001440000003106012627132546014732 0ustar hornikusers\documentclass[a4paper]{article} %\VignetteIndexEntry{Moran's I} %\VignettePackage{ape} \usepackage{fancyvrb} \usepackage{color} \newcommand{\code}{\texttt} \newcommand{\pkg}{\textsf} \newcommand{\ape}{\pkg{ape}} \newcommand{\ade}{\pkg{ade4}} \newcommand{\spatial}{\pkg{spatial}} \renewcommand{\sp}{\pkg{sp}} \author{Emmanuel Paradis} \title{Moran's Autocorrelation Coefficient in Comparative Methods} \begin{document} \maketitle <>= options(width=60) @ This document clarifies the use of Moran's autocorrelation coefficient to quantify whether the distribution of a trait among a set of species is affected or not by their phylogenetic relationships. \section{Theoretical Background} Moran's autocorrelation coefficient (often denoted as $I$) is an extension of Pearson product-moment correlation coefficient to a univariate series \cite{Cliff1973, Moran1950}. Recall that Pearson's correlation (denoted as $\rho$) between two variables $x$ and $y$ both of length $n$ is: \begin{displaymath} \rho = \frac{\displaystyle\sum_{i=1}^n(x_i - \bar{x})(y_i - \bar{y})}{\displaystyle\left[{\sum_{i=1}^n(x_i - \bar{x})^2\sum_{i=1}^n(y_i - \bar{y})^2}\right]^{1/2}}, \end{displaymath} where $\bar{x}$ and $\bar{y}$ are the sample means of both variables. $\rho$ measures whether, on average, $x_i$ and $y_i$ are associated. For a single variable, say $x$, $I$ will measure whether $x_i$ and $x_j$, with $i\ne j$, are associated. Note that with $\rho$, $x_i$ and $x_j$ are {\em not} associated since the pairs $(x_i,y_i)$ are assumed to be independent of each other. In the study of spatial patterns and processes, we may logically expect that close observations are more likely to be similar than those far apart. It is usual to associate a {\em weight} to each pair $(x_i,x_j)$ which quantifies this \cite{Cliff1981}. In its simplest form, these weights will take values 1 for close neighbours, and 0 otherwise. We also set $w_{ii}=0$. These weights are sometimes referred to as a {\em neighbouring function}. $I$'s formula is: \begin{equation} I = \frac{n}{S_0} \frac{\displaystyle\sum_{i=1}^n \sum_{j=1}^n w_{ij}(x_i - \bar{x})(x_j - \bar{x})}{\displaystyle\sum_{i=1}^n (x_i - \bar{x})^2},\label{eq:morani} \end{equation} where $w_{ij}$ is the weight between observation $i$ and $j$, and $S_0$ is the sum of all $w_{ij}$'s: \begin{displaymath} S_0 = \sum_{i=1}^n \sum_{j=1}^n w_{ij}. \end{displaymath} Quite not so intuitively, the expected value of $I$ under the null hypothesis of no autocorrelation is not equal to zero but given by $I_0 = -1/(n-1)$. The expected variance of $I_0$ is also known, and so we can make a test of the null hypothesis. If the observed value of $I$ (denoted $\hat{I}$) is significantly greater than $I_0$, then values of $x$ are positively autocorrelated, whereas if $\hat{I} c,\\ \end{array}\] where $c$ is a cut-off phylogenetic distance above which the species are considered to have evolved completely independently, and $\alpha$ is a coefficient (see \cite{Gittleman1990} for details). By analogy to the use of a spatial correlogram where coefficients are calculated assuming different sizes of the ``neighbourhood'' and then plotted to visualize the spatial extent of autocorrelation, they proposed to calculate $I$ at different taxonomic levels. \section{Implementation in \ape} From version 1.2-6, \ape\ has functions \code{Moran.I} and \code{correlogram.formula} implementing the approach developed by Gittleman \& Kot. There was an error in the help pages of \code{?Moran.I} (corrected in ver.\ 2.1) where the weights were referred to as ``distance weights''. This has been wrongly interpreted in my book \cite[pp.~139--142]{Paradis2006}. The analyses below aim to correct this. \subsection{Phylogenetic Distances} The data, taken from \cite{Cheverud1985}, are the log-transformed body mass and longevity of five species of primates: <<>>= body <- c(4.09434, 3.61092, 2.37024, 2.02815, -1.46968) longevity <- c(4.74493, 3.3322, 3.3673, 2.89037, 2.30259) names(body) <- names(longevity) <- c("Homo", "Pongo", "Macaca", "Ateles", "Galago") @ The tree has branch lengths scaled so that the root age is one. We read the tree with \ape, and plot it: <>= library(ape) trnwk <- "((((Homo:0.21,Pongo:0.21):0.28,Macaca:0.49):0.13,Ateles:0.62)" trnwk[2] <- ":0.38,Galago:1.00);" tr <- read.tree(text = trnwk) plot(tr) axisPhylo() @ We choose the weights as $w_{ij}=1/d_{ij}$, where the $d$'s is the distances measured on the tree: <<>>= w <- 1/cophenetic(tr) w @ Of course, we must set the diagonal to zero: <<>>= diag(w) <- 0 @ We can now perform the analysis with Moran's $I$: <<>>= Moran.I(body, w) @ Not surprisingly, the results are opposite to those in \cite{Paradis2006} since, there, the distances (given by \code{cophenetic(tr)}) were used as weights. (Note that the argument \code{dist} has been since renamed \code{weight}.\footnote{The older code was actually correct; nevertheless, it has been rewritten, and is now much faster. The documentation has been clarified. The function \code{correlogram.phylo}, which computed Moran's $I$ for a tree given as argument using the distances among taxa, has been removed.}) We can now conclude for a slighly significant positive phylogenetic correlation among body mass values for these five species. The new version of \code{Moran.I} gains the option \code{alternative} which specifies the alternative hypothesis (\code{"two-sided"} by default, i.e., H$_1$: $I \ne I_0$). As expected from the above result, we divide the $P$-value be two if we define H$_1$ as $I > I_0$: <<>>= Moran.I(body, w, alt = "greater") @ The same analysis with \code{longevity} gives: <<>>= Moran.I(longevity, w) @ As for \code{body}, the results are nearly mirrored compared to \cite{Paradis2006} where a non-significant negative phylogenetic correlation was found: it is now positive but still largely not significant. \subsection{Taxonomic Levels} The function \code{correlogram.formula} provides an interface to calculate Moran's $I$ for one or several variables giving a series of taxonomic levels. An example of its use was provided in \cite[pp.~141--142]{Paradis2006}. The code of this function has been simplified, and the graphical presentation of the results have been improved. \code{correlogram.formula}'s main argument is a formula which is ``sliced'', and \code{Moran.I} is called for each of these elements. Two things have been changed for the end-user at this level: \begin{enumerate} \item In the old version, the rhs of the formula was given in the order of the taxonomic hierarchy: e.g., \code{Order/SuperFamily/Family/Genus}. Not respecting this order resulted in an error. In the new version, any order is accepted, but the order given is then respected when plotted the correlogram. \item Variable transformations (e.g., log) were allowed on the lhs of the formula. Because of the simplification of the code, this is no more possible. So it is the responsibility of the user to apply any tranformation before the analysis. \end{enumerate} Following Gittleman \& Kot \cite{Gittleman1990}, the autocorrelation at a higher level (e.g., family) is calculated among species belonging to the same category and to different categories at the level below (genus). To formalize this, let us write the different levels as $X^1/X^2/X^3/\dots/X^n$ with $X^n$ being the lowest one (\code{Genus} in the above formula): \begin{displaymath} \begin{array}{l} \left.\begin{array}{ll} w_{ij}=1 & \mathrm{if}\ X_i^k = X_j^k\ \mathrm{and}\ X_i^{k+1} \ne X_j^{k+1}\\ w_{ij}=0 & \mathrm{otherwise}\\ \end{array} \right\} k < n \\\\ \left.\begin{array}{ll} w_{ij}=1 & \mathrm{if}\ X_i^k = X_j^k\\ w_{ij}=0 & \mathrm{otherwise}\\ \end{array} \right\} k = n \end{array} \end{displaymath} This is thus different from the idea of a ``neighbourhood'' of different sizes, but rather similar to the idea of partial correlation where the influence of the lowest level is removed when considering the highest ones \cite{Gittleman1990}. To repeat the analyses on the \code{carnivora} data set, we first log$_{10}$-transform the variables mean body mass (\code{SW}) and the mean female body mass (\code{FW}): <<>>= data(carnivora) carnivora$log10SW <- log10(carnivora$SW) carnivora$log10FW <- log10(carnivora$FW) @ We first consider a single variable analysis (as in \cite{Paradis2006}): <>= fm1.carn <- log10SW ~ Order/SuperFamily/Family/Genus co1 <- correlogram.formula(fm1.carn, data = carnivora) plot(co1) @ A legend now appears by default, but can be removed with \code{legend = FALSE}. Most of the appearance of the graph can be customized via the option of the plot method (see \code{?plot.correlogram} for details). This is the same analysis than the one displayed on Fig.~6.3 of \cite{Paradis2006}. When a single variable is given in the lhs in \code{correlogram.formula}, an object of class \code{"correlogram"} is returned as above. If several variables are analysed simultaneously, the object returned is of class \code{"correlogramList"}, and the correlograms can be plotted together with the appropriate plot method: <>= fm2.carn <- log10SW + log10FW ~ Order/SuperFamily/Family/Genus co2 <- correlogram.formula(fm2.carn, data = carnivora) print(plot(co2)) @ By default, lattice is used to plot the correlograms on separate panels; using \code{lattice = FALSE} (actually the second argument, see \code{?plot.correlogramList}) makes a standard graph superimposing the different correlograms: <>= plot(co2, FALSE) @ The options are roughly the same than above, but do not have always the same effect since lattice and base graphics do not have the same graphical parameters. For instance, \code{legend = FALSE} has no effect if \code{lattice = TRUE}. \section{Implementation in \ade} The analysis done with \ade\ in \cite{Paradis2006} suffers from the same error than the one done with \code{Moran.I} since it was also done with a distance matrix. So I correct this below: \begin{Schunk} \begin{Sinput} > library(ade4) > gearymoran(w, data.frame(body, longevity)) \end{Sinput} \begin{Soutput} class: krandtest Monte-Carlo tests Call: as.krandtest(sim = matrix(res$result, ncol = nvar, byr = TRUE), obs = res$obs, alter = alter, names = test.names) Test number: 2 Permutation number: 999 Alternative hypothesis: greater Test Obs Std.Obs Pvalue 1 body -0.06256789 2.1523342 0.001 2 longevity -0.22990437 0.3461414 0.414 other elements: NULL \end{Soutput} \end{Schunk} The results are wholly consistent with those from \ape, but the estimated coefficients are substantially different. This is because the computational methods are not the same in both packages. In \ade, the weight matrix is first transformed as a relative frequency matrix with $\tilde{w}_{ij} = w_{ij}/S_0$. The weights are further transformed with: \begin{displaymath} p_{ij} = \tilde{w}_{ij} - \sum_{i=1}^n\tilde{w}_{ij}\sum_{j=1}^n\tilde{w}_{ij}, \end{displaymath} with $p_{ij}$ being the elements of the matrix denoted as $P$. Moran's $I$ is finally computed with $x^\mathrm{T}Px$. In \ape, the weights are first row-normalized: \begin{displaymath} w_{ij} \Big/ \sum_{i=1}^n w_{ij}, \end{displaymath} then eq.~\ref{eq:morani} is applied. Another difference between both packages, though less important, is that in \ade\ the weight matrix is forced to be symmetric with $(W+W^\mathrm{T})/2$. In \ape, this matrix is assumed to be symmetric, which is likely to be the case like in the examples above. \section{Other Implementations} Package \sp\ has several functions, including \code{moran.test}, that are more specifically targeted to the analysis of spatial data. Package \spatial\ has the function \code{correlogram} that computes and plots spatial correlograms. \section*{Acknowledgements} I am thankful to Thibaut Jombart for clarifications on Moran's $I$. \bibliographystyle{plain} \bibliography{ape} \end{document} ape/MD50000644000175100001440000004352313020051200011333 0ustar hornikuserseb723b61539feef013de476e68b5c50a *COPYING e28f0a5656abc88ffa75eb720a68e0ff *DESCRIPTION 6936565af4821e47088568525c3bda01 *NAMESPACE 854a025cb7e5da3e4fe230c0be950d08 *NEWS 0c7bc9101516fd26fb3ddbedbe25b6a3 *R/CADM.global.R e042efca1d8a00d4178204f5f481b64d *R/CADM.post.R a10ebb0e9ecf861eea483eb41da1bd23 *R/CDF.birth.death.R fdb9cfa0cbda82bda982b290693e44e3 *R/Cheverud.R 32741db1a4135fdd540d71a103d78d6f *R/DNA.R 2187a1289b767066d1efe1ebbe7c3b0c *R/MPR.R bb95af56d882b6162aa517a77140175e *R/MoranI.R 218b8cf3c13a700c757b7b2303dc897e *R/PGLS.R 6be0924b9f043abaee0968de5cf62aa6 *R/SDM.R 315ae41ee77b323b07e63ff861359ae2 *R/SlowinskiGuyer.R 8240ac5d3ec4c439e9a33a33f66e8428 *R/ace.R 4ce79cf3f3ff49bef989454d86d0c891 *R/additive.R 9fca35b1005cce7b2a260b553dd971a3 *R/alex.R 9fe874382f024a98f62a0ccfcd6d09ac *R/all.equal.phylo.R 06b049b681ab2e594124a2b010c5cddd *R/as.bitsplits.R c94018d5e792c72e20ce84085b2df9e7 *R/as.matching.R 86d55d04b20c1ecad73ea817866d632d *R/as.phylo.R 1bb4dcfb44a7485710ec7f599d4b2ee8 *R/as.phylo.formula.R 844a38494dd34adbe916bb9116cd0bc2 *R/balance.R 607d7d6bc0ec5559ce1de5b1d1aab0c1 *R/binaryPGLMM.R 76b5ca45b7210c85fdc20cd1579b33a2 *R/bind.tree.R a28930cdae07a271403e988e86a0c324 *R/biplot.pcoa.R 92d9db6d7c1150d1a7c9443fd3d5cb04 *R/birthdeath.R 4ee816e0dc69630d104fb5da4cc542c4 *R/branching.times.R b4557270916972166e13e76391bb0a69 *R/checkValidPhylo.R e43b5dec7eae6d4bf9371e50117bf6ed *R/cherry.R 5fd65efbdae6e0934e8bb42191142d4b *R/chronoMPL.R 74e1019810b06458e808a447bb099a91 *R/chronopl.R 8ae1af4a30c40d15676d70e180f3d593 *R/chronos.R 2a9983307f686facf6d9ec843d214f38 *R/clustal.R dedf66f0595977a11a7dbc2b0d2f56bb *R/coalescent.intervals.R c3d44d960238a711764aaeebe9570559 *R/collapse.singles.R 338accc0accb8e67f31db5a90c033d2f *R/collapsed.intervals.R 01e979242ba4667e48a80fd32c03f254 *R/compar.gee.R 89ce53eb1bb8c0fb36e95810cf7cd769 *R/compar.lynch.R 207154a3a9b9ebbe5d7c29995565dc82 *R/compar.ou.R 8d7c71929156744fd0e4fac370bf9456 *R/compute.brtime.R 0092074917dc5631dc62fb9a3016145c *R/cophenetic.phylo.R 13f2dac84d7b8a1da3df0e0c11b4ab1c *R/cophyloplot.R fd39268020a494980293c92d0971caca *R/corphylo.R 1c3460b48ed1e772c40e5993cd663d43 *R/dbd.R 3822f0bb0a9ed4c8c19654e86ef34359 *R/def.R 93480a5b64e0d37f5450891629557615 *R/delta.plot.R dfd5bb35f1cb1fd9154d023e0e4cfc2b *R/dist.gene.R c59b82a465d826b821896e0da82f1017 *R/dist.topo.R b28ced504fedeb7f991f7eba10ad06df *R/diversi.gof.R 8b2ec4004022afdc7e2cb42f2657b628 *R/diversi.time.R ea5fcbd0f207ab1d874c0d032392967d *R/drop.tip.R 1c4bdd6cf163aa4d605ed67249883ad4 *R/evonet.R fceafc86fae624fd9037403ad301d35a *R/ewLasso.R aa09abeb90ef891384128f978ffce843 *R/extract.popsize.R 5c29d3ee785da587f4ad5288ec36b76a *R/gammaStat.R 499b5f8596f40c32592fc85ee0e226ce *R/howmanytrees.R 68d848281455c4c91e9b91f16170e2f7 *R/identify.phylo.R 7d6ba4bcc70903878b1bba0565ac4722 *R/is.binary.tree.R be075b35bb032eaca5946abd14ded1e3 *R/is.compatible.R 35921387c705612d8f7c5baa06f9ab79 *R/is.monophyletic.R a7bd37de10eb3f5c02096dfb9a492307 *R/is.ultrametric.R 944879f7a9a134866f31d8476a07f9c1 *R/ladderize.R 65b2494ebd918c6f9a31c80e25370035 *R/lmorigin.R 1553fd068a844a4274c62b936e242131 *R/ltt.plot.R 0e3a341c99497686db7583eb0894ba77 *R/makeLabel.R 34069210fd7b12dda0979c45822e4d3a *R/makeNodeLabel.R a84000c0d7d2f53aec6a7105477f886a *R/mantel.test.R d2c16632492bfafd2ee18f2fe3d3d64a *R/matexpo.R 566ed17c837a32977cb1546880d253b0 *R/mcmc.popsize.R 61021f7af1175c46a743c7fee4cdc87e *R/me.R e1327a592199bac7ac8f670c3a068d46 *R/mrca.R a078728fb5907565f85b54b30e5bf83f *R/mst.R 93f3fe244219d565bb2e111ff249b540 *R/multi2di.R 0850fdd19c01d37ac632fc308632a463 *R/mvr.R 282308c27ac1e78e330711d635d2e572 *R/nj.R e3f22d0f260c43be87a17b0ab091e2bb *R/njs.R 5e43665c088ced872dd2a03f7adc2add *R/node.dating.R e4a0712fa45754cd02f5d3da6ef23204 *R/nodelabels.R ae2aeb0e8aef7f8d4b19939ca61b3482 *R/nodepath.R d9fd8e402e6fce6939a05332823a9390 *R/parafit.R fc0260f9e8e17fc1446117580bbc93cc *R/pcoa.R 431d25db557d480985ac16bfc3d6425c *R/phydataplot.R e71db002c66c277bfb57f6914ca143d4 *R/phymltest.R d04e04530104c16108684db049d715da *R/pic.R 198dfc699186f842a0cce2bedf4eabc9 *R/plot.phylo.R b31f836442e0a6dd739d446faffda284 *R/plot.phyloExtra.R e579ec65c808c29e1ecaae1501784b37 *R/plot.popsize.R 736506e2f67e90cf9326abead437d298 *R/plotPhyloCoor.R 1e2485437566ca9af99d93b4580cbbc2 *R/print.lmorigin.R d0e8bd41d5acc217fdee3578adcf635b *R/print.parafit.R 8c401518738b9cda403fa9f0eb382757 *R/rTrait.R 9c261f833a2f3325949b00f49a3d9d61 *R/read.GenBank.R b13dfb8f455b1c9e74a364085f72dbce *R/read.caic.R 740c43ccf599f0ea029fddf4361f5738 *R/read.dna.R b25674d229dfa4d2bf76a50e1874c690 *R/read.gff.R 12cc225d7dbe722e9e61cd3911de0b5a *R/read.nexus.R 13ce7f5c7d1bcb7101469d12651e99c8 *R/read.nexus.data.R 88e633c80886f5a6c9f2b34918452d15 *R/read.tree.R df2ac5d3de7185c7e26fc95b35192a40 *R/reconstruct.R 1770cbeb0312916ebe52647fc29a83fc *R/reorder.phylo.R 4400af9cbac48963c7cb287c51aad62c *R/root.R f584366b32e7414c669714ba5b84951b *R/rotate.R b7158b84c7ee7d9dcb2e0abeb6005cb0 *R/rtree.R be352a2ab62b61eaf8186a7f9b682798 *R/rtt.R d099c8987470c4506511be54e29a5ddd *R/scales.R d2e06f8288af941a00c46248b586225a *R/skyline.R 1f82059f740388b7430b2359e54a147f *R/skylineplot.R 9c7b02a4625099f715700fb868226b0f *R/speciesTree.R 28fce999b31a0c7d53816cec6916981f *R/subtreeplot.R bcc8f1fc8363728caba82129412d9e31 *R/subtrees.R e9daa8dbb2eef717c51a73e92669ae31 *R/summary.phylo.R 8fbd1589f5d98d76b1154cffb8d4d1f5 *R/treePop.R b5081fca8758fe4458183c3e25e3e661 *R/triangMtd.R 6e92716e8004feb088d5c093bad3828f *R/unique.multiPhylo.R 2937379ad9e91e263b7956c264926466 *R/varcomp.R a40ae9ad30c221d4ed14b90e8b406f93 *R/vcv.phylo.R 31b3bb1feed474692f07fcebe3a61ac7 *R/vcv2phylo.R 16d5511c871e41b9b2673052e03c8b33 *R/which.edge.R 43b881eea3763d0079e88012e0b84d37 *R/write.dna.R 4e5d7a7904fe6496a44c4b69f674290b *R/write.nexus.R 89496c0df70205654456d3b7bb7ba41f *R/write.nexus.data.R 17d72a136a8131ea46ef9a20fcfd4d36 *R/write.tree.R 774ce72875903259aade5344f9a70aa4 *R/yule.R c8d3aa3fe64e75e61af07a1b11c74f3f *R/yule.time.R 1eb44ff9e5a036eb845faa1598ce5009 *R/zoom.R 3387c0d0c1f913f8471e1bb34bd2e516 *R/zzz.R b77a7eef47f2f8d2874a638562f49ea4 *build/vignette.rds db9083e8750aff839d5ebf3ed982f1f1 *data/HP.links.rda 9d9f9232839665422709ded1e541d038 *data/bird.families.rda a14a6df0f3a735ebc056065077788c90 *data/bird.orders.rda f74f9ed80c04756021cc093d40ca9ff9 *data/carnivora.csv.gz 4eaf8cbaefa2e8f8d395a9b482ee9967 *data/chiroptera.rda 1c74c3b99d08b0e17eea3ec1065c12d2 *data/cynipids.rda 7fe760c2f3b4deba0554aae6138cb602 *data/gopher.D.rda 1c8e6ca4c99ce95b2f2692c15b6d768d *data/hivtree.newick.rda 8d14f95319d0a5cdc8faa60a1d0085ce *data/hivtree.table.txt.gz 31be81fe3faca11f98d3e74c090bc59e *data/lice.D.rda 38edbd84a0a067322c40db8d71fb1289 *data/lmorigin.ex1.rda e3ce9e3444182fea2e65df2e150ea0db *data/lmorigin.ex2.rda ce7a56faebdf286fdf5ba6c8c3699a79 *data/mat3.RData e2d1339025ed901009bfed58dc6505ff *data/mat5M3ID.RData 101d0ab2e981b0987cde704a2dee1d8d *data/mat5Mrand.RData 39e4fece2bdc527d7a9d4d83d023a947 *data/woodmouse.rda 828290996b613493f96e0fab024beebb *inst/CITATION 3f54f3775bcf382e25df2a12228894f6 *inst/doc/MoranI.R 2277b0efdb2f70dfdc5df8278702c6b6 *inst/doc/MoranI.Rnw 31ca3eafda127eab7c4799764f8fa68c *inst/doc/MoranI.pdf db2ed5302bddcfac232dcd6fabe4a651 *man/AAbin.Rd e6876b193a0df06697c788a8e48cf4bc *man/CADM.global.Rd dfa15a3e3bb57c9b21a30b8d5d790c62 *man/DNAbin.Rd d94f358593695b1713840df5a8c000ba *man/DNAbin2indel.Rd 8b9bc214e32cde4c6e5970e48ff30c5f *man/Initialize.corPhyl.Rd 4ed78ca9d87b32808b064e0ecd6756cb *man/LTT.Rd ff05fd6fa0a2750b53abf025cdc021d3 *man/MPR.Rd 303135aa8664be5cb518e0cbf2018b2c *man/MoranI.Rd 17486c0fd29fb6f4a752c53fe37142c4 *man/SDM.Rd b4b2d3c708bf1ebca6f1f3b4cb752243 *man/ace.Rd 60adac0f324c7b08a756d8f45c02b024 *man/add.scale.bar.Rd 0d68dd79c42bad2f3a68635ba75a59b0 *man/additive.Rd 25a2859708b9a281a0d682e4376f3f53 *man/alex.Rd 2ff5d30c6fb1c5458643f1b3c09e76da *man/all.equal.DNAbin.Rd f0b85d459edb5ead2e6d39a86cbb350c *man/all.equal.phylo.Rd c3bd9e7b02831d6086fabd5de6db917c *man/alview.Rd 42489c977f59031dc17a0ba7e55663b6 *man/ape-internal.Rd f84e59c805efa00000d775b81bf9f8d0 *man/ape-package.Rd 5bba4ae4bfc66b613855cfc182d9b1bc *man/as.alignment.Rd 2771f272ad46b279022892d9f5d21eb2 *man/as.bitsplits.Rd 4f014cf2923e2eab6188acd48e8096fa *man/as.matching.Rd 78ff1c24cc3b91de1bf33ca5f45c7af5 *man/as.phylo.Rd 219cff7b94e167e18f4f9cd99cc8efc3 *man/as.phylo.formula.Rd c1bb2b36369966cc61f802daa27921a2 *man/axisPhylo.Rd ad514b163e70bfbc11dfd34a450799f8 *man/balance.Rd 868d03a447b2375bd9e99cde899cedea *man/base.freq.Rd 524a1163eac56d1fc7f65bcd6c74a8d0 *man/bd.ext.Rd 5f1e61abe5908708f503cb2626a1b5e6 *man/bd.time.Rd f929bc1b6391c57a6b0099c4561fd7be *man/binaryPGLMM.Rd 814a2437b237e083dfb91b404a8ede60 *man/bind.tree.Rd 822558d4f7ee04257b2c903c53ec4344 *man/bionj.Rd 71a008cfe65c4f524a5b66e68bbf81ab *man/bird.families.Rd 0e41770e1e6d0b8d90c4cf51049213cb *man/bird.orders.Rd ef1c15d5d93410c21179997431112209 *man/birthdeath.Rd 87fafa0226908ea87c6d11aecc9bf72c *man/boot.phylo.Rd 5a64b90d3a6c7a8204946b00f45f4cfc *man/branching.times.Rd c808768a942998429ecc9fc925f3f3a3 *man/c.phylo.Rd 9d3f9614732671a610cc8a37454885e2 *man/carnivora.Rd 953b3c21c60a38e8e53ec6894170dd36 *man/checkAlignment.Rd 5ff8c7e8fad519d978f166948c03059c *man/checkValidPhylo.Rd 64c3996ca6bcc97d0d2e2cf3361f8f71 *man/cherry.Rd f82a24dc4bb17b5675ec7b422d575587 *man/chiroptera.Rd b40dd77fd2529626e983ee0300be6781 *man/chronoMPL.Rd c1f01c6200b2f1e2901d45d40daae404 *man/chronopl.Rd 506d0332fb092ab87ca7674faef63ab7 *man/chronos.Rd 1edeca1697a517d946b2062d20b90cbb *man/clustal.Rd 866af6e8d769b3d6972ef8e1ac849a12 *man/coalescent.intervals.Rd 18c77b4104aa22d3e6cb88339f2eff90 *man/collapse.singles.Rd bff5a7826f5a39767601e32ceb776247 *man/collapsed.intervals.Rd 301f271dc131de2efc3294d31f03afed *man/compar.cheverud.Rd 4d8ee141d7b6b323ef5ee9446000ae32 *man/compar.gee.Rd 4317f601ba2eef4e5730dc4274172f0f *man/compar.lynch.Rd 8b079bc165c375f823c40074ad9106c6 *man/compar.ou.Rd 70a4c1daab3326b147758128826248d6 *man/compute.brlen.Rd dbb4b5b1d5136bd32660699d9d4cc197 *man/compute.brtime.Rd cea3751e04bbda7eda58a8ca96466bac *man/consensus.Rd 1e5b635a08fe0e1242801ff0caec9d0d *man/cophenetic.phylo.Rd 1ca9ec0cb824468adc03884c940c7aa3 *man/cophyloplot.Rd b83a1aa72b6b94ccd7e519eaba7def04 *man/corBlomberg.Rd a210fe55aacb847936004458d4089b6d *man/corBrownian.Rd 2ee5e8585f40c2beff6dc9ee993c22e1 *man/corClasses.Rd 673c9738c6ff3e237e11d35d62629bcc *man/corGrafen.Rd 628a4d6339f82e7ef3debe96d19ffa02 *man/corMartins.Rd 202f26f668a8fc7973d50696dcdd6cd4 *man/corPagel.Rd e259ee771509883d3afe8eafd41e9cb1 *man/corphylo.Rd d7eb9b4fdf7036e82b5964bfd85e5e36 *man/correlogram.formula.Rd c199605f9d353b303acad4896f9b39a5 *man/cynipids.Rd 34164e368efd0d5d961fe62e9ede75e8 *man/dbd.Rd c0763a70c4965a6b03df3e5be68e450d *man/def.Rd 95621da51b61fe6a551369222015192f *man/del.gaps.Rd fbcd1d4bcf74e21fc93c195c7af3db98 *man/delta.plot.Rd d4c1853e139f84101de2b9309823f366 *man/dist.dna.Rd 38011e81d28a120d88eead09e62c154a *man/dist.gene.Rd 4042a6c6113e8a0eb3a1ffaf51138f0f *man/dist.topo.Rd c7cc398115be066740ca4fb037394727 *man/diversi.gof.Rd d646ea0343999bd0e38e86dcf6c12018 *man/diversi.time.Rd da8898476bb15b627b34ee1093b9aeb4 *man/diversity.contrast.test.Rd 55ed69cf42cb2fb768467870ef5e4c99 *man/drop.tip.Rd 6ae02a689abea279f7e6650678aa7ae2 *man/edges.Rd 7ad398603675bd4e0e1c5f5eeb1105bc *man/evonet.Rd 28675cca1ce5738ba2cb3148d8e935cb *man/ewLasso.Rd fd760ac491d39a6c9bb32c95995e87b3 *man/fastme.Rd eea313e8ee32597b4cec120d23113642 *man/gammaStat.Rd 3991fa7864e326579f1ab8b671095e4b *man/hivtree.Rd 18012643a904f657fc5f5896f3d14054 *man/howmanytrees.Rd 86c49d080fdffd614d8056021e91cc55 *man/identify.phylo.Rd dc00b2b43a44f4ba7ea76ea23a12c615 *man/image.DNAbin.Rd 0ede757d7bed82216980d3c4fd592cb6 *man/is.binary.tree.Rd 80a5a228a43679edf75903590253a875 *man/is.compatible.Rd d2de8fd9549ef01a1dddeb726dd77fcf *man/is.monophyletic.Rd ad9e7316219c3238b44b02d55c44b4d3 *man/is.ultrametric.Rd 3f6ff8340b6c9770a1f4d2fed72a295d *man/kronoviz.Rd 8edde42ffc43737ba82e18594801421f *man/label2table.Rd 2afa6305e48e4c47a7d94d46401f85a3 *man/ladderize.Rd 4b86460e4e5d993abf13c99b9744dbd6 *man/lmorigin.Rd 21bb31db5bcc8d8650467ef73fe0c0d3 *man/ltt.plot.Rd 7ca1aeffd0cd8106e00d0ee1952b5ccb *man/makeLabel.Rd 491c376d22c2f05443840b3835dc6e25 *man/makeNodeLabel.Rd 817b23b342fe170de6500d13d9f54c82 *man/mantel.test.Rd 97cf5ddb9352b0545ed225d16d750ffb *man/mat3.Rd f56f6f49c89c6bc850a7aee1bce5e0bd *man/mat5M3ID.Rd 0d8eb60696c80de3cc9cc85ba66373a5 *man/mat5Mrand.Rd 69ae0cb181240bb8ec168e69f1ba44bb *man/matexpo.Rd a8b9d6b04d35d75f43d1b283361a1642 *man/mcconwaysims.test.Rd 8c3dfdb6c70caee1051b1e576e3eaa74 *man/mcmc.popsize.Rd d974e980cb56568e337ef4e926f43617 *man/mixedFontLabel.Rd dbcdc231c2f1f221818307bb33486159 *man/mrca.Rd 5c88230ad597ea9fe41536a8321c326b *man/mst.Rd b74a379a0a9b80941118922ca7843b02 *man/multi2di.Rd 029b04adeafe89ea5edf9a1ab00cd154 *man/multiphylo.Rd 00fb7ade93c2dd887be27e3dad8e2115 *man/mvr.Rd 3df9e16b8a09df3f1dba5c4327a635fc *man/nj.Rd 9ea7d5899a190171de4165e3240de62e *man/njs.Rd 8a9189a62be3d0e871deb20be5bd6e8a *man/node.dating.Rd a589b4cc04505185dc9ef1817c7ae304 *man/node.depth.Rd ba754eba67181a1c39d417ffd9d23b76 *man/nodelabels.Rd 447ae03684ff56a4a24932aec182acf3 *man/nodepath.Rd c2e2f35f4e233265c86b7967ec2d0630 *man/parafit.Rd 89db814a5fc2e9fa5f0b9f4ad2f0d070 *man/pcoa.Rd 583200254fe87b2a36fc18a88825298d *man/phydataplot.Rd 6dfa52711bab351bbcfe2624690eb730 *man/phymltest.Rd 447941526b92322c52b5cfe367cb7088 *man/pic.Rd 0363aa3fa3e86160934e2359c8ac5323 *man/pic.ortho.Rd 265527313d479d3625df7680c7479cd1 *man/plot.correlogram.Rd d23d21863b2dffa5388f3fc128368af4 *man/plot.phylo.Rd 896198fa3a0ce916346c8b507bf707bf *man/plot.phyloExtra.Rd 6bb1cf751772b9b6acf560b5f3c6f3c1 *man/plot.varcomp.Rd e0e2f60baddaaaa8f1d9796bd50a8ba2 *man/plotTreeTime.Rd b24438c42cea969302ec6ba61002426e *man/print.phylo.Rd 80bf68fd21b5e665329cf30b10a1655f *man/rTraitCont.Rd 59e81eaae91dc77b4275c9a5b2910dda *man/rTraitDisc.Rd 81f756fdf2ec4c968095595dece8338f *man/rTraitMult.Rd 028b11582b3493cdefea60ccb78ad429 *man/read.GenBank.Rd 9e31bccfa08c1d2da2180cd8f50ab250 *man/read.caic.Rd 2b32811be5bed71ffeca3801c4408e5b *man/read.dna.Rd 51670875393d70cb7ef84b4b0388e8e4 *man/read.gff.Rd 5c9aed0b6f0a7e0f0fac9b5a59ac732f *man/read.nexus.Rd bc02e36c51d67074e661468993ed359b *man/read.nexus.data.Rd 3c8b53f5af4fdd36e7c0b449412d5a77 *man/read.tree.Rd 9224f164351fea4be9f7ce9d827f8e58 *man/reconstruct.Rd 5c2f0e05ef560aa4ec066c898c430aec *man/reorder.phylo.Rd af19f262b468dfd7c12448d9d8085331 *man/richness.yule.test.Rd 3afe25cebe4628e4844e41aad512d6e4 *man/rlineage.Rd c2503e4a9511cafefa7bc1e058fdde2a *man/root.Rd 6b97ea2fd96bf948fca764deab3a6e76 *man/rotate.Rd 1a7314ee0aa76712737e76162df6cc74 *man/rtree.Rd e53b4b3f7e009289c628e16143b3e8b4 *man/rtt.Rd 5010f7e12af0865bd3e4112349d601db *man/seg.sites.Rd f125fe172ee83b8bb4adaede4b4d3b43 *man/skyline.Rd bf851aa61b6310afa2ae1358c189dad7 *man/skylineplot.Rd 0cede7cdef45fc9a8b993f938a32ce67 *man/slowinskiguyer.test.Rd a0db170675b1c265f1f4e7d56e88d7cb *man/speciesTree.Rd 8fc51ff26614e7c713be2570d9af47b6 *man/stree.Rd 1f1309e2ec6327974952d546241a6024 *man/subtreeplot.Rd ef8aa9721275f20ddd38612cddf8300c *man/subtrees.Rd d684cc640acf041c6f1124e08426c8c8 *man/summary.phylo.Rd 18eb8ab87509076b49c50cd86b231cf7 *man/trans.Rd 3340a4f09c55010c15c0149a20b41c99 *man/treePop.Rd 7749863f505076f2288c106eb465805e *man/trex.Rd dbb269e680caf8c722cf53c9b5ce7ace *man/triangMtd.Rd 9e7d047e16ff821f3b7254b92d027bf0 *man/unique.multiPhylo.Rd 3fc83bd5ac2be01f581d0aa5a1038b80 *man/varCompPhylip.Rd 196c20c5aad9b231c4736375e50b3de3 *man/varcomp.Rd 5c459720196654a10cfff0390bffc14f *man/vcv.phylo.Rd f7ce7760e913c10f1cb7be05315b39fc *man/vcv2phylo.Rd a5d3cbf19df84d0f1e4e3a4650945cbf *man/weight.taxo.Rd 5d20c7995514d810a36e6ecf4c5faa87 *man/where.Rd ef9658f5343bdcbfc3673c7f936934f5 *man/which.edge.Rd 9b83a148295dcfcb3994fdb6eaab0174 *man/woodmouse.Rd f613518d0ecd88b4a80c779b0453ad7f *man/write.dna.Rd b9fe1836be61c56a521386b00021fa67 *man/write.nexus.Rd bf9417a54722e3185ece06cf01b5e899 *man/write.nexus.data.Rd b2302d65196726ab4cc573a22ee2d8e3 *man/write.tree.Rd 2568c6529e40fae7effe88b6c73998a1 *man/yule.Rd 7df89ac6996c82b52c4c9b3734807de1 *man/yule.cov.Rd 8612123f3617699a8e29ddf0541dc9ee *man/yule.time.Rd a00006ae345bb9379312e81694de3885 *man/zoom.Rd 225b45505001f9311e1d76f3a880cd70 *src/BIONJ.c 2a6f9e9e044a78154d3cfda5936d6f48 *src/Makevars 3174e9b61c83de87e8f14f428775d415 *src/NNI.c 122ba51b574f7f7acd5ea4b6256cea5f *src/SPR.c d11fb19958f2953583a9c5876da82df9 *src/TBR.c 9733c82cd67c4bd41aea44981f4ac8b8 *src/additive.c f795f77892d496e05e247b114eacf83a *src/ape.c 7eaffd3d85df9a1e4460905e9ca5eced *src/ape.h 19b564aab62c464c092cdf2f0d5cf447 *src/bNNI.c 79ca5c473decf13964192524caebf9f1 *src/bionjs.c f782a97466ed8008d31afd7a3e9d4ea9 *src/bipartition.c a5d4f692aca36f6b50e123b443792fa1 *src/bitsplits.c 81e4ad60b418966cdd09e608e074bb28 *src/delta_plot.c bcbc45836832bf51f35e920283cc37d6 *src/dist_dna.c 2a6a59a3a220eb855a3c48bc73dc54ba *src/dist_nodes.c 005ab69356525fbbc1b69950341308c2 *src/ewLasso.c afa27403972145d083d7f7f8b2536b98 *src/heap.c 13eb779c3014478185f3a9d7a39765df *src/mat_expo.c d07550c1f789ea92d5dd7668e7521778 *src/me.c 52c31d588a767b637b5a852fceeeb154 *src/me.h cc4c695b4b001305b83658df8075850e *src/me_balanced.c cf2bdcf9eda24eb6b572584c0ab79fb4 *src/me_ols.c 8f25a7d4686c85b25862941c023e5974 *src/mvr.c b3da0884f49bb4564fa1109c3255aa38 *src/mvrs.c d3364013ad597425d01ac50ae4ee0b34 *src/nj.c 1a4fa91d36ba25cf8d53d25683a2235e *src/njs.c 7de13de6d828d870915c2efb6eb47ab6 *src/pic.c 28ef72b2ccede817c0431afcb04e9c8c *src/plot_phylo.c aa8d9966da3b7e970879a49a40c05a07 *src/rTrait.c 23d15137e1f3d9b0d365d04c1f4d9b05 *src/read_dna.c b5505d4f7c732c82bc54687d6fc37c0d *src/reorder_phylo.c d7d48424f600f5dad372a8c3ccfbbcad *src/treePop.c 40d4ed144aba4b1acbc64d2807f33466 *src/tree_build.c 42c108c79f26d1940f94b98fcbe271e1 *src/tree_phylo.c 5937b5ba96d2ff5615badf55dff9ed5a *src/triangMtd.c ace51cbbe1e728d1e94e78ca99a6d019 *src/triangMtds.c 72e04107c752568641219bf57b5731a8 *src/ultrametric.c 2277b0efdb2f70dfdc5df8278702c6b6 *vignettes/MoranI.Rnw 70d5ed89ae0c78af85e1309702679087 *vignettes/ape.bib ape/build/0000755000175100001440000000000013017516351012136 5ustar hornikusersape/build/vignette.rds0000644000175100001440000000030213017516351014470 0ustar hornikusersb```b`ffb`b2 1# '/J +G˨+xR&3 h0X",LHXsS4楀a>"5lP5,n90{C2K7(1 棸(\^P(7@btr$$ rape/DESCRIPTION0000644000175100001440000000714513020051200012531 0ustar hornikusersPackage: ape Version: 4.0 Date: 2016-11-29 Title: Analyses of Phylogenetics and Evolution Authors@R: c(person("Emmanuel", "Paradis", role = c("aut", "cre", "cph"), email = "Emmanuel.Paradis@ird.fr"), person("Simon", "Blomberg", role = c("aut", "cph")), person("Ben", "Bolker", role = c("aut", "cph")), person("Julien", "Claude", role = c("aut", "cph")), person("Hoa Sien", "Cuong", role = c("aut", "cph")), person("Richard", "Desper", role = c("aut", "cph")), person("Gilles", "Didier", role = c("aut", "cph")), person("Benoit", "Durand", role = c("aut", "cph")), person("Julien", "Dutheil", role = c("aut", "cph")), person("Olivier", "Gascuel", role = c("aut", "cph")), person("Christoph", "Heibl", role = c("aut", "cph")), person("Anthony", "Ives", role = c("aut", "cph")), person("Bradley", "Jones", role = c("aut", "cph")), person("Daniel", "Lawson", role = c("aut", "cph")), person("Vincent", "Lefort", role = c("aut", "cph")), person("Pierre", "Legendre", role = c("aut", "cph")), person("Jim", "Lemon", role = c("aut", "cph")), person("Rosemary", "McCloskey", role = c("aut", "cph")), person("Johan", "Nylander", role = c("aut", "cph")), person("Rainer", "Opgen-Rhein", role = c("aut", "cph")), person("Andrei-Alin", "Popescu", role = c("aut", "cph")), person("Manuela", "Royer-Carenzi", role = c("aut", "cph")), person("Klaus", "Schliep", role = c("aut", "cph")), person("Korbinian", "Strimmer", role = c("aut", "cph")), person("Damien", "de Vienne", role = c("aut", "cph"))) Depends: R (>= 3.2.0) Suggests: gee, expm Imports: nlme, lattice, graphics, methods, stats, tools, utils, parallel ZipData: no Description: Functions for reading, writing, plotting, and manipulating phylogenetic trees, analyses of comparative data in a phylogenetic framework, ancestral character analyses, analyses of diversification and macroevolution, computing distances from DNA sequences, reading and writing nucleotide sequences as well as importing from BioConductor, and several tools such as Mantel's test, generalized skyline plots, graphical exploration of phylogenetic data (alex, trex, kronoviz), estimation of absolute evolutionary rates and clock-like trees using mean path lengths and penalized likelihood, dating trees with non-contemporaneous sequences, translating DNA into AA sequences, and assessing sequence alignments. Phylogeny estimation can be done with the NJ, BIONJ, ME, MVR, SDM, and triangle methods, and several methods handling incomplete distance matrices (NJ*, BIONJ*, MVR*, and the corresponding triangle method). Some functions call external applications (PhyML, Clustal, T-Coffee, Muscle, MAFFT) whose results are returned into R. License: GPL (>= 2) URL: http://ape-package.ird.fr/ NeedsCompilation: yes Packaged: 2016-11-30 09:33:29 UTC; paradis Author: Emmanuel Paradis [aut, cre, cph], Simon Blomberg [aut, cph], Ben Bolker [aut, cph], Julien Claude [aut, cph], Hoa Sien Cuong [aut, cph], Richard Desper [aut, cph], Gilles Didier [aut, cph], Benoit Durand [aut, cph], Julien Dutheil [aut, cph], Olivier Gascuel [aut, cph], Christoph Heibl [aut, cph], Anthony Ives [aut, cph], Bradley Jones [aut, cph], Daniel Lawson [aut, cph], Vincent Lefort [aut, cph], Pierre Legendre [aut, cph], Jim Lemon [aut, cph], Rosemary McCloskey [aut, cph], Johan Nylander [aut, cph], Rainer Opgen-Rhein [aut, cph], Andrei-Alin Popescu [aut, cph], Manuela Royer-Carenzi [aut, cph], Klaus Schliep [aut, cph], Korbinian Strimmer [aut, cph], Damien de Vienne [aut, cph] Maintainer: Emmanuel Paradis Repository: CRAN Date/Publication: 2016-12-01 17:40:32 ape/man/0000755000175100001440000000000013017516351011612 5ustar hornikusersape/man/makeLabel.Rd0000644000175100001440000000535412623114447013767 0ustar hornikusers\name{makeLabel} \alias{makeLabel} \alias{makeLabel.character} \alias{makeLabel.phylo} \alias{makeLabel.multiPhylo} \alias{makeLabel.DNAbin} \title{Label Management} \description{ This is a generic function with methods for character vectors, trees of class \code{"phylo"}, lists of trees of class \code{"multiPhylo"}, and DNA sequences of class \code{"DNAbin"}. All options for the class character may be used in the other methods. } \usage{ makeLabel(x, ...) \method{makeLabel}{character}(x, len = 99, space = "_", make.unique = TRUE, illegal = "():;,[]", quote = FALSE, ...) \method{makeLabel}{phylo}(x, tips = TRUE, nodes = TRUE, ...) \method{makeLabel}{multiPhylo}(x, tips = TRUE, nodes = TRUE, ...) \method{makeLabel}{DNAbin}(x, ...) } \arguments{ \item{x}{a vector of mode character or an object for which labels are to be changed.} \item{len}{the maximum length of the labels: those longer than `len' will be truncated.} \item{space}{the character to replace spaces, tabulations, and linebreaks.} \item{make.unique}{a logical specifying whether duplicate labels should be made unique by appending numerals; \code{TRUE} by default.} \item{illegal}{a string specifying the characters to be deleted.} \item{quote}{a logical specifying whether to quote the labels; \code{FALSE} by default.} \item{tips}{a logical specifying whether tip labels are to be modified; \code{TRUE} by default.} \item{nodes}{a logical specifying whether node labels are to be modified; \code{TRUE} by default.} \item{\dots}{further arguments to be passed to or from other methods.} } \details{ The option \code{make.unique} does not work exactly in the same way then the function of the same name: numbers are suffixed to all labels that are identical (without separator). See the examples. If there are 10--99 identical labels, the labels returned are "xxx01", "xxx02", etc, or "xxx001", "xxx002", etc, if they are 100--999, and so on. The number of digits added preserves the option `len'. The default for `len' makes labels short enough to be read by PhyML. Clustal accepts labels up to 30 character long. } \note{ The current version does not perform well when trying to make very short unique labels (e.g., less than 5 character long). } \value{ An object of the appropriate class. } \author{Emmanuel Paradis} \seealso{ \code{\link{makeNodeLabel}}, \code{\link[base]{make.unique}}, \code{\link[base]{make.names}}, \code{\link[base]{abbreviate}}, \code{\link{mixedFontLabel}}, \code{\link{label2table}} } \examples{ x <- rep("a", 3) makeLabel(x) make.unique(x) # <- from R's base x <- rep("aaaaa", 2) makeLabel(x, len = 3) # made unique and of length 3 makeLabel(x, len = 3, make.unique = FALSE) } \keyword{manip} ape/man/bd.ext.Rd0000644000175100001440000000644411530633670013277 0ustar hornikusers\name{bd.ext} \alias{bd.ext} \title{Extended Version of the Birth-Death Models to Estimate Speciation and Extinction Rates} \usage{ bd.ext(phy, S, conditional = TRUE) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{S}{a numeric vector giving the number of species for each tip.} \item{conditional}{whether probabilities should be conditioned on no extinction (mainly to compare results with previous analyses; see details).} } \description{ This function fits by maximum likelihood a birth-death model to the combined phylogenetic and taxonomic data of a given clade. The phylogenetic data are given by a tree, and the taxonomic data by the number of species for the its tips. } \details{ A re-parametrization of the birth-death model studied by Kendall (1948) so that the likelihood has to be maximized over \emph{d/b} and \emph{b - d}, where \emph{b} is the birth rate, and \emph{d} the death rate. The standard-errors of the estimated parameters are computed using a normal approximation of the maximum likelihood estimates. If the argument \code{S} has names, then they are matched to the tip labels of \code{phy}. The user must be careful here since the function requires that both series of names perfectly match, so this operation may fail if there is a typing or syntax error. If both series of names do not match, the values \code{S} are taken to be in the same order than the tip labels of \code{phy}, and a warning message is issued. Note that the function does not check that the tree is effectively ultrametric, so if it is not, the returned result may not be meaningful. If \code{conditional = TRUE}, the probabilities of the taxonomic data are calculated conditioned on no extinction (Rabosky et al. 2007). In previous versions of the present function (until ape 2.6-1), unconditional probabilities were used resulting in underestimated extinction rate. Though it does not make much sense to use \code{conditional = FALSE}, this option is provided to compare results from previous analyses: if the species richnesses are relatively low, both versions will give similar results (see examples). } \references{ Paradis, E. (2003) Analysis of diversification: combining phylogenetic and taxonomic data. \emph{Proceedings of the Royal Society of London. Series B. Biological Sciences}, \bold{270}, 2499--2505. Rabosky, D. L., Donnellan, S. C., Talaba, A. L. and Lovette, I. J. (2007) Exceptional among-lineage variation in diversification rates during the radiation of Australia's most diverse vertebrate clade. \emph{Proceedings of the Royal Society of London. Series B. Biological Sciences}, \bold{274}, 2915--2923. } \author{Emmanuel Paradis} \seealso{ \code{\link{birthdeath}}, \code{\link{branching.times}}, \code{\link{diversi.gof}}, \code{\link{diversi.time}}, \code{\link{ltt.plot}}, \code{\link{yule}}, \code{\link{yule.cov}}, \code{\link{bd.time}} } \examples{ ### An example from Paradis (2003) using the avian orders: data(bird.orders) ### Number of species in each order from Sibley and Monroe (1990): S <- c(10, 47, 69, 214, 161, 17, 355, 51, 56, 10, 39, 152, 6, 143, 358, 103, 319, 23, 291, 313, 196, 1027, 5712) bd.ext(bird.orders, S) bd.ext(bird.orders, S, FALSE) # same than older versions } \keyword{models} ape/man/makeNodeLabel.Rd0000644000175100001440000000577012645745614014611 0ustar hornikusers\name{makeNodeLabel} \alias{makeNodeLabel} \title{Makes Node Labels} \description{ This function makes node labels in a tree in a flexible way. } \usage{ makeNodeLabel(phy, method = "number", prefix = "Node", nodeList = list(), ...) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{method}{a character string giving the method used to create the labels. Three choices are possible: \code{"number"} (the default), \code{"md5sum"}, and \code{"user"}, or any unambiguous abbreviation of these.} \item{prefix}{the prefix used if \code{method = "number"}.} \item{nodeList}{a named list specifying how nodes are names if \code{method = "user"} (see details and examples).} \item{\dots}{further arguments passed to \code{grep}.} } \details{ The three methods are described below: \itemize{ \item{``number''}{The labels are created with 1, 2, \dots prefixed with the argument \code{prefix}; thus the default is to have Node1, Node2, \dots Set \code{prefix = ""} to have only numbers.} \item{``md5sum''}{For each node, the labels of the tips descendant from this node are extracted, sorted alphabetically, and written into a temporary file, then the md5sum of this file is extracted and used as label. This results in a 32-character string which is unique (even accross trees) for a given set of tip labels.} \item{``user''}{the argument \code{nodeList} must be a list with names, the latter will be used as node labels. For each element of \code{nodeList}, the tip labels of the tree are searched for patterns present in this element: this is done using \code{\link[base]{grep}}. Then the most recent common ancestor of the matching tips is given the corresponding names as labels. This is repeated for each element of \code{nodeList}.} } The method \code{"user"} can be used in combination with either of the two others (see examples). Note that this method only modifies the specified node labels (so that if the other nodes have already labels they are not modified) while the two others change all labels. } \value{ an object of class \code{"phylo"}. } \author{Emmanuel Paradis} \seealso{ \code{\link{makeLabel}}, \code{\link[base]{grep}}, \code{\link{mixedFontLabel}}, \code{\link{label2table}} } \examples{ tr <- "((Pan_paniscus,Pan_troglodytes),((Homo_sapiens,Homo_erectus),Homo_abilis));" tr <- read.tree(text = tr) tr <- makeNodeLabel(tr, "u", nodeList = list(Pan = "Pan", Homo = "Homo")) plot(tr, show.node.label = TRUE) ### does not erase the previous node labels: tr <- makeNodeLabel(tr, "u", nodeList = list(Hominid = c("Pan","Homo"))) plot(tr, show.node.label = TRUE) ### the two previous commands could be combined: L <- list(Pan = "Pan", Homo = "Homo", Hominid = c("Pan","Homo")) tr <- makeNodeLabel(tr, "u", nodeList = L) ### combining different methods: tr <- makeNodeLabel(tr, c("n", "u"), prefix = "#", nodeList = list(Hominid = c("Pan","Homo"))) plot(tr, show.node.label = TRUE) } \keyword{manip} ape/man/read.dna.Rd0000644000175100001440000001423712727155675013603 0ustar hornikusers\name{read.dna} \alias{read.dna} \alias{read.FASTA} \title{Read DNA Sequences in a File} \description{ These functions read DNA sequences in a file, and returns a matrix or a list of DNA sequences with the names of the taxa read in the file as rownames or names, respectively. By default, the sequences are stored in binary format, otherwise (if \code{as.character = TRUE}) in lower case. } \usage{ read.dna(file, format = "interleaved", skip = 0, nlines = 0, comment.char = "#", as.character = FALSE, as.matrix = NULL) read.FASTA(file) } \arguments{ \item{file}{a file name specified by either a variable of mode character, or a double-quoted string.} \item{format}{a character string specifying the format of the DNA sequences. Four choices are possible: \code{"interleaved"}, \code{"sequential"}, \code{"clustal"}, or \code{"fasta"}, or any unambiguous abbreviation of these.} \item{skip}{the number of lines of the input file to skip before beginning to read data (ignored for FASTA files; see below).} \item{nlines}{the number of lines to be read (by default the file is read untill its end; ignored for FASTA files)).} \item{comment.char}{a single character, the remaining of the line after this character is ignored (ignored for FASTA files).} \item{as.character}{a logical controlling whether to return the sequences as an object of class \code{"DNAbin"} (the default).} \item{as.matrix}{(used if \code{format = "fasta"}) one of the three followings: (i) \code{NULL}: returns the sequences in a matrix if they are of the same length, otherwise in a list; (ii) \code{TRUE}: returns the sequences in a matrix, or stops with an error if they are of different lengths; (iii) \code{FALSE}: always returns the sequences in a list.} } \details{ \code{read.dna} follows the interleaved and sequential formats defined in PHYLIP (Felsenstein, 1993) but with the original feature than there is no restriction on the lengths of the taxa names. For these two formats, the first line of the file must contain the dimensions of the data (the numbers of taxa and the numbers of nucleotides); the sequences are considered as aligned and thus must be of the same lengths for all taxa. For the FASTA format, the conventions defined in the URL below (see References) are followed; the sequences are taken as non-aligned. For all formats, the nucleotides can be arranged in any way with blanks and line-breaks inside (with the restriction that the first ten nucleotides must be contiguous for the interleaved and sequential formats, see below). The names of the sequences are read in the file. Particularities for each format are detailed below. \itemize{ \item{Interleaved:}{the function starts to read the sequences after it finds one or more spaces (or tabulations). All characters before the sequences are taken as the taxa names after removing the leading and trailing spaces (so spaces in taxa names are allowed). It is assumed that the taxa names are not repeated in the subsequent blocks of nucleotides.} \item{Sequential:}{the same criterion than for the interleaved format is used to start reading the sequences and the taxa names; the sequences are then read until the number of nucleotides specified in the first line of the file is reached. This is repeated for each taxa.} \item{Clustal:}{this is the format output by the Clustal programs (.aln). It is somehow similar to the interleaved format: the differences being that the dimensions of the data are not indicated in the file, and the names of the sequences are repeated in each block.} \item{FASTA:}{This looks like the sequential format but the taxa names (or rather a description of the sequence) are on separate lines beginning with a `greater than' character `>' (there may be leading spaces before this character). These lines are taken as taxa names after removing the `>' and the possible leading and trailing spaces. All the data in the file before the first sequence is ignored.} }} \value{ a matrix or a list (if \code{format = "fasta"}) of DNA sequences stored in binary format, or of mode character (if \code{as.character = "TRUE"}). \code{read.FASTA} always returns a list of class \code{"DNAbin"}. } \references{ Anonymous. FASTA format. \url{http://en.wikipedia.org/wiki/FASTA_format} Felsenstein, J. (1993) Phylip (Phylogeny Inference Package) version 3.5c. Department of Genetics, University of Washington. \url{http://evolution.genetics.washington.edu/phylip/phylip.html} } \seealso{ \code{\link{read.GenBank}}, \code{\link{write.dna}}, \code{\link{DNAbin}}, \code{\link{dist.dna}}, \code{\link{woodmouse}} } \author{Emmanuel Paradis} \examples{ ### a small extract from `data(woddmouse)' cat("3 40", "No305 NTTCGAAAAACACACCCACTACTAAAANTTATCAGTCACT", "No304 ATTCGAAAAACACACCCACTACTAAAAATTATCAACCACT", "No306 ATTCGAAAAACACACCCACTACTAAAAATTATCAATCACT", file = "exdna.txt", sep = "\n") ex.dna <- read.dna("exdna.txt", format = "sequential") str(ex.dna) ex.dna ### the same data in interleaved format... cat("3 40", "No305 NTTCGAAAAA CACACCCACT", "No304 ATTCGAAAAA CACACCCACT", "No306 ATTCGAAAAA CACACCCACT", " ACTAAAANTT ATCAGTCACT", " ACTAAAAATT ATCAACCACT", " ACTAAAAATT ATCAATCACT", file = "exdna.txt", sep = "\n") ex.dna2 <- read.dna("exdna.txt") ### ... in clustal format... cat("CLUSTAL (ape) multiple sequence alignment", "", "No305 NTTCGAAAAACACACCCACTACTAAAANTTATCAGTCACT", "No304 ATTCGAAAAACACACCCACTACTAAAAATTATCAACCACT", "No306 ATTCGAAAAACACACCCACTACTAAAAATTATCAATCACT", " ************************** ****** ****", file = "exdna.txt", sep = "\n") ex.dna3 <- read.dna("exdna.txt", format = "clustal") ### ... and in FASTA format cat(">No305", "NTTCGAAAAACACACCCACTACTAAAANTTATCAGTCACT", ">No304", "ATTCGAAAAACACACCCACTACTAAAAATTATCAACCACT", ">No306", "ATTCGAAAAACACACCCACTACTAAAAATTATCAATCACT", file = "exdna.txt", sep = "\n") ex.dna4 <- read.dna("exdna.txt", format = "fasta") ### They are the same! identical(ex.dna, ex.dna2) identical(ex.dna, ex.dna3) identical(ex.dna, ex.dna4) unlink("exdna.txt") # clean-up } \keyword{IO} ape/man/mcconwaysims.test.Rd0000644000175100001440000000407311736206406015602 0ustar hornikusers\name{mcconwaysims.test} \alias{mcconwaysims.test} \title{McConway-Sims Test of Homogeneous Diversification} \description{ This function performs the McConway--Sims test that a trait or variable does not affect diversification rate. } \usage{ mcconwaysims.test(x) } \arguments{ \item{x}{a matrix or a data frame with at least two columns: the first one gives the number of species in clades with a trait supposed to increase or decrease diversification rate, and the second one the number of species in the sister-clades without the trait. Each row represents a pair of sister-clades.} } \details{ The McConway--Sims test compares a series of sister-clades where one of the two is characterized by a trait supposed to affect diversification rate. The null hypothesis is that the trait does not affect diversification. The alternative hypothesis is that diversification rate is increased or decreased by the trait (by contrast to the Slowinski--Guyer test). The test is a likelihood-ratio of a null Yule model and an alternative model with two parameters. } \value{ a data frame with the \eqn{\chi^2}{chi2}, the number of degrees of freedom, and the \emph{P}-value. } \references{ McConway, K. J. and Sims, H. J. (2004) A likelihood-based method for testing for nonstochastic variation of diversification rates in phylogenies. \emph{Evolution}, \bold{58}, 12--23. Paradis, E. (2012) Shift in diversification in sister-clade comparisons: a more powerful test. \emph{Evolution}, \bold{66}, 288--295. } \author{Emmanuel Paradis} \seealso{ \code{\link{balance}}, \code{\link{slowinskiguyer.test}}, \code{\link[geiger]{rc}} in \pkg{geiger}, \code{\link[apTreeshape]{shift.test}} in \pkg{apTreeshape} } \examples{ ### simulate 10 clades with lambda = 0.1 and mu = 0.09: n0 <- replicate(10, balance(rbdtree(.1, .09, Tmax = 35))[1]) ### simulate 10 clades with lambda = 0.15 and mu = 0.1: n1 <- replicate(10, balance(rbdtree(.15, .1, Tmax = 35))[1]) x <- cbind(n1, n0) mcconwaysims.test(x) slowinskiguyer.test(x) richness.yule.test(x, 35) } \keyword{htest} ape/man/binaryPGLMM.Rd0000644000175100001440000003161412531275231014166 0ustar hornikusers\name{binaryPGLMM} \alias{binaryPGLMM} \alias{binaryPGLMM.sim} \alias{print.binaryPGLMM} \title{Phylogenetic Generalized Linear Mixed Model for Binary Data} \description{ binaryPGLMM performs linear regression for binary phylogenetic data, estimating regression coefficients with approximate standard errors. It simultaneously estimates the strength of phylogenetic signal in the residuals and gives an approximate conditional likelihood ratio test for the hypothesis that there is no signal. Therefore, when applied without predictor (independent) variables, it gives a test for phylogenetic signal for binary data. The method uses a GLMM approach, alternating between penalized quasi-likelihood (PQL) to estimate the "mean components" and restricted maximum likelihood (REML) to estimate the "variance components" of the model. binaryPGLMM.sim is a companion function that simulates binary phylogenetic data of the same structure analyzed by binaryPGLMM. } \usage{ binaryPGLMM(formula, data = list(), phy, s2.init = 0.1, B.init = NULL, tol.pql = 10^-6, maxit.pql = 200, maxit.reml = 100) binaryPGLMM.sim(formula, data = list(), phy, s2 = NULL, B = NULL, nrep = 1) \method{print}{binaryPGLMM}(x, digits = max(3, getOption("digits") - 3), ...) } \arguments{ \item{formula}{a two-sided linear formula object describing the fixed-effects of the model; for example, Y ~ X.} \item{data}{a data frame containing the variables named in formula.} \item{phy}{a phylogenetic tree as an object of class "phylo".} \item{s2.init}{an initial estimate of s2, the scaling component of the variance in the PGLMM. A value of s2 = 0 implies no phylogenetic signal. Note that the variance-covariance matrix given by the phylogeny phy is scaled to have determinant = 1.} \item{B.init}{initial estimates of B, the matrix containing regression coefficients in the model. This matrix must have dim(B.init)=c(p+1,1), where p is the number of predictor (independent) variables; the first element of B corresponds to the intercept, and the remaining elements correspond in order to the predictor (independent) variables in the model.} \item{tol.pql}{a control parameter dictating the tolerance for convergence for the PQL optimization.} \item{maxit.pql}{a control parameter dictating the maximum number of iterations for the PQL optimization.} \item{maxit.reml}{a control parameter dictating the maximum number of iterations for the REML optimization.} \item{x}{an object of class "binaryPGLMM".} \item{s2}{in binaryPGLMM.sim, value of s2. See s2.init.} \item{B}{in binaryPGLMM.sim, value of B, the matrix containing regression coefficients in the model. See B.init.} \item{nrep}{in binaryPGLMM.sim, number of compete data sets produced.} \item{digits}{the number of digits to print.} \item{\dots}{further arguments passed to \code{print}.} } \details{ The function estimates parameters for the model \deqn{Pr(Y = 1) = q } \deqn{q = inverse.logit(b0 + b1 * x1 + b2 * x2 + \dots + \epsilon)} \deqn{\epsilon ~ Gaussian(0, s2 * V) } where \eqn{V} is a variance-covariance matrix derived from a phylogeny (typically under the assumption of Brownian motion evolution). Although mathematically there is no requirement for \eqn{V} to be ultrametric, forcing \eqn{V} into ultrametric form can aide in the interpretation of the model, because in regression for binary dependent variables, only the off-diagonal elements (i.e., covariances) of matrix \eqn{V} are biologically meaningful (see Ives & Garland 2014). The function converts a phylo tree object into a variance-covariance matrix, and further standardizes this matrix to have determinant = 1. This in effect standardizes the interpretation of the scalar s2. Although mathematically not required, it is a very good idea to standardize the predictor (independent) variables to have mean 0 and variance 1. This will make the function more robust and improve the interpretation of the regression coefficients. For categorical (factor) predictor variables, you will need to construct 0-1 dummy variables, and these should not be standardized (for obvious reasons). The estimation method alternates between PQL to obtain estimates of the mean components of the model (this is the standard approach to estimating GLMs) and REML to obtain estimates of the variance components. This method gives relatively fast and robust estimation. Nonetheless, the estimates of the coefficients B will generally be upwards bias, as is typical of estimation for binary data. The standard errors of B are computed from the PQL results conditional on the estimate of s2 and therefore should tend to be too small. The function returns an approximate P-value for the hypothesis of no phylogenetic signal in the residuals (i.e., H0:s2 = 0) using an approximate likelihood ratio test based on the conditional REML likelihood (rather than the marginal likelihood). Simulations have shown that these P-values tend to be high (giving type II errors: failing to identify variances that in fact are statistically significantly different from zero). It is a good idea to confirm statistical inferences using parametric bootstrapping, and the companion function binaryPGLMM.sim gives a simply tool for this. See Examples below. } \value{ An object of class "binaryPGLMM". \item{formula}{formula specifying the regression model.} \item{B}{estimates of the regression coefficients.} \item{B.se}{approximate PQL standard errors of the regression coefficients.} \item{B.cov}{approximate PQL covariance matrix for the regression coefficients.} \item{B.zscore}{approximate PQL Z scores for the regression coefficients.} \item{B.pvalue}{approximate PQL tests for the regression coefficients being different from zero.} \item{s2}{phylogenetic signal measured as the scalar magnitude of the phylogenetic variance-covariance matrix s2 * V.} \item{P.H0.s2}{approximate likelihood ratio test of the hypothesis H0 that s2 = 0. This test is based on the conditional REML (keeping the regression coefficients fixed) and is prone to inflated type 1 errors.} \item{mu}{for each data point y, the estimate of p that y = 1.} \item{b}{for each data point y, the estimate of inverse.logit(p).} \item{X}{the predictor (independent) variables returned in matrix form (including 1s in the first column).} \item{H}{residuals of the form b + (Y - mu)/(mu * (1 - mu)).} \item{B.init}{the user-provided initial estimates of B. If B.init is not provided, these are estimated using glm() assuming no phylogenetic signal. The glm() estimates can generate convergence problems, so using small values (e.g., 0.01) is more robust but slower.} \item{VCV}{the standardized phylogenetic variance-covariance matrix.} \item{V}{estimate of the covariance matrix of H.} \item{convergeflag}{flag for cases when convergence failed.} \item{iteration}{number of total iterations performed.} \item{converge.test.B}{final tolerance for B.} \item{converge.test.s2}{final tolerance for s2.} \item{rcondflag}{number of times B is reset to 0.01. This is done when rcond(V) < 10^(-10), which implies that V cannot be inverted.} \item{Y}{in binaryPGLMM.sim, the simulated values of Y.} } \author{Anthony R. Ives} \references{ Ives, A. R. and Helmus, M. R. (2011) Generalized linear mixed models for phylogenetic analyses of community structure. \emph{Ecological Monographs}, \bold{81}, 511--525. Ives, A. R. and Garland, T., Jr. (2014) Phylogenetic regression for binary dependent variables. Pages 231--261 \emph{in} L. Z. Garamszegi, editor. \emph{Modern Phylogenetic Comparative Methods and Their Application in Evolutionary Biology}. Springer-Verlag, Berlin Heidelberg. } \seealso{ package \pkg{pez} and its function \code{communityPGLMM}; package \pkg{phylolm} and its function \code{phyloglm}; package \pkg{MCMCglmm} } \examples{ ## Illustration of binaryPGLMM() with simulated data # Generate random phylogeny n <- 100 phy <- compute.brlen(rtree(n=n), method = "Grafen", power = 1) # Generate random data and standardize to have mean 0 and variance 1 X1 <- rTraitCont(phy, model = "BM", sigma = 1) X1 <- (X1 - mean(X1))/var(X1) # Simulate binary Y sim.dat <- data.frame(Y=array(0, dim=n), X1=X1, row.names=phy$tip.label) sim.dat$Y <- binaryPGLMM.sim(Y ~ X1, phy=phy, data=sim.dat, s2=.5, B=matrix(c(0,.25),nrow=2,ncol=1), nrep=1)$Y # Fit model binaryPGLMM(Y ~ X1, phy=phy, data=sim.dat) \dontrun{ # Compare with phyloglm() library(phylolm) summary(phyloglm(Y ~ X1, phy=phy, data=sim.dat)) # Compare with glm() that does not account for phylogeny summary(glm(Y ~ X1, data=sim.dat, family="binomial")) # Compare with logistf() that does not account # for phylogeny but is less biased than glm() library(logistf) logistf(Y ~ X1, data=sim.dat) # Compare with MCMCglmm library(MCMCglmm) V <- vcv(phy) V <- V/max(V) detV <- exp(determinant(V)$modulus[1]) V <- V/detV^(1/n) invV <- Matrix(solve(V),sparse=T) sim.dat$species <- phy$tip.label rownames(invV) <- sim.dat$species nitt <- 43000 thin <- 10 burnin <- 3000 prior <- list(R=list(V=1, fix=1), G=list(G1=list(V=1, nu=1000, alpha.mu=0, alpha.V=1))) summary(MCMCglmm(Y ~ X1, random=~species, ginvers=list(species=invV), data=sim.dat, slice=TRUE, nitt=nitt, thin=thin, burnin=burnin, family="categorical", prior=prior, verbose=FALSE)) ## Examine bias in estimates of B1 and s2 from binaryPGLMM with # simulated data. Note that this will take a while. Reps = 1000 s2 <- 0.4 B1 <- 1 meanEsts <- data.frame(n = Inf, B1 = B1, s2 = s2, Pr.s2 = 1, propconverged = 1) for (n in c(160, 80, 40, 20)) { meanEsts.n <- data.frame(B1 = 0, s2 = 0, Pr.s2 = 0, convergefailure = 0) for (rep in 1:Reps) { phy <- compute.brlen(rtree(n = n), method = "Grafen", power = 1) X <- rTraitCont(phy, model = "BM", sigma = 1) X <- (X - mean(X))/var(X) sim.dat <- data.frame(Y = array(0, dim = n), X = X, row.names = phy$tip.label) sim <- binaryPGLMM.sim(Y ~ 1 + X, phy = phy, data = sim.dat, s2 = s2, B = matrix(c(0,B1), nrow = 2, ncol = 1), nrep = 1) sim.dat$Y <- sim$Y z <- binaryPGLMM(Y ~ 1 + X, phy = phy, data = sim.dat) meanEsts.n[rep, ] <- c(z$B[2], z$s2, z$P.H0.s2, z$convergeflag == "converged") } converged <- meanEsts.n[,4] meanEsts <- rbind(meanEsts, c(n, mean(meanEsts.n[converged==1,1]), mean(meanEsts.n[converged==1,2]), mean(meanEsts.n[converged==1, 3] < 0.05), mean(converged))) } meanEsts # Results output for B1 = 0.5, s2 = 0.4; n-Inf gives the values used to # simulate the data # n B1 s2 Pr.s2 propconverged # 1 Inf 1.000000 0.4000000 1.00000000 1.000 # 2 160 1.012719 0.4479946 0.36153072 0.993 # 3 80 1.030876 0.5992027 0.24623116 0.995 # 4 40 1.110201 0.7425203 0.13373860 0.987 # 5 20 1.249886 0.8774708 0.05727377 0.873 ## Examine type I errors for estimates of B0 and s2 from binaryPGLMM() # with simulated data. Note that this will take a while. Reps = 1000 s2 <- 0 B0 <- 0 B1 <- 0 H0.tests <- data.frame(n = Inf, B0 = B0, s2 = s2, Pr.B0 = .05, Pr.s2 = .05, propconverged = 1) for (n in c(160, 80, 40, 20)) { ests.n <- data.frame(B1 = 0, s2 = 0, Pr.B0 = 0, Pr.s2 = 0, convergefailure = 0) for (rep in 1:Reps) { phy <- compute.brlen(rtree(n = n), method = "Grafen", power = 1) X <- rTraitCont(phy, model = "BM", sigma = 1) X <- (X - mean(X))/var(X) sim.dat <- data.frame(Y = array(0, dim = n), X = X, row.names = phy$tip.label) sim <- binaryPGLMM.sim(Y ~ 1, phy = phy, data = sim.dat, s2 = s2, B = matrix(B0, nrow = 1, ncol = 1), nrep = 1) sim.dat$Y <- sim$Y z <- binaryPGLMM(Y ~ 1, phy = phy, data = sim.dat) ests.n[rep, ] <- c(z$B[1], z$s2, z$B.pvalue, z$P.H0.s2, z$convergeflag == "converged") } converged <- ests.n[,5] H0.tests <- rbind(H0.tests, c(n, mean(ests.n[converged==1,1]), mean(ests.n[converged==1,2]), mean(ests.n[converged==1, 3] < 0.05), mean(ests.n[converged==1, 4] < 0.05), mean(converged))) } H0.tests # Results for type I errors for B0 = 0 and s2 = 0; n-Inf gives the values # used to simulate the data. These results show that binaryPGLMM() tends to # have lower-than-nominal p-values; fewer than 0.05 of the simulated # data sets have H0:B0=0 and H0:s2=0 rejected at the alpha=0.05 level. # n B0 s2 Pr.B0 Pr.s2 propconverged # 1 Inf 0.0000000000 0.00000000 0.05000000 0.05000000 1.000 # 2 160 -0.0009350357 0.07273163 0.02802803 0.04804805 0.999 # 3 80 -0.0085831477 0.12205876 0.04004004 0.03403403 0.999 # 4 40 0.0019303847 0.25486307 0.02206620 0.03711133 0.997 # 5 20 0.0181394905 0.45949266 0.02811245 0.03313253 0.996 }} \keyword{regression} ape/man/compute.brlen.Rd0000644000175100001440000000440211353106303014647 0ustar hornikusers\name{compute.brlen} \alias{compute.brlen} \title{Branch Lengths Computation} \usage{ compute.brlen(phy, method = "Grafen", power = 1, ...) } \arguments{ \item{phy}{an object of class \code{phylo} representing the tree.} \item{method}{the method to be used to compute the branch lengths; this must be one of the followings: (i) \code{"Grafen"} (the default), (ii) a numeric vector, or (iii) a function.} \item{power}{The power at which heights must be raised (see below).} \item{\dots}{further argument(s) to be passed to \code{method} if it is a function.} } \description{ This function computes branch lengths of a tree using different methods. } \details{ Grafen's (1989) computation of branch lengths: each node is given a `height', namely the number of leaves of the subtree minus one, 0 for leaves. Each height is scaled so that root height is 1, and then raised at power 'rho' (> 0). Branch lengths are then computed as the difference between height of lower node and height of upper node. If one or several numeric values are provided as \code{method}, they are recycled if necessary. If a function is given instead, further arguments are given in place of \code{...} (they must be named, see examples). Zero-length branches are not treated as multichotomies, and thus may need to be collapsed (see \code{\link{di2multi}}). } \value{ An object of class \code{phylo} with branch lengths. } \author{Julien Dutheil \email{julien.dutheil@univ-montp2.fr} and Emmanuel Paradis} \references{ Grafen, A. (1989) The phylogenetic regression. \emph{Philosophical Transactions of the Royal society of London. Series B. Biological Sciences}, \bold{326}, 119--157. } \seealso{ \code{\link{read.tree}} for a description of \code{phylo} objects, \code{\link{di2multi}}, \code{\link{multi2di}} } \examples{ data(bird.orders) plot(compute.brlen(bird.orders, 1)) plot(compute.brlen(bird.orders, runif, min = 0, max = 5)) layout(matrix(1:4, 2, 2)) plot(compute.brlen(bird.orders, power=1), main=expression(rho==1)) plot(compute.brlen(bird.orders, power=3), main=expression(rho==3)) plot(compute.brlen(bird.orders, power=0.5), main=expression(rho==0.5)) plot(compute.brlen(bird.orders, power=0.1), main=expression(rho==0.1)) layout(1) } \keyword{manip} ape/man/ewLasso.Rd0000644000175100001440000000372412125471037013524 0ustar hornikusers\name{ewLasso} \alias{ewLasso} \title{ Incomplete distances and edge weights of unrooted topology } \description{ This function implements a method for checking whether an incomplete set of distances satisfy certain conditions that might make it uniquely determine the edge weights of a given topology, T. It prints information about whether the graph with vertex set the set of leaves, denoted by X, and edge set the set of non-missing distance pairs, denoted by L, is connected or strongly non-bipartite. It then also checks whether L is a triplet cover for T. } \usage{ ewLasso(X, phy) } \arguments{ \item{X}{a distance matrix.} \item{phy}{an unrooted tree of class \code{"phylo"}.} } \details{ Missing values must be represented by either \code{NA} or a negative value. This implements a method for checking whether an incomplete set of distances satisfies certain conditions that might make it uniquely determine the edge weights of a given topology, T. It prints information about whether the graph, G, with vertex set the set of leaves, denoted by X, and edge set the set of non-missing distance pairs, denoted by L, is connected or strongly non-bipartite. It also checks whether L is a triplet cover for T. If G is not connected, then T does not need to be the only topology satisfying the input incomplete distances. If G is not strongly non-bipartite then the edge-weights of the edges of T are not the unique ones for which the input distance is satisfied. If L is a triplet cover, then the input distance matrix uniquely determines the edge weights of T. See Dress et al. (2012) for details. } \value{ NULL, the results are printed in the console. } \references{ Dress, A. W. M., Huber, K. T., and Steel, M. (2012) `Lassoing' a phylogentic tree I: basic properties, shellings and covers. \emph{Journal of Mathematical Biology}, \bold{65(1)}, 77--105. } \author{Andrei Popescu \email{niteloserpopescu@gmail.com}} \keyword{multivariate} ape/man/pic.ortho.Rd0000644000175100001440000000416611470134274014016 0ustar hornikusers\name{pic.ortho} \alias{pic.ortho} \title{Phylogenetically Independent Orthonormal Contrasts} \description{ This function computes the orthonormal contrasts using the method described by Felsenstein (2008). Only a single trait can be analyzed; there can be several observations per species. } \usage{ pic.ortho(x, phy, var.contrasts = FALSE, intra = FALSE) } \arguments{ \item{x}{a numeric vector or a list of numeric vectors.} \item{phy}{an object of class \code{"phylo"}.} \item{var.contrasts}{logical, indicates whether the expected variances of the contrasts should be returned (default to \code{FALSE}).} \item{intra}{logical, whether to return the intraspecific contrasts.} } \details{ The data \code{x} can be in two forms: a vector if there is a single observation for each species, or a list whose elements are vectors containing the individual observations for each species. These vectors may be of different lengths. If \code{x} has names, its values are matched to the tip labels of \code{phy}, otherwise its values are taken to be in the same order than the tip labels of \code{phy}. } \value{ either a vector of contrasts, or a two-column matrix with the contrasts in the first column and their expected variances in the second column (if \code{var.contrasts = TRUE}). If the tree has node labels, these are used as labels of the returned object. If \code{intra = TRUE}, the attribute \code{"intra"}, a list of vectors with the intraspecific contrasts or \code{NULL} for the species with a one observation, is attached to the returned object. } \references{ Felsenstein, J. (2008) Comparative methods with sampling error and within-species variation: Contrasts revisited and revised. \emph{American Naturalist}, \bold{171}, 713--725. } \author{Emmanuel Paradis} \seealso{ \code{\link{pic}}, \code{\link{varCompPhylip}} } \examples{ tr <- rcoal(30) ### a single observation per species: x <- rTraitCont(tr) pic.ortho(x, tr) pic.ortho(x, tr, TRUE) ### different number of observations per species: x <- lapply(sample(1:5, 30, TRUE), rnorm) pic.ortho(x, tr, intra = TRUE) } \keyword{regression} ape/man/plot.correlogram.Rd0000644000175100001440000000434711353107024015374 0ustar hornikusers\name{plot.correlogram} \alias{plot.correlogram} \alias{plot.correlogramList} \title{Plot a Correlogram} \usage{ \method{plot}{correlogram}(x, legend = TRUE, test.level = 0.05, col = c("grey", "red"), type = "b", xlab = "", ylab = "Moran's I", pch = 21, cex = 2, ...) \method{plot}{correlogramList}(x, lattice = TRUE, legend = TRUE, test.level = 0.05, col = c("grey", "red"), xlab = "", ylab = "Moran's I", type = "b", pch = 21, cex = 2, ...) } \arguments{ \item{x}{an object of class \code{"correlogram"} or of class \code{"correlogramList"} (both produced by \code{\link{correlogram.formula}}).} \item{legend}{should a legend be added on the plot?} \item{test.level}{the level used to discriminate the plotting symbols with colours considering the P-values.} \item{col}{two colours for the plotting symbols: the first one is used if the P-value is greater than or equal to \code{test.level}, the second one otherwise.} \item{type}{the type of plot to produce (see \code{\link[graphics]{plot}} for possible choices).} \item{xlab}{an optional character string for the label on the x-axis (none by default).} \item{ylab}{the default label on the y-axis.} \item{pch}{the type of plotting symbol.} \item{cex}{the default size for the plotting symbols.} \item{lattice}{when plotting several correlograms, should they be plotted in trellis-style with lattice (the default), or together on the same plot?} \item{\dots}{other parameters passed to the \code{plot} or \code{lines} function.} } \description{ These functions plot correlagrams previously computed with \code{\link{correlogram.formula}}. } \details{ When plotting several correlograms with lattice, some options have no effect: \code{legend}, \code{type}, and \code{pch} (\code{pch=19} is always used in this situation). When using \code{pch} between 1 and 20 (i.e., non-filled symbols, the colours specified in \code{col} are also used for the lines joining the points. To keep black lines, it is better to leave \code{pch} between 21 and 25. } \author{Emmanuel Paradis} \seealso{ \code{\link{correlogram.formula}}, \code{\link{Moran.I}} } \keyword{hplot} ape/man/add.scale.bar.Rd0000644000175100001440000000331311571032667014470 0ustar hornikusers\name{add.scale.bar} \alias{add.scale.bar} \title{Add a Scale Bar to a Phylogeny Plot} \usage{ add.scale.bar(x, y, length = NULL, ask = FALSE, lwd = 1, lcol = "black", ...) } \arguments{ \item{x}{x location of the bar (can be left missing).} \item{y}{y location of the bar (can be left missing).} \item{length}{a numeric value giving the length of the scale bar. If none is supplied, a value is calculated from the data.} \item{ask}{a logical; if \code{TRUE} the user is asked to click where to draw the bar. The default is \code{FALSE}.} \item{lwd}{the width of the bar.} \item{lcol}{the colour of the bar (use \code{col} for the colour of the text).} \item{\dots}{further arguments to be passed to \code{text}.} } \description{ This function adds a horizontal bar giving the scale of the branch lengths to a plot of a phylogenetic tree on the current graphical device. } \details{ By default, the bar is placed in a corner of the graph depending on the direction of the tree. Otherwise both \code{x} and \code{y} must be specified (if only one is given it is ignored). The further arguments (\code{\dots}) are used to format the text. They may be \code{font}, \code{cex}, \code{col}, and so on (see examples below, and the help page on \code{\link[graphics]{text}}). The function \code{\link[graphics]{locator}} may be used to determine the \code{x} and \code{y} arguments. } \author{Emmanuel Paradis} \seealso{ \code{\link{plot.phylo}}, \code{\link{axisPhylo}}, \code{\link[graphics]{locator}} } \examples{ tr <- rtree(10) layout(matrix(1:2, 2, 1)) plot(tr) add.scale.bar() plot(tr) add.scale.bar(cex = 0.7, font = 2, col = "red") layout(matrix(1)) } \keyword{aplot} ape/man/richness.yule.test.Rd0000644000175100001440000000225711736206145015663 0ustar hornikusers\name{richness.yule.test} \alias{richness.yule.test} \title{Test of Diversification-Shift With the Yule Process} \description{ This function performs a test of shift in diversification rate using probabilities from the Yule process. } \usage{ richness.yule.test(x, t) } \arguments{ \item{x}{a matrix or a data frame with at least two columns: the first one gives the number of species in clades with a trait supposed to increase or decrease diversification rate, and the second one the number of species in the sister-clades without the trait. Each row represents a pair of sister-clades.} \item{t}{a numeric vector giving the divergence times of each pair of clades in \code{x}.} } \value{ a data frame with the \eqn{\chi^2}{chi2}, the number of degrees of freedom (= 1), and the \emph{P}-value. } \references{ Paradis, E. (2012) Shift in diversification in sister-clade comparisons: a more powerful test. \emph{Evolution}, \bold{66}, 288--295. } \author{Emmanuel Paradis} \seealso{ \code{\link{slowinskiguyer.test}}, \code{\link{mcconwaysims.test}}, \code{\link{diversity.contrast.test}} } \examples{ ### see examples(mcconwaysims.test) } \keyword{htest} ape/man/multi2di.Rd0000644000175100001440000000332713002723773013641 0ustar hornikusers\name{multi2di} \alias{multi2di} \alias{multi2di.phylo} \alias{multi2di.multiPhylo} \alias{di2multi} \alias{di2multi.phylo} \alias{di2multi.multiPhylo} \title{Collapse and Resolve Multichotomies} \description{ These two functions collapse or resolve multichotomies in phylogenetic trees. } \usage{ multi2di(phy, ...) \method{multi2di}{phylo}(phy, random = TRUE, ...) \method{multi2di}{multiPhylo}(phy, random = TRUE, ...) di2multi(phy, ...) \method{di2multi}{phylo}(phy, tol = 1e-08, ...) \method{di2multi}{multiPhylo}(phy, tol = 1e-08, ...) } \arguments{ \item{phy}{an object of class \code{"phylo"} or \code{"multiPhylo"}.} \item{random}{a logical value specifying whether to resolve the multichotomies randomly (the default) or in the order they appear in the tree (if \code{random = FALSE}).} \item{tol}{a numeric value giving the tolerance to consider a branch length significantly greater than zero.} \item{\dots}{arguments passed among methods.} } \details{ \code{multi2di} transforms all multichotomies into a series of dichotomies with one (or several) branch(es) of length zero. \code{di2multi} deletes all branches smaller than \code{tol} and collapses the corresponding dichotomies into a multichotomy. } \seealso{\code{\link{is.binary}}} \author{Emmanuel Paradis} \value{ an object of the same class than the input. } \examples{ data(bird.families) is.binary(bird.families) is.binary(multi2di(bird.families)) all.equal(di2multi(multi2di(bird.families)), bird.families) ### To see the results of randomly resolving a trichotomy: tr <- read.tree(text = "(a:1,b:1,c:1);") layout(matrix(1:4, 2, 2)) for (i in 1:4) plot(multi2di(tr), use.edge.length = FALSE, cex = 1.5) layout(matrix(1)) } \keyword{manip} ape/man/trex.Rd0000644000175100001440000000501011736203020013047 0ustar hornikusers\name{trex} \alias{trex} \title{Tree Explorer With Multiple Devices} \description{ This function requires a plotted tree: the user is invited to click close to a node and the corresponding subtree (or clade) is plotted on a new window. } \usage{ trex(phy, title = TRUE, subbg = "lightyellow3", return.tree = FALSE, ...) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{title}{a logical or a character string (see details).} \item{subbg}{a character string giving the background colour for the subtree.} \item{return.tree}{a logical: if \code{TRUE}, the subtree is returned after being plotted and the operation is stopped.} \item{\dots}{further arguments to pass to \code{plot.phylo}.} } \details{ This function works with a tree (freshly) plotted on an interactive graphical device (i.e., not a file). After calling \code{trex}, the user clicks close to a node of the tree, then the clade from this node is plotted on a \emph{new} window. The user can click as many times on the main tree: the clades are plotted successively on the \emph{same} new window. The process is stopped by a right-click. If the user clicks too close to the tips, a message ``Try again!'' is printed. Each time \code{trex} is called, the subtree is plotted on a new window without closing or deleting those possibly already plotted. They may be distinguished with the options \code{title} and/or \code{subbg}. In all cases, the device where \code{phy} is plotted is the active window after the operation. It should \emph{not} be closed during the whole process. If \code{title = TRUE}, a default title is printed on the new window using the node label, or the node number if there are no node labels in the tree. If \code{title = FALSE}, no title is printed. If \code{title} is a character string, it is used for the title. } \value{ an object of class \code{"phylo"} if \code{return.tree = TRUE} } \author{Emmanuel Paradis} \seealso{ \code{\link{plot.phylo}}, \code{\link{identify.phylo}} } \examples{ \dontrun{ tr <- rcoal(1000) plot(tr, show.tip.label = FALSE) trex(tr) # left-click as many times as you want, then right-click tr <- makeNodeLabel(tr) trex(tr, subbg = "lightgreen") # id. ## generate a random colour with control on the darkness: rRGB <- function(a, b) rgb(runif(1, a, b), runif(1, a, b), runif(1, a, b)) ### with a random pale background: trex(tr, subbg = rRGB(0.8, 1)) ## the above can be called many times... graphics.off() # close all graphical devices }} \keyword{hplot} ape/man/mantel.test.Rd0000644000175100001440000000535112033743740014344 0ustar hornikusers\name{mantel.test} \alias{mantel.test} \title{Mantel Test for Similarity of Two Matrices} \usage{ mantel.test(m1, m2, nperm = 999, graph = FALSE, alternative = "two.sided", ...) } \arguments{ \item{m1}{a numeric matrix giving a measure of pairwise distances, correlations, or similarities among observations.} \item{m2}{a second numeric matrix giving another measure of pairwise distances, correlations, or similarities among observations.} \item{nperm}{the number of times to permute the data.} \item{graph}{a logical indicating whether to produce a summary graph (by default the graph is not plotted).} \item{alternative}{a character string defining the alternative hypothesis: \code{"two.sided"} (default), \code{"less"}, \code{"greater"}, or any unambiguous abbreviation of these.} \item{\dots}{further arguments to be passed to \code{plot()} (to add a title, change the axis labels, and so on).} } \description{ This function computes Mantel's permutation test for similarity of two matrices. It permutes the rows and columns of the two matrices randomly and calculates a \eqn{Z}-statistic. } \details{ The function calculates a \eqn{Z}-statistic for the Mantel test, equal to the sum of the pairwise product of the lower triangles of the permuted matrices, for each permutation of rows and columns. It compares the permuted distribution with the \eqn{Z}-statistic observed for the actual data. If \code{graph = TRUE}, the functions plots the density estimate of the permutation distribution along with the observed \eqn{Z}-statistic as a vertical line. The \code{\dots} argument allows the user to give further options to the \code{plot} function: the title main be changed with \code{main=}, the axis labels with \code{xlab =}, and \code{ylab =}, and so on. } \value{ \item{z.stat}{the \eqn{Z}-statistic (sum of rows*columns of lower triangle) of the data matrices.} \item{p}{\eqn{P}-value (quantile of the observed \eqn{Z}-statistic in the permutation distribution).} \item{alternative}{the alternative hypothesis.} } \references{ Mantel, N. (1967) The detection of disease clustering and a generalized regression approach. \emph{Cancer Research}, \bold{27}, 209--220. Manly, B. F. J. (1986) \emph{Multivariate statistical methods: a primer.} London: Chapman & Hall. } \author{ Original code in S by Ben Bolker, ported to \R by Julien Claude } \examples{ q1 <- matrix(runif(36), nrow = 6) q2 <- matrix(runif(36), nrow = 6) mantel.test(q1, q2, graph = TRUE, main = "Mantel test: a random example with 6 X 6 matrices", xlab = "z-statistic", ylab = "Density", sub = "The vertical line shows the observed z-statistic") } \keyword{multivariate} ape/man/edges.Rd0000644000175100001440000000361611331311476013174 0ustar hornikusers\name{edges} \alias{edges} \alias{fancyarrows} \title{Draw Additional Edges on a Plotted Tree} \description{ \code{edges} draws edges on a plotted tree. \code{fancyarrows} enhances \code{\link[graphics]{arrows}} with triangle and harpoon heads; it can be called from \code{edges}. } \usage{ edges(nodes0, nodes1, arrows = 0, type = "classical", ...) fancyarrows(x0, y0, x1, y1, length = 0.25, angle = 30, code = 2, col = par("fg"), lty = par("lty"), lwd = par("lwd"), type = "triangle", ...) } \arguments{ \item{nodes0, nodes1}{vectors of integers giving the tip and/or node numbers where to start and to end the edges (eventually recycled).} \item{arrows}{an integer between 0 and 3; 0: lines (the default); 1: an arrow head is drawn at \code{nodes0}; 2: at \code{nodes1}; 3: both.} \item{type}{if the previous argument is not 0, the type of arrow head: \code{"classical"} (just lines, the default), \code{"triangle"}, \code{"harpoon"}, or any unambiguous abbreviations of these. For \code{fancyarrows} only the last two are available.} \item{x0, y0, x1, y1}{the coordinates of the start and end points for \code{fancyarrows} (these are not recycled and so should be vectors of the same length).} \item{length, angle, code, col, lty, lwd}{default options similar to those of \code{\link[graphics]{arrows}}.} \item{\dots}{further arguments passed to \code{\link[graphics]{segments}}.} } \details{ The first function is helpful when drawing reticulations on a phylogeny, especially if computed from the edge matrix. } \author{Emmanuel Paradis} \seealso{ \code{\link{plot.phylo}}, \code{\link{nodelabels}} } \examples{ set.seed(2) tr <- rcoal(6) plot(tr, "c") edges(10, 9, col = "red", lty = 2) edges(10:11, 8, col = c("blue", "green")) # recycling of 'nodes1' edges(1, 2, lwd = 2, type = "h", arrows = 3, col = "green") nodelabels() } \keyword{aplot} ape/man/rTraitDisc.Rd0000644000175100001440000000756711714702074014171 0ustar hornikusers\name{rTraitDisc} \alias{rTraitDisc} \title{Discrete Character Simulation} \usage{ rTraitDisc(phy, model = "ER", k = if (is.matrix(model)) ncol(model) else 2, rate = 0.1, states = LETTERS[1:k], freq = rep(1/k, k), ancestor = FALSE, root.value = 1, ...) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{model}{a character, a square numeric matrix, or a function specifying the model (see details).} \item{k}{the number of states of the character.} \item{rate}{the rate of change used if \code{model} is a character; it is \emph{not} recycled if \code{model = "ARD"} of \code{model = "SYM"}.} \item{states}{the labels used for the states; by default ``A'', ``B'', \dots} \item{freq}{a numeric vector giving the equilibrium relative frequencies of each state; by default the frequencies are equal.} \item{ancestor}{a logical value specifying whether to return the values at the nodes as well (by default, only the values at the tips are returned).} \item{root.value}{an integer giving the value at the root (by default, it's the first state). To have a random value, use \code{root.value = sample(k)}.} \item{\dots}{further arguments passed to \code{model} if it is a function.} } \description{ This function simulates the evolution of a discrete character along a phylogeny. If \code{model} is a character or a matrix, evolution is simulated with a Markovian model; the transition probabilities are calculated for each branch with \eqn{P = e^{Qt}} where \eqn{Q} is the rate matrix given by \code{model} and \eqn{t} is the branch length. The calculation is done recursively from the root. See Paradis (2006, p. 101) for a general introduction applied to evolution. } \details{ There are three possibilities to specify \code{model}: \itemize{ \item{A matrix:}{it must be a numeric square matrix; the diagonal is always ignored. The arguments \code{k} and \code{rate} are ignored.} \item{A character:}{these are the same short-cuts than in the function \code{\link{ace}}: \code{"ER"} is an equal-rates model, \code{"ARD"} is an all-rates-different model, and \code{"SYM"} is a symmetrical model. Note that the argument \code{rate} must be of the appropriate length, i.e., 1, \eqn{k(k - 1)}, or \eqn{k(k - 1)/2} for the three models, respectively. The rate matrix \eqn{Q} is then filled column-wise.} \item{A function:}{it must be of the form \code{foo(x, l)} where \code{x} is the trait of the ancestor and \code{l} is the branch length. It must return the value of the descendant as an integer.} }} \value{ A factor with names taken from the tip labels of \code{phy}. If \code{ancestor = TRUE}, the node labels are used if present, otherwise, ``Node1'', ``Node2'', etc. } \references{ Paradis, E. (2006) \emph{Analyses of Phylogenetics and Evolution with R.} New York: Springer. } \author{Emmanuel Paradis} \seealso{ \code{\link{rTraitCont}}, \code{\link{rTraitMult}}, \code{\link{ace}} } \examples{ data(bird.orders) ### the two followings are the same: rTraitDisc(bird.orders) rTraitDisc(bird.orders, model = matrix(c(0, 0.1, 0.1, 0), 2)) ### two-state model with irreversibility: rTraitDisc(bird.orders, model = matrix(c(0, 0, 0.1, 0), 2)) ### simple two-state model: tr <- rcoal(n <- 40, br = runif) x <- rTraitDisc(tr, ancestor = TRUE) plot(tr, show.tip.label = FALSE) nodelabels(pch = 19, col = x[-(1:n)]) tiplabels(pch = 19, col = x[1:n]) ### an imaginary model with stasis 0.5 time unit after a node, then ### random evolution: foo <- function(x, l) { if (l < 0.5) return(x) sample(2, size = 1) } tr <- rcoal(20, br = runif) x <- rTraitDisc(tr, foo, ancestor = TRUE) plot(tr, show.tip.label = FALSE) co <- c("blue", "yellow") cot <- c("white", "black") Y <- x[1:20] A <- x[-(1:20)] nodelabels(A, bg = co[A], col = cot[A]) tiplabels(Y, bg = co[Y], col = cot[Y]) } \keyword{datagen} ape/man/varcomp.Rd0000644000175100001440000000172111747715250013560 0ustar hornikusers\name{varcomp} \alias{varcomp} \title{Compute Variance Component Estimates} \description{ Get variance component estimates from a fitted \code{lme} object. } \usage{ varcomp(x, scale = FALSE, cum = FALSE) } \arguments{ \item{x}{A fitted \code{lme} object} \item{scale}{Scale all variance so that they sum to 1} \item{cum}{Send cumulative variance components.} } \details{ Variance computations is done as in Venables and Ripley (2002). } \value{ A named vector of class \code{varcomp} with estimated variance components. } \references{ Venables, W. N. and Ripley, B. D. (2002) \emph{Modern Applied Statistics with S (Fourth Edition)}. New York: Springer-Verlag. } \author{Julien Dutheil \email{julien.dutheil@univ-montp2.fr}} \seealso{\code{\link[nlme]{lme}}} \examples{ data(carnivora) library(nlme) m <- lme(log10(SW) ~ 1, random = ~ 1|Order/SuperFamily/Family/Genus, data=carnivora) v <- varcomp(m, TRUE, TRUE) plot(v) } \keyword{regression} \keyword{dplot} ape/man/mat5Mrand.Rd0000644000175100001440000000051011163652207013726 0ustar hornikusers\name{mat5Mrand} \alias{mat5Mrand} \title{Five Independent Trees} \description{ Five independent additive trees. } \usage{ data(mat5Mrand) } \format{ A data frame with 250 observations and 50 variables. } \source{ Data provided by V. Campbell. } \seealso{ \code{\link{mat5M3ID}}, \code{\link{mat3}} } \keyword{datasets} ape/man/nodelabels.Rd0000644000175100001440000001612012344065406014213 0ustar hornikusers\name{nodelabels} \alias{nodelabels} \alias{tiplabels} \alias{edgelabels} \title{Labelling the Nodes, Tips, and Edges of a Tree} \description{ These functions add labels to or near the nodes, the tips, or the edges of a tree using text or plotting symbols. The text can be framed. } \usage{ nodelabels(text, node, adj = c(0.5, 0.5), frame = "rect", pch = NULL, thermo = NULL, pie = NULL, piecol = NULL, col = "black", bg = "lightblue", horiz = FALSE, width = NULL, height = NULL, ...) tiplabels(text, tip, adj = c(0.5, 0.5), frame = "rect", pch = NULL, thermo = NULL, pie = NULL, piecol = NULL, col = "black", bg = "yellow", horiz = FALSE, width = NULL, height = NULL, ...) edgelabels(text, edge, adj = c(0.5, 0.5), frame = "rect", pch = NULL, thermo = NULL, pie = NULL, piecol = NULL, col = "black", bg = "lightgreen", horiz = FALSE, width = NULL, height = NULL, date = NULL, ...) } \arguments{ \item{text}{a vector of mode character giving the text to be printed. Can be left empty.} \item{node}{a vector of mode numeric giving the numbers of the nodes where the text or the symbols are to be printed. Can be left empty.} \item{tip}{a vector of mode numeric giving the numbers of the tips where the text or the symbols are to be printed. Can be left empty.} \item{edge}{a vector of mode numeric giving the numbers of the edges where the text or the symbols are to be printed. Can be left empty.} \item{adj}{one or two numeric values specifying the horizontal and vertical, respectively, justification of the text or symbols. By default, the text is centered horizontally and vertically. If a single value is given, this alters only the horizontal position of the text.} \item{frame}{a character string specifying the kind of frame to be printed around the text. This must be one of "rect" (the default), "circle", "none", or any unambiguous abbreviation of these.} \item{pch}{a numeric giving the type of plotting symbol to be used; this is eventually recycled. See \code{\link[graphics]{par}} for R's plotting symbols. If \code{pch} is used, then \code{text} is ignored.} \item{thermo}{a numeric vector giving some proportions (values between 0 and 1) for each node, or a numeric matrix giving some proportions (the rows must sum to one).} \item{pie}{same than \code{thermo}.} \item{piecol}{a list of colours (given as a character vector) to be used by \code{thermo} or \code{pie}; if left \code{NULL}, a series of colours given by the function \code{rainbow} is used.} \item{col}{a character string giving the color to be used for the text or the plotting symbols; this is eventually recycled.} \item{bg}{a character string giving the color to be used for the background of the text frames or of the plotting symbols if it applies; this is eventually recycled.} \item{\dots}{further arguments passed to the \code{text} or \code{points} functions (e.g. \code{cex} to alter the size of the text or the symbols, or \code{font} for the text; see the examples below).} \item{horiz, width, height}{parameters controlling the aspect of thermometers; by default, their width and height are determined automatically.} \item{date}{specifies the positions of labels on edges of chronograms with respect to the time scale.} } \details{ These three functions have the same optional arguments and the same functioning. If the arguments \code{text} is missing and \code{pch} and \code{thermo} are left as \code{NULL}, then the numbers of the nodes (or of the tips) are printed. If \code{node}, \code{tip}, or \code{edge} is missing, then the text or the symbols are printed on all nodes, tips, or edges. The option \code{cex} can be used to change the size of all types of labels. A simple call of these functions with no arguments (e.g., \code{nodelabels()}) prints the numbers of all nodes (or tips). In the case of \code{tiplabels}, it would be useful to play with the options \code{x.lim} and \code{label.offset} (and possibly \code{show.tip.label}) of \code{plot.phylo} in most cases (see the examples). } \author{Emmanuel Paradis, Ben Bolker, and Jim Lemon} \seealso{ \code{\link{plot.phylo}}, \code{\link{edges}}, \code{\link{mixedFontLabel}} } \examples{ tr <- read.tree(text = "((Homo,Pan),Gorilla);") plot(tr) nodelabels("7.3 Ma", 4, frame = "r", bg = "yellow", adj = 0) nodelabels("5.4 Ma", 5, frame = "c", bg = "tomato", font = 3) ## A trick by Liam Revell when there are many categories: plot(tr, x.lim = c(-1, 4)) nodelabels(node = 4, pie = matrix(rep(1, 100), 1), cex = 5) op <- par(fg = "transparent") nodelabels(node = 5, pie = matrix(rep(1, 100), 1), cex = 5) par(op) data(bird.orders) plot(bird.orders, use.edge.length = FALSE, font = 1) bs <- round(runif(22, 90, 100), 0) # some imaginary bootstrap values bs2 <- round(runif(22, 90, 100), 0) bs3 <- round(runif(22, 90, 100), 0) nodelabels(bs, adj = 1.2) nodelabels(bs2, adj = -0.2, bg = "yellow") ### something more classical plot(bird.orders, use.edge.length = FALSE, font = 1) nodelabels(bs, adj = -0.2, frame = "n", cex = 0.8) nodelabels(bs2, adj = c(1.2, 1), frame = "n", cex = 0.8) nodelabels(bs3, adj = c(1.2, -0.2), frame = "n", cex = 0.8) ### the same but we play with the font plot(bird.orders, use.edge.length = FALSE, font = 1) nodelabels(bs, adj = -0.2, frame = "n", cex = 0.8, font = 2) nodelabels(bs2, adj = c(1.2, 1), frame = "n", cex = 0.8, font = 3) nodelabels(bs3, adj = c(1.2, -0.2), frame = "n", cex = 0.8) plot(bird.orders, "c", use.edge.length = FALSE, font = 1) nodelabels(thermo = runif(22), cex = .8) plot(bird.orders, "u", FALSE, font = 1, lab4ut = "a") nodelabels(cex = .75, bg = "yellow") ### representing two characters at the tips (you could have as many ### as you want) plot(bird.orders, "c", FALSE, font = 1, label.offset = 3, x.lim = 31, no.margin = TRUE) tiplabels(pch = 21, bg = gray(1:23/23), cex = 2, adj = 1.4) tiplabels(pch = 19, col = c("yellow", "red", "blue"), adj = 2.5, cex = 2) ### This can be used to highlight tip labels: plot(bird.orders, font = 1) i <- c(1, 7, 18) tiplabels(bird.orders$tip.label[i], i, adj = 0) ### Some random data to compare piecharts and thermometres: tr <- rtree(15) x <- runif(14, 0, 0.33) y <- runif(14, 0, 0.33) z <- runif(14, 0, 0.33) x <- cbind(x, y, z, 1 - x - y - z) layout(matrix(1:2, 1, 2)) plot(tr, "c", FALSE, no.margin = TRUE) nodelabels(pie = x, cex = 1.3) text(4.5, 15, "Are you \"pie\"...", font = 4, cex = 1.5) plot(tr, "c", FALSE, no.margin = TRUE) nodelabels(thermo = x, col = rainbow(4), cex = 1.3) text(4.5, 15, "... or \"thermo\"?", font = 4, cex = 1.5) plot(tr, "c", FALSE, no.margin = TRUE) nodelabels(thermo = x, col = rainbow(4), cex = 1.3) plot(tr, "c", FALSE, no.margin = TRUE) nodelabels(thermo = x, col = rainbow(4), width = 3, horiz = TRUE) layout(matrix(1)) plot(tr, main = "Showing Edge Lengths") edgelabels(round(tr$edge.length, 3), srt = 90) plot(tr, "p", FALSE) edgelabels("above", adj = c(0.5, -0.25), bg = "yellow") edgelabels("below", adj = c(0.5, 1.25), bg = "lightblue") } \keyword{aplot} ape/man/checkAlignment.Rd0000644000175100001440000000270213016363673015024 0ustar hornikusers\name{checkAlignment} \alias{checkAlignment} \title{Check DNA Alignments} \description{ This function performs a series of diagnostics on a DNA alignement. } \usage{ checkAlignment(x, check.gaps = TRUE, plot = TRUE, what = 1:4) } \arguments{ \item{x}{an object of class \code{"DNAbin"}.} \item{check.gaps}{a logical value specifying whether to check the distribution of alignment gaps.} \item{plot}{a logical value specifying whether to do the plots.} \item{what}{an integer value giving the plot to be done. By default, four plots are done on the same figure.} } \details{ This function prints on the console a series of diagnostics on the set a aligned DNA sequences. If alignment gaps are present, their width distribution is analysed, as well as the width of contiguous base segments. The pattern of nucleotide diversity on each site is also analysed, and a relevant table is printed. If \code{plot = TRUE}, four plots are done: an image of the alignement, the distribution of gap widths (if present), the Shannon index of nucleotide diversity along the sequence, and the number of observed bases along the sequence. If the sequences contain many gaps, it might be better to set \code{check.gaps = FALSE} to skip the analysis of contiguous segments. } \value{NULL} \author{Emmanuel Paradis} \seealso{ \code{\link{alview}}, \code{\link{image.DNAbin}}, \code{\link{all.equal.DNAbin}} } \examples{ data(woodmouse) checkAlignment(woodmouse) }ape/man/varCompPhylip.Rd0000644000175100001440000000536711470134652014712 0ustar hornikusers\name{varCompPhylip} \alias{varCompPhylip} \title{Variance Components with Orthonormal Contrasts} \description{ This function calls Phylip's contrast program and returns the phylogenetic and phenotypic variance-covariance components for one or several traits. There can be several observations per species. } \usage{ varCompPhylip(x, phy, exec = NULL) } \arguments{ \item{x}{a numeric vector, a matrix (or data frame), or a list.} \item{phy}{an object of class \code{"phylo"}.} \item{exec}{a character string giving the name of the executable contrast program (see details).} } \details{ The data \code{x} can be in several forms: (i) a numeric vector if there is single trait and one observation per species; (ii) a matrix or data frame if there are several traits (as columns) and a single observation of each trait for each species; (iii) a list of vectors if there is a single trait and several observations per species; (iv) a list of matrices or data frames: same than (ii) but with several traits and the rows are individuals. If \code{x} has names, its values are matched to the tip labels of \code{phy}, otherwise its values are taken to be in the same order than the tip labels of \code{phy}. Phylip (version 3.68 or higher) must be accessible on your computer. If you have a Unix-like operating system, the executable name is assumed to be \code{"phylip contrast"} (as in Debian); otherwise it is set to \code{"contrast"}. If this doesn't suit your system, use the option \code{exec} accordingly. If the executable is not in the path, you may need to specify it, e.g., \code{exec = "C:/Program Files/Phylip/contrast"}. } \value{ a list with elements \code{varA} and \code{varE} with the phylogenetic (additive) and phenotypic (environmental) variance-covariance matrices. If a single trait is analyzed, these contains its variances. } \references{ Felsenstein, J. (2004) Phylip (Phylogeny Inference Package) version 3.68. Department of Genetics, University of Washington, Seattle, USA. \url{http://evolution.genetics.washington.edu/phylip/phylip.html}. Felsenstein, J. (2008) Comparative methods with sampling error and within-species variation: Contrasts revisited and revised. \emph{American Naturalist}, \bold{171}, 713--725. } \author{Emmanuel Paradis} \seealso{ \code{\link{pic}}, \code{\link{pic.ortho}}, \code{\link{compar.lynch}} } \examples{ \dontrun{ tr <- rcoal(30) ### Five traits, one observation per species: x <- replicate(5, rTraitCont(tr, sigma = 1)) varCompPhylip(x, tr) # varE is small x <- replicate(5, rnorm(30)) varCompPhylip(x, tr) # varE is large ### Five traits, ten observations per species: x <- replicate(30, replicate(5, rnorm(10)), simplify = FALSE) varCompPhylip(x, tr) }} \keyword{regression} ape/man/compar.gee.Rd0000644000175100001440000001237512254505572014136 0ustar hornikusers\name{compar.gee} \alias{compar.gee} \alias{print.compar.gee} \alias{drop1.compar.gee} \alias{predict.compar.gee} \title{Comparative Analysis with GEEs} \description{ \code{compar.gee} performs the comparative analysis using generalized estimating equations as described by Paradis and Claude (2002). \code{drop1} tests single effects of a fitted model output from \code{compar.gee}. \code{predict} returns the predicted (fitted) values of the model. } \usage{ compar.gee(formula, data = NULL, family = "gaussian", phy, corStruct, scale.fix = FALSE, scale.value = 1) \method{drop1}{compar.gee}(object, scope, quiet = FALSE, ...) \method{predict}{compar.gee}(object, newdata = NULL, type = c("link", "response"), ...) } \arguments{ \item{formula}{a formula giving the model to be fitted.} \item{data}{the name of the data frame where the variables in \code{formula} are to be found; by default, the variables are looked for in the global environment.} \item{family}{a function specifying the distribution assumed for the response; by default a Gaussian distribution (with link identity) is assumed (see \code{?family} for details on specifying the distribution, and on changing the link function).} \item{phy}{an object of class \code{"phylo"} (ignored if \code{corStruct} is used).} \item{corStruct}{a (phylogenetic) correlation structure.} \item{scale.fix}{logical, indicates whether the scale parameter should be fixed (TRUE) or estimated (FALSE, the default).} \item{scale.value}{if \code{scale.fix = TRUE}, gives the value for the scale (default: \code{scale.value = 1}).} \item{object}{an object of class \code{"compar.gee"} resulting from fitting \code{compar.gee}.} \item{scope}{.} \item{quiet}{a logical specifying whether to display a warning message about eventual ``marginality principle violation''.} \item{newdata}{a data frame with column names matching the variables in the formula of the fitted object (see \code{\link[stats]{predict}} for details).} \item{type}{a character string specifying the type of predicted values. By default, the linear (link) prediction is returned.} \item{\dots}{further arguments to be passed to \code{drop1}.} } \details{ If a data frame is specified for the argument \code{data}, then its rownames are matched to the tip labels of \code{phy}. The user must be careful here since the function requires that both series of names perfectly match, so this operation may fail if there is a typing or syntax error. If both series of names do not match, the values in the data frame are taken to be in the same order than the tip labels of \code{phy}, and a warning message is issued. If \code{data = NULL}, then it is assumed that the variables are in the same order than the tip labels of \code{phy}. } \note{ The calculation of the phylogenetic degrees of freedom is likely to be approximative for non-Brownian correlation structures (this will be refined soon). The calculation of the quasilikelihood information criterion (QIC) needs to be tested. } \value{ \code{compar.gee} returns an object of class \code{"compar.gee"} with the following components: \item{call}{the function call, including the formula.} \item{effect.assign}{a vector of integers assigning the coefficients to the effects (used by \code{drop1}).} \item{nobs}{the number of observations.} \item{QIC}{the quasilikelihood information criterion as defined by Pan (2001).} \item{coefficients}{the estimated coefficients (or regression parameters).} \item{residuals}{the regression residuals.} \item{family}{a character string, the distribution assumed for the response.} \item{link}{a character string, the link function used for the mean function.} \item{scale}{the scale (or dispersion parameter).} \item{W}{the variance-covariance matrix of the estimated coefficients.} \item{dfP}{the phylogenetic degrees of freedom (see Paradis and Claude for details on this).} \code{drop1} returns an object of class \code{"\link[stats]{anova}"}. \code{predict} returns a vector or a data frame if \code{newdata} is used. } \references{ Pan, W. (2001) Akaike's information criterion in generalized estimating equations. \emph{Biometrics}, \bold{57}, 120--125. Paradis, E. and Claude J. (2002) Analysis of comparative data using generalized estimating equations. \emph{Journal of theoretical Biology}, \bold{218}, 175--185. } \author{Emmanuel Paradis} \seealso{ \code{\link{read.tree}}, \code{\link{pic}}, \code{\link{compar.lynch}}, \code{\link[stats]{drop1}} } \examples{ ### The example in Phylip 3.5c (originally from Lynch 1991) ### (the same analysis than in help(pic)...) tr <- "((((Homo:0.21,Pongo:0.21):0.28,Macaca:0.49):0.13,Ateles:0.62):0.38,Galago:1.00);" tree.primates <- read.tree(text = tr) X <- c(4.09434, 3.61092, 2.37024, 2.02815, -1.46968) Y <- c(4.74493, 3.33220, 3.36730, 2.89037, 2.30259) ### Both regressions... the results are quite close to those obtained ### with pic(). compar.gee(X ~ Y, phy = tree.primates) compar.gee(Y ~ X, phy = tree.primates) ### Now do the GEE regressions through the origin: the results are quite ### different! compar.gee(X ~ Y - 1, phy = tree.primates) compar.gee(Y ~ X - 1, phy = tree.primates) } \keyword{regression} ape/man/del.gaps.Rd0000644000175100001440000000326612706674305013615 0ustar hornikusers\name{del.gaps} \alias{del.gaps} \alias{del.colgapsonly} \alias{del.rowgapsonly} \title{Delete Alignment Gaps in DNA Sequences} \description{ These functions remove gaps (\code{"-"}) in a sample of DNA sequences. } \usage{ del.gaps(x) del.colgapsonly(x, threshold = 1, freq.only = FALSE) del.rowgapsonly(x, threshold = 1, freq.only = FALSE) } \arguments{ \item{x}{a matrix, a list, or a vector containing the DNA sequences; only matrices for \code{del.colgapsonly} and for \code{del.rowgapsonly}.} \item{threshold}{the largest gap proportion to delete the column or row.} \item{freq.only}{if \code{TRUE}, returns only the numbers of gaps for each column or row.} } \details{ \code{del.gaps} remove all gaps, so the returned sequences may not have all the same lengths and are therefore returned in a list. \code{del.colgapsonly} removes the columns with a proportion at least \code{threshold} of gaps. Thus by default, only the columns with gaps only are removed (useful when a small matrix is extracted from a large alignment). \code{del.rowgapsonly} does the same for the rows. The sequences can be either in \code{"DNAbin"} or in another format, but the returned object is always of class \code{"DNAbin"}. } \value{ \code{del.gaps} returns a vector (if there is only one input sequence) or a list of class \code{"DNAbin"}; \code{del.colgapsonly} and \code{del.rowgapsonly} return a matrix of class \code{"DNAbin"} or a numeric vector (with names for the second function) if \code{freq.only = TRUE}. } \author{Emmanuel Paradis} \seealso{ \code{\link{base.freq}}, \code{\link{seg.sites}}, \code{\link{image.DNAbin}}, \code{\link{checkAlignment}} } \keyword{univar} ape/man/pic.Rd0000644000175100001440000000530512052602512012650 0ustar hornikusers\name{pic} \alias{pic} \title{Phylogenetically Independent Contrasts} \usage{ pic(x, phy, scaled = TRUE, var.contrasts = FALSE, rescaled.tree = FALSE) } \arguments{ \item{x}{a numeric vector.} \item{phy}{an object of class \code{"phylo"}.} \item{scaled}{logical, indicates whether the contrasts should be scaled with their expected variances (default to \code{TRUE}).} \item{var.contrasts}{logical, indicates whether the expected variances of the contrasts should be returned (default to \code{FALSE}).} \item{rescaled.tree}{logical, if \code{TRUE} the rescaled tree is returned together with the main results.} } \description{ Compute the phylogenetically independent contrasts using the method described by Felsenstein (1985). } \details{ If \code{x} has names, its values are matched to the tip labels of \code{phy}, otherwise its values are taken to be in the same order than the tip labels of \code{phy}. The user must be careful here since the function requires that both series of names perfectly match. If both series of names do not match, the values in the \code{x} are taken to be in the same order than the tip labels of \code{phy}, and a warning message is issued. } \value{ either a vector of phylogenetically independent contrasts (if \code{var.contrasts = FALSE}), or a two-column matrix with the phylogenetically independent contrasts in the first column and their expected variance in the second column (if \code{var.contrasts = TRUE}). If the tree has node labels, these are used as labels of the returned object. If \code{rescaled.tree = TRUE}, a list is returned with two elements named ``contr'' with the above results and ``rescaled.tree'' with the tree and its rescaled branch lengths (see Felsenstein 1985). } \references{ Felsenstein, J. (1985) Phylogenies and the comparative method. \emph{American Naturalist}, \bold{125}, 1--15. } \author{Emmanuel Paradis} \seealso{ \code{\link{read.tree}}, \code{\link{compar.gee}}, \code{\link{compar.lynch}}, \code{\link{pic.ortho}}, \code{\link{varCompPhylip}} } \examples{ ### The example in Phylip 3.5c (originally from Lynch 1991) cat("((((Homo:0.21,Pongo:0.21):0.28,", "Macaca:0.49):0.13,Ateles:0.62):0.38,Galago:1.00);", file = "ex.tre", sep = "\n") tree.primates <- read.tree("ex.tre") X <- c(4.09434, 3.61092, 2.37024, 2.02815, -1.46968) Y <- c(4.74493, 3.33220, 3.36730, 2.89037, 2.30259) names(X) <- names(Y) <- c("Homo", "Pongo", "Macaca", "Ateles", "Galago") pic.X <- pic(X, tree.primates) pic.Y <- pic(Y, tree.primates) cor.test(pic.X, pic.Y) lm(pic.Y ~ pic.X - 1) # both regressions lm(pic.X ~ pic.Y - 1) # through the origin unlink("ex.tre") # delete the file "ex.tre" } \keyword{regression} ape/man/where.Rd0000644000175100001440000000162112471072354013216 0ustar hornikusers\name{where} \alias{where} \title{Find Patterns in DNA Sequences} \description{ This function finds patterns in a single or a set of DNA sequences. } \usage{ where(x, pattern) } \arguments{ \item{x}{an object of class \code{"DNAbin"}.} \item{pattern}{a character string to be searched in \code{x}.} } \details{ If \code{x} is a vector, the function returns a single vector giving the position(s) where the pattern was found. If \code{x} is a matrix or a list, it returns a list with the positions of the pattern for each sequence. Patterns may be overlapping. For instance, if \code{pattern = "tata"} and the sequence starts with `tatata', then the output will be c(1, 3). } \value{ a vector of integers or a list of such vectors. } \author{Emmanuel Paradis} \seealso{ \code{\link{DNAbin}}, \code{\link{image.DNAbin}} } \examples{ data(woodmouse) where(woodmouse, "tata") } \keyword{manip} ape/man/unique.multiPhylo.Rd0000644000175100001440000000243212265566207015566 0ustar hornikusers\name{unique.multiPhylo} \alias{unique.multiPhylo} \title{Revomes Duplicate Trees} \description{ This function scans a list of trees, and returns a list with the duplicate trees removed. By default the labelled topologies are compared. } \usage{ \method{unique}{multiPhylo}(x, incomparables = FALSE, use.edge.length = FALSE, use.tip.label = TRUE, ...) } \arguments{ \item{x}{an object of class \code{"multiPhylo"}.} \item{incomparables}{unused (for compatibility with the generic).} \item{use.edge.length}{a logical specifying whether to consider the edge lengths in the comparisons; the default is \code{FALSE}.} \item{use.tip.label}{a logical specifying whether to consider the tip labels in the comparisons; the default is \code{TRUE}.} \item{\dots}{further arguments passed to or from other methods.} } \value{ an object of class \code{"multiPhylo"} with an attribute \code{"old.index"} indicating which trees of the original list are similar (the tree of smaller index is taken as reference). } \author{Emmanuel Paradis} \seealso{ \code{all.equal.phylo}, \code{\link[base]{unique}} for the generic R function, \code{read.tree}, \code{read.nexus} } \examples{ TR <- rmtree(50, 4) length(unique(TR)) # not always 15... howmanytrees(4) } \keyword{manip} ape/man/is.compatible.Rd0000644000175100001440000000134211647512233014634 0ustar hornikusers\name{is.compatible} \alias{is.compatible} \alias{is.compatible.bitsplits} \alias{arecompatible} \title{Check Compatibility of Splits} \description{ \code{is.compatible} is a generic function with a method for the class \code{"bitsplits"}. It checks whether a set of splits is compatible using the \code{arecompatible} function. } \usage{ is.compatible(obj) \method{is.compatible}{bitsplits}(obj) arecompatible(x, y, n) } \arguments{ \item{obj}{an object of class \code{"bitsplits"}.} \item{x, y}{a vector of mode raw\code{}.} \item{n}{the number of taxa in the splits.} } \value{ \code{TRUE} if the splits are compatible, \code{FALSE} otherwise. } \author{Andrei Popescu \email{niteloserpopescu@gmail.com}} \keyword{manip} ape/man/SDM.Rd0000644000175100001440000000270711736036032012531 0ustar hornikusers\name{SDM} \alias{SDM} \title{Construction of Consensus Distance Matrix With SDM} \description{ This function implements the SDM method of Criscuolo et al. (2006) for a set of n distance matrices. } \usage{ SDM(...) } \arguments{ \item{\dots}{2n elements (with n > 1), the first n elements are the distance matrices: these can be (symmetric) matrices, objects of class \code{"dist"}, or a mix of both. The next n elements are the sequence length from which the matrices have been estimated (can be seen as a degree of confidence in matrices).} } \details{ Reconstructs a consensus distance matrix from a set of input distance matrices on overlapping sets of taxa. Potentially missing values in the supermatrix are represented by \code{NA}. An error is returned if the input distance matrices can not resolve to a consensus matrix. } \value{ a 2-element list containing a distance matrix labelled by the union of the set of taxa of the input distance matrices, and a variance matrix associated to the returned distance matrix. } \references{ Criscuolo, A., Berry, V., Douzery, E. J. P. , and Gascuel, O. (2006) SDM: A fast distance-based approach for (super)tree building in phylogenomics. \emph{Systematic Biology}, \bold{55}, 740--755. } \author{Andrei Popescu \email{niteloserpopescu@gmail.com}} \seealso{ \code{\link{bionj}}, \code{\link{fastme}}, \code{\link{njs}}, \code{\link{mvrs}}, \code{\link{triangMtd}} } \keyword{models} ape/man/bird.orders.Rd0000644000175100001440000000225310775732361014331 0ustar hornikusers\name{bird.orders} \alias{bird.orders} \title{Phylogeny of the Orders of Birds From Sibley and Ahlquist} \description{ This data set describes the phylogenetic relationships of the orders of birds as reported by Sibley and Ahlquist (1990). Sibley and Ahlquist inferred this phylogeny from an extensive number of DNA/DNA hybridization experiments. The ``tapestry'' reported by these two authors (more than 1000 species out of the ca. 9000 extant bird species) generated a lot of debates. The present tree is based on the relationships among orders. The branch lengths were calculated from the values of \eqn{\Delta T_{50}H}{Delta T50H} as found in Sibley and Ahlquist (1990, fig. 353). } \usage{ data(bird.orders) } \format{ The data are stored as an object of class \code{"phylo"} which structure is described in the help page of the function \code{\link{read.tree}}. } \source{ Sibley, C. G. and Ahlquist, J. E. (1990) Phylogeny and classification of birds: a study in molecular evolution. New Haven: Yale University Press. } \seealso{ \code{\link{read.tree}}, \code{\link{bird.families}} } \examples{ data(bird.orders) plot(bird.orders) } \keyword{datasets} ape/man/plot.phyloExtra.Rd0000644000175100001440000000326712752422610015224 0ustar hornikusers\name{plot.phylo.extra} \alias{plot.phylo.extra} \alias{plotBreakLongEdges} \alias{drawSupportOnEdges} \title{Extra Fuctions to Plot and Annotate Phylogenies} \description{ These are extra functions to plot and annotate phylogenies, mostly calling basic graphical functions in \pkg{ape}. } \usage{ plotBreakLongEdges(phy, n = 1, ...) drawSupportOnEdges(value, ...) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{n}{the numner of long branches to be broken.} \item{value}{the values to be printed on the internal branches of the tree.} \item{\dots}{further arguments to be passed to \code{plot.phylo} or to \code{edgelabels}.} } \details{ \code{drawSupportOnEdges} assumes the tree is unrooted, so the vector \code{value} should have as many values than the number of internal branches (= number of nodes - 1). If there is one additional value, it is assumed that it relates to the root node and is dropped (see examples). } \value{NULL} \author{Emmanuel Paradis} \seealso{ \code{\link{plot.phylo}}, \code{\link{edgelabels}}, \code{\link{boot.phylo}}, \code{\link{plotTreeTime}} } \examples{ tr <- rtree(10) tr$edge.length[c(1, 18)] <- 100 op <- par(mfcol = 1:2) plot(tr); axisPhylo() plotBreakLongEdges(tr, 2); axisPhylo() ## from ?boot.phylo: f <- function(x) nj(dist.dna(x)) data(woodmouse) tw <- f(woodmouse) # NJ tree with K80 distance set.seed(1) ## bootstrap with 100 replications: (bp <- boot.phylo(tw, woodmouse, f, quiet = TRUE)) ## the first value relates to the root node and is always 100 ## it is ignored below: plot(tw, "u") drawSupportOnEdges(bp) ## more readable but the tree is really unrooted: plot(tw) drawSupportOnEdges(bp) par(op) } \keyword{hplot} ape/man/triangMtd.Rd0000644000175100001440000000140111737221712014027 0ustar hornikusers\name{triangMtd} \alias{triangMtd} \alias{triangMtds} \title{Tree Reconstruction Based on the Triangles Method} \usage{ triangMtd(X) triangMtds(X) } \arguments{ \item{X}{a distance matrix}. } \description{ Fast distance-based construction method. Should only be used when distance measures are fairly reliable. } \value{ an object of class \code{"phylo"}. } \references{ \url{http://archive.numdam.org/ARCHIVE/RO/RO_2001__35_2/RO_2001__35_2_283_0/RO_2001__35_2_283_0.pdf} } \author{Andrei Popescu \email{niteloserpopescu@gmail.com}} \seealso{ \code{\link{nj}}, \code{\link{bionj}}, \code{\link{fastme}}, \code{\link{njs}}, \code{\link{mvrs}}, \code{\link{SDM}} } \examples{ data(woodmouse) tr <- triangMtd(dist.dna(woodmouse)) plot(tr) } \keyword{models} ape/man/ape-package.Rd0000644000175100001440000000300412721074410014230 0ustar hornikusers\name{ape-package} \alias{ape-package} \alias{ape} \docType{package} \title{ Analyses of Phylogenetics and Evolution } \description{ \pkg{ape} provides functions for reading and manipulating phylogenetic trees and DNA sequences, computing DNA distances, estimating trees with distance-based methods, and a range of methods for comparative analyses and analysis of diversification. Functionalities are also provided for programming new phylogenetic methods. The complete list of functions can be displayed with \code{library(help = ape)}. More information on \pkg{ape} can be found at \url{http://ape-package.ird.fr/}. } \author{ Emmanuel Paradis, Ben Bolker, Julien Claude, Hoa Sien Cuong, Richard Desper, Benoit Durand, Julien Dutheil, Olivier Gascuel, Christoph Heibl, Daniel Lawson, Vincent Lefort, Pierre Legendre, Jim Lemon, Yvonnick Noel, Johan Nylander, Rainer Opgen-Rhein, Andrei-Alin Popescu, Klaus Schliep, Korbinian Strimmer, Damien de Vienne Maintainer: Emmanuel Paradis } \references{ Paradis, E. (2012) \emph{Analysis of Phylogenetics and Evolution with R (Second Edition).} New York: Springer. Paradis, E., Claude, J. and Strimmer, K. (2004) APE: analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289--290. Popescu, A.-A., Huber, K. T. and Paradis, E. (2012) ape 3.0: new tools for distance based phylogenetics and evolutionary analysis in R. \emph{Bioinformatics}, \bold{28}, 1536-1537. } \keyword{package} ape/man/MoranI.Rd0000644000175100001440000000550112455245726013301 0ustar hornikusers\name{Moran.I} \alias{Moran.I} \title{Moran's I Autocorrelation Index} \usage{ Moran.I(x, weight, scaled = FALSE, na.rm = FALSE, alternative = "two.sided") } \arguments{ \item{x}{a numeric vector.} \item{weight}{a matrix of weights.} \item{scaled}{a logical indicating whether the coefficient should be scaled so that it varies between -1 and +1 (default to \code{FALSE}).} \item{na.rm}{a logical indicating whether missing values should be removed.} \item{alternative}{a character string specifying the alternative hypothesis that is tested against the null hypothesis of no phylogenetic correlation; must be of one "two.sided", "less", or "greater", or any unambiguous abbrevation of these.} } \description{ This function computes Moran's I autocorrelation coefficient of \code{x} giving a matrix of weights using the method described by Gittleman and Kot (1990). } \details{ The matrix \code{weight} is used as ``neighbourhood'' weights, and Moran's I coefficient is computed using the formula: \deqn{I = \frac{n}{S_0} \frac{\sum_{i=1}^n\sum_{j=1}^n w_{i,j}(y_i - \overline{y})(y_j - \overline{y})}{\sum_{i=1}^n {(y_i - \overline{y})}^2}}{\code{I = n/S0 * (sum\{i=1..n\} sum\{j=1..n\} wij(yi - ym))(yj - ym) / (sum\{i=1..n\} (yi - ym)^2)}} with \itemize{ \item \eqn{y_i}{yi} = observations \item \eqn{w_{i,j}}{wij} = distance weight \item \eqn{n} = number of observations \item \eqn{S_0}{S0} = \eqn{\sum_{i=1}^n\sum_{j=1}^n wij}{\code{sum_{i=1..n} sum{j=1..n} wij}} } The null hypothesis of no phylogenetic correlation is tested assuming normality of I under this null hypothesis. If the observed value of I is significantly greater than the expected value, then the values of \code{x} are positively autocorrelated, whereas if Iobserved < Iexpected, this will indicate negative autocorrelation. } \value{ A list containing the elements: \item{observed}{the computed Moran's I.} \item{expected}{the expected value of I under the null hypothesis.} \item{sd}{the standard deviation of I under the null hypothesis.} \item{p.value}{the P-value of the test of the null hypothesis against the alternative hypothesis specified in \code{alternative}.} } \references{ Gittleman, J. L. and Kot, M. (1990) Adaptation: statistics and a null model for estimating phylogenetic effects. \emph{Systematic Zoology}, \bold{39}, 227--241. } \author{Julien Dutheil \email{julien.dutheil@univ-montp2.fr} and Emmanuel Paradis} \seealso{\code{\link{weight.taxo}}} \examples{ tr <- rtree(30) x <- rnorm(30) ## weights w[i,j] = 1/d[i,j]: w <- 1/cophenetic(tr) ## set the diagonal w[i,i] = 0 (instead of Inf...): diag(w) <- 0 Moran.I(x, w) Moran.I(x, w, alt = "l") Moran.I(x, w, alt = "g") Moran.I(x, w, scaled = TRUE) # usualy the same } \keyword{models} \keyword{regression} ape/man/chronoMPL.Rd0000644000175100001440000000476311373450365013761 0ustar hornikusers\name{chronoMPL} \alias{chronoMPL} \title{Molecular Dating With Mean Path Lengths} \usage{ chronoMPL(phy, se = TRUE, test = TRUE) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{se}{a logical specifying whether to compute the standard-errors of the node ages (\code{TRUE} by default).} \item{test}{a logical specifying whether to test the molecular clock at each node (\code{TRUE} by default).} } \description{ This function estimates the node ages of a tree using the mean path lengths method of Britton et al. (2002). The branch lengths of the input tree are interpreted as (mean) numbers of substitutions. } \details{ The mean path lengths (MPL) method estimates the age of a node with the mean of the distances from this node to all tips descending from it. Under the assumption of a molecular clock, standard-errors of the estimates node ages can be computed (Britton et al. 2002). The tests performed if \code{test = TRUE} is a comparison of the MPL of the two subtrees originating from a node; the null hypothesis is that the rate of substitution was the same in both subtrees (Britton et al. 2002). The test statistic follows, under the null hypothesis, a standard normal distribution. The returned \emph{P}-value is the probability of observing a greater absolute value (i.e., a two-sided test). No correction for multiple testing is applied: this is left to the user. Absolute dating can be done by multiplying the edge lengths found by calibrating one node age. } \note{ The present version requires a dichotomous tree. } \value{ an object of class \code{"phylo"} with branch lengths as estimated by the function. There are, by default, two attributes: \item{stderr}{the standard-errors of the node ages.} \item{Pval}{the \emph{P}-value of the test of the molecular clock for each node.} } \references{ Britton, T., Oxelman, B., Vinnersten, A. and Bremer, K. (2002) Phylogenetic dating with confidence intervals using mean path lengths. \emph{Molecular Phylogenetics and Evolution}, \bold{24}, 58--65. } \author{Emmanuel Paradis} \seealso{ \code{\link{chronopl}} } \examples{ tr <- rtree(10) tr$edge.length <- 5*tr$edge.length chr <- chronoMPL(tr) layout(matrix(1:4, 2, 2, byrow = TRUE)) plot(tr) title("The original tree") plot(chr) axisPhylo() title("The dated MPL tree") plot(chr) nodelabels(round(attr(chr, "stderr"), 3)) title("The standard-errors") plot(tr) nodelabels(round(attr(chr, "Pval"), 3)) title("The tests") } \keyword{models} ape/man/AAbin.Rd0000644000175100001440000000676613010312226013056 0ustar hornikusers\name{AAbin} \alias{AAbin} \alias{print.AAbin} \alias{[.AAbin} \alias{as.character.AAbin} \alias{labels.AAbin} \alias{image.AAbin} \alias{as.AAbin} \alias{as.AAbin.character} \alias{as.phyDat.AAbin} \alias{dist.aa} \alias{AAsubst} \title{Amino Acid Sequences} \description{ These functions help to create and manipulate AA sequences. } \usage{ \method{print}{AAbin}(x, \dots) \method{[}{AAbin}(x, i, j, drop = FALSE) \method{as.character}{AAbin}(x, \dots) \method{labels}{AAbin}(object, \dots) \method{image}{AAbin}(x, what, col, bg = "white", xlab = "", ylab = "", show.labels = TRUE, cex.lab = 1, legend = TRUE, \dots) as.AAbin(x, \dots) \method{as.AAbin}{character}(x, \dots) \method{as.phyDat}{AAbin}(x, \dots) dist.aa(x, pairwise.deletion = FALSE, scaled = FALSE) AAsubst(x) } \arguments{ \item{x, object}{an object of class \code{"AAbin"}.} \item{i, j}{indices of the rows and/or columns to select or to drop. They may be numeric, logical, or character (in the same way than for standard \R objects).} \item{drop}{logical; if \code{TRUE}, the returned object is of the lowest possible dimension.} \item{what}{a vector of characters specifying the amino acids to visualize. Currently, the only possible choice is to show the three categories hydrophobic, small, and hydrophilic.} \item{col}{a vector of colours. If missing, this is set to ``red'', ``yellow'' and ``blue''.} \item{bg}{the colour used for AA codes not among \code{what} (typically X and *).} \item{xlab}{the label for the \emph{x}-axis; none by default.} \item{ylab}{Idem for the \emph{y}-axis. Note that by default, the labels of the sequences are printed on the \emph{y}-axis (see next option).} \item{show.labels}{a logical controlling whether the sequence labels are printed (\code{TRUE} by default).} \item{cex.lab}{a single numeric controlling the size of the sequence labels. Use \code{cex.axis} to control the size of the annotations on the \emph{x}-axis.} \item{legend}{a logical controlling whether the legend is plotted (\code{TRUE} by default).} \item{pairwise.deletion}{a logical indicating whether to delete the sites with missing data in a pairwise way. The default is to delete the sites with at least one missing data for all sequences.} \item{scaled}{a logical value specifying whether to scale the number of AA differences by the sequence length.} \item{\dots}{further arguments to be passed to or from other methods.} } \details{ These functions help to manipulate amino acid sequences of class \code{"AAbin"}. These objects are stored in vectors, matrices, or lists which can be manipulated with the usual \code{[} operator. There are conversion functions to and from characters, and to \code{"phyDat"}. The function \code{dist.aa} computes the number of AA differences between each pair of sequences in a matrix; this can be scaled by the sequence length. See the function \code{\link[phangorn]{dist.ml}} in \pkg{phangorn} for evolutionary distances with AA sequences. The function \code{AAsubst} returns the indices of the polymorphic sites (similar to \code{\link{seg.sites}} for DNA sequences; see examples below). } \note{ Package \pkg{phangorn} has the function \code{read.aa} to read amino acid sequence files in FASTA format. } \value{ an object of class \code{"AAbin"}, \code{"character"}, \code{"phyDat"}, \code{"dist"}, or \code{"numeric"}, depending on the function. } \author{Emmanuel Paradis} \seealso{ \code{\link{trans}}, \code{\link{alview}} } \examples{ data(woodmouse) AA <- trans(woodmouse, 2) seg.sites(woodmouse) AAsubst(AA) } \keyword{manip} ape/man/howmanytrees.Rd0000644000175100001440000000473011747715643014647 0ustar hornikusers\name{howmanytrees} \alias{howmanytrees} \title{Calculate Numbers of Phylogenetic Trees} \usage{ howmanytrees(n, rooted = TRUE, binary = TRUE, labeled = TRUE, detail = FALSE) } \arguments{ \item{n}{a positive numeric integer giving the number of tips.} \item{rooted}{a logical indicating whether the trees are rooted (default is \code{TRUE}).} \item{binary}{a logical indicating whether the trees are bifurcating (default is \code{TRUE}).} \item{labeled}{a logical indicating whether the trees have tips labeled (default is \code{TRUE}).} \item{detail}{a logical indicating whether the eventual intermediate calculations should be returned (default is \code{FALSE}). This applies only for the multifurcating trees, and the bifurcating, rooted, unlabeled trees (aka tree shapes).} } \description{ This function calculates the number of possible phylogenetic trees for a given number of tips. } \details{ In the cases of labeled binary trees, the calculation is done directly and a single numeric value is returned. For multifurcating trees, and bifurcating, rooted, unlabeled trees, the calculation is done iteratively for 1 to \code{n} tips. Thus the user can print all the intermediate values if \code{detail = TRUE}, or only a single value if \code{detail = FALSE} (the default). For multifurcating trees, if \code{detail = TRUE}, a matrix is returned with the number of tips as rows (named from \code{1} to \code{n}), and the number of nodes as columns (named from \code{1} to \code{n - 1}). For bifurcating, rooted, unlabeled trees, a vector is returned with names equal to the number of tips (from \code{1} to \code{n}). The number of unlabeled trees (aka tree shapes) can be computed only for the rooted binary cases. Note that if an infinite value (\code{Inf}) is returned this does not mean that there is an infinite number of trees (this cannot be if the number of tips is finite), but that the calculation is beyond the limits of the computer. } \value{ a single numeric value, or in the case where \code{detail = TRUE} is used, a named vector or matrix. } \references{ Felsenstein, J. (2004) \emph{Inferring Phylogenies}. Sunderland: Sinauer Associates. } \author{Emmanuel Paradis} \examples{ ### Table 3.1 in Felsenstein 2004: for (i in c(1:20, 30, 40, 50)) cat(paste(i, howmanytrees(i), sep = "\t"), sep ="\n") ### Table 3.6: howmanytrees(8, binary = FALSE, detail = TRUE) } \keyword{arith} \keyword{math} ape/man/cophyloplot.Rd0000644000175100001440000000731712211250450014453 0ustar hornikusers\name{cophyloplot} \alias{cophyloplot} \title{Plots two phylogenetic trees face to face with links between the tips.} \description{ This function plots two trees face to face with the links if specified. It is possible to rotate the branches of each tree around the nodes by clicking. } \usage{ cophyloplot(x, y, assoc = NULL, use.edge.length = FALSE, space = 0, length.line = 1, gap = 2, type = "phylogram", rotate = FALSE, col = par("fg"), lwd = par("lwd"), lty = par("lty"), show.tip.label = TRUE, font = 3, \dots) } \arguments{ \item{x, y}{two objects of class \code{"phylo"}.} \item{assoc}{a matrix with 2 columns specifying the associations between the tips. If NULL, no links will be drawn.} \item{use.edge.length}{a logical indicating whether the branch lengths should be used to plot the trees; default is FALSE.} \item{space}{a positive value that specifies the distance between the two trees.} \item{length.line}{a positive value that specifies the length of the horizontal line associated to each taxa. Default is 1.} \item{gap}{a value specifying the distance between the tips of the phylogeny and the lines.} \item{type}{a character string specifying the type of phylogeny to be drawn; it must be one of "phylogram" (the default) or "cladogram".} \item{rotate}{a logical indicating whether the nodes of the phylogeny can be rotated by clicking. Default is FALSE.} \item{col}{a character vector indicating the color to be used for the links; recycled as necessary.} \item{lwd}{id. for the width.} \item{lty}{id. for the line type.} \item{show.tip.label}{a logical indicating whether to show the tip labels on the phylogeny (defaults to 'TRUE', i.e. the labels are shown).} \item{font}{an integer specifying the type of font for the labels: 1 (plain text), 2 (bold), 3 (italic, the default), or 4 (bold italic).} \item{\dots}{(unused)} } \details{ The aim of this function is to plot simultaneously two phylogenetic trees with associated taxa. The two trees do not necessarily have the same number of tips and more than one tip in one phylogeny can be associated with a tip in the other. The association matrix used to draw the links has to be a matrix with two columns containing the names of the tips. One line in the matrix represents one link on the plot. The first column of the matrix has to contain tip labels of the first tree (\code{phy1}) and the second column of the matrix, tip labels of the second tree (\code{phy2}). There is no limit (low or high) for the number of lines in the matrix. A matrix with two colums and one line will give a plot with one link. Arguments \code{gap}, \code{length.line} and \code{space} have to be changed to get a nice plot of the two phylogenies. Note that the function takes into account the length of the character strings corresponding to the names at the tips, so that the lines do not overwrite those names. The \code{rotate} argument can be used to transform both phylogenies in order to get the more readable plot (typically by decreasing the number of crossing lines). This can be done by clicking on the nodes. The escape button or right click take back to the console. } \author{Damien de Vienne \email{damien.de-vienne@u-psud.fr}} \seealso{ \code{\link{plot.phylo}}, \code{\link{rotate}}, \code{\link{rotateConstr}} } \examples{ #two random trees tree1 <- rtree(40) tree2 <- rtree(20) #creation of the association matrix: association <- cbind(tree2$tip.label, tree2$tip.label) cophyloplot(tree1, tree2, assoc = association, length.line = 4, space = 28, gap = 3) #plot with rotations \dontrun{ cophyloplot(tree1, tree2, assoc=association, length.line=4, space=28, gap=3, rotate=TRUE) } } \keyword{hplot} ape/man/dbd.Rd0000644000175100001440000001017512024614717012640 0ustar hornikusers\name{dbd} \alias{dyule} \alias{dbd} \alias{dbdTime} \title{Probability Density Under Birth--Death Models} \description{ These functions compute the probability density under some birth--death models, that is the probability of obtaining \emph{x} species after a time \emph{t} giving how speciation and extinction probabilities vary through time (these may be constant, or even equal to zero for extinction). } \usage{ dyule(x, lambda = 0.1, t = 1, log = FALSE) dbd(x, lambda, mu, t, conditional = FALSE, log = FALSE) dbdTime(x, birth, death, t, conditional = FALSE, BIRTH = NULL, DEATH = NULL, fast = FALSE) } \arguments{ \item{x}{a numeric vector of species numbers (see Details).} \item{lambda}{a numerical value giving the probability of speciation; can be a vector with several values for \code{dyule}.} \item{mu}{id. for extinction.} \item{t}{id. for the time(s).} \item{log}{a logical value specifying whether the probabilities should be returned log-transformed; the default is \code{FALSE}.} \item{conditional}{a logical specifying whether the probabilities should be computed conditional under the assumption of no extinction after time \code{t}.} \item{birth, death}{a (vectorized) function specifying how the speciation or extinction probability changes through time (see \code{\link{yule.time}} and below).} \item{BIRTH, DEATH}{a (vectorized) function giving the primitive of \code{birth} or \code{death}.} \item{fast}{a logical value specifying whether to use faster integration (see \code{\link{bd.time}}).} } \details{ These three functions compute the probabilities to observe \code{x} species starting from a single one after time \code{t} (assumed to be continuous). The first function is a short-cut for the second one with \code{mu = 0} and with default values for the two other arguments. \code{dbdTime} is for time-varying \code{lambda} and \code{mu} specified as \R functions. \code{dyule} is vectorized simultaneously on its three arguments \code{x}, \code{lambda}, and \code{t}, according to \R's rules of recycling arguments. \code{dbd} is vectorized simultaneously \code{x} and \code{t} (to make likelihood calculations easy), and \code{dbdTime} is vectorized only on \code{x}; the other arguments are eventually shortened with a warning if necessary. The returned value is, logically, zero for values of \code{x} out of range, i.e., negative or zero for \code{dyule} or if \code{conditional = TRUE}. However, it is not checked if the values of \code{x} are positive non-integers and the probabilities are computed and returned. The details on the form of the arguments \code{birth}, \code{death}, \code{BIRTH}, \code{DEATH}, and \code{fast} can be found in the links below. } \note{ If you use these functions to calculate a likelihood function, it is strongly recommended to compute the log-likelihood with, for instance in the case of a Yule process, \code{sum(dyule( , log = TRUE))} (see examples). } \value{ a numeric vector. } \references{ Kendall, D. G. (1948) On the generalized ``birth-and-death'' process. \emph{Annals of Mathematical Statistics}, \bold{19}, 1--15. } \author{Emmanuel Paradis} \seealso{ \code{\link{bd.time}}, \code{\link{yule.time}} } \examples{ x <- 0:10 plot(x, dyule(x), type = "h", main = "Density of the Yule process") text(7, 0.85, expression(list(lambda == 0.1, t == 1))) y <- dbd(x, 0.1, 0.05, 10) z <- dbd(x, 0.1, 0.05, 10, conditional = TRUE) d <- rbind(y, z) colnames(d) <- x barplot(d, beside = TRUE, ylab = "Density", xlab = "Number of species", legend = c("unconditional", "conditional on\nno extinction"), args.legend = list(bty = "n")) title("Density of the birth-death process") text(17, 0.4, expression(list(lambda == 0.1, mu == 0.05, t == 10))) \dontrun{ ### generate 1000 values from a Yule process with lambda = 0.05 x <- replicate(1e3, Ntip(rlineage(0.05, 0))) ### the correct way to calculate the log-likelihood...: sum(dyule(x, 0.05, 50, log = TRUE)) ### ... and the wrong way: log(prod(dyule(x, 0.05, 50))) ### a third, less preferred, way: sum(log(dyule(x, 0.05, 50))) }} \keyword{utilities} ape/man/chronopl.Rd0000644000175100001440000001257112071324651013732 0ustar hornikusers\name{chronopl} \alias{chronopl} \title{Molecular Dating With Penalized Likelihood} \description{ This function estimates the node ages of a tree using a semi-parametric method based on penalized likelihood (Sanderson 2002). The branch lengths of the input tree are interpreted as mean numbers of substitutions (i.e., per site). } \usage{ chronopl(phy, lambda, age.min = 1, age.max = NULL, node = "root", S = 1, tol = 1e-8, CV = FALSE, eval.max = 500, iter.max = 500, ...) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{lambda}{value of the smoothing parameter.} \item{age.min}{numeric values specifying the fixed node ages (if \code{age.max = NULL}) or the youngest bound of the nodes known to be within an interval.} \item{age.max}{numeric values specifying the oldest bound of the nodes known to be within an interval.} \item{node}{the numbers of the nodes whose ages are given by \code{age.min}; \code{"root"} is a short-cut for the root.} \item{S}{the number of sites in the sequences; leave the default if branch lengths are in mean number of substitutions.} \item{tol}{the value below which branch lengths are considered effectively zero.} \item{CV}{whether to perform cross-validation.} \item{eval.max}{the maximal number of evaluations of the penalized likelihood function.} \item{iter.max}{the maximal number of iterations of the optimization algorithm.} \item{\dots}{further arguments passed to control \code{nlminb}.} } \details{ The idea of this method is to use a trade-off between a parametric formulation where each branch has its own rate, and a nonparametric term where changes in rates are minimized between contiguous branches. A smoothing parameter (lambda) controls this trade-off. If lambda = 0, then the parametric component dominates and rates vary as much as possible among branches, whereas for increasing values of lambda, the variation are smoother to tend to a clock-like model (same rate for all branches). \code{lambda} must be given. The known ages are given in \code{age.min}, and the correponding node numbers in \code{node}. These two arguments must obviously be of the same length. By default, an age of 1 is assumed for the root, and the ages of the other nodes are estimated. If \code{age.max = NULL} (the default), it is assumed that \code{age.min} gives exactly known ages. Otherwise, \code{age.max} and \code{age.min} must be of the same length and give the intervals for each node. Some node may be known exactly while the others are known within some bounds: the values will be identical in both arguments for the former (e.g., \code{age.min = c(10, 5), age.max = c(10, 6), node = c(15, 18)} means that the age of node 15 is 10 units of time, and the age of node 18 is between 5 and 6). If two nodes are linked (i.e., one is the ancestor of the other) and have the same values of \code{age.min} and \code{age.max} (say, 10 and 15) this will result in an error because the medians of these values are used as initial times (here 12.5) giving initial branch length(s) equal to zero. The easiest way to solve this is to change slightly the given values, for instance use \code{age.max = 14.9} for the youngest node, or \code{age.max = 15.1} for the oldest one (or similarly for \code{age.min}). The input tree may have multichotomies. If some internal branches are of zero-length, they are collapsed (with a warning), and the returned tree will have less nodes than the input one. The presence of zero-lengthed terminal branches of results in an error since it makes little sense to have zero-rate branches. The cross-validation used here is different from the one proposed by Sanderson (2002). Here, each tip is dropped successively and the analysis is repeated with the reduced tree: the estimated dates for the remaining nodes are compared with the estimates from the full data. For the \eqn{i}{i}th tip the following is calculated: \deqn{\sum_{j=1}^{n-2}{\frac{(t_j - t_j^{-i})^2}{t_j}}}{SUM[j = 1, ..., n-2] (tj - tj[-i])^2/tj}, where \eqn{t_j}{tj} is the estimated date for the \eqn{j}{j}th node with the full phylogeny, \eqn{t_j^{-i}}{tj[-i]} is the estimated date for the \eqn{j}{j}th node after removing tip \eqn{i}{i} from the tree, and \eqn{n}{n} is the number of tips. The present version uses the \code{\link[stats]{nlminb}} to optimise the penalized likelihood function: see its help page for details on parameters controlling the optimisation procedure. } \value{ an object of class \code{"phylo"} with branch lengths as estimated by the function. There are three or four further attributes: \item{ploglik}{the maximum penalized log-likelihood.} \item{rates}{the estimated rates for each branch.} \item{message}{the message returned by \code{nlminb} indicating whether the optimisation converged.} \item{D2}{the influence of each observation on overall date estimates (if \code{CV = TRUE}).} } \note{ The new function \code{\link{chronos}} replaces the present one which is no more maintained. } \references{ Sanderson, M. J. (2002) Estimating absolute rates of molecular evolution and divergence times: a penalized likelihood approach. \emph{Molecular Biology and Evolution}, \bold{19}, 101--109. } \author{Emmanuel Paradis} \seealso{ \code{\link{chronos}}, \code{\link{chronoMPL}} } \keyword{models} ape/man/read.GenBank.Rd0000644000175100001440000000510212746142265014325 0ustar hornikusers\name{read.GenBank} \alias{read.GenBank} \title{Read DNA Sequences from GenBank via Internet} \usage{ read.GenBank(access.nb, seq.names = access.nb, species.names = TRUE, gene.names = FALSE, as.character = FALSE) } \description{ This function connects to the GenBank database, and reads nucleotide sequences using accession numbers given as arguments. } \arguments{ \item{access.nb}{a vector of mode character giving the accession numbers.} \item{seq.names}{the names to give to each sequence; by default the accession numbers are used.} \item{species.names}{a logical indicating whether to attribute the species names to the returned object.} \item{gene.names}{obsolete (will be removed soon).} \item{as.character}{a logical controlling whether to return the sequences as an object of class \code{"DNAbin"} (the default).} } \details{ The function uses the site \url{http://www.ncbi.nlm.nih.gov/} from where the sequences are retrieved. If \code{species.names = TRUE}, the returned list has an attribute \code{"species"} containing the names of the species taken from the field ``ORGANISM'' in GenBank. Since ape 3.6, this function retrieves the sequences in FASTA format: this is more efficient and more flexible (scaffolds and contigs can be read). The option \code{gene.names} is obsolete and will be removed; this information is also present in the description. Setting \code{species.names = FALSE} is quite faster (could be useful if you read a series of scaffolds or contigs, or if you already have the species names). } \value{ A list of DNA sequences made of vectors of class \code{"DNAbin"}, or of single characters (if \code{as.character = TRUE}) with two attributes (species and description). } \seealso{ \code{\link{read.dna}}, \code{\link{write.dna}}, \code{\link{dist.dna}}, \code{\link{DNAbin}} } \author{Emmanuel Paradis} \examples{ ## This won't work if your computer is not connected ## to the Internet ## Get the 8 sequences of tanagers (Ramphocelus) ## as used in Paradis (1997) ref <- c("U15717", "U15718", "U15719", "U15720", "U15721", "U15722", "U15723", "U15724") ## Copy/paste or type the following commands if you ## want to try them. \dontrun{ Rampho <- read.GenBank(ref) ## get the species names: attr(Rampho, "species") ## build a matrix with the species names and the accession numbers: cbind(attr(Rampho, "species"), names(Rampho)) ## print the first sequence ## (can be done with `Rampho$U15717' as well) Rampho[[1]] ## the description from each FASTA sequence: attr(Rampho, "description") } } \keyword{IO} ape/man/LTT.Rd0000644000175100001440000000601012706674664012561 0ustar hornikusers\name{LTT} \alias{LTT} \title{Theoretical Lineage-Through Time Plots} \description{ This function draws the lineage-through time (LTT) plots predicted under a speciation-extinction model (aka birth-death model) with specified values of speciation and extinction rates (which may vary with time). A prediction interval is plotted by default which requires to define a sample size (100 by default), and different curves can be combined. } \usage{ LTT(birth = 0.1, death = 0, N = 100, Tmax = 50, PI = 95, scaled = TRUE, eps = 0.1, add = FALSE, backward = TRUE, ltt.style = list("black", 1, 1), pi.style = list("blue", 1, 2)) } \arguments{ \item{birth}{the speciation rate, this may be either a numeric value or a funtion of time (named \code{t} in the code of the function).} \item{death}{id. for the extinction rate.} \item{N}{the size of the tree.} \item{Tmax}{the age of the root of the tree.} \item{PI}{the percentage value of the prediction interval; set this value to 0 to not draw this interval.} \item{scaled}{a logical values specifying whether to scale the \eqn{y}-axis between 0 and 1.} \item{eps}{a numerical value giving the resolution of the time axis.} \item{add}{a logical values specifying whether to make a new plot (the default).} \item{backward}{a logical value: should the time axis be traced from the present (the default), or from the root of the tree?} \item{ltt.style}{a list with three elements giving the style of the LTT curve with, respectively, the colour (\code{"col"}), the line thickness (\code{"lwd"}), and the line type (\code{"lty"}).} \item{pi.style}{id. for the prediction interval.} } \details{ For the moment, this works well when \code{birth} and \code{death} are constant. Some improvements are under progress for time-dependent rates (but see below for an example). } \references{ Hallinan, N. (2012) The generalized time variable reconstructed birth--death process. \emph{Journal of Theoretical Biology}, \bold{300}, 265--276. Paradis, E. (2011) Time-dependent speciation and extinction from phylogenies: a least squares approach. \emph{Evolution}, \bold{65}, 661--672. Paradis, E. (2015) Random phylogenies and the distribution of branching times. \emph{Journal of Theoretical Biology}, \bold{387}, 39--45. } \author{Emmanuel Paradis} \seealso{ \code{\link{ltt.plot}} } \examples{ ### predicted LTT plot under a Yule model with lambda = 0.1 ### and 50 species after 50 units of time... LTT(N = 50) ### ... and with a birth-death model with the same rate of ### diversification (try with N = 500): LTT(0.2, 0.1, N = 50, PI = 0, add = TRUE, ltt.style = list("red", 2, 1)) ### predictions under different tree sizes: layout(matrix(1:4, 2, 2, byrow = TRUE)) for (N in c(50, 100, 500, 1000)) { LTT(0.2, 0.1, N = N) title(paste("N =", N)) } layout(1) \dontrun{ ### speciation rate decreasing with time birth.logis <- function(t) 1/(1 + exp(0.02 * t + 4)) LTT(birth.logis) LTT(birth.logis, 0.05) LTT(birth.logis, 0.1) } } \keyword{hplot} ape/man/c.phylo.Rd0000644000175100001440000000373613002704366013465 0ustar hornikusers\name{c.phylo} \alias{c.phylo} \alias{c.multiPhylo} \alias{.compressTipLabel} \alias{.uncompressTipLabel} \title{Building Lists of Trees} \description{ These functions help to build lists of trees of class \code{"multiPhylo"}. } \usage{ \method{c}{phylo}(..., recursive = TRUE) \method{c}{multiPhylo}(..., recursive = TRUE) .compressTipLabel(x, ref = NULL) .uncompressTipLabel(x) } \arguments{ \item{\dots}{one or several objects of class \code{"phylo"} and/or \code{"multiPhylo"}.} \item{recursive}{for compatibily with the generic (do not change).} \item{x}{an object of class \code{"phylo"} or \code{"multiPhylo"}.} \item{ref}{an optional vector of mode character to constrain the order of the tips. By default, the order from the first tree is used.} } \details{ These \code{c} methods check all the arguments, and return by default a list of single trees unless some objects are not trees or lists of trees, in which case \code{recursive} is switched to FALSE and a warning message is given. If \code{recursive = FALSE}, the objects are simply concatenated into a list. Before \pkg{ape} 4.0, \code{recursive} was always set to FALSE. \code{.compressTipLabel} transforms an object of class \code{"multiPhylo"} by checking that all trees have the same tip labels and renumbering the tips in the \code{edge} matrix so that the tip numbers are also the same taking the first tree as the reference (duplicated labels are not allowed). The returned object has a unique vector of tip labels (\code{attr(x, "TipLabel")}). \code{.uncompressTipLabel} does the reverse operation. } \value{ An object of class \code{"multiPhylo"}. } \author{Emmanuel Paradis} \seealso{\code{\link{summary.phylo}}, \code{\link{multiphylo}}} \examples{ x <- c(rtree(4), rtree(2)) x y <- c(rtree(4), rtree(4)) z <- c(x, y) z print(z, TRUE) try(.compressTipLabel(x)) # error a <- .compressTipLabel(y) .uncompressTipLabel(a) # back to y ## eventually compare str(a) and str(y) } \keyword{manip} ape/man/DNAbin.Rd0000644000175100001440000001104212661353334013176 0ustar hornikusers\name{DNAbin} \alias{DNAbin} \alias{print.DNAbin} \alias{[.DNAbin} \alias{rbind.DNAbin} \alias{cbind.DNAbin} \alias{as.matrix.DNAbin} \alias{c.DNAbin} \alias{as.list.DNAbin} \alias{labels.DNAbin} \title{Manipulate DNA Sequences in Bit-Level Format} \description{ These functions help to manipulate DNA sequences coded in the bit-level coding scheme. } \usage{ \method{print}{DNAbin}(x, printlen = 6, digits = 3, \dots) \method{rbind}{DNAbin}(\dots) \method{cbind}{DNAbin}(\dots, check.names = TRUE, fill.with.gaps = FALSE, quiet = FALSE) \method{[}{DNAbin}(x, i, j, drop = FALSE) \method{as.matrix}{DNAbin}(x, \dots) \method{c}{DNAbin}(\dots, recursive = FALSE) \method{as.list}{DNAbin}(x, \dots) \method{labels}{DNAbin}(object, \dots) } \arguments{ \item{x, object}{an object of class \code{"DNAbin"}.} \item{\dots}{either further arguments to be passed to or from other methods in the case of \code{print}, \code{as.matrix}, and \code{labels}, or a series of objects of class \code{"DNAbin"} in the case of \code{rbind}, \code{cbind}, and \code{c}.} \item{printlen}{the number of labels to print (6 by default).} \item{digits}{the number of digits to print (3 by default).} \item{check.names}{a logical specifying whether to check the rownames before binding the columns (see details).} \item{fill.with.gaps}{a logical indicating whether to keep all possible individuals as indicating by the rownames, and eventually filling the missing data with insertion gaps (ignored if \code{check.names = FALSE}).} \item{quiet}{a logical to switch off warning messages when some rows are dropped.} \item{i, j}{indices of the rows and/or columns to select or to drop. They may be numeric, logical, or character (in the same way than for standard \R objects).} \item{drop}{logical; if \code{TRUE}, the returned object is of the lowest possible dimension.} \item{recursive}{for compatibility with the generic (unused).} } \details{ These are all `methods' of generic functions which are here applied to DNA sequences stored as objects of class \code{"DNAbin"}. They are used in the same way than the standard \R functions to manipulate vectors, matrices, and lists. Additionally, the operators \code{[[} and \code{$} may be used to extract a vector from a list. Note that the default of \code{drop} is not the same than the generic operator: this is to avoid dropping rownames when selecting a single sequence. These functions are provided to manipulate easily DNA sequences coded with the bit-level coding scheme. The latter allows much faster comparisons of sequences, as well as storing them in less memory compared to the format used before \pkg{ape} 1.10. For \code{cbind}, the default behaviour is to keep only individuals (as indicated by the rownames) for which there are no missing data. If \code{fill.with.gaps = TRUE}, a `complete' matrix is returned, enventually with insertion gaps as missing data. If \code{check.names = TRUE} (the default), the rownames of each matrix are checked, and the rows are reordered if necessary. If \code{check.names = FALSE}, the matrices must all have the same number of rows, and are simply binded; the rownames of the first matrix are used. See the examples. \code{as.matrix} may be used to convert DNA sequences (of the same length) stored in a list into a matrix while keeping the names and the class. \code{as.list} does the reverse operation. } \value{ an object of class \code{"DNAbin"} in the case of \code{rbind}, \code{cbind}, and \code{[}. } \references{ Paradis, E. (2007) A Bit-Level Coding Scheme for Nucleotides. \url{http://ape-package.ird.fr/misc/BitLevelCodingScheme_20April2007.pdf} Paradis, E. (2012) \emph{Analysis of Phylogenetics and Evolution with R (Second Edition).} New York: Springer. } \author{Emmanuel Paradis} \seealso{ \code{\link{as.DNAbin}}, \code{\link{read.dna}}, \code{\link{read.GenBank}}, \code{\link{write.dna}}, \code{\link{image.DNAbin}},\code{\link{AAbin}} The corresponding generic functions are documented in the package \pkg{base}. } \examples{ data(woodmouse) woodmouse print(woodmouse, 15, 6) print(woodmouse[1:5, 1:300], 15, 6) ### Just to show how distances could be influenced by sampling: dist.dna(woodmouse[1:2, ]) dist.dna(woodmouse[1:3, ]) ### cbind and its options: x <- woodmouse[1:2, 1:5] y <- woodmouse[2:4, 6:10] as.character(cbind(x, y)) # gives warning as.character(cbind(x, y, fill.with.gaps = TRUE)) \dontrun{ as.character(cbind(x, y, check.names = FALSE)) # gives an error } } \keyword{manip} ape/man/hivtree.Rd0000644000175100001440000000250410775732361013561 0ustar hornikusers\name{hivtree} \alias{hivtree} \alias{hivtree.newick} \alias{hivtree.table} \title{Phylogenetic Tree of 193 HIV-1 Sequences} \description{ This data set describes an estimated clock-like phylogeny of 193 HIV-1 group M sequences sampled in the Democratic Republic of Congo. } \usage{ data(hivtree.newick) data(hivtree.table) } \format{ \code{hivtree.newick} is a string with the tree in Newick format. The data frame \code{hivtree.table} contains the corresponding internode distances. } \source{ This is a data example from Strimmer and Pybus (2001). } \references{ Strimmer, K. and Pybus, O. G. (2001) Exploring the demographic history of DNA sequences using the generalized skyline plot. \emph{Molecular Biology and Evolution}, \bold{18}, 2298--2305. } \examples{ # example tree in NH format (a string) data("hivtree.newick") hivtree.newick # generate file "hivtree.phy" in working directory cat(hivtree.newick, file = "hivtree.phy", sep = "\n") tree.hiv <- read.tree("hivtree.phy") # load tree unlink("hivtree.phy") # delete the file "hivtree.phy" plot(tree.hiv) # table with list of internode distances data("hivtree.table") hivtree.table # construct coalescence intervals ci <- coalescent.intervals(tree.hiv) # from tree ci <- coalescent.intervals(hivtree.table$size) #from intervals ci } \keyword{datasets} ape/man/as.bitsplits.Rd0000644000175100001440000000406712442275616014536 0ustar hornikusers\name{as.bitsplits} \alias{as.bitsplits} \alias{as.bitsplits.prop.part} \alias{print.bitsplits} \alias{sort.bitsplits} \alias{bitsplits} \alias{countBipartitions} \alias{as.prop.part} \alias{as.prop.part.bitsplits} \title{Split Frequencies and Conversion Among Split Classes} \description{ \code{bitsplits} returns the bipartitions (aka splits) for a single tree or a list of trees. \code{countBipartitions} returns the frequencies of the bipartitions from a reference tree (phy) observed in a list of trees (X). \code{as.bitsplits} and \code{as.prop.part} are generic functions for converting between the \code{"bitsplits"} and \code{"prop.part"} classes. } \usage{ bitsplits(x) countBipartitions(phy, X) as.bitsplits(x) \method{as.bitsplits}{prop.part}(x) \method{print}{bitsplits}(x, ...) \method{sort}{bitsplits}(x, decreasing = FALSE, ...) as.prop.part(x) \method{as.prop.part}{bitsplits}(x) } \arguments{ \item{x}{an object of the appropriate class.} \item{phy}{an object of class \code{"phylo"}.} \item{X}{an object of class \code{"multiPhylo"}.} \item{decreasing}{a logical value to sort the bipartitions in increasing (the default) or decreasing order of their frequency.} \item{\dots}{further arguments passed to or from other methods.} } \details{ These functions count bipartitions as defined by internal branches, so they do not work with rooted trees (see examples). The structure of the class \code{"bitsplits"} is described in a separate document on ape's web site. } \value{ \code{bitsplits}, \code{as.bitsplits}, and \code{sort} return an object of class \code{"bitsplits"}. \code{countBipartitions} returns a vector of integers. \code{as.prop.part} returns an object of class \code{"prop.part"}. } \author{Emmanuel Paradis} \seealso{\code{\link{prop.part}}} \examples{ tr <- rtree(20) pp <- prop.part(tr) as.bitsplits(pp) ## doesn't work for rooted trees...: countBipartitions(rtree(10), rmtree(100, 10)) ## ... but OK with unrooted trees: countBipartitions(rtree(10, rooted = FALSE), rmtree(100, 10, rooted = FALSE)) } \keyword{manip} ape/man/corBlomberg.Rd0000644000175100001440000000375711010351255014341 0ustar hornikusers\name{corBlomberg} \alias{corBlomberg} \alias{coef.corBlomberg} \alias{corMatrix.corBlomberg} \title{Blomberg et al.'s Correlation Structure} \usage{ corBlomberg(value, phy, form = ~1, fixed = FALSE) \method{corMatrix}{corBlomberg}(object, covariate = getCovariate(object), corr = TRUE, ...) \method{coef}{corBlomberg}(object, unconstrained = TRUE, \dots) } \arguments{ \item{value}{the (initial) value of the parameter \eqn{g}{g}.} \item{phy}{an object of class \code{"phylo"}.} \item{form}{(ignored).} \item{fixed}{a logical specifying whether \code{gls} should estimate \eqn{\gamma}{gamma} (the default) or keep it fixed.} \item{object}{an (initialized) object of class \code{"corBlomberg"}.} \item{covariate}{(ignored).} \item{corr}{a logical value specifying whether to return the correlation matrix (the default) or the variance-covariance matrix.} \item{unconstrained}{a logical value. If \code{TRUE} (the default), the coefficients are returned in unconstrained form (the same used in the optimization algorithm). If \code{FALSE} the coefficients are returned in ``natural'', possibly constrained, form.} \item{\dots}{further arguments passed to or from other methods.} } \description{ The ``ACDC'' (accelerated/decelerated) model assumes that continuous traits evolve under a Brownian motion model which rates accelerates (if \eqn{g}{g} < 1) or decelerates (if \eqn{g}{g} > 1) through time. If \eqn{g}{g} = 1, then the model reduces to a Brownian motion model. } \value{ an object of class \code{"corBlomberg"}, the coefficients from an object of this class, or the correlation matrix of an initialized object of this class. In most situations, only \code{corBlomberg} will be called by the user. } \author{Emmanuel Paradis} \references{ Blomberg, S. P., Garland, Jr, T., and Ives, A. R. (2003) Testing for phylogenetic signal in comparative data: behavioral traits are more labile. \emph{Evolution}, \bold{57}, 717--745. } \keyword{models} ape/man/mat3.Rd0000644000175100001440000000111311163664407012747 0ustar hornikusers\name{mat3} \alias{mat3} \title{Three Matrices} \description{ Three matrices respectively representing Serological (asymmetric), DNA hybridization (asymmetric) and Anatomical (symmetric) distances among 9 families. } \usage{ data(mat3) } \format{ A data frame with 27 observations and 9 variables. } \source{ Lapointe, F.-J., J. A. W. Kirsch and J. M. Hutcheon. 1999. Total evidence, consensus, and bat phylogeny: a distance-based approach. Molecular Phylogenetics and Evolution 11: 55-66. } \seealso{ \code{\link{mat5Mrand}}, \code{\link{mat5M3ID}} } \keyword{datasets} ape/man/dist.dna.Rd0000644000175100001440000002426012671755310013616 0ustar hornikusers\name{dist.dna} \alias{dist.dna} \title{Pairwise Distances from DNA Sequences} \usage{ dist.dna(x, model = "K80", variance = FALSE, gamma = FALSE, pairwise.deletion = FALSE, base.freq = NULL, as.matrix = FALSE) } \arguments{ \item{x}{a matrix or a list containing the DNA sequences; this must be of class \code{"DNAbin"} (use \code{\link{as.DNAbin}} is they are stored as character).} \item{model}{a character string specifying the evolutionary model to be used; must be one of \code{"raw"}, \code{"N"}, \code{"TS"}, \code{"TV"}, \code{"JC69"}, \code{"K80"} (the default), \code{"F81"}, \code{"K81"}, \code{"F84"}, \code{"BH87"}, \code{"T92"}, \code{"TN93"}, \code{"GG95"}, \code{"logdet"}, \code{"paralin"}, \code{"indel"}, or \code{"indelblock"}.} \item{variance}{a logical indicating whether to compute the variances of the distances; defaults to \code{FALSE} so the variances are not computed.} \item{gamma}{a value for the gamma parameter possibly used to apply a correction to the distances (by default no correction is applied).} \item{pairwise.deletion}{a logical indicating whether to delete the sites with missing data in a pairwise way. The default is to delete the sites with at least one missing data for all sequences (ignored if \code{model = "indel"} or \code{"indelblock"}).} \item{base.freq}{the base frequencies to be used in the computations (if applicable). By default, the base frequencies are computed from the whole set of sequences.} \item{as.matrix}{a logical indicating whether to return the results as a matrix. The default is to return an object of class \link[stats]{dist}.} } \description{ This function computes a matrix of pairwise distances from DNA sequences using a model of DNA evolution. Eleven substitution models (and the raw distance) are currently available. } \details{ The molecular evolutionary models available through the option \code{model} have been extensively described in the literature. A brief description is given below; more details can be found in the references. \itemize{ \item{\code{raw}, \code{N}: }{This is simply the proportion or the number of sites that differ between each pair of sequences. This may be useful to draw ``saturation plots''. The options \code{variance} and \code{gamma} have no effect, but \code{pairwise.deletion} can.} \item{\code{TS}, \code{TV}: }{These are the numbers of transitions and transversions, respectively.} \item{\code{JC69}: }{This model was developed by Jukes and Cantor (1969). It assumes that all substitutions (i.e. a change of a base by another one) have the same probability. This probability is the same for all sites along the DNA sequence. This last assumption can be relaxed by assuming that the substition rate varies among site following a gamma distribution which parameter must be given by the user. By default, no gamma correction is applied. Another assumption is that the base frequencies are balanced and thus equal to 0.25.} \item{\code{K80}: }{The distance derived by Kimura (1980), sometimes referred to as ``Kimura's 2-parameters distance'', has the same underlying assumptions than the Jukes--Cantor distance except that two kinds of substitutions are considered: transitions (A <-> G, C <-> T), and transversions (A <-> C, A <-> T, C <-> G, G <-> T). They are assumed to have different probabilities. A transition is the substitution of a purine (C, T) by another one, or the substitution of a pyrimidine (A, G) by another one. A transversion is the substitution of a purine by a pyrimidine, or vice-versa. Both transition and transversion rates are the same for all sites along the DNA sequence. Jin and Nei (1990) modified the Kimura model to allow for variation among sites following a gamma distribution. Like for the Jukes--Cantor model, the gamma parameter must be given by the user. By default, no gamma correction is applied.} \item{\code{F81}: }{Felsenstein (1981) generalized the Jukes--Cantor model by relaxing the assumption of equal base frequencies. The formulae used in this function were taken from McGuire et al. (1999)}. \item{\code{K81}: }{Kimura (1981) generalized his model (Kimura 1980) by assuming different rates for two kinds of transversions: A <-> C and G <-> T on one side, and A <-> T and C <-> G on the other. This is what Kimura called his ``three substitution types model'' (3ST), and is sometimes referred to as ``Kimura's 3-parameters distance''}. \item{\code{F84}: }{This model generalizes K80 by relaxing the assumption of equal base frequencies. It was first introduced by Felsenstein in 1984 in Phylip, and is fully described by Felsenstein and Churchill (1996). The formulae used in this function were taken from McGuire et al. (1999)}. \item{\code{BH87}: }{Barry and Hartigan (1987) developed a distance based on the observed proportions of changes among the four bases. This distance is not symmetric.} \item{\code{T92}: }{Tamura (1992) generalized the Kimura model by relaxing the assumption of equal base frequencies. This is done by taking into account the bias in G+C content in the sequences. The substitution rates are assumed to be the same for all sites along the DNA sequence.} \item{\code{TN93}: }{Tamura and Nei (1993) developed a model which assumes distinct rates for both kinds of transition (A <-> G versus C <-> T), and transversions. The base frequencies are not assumed to be equal and are estimated from the data. A gamma correction of the inter-site variation in substitution rates is possible.} \item{\code{GG95}: }{Galtier and Gouy (1995) introduced a model where the G+C content may change through time. Different rates are assumed for transitons and transversions.} \item{\code{logdet}: }{The Log-Det distance, developed by Lockhart et al. (1994), is related to BH87. However, this distance is symmetric. Formulae from Gu and Li (1996) are used. \code{dist.logdet} in \pkg{phangorn} uses a different implementation that gives substantially different distances for low-diverging sequences.} \item{\code{paralin}: }{Lake (1994) developed the paralinear distance which can be viewed as another variant of the Barry--Hartigan distance.} \item{\code{indel}: }{this counts the number of sites where there is an insertion/deletion gap in one sequence and not in the other.} \item{\code{indelblock}: }{same than before but contiguous gaps are counted as a single unit. Note that the distance between \code{-A-} and \code{A--} is 3 because there are three different blocks of gaps, whereas the ``indel'' distance will be 2.} }} \note{ If the sequences are very different, most evolutionary distances are undefined and a non-finite value (Inf or NaN) is returned. You may do \code{dist.dna(, model = "raw")} to check whether some values are higher than 0.75. } \value{ an object of class \link[stats]{dist} (by default), or a numeric matrix if \code{as.matrix = TRUE}. If \code{model = "BH87"}, a numeric matrix is returned because the Barry--Hartigan distance is not symmetric. If \code{variance = TRUE} an attribute called \code{"variance"} is given to the returned object. } \references{ Barry, D. and Hartigan, J. A. (1987) Asynchronous distance between homologous DNA sequences. \emph{Biometrics}, \bold{43}, 261--276. Felsenstein, J. (1981) Evolutionary trees from DNA sequences: a maximum likelihood approach. \emph{Journal of Molecular Evolution}, \bold{17}, 368--376. Felsenstein, J. and Churchill, G. A. (1996) A Hidden Markov model approach to variation among sites in rate of evolution. \emph{Molecular Biology and Evolution}, \bold{13}, 93--104. Galtier, N. and Gouy, M. (1995) Inferring phylogenies from DNA sequences of unequal base compositions. \emph{Proceedings of the National Academy of Sciences USA}, \bold{92}, 11317--11321. Gu, X. and Li, W.-H. (1996) Bias-corrected paralinear and LogDet distances and tests of molecular clocks and phylogenies under nonstationary nucleotide frequencies. \emph{Molecular Biology and Evolution}, \bold{13}, 1375--1383. Jukes, T. H. and Cantor, C. R. (1969) Evolution of protein molecules. in \emph{Mammalian Protein Metabolism}, ed. Munro, H. N., pp. 21--132, New York: Academic Press. Kimura, M. (1980) A simple method for estimating evolutionary rates of base substitutions through comparative studies of nucleotide sequences. \emph{Journal of Molecular Evolution}, \bold{16}, 111--120. Kimura, M. (1981) Estimation of evolutionary distances between homologous nucleotide sequences. \emph{Proceedings of the National Academy of Sciences USA}, \bold{78}, 454--458. Jin, L. and Nei, M. (1990) Limitations of the evolutionary parsimony method of phylogenetic analysis. \emph{Molecular Biology and Evolution}, \bold{7}, 82--102. Lake, J. A. (1994) Reconstructing evolutionary trees from DNA and protein sequences: paralinear distances. \emph{Proceedings of the National Academy of Sciences USA}, \bold{91}, 1455--1459. Lockhart, P. J., Steel, M. A., Hendy, M. D. and Penny, D. (1994) Recovering evolutionary trees under a more realistic model of sequence evolution. \emph{Molecular Biology and Evolution}, \bold{11}, 605--602. McGuire, G., Prentice, M. J. and Wright, F. (1999). Improved error bounds for genetic distances from DNA sequences. \emph{Biometrics}, \bold{55}, 1064--1070. Tamura, K. (1992) Estimation of the number of nucleotide substitutions when there are strong transition-transversion and G + C-content biases. \emph{Molecular Biology and Evolution}, \bold{9}, 678--687. Tamura, K. and Nei, M. (1993) Estimation of the number of nucleotide substitutions in the control region of mitochondrial DNA in humans and chimpanzees. \emph{Molecular Biology and Evolution}, \bold{10}, 512--526. } \author{Emmanuel Paradis} \seealso{ \code{\link{read.GenBank}}, \code{\link{read.dna}}, \code{\link{write.dna}}, \code{\link{DNAbin}}, \code{\link{dist.gene}}, \code{\link{cophenetic.phylo}}, \code{\link[stats]{dist}} } \keyword{manip} \keyword{multivariate} ape/man/compar.lynch.Rd0000644000175100001440000000510712425450506014502 0ustar hornikusers\name{compar.lynch} \alias{compar.lynch} \title{Lynch's Comparative Method} \usage{ compar.lynch(x, G, eps = 1e-4) } \arguments{ \item{x}{eiher a matrix, a vector, or a data.frame containing the data with species as rows and variables as columns.} \item{G}{a matrix that can be interpreted as an among-species correlation matrix.} \item{eps}{a numeric value to detect convergence of the EM algorithm.} } \description{ This function computes the heritable additive value and the residual deviation for continous characters, taking into account the phylogenetic relationships among species, following the comparative method described in Lynch (1991). } \details{ The parameter estimates are computed following the EM (expectation-maximization) algorithm. This algorithm usually leads to convergence but may lead to local optima of the likelihood function. It is recommended to run several times the function in order to detect these potential local optima. The `optimal' value for \code{eps} depends actually on the range of the data and may be changed by the user in order to check the stability of the parameter estimates. Convergence occurs when the differences between two successive iterations of the EM algorithm leads to differences between both residual and additive values less than or equal to \code{eps}. } \note{ The present function does not perform the estimation of ancestral phentoypes as proposed by Lynch (1991). This will be implemented in a future version. } \value{ A list with the following components: \item{vare}{estimated residual variance-covariance matrix.} \item{vara}{estimated additive effect variance covariance matrix.} \item{u}{estimates of the phylogeny-wide means.} \item{A}{addtitive value estimates.} \item{E}{residual values estimates.} \item{lik}{logarithm of the likelihood for the entire set of observed taxon-specific mean.} } \references{ Lynch, M. (1991) Methods for the analysis of comparative data in evolutionary biology. \emph{Evolution}, \bold{45}, 1065--1080. } \author{Julien Claude \email{Julien.Claude@univ-montp2.fr}} \seealso{ \code{\link{pic}}, \code{\link{compar.gee}} } \examples{ ### The example in Lynch (1991) cat("((((Homo:0.21,Pongo:0.21):0.28,", "Macaca:0.49):0.13,Ateles:0.62):0.38,Galago:1.00);", file = "ex.tre", sep = "\n") tree.primates <- read.tree("ex.tre") unlink("ex.tre") X <- c(4.09434, 3.61092, 2.37024, 2.02815, -1.46968) Y <- c(4.74493, 3.33220, 3.36730, 2.89037, 2.30259) compar.lynch(cbind(X, Y), G = vcv.phylo(tree.primates, cor = TRUE)) } \keyword{regression} ape/man/stree.Rd0000644000175100001440000000252412124320030013207 0ustar hornikusers\name{stree} \alias{stree} \title{Generates Systematic Regular Trees} \usage{ stree(n, type = "star", tip.label = NULL) } \arguments{ \item{n}{an integer giving the number of tips in the tree.} \item{type}{a character string specifying the type of tree to generate; four choices are possible: \code{"star"}, \code{"balanced"}, \code{"left"}, \code{"right"}, or any unambiguous abbreviation of these.} \item{tip.label}{a character vector giving the tip labels; if not specified, the tips "t1", "t2", ..., are given.} } \description{ This function generates trees with regular shapes. } \details{ The types of trees generated are: \itemize{ \item{``star''}{a star (or comb) tree with a single internal node.} \item{``balanced''}{a fully balanced dichotomous rooted tree; \code{n} must be a power of 2 (2, 4, 8, \dots).} \item{``left''}{a fully unbalanced rooted tree where the largest clade is on the left-hand side when the tree is plotted upwards.} \item{``right''}{same than above but in the other direction.} } } \value{ An object of class \code{"phylo"}. } \author{Emmanuel Paradis} \seealso{ \code{\link{compute.brlen}}, \code{\link{rtree}} } \examples{ layout(matrix(1:4, 2, 2)) plot(stree(100)) plot(stree(128, "balanced")) plot(stree(100, "left")) plot(stree(100, "right")) } \keyword{datagen} ape/man/read.tree.Rd0000644000175100001440000001174312473377205013770 0ustar hornikusers\name{read.tree} \alias{read.tree} \alias{phylo} \title{Read Tree File in Parenthetic Format} \usage{ read.tree(file = "", text = NULL, tree.names = NULL, skip = 0, comment.char = "#", keep.multi = FALSE, ...) } \arguments{ \item{file}{a file name specified by either a variable of mode character, or a double-quoted string; if \code{file = ""} (the default) then the tree is input on the keyboard, the entry being terminated with a blank line.} \item{text}{alternatively, the name of a variable of mode character which contains the tree(s) in parenthetic format. By default, this is ignored (set to \code{NULL}, meaning that the tree is read in a file); if \code{text} is not \code{NULL}, then the argument \code{file} is ignored.} \item{tree.names}{if there are several trees to be read, a vector of mode character that gives names to the individual trees; if \code{NULL} (the default), the trees are named \code{"tree1"}, \code{"tree2"}, ...} \item{skip}{the number of lines of the input file to skip before beginning to read data (this is passed directly to\code{ scan()}).} \item{comment.char}{a single character, the remaining of the line after this character is ignored (this is passed directly to \code{scan()}).} \item{keep.multi}{if \code{TRUE} and \code{tree.names = NULL} then single trees are returned in \code{"multiPhylo"} format, with any name that is present (see details). Default is \code{FALSE}.} \item{\dots}{further arguments to be passed to \code{scan()}.} } \description{ This function reads a file which contains one or several trees in parenthetic format known as the Newick or New Hampshire format. } \details{ The default option for \code{file} allows to type directly the tree on the keyboard (or possibly to copy from an editor and paste in R's console) with, e.g., \code{mytree <- read.tree()}. `read.tree' tries to represent correctly trees with a badly represented root edge (i.e. with an extra pair of parentheses). For instance, the tree "((A:1,B:1):10);" will be read like "(A:1,B:1):10;" but a warning message will be issued in the former case as this is apparently not a valid Newick format. If there are two root edges (e.g., "(((A:1,B:1):10):10);"), then the tree is not read and an error message is issued. If there are any characters preceding the first "(" in a line then this is assigned to the name. This is returned when a "multiPhylo" object is returned and \code{tree.names = NULL}. } \value{ an object of class \code{"phylo"} with the following components: \item{edge}{a two-column matrix of mode numeric where each row represents an edge of the tree; the nodes and the tips are symbolized with numbers; the tips are numbered 1, 2, \dots, and the nodes are numbered after the tips. For each row, the first column gives the ancestor.} \item{edge.length}{(optional) a numeric vector giving the lengths of the branches given by \code{edge}.} \item{tip.label}{a vector of mode character giving the names of the tips; the order of the names in this vector corresponds to the (positive) number in \code{edge}.} \item{Nnode}{the number of (internal) nodes.} \item{node.label}{(optional) a vector of mode character giving the names of the nodes.} \item{root.edge}{(optional) a numeric value giving the length of the branch at the root if it exists.} If several trees are read in the file, the returned object is of class \code{"multiPhylo"}, and is a list of objects of class \code{"phylo"}. The name of each tree can be specified by \code{tree.names}, or can be read from the file (see details). } \references{ Felsenstein, J. The Newick tree format. \url{http://evolution.genetics.washington.edu/phylip/newicktree.html} Olsen, G. Interpretation of the "Newick's 8:45" tree format standard. \url{http://evolution.genetics.washington.edu/phylip/newick_doc.html} Paradis, E. (2008) Definition of Formats for Coding Phylogenetic Trees in R. \url{http://ape-package.ird.fr/misc/FormatTreeR_24Oct2012.pdf} Paradis, E. (2012) \emph{Analysis of Phylogenetics and Evolution with R (Second Edition).} New York: Springer. } \author{Emmanuel Paradis and Daniel Lawson \email{dan.lawson@bristol.ac.uk}} \seealso{ \code{\link{write.tree}}, \code{\link{read.nexus}}, \code{\link{write.nexus}}, \code{\link[base]{scan}} for the basic R function to read data in a file } \examples{ ### An extract from Sibley and Ahlquist (1990) s <- "owls(((Strix_aluco:4.2,Asio_otus:4.2):3.1,Athene_noctua:7.3):6.3,Tyto_alba:13.5);" cat(s, file = "ex.tre", sep = "\n") tree.owls <- read.tree("ex.tre") str(tree.owls) tree.owls tree.owls <- read.tree("ex.tre", keep.multi = TRUE) tree.owls names(tree.owls) unlink("ex.tre") # delete the file "ex.tre" ### Only the first three species using the option `text' TREE <- "((Strix_aluco:4.2,Asio_otus:4.2):3.1,Athene_noctua:7.3);" TREE tree.owls.bis <- read.tree(text = TREE) str(tree.owls.bis) tree.owls.bis } \keyword{manip} \keyword{IO} ape/man/weight.taxo.Rd0000644000175100001440000000146011353107305014337 0ustar hornikusers\name{weight.taxo} \alias{weight.taxo} \alias{weight.taxo2} \title{Define Similarity Matrix} \usage{ weight.taxo(x) weight.taxo2(x, y) } \arguments{ \item{x, y}{a vector or a factor.} } \description{ \code{weight.taxo} computes a matrix whose entries [i, j] are set to 1 if x[i] == x[j], 0 otherwise. \code{weight.taxo2} computes a matrix whose entries [i, j] are set to 1 if x[i] == x[j] AND y[i] != y[j], 0 otherwise. The diagonal [i, i] is always set to 0. The returned matrix can be used as a weight matrix in \code{\link{Moran.I}}. \code{x} and \code{y} may be vectors of factors. See further details in \code{vignette("MoranI")}. } \value{ a square numeric matrix. } \author{Emmanuel Paradis} \seealso{ \code{\link{Moran.I}}, \code{\link{correlogram.formula}} } \keyword{manip} ape/man/subtrees.Rd0000644000175100001440000000205611133052076013734 0ustar hornikusers\name{subtrees} \alias{subtrees} \title{All subtrees of a Phylogenetic Tree} \usage{ subtrees(tree, wait=FALSE) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{wait}{a logical indicating whether the node beeing processed should be printed (useful for big phylogenies).} } \description{ This function returns a list of all the subtrees of a phylogenetic tree. } \author{Damien de Vienne \email{damien.de-vienne@u-psud.fr}} \seealso{ \code{\link{zoom}}, \code{\link{subtreeplot}} for functions extracting particular subtrees. } \value{ \code{subtrees} returns a list of trees of class \code{"phylo"} and returns invisibly for each subtree a list with the following components: \item{tip.label}{} \item{node.label}{} \item{Ntip}{} \item{Nnode}{} } \examples{ ### Random tree with 12 leaves phy<-rtree(12) par(mfrow=c(4,3)) plot(phy, sub="Complete tree") ### Extract the subtrees l<-subtrees(phy) ### plot all the subtrees for (i in 1:11) plot(l[[i]], sub=paste("Node", l[[i]]$node.label[1])) par(mfrow=c(1,1)) } \keyword{manip} ape/man/reorder.phylo.Rd0000644000175100001440000000515413002701475014677 0ustar hornikusers\name{reorder.phylo} \alias{reorder.phylo} \alias{reorder.multiPhylo} \title{Internal Reordering of Trees} \description{ This function changes the internal structure of a phylogeny stored as an object of class \code{"phylo"}. The tree returned is the same than the one input, but the ordering of the edges could be different. } \usage{ \method{reorder}{phylo}(x, order = "cladewise", index.only = FALSE, ...) \method{reorder}{multiPhylo}(x, order = "cladewise", ...) } \arguments{ \item{x}{an object of class \code{"phylo"} or \code{"multiPhylo"}.} \item{order}{a character string: either \code{"cladewise"} (the default), \code{"postorder"}, \code{"pruningwise"}, or any unambiguous abbreviation of these.} \item{index.only}{should the function return only the ordered indices of the rows of the edge matrix?} \item{\dots}{further arguments passed to or from other methods.} } \details{ Because in a tree coded as an object of class \code{"phylo"} each branch is represented by a row in the element `edge', there is an arbitrary choice for the ordering of these rows. \code{reorder} allows to reorder these rows according to three rules: in the \code{"cladewise"} order each clade is formed by a series of contiguous rows. In the \code{"postorder"} order, the rows are arranged so that computations following pruning-like algorithm the tree (or postorder tree traversal) can be done by descending along these rows (conversely, a preorder tree traversal can be performed by moving from the last to the first row). The \code{"pruningwise"} order is an alternative ``pruning'' order which is actually a bottom-up traversal order (Valiente 2002). (This third choice might be removed in the future as it merely duplicates the second one which is more efficient.) The possible multichotomies and branch lengths are preserved. Note that for a given order, there are several possible orderings of the rows of `edge'. } \value{ an object of class \code{"phylo"} (with the attribute \code{"order"} set accordingly), or a numeric vector if \code{index.only = TRUE}; if \code{x} is of class \code{"multiPhylo"}, then an object of the same class. } \references{ Valiente, G. (2002) \emph{Algorithms on Trees and Graphs.} New York: Springer. } \author{Emmanuel Paradis} \seealso{ \code{\link{read.tree}} to read tree files in Newick format, \code{\link[stats]{reorder}} for the generic function } \examples{ data(bird.families) tr <- reorder(bird.families, "postorder") all.equal(bird.families, tr) # uses all.equal.phylo actually all.equal.list(bird.families, tr) # bypasses the generic } \keyword{manip} ape/man/kronoviz.Rd0000644000175100001440000000166211542362576014000 0ustar hornikusers\name{kronoviz} \alias{kronoviz} \title{Plot Multiple Chronograms on the Same Scale} \description{ The main argument is a list of (rooted) trees which are plotted on the same scale. } \usage{ kronoviz(x, layout = length(x), horiz = TRUE, ...) } \arguments{ \item{x}{a list of (rooted) trees of class \code{"phylo"}.} \item{layout}{an integer giving the number of trees plotted simultaneously; by default all.} \item{horiz}{a logical specifying whether the trees should be plotted rightwards (the default) or upwards.} \item{\dots}{further arguments passed to \code{plot.phylo}.} } \details{ The size of the individual plots is proportional to the size of the trees. } \value{NULL} \author{Emmanuel Paradis} \seealso{ \code{\link{plot.phylo}} } \examples{ TR <- replicate(10, rcoal(sample(11:20, size = 1)), simplify = FALSE) kronoviz(TR) kronoviz(TR, horiz = FALSE, type = "c", show.tip.label = FALSE) } \keyword{hplot} ape/man/read.nexus.Rd0000644000175100001440000000432212033450425014152 0ustar hornikusers\name{read.nexus} \alias{read.nexus} \title{Read Tree File in Nexus Format} \usage{ read.nexus(file, tree.names = NULL) } \arguments{ \item{file}{a file name specified by either a variable of mode character, or a double-quoted string.} \item{tree.names}{if there are several trees to be read, a vector of mode character giving names to the individual trees (by default, this uses the labels in the NEXUS file if these are present).} } \description{ This function reads one or several trees in a NEXUS file. } \details{ The present implementation tries to follow as much as possible the NEXUS standard (but see the restriction below on TRANSLATION tables). Only the block ``TREES'' is read; the other data can be read with other functions (e.g., \code{\link{read.dna}}, \code{\link[utils]{read.table}}, \dots). If a TRANSLATION table is present it is assumed that only the tip labels are translated and they are all translated with integers without gap. Consequently, if nodes have labels in the tree(s) they are read as they are and not looked for in the translation table. The logic behind this is that in the vast majority of cases, node labels will be support values rather than proper taxa names. This is consistent with \code{\link{write.nexus}} which translates only the tip labels. `read.nexus' tries to represent correctly trees with a badly represented root edge (i.e. with an extra pair of parentheses). For instance, the tree "((A:1,B:1):10);" will be read like "(A:1,B:1):10;" but a warning message will be issued in the former case as this is apparently not a valid Newick format. If there are two root edges (e.g., "(((A:1,B:1):10):10);"), then the tree is not read and an error message is issued. } \value{ an object of class \code{"phylo"} or of class \code{"multiPhylo"}. } \references{ Maddison, D. R., Swofford, D. L. and Maddison, W. P. (1997) NEXUS: an extensible file format for systematic information. \emph{Systematic Biology}, \bold{46}, 590--621. } \author{Emmanuel Paradis} \seealso{ \code{\link{read.tree}}, \code{\link{write.nexus}}, \code{\link{write.tree}}, \code{\link{read.nexus.data}}, \code{\link{write.nexus.data}} } \keyword{manip} \keyword{IO} ape/man/def.Rd0000644000175100001440000000420112706672723012646 0ustar hornikusers\name{def} \alias{def} \title{Definition of Vectors for Plotting or Annotating} \description{ This function can be used to define vectors to annotate a set of taxon names, labels, etc. It should facilitate the (re)definition of colours or similar attributes for plotting trees or other graphics. } \usage{ def(x, ..., default = NULL, regexp = FALSE) } \arguments{ \item{x}{a vector of mode character.} \item{\dots}{a series of statements defining the attributes.} \item{default}{the default to be used (see details).} \item{regexp}{a logical value specifying whether the statements defined in \code{\dots} should be taken as regular expressions.} } \details{ The idea of this function is to make the definition of colours, etc., simpler than what is done usually. A typical use is: \code{def(tr$tip.label, Homo_sapiens = "blue")} which will return a vector of character strings all "black" except one matching the tip label "Homo_sapiens" which will be "blue". Another use could be: \code{def(tr$tip.label, Homo_sapiens = 2)} which will return a vector a numerical values all 1 except for "Homo_sapiens" which will be 2. Several definitions can be done, e.g.: \code{def(tr$tip.label, Homo_sapiens = "blue", Pan_paniscus = "red")} The default value is determined with respect to the mode of the values given with the \code{\dots} (either "black" or 1). If \code{regexp = TRUE} is used, then the names of the statements must be quoted, e.g.: \code{def(tr$tip.label, "^Pan_" = "red", regexp = TRUE)} will return "red" for all labels starting with "Pan_". } \value{ a vector of the same length than \code{x}. } \author{Emmanuel Paradis} \examples{ data(bird.orders) a <- def(bird.orders$tip.label, Galliformes = 2) str(a) # numeric plot(bird.orders, font = a) co <- def(bird.orders$tip.label, Passeriformes = "red", Trogoniformes = "blue") str(co) # character plot(bird.orders, tip.color = co) ### use of a regexp (so we need to quote it) to colour all orders ### with names starting with "C" (and change the default): co2 <- def(bird.orders$tip.label, "^C" = "gold", default = "grey", regexp = TRUE) plot(bird.orders, tip.color = co2) } \keyword{manip} ape/man/rtt.Rd0000644000175100001440000000520712350767613012726 0ustar hornikusers\name{rtt} \alias{rtt} \title{Root a Tree by Root-to-Tip Regression} \description{ This function roots a phylogenetic tree with dated tips in the location most compatible with the assumption of a strict molecular clock. } \usage{ rtt(t, tip.dates, ncpu = 1, objective = correlation, opt.tol = .Machine$double.eps^0.25) } \arguments{ \item{t}{an object of class \code{"phylo"}.} \item{tip.dates}{a vector of sampling times associated to the tips of \code{t}, in the same order as \code{t$tip.label}.} \item{ncpu}{number of cores to use.} \item{objective}{one of \code{"correlation"}, \code{"rms"}, or \code{"rsquared"}.} \item{opt.tol}{tolerance for optimization precision.} } \details{ This function duplicates one part the functionality of the program Path-O-Gen (see references). The root position is chosen to produce the best linear regression of root-to-tip distances against sampling times. \code{t} must have branch lengths in units of expected substitutions per site. \code{tip.dates} should be a vector of sampling times, in any time unit, with time increasing toward the present. For example, this may be in units of ``days since study start'' or ``years since 10,000 BCE'', but not ``millions of yearsago''. Setting \code{ncpu} to a value larger than 1 requires the \code{parallel} library. \code{objective} is the measure which will be used to define the ``goodness'' of a regression fit. It may be one of \code{"correlation"} (strongest correlation between tip date and distance from root), \code{"rms"} (lowest root-mean-squared error), or \code{"rsquared"} (highest R-squared value). \code{opt.tol} is used to optimize the location of the root along the best branch. By default, R's \code{optimize} function uses a precision of \code{.Machine$double.eps^0.25}, which is about 0.0001 on a 64-bit system. This should be set to a smaller value if the branch lengths of \code{t} are very short. } \value{ an object of class \code{"phylo"}. } \note{ This function only chooses the best root. It does not rescale the branch lengths to time, or perform a statistical test of the molecular clock hypothesis. } \author{ Rosemary McCloskey\email{rmccloskey@cfenet.ubc.ca}, Emmanuel Paradis } \references{ Rambaut, A. (2009). Path-O-Gen: temporal signal investigation tool. \url{http://tree.bio.ed.ac.uk/software/pathogen/} Rambaut, A. (2000). Estimating the rate of molecular evolution: incorporating non-contemporaneous sequences into maximum likelihood phylogenies. \emph{Bioinformatics}, \bold{16}, 395-399. } \examples{ t <- rtree(100) tip.date <- rnorm(t$tip.label)^2 rtt(t, tip.date) } ape/man/phymltest.Rd0000644000175100001440000001410712202364000014120 0ustar hornikusers\name{phymltest} \alias{phymltest} \alias{print.phymltest} \alias{summary.phymltest} \alias{plot.phymltest} \title{Fits a Bunch of Models with PhyML} \usage{ phymltest(seqfile, format = "interleaved", itree = NULL, exclude = NULL, execname = NULL, append = TRUE) \method{print}{phymltest}(x, ...) \method{summary}{phymltest}(object, ...) \method{plot}{phymltest}(x, main = NULL, col = "blue", ...) } \arguments{ \item{seqfile}{a character string giving the name of the file that contains the DNA sequences to be analysed by PhyML.} \item{format}{a character string specifying the format of the DNA sequences: either \code{"interleaved"} (the default), or \code{"sequential"}.} \item{itree}{a character string giving the name of a file with a tree in Newick format to be used as an initial tree by PhyML. If \code{NULL} (the default), PhyML uses a ``BIONJ'' tree.} \item{exclude}{a vector of mode character giving the models to be excluded from the analysis. These must be among those below, and follow the same syntax.} \item{execname}{a character string specifying the name of the PhyML executable. This argument can be left as \code{NULL} if PhyML's default names are used: \code{"phyml_3.0_linux32"}, \code{"phyml_3.0_macintel"}, or \code{"phyml_3.0_win32.exe"}, under Linux, MacOS, or Windows respectively.} \item{append}{a logical indicating whether to erase previous PhyML output files if present; the default is to not erase.} \item{x}{an object of class \code{"phymltest"}.} \item{object}{an object of class \code{"phymltest"}.} \item{main}{a title for the plot; if left \code{NULL}, a title is made with the name of the object (use \code{main = ""} to have no title).} \item{col}{a colour used for the segments showing the AIC values (blue by default).} \item{\dots}{further arguments passed to or from other methods.} } \description{ This function calls PhyML and fits successively 28 models of DNA evolution. The results are saved on disk, as PhyML usually does, and returned in \R as a vector with the log-likelihood value of each model. } \details{ The present function requires version 3.0.1 of PhyML; it won't work with older versions. The user must take care to set correctly the three different paths involved here: the path to PhyML's binary, the path to the sequence file, and the path to R's working directory. The function should work if all three paths are different. Obviously, there should be no problem if they are all the same. The following syntax is used for the models: "X[Y][Z]00[+I][+G]" where "X" is the first letter of the author of the model, "Y" and "Z" are possibly other co-authors of the model, "00" is the year of the publication of the model, and "+I" and "+G" indicates whether the presence of invariant sites and/or a gamma distribution of substitution rates have been specified. Thus, Kimura's model is denoted "K80" and not "K2P". The exception to this rule is the general time-reversible model which is simple denoted "GTR" model. The seven substitution models used are: "JC69", "K80", "F81", "F84", "HKY85", "TN93", and "GTR". These models are then altered by adding the "+I" and/or "+G", resulting thus in four variants for each of them (e.g., "JC69", "JC69+I", "JC69+G", "JC69+I+G"). Some of these models are described in the help page of \code{\link{dist.dna}}. When a gamma distribution of substitution rates is specified, four categories are used (which is PhyML's default behaviour), and the ``alpha'' parameter is estimated from the data. For the models with a different substition rate for transitions and transversions, these rates are left free and estimated from the data (and not constrained with a ratio of 4 as in PhyML's default). The option \code{path2exec} has been removed in the present version: the path to PhyML's executable can be specified with the option \code{execname}. } \note{ It is important to note that the models fitted by this function is only a small fraction of the models possible with PhyML. For instance, it is possible to vary the number of categories in the (discretized) gamma distribution of substitution rates, and many parameters can be fixed by the user. The results from the present function should rather be taken as indicative of a best model. } \value{ \code{phymltest} returns an object of class \code{"phymltest"}: a numeric vector with the models as names. The \code{print} method prints an object of class \code{"phymltest"} as matrix with the name of the models, the number of free parameters, the log-likelihood value, and the value of the Akaike information criterion (AIC = -2 * loglik + 2 * number of free parameters) The \code{summary} method prints all the possible likelihood ratio tests for an object of class \code{"phymltest"}. The \code{plot} method plots the values of AIC of an object of class \code{"phymltest"} on a vertical scale. } \references{ Posada, D. and Crandall, K. A. (2001) Selecting the best-fit model of nucleotide substitution. \emph{Systematic Biology}, \bold{50}, 580--601. Guindon, S. and Gascuel, O. (2003) A simple, fast, and accurate algorithm to estimate large phylogenies by maximum likelihood. \emph{Systematic Biology}, \bold{52}, 696--704. \url{http://www.atgc-montpellier.fr/phyml/} } \author{Emmanuel Paradis} \seealso{ \code{\link{read.tree}}, \code{\link{write.tree}}, \code{\link{dist.dna}} } \examples{ ### A `fake' example with random likelihood values: it does not ### make sense, but does not need PhyML and gives you a flavour ### of what the output looks like: x <- runif(28, -100, -50) names(x) <- ape:::.phymltest.model class(x) <- "phymltest" x summary(x) plot(x) plot(x, main = "", col = "red") ### This example needs PhyML, copy/paste or type the ### following commands if you want to try them, eventually ### changing setwd() and the options of phymltest() \dontrun{ setwd("D:/phyml_v2.4/exe") # under Windows data(woodmouse) write.dna(woodmouse, "woodmouse.txt") X <- phymltest("woodmouse.txt") X summary(X) plot(X) } } \keyword{models} ape/man/yule.cov.Rd0000644000175100001440000000773512125467226013666 0ustar hornikusers\name{yule.cov} \alias{yule.cov} \title{Fits the Yule Model With Covariates} \usage{ yule.cov(phy, formula, data = NULL) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{formula}{a formula specifying the model to be fitted.} \item{data}{the name of the data frame where the variables in \code{formula} are to be found; by default, the variables are looked for in the global environment.} } \description{ This function fits by maximum likelihood the Yule model with covariates, that is a birth-only model where speciation rate is determined by a generalized linear model. } \details{ The model fitted is a generalization of the Yule model where the speciation rate is determined by: \deqn{\ln\frac{\lambda_i}{1 - \lambda_i} = \beta_1 x_{i1} + \beta_2 x_{i2} + \dots + \alpha }{ln(li / (1 - li)) = b1 xi1 + b2 xi2 + ... a} where \eqn{\lambda_i}{li} is the speciation rate for species i, \eqn{x_{i1}, x_{i2}, \dots}{xi1, xi2, ...} are species-specific variables, and \eqn{\beta_1, \beta_2, \dots, \alpha}{b1, b2, ..., a} are parameters to be estimated. The term on the left-hand side above is a logit function often used in generalized linear models for binomial data (see \code{\link[stats]{family}}). The above model can be written in matrix form: \deqn{\mathrm{logit} \lambda_i = x_i' \beta}{logit li = xi' b} The standard-errors of the parameters are computed with the second derivatives of the log-likelihood function. (See References for other details on the estimation procedure.) The function needs three things: \itemize{ \item a phylogenetic tree which may contain multichotomies; \item a formula which specifies the predictors of the model described above: this is given as a standard \R formula and has no response (no left-hand side term), for instance: \code{~ x + y}, it can include interactions (\code{~ x + a * b}) (see \code{\link[stats]{formula}} for details); \item the predictors specified in the formula must be accessible to the function (either in the global space, or though the \code{data} option); they can be numeric vectors or factors. The length and the order of these data are important: the number of values (length) must be equal to the number of tips of the tree + the number of nodes. The order is the following: first the values for the tips in the same order than for the labels, then the values for the nodes sequentially from the root to the most terminal nodes (i.e., in the order given by \code{phy$edge}). } The user must obtain the values for the nodes separately. Note that the method in its present implementation assumes that the change in a species trait is more or less continuous between two nodes or between a node and a tip. Thus reconstructing the ancestral values with a Brownian motion model may be consistent with the present method. This can be done with the function \code{\link{ace}}. } \value{ A NULL value is returned, the results are simply printed. The output includes the deviance of the null (intercept-only) model and a likelihood-ratio test of the fitted model against the null model. Note that the deviance of the null model is different from the one returned by \code{\link{yule}} because of the different parametrizations. } \references{ Paradis, E. (2005) Statistical analysis of diversification with species traits. \emph{Evolution}, \bold{59}, 1--12. } \author{Emmanuel Paradis} \seealso{ \code{\link{branching.times}}, \code{\link{diversi.gof}}, \code{\link{diversi.time}}, \code{\link{ltt.plot}}, \code{\link{birthdeath}}, \code{\link{bd.ext}}, \code{\link{yule}} } \examples{ ### a simple example with some random data data(bird.orders) x <- rnorm(45) # the tree has 23 tips and 22 nodes ### the standard-error for x should be as large as ### the estimated parameter yule.cov(bird.orders, ~ x) ### another example with a tree that has a multichotomy data(bird.families) y <- rnorm(272) # 137 tips + 135 nodes yule.cov(bird.families, ~ y) } \keyword{models} ape/man/speciesTree.Rd0000644000175100001440000000402512273212360014351 0ustar hornikusers\name{speciesTree} \alias{speciesTree} \title{Species Tree Estimation} \description{ This function calculates the species tree from a set of gene trees. } \usage{ speciesTree(x, FUN = min) } \arguments{ \item{x}{a list of trees, e.g., an object of class \code{"multiPhylo"}.} \item{FUN}{a function used to compute the divergence times of each pair of tips.} } \details{ For all trees in \code{x}, the divergence time of each pair of tips is calculated: these are then `summarized' with \code{FUN} to build a new distance matrix used to calculate the species tree with a single-linkage hierarchical clustering. The default for \code{FUN} computes the maximum tree (maxtree) of Liu et al. (2010). Using \code{FUN = mean} gives the shallowest divergence tree of Maddison and Knowles (2006). } \value{ an object of class \code{"phylo"}. } \references{ Liu, L., Yu, L. and Pearl, D. K. (2010) Maximum tree: a consistent estimator of the species tree. \emph{Journal of Mathematical Biology}, \bold{60}, 95--106. Maddison, W. P. and Knowles, L. L. (2006) Inferring phylogeny despite incomplete lineage sorting. \emph{Systematic Biology}, \bold{55}, 21--30. } \author{Emmanuel Paradis} \examples{ ### example in Liu et al. (2010): tr1 <- read.tree(text = "(((B:0.05,C:0.05):0.01,D:0.06):0.04,A:0.1);") tr2 <- read.tree(text = "(((A:0.07,C:0.07):0.02,D:0.09):0.03,B:0.12);") TR <- c(tr1, tr2) TSmax <- speciesTree(TR) # MAXTREE TSsha <- speciesTree(TR, mean) # shallowest divergence layout(matrix(1:4, 1)) ## playing with 'x.lim' is not so complicated ## but this will be improved someday plot(tr1, "c", d = "u", y.lim = c(-0.07, 0.1), font = 1) axisPhylo(4); title("Gene tree 1") plot(tr2, "c", d = "u", y.lim = c(-0.05, 0.12), font = 1) axisPhylo(4); title("Gene tree 2") plot(TSmax, "c", d = "u", y.lim = c(-0.1, 0.07), font = 1) axisPhylo(4); title("Species tree inferred\nby MAXTREE") plot(TSsha, "c", d = "u", y.lim = c(0, 0.17), font = 1) axisPhylo(4); title("Species tree inferred\nby Shallowest Divergence") } \keyword{models} ape/man/boot.phylo.Rd0000644000175100001440000001746312757050715014220 0ustar hornikusers\name{boot.phylo} \alias{boot.phylo} \alias{prop.part} \alias{prop.clades} \alias{print.prop.part} \alias{summary.prop.part} \alias{plot.prop.part} \title{Tree Bipartition and Bootstrapping Phylogenies} \description{ These functions analyse bipartitions found in a series of trees. \code{prop.part} counts the number of bipartitions found in a series of trees given as \code{\dots}. If a single tree is passed, the returned object is a list of vectors with the tips descending from each node (i.e., clade compositions indexed by node number). \code{prop.clades} counts the number of times the bipartitions present in \code{phy} are present in a series of trees given as \code{\dots} or in the list previously computed and given with \code{part}. \code{boot.phylo} performs a bootstrap analysis. } \usage{ boot.phylo(phy, x, FUN, B = 100, block = 1, trees = FALSE, quiet = FALSE, rooted = is.rooted(phy), jumble = TRUE, mc.cores = 1) prop.part(..., check.labels = TRUE) prop.clades(phy, ..., part = NULL, rooted = FALSE) \method{print}{prop.part}(x, ...) \method{summary}{prop.part}(object, ...) \method{plot}{prop.part}(x, barcol = "blue", leftmar = 4, col = "red", ...) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{x}{in the case of \code{boot.phylo}: a taxa (rows) by characters (columns) matrix; in the case of \code{print} and \code{plot}: an object of class \code{"prop.part"}.} \item{FUN}{the function used to estimate \code{phy} (see details).} \item{B}{the number of bootstrap replicates.} \item{block}{the number of columns in \code{x} that will be resampled together (see details).} \item{trees}{a logical specifying whether to return the bootstraped trees (\code{FALSE} by default).} \item{quiet}{a logical: a progress bar is displayed by default.} \item{rooted}{a logical specifying whether the trees should be treated as rooted or not.} \item{jumble}{a logical value. By default, the rows of \code{x} are randomized to avoid artificially too large bootstrap values associated with very short branches.} \item{mc.cores}{the number of cores (CPUs) to be used (passed to \pkg{parallel}).} \item{\dots}{either (i) a single object of class \code{"phylo"}, (ii) a series of such objects separated by commas, or (iii) a list containing such objects. In the case of \code{plot} further arguments for the plot (see details).} \item{check.labels}{a logical specifying whether to check the labels of each tree. If \code{FALSE}, it is assumed that all trees have the same tip labels, and that they are in the same order (see details).} \item{part}{a list of partitions as returned by \code{prop.part}; if this is used then \code{\dots} is ignored.} \item{object}{an object of class \code{"prop.part"}.} \item{barcol}{the colour used for the bars displaying the number of partitions in the upper panel.} \item{leftmar}{the size of the margin on the left to display the tip labels.} \item{col}{the colour used to visualise the bipartitions.} } \details{ The argument \code{FUN} in \code{boot.phylo} must be the function used to estimate the tree from the original data matrix. Thus, if the tree was estimated with neighbor-joining (see \code{nj}), one maybe wants something like \code{FUN = function(xx) nj(dist.dna(xx))}. \code{block} in \code{boot.phylo} specifies the number of columns to be resampled altogether. For instance, if one wants to resample at the codon-level, then \code{block = 3} must be used. Using \code{check.labels = FALSE} in \code{prop.part} decreases computing times. This requires that (i) all trees have the same tip labels, \emph{and} (ii) these labels are ordered similarly in all trees (in other words, the element \code{tip.label} are identical in all trees). The plot function represents a contingency table of the different partitions (on the \emph{x}-axis) in the lower panel, and their observed numbers in the upper panel. Any further arguments (\dots) are used to change the aspects of the points in the lower panel: these may be \code{pch}, \code{col}, \code{bg}, \code{cex}, etc. This function works only if there is an attribute \code{labels} in the object. The print method displays the partitions and their numbers. The summary method extracts the numbers only. } \note{ \code{prop.clades} calls internally \code{prop.part} with the option \code{check.labels = TRUE}, which may be very slow. If the trees passed as \code{\dots} fulfills conditions (i) and (ii) above, then it might be faster to first call, e.g., \code{pp <- prop.part(...)}, then use the option \code{part}: \code{prop.clades(phy, part = pp)}. Since \pkg{ape} 3.5, \code{prop.clades} should return sensible results for all values of \code{rooted}: if \code{FALSE}, the numbers of bipartitions (or splits); if \code{TRUE}, the number of clades (of hopefully rooted trees). } \value{ \code{prop.part} returns an object of class \code{"prop.part"} which is a list with an attribute \code{"number"}. The elements of this list are the observed clades, and the attribute their respective numbers. If the default \code{check.labels = FALSE} is used, an attribute \code{"labels"} is added, and the vectors of the returned object contains the indices of these labels instead of the labels themselves. \code{prop.clades} and \code{boot.phylo} return a numeric vector which \emph{i}th element is the number associated to the \emph{i}th node of \code{phy}. If \code{trees = TRUE}, \code{boot.phylo} returns a list whose first element (named \code{"BP"}) is like before, and the second element (\code{"trees"}) is a list with the bootstraped trees. \code{summary} returns a numeric vector. } \references{ Efron, B., Halloran, E. and Holmes, S. (1996) Bootstrap confidence levels for phylogenetic trees. \emph{Proceedings of the National Academy of Sciences USA}, \bold{93}, 13429--13434. Felsenstein, J. (1985) Confidence limits on phylogenies: an approach using the bootstrap. \emph{Evolution}, \bold{39}, 783--791. } \author{Emmanuel Paradis} \seealso{ \code{\link{as.bitsplits}}, \code{\link{dist.topo}}, \code{\link{consensus}}, \code{\link{nodelabels}} } \examples{ data(woodmouse) f <- function(x) nj(dist.dna(x)) tr <- f(woodmouse) ### Are bootstrap values stable? for (i in 1:5) print(boot.phylo(tr, woodmouse, f, quiet = TRUE)) ### How many partitions in 100 random trees of 10 labels?... TR <- rmtree(100, 10) pp10 <- prop.part(TR) length(pp10) ### ... and in 100 random trees of 20 labels? TR <- rmtree(100, 20) pp20 <- prop.part(TR) length(pp20) plot(pp10, pch = "x", col = 2) plot(pp20, pch = "x", col = 2) set.seed(1) tr <- rtree(10) # rooted ## the following used to return a wrong result with ape <= 3.4: prop.clades(tr, tr) prop.clades(tr, tr, rooted = TRUE) tr <- rtree(10, rooted = FALSE) prop.clades(tr, tr) # correct ### an illustration of the use of prop.clades with bootstrap trees: fun <- function(x) as.phylo(hclust(dist.dna(x), "average")) # upgma() in phangorn tree <- fun(woodmouse) ## get 100 bootstrap trees: bstrees <- boot.phylo(tree, woodmouse, fun, trees = TRUE)$trees ## get proportions of each clade: clad <- prop.clades(tree, bstrees, rooted = TRUE) ## get proportions of each bipartition: boot <- prop.clades(tree, bstrees) plot(tree, main = "Bipartitions vs. Clades Support Values") drawSupportOnEdges(boot) nodelabels(clad) legend("bottomleft", legend = c("Bipartitions", "Clades"), pch = 22, pt.bg = c("green", "lightblue"), pt.cex = 2.5) \dontrun{ ## an example of double bootstrap: nrep1 <- 100 nrep2 <- 100 p <- ncol(woodmouse) DB <- 0 for (b in 1:nrep1) { X <- woodmouse[, sample(p, p, TRUE)] DB <- DB + boot.phylo(tr, X, f, nrep2, quiet = TRUE) } DB ## to compare with: boot.phylo(tr, woodmouse, f, 1e4) } } \keyword{manip} \keyword{htest} ape/man/rTraitMult.Rd0000644000175100001440000000407112010712116014177 0ustar hornikusers\name{rTraitMult} \alias{rTraitMult} \title{Multivariate Character Simulation} \description{ This function simulates the evolution of a multivariate set of traits along a phylogeny. The calculation is done recursively from the root. } \usage{ rTraitMult(phy, model, p = 1, root.value = rep(0, p), ancestor = FALSE, asFactor = NULL, trait.labels = paste("x", 1:p, sep = ""), ...) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{model}{a function specifying the model (see details).} \item{p}{an integer giving the number of traits.} \item{root.value}{a numeric vector giving the values at the root.} \item{ancestor}{a logical value specifying whether to return the values at the nodes as well (by default, only the values at the tips are returned).} \item{asFactor}{the indices of the traits that are returned as factors (discrete traits).} \item{trait.labels}{a vector of mode character giving the names of the traits.} \item{\dots}{further arguments passed to \code{model} if it is a function.} } \details{ The model is specified with an \R function of the form \code{foo(x, l)} where \code{x} is a vector of the traits of the ancestor and \code{l} is the branch length. Other arguments may be added. The function must return a vector of length \code{p}. } \value{ A data frame with \code{p} columns whose names are given by \code{trait.labels} and row names taken from the labels of the tree. } \author{Emmanuel Paradis} \seealso{ \code{\link{rTraitCont}}, \code{\link{rTraitDisc}}, \code{\link{ace}} } \examples{ ## correlated evolution of 2 continuous traits: mod <- function(x, l) { y1 <- rnorm(1, x[1] + 0.5*x[2], 0.1) y2 <- rnorm(1, 0.5*x[1] + x[2], 0.1) c(y1, y2) } set.seed(11) tr <- makeNodeLabel(rcoal(20)) x <- rTraitMult(tr, mod, 2, ancestor = TRUE) op <- par(mfcol = c(2, 1)) plot(x, type = "n") text(x, labels = rownames(x), cex = 0.7) oq <- par(mar = c(0, 1, 0, 1), xpd = TRUE) plot(tr, font = 1, cex = 0.7) nodelabels(tr$node.label, cex = 0.7, adj = 1) par(c(op, oq)) } \keyword{datagen} ape/man/rotate.Rd0000644000175100001440000000673412211250365013404 0ustar hornikusers\name{rotate} \alias{rotate} \alias{rotateConstr} \title{Swapping Sister Clades} \description{ For a given node, \code{rotate} exchanges the position of two clades descending from this node. It can handle dichotomies as well as polytomies. In the latter case, two clades from the polytomy are selected for swapping. \code{rotateConstr} rotates internal branches giving a constraint on the order of the tips. } \usage{ rotate(phy, node, polytom = c(1, 2)) rotateConstr(phy, constraint) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{node}{a vector of mode numeric or character specifying the number of the node.} \item{polytom}{a vector of mode numeric and length two specifying the two clades that should be exchanged in a polytomy.} \item{constraint}{a vector of mode character specifying the order of the tips as they should appear when plotting the tree (from bottom to top).} } \details{ \code{phy} can be either rooted or unrooted, contain polytomies and lack branch lengths. In the presence of very short branch lengths it is convenient to plot the phylogenetic tree without branch lengths in order to identify the number of the node in question. \code{node} can be any of the interior nodes of a phylogenetic tree including the root node. Number of the nodes can be identified by the nodelabels function. Alternatively, you can specify a vector of length two that contains either the number or the names of two tips that coalesce in the node of interest. If the node subtends a polytomy, any two clades of the the polytomy can be chosen by polytom. On a plotted phylogeny, the clades are numbered from bottom to top and polytom is used to index the two clades one likes to swop. } \value{ an object of class \code{"phylo"}. } \author{Christoph Heibl \email{heibl@lmu.de}, Emmanuel Paradis} \seealso{ \code{\link{plot.phylo}}, \code{\link{nodelabels}}, \code{\link{root}}, \code{\link{drop.tip}}} \examples{ # create a random tree: tre <- rtree(25) # visualize labels of internal nodes: plot(tre, use.edge.length=FALSE) nodelabels() # rotate clades around node 30: tre.new <- rotate(tre, 30) # compare the results: par(mfrow=c(1,2)) # split graphical device plot(tre) # plot old tre plot(tre.new) # plot new tree # visualize labels of terminal nodes: plot(tre) tiplabels() # rotate clades containing nodes 12 and 20: tre.new <- rotate(tre, c(12, 21)) # compare the results: par(mfrow=c(1,2)) # split graphical device plot(tre) # plot old tre plot(tre.new) # plot new tree # or you migth just specify tiplabel names: tre.new <- rotate(tre, c("t3", "t14")) # compare the results: par(mfrow=c(1,2)) # devide graphical device plot(tre) # plot old tre plot(tre.new) # plot new tree # a simple example for rotateConstr: A <- read.tree(text = "((A,B),(C,D));") B <- read.tree(text = "(((D,C),B),A);") B <- rotateConstr(B, A$tip.label) plot(A); plot(B, d = "l") # something more interesting (from ?cophyloplot): tr1 <- rtree(40) ## drop 20 randomly chosen tips: tr2 <- drop.tip(tr1, sample(tr1$tip.label, size = 20)) ## rotate the root and reorder the whole: tr2 <- rotate(tr2, 21) tr2 <- read.tree(text = write.tree(tr2)) X <- cbind(tr2$tip.label, tr2$tip.label) # association matrix cophyloplot(tr1, tr2, assoc = X, space = 28) ## before reordering tr2 we have to find the constraint: co <- tr2$tip.label[order(match(tr2$tip.label, tr1$tip.label))] newtr2 <- rotateConstr(tr2, co) cophyloplot(tr1, newtr2, assoc = X, space = 28) } \keyword{manip} ape/man/skyline.Rd0000644000175100001440000001231412473401153013556 0ustar hornikusers\name{skyline} \alias{skyline} \alias{skyline.phylo} \alias{skyline.coalescentIntervals} \alias{skyline.collapsedIntervals} \alias{find.skyline.epsilon} \title{Skyline Plot Estimate of Effective Population Size} \usage{ skyline(x, \dots) \method{skyline}{phylo}(x, \dots) \method{skyline}{coalescentIntervals}(x, epsilon=0, \dots) \method{skyline}{collapsedIntervals}(x, old.style=FALSE, \dots) find.skyline.epsilon(ci, GRID=1000, MINEPS=1e-6, \dots) } \arguments{ \item{x}{Either an ultrametric tree (i.e. an object of class \code{"phylo"}), or coalescent intervals (i.e. an object of class \code{"coalescentIntervals"}), or collapsed coalescent intervals (i.e. an object of class \code{"collapsedIntervals"}).} \item{epsilon}{collapsing parameter that controls the amount of smoothing (allowed range: from \code{0} to \code{ci$total.depth}, default value: 0). This is the same parameter as in \link{collapsed.intervals}.} \item{old.style}{Parameter to choose between two slightly different variants of the generalized skyline plot (Strimmer and Pybus, pers. comm.). The default value \code{FALSE} is recommended.} \item{ci}{coalescent intervals (i.e. an object of class \code{"coalescentIntervals"})} \item{GRID}{Parameter for the grid search for \code{epsilon} in \code{find.skyline.epsilon}.} \item{MINEPS}{Parameter for the grid search for \code{epsilon} in \code{find.skyline.epsilon}.} \item{\dots}{Any of the above parameters.} } \description{ \code{skyline} computes the \emph{generalized skyline plot} estimate of effective population size from an estimated phylogeny. The demographic history is approximated by a step-function. The number of parameters of the skyline plot (i.e. its smoothness) is controlled by a parameter \code{epsilon}. \code{find.skyline.epsilon} searches for an optimal value of the \code{epsilon} parameter, i.e. the value that maximizes the AICc-corrected log-likelihood (\code{logL.AICc}). } \details{ \code{skyline} implements the \emph{generalized skyline plot} introduced in Strimmer and Pybus (2001). For \code{epsilon = 0} the generalized skyline plot degenerates to the \emph{classic skyline plot} described in Pybus et al. (2000). The latter is in turn directly related to lineage-through-time plots (Nee et al., 1995). } \value{ \code{skyline} returns an object of class \code{"skyline"} with the following entries: \item{time}{ A vector with the time at the end of each coalescent interval (i.e. the accumulated interval lengths from the beginning of the first interval to the end of an interval)} \item{interval.length}{ A vector with the length of each interval.} \item{population.size}{A vector with the effective population size of each interval.} \item{parameter.count}{ Number of free parameters in the skyline plot.} \item{epsilon}{The value of the underlying smoothing parameter.} \item{logL}{Log-likelihood of skyline plot (see Strimmer and Pybus, 2001).} \item{logL.AICc}{AICc corrected log-likelihood (see Strimmer and Pybus, 2001).} \code{find.skyline.epsilon} returns the value of the \code{epsilon} parameter that maximizes \code{logL.AICc}. } \author{Korbinian Strimmer} \seealso{ \code{\link{coalescent.intervals}}, \code{\link{collapsed.intervals}}, \code{\link{skylineplot}}, \code{\link{ltt.plot}}. } \references{ Strimmer, K. and Pybus, O. G. (2001) Exploring the demographic history of DNA sequences using the generalized skyline plot. \emph{Molecular Biology and Evolution}, \bold{18}, 2298--2305. Pybus, O. G, Rambaut, A. and Harvey, P. H. (2000) An integrated framework for the inference of viral population history from reconstructed genealogies. \emph{Genetics}, \bold{155}, 1429--1437. Nee, S., Holmes, E. C., Rambaut, A. and Harvey, P. H. (1995) Inferring population history from molecular phylogenies. \emph{Philosophical Transactions of the Royal Society of London. Series B. Biological Sciences}, \bold{349}, 25--31. } \examples{ # get tree data("hivtree.newick") # example tree in NH format tree.hiv <- read.tree(text = hivtree.newick) # load tree # corresponding coalescent intervals ci <- coalescent.intervals(tree.hiv) # from tree # collapsed intervals cl1 <- collapsed.intervals(ci,0) cl2 <- collapsed.intervals(ci,0.0119) #### classic skyline plot #### sk1 <- skyline(cl1) # from collapsed intervals sk1 <- skyline(ci) # from coalescent intervals sk1 <- skyline(tree.hiv) # from tree sk1 plot(skyline(tree.hiv)) skylineplot(tree.hiv) # shortcut plot(sk1, show.years=TRUE, subst.rate=0.0023, present.year = 1997) #### generalized skyline plot #### sk2 <- skyline(cl2) # from collapsed intervals sk2 <- skyline(ci, 0.0119) # from coalescent intervals sk2 <- skyline(tree.hiv, 0.0119) # from tree sk2 plot(sk2) # classic and generalized skyline plot together in one plot plot(sk1, show.years=TRUE, subst.rate=0.0023, present.year = 1997, col=c(grey(.8),1)) lines(sk2, show.years=TRUE, subst.rate=0.0023, present.year = 1997) legend(.15,500, c("classic", "generalized"), col=c(grey(.8),1),lty=1) # find optimal epsilon parameter using AICc criterion find.skyline.epsilon(ci) sk3 <- skyline(ci, -1) # negative epsilon also triggers estimation of epsilon sk3$epsilon } \keyword{manip} ape/man/skylineplot.Rd0000644000175100001440000000572712473401264014472 0ustar hornikusers\name{skylineplot} \alias{skylineplot} \alias{plot.skyline} \alias{lines.skyline} \alias{skylineplot.deluxe} \title{Drawing Skyline Plot Graphs} \usage{ \method{plot}{skyline}(x, show.years=FALSE, subst.rate, present.year, \dots) \method{lines}{skyline}(x, show.years=FALSE, subst.rate, present.year, \dots) skylineplot(z, \dots) skylineplot.deluxe(tree, \dots) } \arguments{ \item{x}{skyline plot data (i.e. an object of class \code{"skyline"}).} \item{z}{Either an ultrametric tree (i.e. an object of class \code{"phylo"}), or coalescent intervals (i.e. an object of class \code{"coalescentIntervals"}), or collapsed coalescent intervals (i.e. an object of class \code{"collapsedIntervals"}).} \item{tree}{ultrametric tree (i.e. an object of class \code{"phylo"}).} \item{show.years}{option that determines whether the time is plotted in units of of substitutions (default) or in years (requires specification of substution rate and year of present).} \item{subst.rate}{substitution rate (see option show.years).} \item{present.year}{present year (see option show.years).} \item{\dots}{further arguments to be passed on to \code{skyline()} and \code{plot()}.} } \description{ These functions provide various ways to draw \emph{skyline plot} graphs on the current graphical device. Note that \code{skylineplot(z, \dots)} is simply a shortcut for \code{plot(skyline(z, \dots))}. The skyline plot itself is an estimate of effective population size through time, and is computed using the function \code{\link{skyline}}. } \details{ See \code{\link{skyline}} for more details (incl. references) about the skyline plot method. } \author{Korbinian Strimmer} \seealso{ \code{\link[graphics]{plot}} and \code{\link[graphics]{lines}} for the basic plotting function in R, \code{\link{coalescent.intervals}}, \code{\link{skyline}} } \examples{ # get tree data("hivtree.newick") # example tree in NH format tree.hiv <- read.tree(text = hivtree.newick) # load tree #### classic skyline plot skylineplot(tree.hiv) # shortcut #### plot classic and generalized skyline plots and estimate epsilon sk.opt <- skylineplot.deluxe(tree.hiv) sk.opt$epsilon #### classic and generalized skyline plot #### sk1 <- skyline(tree.hiv) sk2 <- skyline(tree.hiv, 0.0119) # use years rather than substitutions as unit for the time axis plot(sk1, show.years=TRUE, subst.rate=0.0023, present.year = 1997, col=c(grey(.8),1)) lines(sk2, show.years=TRUE, subst.rate=0.0023, present.year = 1997) legend(.15,500, c("classic", "generalized"), col=c(grey(.8),1),lty=1) #### various skyline plots for different epsilons layout(mat= matrix(1:6,2,3,byrow=TRUE)) ci <- coalescent.intervals(tree.hiv) plot(skyline(ci, 0.0));title(main="0.0") plot(skyline(ci, 0.007));title(main="0.007") plot(skyline(ci, 0.0119),col=4);title(main="0.0119") plot(skyline(ci, 0.02));title(main="0.02") plot(skyline(ci, 0.05));title(main="0.05") plot(skyline(ci, 0.1));title(main="0.1") layout(mat= matrix(1:1,1,1,byrow=TRUE)) } \keyword{hplot} ape/man/is.monophyletic.Rd0000644000175100001440000000360611273753536015244 0ustar hornikusers\name{is.monophyletic} \alias{is.monophyletic} \title{ Is Group Monophyletic } \usage{ is.monophyletic(phy, tips, reroot = !is.rooted(phy), plot = FALSE, ...) } \description{ This function tests whether a list of tip labels is monophyletic on a given tree. } \arguments{ \item{phy}{ a phylogenetic tree description of class \code{"phylo"}. } \item{tips}{ a vector of mode numeric or character specifying the tips to be tested. } \item{reroot}{ a logical. If \code{FALSE}, then the input tree is not unrooted before the test. } \item{plot}{ a logical. If \code{TRUE}, then the tree is plotted with the specified group \code{tips} highlighted. } \item{\dots}{ further arguments passed to \code{plot}. } } \details{ If \code{phy} is rooted, the test is done on the rooted tree, otherwise the tree is first unrooted, then arbitrarily rerooted, in order to be independent on the current position of the root. That is, the test asks if \code{tips} could be monophyletic given any favourably rooting of \code{phy}. If \code{phy} is unrooted the test is done on an unrooted tree, unless \code{reroot = FALSE} is specified. If tip labels in the list \code{tips} are given as characters, they need to be spelled as in the object \code{phy}. } \value{ \code{TRUE} or \code{FALSE}. } \author{ Johan Nylander \email{jnylander@users.sourceforge.net} } \seealso{ \code{\link{which.edge}}, \code{\link{drop.tip}}, \code{\link{mrca}}. } \examples{ ## Test one monophyletic and one paraphyletic group on the bird.orders tree \dontrun{data("bird.orders")} \dontrun{is.monophyletic(phy = bird.orders, tips = c("Ciconiiformes", "Gruiformes"))} \dontrun{is.monophyletic(bird.orders, c("Passeriformes", "Ciconiiformes", "Gruiformes"))} \dontshow{\dontrun{rm(bird.orders)}} } \keyword{utilities} ape/man/all.equal.phylo.Rd0000644000175100001440000000506712661362710015123 0ustar hornikusers\encoding{utf8} \name{all.equal.phylo} \alias{all.equal.phylo} \title{Global Comparison of two Phylogenies} \usage{ \method{all.equal}{phylo}(target, current, use.edge.length = TRUE, use.tip.label = TRUE, index.return = FALSE, tolerance = .Machine$double.eps ^ 0.5, scale = NULL, \dots) } \arguments{ \item{target}{an object of class \code{"phylo"}.} \item{current}{an object of class \code{"phylo"}.} \item{use.edge.length}{if \code{FALSE} only the topologies are compared; the default is \code{TRUE}.} \item{use.tip.label}{if \code{FALSE} the unlabelled trees are compared; the default is \code{TRUE}.} \item{index.return}{if \code{TRUE} the function returns a two-column matrix giving the correspondence between the nodes of both trees.} \item{tolerance}{the numeric tolerance used to compare the branch lengths.} \item{scale}{a positive number, comparison of branch lengths is made after scaling (i.e., dividing) them by this number.} \item{\dots}{further arguments passed to or from other methods.} } \description{ This function makes a global comparison of two phylogenetic trees. } \details{ This function is meant to be an adaptation of the generic function \code{all.equal} for the comparison of phylogenetic trees. A single phylogenetic tree may have several representations in the Newick format and in the \code{"phylo"} class of objects used in `ape'. One aim of the present function is to be able to identify whether two objects of class \code{"phylo"} represent the same phylogeny. } \note{ The algorithm used here does not work correctly for the comparison of topologies (i.e., ignoring tip labels) of unrooted trees. This also affects \code{\link{unique.multiPhylo}} which calls the present function. See: \url{http://www.mail-archive.com/r-sig-phylo@r-project.org/msg01445.html}. } \value{ A logical value, or a two-column matrix. } \author{\enc{Benoît}{Benoit} Durand \email{b.durand@alfort.AFSSA.FR}} \seealso{ \code{\link[base]{all.equal}} for the generic \R function } \examples{ ### maybe the simplest example of two representations ### for the same rooted tree...: t1 <- read.tree(text = "(a:1,b:1);") t2 <- read.tree(text = "(b:1,a:1);") all.equal(t1, t2) ### ... compare with this: identical(t1, t2) ### one just slightly more complicated...: t3 <- read.tree(text = "((a:1,b:1):1,c:2);") t4 <- read.tree(text = "(c:2,(a:1,b:1):1);") all.equal(t3, t4) # == all.equal.phylo(t3, t4) ### ... here we force the comparison as lists: all.equal.list(t3, t4) } \keyword{manip} ape/man/axisPhylo.Rd0000644000175100001440000000246612375572636014107 0ustar hornikusers\name{axisPhylo} \alias{axisPhylo} \title{Axis on Side of Phylogeny} \usage{ axisPhylo(side = 1, root.time = NULL, backward = TRUE, ...) } \arguments{ \item{side}{a numeric value specifying the side where the axis is plotted: 1: below, 2: left, 3: above, 4: right.} \item{root.time}{the time assigned to the root node of the tree. By default, this is taken from the \code{root.time} element of the tree. If it is absent, this is determined from the next option.} \item{backward}{a logical value; if TRUE, the most distant tip from the root is considered as the origin of the time scale; if FALSE, this is the root node.} \item{\dots}{further arguments to be passed to \code{axis}.} } \description{ This function adds a scaled axis on the side of a phylogeny plot. } \details{ The further arguments (\code{...}) are used to format the axis. They may be \code{font}, \code{cex}, \code{col}, \code{las}, and so on (see the help pages on \code{\link[graphics]{axis}} and \code{\link[graphics]{par}}). } \author{Emmanuel Paradis} \seealso{ \code{\link{plot.phylo}}, \code{\link{add.scale.bar}}, \code{\link[graphics]{axis}}, \code{\link[graphics]{par}} } \examples{ tr <- rtree(30) ch <- rcoal(30) plot(ch) axisPhylo() plot(tr, "c", FALSE, direction = "u") axisPhylo(2, las = 1) } \keyword{aplot} ape/man/corPagel.Rd0000644000175100001440000000407011143325553013636 0ustar hornikusers\name{corPagel} \alias{corPagel} \alias{coef.corPagel} \alias{corMatrix.corPagel} \title{Pagel's ``lambda'' Correlation Structure} \usage{ corPagel(value, phy, form = ~1, fixed = FALSE) \method{corMatrix}{corPagel}(object, covariate = getCovariate(object), corr = TRUE, ...) \method{coef}{corPagel}(object, unconstrained = TRUE, \dots) } \arguments{ \item{value}{the (initial) value of the parameter \eqn{\lambda}{lambda}.} \item{phy}{an object of class \code{"phylo"}.} \item{form}{(ignored).} \item{fixed}{a logical specifying whether \code{gls} should estimate \eqn{\lambda}{lambda} (the default) or keep it fixed.} \item{object}{an (initialized) object of class \code{"corPagel"}.} \item{covariate}{(ignored).} \item{corr}{a logical value specifying whether to return the correlation matrix (the default) or the variance-covariance matrix.} \item{unconstrained}{a logical value. If \code{TRUE} (the default), the coefficients are returned in unconstrained form (the same used in the optimization algorithm). If \code{FALSE} the coefficients are returned in ``natural'', possibly constrained, form.} \item{\dots}{further arguments passed to or from other methods.} } \description{ The correlation structure from the present model is derived from the Brownian motion model by multiplying the off-diagonal elements (i.e., the covariances) by \eqn{\lambda}{lambda}. The variances are thus the same than for a Brownian motion model. } \value{ an object of class \code{"corPagel"}, the coefficients from an object of this class, or the correlation matrix of an initialized object of this class. In most situations, only \code{corPagel} will be called by the user. } \author{Emmanuel Paradis} \references{ Freckleton, R. P., Harvey, P. H. and M. Pagel, M. (2002) Phylogenetic analysis and comparative data: a test and review of evidence. \emph{American Naturalist}, \bold{160}, 712--726. Pagel, M. (1999) Inferring the historical patterns of biological evolution. \emph{Nature}, \bold{401},877--884. } \keyword{models} ape/man/print.phylo.Rd0000644000175100001440000000204212033453153014362 0ustar hornikusers\name{print.phylo} \alias{print.phylo} \alias{print.multiPhylo} \alias{str.multiPhylo} \title{Compact Display of a Phylogeny} \usage{ \method{print}{phylo}(x, printlen = 6 ,...) \method{print}{multiPhylo}(x, details = FALSE ,...) \method{str}{multiPhylo}(object, ...) } \arguments{ \item{x}{an object of class \code{"phylo"} or \code{"multiPhylo"}.} \item{object}{an object of class \code{"multiPhylo"}.} \item{printlen}{the number of labels to print (6 by default).} \item{details}{a logical indicating whether to print information on all trees.} \item{\dots}{further arguments passed to or from other methods.} } \description{ These functions prints a compact summary of a phylogeny, or a list of phylogenies, on the console. } \value{ NULL. } \author{Ben Bolker and Emmanuel Paradis} \seealso{ \code{\link{read.tree}}, \code{\link{summary.phylo}}, \code{\link[base]{print}} for the generic \R function } \examples{ x <- rtree(10) print(x) print(x, printlen = 10) x <- rmtree(2, 10) print(x) print(x, TRUE) str(x) } \keyword{manip} ape/man/plot.varcomp.Rd0000644000175100001440000000121710775732361014537 0ustar hornikusers\name{plot.varcomp} \alias{plot.varcomp} \title{Plot Variance Components} \description{ Plot previously estimated variance components. } \usage{ \method{plot}{varcomp}(x, xlab = "Levels", ylab = "Variance", type = "b", ...) } \arguments{ \item{x}{ A \var{varcomp} object} \item{xlab}{ x axis label} \item{ylab}{ y axis label } \item{type}{ plot type ("l", "p" or "b", see \code{\link{plot}})} \item{\dots}{Further argument sent to the \code{\link[lattice]{xyplot}} function.} } \value{ The same as \code{\link[lattice]{xyplot}}. } \author{Julien Dutheil \email{julien.dutheil@univ-montp2.fr}} \seealso{\code{\link{varcomp}}} \keyword{hplot} ape/man/dist.gene.Rd0000644000175100001440000000365611736277354014010 0ustar hornikusers\name{dist.gene} \alias{dist.gene} \title{Pairwise Distances from Genetic Data} \usage{ dist.gene(x, method = "pairwise", pairwise.deletion = FALSE, variance = FALSE) } \arguments{ \item{x}{a matrix or a data frame (will be coerced as a matrix).} \item{method}{a character string specifying the method used to compute the distances; two choices are available: \code{"pairwise"} and \code{"percentage"}, or any unambiguous abbreviation of these.} \item{pairwise.deletion}{a logical indicating whether to delete the columns with missing data on a pairwise basis. The default is to delete the columns with at least one missing observation.} \item{variance}{a logical, indicates whether the variance of the distances should be returned (default to \code{FALSE}).} } \description{ This function computes a matrix of distances between pairs of individuals from a matrix or a data frame of genetic data. } \details{ This function is meant to be very general and accepts different kinds of data (alleles, haplotypes, SNP, DNA sequences, \dots). The rows of the data matrix represent the individuals, and the columns the loci. In the case of the pairwise method, the distance \eqn{d} between two individuals is the number of loci for which they differ, and the associated variance is \eqn{d(L - d)/L}, where \eqn{L} is the number of loci. In the case of the percentage method, this distance is divided by \eqn{L}, and the associated variance is \eqn{d(1 - d)/L}. For more elaborate distances with DNA sequences, see the function \code{dist.dna}. } \note{ Missing data (\code{NA}) are coded and treated in R's usual way. } \value{ an object of class \code{dist}. If \code{variance = TRUE} an attribute called \code{"variance"} is given to the returned object. } \author{Emmanuel Paradis} \seealso{ \code{\link{dist.dna}}, \code{\link{cophenetic.phylo}}, \code{\link[stats]{dist}} } \keyword{manip} ape/man/write.dna.Rd0000644000175100001440000000730612473400567014010 0ustar hornikusers\name{write.dna} \alias{write.dna} \title{Write DNA Sequences in a File} \usage{ write.dna(x, file, format = "interleaved", append = FALSE, nbcol = 6, colsep = " ", colw = 10, indent = NULL, blocksep = 1) } \arguments{ \item{x}{a list or a matrix of DNA sequences.} \item{file}{a file name specified by either a variable of mode character, or a double-quoted string.} \item{format}{a character string specifying the format of the DNA sequences. Three choices are possible: \code{"interleaved"}, \code{"sequential"}, or \code{"fasta"}, or any unambiguous abbreviation of these.} \item{append}{a logical, if \code{TRUE} the data are appended to the file without erasing the data possibly existing in the file, otherwise the file (if it exists) is overwritten (\code{FALSE} the default).} \item{nbcol}{a numeric specifying the number of columns per row (6 by default); may be negative implying that the nucleotides are printed on a single line.} \item{colsep}{a character used to separate the columns (a single space by default).} \item{colw}{a numeric specifying the number of nucleotides per column (10 by default).} \item{indent}{a numeric or a character specifying how the blocks of nucleotides are indented (see details).} \item{blocksep}{a numeric specifying the number of lines between the blocks of nucleotides (this has an effect only if `format = "interleaved"').} } \description{ This function writes in a file a list of DNA sequences in sequential, interleaved, or FASTA format. } \details{ Three formats are supported in the present function: see the help page of \code{\link{read.dna}} and the references below for a description. If the sequences have no names, then they are given "1", "2", ... as names in the file. With the interleaved and sequential formats, the sequences must be all of the same length. The names of the sequences are not truncated. The argument \code{indent} specifies how the rows of nucleotides are indented. In the interleaved and sequential formats, the rows with the taxon names are never indented; the subsequent rows are indented with 10 spaces by default (i.e., if \code{indent = NULL}). In the FASTA format, the rows are not indented by default. This default behaviour can be modified by specifying a value to \code{indent}: the rows are then indented with ``indent'' (if it is a character) or `indent' spaces (if it is a numeric). For example, specifying \code{indent = " "} or \code{indent = 3} will have the same effect (use \code{indent = "\\t"} for a tabulation). The different options are intended to give flexibility in formatting the sequences. For instance, if the sequences are very long it may be judicious to remove all the spaces beween columns (colsep = ""), in the margins (indent = 0), and between the blocks (blocksep = 0) to produce a smaller file. } \note{ Specifying a negative value for `nbcol' (meaning that the nucleotides are printed on a single line) gives the same output for the interleaved and sequential formats. The names of the sequences may be truncated with the function \code{\link{makeLabel}}. In particular, Clustal is limited to 30 characters, and PHYML seems limited to 99 characters. } \value{ None (invisible `NULL'). } \author{Emmanuel Paradis} \references{ Anonymous. FASTA format. \url{http://en.wikipedia.org/wiki/FASTA_format} Felsenstein, J. (1993) Phylip (Phylogeny Inference Package) version 3.5c. Department of Genetics, University of Washington. \url{http://evolution.genetics.washington.edu/phylip/phylip.html} } \seealso{ \code{\link{read.dna}}, \code{\link{read.GenBank}}, \code{\link{makeLabel}} } \keyword{IO} ape/man/compute.brtime.Rd0000644000175100001440000000326411607721240015041 0ustar hornikusers\name{compute.brtime} \alias{compute.brtime} \title{Compute and Set Branching Times} \description{ This function computes the branch lengths of a tree giving its branching times (aka node ages or heights). } \usage{ compute.brtime(phy, method = "coalescent", force.positive = NULL) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{method}{either \code{"coalescent"} (the default), or a numeric vector giving the branching times.} \item{force.positive}{a logical value (see details).} } \details{ By default, a set of random branching times is generated from a simple coalescent, and the option \code{force.positive} is set to \code{TRUE} so that no branch length is negative. If a numeric vector is passed to \code{method}, it is taken as the branching times of the nodes with respect to their numbers (i.e., the first element of \code{method} is the branching time of the node numbered \eqn{n + 1} [= the root], the second element of the node numbered \eqn{n + 2}, and so on), so \code{force.positive} is set to \code{FALSE}. This may result in negative branch lengths. To avoid this, one should use \code{force.positive = TRUE} in which case the branching times are eventually reordered. } \value{ An object of class \code{"phylo"} with branch lengths and ultrametric. } \author{Emmanuel Paradis} \seealso{ \code{\link{compute.brlen}}, \code{\link{branching.times}} } \examples{ tr <- rtree(10) layout(matrix(1:4, 2)) plot(compute.brtime(tr)); axisPhylo() plot(compute.brtime(tr, force.positive = FALSE)); axisPhylo() plot(compute.brtime(tr, 1:9)); axisPhylo() # a bit nonsense plot(compute.brtime(tr, 1:9, TRUE)); axisPhylo() layout(1) } \keyword{manip} ape/man/is.binary.tree.Rd0000644000175100001440000000227313002724066014737 0ustar hornikusers\name{is.binary} \alias{is.binary} \alias{is.binary.phylo} \alias{is.binary.multiPhylo} \alias{is.binary.tree} \title{Test for Binary Tree} \description{ This function tests whether a phylogenetic tree is binary. } \usage{ is.binary(phy) \method{is.binary}{phylo}(phy) \method{is.binary}{multiPhylo}(phy) \method{is.binary}{tree}(phy) } \arguments{ \item{phy}{an object of class \code{"phylo"} or \code{"multiPhylo"}.} } \details{ The test differs whether the tree is rooted or not. An urooted tree is considered binary if all its nodes are of degree three (i.e., three edges connect to each node). A rooted tree is considered binary if all nodes (including the root node) have exactly two descendant nodes, so that they are of degree three expect the root which is of degree 2. \code{is.binary.tree} is deprecated and will be removed soon: currently it calls \code{is.binary}. } \value{ a logical vector. } \seealso{ \code{\link{is.rooted}}, \code{\link{is.ultrametric}}, \code{\link{multi2di}} } \author{Emmanuel Paradis} \examples{ is.binary(rtree(10)) is.binary(rtree(10, rooted = FALSE)) is.binary(stree(10)) x <- setNames(rmtree(10, 10), LETTERS[1:10]) is.binary(x) } \keyword{logic} ape/man/branching.times.Rd0000644000175100001440000000155311353106160015152 0ustar hornikusers\name{branching.times} \alias{branching.times} \title{Branching Times of a Phylogenetic Tree} \usage{ branching.times(phy) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} } \description{ This function computes the branching times of a phylogenetic tree, that is the distance from each node to the tips, under the assumption that the tree is ultrametric. Note that the function does not check that the tree is effectively ultrametric, so if it is not, the returned result may not be meaningful. } \value{ a numeric vector with the branching times. If the phylogeny \code{phy} has an element \code{node.label}, this is used as names for the returned vector; otherwise the numbers (of mode character) of the matrix \code{edge} of \code{phy} are used as names. } \author{Emmanuel Paradis} \seealso{ \code{\link{is.ultrametric}} } \keyword{manip} ape/man/additive.Rd0000644000175100001440000000124312661357152013700 0ustar hornikusers\name{additive} \alias{additive} \alias{ultrametric} \title{Incomplete Distance Matrix Filling} \description{ Fills missing entries from incomplete distance matrix using the additive or the ultrametric procedure (see reference for details). } \usage{ additive(X) ultrametric(X) } \arguments{ \item{X}{a distance matrix or an object of class \code{"dist"}.} } \value{ a distance matrix. } \references{ Makarenkov, V. and Lapointe, F.-J. (2004) A weighted least-squares approach for inferring phylogenies from incomplete distance matrices. \emph{Bioinformatics}, \bold{20}, 2113--2121. } \author{Andrei Popescu \email{niteloserpopescu@gmail.com}} \keyword{manip} ape/man/corClasses.Rd0000644000175100001440000000322312435624675014216 0ustar hornikusers\name{corClasses} \alias{corClasses} \alias{corPhyl} \title{Phylogenetic Correlation Structures} \description{ Classes of phylogenetic correlation structures (\code{"corPhyl"}) available in \pkg{ape}. \itemize{ \item{corBrownian}{Brownian motion model (Felsenstein 1985)} \item{corMartins}{The covariance matrix defined in Martins and Hansen (1997)} \item{corGrafen}{The covariance matrix defined in Grafen (1989)} \item{corPagel}{The covariance matrix defined in Freckelton et al. (2002)} \item{corBlomberg}{The covariance matrix defined in Blomberg et al. (2003)} } See the help page of each class for references and detailed description. } \seealso{ \code{\link[nlme]{corClasses}} and \code{\link[nlme]{gls}} in the \pkg{nlme} librarie, \code{\link{corBrownian}}, \code{\link{corMartins}}, \code{\link{corGrafen}}, \code{\link{corPagel}}, \code{\link{corBlomberg}}, \code{\link{vcv}}, \code{\link{vcv2phylo}} } \author{Julien Dutheil \email{julien.dutheil@univ-montp2.fr}, Emmanuel Paradis} \examples{ library(nlme) cat("((((Homo:0.21,Pongo:0.21):0.28,", "Macaca:0.49):0.13,Ateles:0.62):0.38,Galago:1.00);", file = "ex.tre", sep = "\n") tree.primates <- read.tree("ex.tre") X <- c(4.09434, 3.61092, 2.37024, 2.02815, -1.46968) Y <- c(4.74493, 3.33220, 3.36730, 2.89037, 2.30259) unlink("ex.tre") # delete the file "ex.tre" m1 <- gls(Y ~ X, correlation=corBrownian(1, tree.primates)) summary(m1) m2 <- gls(Y ~ X, correlation=corMartins(1, tree.primates)) summary(m2) corMatrix(m2$modelStruct$corStruct) m3 <- gls(Y ~ X, correlation=corGrafen(1, tree.primates)) summary(m3) corMatrix(m3$modelStruct$corStruct) } \keyword{models} ape/man/bind.tree.Rd0000644000175100001440000001005011715637743013763 0ustar hornikusers\name{bind.tree} \alias{bind.tree} \alias{+.phylo} \title{Binds Trees} \usage{ bind.tree(x, y, where = "root", position = 0, interactive = FALSE) \special{x + y} } \arguments{ \item{x}{an object of class \code{"phylo"}.} \item{y}{an object of class \code{"phylo"}.} \item{where}{an integer giving the number of the node or tip of the tree \code{x} where the tree \code{y} is binded (\code{"root"} is a short-cut for the root).} \item{position}{a numeric value giving the position from the tip or node given by \code{node} where the tree \code{y} is binded; negative values are ignored.} \item{interactive}{if \code{TRUE} the user is asked to choose the tip or node of \code{x} by clicking on the tree which must be plotted.} } \description{ This function binds together two phylogenetic trees to give a single object of class \code{"phylo"}. } \details{ The argument \code{x} can be seen as the receptor tree, whereas \code{y} is the donor tree. The root of \code{y} is then grafted on a location of \code{x} specified by \code{where} and, possibly, \code{position}. If \code{y} has a root edge, this is added as in internal branch in the resulting tree. \code{x + y} is a shortcut for: \preformatted{ bind.tree(x, y, position = if (is.null(x$root.edge)) 0 else x$root.edge) } If only one of the trees has no branch length, the branch lengths of the other one are ignored with a warning. If one (or both) of the trees has no branch length, it is possible to specify a value of 'position' to graft 'y' below the node of 'x' specified by 'where'. In this case, the exact value of 'position' is not important as long as it is greater than zero. The new node will be multichotomous if 'y' has no root edge. This can be solved by giving an arbitrary root edge to 'y' beforehand (e.g., \code{y$root.edge <- 1}): it will be deleted during the binding operation. } \value{ an object of class \code{"phylo"}. } \author{Emmanuel Paradis} \seealso{ \code{\link{drop.tip}}, \code{\link{root}} } \examples{ ### binds the two clades of bird orders cat("((Struthioniformes:21.8,Tinamiformes:21.8):4.1,", "((Craciformes:21.6,Galliformes:21.6):1.3,Anseriformes:22.9):3.0):2.1;", file = "ex1.tre", sep = "\n") cat("(Turniciformes:27.0,(Piciformes:26.3,((Galbuliformes:24.4,", "((Bucerotiformes:20.8,Upupiformes:20.8):2.6,", "(Trogoniformes:22.1,Coraciiformes:22.1):1.3):1.0):0.6,", "(Coliiformes:24.5,(Cuculiformes:23.7,(Psittaciformes:23.1,", "(((Apodiformes:21.3,Trochiliformes:21.3):0.6,", "(Musophagiformes:20.4,Strigiformes:20.4):1.5):0.6,", "((Columbiformes:20.8,(Gruiformes:20.1,Ciconiiformes:20.1):0.7):0.8,", "Passeriformes:21.6):0.9):0.6):0.6):0.8):0.5):1.3):0.7):1.0;", file = "ex2.tre", sep = "\n") tree.bird1 <- read.tree("ex1.tre") tree.bird2 <- read.tree("ex2.tre") unlink(c("ex1.tre", "ex2.tre")) # clean-up (birds <- tree.bird1 + tree.bird2) layout(matrix(c(1, 2, 3, 3), 2, 2)) plot(tree.bird1) plot(tree.bird2) plot(birds) ### examples with random trees x <- rtree(4, tip.label = LETTERS[1:4]) y <- rtree(4, tip.label = LETTERS[5:8]) x <- makeNodeLabel(x, prefix = "x_") y <- makeNodeLabel(y, prefix = "y_") x$root.edge <- y$root.edge <- .2 z <- bind.tree(x, y, po=.2) plot(y, show.node.label = TRUE, font = 1, root.edge = TRUE) title("y") plot(x, show.node.label = TRUE, font = 1, root.edge = TRUE) title("x") plot(z, show.node.label = TRUE, font = 1, root.edge = TRUE) title("z <- bind.tree(x, y, po=.2)") z <- bind.tree(x, y, 2, .1) plot(y, show.node.label = TRUE, font = 1, root.edge = TRUE) title("y") plot(x, show.node.label = TRUE, font = 1, root.edge = TRUE) title("x") plot(z, show.node.label = TRUE, font = 1, root.edge = TRUE) title("z <- bind.tree(x, y, 2, .1)") x <- rtree(50) y <- rtree(50) x$root.edge <- y$root.edge <- .2 z <- x + y plot(y, show.tip.label = FALSE, root.edge = TRUE); axisPhylo() title("y") plot(x, show.tip.label = FALSE, root.edge = TRUE); axisPhylo() title("x") plot(z, show.tip.label = FALSE, root.edge = TRUE); axisPhylo() title("z <- x + y") layout(1) } \keyword{manip} ape/man/bird.families.Rd0000644000175100001440000000254010775732361014623 0ustar hornikusers\name{bird.families} \alias{bird.families} \title{Phylogeny of the Families of Birds From Sibley and Ahlquist} \description{ This data set describes the phylogenetic relationships of the families of birds as reported by Sibley and Ahlquist (1990). Sibley and Ahlquist inferred this phylogeny from an extensive number of DNA/DNA hybridization experiments. The ``tapestry'' reported by these two authors (more than 1000 species out of the ca. 9000 extant bird species) generated a lot of debates. The present tree is based on the relationships among families. A few families were not included in the figures in Sibley and Ahlquist, and thus are not included here as well. The branch lengths were calculated from the values of \eqn{\Delta T_{50}H}{Delta T50H} as found in Sibley and Ahlquist (1990, figs. 354, 355, 356, and 369). } \usage{ data(bird.families) } \format{ The data are stored as an object of class \code{"phylo"} which structure is described in the help page of the function \code{\link{read.tree}}. } \source{ Sibley, C. G. and Ahlquist, J. E. (1990) Phylogeny and classification of birds: a study in molecular evolution. New Haven: Yale University Press. } \seealso{ \code{\link{read.tree}}, \code{\link{bird.orders}} } \examples{ data(bird.families) op <- par() par(cex = 0.3) plot(bird.families) par(op) } \keyword{datasets} ape/man/alex.Rd0000644000175100001440000000263612623114175013041 0ustar hornikusers\name{alex} \alias{alex} \title{Alignment Explorer With Multiple Devices} \description{ This function helps to explore DNA alignments by zooming in. The user clicks twice defining the opposite corners of the portion which is extracted and drawned on a new window. } \usage{ alex(x, ...) } \arguments{ \item{x}{an object of class \code{"DNAbin"}.} \item{\dots}{further arguments to pass to \code{image.DNAbin}.} } \details{ This function works with a DNA alignment (freshly) plotted on an interactive graphical device (i.e., not a file) with \code{image}. After calling \code{alex}, the user clicks twice defining a rectangle in the alignment, then this portion of the alignment is extacted and plotted on a \emph{new} window. The user can click as many times on the alignment. The process is stopped by a right-click. If the user clicks twice outside the alignment, a message ``Try again!'' is printed. Each time \code{alex} is called, the alignment is plotted on a new window without closing or deleting those possibly already plotted. In all cases, the device where \code{x} is plotted is the active window after the operation. It should \emph{not} be closed during the whole process. } \value{NULL} \author{Emmanuel Paradis} \seealso{ \code{\link{image.DNAbin}}, \code{\link{trex}}, \code{\link{alview}} } \examples{ \dontrun{ data(woodmouse) image(woodmouse) alex(woodmouse) }} \keyword{hplot} ape/man/corBrownian.Rd0000644000175100001440000000425711420316265014372 0ustar hornikusers\name{corBrownian} \alias{corBrownian} \alias{coef.corBrownian} \alias{corMatrix.corBrownian} \title{Brownian Correlation Structure} \usage{ corBrownian(value=1, phy, form=~1) \method{coef}{corBrownian}(object, unconstrained = TRUE, ...) \method{corMatrix}{corBrownian}(object, covariate = getCovariate(object), corr = TRUE, ...) } \arguments{ \item{value}{The \eqn{\gamma}{gamma} parameter (default to 1)} \item{phy}{An object of class \code{phylo} representing the phylogeny (with branch lengths) to consider} \item{object}{An (initialized) object of class \code{corBrownian}} \item{corr}{a logical value. If 'TRUE' the function returns the correlation matrix, otherwise it returns the variance/covariance matrix.} \item{form}{ignored for now.} \item{covariate}{ignored for now.} \item{unconstrained}{a logical value. If 'TRUE' the coefficients are returned in unconstrained form (the same used in the optimization algorithm). If 'FALSE' the coefficients are returned in "natural", possibly constrained, form. Defaults to 'TRUE'} \item{\dots}{some methods for these generics require additional arguments. None are used in these methods.} } \description{ Expected covariance under a Brownian model (Felsenstein 1985, Martins and Hansen 1997) \deqn{V_{ij} = \gamma \times t_a}{Vij = gamma . ta} where \eqn{t_a}{ta} is the distance on the phylogeny between the root and the most recent common ancestor of taxa \eqn{i}{i} and \eqn{j}{j} and \eqn{\gamma}{gamma} is a constant. } \value{ An object of class \code{corBrownian}, or the coefficient from an object of this class (actually sends \code{numeric(0)}), or the correlation matrix of an initialized object of this class. } \author{Julien Dutheil \email{julien.dutheil@univ-montp2.fr}} \seealso{ \code{\link{corClasses}} } \references{ Felsenstein, J. (1985) Phylogenies and the comparative method. \emph{American Naturalist}, \bold{125}, 1--15. Martins, E. P. and Hansen, T. F. (1997) Phylogenies and the comparative method: a general approach to incorporating phylogenetic information into the analysis of interspecific data. \emph{American Naturalist}, \bold{149}, 646--667. } \keyword{models} ape/man/rTraitCont.Rd0000644000175100001440000000747112024532163014177 0ustar hornikusers\name{rTraitCont} \alias{rTraitCont} \title{Continuous Character Simulation} \usage{ rTraitCont(phy, model = "BM", sigma = 0.1, alpha = 1, theta = 0, ancestor = FALSE, root.value = 0, ...) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{model}{a character (either \code{"BM"} or \code{"OU"}) or a function specifying the model (see details).} \item{sigma}{a numeric vector giving the standard-deviation of the random component for each branch (can be a single value).} \item{alpha}{if \code{model = "OU"}, a numeric vector giving the strength of the selective constraint for each branch (can be a single value).} \item{theta}{if \code{model = "OU"}, a numeric vector giving the optimum for each branch (can be a single value).} \item{ancestor}{a logical value specifying whether to return the values at the nodes as well (by default, only the values at the tips are returned).} \item{root.value}{a numeric giving the value at the root.} \item{\dots}{further arguments passed to \code{model} if it is a function.} } \description{ This function simulates the evolution of a continuous character along a phylogeny. The calculation is done recursively from the root. See Paradis (2012, pp. 232 and 324) for an introduction. } \details{ There are three possibilities to specify \code{model}: \itemize{ \item{\code{"BM"}:}{a Browian motion model is used. If the arguments \code{sigma} has more than one value, its length must be equal to the the branches of the tree. This allows to specify a model with variable rates of evolution. You must be careful that branch numbering is done with the tree in ``pruningwise'' order: to see the order of the branches you can use: \code{tr <- reorder(tr, "p"); plor(tr); edgelabels()}. The arguments \code{alpha} and \code{theta} are ignored.} \item{\code{"OU"}:}{an Ornstein-Uhlenbeck model is used. The above indexing rule is used for the three parameters \code{sigma}, \code{alpha}, and \code{theta}. This may be interesting for the last one to model varying phenotypic optima. The exact updating formula from Gillespie (1996) are used which are reduced to BM formula if \code{alpha = 0}.} \item{A function:}{it must be of the form \code{foo(x, l)} where \code{x} is the trait of the ancestor and \code{l} is the branch length. It must return the value of the descendant. The arguments \code{sigma}, \code{alpha}, and \code{theta} are ignored.} }} \value{ A numeric vector with names taken from the tip labels of \code{phy}. If \code{ancestor = TRUE}, the node labels are used if present, otherwise, ``Node1'', ``Node2'', etc. } \references{ Gillespie, D. T. (1996) Exact numerical simulation of the Ornstein-Uhlenbeck process and its integral. \emph{Physical Review E}, \bold{54}, 2084--2091. Paradis, E. (2012) \emph{Analysis of Phylogenetics and Evolution with R (Second Edition).} New York: Springer. } \author{Emmanuel Paradis} \seealso{ \code{\link{rTraitDisc}}, \code{\link{rTraitMult}}, \code{\link{ace}} } \examples{ data(bird.orders) rTraitCont(bird.orders) # BM with sigma = 0.1 ### OU model with two optima: tr <- reorder(bird.orders, "postorder") plot(tr) edgelabels() theta <- rep(0, Nedge(tr)) theta[c(1:4, 15:16, 23:24)] <- 2 ## sensitive to 'alpha' and 'sigma': rTraitCont(tr, "OU", theta = theta, alpha=.1, sigma=.01) ### an imaginary model with stasis 0.5 time unit after a node, then ### BM evolution with sigma = 0.1: foo <- function(x, l) { if (l <= 0.5) return(x) x + (l - 0.5)*rnorm(1, 0, 0.1) } tr <- rcoal(20, br = runif) rTraitCont(tr, foo, ancestor = TRUE) ### a cumulative Poisson process: bar <- function(x, l) x + rpois(1, l) (x <- rTraitCont(tr, bar, ancestor = TRUE)) plot(tr, show.tip.label = FALSE) Y <- x[1:20] A <- x[-(1:20)] nodelabels(A) tiplabels(Y) } \keyword{datagen} ape/man/is.ultrametric.Rd0000644000175100001440000000241613002723742015047 0ustar hornikusers\name{is.ultrametric} \alias{is.ultrametric} \alias{is.ultrametric.phylo} \alias{is.ultrametric.multiPhylo} \title{Test if a Tree is Ultrametric} \description{ This function tests whether a tree is ultrametric using the distances from each tip to the root. } \usage{ is.ultrametric(phy, ...) \method{is.ultrametric}{phylo}(phy, tol = .Machine$double.eps^0.5, option = 1, ...) \method{is.ultrametric}{multiPhylo}(phy, tol = .Machine$double.eps^0.5, option = 1, ...) } \arguments{ \item{phy}{an object of class \code{"phylo"} or \code{"multiPhylo"}.} \item{tol}{a numeric >= 0, variation below this value are considered non-significant.} \item{option}{an integer (1 or 2; see details).} \item{\dots}{arguments passed among methods.} } \details{ The test is based on the distances from each tip to the root and a criterion: if \code{option = 1}, the criterion is the scaled range ((max - min/max)), if \code{option = 2}, the variance is used (this was the method used until ape 3.5). The default criterion is invariant to linear changes of the branch lengths. } \value{ a logical vector. } \author{Emmanuel Paradis} \seealso{ \code{\link{is.binary}}, \code{\link[base]{.Machine}} } \examples{ is.ultrametric(rtree(10)) is.ultrametric(rcoal(10)) } \keyword{utilities} ape/man/chronos.Rd0000644000175100001440000001237112244624036013561 0ustar hornikusers\name{chronos} \alias{chronos} \alias{makeChronosCalib} \alias{chronos.control} \alias{print.chronos} \title{Molecular Dating by Penalised Likelihood and Maximum Likelihood} \description{ \code{chronos} is the main function fitting a chronogram to a phylogenetic tree whose branch lengths are in number of substitution per sites. \code{makeChronosCalib} is a tool to prepare data frames with the calibration points of the phylogenetic tree. \code{chronos.control} creates a list of parameters to be passed to \code{chronos}. } \usage{ chronos(phy, lambda = 1, model = "correlated", quiet = FALSE, calibration = makeChronosCalib(phy), control = chronos.control()) \method{print}{chronos}(x, ...) makeChronosCalib(phy, node = "root", age.min = 1, age.max = age.min, interactive = FALSE, soft.bounds = FALSE) chronos.control(...) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{lambda}{value of the smoothing parameter.} \item{model}{a character string specifying the model of substitution rate variation among branches. The possible choices are: ``correlated'', ``relaxed'', ``discrete'', or an unambiguous abbreviation of these.} \item{quiet}{a logical value; by default the calculation progress are displayed.} \item{calibration}{a data frame (see details).} \item{control}{a list of parameters controlling the optimisation procedure (see details).} \item{x}{an object of class \code{c("chronos", "phylo")}.} \item{node}{a vector of integers giving the node numbers for which a calibration point is given. The default is a short-cut for the root.} \item{age.min, age.max}{vectors of numerical values giving the minimum and maximum ages of the nodes specified in \code{node}.} \item{interactive}{a logical value. If \code{TRUE}, then \code{phy} is plotted and the user is asked to click close to a node and enter the ages on the keyboard.} \item{soft.bounds}{(currently unused)} \item{\dots}{in the case of \code{chronos.control}: one of the five parameters controlling optimisation (unused in the case of \code{print.chronos}).} } \details{ \code{chronos} replaces \code{chronopl} but with a different interface and some extensions (see References). The known dates (argument \code{calibration}) must be given in a data frame with the following column names: node, age.min, age.max, and soft.bounds (the last one is yet unused). For each row, these are, respectively: the number of the node in the ``phylo'' coding standard, the minimum age for this node, the maximum age, and a logical value specifying whether the bounds are soft. If age.min = age.max, this means that the age is exactly known. This data frame can be built with \code{makeChronosCalib} which returns by default a data frame with a single row giving age = 1 for the root. The data frame can be built interactively by clicking on the plotted tree. The argument \code{control} allows one to change some parameters of the optimisation procedure. This must be a list with names. The available options with their default values are: \itemize{ \item{tol = 1e-8: }{tolerance for the estimation of the substitution rates.} \item{iter.max = 1e4: }{the maximum number of iterations at each optimization step.} \item{eval.max = 1e4: }{the maximum number of function evaluations at each optimization step.} \item{nb.rate.cat = 10: }{the number of rate categories if \code{model = "discrete"} (set this parameter to 1 to fit a strict clock model).} \item{dual.iter.max = 20: }{the maximum number of alternative iterations between rates and dates.} } The command \code{chronos.control()} returns a list with the default values of these parameters. They may be modified by passing them to this function, or directly in the list. } \value{ \code{chronos} returns an object of class \code{c("chronos", "phylo")}. There is a print method for it. There are additional attributes which can be visualised with \code{str} or extracted with \code{attr}. \code{makeChronosCalib} returns a data frame. \code{chronos.control} returns a list. } \references{ Kim, J. and Sanderson, M. J. (2008) Penalized likelihood phylogenetic inference: bridging the parsimony-likelihood gap. \emph{Systematic Biology}, \bold{57}, 665--674. Paradis, E. (2013) Molecular dating of phylogenies by likelihood methods: a comparison of models and a new information criterion. \emph{Molecular Phylogenetics and Evolution}, \bold{67}, 436--444. Sanderson, M. J. (2002) Estimating absolute rates of molecular evolution and divergence times: a penalized likelihood approach. \emph{Molecular Biology and Evolution}, \bold{19}, 101--109. } \author{Emmanuel Paradis} \seealso{ \code{\link{chronoMPL}} } \examples{ tr <- rtree(10) ### the default is the correlated rate model: chr <- chronos(tr) ### strict clock model: ctrl <- chronos.control(nb.rate.cat = 1) chr.clock <- chronos(tr, model = "discrete", control = ctrl) ### How different are the rates? attr(chr, "rates") attr(chr.clock, "rates") \dontrun{ cal <- makeChronosCalib(tr, interactive = TRUE) cal ### if you made mistakes, you can edit the data frame with: ### fix(cal) chr <- chronos(tr, calibration = cal) } } \keyword{models} ape/man/compar.cheverud.Rd0000644000175100001440000000477511747715541015215 0ustar hornikusers\name{compar.cheverud} \alias{compar.cheverud} \title{Cheverud's Comparative Method} \description{ This function computes the phylogenetic variance component and the residual deviation for continous characters, taking into account the phylogenetic relationships among species, following the comparative method described in Cheverud et al. (1985). The correction proposed by Rholf (2001) is used. } \usage{ compar.cheverud(y, W, tolerance = 1e-06, gold.tol = 1e-04) } \arguments{ \item{y}{A vector containing the data to analyse.} \item{W}{The phylogenetic connectivity matrix. All diagonal elements will be ignored.} \item{tolerance}{Minimum difference allowed to consider eigenvalues as distinct.} \item{gold.tol}{Precision to use in golden section search alogrithm.} } \details{ Model: \deqn{y = \rho W y + e}{y = rho.W.y + e} where \eqn{e}{e} is the error term, assumed to be normally distributed. \eqn{\rho}{rho} is estimated by the maximum likelihood procedure given in Rohlf (2001), using a golden section search algorithm. The code of this function is indeed adapted from a MatLab code given in appendix in Rohlf's article, to correct a mistake in Cheverud's original paper. } \value{ A list with the following components: \item{rhohat}{The maximum likelihood estimate of \eqn{\rho}{rho}} \item{Wnorm}{The normalized version of \code{W}} \item{residuals}{Error terms (\eqn{e}{e})} } \references{ Cheverud, J. M., Dow, M. M. and Leutenegger, W. (1985) The quantitative assessment of phylogenetic constraints in comparative analyses: sexual dimorphism in body weight among primates. \emph{Evolution}, \bold{39}, 1335--1351. Rohlf, F. J. (2001) Comparative methods for the analysis of continuous variables: geometric interpretations. \emph{Evolution}, \bold{55}, 2143--2160. Harvey, P. H. and Pagel, M. D. (1991) \emph{The Comparative Method in Evolutionary Biology}. Oxford University Press. } \author{Julien Dutheil \email{julien.dutheil@univ-montp2.fr}} \seealso{\code{\link{compar.lynch}}} \examples{ ### Example from Harvey and Pagel's book: y<-c(10,8,3,4) W <- matrix(c(1,1/6,1/6,1/6,1/6,1,1/2,1/2,1/6,1/2,1,1,1/6,1/2,1,1), 4) compar.cheverud(y,W) ### Example from Rohlf's 2001 article: W<- matrix(c( 0,1,1,2,0,0,0,0, 1,0,1,2,0,0,0,0, 1,1,0,2,0,0,0,0, 2,2,2,0,0,0,0,0, 0,0,0,0,0,1,1,2, 0,0,0,0,1,0,1,2, 0,0,0,0,1,1,0,2, 0,0,0,0,2,2,2,0 ),8) W <- 1/W W[W == Inf] <- 0 y<-c(-0.12,0.36,-0.1,0.04,-0.15,0.29,-0.11,-0.06) compar.cheverud(y,W) } \keyword{regression} ape/man/MPR.Rd0000644000175100001440000000447311453314721012546 0ustar hornikusers\name{MPR} \alias{MPR} \title{Most Parsimonious Reconstruction} \description{ This function does ancestral character reconstruction by parsimony as described in Hanazawa et al. (1995) and modified by Narushima and Hanazawa (1997). } \usage{ MPR(x, phy, outgroup) } \arguments{ \item{x}{a vector of integers.} \item{phy}{an object of class \code{"phylo"}; the tree must be unrooted and fully dichotomous.} \item{outgroup}{an integer or a character string giving the tip of \code{phy} used as outgroup.} } \details{ Hanazawa et al. (1995) and Narushima and Hanazawa (1997) used Farris's (1970) and Swofford and Maddison's (1987) framework to reconstruct ancestral states using parsimony. The character is assumed to take integer values. The algorithm finds the sets of values for each node as intervals with lower and upper values. It is recommended to root the tree with the outgroup before the analysis, so plotting the values with \code{\link{nodelabels}} is simple. } \value{ a matrix of integers with two columns named ``lower'' and ``upper'' giving the lower and upper values of the reconstructed sets for each node. } \references{ Farris, J. M. (1970) Methods for computing Wagner trees. \emph{Systematic Zoology}, \bold{19}, 83--92. Hanazawa, M., Narushima, H. and Minaka, N. (1995) Generating most parsimonious reconstructions on a tree: a generalization of the Farris--Swofford--Maddison method. \emph{Discrete Applied Mathematics}, \bold{56}, 245--265. Narushima, H. and Hanazawa, M. (1997) A more efficient algorithm for MPR problems in phylogeny. \emph{Discrete Applied Mathematics}, \bold{80}, 231--238. Swofford, D. L. and Maddison, W. P. (1987) Reconstructing ancestral character states under Wagner parsimony. \emph{Mathematical Biosciences}, \bold{87}, 199--229. }\author{Emmanuel Paradis} \seealso{ \code{\link{ace}}, \code{\link{root}}, \code{\link{nodelabels}} } \examples{ ## the example in Narushima and Hanazawa (1997): tr <- read.tree(text = "(((i,j)c,(k,l)b)a,(h,g)e,f)d;") x <- c(1, 3, 0, 6, 5, 2, 4) names(x) <- letters[6:12] (o <- MPR(x, tr, "f")) plot(tr) nodelabels(paste("[", o[, 1], ",", o[, 2], "]", sep = "")) tiplabels(x[tr$tip.label], adj = -2) ## some random data: x <- rpois(30, 1) tr <- rtree(30, rooted = FALSE) MPR(x, tr, "t1") } \keyword{models} ape/man/mat5M3ID.Rd0000644000175100001440000000051411163652513013365 0ustar hornikusers\name{mat5M3ID} \alias{mat5M3ID} \title{Five Trees} \description{ Three partly similar trees, two independent trees. } \usage{ data(mat5M3ID) } \format{ A data frame with 250 observations and 50 variables. } \source{ Data provided by V. Campbell. } \seealso{ \code{\link{mat5Mrand}}, \code{\link{mat3}} } \keyword{datasets} ape/man/as.matching.Rd0000644000175100001440000000436311532117272014302 0ustar hornikusers\name{as.matching} \alias{as.matching} \alias{matching} \alias{as.matching.phylo} \alias{as.phylo.matching} \title{Conversion Between Phylo and Matching Objects} \description{ These functions convert objects between the classes \code{"phylo"} and \code{"matching"}. } \usage{ as.matching(x, ...) \method{as.matching}{phylo}(x, labels = TRUE, ...) \method{as.phylo}{matching}(x, ...) } \arguments{ \item{x}{an object to convert as an object of class \code{"matching"} or of class \code{"phylo"}.} \item{labels}{a logical specifying whether the tip and node labels should be included in the returned matching.} \item{\dots}{further arguments to be passed to or from other methods.} } \details{ A matching is a representation where each tip and each node are given a number, and sibling groups are grouped in a ``matching pair'' (see Diaconis and Holmes 1998, for details). This coding system can be used only for binary (fully dichotomous) trees. Diaconis and Holmes (1998) gave some conventions to insure that a given tree has a unique representation as a matching. I have tried to follow them in the present functions. } \value{ \code{as.matching} returns an object of class \code{"matching"} with the following component: \item{matching}{a two-column numeric matrix where the columns represent the sibling pairs.} \item{tip.label}{(optional) a character vector giving the tip labels where the ith element is the label of the tip numbered i in \code{matching}.} \item{node.label}{(optional) a character vector giving the node labels in the same order than in \code{matching} (i.e. the ith element is the label of the node numbered i + n in \code{matching}, with n the number of tips).} \code{as.phylo.matching} returns an object of class \code{"phylo"}. } \note{ Branch lengths are not supported in the present version. } \author{Emmanuel Paradis} \references{ Diaconis, P. W. and Holmes, S. P. (1998) Matchings and phylogenetic trees. \emph{Proceedings of the National Academy of Sciences USA}, \bold{95}, 14600--14602. } \seealso{\code{\link{as.phylo}}} \examples{ data(bird.orders) m <- as.matching(bird.orders) str(m) m tr <- as.phylo(m) all.equal(tr, bird.orders, use.edge.length = FALSE) } \keyword{manip} ape/man/correlogram.formula.Rd0000644000175100001440000000364311353107046016065 0ustar hornikusers\name{correlogram.formula} \alias{correlogram.formula} \title{Phylogenetic Correlogram} \usage{ correlogram.formula(formula, data = NULL, use = "all.obs") } \arguments{ \item{formula}{a formula of the type \code{y1+..+yn ~ g1/../gn}, where the \code{y}'s are the data to analyse and the \code{g}'s are the taxonomic levels.} \item{data}{a data frame containing the variables specified in the formula. If \code{NULL}, the variables are sought in the user's workspace.} \item{use}{a character string specifying how to handle missing values (i.e., \code{NA}). This must be one of "all.obs", "complete.obs", or "pairwise.complete.obs", or any unambiguous abbrevation of these. In the first case, the presence of missing values produces an error. In the second case, all rows with missing values will be removed before computation. In the last case, missing values are removed on a case-by-case basis.} } \description{ This function computes a correlogram from taxonomic levels. } \details{ See the vignette in R: \code{vignette("MoranI")}. } \value{ An object of class \code{correlogram} which is a data frame with three columns: \item{obs}{the computed Moran's I} \item{p.values}{the corresponding P-values} \item{labels}{the names of each level} or an object of class \code{correlogramList} containing a list of objects of class \code{correlogram} if several variables are given as response in \code{formula}. } \author{Julien Dutheil \email{julien.dutheil@univ-montp2.fr} and Emmanuel Paradis} \seealso{ \code{\link{plot.correlogram}, \link{Moran.I}} } \examples{ data(carnivora) ### Using the formula interface: co <- correlogram.formula(SW ~ Order/SuperFamily/Family/Genus, data=carnivora) co plot(co) ### Several correlograms on the same plot: cos <- correlogram.formula(SW + FW ~ Order/SuperFamily/Family/Genus, data=carnivora) cos plot(cos) } \keyword{regression} ape/man/njs.Rd0000644000175100001440000000234111736034401012670 0ustar hornikusers\name{njs} \alias{njs} \alias{bionjs} \title{Tree Reconstruction from Incomplete Distances With NJ* or bio-NJ*} \description{ Reconstructs a phylogenetic tree from a distance matrix with possibly missing values. } \usage{ njs(X, fs = 15) bionjs(X, fs = 15) } \arguments{ \item{X}{a distance matrix.} \item{fs}{argument \emph{s} of the agglomerative criterion: it is coerced as an integer and must at least equal to one.} } \details{ Missing values represented by either \code{NA} or any negative number. Basically, the Q* criterion is applied to all the pairs of leaves, and the \emph{s} highest scoring ones are chosen for further analysis by the agglomeration criteria that better handle missing distances (see references for details). } \value{ an object of class \code{"phylo"}. } \references{ \url{http://www.biomedcentral.com/1471-2105/9/166} } \author{Andrei Popescu \email{niteloserpopescu@gmail.com}} \seealso{ \code{\link{nj}}, \code{\link{bionj}}, \code{\link{triangMtds}} } \examples{ data(woodmouse) d <- dist.dna(woodmouse) dm <- d dm[sample(length(dm), size = 3)] <- NA dist.topo(njs(dm), nj(d)) # often 0 dm[sample(length(dm), size = 10)] <- NA dist.topo(njs(dm), nj(d)) # sometimes 0 } \keyword{models} ape/man/write.tree.Rd0000644000175100001440000000430511464177137014204 0ustar hornikusers\name{write.tree} \alias{write.tree} \title{Write Tree File in Parenthetic Format} \usage{ write.tree(phy, file = "", append = FALSE, digits = 10, tree.names = FALSE) } \arguments{ \item{phy}{an object of class \code{"phylo"} or \code{"multiPhylo"}.} \item{file}{a file name specified by either a variable of mode character, or a double-quoted string; if \code{file = ""} (the default) then the tree is written on the standard output connection (i.e. the console).} \item{append}{a logical, if \code{TRUE} the tree is appended to the file without erasing the data possibly existing in the file, otherwise the file (if it exists) is overwritten (\code{FALSE} the default).} \item{digits}{a numeric giving the number of digits used for printing branch lengths.} \item{tree.names}{either a logical or a vector of mode character. If \code{TRUE} then any tree names will be written prior to the tree on each line. If character, specifies the name of \code{"phylo"} objects which can be written to the file.} } \description{ This function writes in a file a tree in parenthetic format using the Newick (also known as New Hampshire) format. } \value{ a vector of mode character if \code{file = ""}, none (invisible \code{NULL}) otherwise. } \details{ The node labels and the root edge length, if available, are written in the file. If \code{tree.names == TRUE} then a variant of the Newick format is written for which the name of a tree precedes the Newick format tree (parentheses are eventually deleted beforehand). The tree names are taken from the \code{names} attribute if present (they are ignored if \code{tree.names} is a character vector). } \references{ Felsenstein, J. The Newick tree format. \url{http://evolution.genetics.washington.edu/phylip/newicktree.html} Olsen, G. Interpretation of the "Newick's 8:45" tree format standard. \url{http://evolution.genetics.washington.edu/phylip/newick_doc.html} } \author{Emmanuel Paradis, Daniel Lawson \email{dan.lawson@bristol.ac.uk}, and Klaus Schliep \email{kschliep@snv.jussieu.fr}} \seealso{ \code{\link{read.tree}}, \code{\link{read.nexus}}, \code{\link{write.nexus}} } \keyword{manip} \keyword{IO}ape/man/root.Rd0000644000175100001440000001055313014573730013071 0ustar hornikusers\name{root} \alias{root} \alias{root.phylo} \alias{root.multiPhylo} \alias{unroot} \alias{unroot.phylo} \alias{unroot.multiPhylo} \alias{is.rooted} \alias{is.rooted.phylo} \alias{is.rooted.multiPhylo} \title{Roots Phylogenetic Trees} \description{ \code{root} reroots a phylogenetic tree with respect to the specified outgroup or at the node specified in \code{node}. \code{unroot} unroots a phylogenetic tree, or returns it unchanged if it is already unrooted. \code{is.rooted} tests whether a tree is rooted. } \usage{ root(phy, ...) \method{root}{phylo}(phy, outgroup, node = NULL, resolve.root = FALSE, interactive = FALSE, edgelabel = FALSE, ...) \method{root}{multiPhylo}(phy, outgroup, ...) unroot(phy) \method{unroot}{phylo}(phy) \method{unroot}{multiPhylo}(phy) is.rooted(phy) \method{is.rooted}{phylo}(phy) \method{is.rooted}{multiPhylo}(phy) } \arguments{ \item{phy}{an object of class \code{"phylo"} or \code{"multiPhylo"}.} \item{outgroup}{a vector of mode numeric or character specifying the new outgroup.} \item{node}{alternatively, a node number where to root the tree.} \item{resolve.root}{a logical specifying whether to resolve the new root as a bifurcating node.} \item{interactive}{if \code{TRUE} the user is asked to select the node by clicking on the tree which must be plotted.} \item{edgelabel}{a logical value specifying whether to treat node labels as edge labels and thus eventually switching them so that they are associated with the correct edges when using \code{\link{drawSupportOnEdges}} (see Czech et al. 2016).} \item{\dots}{arguments passed among methods (e.g., when rooting lists of trees).} } \details{ The argument \code{outgroup} can be either character or numeric. In the first case, it gives the labels of the tips of the new outgroup; in the second case the numbers of these labels in the vector \code{phy$tip.label} are given. If \code{outgroup} is of length one (i.e., a single value), then the tree is rerooted using the node below this tip as the new root. If \code{outgroup} is of length two or more, the most recent common ancestor (MRCA) \emph{of the ingroup} is used as the new root. Note that the tree is unrooted before being rerooted, so that if \code{outgroup} is already the outgroup, then the returned tree is not the same than the original one (see examples). If \code{outgroup} is not monophyletic, the operation fails and an error message is issued. If \code{resolve.root = TRUE}, \code{root} adds a zero-length branch below the MRCA of the ingroup. A tree is considered rooted if either only two branches connect to the root, or if there is a \code{root.edge} element. In all other cases, \code{is.rooted} returns \code{FALSE}. } \note{ The use of \code{resolve.root = TRUE} together with \code{node = } gives an error if the specified node is the current root of the tree. This is because there is an ambiguity when resolving a node in an unrooted tree with no explicit outgroup. If the node is not the current root, the ambiguity is solved arbitrarily by considering the clade on the right of \code{node} (when the tree is plotted by default) as the ingroup. See a detailed explanation there: \url{http://www.mail-archive.com/r-sig-phylo@r-project.org/msg03805.html}. } \value{ an object of class \code{"phylo"} or \code{"multiPhylo"} for \code{root} and \code{unroot}; a logical vector for \code{is.rooted}. } \references{ Czech, L., Huerta-Cepas, J. and Stamatakis, A. (2016) A critical review on the use of support values in tree viewers and bioinformatics toolkits. \url{http://dx.doi.org/10.1101/035360} } \author{Emmanuel Paradis} \seealso{ \code{\link{bind.tree}}, \code{\link{drop.tip}}, \code{\link{nodelabels}}, \code{\link{identify.phylo}} } \examples{ data(bird.orders) plot(root(bird.orders, 1)) plot(root(bird.orders, 1:5)) tr <- root(bird.orders, 1) is.rooted(bird.orders) # yes is.rooted(tr) # no ### This is because the tree has been unrooted first before rerooting. ### You can delete the outgroup... is.rooted(drop.tip(tr, "Struthioniformes")) ### ... or resolve the basal trichotomy in two ways: is.rooted(multi2di(tr)) is.rooted(root(bird.orders, 1, r = TRUE)) ### To keep the basal trichotomy but forcing the tree as rooted: tr$root.edge <- 0 is.rooted(tr) x <- setNames(rmtree(10, 10), LETTERS[1:10]) is.rooted(x) } \keyword{manip} ape/man/bd.time.Rd0000644000175100001440000000616712304607331013432 0ustar hornikusers\name{bd.time} \alias{bd.time} \title{Time-Dependent Birth-Death Models} \description{ This function fits a used-defined time-dependent birth-death model. } \usage{ bd.time(phy, birth, death, BIRTH = NULL, DEATH = NULL, ip, lower, upper, fast = FALSE, boot = 0, trace = 0) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{birth}{either a numeric (if speciation rate is assumed constant), or a (vectorized) function specifying how the birth (speciation) probability changes through time (see details).} \item{death}{id. for extinction probability.} \item{BIRTH}{(optional) a vectorized function giving the primitive of \code{birth}.} \item{DEATH}{id. for \code{death}.} \item{ip}{a numeric vector used as initial values for the estimation procedure. If missing, these values are guessed.} \item{lower, upper}{the lower and upper bounds of the parameters. If missing, these values are guessed too.} \item{fast}{a logical value specifying whether to use faster integration (see details).} \item{boot}{the number of bootstrap replicates to assess the confidence intervals of the parameters. Not run by default.} \item{trace}{an integer value. If non-zero, the fitting procedure is printed every \code{trace} steps. This can be helpful if convergence is particularly slow.} } \details{ Details on how to specify the birth and death functions and their primitives can be found in the help page of \code{\link{yule.time}}. The model is fitted by minimizing the least squares deviation between the observed and the predicted distributions of branching times. These computations rely heavily on numerical integrations. If \code{fast = FALSE}, integrations are done with R's \code{\link[stats]{integrate}} function. If \code{fast = TRUE}, a faster but less accurate function provided in \pkg{ape} is used. If fitting a complex model to a large phylogeny, a strategy might be to first use the latter option, and then to use the estimates as starting values with \code{fast = FALSE}. } \value{ A list with the following components: \itemize{ \item{par}{a vector of estimates with names taken from the parameters in the specified functions.} \item{SS}{the minimized sum of squares.} \item{convergence}{output convergence criterion from \code{\link[stats]{nlminb}}.} \item{message}{id.} \item{iterations}{id.} \item{evaluations}{id.} }} \references{ Paradis, E. (2011) Time-dependent speciation and extinction from phylogenies: a least squares approach. \emph{Evolution}, \bold{65}, 661--672. } \author{Emmanuel Paradis} \seealso{ \code{\link{ltt.plot}}, \code{\link{birthdeath}}, \code{\link{yule.time}}, \code{\link{LTT}} } \examples{ set.seed(3) tr <- rbdtree(0.1, 0.02) bd.time(tr, 0, 0) # fits a simple BD model bd.time(tr, 0, 0, ip = c(.1, .01)) # 'ip' is useful here ## the classic logistic: birth.logis <- function(a, b) 1/(1 + exp(-a*t - b)) \dontrun{ bd.time(tr, birth.logis, 0, ip = c(0, -2, 0.01)) ## slow to get: ## $par ## a b death ## -0.003486961 -1.995983179 0.016496454 ## ## $SS ## [1] 20.73023 } } \keyword{models} ape/man/corphylo.Rd0000644000175100001440000003123412521453003013734 0ustar hornikusers\name{corphylo} \alias{corphylo} \alias{print.corphylo} \title{Correlations among Multiple Traits with Phylogenetic Signal} \description{ This function calculates Pearson correlation coefficients for multiple continuous traits that may have phylogenetic signal, allowing users to specify measurement error as the standard error of trait values at the tips of the phylogenetic tree. Phylogenetic signal for each trait is estimated from the data assuming that trait evolution is given by a Ornstein-Uhlenbeck process. Thus, the function allows the estimation of phylogenetic signal in multiple traits while incorporating correlations among traits. It is also possible to include independent variables (covariates) for each trait to remove possible confounding effects. corphylo() returns the correlation matrix for trait values, estimates of phylogenetic signal for each trait, and regression coefficients for independent variables affecting each trait. } \usage{ corphylo(X, U = list(), SeM = NULL, phy = NULL, REML = TRUE, method = c("Nelder-Mead", "SANN"), constrain.d = FALSE, reltol = 10^-6, maxit.NM = 1000, maxit.SA = 1000, temp.SA = 1, tmax.SA = 1, verbose = FALSE) \method{print}{corphylo}(x, digits = max(3, getOption("digits") - 3), ...) } \arguments{ \item{X}{a n x p matrix with p columns containing the values for the n taxa. Rows of X should have rownames matching the taxon names in phy.} \item{U}{a list of p matrices corresponding to the p columns of X, with each matrix containing independent variables for the corresponding column of X. The rownames of each matrix within U must be the same as X, or alternatively, the order of values in rows must match those in X. If U is omitted, only the mean (aka intercept) for each column of X is estimated. If U[[i]] is NULL, only an intercept is estimated for X[, i]. If all values of U[[i]][j] are the same, this variable is automatically dropped from the analysis (i.e., there is no offset in the regression component of the model).} \item{SeM}{a n x p matrix with p columns containing standard errors of the trait values in X. The rownames of SeM must be the same as X, or alternatively, the order of values in rows must match those in X. If SeM is omitted, the trait values are assumed to be known without error. If only some traits have mesurement errors, the remaining traits can be given zero-valued standard errors.} \item{phy}{a phylo object giving the phylogenetic tree. The rownames of phy must be the same as X, or alternatively, the order of values in rows must match those in X.} \item{REML}{whether REML or ML is used for model fitting.} \item{method}{in optim(), either Nelder-Mead simplex minimization or SANN (simulated annealing) minimization is used. If SANN is used, it is followed by Nelder-Mead minimization.} \item{constrain.d}{if constrain.d is TRUE, the estimates of d are constrained to be between zero and 1. This can make estimation more stable and can be tried if convergence is problematic. This does not necessarily lead to loss of generality of the results, because before using corphylo, branch lengths of phy can be transformed so that the "starter" tree has strong phylogenetic signal.} \item{reltol}{a control parameter dictating the relative tolerance for convergence in the optimization; see optim().} \item{maxit.NM}{a control parameter dictating the maximum number of iterations in the optimization with Nelder-Mead minimization; see optim().} \item{maxit.SA}{a control parameter dictating the maximum number of iterations in the optimization with SANN minimization; see optim().} \item{temp.SA}{a control parameter dictating the starting temperature in the optimization with SANN minimization; see optim().} \item{tmax.SA}{a control parameter dictating the number of function evaluations at each temperature in the optimization with SANN minimization; see optim().} \item{verbose}{if TRUE, the model logLik and running estimates of the correlation coefficients and values of d are printed each iteration during optimization.} \item{x}{an objects of class corphylo.} \item{digits}{the number of digits to be printed.} \item{\dots}{arguments passed to and from other methods.} } \details{ For the case of two variables, the function estimates parameters for the model of the form, for example, \deqn{X[1] = B[1,0] + B[1,1] * u[1,1] + \epsilon[1]} \deqn{X[2] = B[2,0] + B[2,1] * u[2,1] + \epsilon[2]} \deqn{\epsilon ~ Gaussian(0, V) } where \eqn{B[1,0]}, \eqn{B[1,1]}, \eqn{B[2,0]}, and \eqn{B[2,1]} are regression coefficients, and \eqn{V} is a variance-covariance matrix containing the correlation coefficient r, parameters of the OU process \eqn{d1} and \eqn{d2}, and diagonal matrices \eqn{M1} and \eqn{M2} of measurement standard errors for \eqn{X[1]} and \eqn{X[2]}. The matrix \eqn{V} is \eqn{2n x 2n}, with \eqn{n x n} blocks given by \deqn{V[1,1] = C[1,1](d1) + M1} \deqn{V[1,2] = C[1,2](d1,d2)} \deqn{V[2,1] = C[2,1](d1,d2)} \deqn{V[2,2] = C[2,2](d2) + M2} where \eqn{C[i,j](d1,d2)} are derived from phy under the assumption of joint OU evolutionary processes for each trait (see Zheng et al. 2009). This formulation extends in the obvious way to more than two traits. } \value{ An object of class "corphylo". \item{cor.matrix}{the p x p matrix of correlation coefficients.} \item{d}{values of d from the OU process for each trait.} \item{B}{estimates of the regression coefficients, including intercepts. Coefficients are named according to the list U. For example, B1.2 is the coefficient corresponding to U[[1]][, 2], and if column 2 in U[[1]] is named "colname2", then the coefficient will be B1.colname2. Intercepts have the form B1.0.} \item{B.se}{standard errors of the regression coefficients.} \item{B.cov}{covariance matrix for regression coefficients.} \item{B.zscore}{Z scores for the regression coefficients.} \item{B.pvalue}{tests for the regression coefficients being different from zero.} \item{logLik}{he log likelihood for either the restricted likelihood (REML = TRUE) or the overall likelihood (REML = FALSE).} \item{AIC}{AIC for either the restricted likelihood (REML = TRUE) or the overall likelihood (REML = FALSE).} \item{BIC}{BIC for either the restricted likelihood (REML = TRUE) or the overall likelihood (REML = FALSE).} \item{REML}{whether REML is used rather than ML (TRUE or FALSE).} \item{constrain.d}{whether or not values of d were constrained to be between 0 and 1 (TRUE or FALSE).} \item{XX}{values of X in vectorized form, with each trait X[, i] standardized to have mean zero and standard deviation one.} \item{UU}{design matrix with values in UU corresponding to XX; each variable U[[i]][, j] is standardized to have mean zero and standard deviation one.} \item{MM}{vector of measurement standard errors corresponding to XX, with the standard errors suitably standardized.} \item{Vphy}{the phylogenetic covariance matrix computed from phy and standardized to have determinant equal to one.} \item{R}{covariance matrix of trait values relative to the standardized values of XX.} \item{V}{overall estimated covariance matrix of residuals for XX including trait correlations, phylogenetic signal, and measurement error variances. This matrix can be used to simulate data for parametric bootstrapping. See examples.} \item{C}{matrix V excluding measurement error variances.} \item{convcode}{he convergence code provided by optim().} \item{niter}{number of iterations performed by optim().} } \author{Anthony R. Ives} \references{ Zheng, L., A. R. Ives, T. Garland, B. R. Larget, Y. Yu, and K. F. Cao. 2009. New multivariate tests for phylogenetic signal and trait correlations applied to ecophysiological phenotypes of nine \emph{Manglietia} species. \emph{Functional Ecology} \bold{23}:1059--1069. } \examples{ ## Simple example using data without correlations or phylogenetic ## signal. This illustrates the structure of the input data. phy <- rcoal(10, tip.label = 1:10) X <- matrix(rnorm(20), nrow = 10, ncol = 2) rownames(X) <- phy$tip.label U <- list(NULL, matrix(rnorm(10, mean = 10, sd = 4), nrow = 10, ncol = 1)) rownames(U[[2]]) <- phy$tip.label SeM <- matrix(c(0.2, 0.4), nrow = 10, ncol = 2) rownames(SeM) <- phy$tip.label corphylo(X = X, SeM = SeM, U = U, phy = phy, method = "Nelder-Mead") \dontrun{ ## Simulation example for the correlation between two variables. The ## example compares the estimates of the correlation coefficients from ## corphylo when measurement error is incorporated into the analyses with ## three other cases: (i) when measurement error is excluded, (ii) when ## phylogenetic signal is ignored (assuming a "star" phylogeny), and (iii) ## neither measurement error nor phylogenetic signal are included. ## In the simulations, variable 2 is associated with a single ## independent variable. This requires setting up a list U that has 2 ## elements: element U[[1]] is NULL and element U[[2]] is a n x 1 vector ## containing simulated values of the independent variable. # Set up parameter values for simulating data n <- 50 phy <- rcoal(n, tip.label = 1:n) R <- matrix(c(1, 0.7, 0.7, 1), nrow = 2, ncol = 2) d <- c(0.3, .95) B2 <- 1 Se <- c(0.2, 1) SeM <- matrix(Se, nrow = n, ncol = 2, byrow = T) rownames(SeM) <- phy$tip.label # Set up needed matrices for the simulations p <- length(d) star <- stree(n) star$edge.length <- array(1, dim = c(n, 1)) star$tip.label <- phy$tip.label Vphy <- vcv(phy) Vphy <- Vphy/max(Vphy) Vphy <- Vphy/exp(determinant(Vphy)$modulus[1]/n) tau <- matrix(1, nrow = n, ncol = 1) %*% diag(Vphy) - Vphy C <- matrix(0, nrow = p * n, ncol = p * n) for (i in 1:p) for (j in 1:p) { Cd <- (d[i]^tau * (d[j]^t(tau)) * (1 - (d[i] * d[j])^Vphy))/(1 - d[i] * d[j]) C[(n * (i - 1) + 1):(i * n), (n * (j - 1) + 1):(j * n)] <- R[i, j] * Cd } MM <- matrix(SeM^2, ncol = 1) V <- C + diag(as.numeric(MM)) ## Perform a Cholesky decomposition of Vphy. This is used to generate ## phylogenetic signal: a vector of independent normal random variables, ## when multiplied by the transpose of the Cholesky deposition of Vphy will ## have covariance matrix equal to Vphy. iD <- t(chol(V)) # Perform Nrep simulations and collect the results Nrep <- 100 cor.list <- matrix(0, nrow = Nrep, ncol = 1) cor.noM.list <- matrix(0, nrow = Nrep, ncol = 1) cor.noP.list <- matrix(0, nrow = Nrep, ncol = 1) cor.noMP.list <- matrix(0, nrow = Nrep, ncol = 1) d.list <- matrix(0, nrow = Nrep, ncol = 2) d.noM.list <- matrix(0, nrow = Nrep, ncol = 2) B.list <- matrix(0, nrow = Nrep, ncol = 3) B.noM.list <- matrix(0, nrow = Nrep, ncol = 3) B.noP.list <- matrix(0, nrow = Nrep, ncol = 3) for (rep in 1:Nrep) { XX <- iD %*% rnorm(2 * n) X <- matrix(XX, nrow = n, ncol = 2) rownames(X) <- phy$tip.label U <- list(NULL, matrix(rnorm(n, mean = 2, sd = 10), nrow = n, ncol = 1)) rownames(U[[2]]) <- phy$tip.label colnames(U[[2]]) <- "V1" X[,2] <- X[,2] + B2[1] * U[[2]][,1] - B2[1] * mean(U[[2]][,1]) z <- corphylo(X = X, SeM = SeM, U = U, phy = phy, method = "Nelder-Mead") z.noM <- corphylo(X = X, U = U, phy = phy, method = "Nelder-Mead") z.noP <- corphylo(X = X, SeM = SeM, U = U, phy = star, method = "Nelder-Mead") cor.list[rep] <- z$cor.matrix[1, 2] cor.noM.list[rep] <- z.noM$cor.matrix[1, 2] cor.noP.list[rep] <- z.noP$cor.matrix[1, 2] cor.noMP.list[rep] <- cor(cbind(lm(X[,1] ~ 1)$residuals, lm(X[,2] ~ U[[2]])$residuals))[1,2] d.list[rep, ] <- z$d d.noM.list[rep, ] <- z.noM$d B.list[rep, ] <- z$B B.noM.list[rep, ] <- z.noM$B B.noP.list[rep, ] <- z.noP$B show(c(rep, z$convcode, z$cor.matrix[1, 2], z$d)) } correlation <- rbind(R[1, 2], mean(cor.list), mean(cor.noM.list), mean(cor.noP.list), mean(cor.noMP.list)) rownames(correlation) <- c("True", "With SeM and Phy", "Without SeM", "Without Phy", "Without Phy or SeM") correlation signal.d <- rbind(d, colMeans(d.list), colMeans(d.noM.list)) rownames(signal.d) <- c("True", "With SeM and Phy", "Without SeM") signal.d est.B <- rbind(c(0, 0, B2), colMeans(B.list), colMeans(B.noM.list), colMeans(B.noP.list)) rownames(est.B) <- c("True", "With SeM and Phy", "Without SeM", "Without Phy") colnames(est.B) <- rownames(z$B) est.B # Example simulation output # correlation # [,1] # True 0.7000000 # With SeM and Phy 0.7055958 # Without SeM 0.3125253 # Without Phy 0.4054043 # Without Phy or SeM 0.3476589 # signal.d # [,1] [,2] # True 0.300000 0.9500000 # With SeM and Phy 0.301513 0.9276663 # Without SeM 0.241319 0.4872675 # est.B # B1.0 B2.0 B2.V1 # True 0.00000000 0.0000000 1.0000000 # With SeM and Phy -0.01285834 0.2807215 0.9963163 # Without SeM 0.01406953 0.3059110 0.9977796 # Without Phy 0.02139281 0.3165731 0.9942140 }} \keyword{regression} ape/man/birthdeath.Rd0000644000175100001440000000526411447700412014224 0ustar hornikusers\name{birthdeath} \alias{birthdeath} \alias{print.birthdeath} \title{Estimation of Speciation and Extinction Rates With Birth-Death Models} \usage{ birthdeath(phy) \method{print}{birthdeath}(x, ...) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{x}{an object of class \code{"birthdeath"}.} \item{\dots}{further arguments passed to the \code{print} function.} } \description{ This function fits by maximum likelihood a birth-death model to the branching times computed from a phylogenetic tree using the method of Nee et al. (1994). } \details{ Nee et al. (1994) used a re-parametrization of the birth-death model studied by Kendall (1948) so that the likelihood has to be maximized over \emph{d/b} and \emph{b - d}, where \emph{b} is the birth rate, and \emph{d} the death rate. This is the approach used by the present function. This function computes the standard-errors of the estimated parameters using a normal approximations of the maximum likelihood estimates: this is likely to be inaccurate because of asymmetries of the likelihood function (Nee et al. 1995). In addition, 95 % confidence intervals of both parameters are computed using profile likelihood: they are particularly useful if the estimate of \emph{d/b} is at the boundary of the parameter space (i.e. 0, which is often the case). Note that the function does not check that the tree is effectively ultrametric, so if it is not, the returned result may not be meaningful. } \value{ An object of class \code{"birthdeath"} which is a list with the following components: \item{tree}{the name of the tree analysed.} \item{N}{the number of species.} \item{dev}{the deviance (= -2 log lik) at its minimum.} \item{para}{the estimated parameters.} \item{se}{the corresponding standard-errors.} \item{CI}{the 95\% profile-likelihood confidence intervals.} } \references{ Kendall, D. G. (1948) On the generalized ``birth-and-death'' process. \emph{Annals of Mathematical Statistics}, \bold{19}, 1--15. Nee, S., May, R. M. and Harvey, P. H. (1994) The reconstructed evolutionary process. \emph{Philosophical Transactions of the Royal Society of London. Series B. Biological Sciences}, \bold{344}, 305--311. Nee, S., Holmes, E. C., May, R. M. and Harvey, P. H. (1995) Estimating extinctions from molecular phylogenies. in \emph{Extinction Rates}, eds. Lawton, J. H. and May, R. M., pp. 164--182, Oxford University Press. } \author{Emmanuel Paradis} \seealso{ \code{\link{branching.times}}, \code{\link{diversi.gof}}, \code{\link{diversi.time}}, \code{\link{ltt.plot}}, \code{\link{yule}}, \code{\link{bd.ext}}, \code{\link{yule.cov}}, \code{\link{bd.time}} } \keyword{models} ape/man/compar.ou.Rd0000644000175100001440000001054411464463161014014 0ustar hornikusers\name{compar.ou} \alias{compar.ou} \title{Ornstein--Uhlenbeck Model for Continuous Characters} \usage{ compar.ou(x, phy, node = NULL, alpha = NULL) } \arguments{ \item{x}{a numeric vector giving the values of a continuous character.} \item{phy}{an object of class \code{"phylo"}.} \item{node}{a vector giving the number(s) of the node(s) where the parameter `theta' (the trait optimum) is assumed to change. The node(s) can be specified with their labels if \code{phy} has node labels. By default there is no change (same optimum thoughout lineages).} \item{alpha}{the value of \eqn{\alpha}{alpha} to be used when fitting the model. By default, this parameter is estimated (see details).} } \description{ This function fits an Ornstein--Uhlenbeck model giving a phylogenetic tree, and a continuous character. The user specifies the node(s) where the optimum changes. The parameters are estimated by maximum likelihood; their standard-errors are computed assuming normality of these estimates. } \details{ The Ornstein--Uhlenbeck (OU) process can be seen as a generalization of the Brownian motion process. In the latter, characters are assumed to evolve randomly under a random walk, that is change is equally likely in any direction. In the OU model, change is more likely towards the direction of an optimum (denoted \eqn{\theta}{theta}) with a strength controlled by a parameter denoted \eqn{\alpha}{alpha}. The present function fits a model where the optimum parameter \eqn{\theta}{theta}, is allowed to vary throughout the tree. This is specified with the argument \code{node}: \eqn{\theta}{theta} changes after each node whose number is given there. Note that the optimum changes \emph{only} for the lineages which are descendants of this node. Hansen (1997) recommends to not estimate \eqn{\alpha}{alpha} together with the other parameters. The present function allows this by giving a numeric value to the argument \code{alpha}. By default, this parameter is estimated, but this seems to yield very large standard-errors, thus validating Hansen's recommendation. In practice, a ``poor man estimation'' of \eqn{\alpha}{alpha} can be done by repeating the function call with different values of \code{alpha}, and selecting the one that minimizes the deviance (see Hansen 1997 for an example). If \code{x} has names, its values are matched to the tip labels of \code{phy}, otherwise its values are taken to be in the same order than the tip labels of \code{phy}. The user must be careful here since the function requires that both series of names perfectly match, so this operation may fail if there is a typing or syntax error. If both series of names do not match, the values in the \code{x} are taken to be in the same order than the tip labels of \code{phy}, and a warning message is issued. } \note{ The inversion of the variance-covariance matrix in the likelihood function appeared as somehow problematic. The present implementation uses a Cholevski decomposition with the function \code{\link[base]{chol2inv}} instead of the usual function \code{\link[base]{solve}}. } \value{ an object of class \code{"compar.ou"} which is list with the following components: \item{deviance}{the deviance (= -2 * loglik).} \item{para}{a data frame with the maximum likelihood estimates and their standard-errors.} \item{call}{the function call.} } \references{ Hansen, T. F. (1997) Stabilizing selection and the comparative analysis of adaptation. \emph{Evolution}, \bold{51}, 1341--1351. } \author{Emmanuel Paradis} \seealso{ \code{\link{ace}}, \code{\link{compar.lynch}}, \code{\link{corBrownian}}, \code{\link{corMartins}}, \code{\link{pic}} } \examples{ data(bird.orders) ### This is likely to give you estimates close to 0, 1, and 0 ### for alpha, sigma^2, and theta, respectively: compar.ou(x <- rnorm(23), bird.orders) ### Much better with a fixed alpha: compar.ou(x, bird.orders, alpha = 0.1) ### Let us 'mimick' the effect of different optima ### for the two clades of birds... x <- c(rnorm(5, 0), rnorm(18, 5)) ### ... the model with two optima: compar.ou(x, bird.orders, node = 25, alpha = .1) ### ... and the model with a single optimum: compar.ou(x, bird.orders, node = NULL, alpha = .1) ### => Compare both models with the difference in deviances ## which follows a chi^2 with df = 1. } \keyword{models} ape/man/multiphylo.Rd0000644000175100001440000000374011376672124014322 0ustar hornikusers\name{multiphylo} \alias{multiphylo} \alias{[.multiPhylo} \alias{[[.multiPhylo} \alias{$.multiPhylo} \alias{[<-.multiPhylo} \alias{[[<-.multiPhylo} \alias{$<-.multiPhylo} \title{Manipulating Lists of Trees} \description{ These are extraction and replacement operators for lists of trees stored in the class \code{"multiPhylo"}. } \usage{ \method{[}{multiPhylo}(x, i) \method{[[}{multiPhylo}(x, i) \method{$}{multiPhylo}(x, name) \method{[}{multiPhylo}(x, ...) <- value \method{[[}{multiPhylo}(x, ...) <- value \method{$}{multiPhylo}(x, ...) <- value } \arguments{ \item{x, value}{an object of class \code{"phylo"} or \code{"multiPhylo"}.} \item{i}{index(ices) of the tree(s) to select from a list; this may be a vector of integers, logicals, or names.} \item{name}{a character string specifying the tree to be extracted.} \item{\dots}{index(ices) of the tree(s) to replace; this may be a vector of integers, logicals, or names.} } \details{ The subsetting operator \code{[} keeps the class correctly (\code{"multiPhylo"}). The replacement operators check the labels of \code{value} if \code{x} has a single vector of tip labels for all trees (see examples). } \value{ An object of class \code{"phylo"} (\code{[[}, \code{$}) or of class \code{"multiPhylo"} (\code{[} and the replacement operators). } \author{Emmanuel Paradis} \seealso{ \code{\link{summary.phylo}}, \code{\link{c.phylo}} } \examples{ x <- rmtree(10, 20) names(x) <- paste("tree", 1:10, sep = "") x[1:5] x[1] # subsetting x[[1]] # extraction x$tree1 # same than above x[[1]] <- rtree(20) y <- .compressTipLabel(x) ## up to here 'x' and 'y' have exactly the same information ## but 'y' has a unique vector of tip labels for all the trees x[[1]] <- rtree(10) # no error try(y[[1]] <- rtree(10)) # error try(x[1] <- rtree(20)) # error ## use instead one of the two: x[1] <- list(rtree(20)) x[1] <- c(rtree(20)) x[1:5] <- rmtree(5, 20) # replacement x[11:20] <- rmtree(10, 20) # elongation x # 20 trees } \keyword{manip} ape/man/summary.phylo.Rd0000644000175100001440000000405513002702310014716 0ustar hornikusers\name{summary.phylo} \alias{summary.phylo} \alias{Ntip} \alias{Ntip.phylo} \alias{Ntip.multiPhylo} \alias{Nnode} \alias{Nnode.phylo} \alias{Nnode.multiPhylo} \alias{Nedge} \alias{Nedge.phylo} \alias{Nedge.multiPhylo} \title{Print Summary of a Phylogeny} \usage{ \method{summary}{phylo}(object, \dots) Ntip(phy) \method{Ntip}{phylo}(phy) \method{Ntip}{multiPhylo}(phy) Nnode(phy, ...) \method{Nnode}{phylo}(phy, internal.only = TRUE, ...) \method{Nnode}{multiPhylo}(phy, internal.only = TRUE, ...) Nedge(phy) \method{Nedge}{phylo}(phy) \method{Nedge}{multiPhylo}(phy) } \arguments{ \item{object, phy}{an object of class \code{"phylo"} or \code{"multiPhylo"}.} \item{\dots}{further arguments passed to or from other methods.} \item{internal.only}{a logical indicating whether to return the number of internal nodes only (the default), or of internal and terminal (tips) nodes (if \code{FALSE}).} } \description{ The first function prints a compact summary of a phylogenetic tree (an object of class \code{"phylo"}). The three other functions return the number of tips, nodes, or edges, respectively. } \details{ The summary includes the numbers of tips and of nodes, summary statistics of the branch lengths (if they are available) with mean, variance, minimum, first quartile, median, third quartile, and maximum, listing of the first ten tip labels, and (if available) of the first ten node labels. It is also printed whether some of these optional elements (branch lengths, node labels, and root edge) are not found in the tree. \code{summary} simply prints its results on the standard output and is not meant for programming. } \value{ A NULL value in the case of \code{summary}, a single numeric value for the three other functions. } \author{Emmanuel Paradis} \seealso{ \code{\link{read.tree}}, \code{\link[base]{summary}} for the generic R function, \code{\link{multiphylo}}, \code{\link{c.phylo}} } \examples{ data(bird.families) summary(bird.families) Ntip(bird.families) Nnode(bird.families) Nedge(bird.families) } \keyword{manip} ape/man/alview.Rd0000644000175100001440000000230413016363735013374 0ustar hornikusers\name{alview} \alias{alview} \title{Print DNA or AA Sequence Alignement} \description{ This function displays in the console or a file an alignment of DNA or AAsequences. The first sequence is printed on the first row and the bases of the other sequences are replaced by dots if they are identical with the first sequence. } \usage{ alview(x, file = "", uppercase = TRUE) } \arguments{ \item{x}{a matrix or a list of DNA sequences (class \code{"DNAbin"}) or a matrix of AA sequences (class \code{"AAbin"}).} \item{file}{a character string giving the name of the file where to print the sequences; by default, they are printed in the console.} \item{uppercase}{a logical specifying whether to print the bases as uppercase letters.} } \details{ The first line of the output shows the position of the last column of the printed alignment. } \author{Emmanuel Paradis} \seealso{ \code{\link{DNAbin}}, \code{\link{image.DNAbin}}, \code{\link{alex}}, \code{\link{clustal}}, \code{\link{checkAlignment}}, \code{\link{all.equal.DNAbin}} } \examples{ data(woodmouse) alview(woodmouse[, 1:50]) alview(woodmouse[, 1:50], uppercase = FALSE) \dontrun{ alview(woodmouse, file = "woodmouse.txt") } } \keyword{IO} ape/man/diversi.gof.Rd0000644000175100001440000000571412432116064014324 0ustar hornikusers\encoding{utf8} \name{diversi.gof} \alias{diversi.gof} \title{Tests of Constant Diversification Rates} \usage{ diversi.gof(x, null = "exponential", z = NULL) } \arguments{ \item{x}{a numeric vector with the branching times.} \item{null}{a character string specifying the null distribution for the branching times. Only two choices are possible: either \code{"exponential"}, or \code{"user"}.} \item{z}{used if \code{null = "user"}; gives the expected distribution under the model.} } \description{ This function computes two tests of the distribution of branching times using the \enc{Cramér}{Cramer}--von Mises and Anderson--Darling goodness-of-fit tests. By default, it is assumed that the diversification rate is constant, and an exponential distribution is assumed for the branching times. In this case, the expected distribution under this model is computed with a rate estimated from the data. Alternatively, the user may specify an expected cumulative density function (\code{z}): in this case, \code{x} and \code{z} must be of the same length. See the examples for how to compute the latter from a sample of expected branching times. } \details{ The \enc{Cramér}{Cramer}--von Mises and Anderson--Darling tests compare the empirical density function (EDF) of the observations to an expected cumulative density function. By contrast to the Kolmogorov--Smirnov test where the greatest difference between these two functions is used, in both tests all differences are taken into account. The distributions of both test statistics depend on the null hypothesis, and on whether or not some parameters were estimated from the data. However, these distributions are not known precisely and critical values were determined by Stephens (1974) using simulations. These critical values were used for the present function. } \value{ A NULL value is returned, the results are simply printed. } \references{ Paradis, E. (1998) Testing for constant diversification rates using molecular phylogenies: a general approach based on statistical tests for goodness of fit. \emph{Molecular Biology and Evolution}, \bold{15}, 476--479. Stephens, M. A. (1974) EDF statistics for goodness of fit and some comparisons. \emph{Journal of the American Statistical Association}, \bold{69}, 730--737. } \author{Emmanuel Paradis} \seealso{ \code{\link{branching.times}}, \code{\link{diversi.time}} \code{\link{ltt.plot}}, \code{\link{birthdeath}}, \code{\link{yule}}, \code{\link{yule.cov}} } \examples{ data(bird.families) x <- branching.times(bird.families) ### suppose we have a sample of expected branching times `y'; ### for simplicity, take them from a uniform distribution: y <- runif(500, 0, max(x) + 1) # + 1 to avoid A2 = Inf ### now compute the expected cumulative distribution: x <- sort(x) N <- length(x) ecdf <- numeric(N) for (i in 1:N) ecdf[i] <- sum(y <= x[i])/500 ### finally do the test: diversi.gof(x, "user", z = ecdf) } \keyword{univar} ape/man/mvr.Rd0000644000175100001440000000225311736034467012720 0ustar hornikusers\name{mvr} \alias{mvr} \alias{mvrs} \title{Minimum Variance Reduction} \description{ Phylogenetic tree construction based on the minimum variance reduction. } \usage{ mvr(X, V) mvrs(X, V, fs = 15) } \arguments{ \item{X}{a distance matrix.} \item{V}{a variance matrix.} \item{fs}{agglomeration criterion parameter: it is coerced as an integer and must at least equal to one.} } \details{ The MVR method can be seen as a version of BIONJ which is not restricted to the Poison model of variance (Gascuel 2000). } \value{ an object of class \code{"phylo"}. } \references{ Criscuolo, A. and Gascuel, O. (2008). Fast NJ-like algorithms to deal with incomplete distance matrices. \emph{BMC Bioinformatics}, 9. Gascuel, O. (2000). Data model and classification by trees: the minimum variance reduction (MVR) method. \emph{Journal of Classification}, \bold{17}, 67--99. } \author{Andrei Popescu \email{niteloserpopescu@gmail.com}} \seealso{ \code{\link{bionj}}, \code{\link{fastme}}, \code{\link{njs}}, \code{\link{SDM}} } \examples{ data(woodmouse) rt <- dist.dna(woodmouse, variance = TRUE) v <- attr(rt, "variance") tr <- mvr(rt, v) plot(tr, "u") } \keyword{models} ape/man/consensus.Rd0000644000175100001440000000265412053361655014134 0ustar hornikusers\name{consensus} \alias{consensus} \title{Concensus Trees} \usage{ consensus(..., p = 1, check.labels = TRUE) } \arguments{ \item{\dots}{either (i) a single object of class \code{"phylo"}, (ii) a series of such objects separated by commas, or (iii) a list containing such objects.} \item{p}{a numeric value between 0.5 and 1 giving the proportion for a clade to be represented in the consensus tree.} \item{check.labels}{a logical specifying whether to check the labels of each tree. If \code{FALSE} (the default), it is assumed that all trees have the same tip labels, and that they are in the same order (see details).} } \description{ Given a series of trees, this function returns the consensus tree. By default, the strict-consensus tree is computed. To get the majority-rule consensus tree, use \code{p = 0.5}. Any value between 0.5 and 1 can be used. } \details{ Using \code{check.labels = FALSE} results in considerable decrease in computing times. This requires that all trees have the same tip labels, \emph{and} these labels are ordered similarly in all trees (in other words, the element \code{tip.label} are identical in all trees). } \value{ an object of class \code{"phylo"}. } \references{ Felsenstein, J. (2004) \emph{Inferring Phylogenies}. Sunderland: Sinauer Associates. } \author{Emmanuel Paradis} \seealso{ \code{\link{prop.part}}, \code{\link{dist.topo}} } \keyword{manip} ape/man/matexpo.Rd0000644000175100001440000000101511353106652013553 0ustar hornikusers\name{matexpo} \alias{matexpo} \title{Matrix Exponential} \usage{ matexpo(x) } \arguments{ \item{x}{a square matrix of mode numeric.} } \description{ This function computes the exponential of a square matrix using a spectral decomposition. } \value{ a numeric matrix of the same dimensions than `x'. } \author{Emmanuel Paradis} \examples{ ### a simple rate matrix: m <- matrix(0.1, 4, 4) diag(m) <- -0.3 ### towards equilibrium: for (t in c(1, 5, 10, 50)) print(matexpo(m*t)) } \keyword{array} \keyword{multivariate} ape/man/diversi.time.Rd0000644000175100001440000000520211353106443014500 0ustar hornikusers\name{diversi.time} \alias{diversi.time} \title{Analysis of Diversification with Survival Models} \usage{ diversi.time(x, census = NULL, censoring.codes = c(1, 0), Tc = NULL) } \arguments{ \item{x}{a numeric vector with the branching times.} \item{census}{a vector of the same length than `x' used as an indicator variable; thus, it must have only two values, one coding for accurately known branching times, and the other for censored branching times. This argument can be of any mode (numeric, character, logical), or can even be a factor.} \item{censoring.codes}{a vector of length two giving the codes used for \code{census}: by default 1 (accurately known times) and 0 (censored times). The mode must be the same than the one of \code{census}.} \item{Tc}{a single numeric value specifying the break-point time to fit Model C. If none is provided, then it is set arbitrarily to the mean of the analysed branching times.} } \description{ This functions fits survival models to a set of branching times, some of them may be known approximately (censored). Three models are fitted, Model A assuming constant diversification, Model B assuming that diversification follows a Weibull law, and Model C assuming that diversification changes with a breakpoint at time `Tc'. The models are fitted by maximum likelihood. } \details{ The principle of the method is to consider each branching time as an event: if the branching time is accurately known, then it is a failure event; if it is approximately knwon then it is a censoring event. An analogy is thus made between the failure (or hazard) rate estimated by the survival models and the diversification rate of the lineage. Time is here considered from present to past. Model B assumes a monotonically changing diversification rate. The parameter that controls the change of this rate is called beta. If beta is greater than one, then the diversification rate decreases through time; if it is lesser than one, the the rate increases through time. If beta is equal to one, then Model B reduces to Model A. } \value{ A NULL value is returned, the results are simply printed. } \references{ Paradis, E. (1997) Assessing temporal variations in diversification rates from phylogenies: estimation and hypothesis testing. \emph{Proceedings of the Royal Society of London. Series B. Biological Sciences}, \bold{264}, 1141--1147. } \author{Emmanuel Paradis} \seealso{ \code{\link{branching.times}}, \code{\link{diversi.gof}} \code{\link{ltt.plot}}, \code{\link{birthdeath}}, \code{\link{bd.ext}}, \code{\link{yule}}, \code{\link{yule.cov}} } \keyword{models} ape/man/as.alignment.Rd0000644000175100001440000000567112371474433014500 0ustar hornikusers\name{as.alignment} \alias{as.alignment} \alias{as.DNAbin} \alias{as.DNAbin.character} \alias{as.DNAbin.list} \alias{as.DNAbin.alignment} \alias{as.character.DNAbin} \alias{as.DNAbin.DNAString} \alias{as.DNAbin.DNAStringSet} \alias{as.DNAbin.PairwiseAlignmentsSingleSubject} \alias{as.DNAbin.DNAMultipleAlignment} \title{Conversion Among DNA Sequence Internal Formats} \description{ These functions transform a set of DNA sequences among various internal formats. } \usage{ as.alignment(x) as.DNAbin(x, ...) \method{as.DNAbin}{character}(x, ...) \method{as.DNAbin}{list}(x, ...) \method{as.DNAbin}{alignment}(x, ...) \method{as.DNAbin}{DNAString}(x, ...) \method{as.DNAbin}{DNAStringSet}(x, ...) \method{as.DNAbin}{PairwiseAlignmentsSingleSubject}(x, ...) \method{as.DNAbin}{DNAMultipleAlignment}(x, ...) \method{as.character}{DNAbin}(x, ...) } \arguments{ \item{x}{a matrix or a list containing the DNA sequences, or an object of class \code{"alignment"}.} \item{\dots}{further arguments to be passed to or from other methods.} } \details{ For \code{as.alignment}, the sequences given as argument should be stored as matrices or lists of single-character strings (the format used in \pkg{ape} before version 1.10). The returned object is in the format used in the package \pkg{seqinr} to store aligned sequences. \code{as.DNAbin} is a generic function with methods so that it works with sequences stored into vectors, matrices, or lists. It can convert some S4 classes from the package \pkg{Biostrings} in BioConductor. For consistency within \pkg{ape}, this uses an S3-style syntax. To convert objects of class \code{"DNAStringSetList"}, see the examples. \code{as.character} is a generic function: the present method converts objects of class \code{"DNAbin"} into the format used before \pkg{ape} 1.10 (matrix of single characters, or list of vectors of single characters). This function must be used first to convert objects of class \code{"DNAbin"} into the class \code{"alignment"}. } \value{ an object of class \code{"alignment"} in the case of \code{"as.alignment"}; an object of class \code{"DNAbin"} in the case of \code{"as.DNAbin"}; a matrix of mode character or a list containing vectors of mode character in the case of \code{"as.character"}. } \author{Emmanuel Paradis} \seealso{ \code{\link{DNAbin}}, \code{\link{read.dna}}, \code{\link{read.GenBank}}, \code{\link{write.dna}} } \examples{ data(woodmouse) x <- as.character(woodmouse) x[, 1:20] str(as.alignment(x)) identical(as.DNAbin(x), woodmouse) ### conversion from BioConductor: \dontrun{ if (require(Biostrings)) { data(phiX174Phage) X <- as.DNAbin(phiX174Phage) ## base frequencies: base.freq(X) # from ape alphabetFrequency(phiX174Phage) # from Biostrings ### for objects of class "DNAStringSetList" X <- lapply(x, as.DNAbin) # a list of lists ### to put all sequences in a single list: X <- unlist(X, recursive = FALSE) class(X) <- "DNAbin" } } } \keyword{manip} ape/man/which.edge.Rd0000644000175100001440000000155312344067752014122 0ustar hornikusers\name{which.edge} \alias{which.edge} \title{Identifies Edges of a Tree} \description{ This function identifies the edges that belong to a group (possibly non-monophyletic) specified as a set of tips. } \usage{ which.edge(phy, group) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{group}{a vector of mode numeric or character specifying the tips for which the edges are to be identified.} } \details{ The group of tips specified in `group' may be non-monophyletic (paraphyletic or polyphyletic), in which case all edges from the tips to their most recent common ancestor are identified. The identification is made with the indices of the rows of the matrix `edge' of the tree. } \value{ a numeric vector. } \author{Emmanuel Paradis} \seealso{ \code{\link{bind.tree}}, \code{\link{drop.tip}}, \code{\link{root}} } \keyword{manip} ape/man/rtree.Rd0000644000175100001440000000465711767763614013256 0ustar hornikusers\name{rtree} \alias{rtree} \alias{rcoal} \alias{rmtree} \title{Generates Random Trees} \description{ These functions generate trees by splitting randomly the edges (\code{rtree}) or randomly clustering the tips (\code{rcoal}). \code{rtree} generates general trees, and \code{rcoal} generates coalescent trees. The algorithms are described in Paradis (2012). } \usage{ rtree(n, rooted = TRUE, tip.label = NULL, br = runif, ...) rcoal(n, tip.label = NULL, br = "coalescent", ...) rmtree(N, n, rooted = TRUE, tip.label = NULL, br = runif, ...) } \arguments{ \item{n}{an integer giving the number of tips in the tree.} \item{rooted}{a logical indicating whether the tree should be rooted (the default).} \item{tip.label}{a character vector giving the tip labels; if not specified, the tips "t1", "t2", ..., are given.} \item{br}{one of the following: (i) an \R function used to generate the branch lengths (\code{rtree}; use \code{NULL} to simulate only a topology), or the coalescence times (\code{rcoal}); (ii) a character to simulate a genuine coalescent tree for \code{rcoal} (the default); or (iii) a numeric vector for the branch lengths or the coalescence times.} \item{\dots}{further argument(s) to be passed to \code{br}.} \item{N}{an integer giving the number of trees to generate.} } \details{ The trees generated are bifurcating. If \code{rooted = FALSE} in (\code{rtree}), the tree is trifurcating at its root. The default function to generate branch lengths in \code{rtree} is \code{runif}. If further arguments are passed to \code{br}, they need to be tagged (e.g., \code{min = 0, max = 10}). \code{rmtree} calls successively \code{rtree} and set the class of the returned object appropriately. } \value{ An object of class \code{"phylo"} or of class \code{"multiPhylo"} in the case of \code{rmtree}. } \references{ Paradis, E. (2012) \emph{Analysis of Phylogenetics and Evolution with R (Second Edition).} New York: Springer. } \author{Emmanuel Paradis} \seealso{ \code{\link{stree}}, \code{\link{rlineage}} } \examples{ layout(matrix(1:9, 3, 3)) ### Nine random trees: for (i in 1:9) plot(rtree(20)) ### Nine random cladograms: for (i in 1:9) plot(rtree(20, FALSE), type = "c") ### generate 4 random trees of bird orders: data(bird.orders) layout(matrix(1:4, 2, 2)) for (i in 1:4) plot(rcoal(23, tip.label = bird.orders$tip.label), no.margin = TRUE) layout(matrix(1)) } \keyword{datagen} ape/man/identify.phylo.Rd0000644000175100001440000000410611542334454015052 0ustar hornikusers\name{identify.phylo} \alias{identify.phylo} \title{Graphical Identification of Nodes and Tips} \usage{ \method{identify}{phylo}(x, nodes = TRUE, tips = FALSE, labels = FALSE, quiet = FALSE, ...) } \arguments{ \item{x}{an object of class \code{"phylo"}.} \item{nodes}{a logical specifying whether to identify the node.} \item{tips}{a logical specifying whether to return the tip information.} \item{labels}{a logical specifying whether to return the labels; by default only the numbers are returned.} \item{quiet}{a logical controlling whether to print a message inviting the user to click on the tree.} \item{\dots}{further arguments to be passed to or from other methods.} } \description{ This function allows to identify a clade on a plotted tree by clicking on the plot with the mouse. The tree, specified in the argument \code{x}, must be plotted beforehand. } \details{ By default, the clade is identified by its number as found in the `edge' matrix of the tree. If \code{tips = TRUE}, the tips descending from the identified node are returned, possibly together with the node. If \code{labels = TRUE}, the labels are returned (if the tree has no node labels, then the node numbered is returned). The node is identified by the shortest distance where the click occurs. If the click occurs close to a tip, the function returns its information. } \note{ This function does not add anything on the plot, but it can be wrapped with, e.g., \code{\link{nodelabels}} (see example), or its results can be sent to, e.g., \code{\link{drop.tip}}. } \value{ A list with one or two vectors named \code{"tips"} and/or \code{"nodes"} with the identification of the tips and/or of the nodes. } \author{Emmanuel Paradis} \seealso{ \code{\link{plot.phylo}}, \code{\link{nodelabels}}, \code{\link[graphics]{identify}} for the generic function } \examples{ \dontrun{ tr <- rtree(20) f <- function(col) { o <- identify(tr) nodelabels(node=o$nodes, pch = 19, col = col) } plot(tr) f("red") # click close to a node f("green") } } \keyword{aplot} ape/man/mixedFontLabel.Rd0000644000175100001440000000441313002742602014772 0ustar hornikusers\name{mixedFontLabel} \alias{mixedFontLabel} \title{Mixed Font Labels for Plotting} \description{ This function helps to format labels with bits of text in different font shapes (italics, bold, or bolditalics) and different separators. The output is intended to be used for plotting. } \usage{ mixedFontLabel(..., sep = " ", italic = NULL, bold = NULL, parenthesis = NULL, always.upright = c("sp.", "spp.", "ssp.")) } \arguments{ \item{\dots}{vectors of mode character to be formatted. They may be of different lengths in which case the shortest ones are recycled.} \item{sep}{a vector of mode character giving the separators to be printed between the elements in \code{\dots}.} \item{italic}{a vector of integers specifying the elements in \code{\dots} to be printed in italics.} \item{bold}{id. in boldface.} \item{parenthesis}{id. within parentheses.} \item{always.upright}{of vector of mode character giving the strings to not print in italics. Use \code{always.upright = ""} to cancel this option.} } \details{ The idea is to have different bits of text in different vectors that are put together to make a vector of \R expressions. This vector is interpreted by graphical functions to format the text. A simple use may be \code{mixedFontLabel(genus, species, italic = 1:2)}, but it is more interesting when mixing fonts (see examples). To have an element in bolditalics, its number must given in both \code{italic} and \code{bold}. The vector returned by this function may be assigned as the \code{tip.label} element of a tree of class \code{"phylo"}, or even as its \code{node.label} element. } \value{ A vector of mode expression. } \author{Emmanuel Paradis} \seealso{ \code{\link{makeLabel}}, \code{\link{makeNodeLabel}}, \code{\link{label2table}} } \examples{ tr <- read.tree(text = "((a,(b,c)),d);") genus <- c("Gorilla", "Pan", "Homo", "Pongo") species <- c("gorilla", "spp.", "sapiens", "pygmaeus") geo <- c("Africa", "Africa", "World", "Asia") tr$tip.label <- mixedFontLabel(genus, species, geo, italic = 1:2, parenthesis = 3) layout(matrix(c(1, 2), 2)) plot(tr) tr$tip.label <- mixedFontLabel(genus, species, geo, sep = c(" ", " | "), italic = 1:2, bold = 3) plot(tr) layout(1) } \keyword{manip} ape/man/zoom.Rd0000644000175100001440000000411211353107417013063 0ustar hornikusers\name{zoom} \alias{zoom} \title{Zoom on a Portion of a Phylogeny} \description{ This function plots simultaneously a whole phylogenetic tree (supposedly large) and a portion of it. } \usage{ zoom(phy, focus, subtree = FALSE, col = rainbow, ...) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{focus}{a vector, either numeric or character, or a list of vectors specifying the tips to be focused on.} \item{subtree}{a logical indicating whether to show the context of the extracted subtrees.} \item{col}{a vector of colours used to show where the subtrees are in the main tree, or a function .} \item{\dots}{further arguments passed to \code{plot.phylo}.} } \details{ This function aims at exploring very large trees. The main argument is a phylogenetic tree, and the second one is a vector or a list of vectors specifying the tips to be focused on. The vector(s) can be either numeric and thus taken as the indices of the tip labels, or character in which case it is taken as the corresponding tip labels. The whole tree is plotted on the left-hand side in a narrower sub-window (about a quarter of the device) without tip labels. The subtrees consisting of the tips in `focus' are extracted and plotted on the right-hand side starting from the top left corner and successively column-wise. If the argument `col' is a vector of colours, as many colours as the number of subtrees must be given. The alternative is to give a function that will create colours or grey levels from the number of subtrees: see \code{\link[grDevices]{rainbow}} for some possibilities with colours. } \author{Emmanuel Paradis} \seealso{ \code{\link{plot.phylo}}, \code{\link{drop.tip}}, \code{\link[graphics]{layout}}, \code{\link[grDevices]{rainbow}}, \code{\link[grDevices]{grey}} } \examples{ \dontrun{ data(chiroptera) zoom(chiroptera, 1:20, subtree = TRUE) zoom(chiroptera, grep("Plecotus", chiroptera$tip.label)) zoom(chiroptera, list(grep("Plecotus", chiroptera$tip.label), grep("Pteropus", chiroptera$tip.label))) } } \keyword{hplot} ape/man/corGrafen.Rd0000644000175100001440000000425011273753471014020 0ustar hornikusers\name{corGrafen} \alias{corGrafen} \alias{coef.corGrafen} \alias{corMatrix.corGrafen} \title{Grafen's (1989) Correlation Structure} \usage{ corGrafen(value, phy, form=~1, fixed = FALSE) \method{coef}{corGrafen}(object, unconstrained = TRUE, ...) \method{corMatrix}{corGrafen}(object, covariate = getCovariate(object), corr = TRUE, ...) } \arguments{ \item{value}{The \eqn{\rho}{rho} parameter} \item{phy}{An object of class \code{phylo} representing the phylogeny (branch lengths are ignored) to consider} \item{object}{An (initialized) object of class \code{corGrafen}} \item{corr}{a logical value. If 'TRUE' the function returns the correlation matrix, otherwise it returns the variance/covariance matrix.} \item{fixed}{an optional logical value indicating whether the coefficients should be allowed to vary in the optimization, or kept fixed at their initial value. Defaults to 'FALSE', in which case the coefficients are allowed to vary.} \item{form}{ignored for now.} \item{covariate}{ignored for now.} \item{unconstrained}{a logical value. If 'TRUE' the coefficients are returned in unconstrained form (the same used in the optimization algorithm). If 'FALSE' the coefficients are returned in "natural", possibly constrained, form. Defaults to 'TRUE'} \item{\dots}{some methods for these generics require additional arguments. None are used in these methods.} } \description{ Grafen's (1989) covariance structure. Branch lengths are computed using Grafen's method (see \code{\link{compute.brlen}}). The covariance matrice is then the traditional variance-covariance matrix for a phylogeny. } \value{ An object of class \code{corGrafen} or the rho coefficient from an object of this class or the correlation matrix of an initialized object of this class. } \author{Julien Dutheil \email{julien.dutheil@univ-montp2.fr}} \seealso{ \code{\link{corClasses}}, \code{\link{compute.brlen}}, \code{\link{vcv.phylo}}. } \references{ Grafen, A. (1989) The phylogenetic regression. \emph{Philosophical Transactions of the Royal society of London. Series B. Biological Sciences}, \bold{326}, 119--157. } \keyword{models} ape/man/DNAbin2indel.Rd0000644000175100001440000000137712661353364014311 0ustar hornikusers\name{DNAbin2indel} \alias{DNAbin2indel} \title{Recode Blocks of Indels} \description{ This function scans a set of aligned DNA sequences and returns a matrix with information of the localisations and lengths on alignment gaps. } \usage{ DNAbin2indel(x) } \arguments{ \item{x}{an object of class \code{"DNAbin"}.} } \details{ The output matrix has the same dimensions than the input one with, either a numeric value where an alignment gap starts giving the length of the gap, or zero. The rownames are kept. } \value{ a numeric matrix. } \author{Emmanuel Paradis} \seealso{ \code{\link{DNAbin}}, \code{\link{as.DNAbin}}, \code{\link{del.gaps}}, \code{\link{seg.sites}}, \code{\link{image.DNAbin}}, \code{\link{checkAlignment}} } \keyword{manip} ape/man/trans.Rd0000644000175100001440000000340212661351501013225 0ustar hornikusers\name{trans} \alias{trans} \alias{complement} \title{Translation from DNA to Amino Acid Sequences} \description{ \code{trans} translates DNA sequences into amino acids. \code{complement} returns the (reverse) complement sequences. } \usage{ trans(x, code = 1, codonstart = 1) complement(x) } \arguments{ \item{x}{an object of class \code{"DNAbin"} (vector, matrix or list).} \item{code}{an integer value giving the genetic code to be used. Currently only 1 (standard code) and 2 (vertebrate mitochondrial code) are supported.} \item{codonstart}{an integer giving where to start the translation. This should be 1, 2, or 3, but larger values are accepted and have for effect to start the translation further within the sequence.} } \details{ With \code{trans}, if the sequence length is not a multiple of three, a warning message is printed. Alignment gaps are simply ignored (i.e., \code{AG-} returns \code{X} with no special warning or message). Base ambiguities are taken into account where relevant: for instance, \code{GGN}, \code{GGA}, \code{GGR}, etc, all return \code{G}. } \value{ an object of class \code{"AAbin"} or \code{"DNAbin"}, respectively. } \note{ These functions are equivalent to \code{translate} and \code{comp} in the package \pkg{seqinr} with the difference that there is no need to convert the sequences into character strings. } \references{ \url{http://www.ncbi.nlm.nih.gov/Taxonomy/taxonomyhome.html/index.cgi?chapter=cgencodes} } \author{Emmanuel Paradis} \seealso{ \code{\link{AAbin}}, \code{\link{checkAlignment}}, \code{\link{alview}} } \examples{ data(woodmouse) X <- trans(woodmouse) # not correct X2 <- trans(woodmouse, 2) # using the correct code identical(X, X2) alview(X[1:2, 1:60]) # some codon Stop (*) alview(X2[, 1:60]) X2 }ape/man/write.nexus.data.Rd0000644000175100001440000000554012705640232015307 0ustar hornikusers\name{write.nexus.data} \alias{write.nexus.data} \title{Write Character Data in NEXUS Format} \description{ This function writes in a file a list of sequences in the NEXUS format. The names of the vectors of the list are used as taxon names. } \usage{ write.nexus.data(x, file, format = "dna", datablock = TRUE, interleaved = TRUE, charsperline = NULL, gap = NULL, missing = NULL) } \arguments{ \item{x}{a matrix or a list of sequences each made of a single vector of mode character where each element is a character state (e.g., \dQuote{A}, \dQuote{C}, \dots) Objects of class of \dQuote{DNAbin} are accepted.} \item{file}{a file name specified by either a variable of mode character, or a double-quoted string.} \item{format}{a character string specifying the format of the sequences. Two choices are possible: \dQuote{dna} (the default) or \dQuote{protein}, or any unambiguous abbreviation of these (case insensitive).} \item{datablock}{a logical, if \code{TRUE} the data are written in a single DATA block. If \code{FALSE} data is written in TAXA and CHARACTER blocks. Default is \code{TRUE}.} \item{interleaved}{a logical, if \code{TRUE} the data is written in interleaved format with number of characters per line as specified with \code{charsperline = numerical_value}. If \code{FALSE}, data is written in sequential format. Default is \code{TRUE}.} \item{charsperline}{a numeric specifying the number of characters per line when used with \code{interleaved = TRUE}. Default is 80.} \item{gap}{a character specifying the symbol for gap. Default is \dQuote{\code{-}}.} \item{missing}{a character specifying the symbol for missing data. Default is \dQuote{\code{?}}.} } \details{ If the sequences have no names, then they are given \dQuote{1}, \dQuote{2}, ..., as names in the file. Sequences must be all of the same length. Default symbols for missing data and gaps can be changed by using the \code{missing} and \code{gap} commands. } \value{ None (invisible \sQuote{NULL}). } \references{ Maddison, D. R., Swofford, D. L. and Maddison, W. P. (1997) NEXUS: an extensible file format for systematic information. \emph{Systematic Biology}, \bold{46}, 590--621. } \author{Johan Nylander \email{nylander@scs.fsu.edu}} \seealso{ \code{\link{read.nexus}},\code{\link{write.nexus}}, \code{\link{read.nexus.data}} } \examples{ \dontrun{ ## Write interleaved DNA data with 100 characters per line in a DATA block data(woodmouse) write.nexus.data(woodmouse, file= "wood.ex.nex", interleaved = TRUE, charsperline = 100) ## Write sequential DNA data in TAXA and CHARACTERS blocks data(cynipids) write.nexus.data(cynipids, file = "cyn.ex.nex", format = "protein", datablock = FALSE, interleaved = FALSE) unlink(c("wood.ex.nex", "cyn.ex.nex")) }} \keyword{file} ape/man/carnivora.Rd0000644000175100001440000000432310775732361014100 0ustar hornikusers\name{carnivora} \docType{data} \alias{carnivora} \title{Carnivora body sizes and life history traits} \description{ Dataset adapted from Gittleman (1986), including 2 morphological variables (body and brain sizes), 8 life history traits variables and 4 taxonomic variables. } \usage{data(carnivora)} \format{ A data frame with 112 observations on 17 variables. \tabular{rlll}{ [,1] \tab Order \tab factor \tab Carnivora order \cr [,2] \tab SuperFamily \tab factor \tab Super family (Caniformia or Feliformia) \cr [,3] \tab Family \tab factor \tab Carnivora family \cr [,4] \tab Genus \tab factor \tab Carnivora genus \cr [,5] \tab Species \tab factor \tab Carnivora species \cr [,6] \tab FW \tab numeric \tab Female body weight (kg) \cr [,7] \tab SW \tab numeric \tab Average body weight of adult male and adult female (kg) \cr [,8] \tab FB \tab numeric \tab Female brain weight (g) \cr [,9] \tab SB \tab numeric \tab Average brain weight of adult male and adult female (g) \cr [,10] \tab LS \tab numeric \tab Litter size \cr [,11] \tab GL \tab numeric \tab Gestation length (days) \cr [,12] \tab BW \tab numeric \tab Birth weigth (g) \cr [,13] \tab WA \tab numeric \tab Weaning age (days) \cr [,14] \tab AI \tab numeric \tab Age of independance (days) \cr [,15] \tab LY \tab numeric \tab Longevity (months) \cr [,16] \tab AM \tab numeric \tab Age of sexual maturity (days) \cr [,17] \tab IB \tab numeric \tab Inter-birth interval (months) \cr } } \source{ Gittleman, J. L. (1986) Carnivore life history patterns: allometric, phylogenetic and ecological associations. \emph{American Naturalist}, \bold{127}: 744--771. } \examples{ data(carnivora); # This is figure 1 of Gittleman 1986: library(lattice) trellis.device(color=FALSE) xyplot(BW ~ FW, groups=Family, data=carnivora, auto.key=TRUE, xlog=TRUE, scale=list(log=TRUE), ylim=c(1, 2000)) trellis.device(color=FALSE) xyplot(BW ~ FB, groups=Family, data=carnivora, auto.key=TRUE, xlog=TRUE, scale=list(log=TRUE), ylim=c(1, 2000)) } \keyword{datasets} ape/man/vcv.phylo.Rd0000644000175100001440000000346012435624745014046 0ustar hornikusers\name{vcv} \alias{vcv} \alias{vcv.phylo} \alias{vcv.corPhyl} \title{Phylogenetic Variance-covariance or Correlation Matrix} \usage{ vcv(phy, ...) \method{vcv}{phylo}(phy, model = "Brownian", corr = FALSE, ...) \method{vcv}{corPhyl}(phy, corr = FALSE, ...) } \arguments{ \item{phy}{an object of the correct class (see above).} \item{model}{a character giving the model used to compute the variances and covariances; only \code{"Brownian"} is available (for other models, a correlation structure may be used).} \item{corr}{a logical indicating whether the correlation matrix should be returned (\code{TRUE}); by default the variance-covariance matrix is returned (\code{FALSE}).} \item{\dots}{further arguments to be passed to or from other methods.} } \description{ This function computes the expected variances and covariances of a continuous trait assuming it evolves under a given model. This is a generic function with methods for objects of class \code{"phylo"} and \code{"corPhyl"}. } \value{ a numeric matrix with the names of the tips as colnames and rownames. } \references{ Garland, T. Jr. and Ives, A. R. (2000) Using the past to predict the present: confidence intervals for regression equations in phylogenetic comparative methods. \emph{American Naturalist}, \bold{155}, 346--364. } \author{Emmanuel Paradis} \note{ Do not confuse this function with \code{\link[stats]{vcov}} which computes the variance-covariance matrix among parameters of a fitted model object. } \seealso{ \code{\link{corBrownian}}, \code{\link{corMartins}}, \code{\link{corGrafen}}, \code{\link{corPagel}}, \code{\link{corBlomberg}}, \code{\link{vcv2phylo}} } \examples{ tr <- rtree(5) ## all are the same: vcv(tr) vcv(corBrownian(1, tr)) vcv(corPagel(1, tr)) } \keyword{manip} \keyword{multivariate} ape/man/subtreeplot.Rd0000644000175100001440000000347311741732455014467 0ustar hornikusers\name{subtreeplot} \alias{subtreeplot} \title{Zoom on a Portion of a Phylogeny by Successive Clicks} \description{ This function plots simultaneously a whole phylogenetic tree (supposedly large) and a portion of it determined by clicking on the nodes of the phylogeny. On exit, returns the last subtree visualized. } \usage{ subtreeplot(x, wait=FALSE, ...) } \arguments{ \item{x}{an object of class \code{"phylo"}.} \item{wait}{a logical indicating whether the node beeing processed should be printed (useful for big phylogenies).} \item{\dots}{further arguments passed to \code{plot.phylo}.} } \details{ This function aims at easily exploring very large trees. The main argument is a phylogenetic tree, and the second one is a logical indicating whether a waiting message should be printed while the calculation is being processed. The whole tree is plotted on the left-hand side in half of the device. The subtree is plotted on the right-hand side in the other half. The user clicks on the nodes in the complete tree and the subtree corresponding to this node is ploted in the right-hand side. There is no limit for the number of clicks that can be done. On exit, the subtree on the right hand side is returned. To use a subtree as the new tree in which to zoom, the user has to use the function many times. This can however be done in a single command line (see example 2). } \author{Damien de Vienne \email{damien.de-vienne@u-psud.fr}} \seealso{ \code{\link{plot.phylo}}, \code{\link{drop.tip}}, \code{\link{subtrees}} } \examples{ \dontrun{ #example 1: simple tree1 <- rtree(50) tree2 <- subtreeplot(tree1, wait = TRUE) # on exit, tree2 will be a subtree of tree1 #example 2: more than one zoom tree1 <- rtree(60) tree2 <- subtreeplot(subtreeplot(subtreeplot(tree1))) # allow three succssive zooms } } \keyword{hplot} ape/man/node.dating.Rd0000644000175100001440000001156213002725273014277 0ustar hornikusers\name{node.dating} \alias{estimate.mu} \alias{estimate.dates} \title{node.dating} \description{ Estimate the dates of a rooted phylogenetic tree from the tip dates. } \usage{ estimate.mu(t, node.dates, p = 0.05) estimate.dates(t, node.dates, mu = estimate.mu(t, node.dates), min.date = -.Machine$double.xmax, show.steps = 0, opt.tol = 1e-8, nsteps = 1000, lik.tol = if (nsteps <= 0) opt.tol else 0, is.binary = is.binary.phylo(t)) } \arguments{ \item{t}{an object of class '"phylo"'} \item{node.dates}{a numeric vector of dates for the tips, in the same order as 't$tip.label' or a vector of dates for all of the nodes.} \item{p}{p-value cutoff for failed regression.} \item{mu}{mutation rate.} \item{min.date}{the minimum bound on the dates of nodes.} \item{show.steps}{print the log likelihood every show.steps. If 0 will supress output.} \item{opt.tol}{tolerance for optimization precision.} \item{lik.tol}{tolerance for likelihood comparison.} \item{nsteps}{the maximum number of steps to run.} \item{is.binary}{if TRUE, will run a faster optimization method that only works if the tree is binary; otherwise will use optimize() as the optimization method.} } \value{ The estimated mutation rate as a numeric vector of length one for estimate.mu. The estimated dates of all of the nodes of the tree as a numeric vector with length equal to the number of nodes in the tree. } \details{ This code duplicates the functionality of the program Tip.Dates (see references). The dates of the internal nodes of 't' are estimated using a maximum likelihood approach. 't' must be rooted and have branch lengths in units of expected substitutions per site. 'node.dates' can be either a numeric vector of dates for the tips or a numeric vector for all of the nodes of 't'. 'estimate.mu' will use all of the values given in 'node.dates' to estimate the mutation rate. Dates can be censored with NA. 'node.dates' must contain all of the tip dates when it is a parameter of 'estimate.dates'. If only tip dates are given, then 'estimate.dates' will run an initial step to estimate the dates of the internal nodes. If 'node.dates' contains dates for some of the nodes, 'estimate.dates' will use those dates as priors in the inital step. If all of the dates for nodes are given, then 'estimate.dates' will not run the inital step. If 'is.binary' is set to FALSE, 'estimate.dates' uses the '"optimize"' function as the optimization method. By default, R's '"optimize"' function uses a precision of '".Machine$double.eps^0.25"', which is about 0.0001 on a 64-bit system. This should be set to a smaller value if the branch lengths of 't' are very short. If 'is.binary' is set to TRUE, estimate dates uses calculus to deterimine the maximum likelihood at each step, which is faster. The bounds of permissible values are reduced by 'opt.tol'. 'estimate.dates' has several criteria to decide how many steps it will run. If 'lik.tol' and 'nsteps' are both 0, then 'estimate.dates' will only run the initial step. If 'lik.tol' is greater than 0 and 'nsteps' is 0, then 'estimate.dates' will run until the difference between successive steps is less than 'lik.tol'. If 'lik.tol' is 0 and 'nsteps' is greater than 0, then 'estimate.dates' will run the inital step and then 'nsteps' steps. If 'lik.tol' and 'nsteps' are both greater than 0, then 'estimate.dates' will run the inital step and then either 'nsteps' steps or until the difference between successive steps is less than 'lik.tol'. } \note{ This model assumes that the tree follows a molecular clock. It only performs a rudimentary statistical test of the molecular clock hypothesis. } \author{Bradley R. Jones } \references{ Felsenstein, J. (1981) Evolutionary trees from DNA sequences: a maximum likelihood approach. \emph{Journal of Molecular Evolution}, \bold{17}, 368--376. Rambaut, A. (2000) Estimating the rate of molecular evolution: incorporating non-contemporaneous sequences into maximum likelihood phylogenies. \emph{Bioinformatics}, \bold{16}, 395--399. Jones, Bradley R., and Poon, Art F. Y. (2016) \emph{node.dating: dating ancestors in phylogenetic trees in R}. Preprint. } \seealso{ \code{\link[stats]{optimize}}, \code{\link{rtt}}, \code{\link{plotTreeTime}} } \examples{ t <- rtree(100) tip.date <- rnorm(t$tip.label, mean = node.depth.edgelength(t)[1:Ntip(t)])^2 t <- rtt(t, tip.date) mu <- estimate.mu(t, tip.date) ## Run for 100 steps node.date <- estimate.dates(t, tip.date, mu, nsteps = 100) ## Run until the difference between successive log likelihoods is ## less than $10^{-4}$ starting with the 100th step's results node.date <- estimate.dates(t, node.date, mu, nsteps = 0, lik.tol = 1e-4) ## To rescale the tree over time t$edge.length <- node.date[t$edge[, 2]] - node.date[t$edge[, 1]] } ape/man/corMartins.Rd0000644000175100001440000000433311527146014014224 0ustar hornikusers\name{corMartins} \alias{corMartins} \alias{coef.corMartins} \alias{corMatrix.corMartins} \title{Martins's (1997) Correlation Structure} \usage{ corMartins(value, phy, form = ~1, fixed = FALSE) \method{coef}{corMartins}(object, unconstrained = TRUE, ...) \method{corMatrix}{corMartins}(object, covariate = getCovariate(object), corr = TRUE, ...) } \arguments{ \item{value}{The \eqn{\alpha}{alpha} parameter} \item{phy}{An object of class \code{phylo} representing the phylogeny (with branch lengths) to consider} \item{object}{An (initialized) object of class \code{corMartins}} \item{corr}{a logical value. If 'TRUE' the function returns the correlation matrix, otherwise it returns the variance/covariance matrix.} \item{fixed}{an optional logical value indicating whether the coefficients should be allowed to vary in the optimization, ok kept fixed at their initial value. Defaults to 'FALSE', in which case the coefficients are allowed to vary.} \item{form}{ignored for now.} \item{covariate}{ignored for now.} \item{unconstrained}{a logical value. If 'TRUE' the coefficients are returned in unconstrained form (the same used in the optimization algorithm). If 'FALSE' the coefficients are returned in "natural", possibly constrained, form. Defaults to 'TRUE'} \item{\dots}{some methods for these generics require additional arguments. None are used in these methods.} } \description{ Martins and Hansen's (1997) covariance structure: \deqn{V_{ij} = \gamma \times e^{-\alpha t_{ij}}}{% Vij = gamma . exp(-alpha . tij)} where \eqn{t_{ij}}{tij} is the phylogenetic distance between taxa \eqn{i}{i} and \eqn{j}{j} and \eqn{\gamma}{gamma} is a constant. } \value{ An object of class \code{corMartins} or the alpha coefficient from an object of this class or the correlation matrix of an initialized object of this class. } \author{Julien Dutheil \email{julien.dutheil@univ-montp2.fr}} \seealso{ \code{\link{corClasses}}. } \references{ Martins, E. P. and Hansen, T. F. (1997) Phylogenies and the comparative method: a general approach to incorporating phylogenetic information into the analysis of interspecific data. \emph{American Naturalist}, \bold{149}, 646--667. } \keyword{models} ape/man/clustal.Rd0000644000175100001440000001060113017303353013542 0ustar hornikusers\name{clustal} \alias{clustal} \alias{clustalomega} \alias{muscle} \alias{tcoffee} \title{Multiple Sequence Alignment with External Applications} \description{ These functions call their respective program from \R to align a set of nucleotide sequences of class \code{"DNAbin"}. The application(s) must be installed seperately and it is highly recommended to do this so that the executables are in a directory located on the PATH of the system. } \usage{ clustal(x, pw.gapopen = 10, pw.gapext = 0.1, gapopen = 10, gapext = 0.2, exec = NULL, MoreArgs = "", quiet = TRUE, original.ordering = TRUE) clustalomega(x, exec = NULL, MoreArgs = "", quiet = TRUE) muscle(x, exec = "muscle", MoreArgs = "", quiet = TRUE, original.ordering = TRUE) tcoffee(x, exec = "t_coffee", MoreArgs = "", quiet = TRUE, original.ordering = TRUE) } \arguments{ \item{x}{an object of class \code{"DNAbin"}.} \item{pw.gapopen, pw.gapext}{gap opening and gap extension penalties used by Clustal during pairwise alignments.} \item{gapopen, gapext}{idem for global alignment.} \item{exec}{a character string giving the name of the program, with its path if necessary. \code{clustal} tries to guess it depending on the operating system (see details).} \item{MoreArgs}{a character string giving additional options.} \item{quiet}{a logical: the default is to not print on \R's console the messages from the external program.} \item{original.ordering}{a logical specifying whether to return the aligned sequences in the same order than in \code{x}.} } \details{ It is highly recommended to install the executables properly so that they are in a directory located on the PATH (i.e., accessible from any other directory). Alternatively, the full path to the executable may be given (e.g., \code{exec = "~/muscle/muscle"}), or a (symbolic) link may be copied in the working directory. For Debian and its derivatives (e.g., Ubuntu), it is recommended to use the binaries distributed by Debian. \code{clustal} tries to guess the name of the executable program depending on the operating system. Specifically, the followings are used: ``clustalw'' under Linux, ``clustalw2'' under MacOS, or ``clustalw2.exe'' under Windows. For \code{clustalomega}, ``clustalo[.exe]'' is the default on all systems (with no specific path) since it seems there is no Windows installer. The computations are done in a temporary directory which is deleted when \R is quit. So it is possible to find the files created by the last call in the directory printed by \code{tempdir()}. When called without arguments (i.e., \code{clustal()}, \dots), the function prints the options of the program which may be passed to \code{MoreArgs}. } \note{ \code{clustalomega} is actually for AA sequences only. } \value{ an object of class \code{"DNAbin"} with the aligned sequences. } \references{ Chenna, R., Sugawara, H., Koike, T., Lopez, R., Gibson, T. J., Higgins, D. G. and Thompson, J. D. (2003) Multiple sequence alignment with the Clustal series of programs. \emph{Nucleic Acids Research} \bold{31}, 3497--3500. \url{http://www.clustal.org/} Edgar, R. C. (2004) MUSCLE: Multiple sequence alignment with high accuracy and high throughput. \emph{Nucleic Acids Research}, \bold{32}, 1792--1797. \url{http://www.drive5.com/muscle/muscle_userguide3.8.html} Notredame, C., Higgins, D. and Heringa, J. (2000) T-Coffee: A novel method for multiple sequence alignments. \emph{Journal of Molecular Biology}, \bold{302}, 205--217. \url{http://www.tcoffee.org/} Sievers, F., Wilm, A., Dineen, D., Gibson, T. J., Karplus, K., Li, W., Lopez, R., McWilliam, H., Remmert, M., S\"oding, J., Thompson, J. D. and Higgins, D. G. (2011) Fast, scalable generation of high-quality protein multiple sequence alignments using Clustal Omega. \emph{Molecular Systems Biology}, \bold{7}, 539. } \author{Emmanuel Paradis} \seealso{ \code{\link{image.DNAbin}}, \code{\link{del.gaps}}, \code{\link{all.equal.DNAbin}}, \code{\link{alex}}, \code{\link{alview}}, \code{\link{checkAlignment}} } \examples{ \dontrun{ ### display the options: clustal() muscle() tcoffee() data(woodmouse) ### open gaps more easily: clustal(woodmouse, pw.gapopen = 1, pw.gapext = 1) ### T-Coffee requires negative values (quite slow; muscle is much faster): tcoffee(woodmouse, MoreArgs = "-gapopen=-10 -gapext=-2") }} \keyword{manip} ape/man/read.gff.Rd0000644000175100001440000000247012775465357013603 0ustar hornikusers\name{read.gff} \alias{read.gff} \title{Read GFF Files} \description{ This function reads a file in general feature format version 3 (GFF3) and returns a data frame. } \usage{ read.gff(file, na.strings = c(".", "?")) } \arguments{ \item{file}{a file name specified by a character string.} \item{na.strings}{the strings in the GFF file that will be converted as NA's (missing values).} } \details{ The returned data frame has its (column) names correctly set (see References) and the categorical variables (seqid, source, type, strand, and phase) set as factors. This function should be more efficient than using \code{read.delim}. GFF2 files can also be read but the field names conform to GFF3. The file can be gz-compressed (see examples), but not zipped. } \value{NULL} \author{Emmanuel Paradis} \references{ \url{https://en.wikipedia.org/wiki/General_feature_format} } \examples{ \dontrun{ ## requires to be connected on Internet d <- "ftp://ftp.ensembl.org/pub/release-86/gff3/homo_sapiens/" f <- "Homo_sapiens.GRCh38.86.chromosome.MT.gff3.gz" download.file(paste0(d, f), "mt_gff3.gz") gff.mito <- read.gff("mt_gff3.gz") ## the lengths of the sequence features: gff.mito$end - (gff.mito$start - 1) table(gff.mito$type) ## where the exons start: gff.mito$start[gff.mito$type == "exon"] } } \keyword{IO} ape/man/nj.Rd0000644000175100001440000000236011736034312012507 0ustar hornikusers\name{nj} \alias{nj} \title{Neighbor-Joining Tree Estimation} \description{ This function performs the neighbor-joining tree estimation of Saitou and Nei (1987). } \usage{ nj(X) } \arguments{ \item{X}{a distance matrix; may be an object of class ``dist''.} } \value{ an object of class \code{"phylo"}. } \references{ Saitou, N. and Nei, M. (1987) The neighbor-joining method: a new method for reconstructing phylogenetic trees. \emph{Molecular Biology and Evolution}, \bold{4}, 406--425. Studier, J. A. and Keppler, K. J. (1988) A note on the neighbor-joining algorithm of Saitou and Nei. \emph{Molecular Biology and Evolution}, \bold{5}, 729--731. } \author{Emmanuel Paradis} \seealso{ \code{\link{write.tree}}, \code{\link{read.tree}}, \code{\link{dist.dna}}, \code{\link{bionj}}, \code{\link{fastme}}, \code{\link{njs}} } \examples{ ### From Saitou and Nei (1987, Table 1): x <- c(7, 8, 11, 13, 16, 13, 17, 5, 8, 10, 13, 10, 14, 5, 7, 10, 7, 11, 8, 11, 8, 12, 5, 6, 10, 9, 13, 8) M <- matrix(0, 8, 8) M[lower.tri(M)] <- x M <- t(M) M[lower.tri(M)] <- x dimnames(M) <- list(1:8, 1:8) tr <- nj(M) plot(tr, "u") ### a less theoretical example data(woodmouse) trw <- nj(dist.dna(woodmouse)) plot(trw) } \keyword{models} ape/man/node.depth.Rd0000644000175100001440000000226112442101114014116 0ustar hornikusers\name{node.depth} \alias{node.depth} \alias{node.depth.edgelength} \alias{node.height} \title{Depth and Heights of Nodes and Tips} \description{ These functions return the depths or heights of nodes and tips. } \usage{ node.depth(phy, method = 1) node.depth.edgelength(phy) node.height(phy, clado.style = FALSE) } \arguments{ \item{phy}{an object of class "phylo".} \item{method}{an integer value (1 or 2); 1: the node depths are proportional to the number of tips descending from each node, 2: they are evenly spaced.} \item{clado.style}{a logical value; if \code{TRUE}, the node heights are calculated for a cladogram.} } \details{ \code{node.depth} computes the depth of a node depending on the value of \code{method} (see the option \code{node.depth} in \code{\link{plot.phylo}}). The value of 1 is given to the tips. \code{node.depth.edgelength} does the same but using branch lengths. \code{node.height} computes the heights of nodes and tips as plotted by a phylogram or a cladogram. } \value{ A numeric vector indexed with the node numbers of the matrix `edge' of \code{phy}. } \author{Emmanuel Paradis} \seealso{\code{\link{plot.phylo}}} \keyword{manip} ape/man/vcv2phylo.Rd0000644000175100001440000000151312435403770014040 0ustar hornikusers\name{vcv2phylo} \alias{vcv2phylo} \title{Variance-Covariance Matrix to Tree} \description{ This function transforms a variance-covariance matrix into a phylogenetic tree. } \usage{ vcv2phylo(mat, tolerance = 1e-7) } \arguments{ \item{mat}{a square symmetric (positive-definite) matrix.} \item{tolerance}{the numeric tolerance used to compare the branch lengths.} } \details{ The function tests if the matrix is symmetric and positive-definite (i.e., all its eigenvalues positive within the specified tolerance). } \value{ an object of class \code{"phylo"}. } \author{Simon Blomberg} \seealso{ \code{\link{vcv}}, \code{\link{corPhyl}} } \examples{ tr <- rtree(10) V <- vcv(tr) # VCV matrix assuming Brownian motion z <- vcv2phylo(V) identical(tr, z) # FALSE all.equal(tr, z) # TRUE } \keyword{manip} \keyword{multivariate} ape/man/phydataplot.Rd0000644000175100001440000001400712623027163014434 0ustar hornikusers\name{phydataplot} \alias{phydataplot} \alias{ring} \title{Tree Annotation} \description{ \code{phydataplot} plots data on a tree in a way that adapts to the type of tree. \code{ring} does the same for circular trees. Both functions match the data with the labels of the tree. } \usage{ phydataplot(x, phy, style = "bars", offset = 1, scaling = 1, continuous = FALSE, width = NULL, legend = "below", funcol = rainbow, ...) ring(x, phy, style = "ring", offset = 1, ...) } \arguments{ \item{x}{a vector, a factor, a matrix, or a data frame.} \item{phy}{the tree (which must be already plotted).} \item{style}{a character string specifying the type of graphics; can be abbreviated (see details).} \item{offset}{the space between the tips of the tree and the plot.} \item{scaling}{the scaling factor to apply to the data.} \item{continuous}{(used if style="mosaic") a logical specifying whether to treat the values in \code{x} as continuous or not; can be an integer value giving the number of categories.} \item{width}{(used if style = "mosaic") the width of the cells; by default, all the available space is used.} \item{legend}{(used if style = "mosaic") the place where to draw the legend; if not the default, the legend is drawn besides the mosaic.} \item{funcol}{(used if style = "mosaic") the function used to generate the colours (see details and examples).} \item{\dots}{further arguments passed to the graphical functions.} } \details{ The possible values for \code{style} are ``bars'', ``segments'', ``image'', ``arrows'', ``boxplot'', ``dotchart'', or ``mosaic'' for \code{phydataplot}, and ``ring'', ``segments'', or ``arrows'' for \code{ring}. \code{style = "image"} works only with square matrices (e.g., similarities). If you want to plot a DNA alignment in the same way than \code{\link{image.DNAbin}}, try \code{style = "mosaic"}. \code{style = "mosaic"} can plot any kind of matrices, possibly after discretizing its values (using \code{continuous}). The default colour palette is taken from the function \code{\link[grDevices]{rainbow}}. If you want to use specified colours, a function simply returning the vector of colours must be used (see examples). } \note{ For the moment, only rightwards trees are supported (does not apply to circular trees). } \author{Emmanuel Paradis} \seealso{ \code{\link{plot.phylo}}, \code{\link{nodelabels}}, \code{\link{fancyarrows}} } \examples{ ## demonstrates matching with names: tr <- rcoal(n <- 10) x <- 1:n names(x) <- tr$tip.label plot(tr, x.lim = 11) phydataplot(x, tr) ## shuffle x but matching names with tip labels reorders them: phydataplot(sample(x), tr, "s", lwd = 3, lty = 3) ## adapts to the tree: plot(tr, "f", x.l = c(-11, 11), y.l = c(-11, 11)) phydataplot(x, tr, "s") ## leave more space with x.lim to show a barplot and a dotchart: plot(tr, x.lim = 22) phydataplot(x, tr, col = "yellow") phydataplot(x, tr, "d", offset = 13) ts <- rcoal(N <- 100) X <- rTraitCont(ts) # names are set dd <- dist(X) op <- par(mar = rep(0, 4)) plot(ts, x.lim = 10, cex = 0.4, font = 1) phydataplot(as.matrix(dd), ts, "i", offset = 0.2) par(xpd = TRUE, mar = op$mar) co <- c("blue", "red"); l <- c(-2, 2) X <- X + abs(min(X)) # move scale so X >= 0 plot(ts, "f", show.tip.label = FALSE, x.lim = l, y.lim = l, open.angle = 30) phydataplot(X, ts, "s", col = co, offset = 0.05) ring(X, ts, "ring", col = co, offset = max(X) + 0.1) # the same info as a ring ## as many rings as you want... co <- c("blue", "yellow") plot(ts, "r", show.tip.label = FALSE, x.l = c(-1, 1), y.l = c(-1, 1)) for (o in seq(0, 0.4, 0.2)) { co <- rev(co) ring(0.2, ts, "r", col = rep(co, each = 5), offset = o) } lim <- c(-5, 5) co <- rgb(0, 0.4, 1, alpha = 0.1) y <- seq(0.01, 1, 0.01) plot(ts, "f", x.lim = lim, y.lim = lim, show.tip.label = FALSE) ring(y, ts, offset = 0, col = co, lwd = 0.1) for (i in 1:3) { y <- y + 1 ring(y, ts, offset = 0, col = co, lwd = 0.1) } ## rings can be in the background plot(ts, "r", plot = FALSE) ring(1, ts, "r", col = rainbow(100), offset = -1) par(new = TRUE) plot(ts, "r", font = 1, edge.color = "white") ## might be more useful: co <- c("lightblue", "yellow") plot(ts, "r", plot = FALSE) ring(0.1, ts, "r", col = sample(co, size = N, rep = TRUE), offset = -.1) par(new = TRUE) plot(ts, "r", font = 1) ## if x is matrix: tx <- rcoal(m <- 20) X <- runif(m, 0, 0.5); Y <- runif(m, 0, 0.5) X <- cbind(X, Y, 1 - X - Y) rownames(X) <- tx$tip.label plot(tx, x.lim = 6) co <- rgb(diag(3)) phydataplot(X, tx, col = co) ## a variation: plot(tx, show.tip.label = FALSE, x.lim = 5) phydataplot(X, tx, col = co, offset = 0.05, border = NA) plot(tx, "f", show.tip.label = FALSE, open.angle = 180) ring(X, tx, col = co, offset = 0.05) Z <- matrix(rnorm(m * 5), m) rownames(Z) <- rownames(X) plot(tx, x.lim = 5) phydataplot(Z, tx, "bo", scaling = .5, offset = 0.5, boxfill = c("gold", "skyblue")) ## plot an alignment with a NJ tree: data(woodmouse) trw <- nj(dist.dna(woodmouse)) plot(trw, x.lim = 0.1, align.tip = TRUE, font = 1) phydataplot(woodmouse[, 1:50], trw, "m", 0.02, border = NA) ## use type = "mosaic" on a 30x5 matrix: tr <- rtree(n <- 30) p <- 5 x <- matrix(sample(3, size = n*p, replace = TRUE), n, p) dimnames(x) <- list(paste0("t", 1:n), LETTERS[1:p]) plot(tr, x.lim = 35, align.tip = TRUE, adj = 1) phydataplot(x, tr, "m", 2) ## change the aspect: plot(tr, x.lim = 35, align.tip = TRUE, adj = 1) phydataplot(x, tr, "m", 2, width = 2, border = "white", lwd = 3, legend = "side") ## user-defined colour: f <- function(n) c("yellow", "blue", "red") phydataplot(x, tr, "m", 18, width = 2, border = "white", lwd = 3, legend = "side", funcol = f) ## use continuous = TRUE with two different scales: x[] <- 1:(n*p) plot(tr, x.lim = 35, align.tip = TRUE, adj = 1) phydataplot(x, tr, "m", 2, width = 1.5, continuous = TRUE, legend = "side", funcol = colorRampPalette(c("white", "darkgreen"))) phydataplot(x, tr, "m", 18, width = 1.5, continuous = 5, legend = "side", funcol = topo.colors) } \keyword{aplot} ape/man/rlineage.Rd0000644000175100001440000001042312623030422013657 0ustar hornikusers\name{rlineage} \alias{rlineage} \alias{rbdtree} \alias{rphylo} \alias{drop.fossil} \title{Tree Simulation Under the Time-Dependent Birth--Death Models} \description{ These three functions simulate phylogenies under any time-dependent birth--death model: \code{rlineage} generates a complete tree including the species going extinct before present; \code{rbdtree} generates a tree with only the species living at present (thus the tree is ultrametric); \code{rphylo} generates a tree with a fixed number of species at present time. \code{drop.fossil} is a utility function to remove the extinct species. } \usage{ rlineage(birth, death, Tmax = 50, BIRTH = NULL, DEATH = NULL, eps = 1e-6) rbdtree(birth, death, Tmax = 50, BIRTH = NULL, DEATH = NULL, eps = 1e-6) rphylo(n, birth, death, BIRTH = NULL, DEATH = NULL, T0 = 50, fossils = FALSE, eps = 1e-06) drop.fossil(phy, tol = 1e-8) } \arguments{ \item{birth, death}{a numeric value or a (vectorized) function specifying how speciation and extinction rates vary through time.} \item{Tmax}{a numeric value giving the length of the simulation.} \item{BIRTH, DEATH}{a (vectorized) function which is the primitive of \code{birth} or \code{death}. This can be used to speed-up the computation. By default, a numerical integration is done.} \item{eps}{a numeric value giving the time resolution of the simulation; this may be increased (e.g., 0.001) to shorten computation times.} \item{n}{the number of species living at present time.} \item{T0}{the time at present (for the backward-in-time algorithm).} \item{fossils}{a logical value specifying whether to output the lineages going extinct.} \item{phy}{an object of class \code{"phylo"}.} \item{tol}{a numeric value giving the tolerance to consider a species as extinct.} } \details{ These three functions use continuous-time algorithms: \code{rlineage} and \code{rbdtree} use the forward-in-time algorithms described in Paradis (2011), whereas \code{rphylo} uses a backward-in-time algorithm from Stadler (2011). The models are time-dependent birth--death models as described in Kendall (1948). Speciation (birth) and extinction (death) rates may be constant or vary through time according to an \R function specified by the user. In the latter case, \code{BIRTH} and/or \code{DEATH} may be used if the primitives of \code{birth} and \code{death} are known. In these functions time is the formal argument and must be named \code{t}. Note that \code{rphylo} simulates trees in a way similar to what the package \pkg{TreeSim} does, the difference is in the parameterization of the time-dependent models which is here the same than used in the two other functions. In this parameterization scheme, time is measured from past to present (see details in Paradis 2015 which includes a comparison of these algorithms). The difference between \code{rphylo} and \code{rphylo(... fossils = TRUE)} is the same than between \code{rbdtree} and \code{rlineage}. } \value{ An object of class \code{"phylo"}. } \references{ Kendall, D. G. (1948) On the generalized ``birth-and-death'' process. \emph{Annals of Mathematical Statistics}, \bold{19}, 1--15. Paradis, E. (2011) Time-dependent speciation and extinction from phylogenies: a least squares approach. \emph{Evolution}, \bold{65}, 661--672. Paradis, E. (2015) Random phylogenies and the distribution of branching times. Manuscript. Stadler, T. (2011) Simulating trees with a fixed number of extant species. \emph{Systematic Biology}, \bold{60}, 676--684. } \author{Emmanuel Paradis} \seealso{ \code{\link{yule}}, \code{\link{yule.time}}, \code{\link{birthdeath}}, \code{\link{rtree}}, \code{\link{stree}} } \examples{ set.seed(10) plot(rlineage(0.1, 0)) # Yule process with lambda = 0.1 plot(rlineage(0.1, 0.05)) # simple birth-death process b <- function(t) 1/(1 + exp(0.2*t - 1)) # logistic layout(matrix(0:3, 2, byrow = TRUE)) curve(b, 0, 50, xlab = "Time", ylab = "") mu <- 0.07 segments(0, mu, 50, mu, lty = 2) legend("topright", c(expression(lambda), expression(mu)), lty = 1:2, bty = "n") plot(rlineage(b, mu), show.tip.label = FALSE) title("Simulated with 'rlineage'") plot(rbdtree(b, mu), show.tip.label = FALSE) title("Simulated with 'rbdtree'") } \keyword{datagen} ape/man/yule.Rd0000644000175100001440000000326312033445612013061 0ustar hornikusers\name{yule} \alias{yule} \title{Fits the Yule Model to a Phylogenetic Tree} \usage{ yule(phy, use.root.edge = FALSE) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{use.root.edge}{a logical specifying whether to consider the root edge in the calculations.} } \description{ This function fits by maximum likelihood a Yule model, i.e., a birth-only model to the branching times computed from a phylogenetic tree. } \details{ The tree must be fully dichotomous. The maximum likelihood estimate of the speciation rate is obtained by the ratio of the number of speciation events on the cumulative number of species through time; these two quantities are obtained with the number of nodes in the tree, and the sum of the branch lengths, respectively. If there is a `root.edge' element in the phylogenetic tree, and \code{use.root.edge = TRUE}, then it is assumed that it has a biological meaning and is counted as a branch length, and the root is counted as a speciation event; otherwise the number of speciation events is the number of nodes - 1. The standard-error of lambda is computed with the second derivative of the log-likelihood function. } \value{ An object of class "yule" which is a list with the following components: \item{lambda}{the maximum likelihood estimate of the speciation (birth) rate.} \item{se}{the standard-error of lambda.} \item{loglik}{the log-likelihood at its maximum.} } \author{Emmanuel Paradis} \seealso{ \code{\link{branching.times}}, \code{\link{diversi.gof}}, \code{\link{diversi.time}}, \code{\link{ltt.plot}}, \code{\link{birthdeath}}, \code{\link{bd.ext}}, \code{\link{yule.cov}} } \keyword{models} ape/man/write.nexus.Rd0000644000175100001440000000262412125467513014404 0ustar hornikusers\name{write.nexus} \alias{write.nexus} \title{Write Tree File in Nexus Format} \usage{ write.nexus(..., file = "", translate = TRUE) } \arguments{ \item{\dots}{either (i) a single object of class \code{"phylo"}, (ii) a series of such objects separated by commas, or (iii) a list containing such objects.} \item{file}{a file name specified by either a variable of mode character, or a double-quoted string; if \code{file = ""} (the default) then the tree is written on the standard output connection.} \item{translate}{a logical, if \code{TRUE} (the default) a translation of the tip labels is done which are replaced in the parenthetic representation with tokens.} } \description{ This function writes trees in a file with the NEXUS format. } \details{ If several trees are given, they must all have the same tip labels. If among the objects given some are not trees of class \code{"phylo"}, they are simply skipped and not written in the file. } \value{ None (invisible `NULL'). } \references{ Maddison, D. R., Swofford, D. L. and Maddison, W. P. (1997) NEXUS: an extensible file format for systematic information. \emph{Systematic Biology}, \bold{46}, 590--621. } \author{Emmanuel Paradis} \seealso{ \code{\link{read.nexus}}, \code{\link{read.tree}}, \code{\link{write.tree}}, \code{\link{read.nexus.data}}, \code{\link{write.nexus.data}} } \keyword{manip} \keyword{IO} ape/man/Initialize.corPhyl.Rd0000644000175100001440000000167411273753372015641 0ustar hornikusers\name{Initialize.corPhyl} \alias{Initialize.corPhyl} \title{Initialize a `corPhyl' Structure Object} \usage{ \method{Initialize}{corPhyl}(object, data, ...) } \arguments{ \item{object}{An object inheriting from class \code{corPhyl}.} \item{data}{The data to use. If it contains rownames, they are matched with the tree tip labels, otherwise data are supposed to be in the same order than tip labels and a warning is sent.} \item{\dots}{some methods for this generic require additional arguments. None are used in this method.} } \description{ Initialize a \code{corPhyl} correlation structure object. Does the same as \code{Initialize.corStruct}, but also checks the row names of data and builds an index. } \value{ An initialized object of same class as \code{object}. } \author{Julien Dutheil \email{julien.dutheil@univ-montp2.fr}} \seealso{ \code{\link{corClasses}}, \code{\link[nlme]{Initialize.corStruct}}. } \keyword{models} \keyword{manip} ape/man/evonet.Rd0000644000175100001440000000476211575561520013417 0ustar hornikusers\name{evonet} \alias{evonet} \alias{print.evonet} \alias{plot.evonet} \alias{as.phylo.evonet} \alias{as.networx.evonet} \alias{as.network.evonet} \alias{as.igraph.evonet} \title{Evolutionary Networks} \description{ \code{evonet} builds a network from a tree of class \code{"phylo"}. There are \code{print} and \code{plot} methods as well as a few conversion functions. } \usage{ evonet(phy, from, to = NULL) \method{print}{evonet}(x, ...) \method{plot}{evonet}(x, col = "blue", lty = 1, lwd = 1, alpha = 0.5, arrows = 0, arrow.type = "classical", ...) \method{as.phylo}{evonet}(x, ...) \method{as.networx}{evonet}(x, weight = NA, ...) \method{as.network}{evonet}(x, directed = TRUE, ...) \method{as.igraph}{evonet}(x, directed = TRUE, use.labels = TRUE, ...) } \arguments{ \item{phy, x}{an object of class \code{"phylo"} or \code{"evonet"}.} \item{from}{a vector (or a matrix if \code{to = NULL}) giving the node or tip numbers involved in the reticulations.} \item{to}{a vector of the same length than \code{from}.} \item{col, lty, lwd}{colors, line type and width of the reticulations (recycled if necessary).} \item{alpha}{a value between 0 and 1 specifying the transparency of the reticulations.} \item{arrows}{see \code{\link{fancyarrows}}.} \item{arrow.type}{idem.} \item{weight}{a numeric vector giving the weights for the reticulations when converting to the class \code{"networx"} (recycled or shortened if needed).} \item{directed}{a logical: should the network be considered as directed? \code{TRUE} by default.} \item{use.labels}{a logical specifying whether to use the tip and node labels when building the network of class \code{"igraph"}.} \item{\dots}{arguments passed to other methods.} } \details{ \code{evonet} is a constructor function that checks the arguments. The classes \code{"networx"}, \code{"network"}, and \code{"igraph"} are defined in the packages \pkg{phangorn}, \pkg{network}, and \pkg{igraph}, respectively. } \value{ an object of class \code{c("evonet", "phylo")} which is made of an object of class \code{"\link{phylo}"} plus an element \code{reticulation} coding additional edges among nodes and uses the same coding rules than the \code{edge} matrix. The conversion functions return an object of the appropriate class. } \author{Emmanuel Paradis} \seealso{ \code{\link[phangorn]{as.networx}} in package \pkg{phangorn} } \examples{ tr <- rcoal(5) (x <- evonet(tr, 6:7, 8:9)) plot(x) } \keyword{manip} \keyword{hplot} ape/man/yule.time.Rd0000644000175100001440000000636311736207471014032 0ustar hornikusers\name{yule.time} \alias{yule.time} \title{Fits the Time-Dependent Yule Model} \usage{ yule.time(phy, birth, BIRTH = NULL, root.time = 0, opti = "nlm", start = 0.01) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{birth}{a (vectorized) function specifying how the birth (speciation) probability changes through time (see details).} \item{BIRTH}{a (vectorized) function giving the primitive of \code{birth}.} \item{root.time}{a numeric value giving the time of the root node (time is measured from the past towards the present).} \item{opti}{a character string giving the function used for optimisation of the likelihood function. Three choices are possible: \code{"nlm"}, \code{"nlminb"}, or \code{"optim"}, or any unambiguous abbreviation of these.} \item{start}{the initial values used in the optimisation.} } \description{ This function fits by maximum likelihood the time-dependent Yule model. The time is measured from the past (\code{root.time}) to the present. } \details{ The model fitted is a straightforward extension of the Yule model with covariates (see \code{\link{yule.cov}}). Rather than having heterogeneity among lineages, the speciation probability is the same for all lineages at a given time, but can change through time. The function \code{birth} \emph{must} meet these two requirements: (i) the parameters to be estimated are the formal arguments; (ii) time is named \code{t} in the body of the function. However, this is the opposite for the primitive \code{BIRTH}: \code{t} is the formal argument, and the parameters are used in its body. See the examples. It is recommended to use \code{BIRTH} if possible, and required if speciation probability is constant on some time interval. If this primitive cannot be provided, a numerical integration is done with \code{\link[stats]{integrate}}. The standard-errors of the parameters are computed with the Hessian of the log-likelihood function. } \value{ An object of class \code{"yule"} (see \code{\link{yule}}). } \author{Emmanuel Paradis} \references{ Hubert, N., Paradis, E., Bruggemann, H. and Planes, S. (2011) Community assembly and diversification in Indo-Pacific coral reef fishes. \emph{Ecology and Evolution}, \bold{1}, 229--277. } \seealso{ \code{\link{branching.times}}, \code{\link{ltt.plot}}, \code{\link{birthdeath}}, \code{\link{yule}}, \code{\link{yule.cov}}, \code{\link{bd.time}} } \examples{ ### define two models... birth.logis <- function(a, b) 1/(1 + exp(-a*t - b)) # logistic birth.step <- function(l1, l2, Tcl) { # 2 rates with one break-point ans <- rep(l1, length(t)) ans[t > Tcl] <- l2 ans } ### ... and their primitives: BIRTH.logis <- function(t) log(exp(-a*t) + exp(b))/a + t BIRTH.step <- function(t) { out <- numeric(length(t)) sel <- t <= Tcl if (any(sel)) out[sel] <- t[sel] * l1 if (any(!sel)) out[!sel] <- Tcl * l1 + (t[!sel] - Tcl) * l2 out } data(bird.families) ### fit both models: yule.time(bird.families, birth.logis) yule.time(bird.families, birth.logis, BIRTH.logis) # same but faster \dontrun{yule.time(bird.families, birth.step)} # fails yule.time(bird.families, birth.step, BIRTH.step, opti = "nlminb", start = c(.01, .01, 100)) } \keyword{models} ape/man/diversity.contrast.test.Rd0000644000175100001440000001022312661134020016724 0ustar hornikusers\name{diversity.contrast.test} \alias{diversity.contrast.test} \title{Diversity Contrast Test} \description{ This function performs the diversity contrast test comparing pairs of sister-clades. } \usage{ diversity.contrast.test(x, method = "ratiolog", alternative = "two.sided", nrep = 0, ...) } \arguments{ \item{x}{a matrix or a data frame with at least two columns: the first one gives the number of species in clades with a trait supposed to increase or decrease diversification rate, and the second one the number of species in the sister-clades without the trait. Each row represents a pair of sister-clades.} \item{method}{a character string specifying the kind of test: \code{"ratiolog"} (default), \code{"proportion"}, \code{"difference"}, \code{"logratio"}, or any unambiguous abbreviation of these.} \item{alternative}{a character string defining the alternative hypothesis: \code{"two.sided"} (default), \code{"less"}, \code{"greater"}, or any unambiguous abbreviation of these.} \item{nrep}{the number of replications of the randomization test; by default, a Wilcoxon test is done.} \item{\dots}{arguments passed to the function \code{\link[stats]{wilcox.test}}.} } \details{ If \code{method = "ratiolog"}, the test described in Barraclough et al. (1996) is performed. If \code{method = "proportion"}, the version in Barraclough et al. (1995) is used. If \code{method = "difference"}, the signed difference is used (Sargent 2004). If \code{method = "logratio"}, then this is Wiegmann et al.'s (1993) version. These four tests are essentially different versions of the same test (Vamosi and Vamosi 2005, Vamosi 2007). See Paradis (2012) for a comparison of their statistical performance with other tests. If \code{nrep = 0}, a Wilcoxon test is done on the species diversity contrasts with the null hypothesis is that they are distributed around zero. If \code{nrep > 0}, a randomization procedure is done where the signs of the diversity contrasts are randomly chosen. This is used to create a distribution of the test statistic which is compared with the observed value (the sum of the diversity contrasts). } \value{ a single numeric value with the \emph{P}-value. } \references{ Barraclough, T. G., Harvey, P. H. and Nee, S. (1995) Sexual selection and taxonomic diversity in passerine birds. \emph{Proceedings of the Royal Society of London. Series B. Biological Sciences}, \bold{259}, 211--215. Barraclough, T. G., Harvey, P. H., and Nee, S. (1996) Rate of \emph{rbc}L gene sequence evolution and species diversification in flowering plants (angiosperms). \emph{Proceedings of the Royal Society of London. Series B. Biological Sciences}, \bold{263}, 589--591. Paradis, E. (2012) Shift in diversification in sister-clade comparisons: a more powerful test. \emph{Evolution}, \bold{66}, 288--295. Sargent, R. D. (2004) Floral symmetry affects speciation rates in angiosperms. \emph{Proceedings of the Royal Society of London. Series B. Biological Sciences}, \bold{271}, 603--608. Vamosi, S. M. (2007) Endless tests: guidelines for analysing non-nested sister-group comparisons. An addendum. \emph{Evolutionary Ecology Research}, \bold{9}, 717. Vamosi, S. M. and Vamosi, J. C. (2005) Endless tests: guidelines for analysing non-nested sister-group comparisons. \emph{Evolutionary Ecology Research}, \bold{7}, 567--579. Wiegmann, B., Mitter, C. and Farrell, B. 1993. Diversification of carnivorous parasitic insects: extraordinary radiation or specialized dead end? \emph{American Naturalist}, \bold{142}, 737--754. } \author{Emmanuel Paradis} \seealso{ \code{\link{slowinskiguyer.test}}, \code{\link{mcconwaysims.test}} \code{\link{richness.yule.test}} } \examples{ ### data from Vamosi & Vamosi (2005): fleshy <- c(1, 1, 1, 1, 1, 3, 3, 5, 9, 16, 33, 40, 50, 100, 216, 393, 850, 947,1700) dry <- c(2, 64, 300, 89, 67, 4, 34, 10, 150, 35, 2, 60, 81, 1, 3, 1, 11, 1, 18) x <- cbind(fleshy, dry) diversity.contrast.test(x) diversity.contrast.test(x, alt = "g") diversity.contrast.test(x, alt = "g", nrep = 1e4) slowinskiguyer.test(x) mcconwaysims.test(x) } \keyword{htest} ape/man/slowinskiguyer.test.Rd0000644000175100001440000000466611736206516016176 0ustar hornikusers\name{slowinskiguyer.test} \alias{slowinskiguyer.test} \title{Slowinski-Guyer Test of Homogeneous Diversification} \description{ This function performs the Slowinski--Guyer test that a trait or variable does not increase diversification rate. } \usage{ slowinskiguyer.test(x, detail = FALSE) } \arguments{ \item{x}{a matrix or a data frame with at least two columns: the first one gives the number of species in clades with a trait supposed to increase diversification rate, and the second one the number of species in the corresponding sister-clade without the trait. Each row represents a pair of sister-clades.} \item{detail}{if \code{TRUE}, the individual P-values are appended.} } \details{ The Slowinski--Guyer test compares a series of sister-clades where one of the two is characterized by a trait supposed to increase diversification rate. The null hypothesis is that the trait does not affect diversification. If the trait decreased diversification rate, then the null hypothesis cannot be rejected. The present function has mainly a historical interest. The Slowinski--Guyer test generally performs poorly: see Paradis (2012) alternatives and the functions cited below. } \value{ a data frame with the \eqn{\chi^2}{chi2}, the number of degrees of freedom, and the \emph{P}-value. If \code{detail = TRUE}, a list is returned with the data frame and a vector of individual \emph{P}-values for each pair of sister-clades. } \references{ Paradis, E. (2012) Shift in diversification in sister-clade comparisons: a more powerful test. \emph{Evolution}, \bold{66}, 288--295. Slowinski, J. B. and Guyer, C. (1993) Testing whether certain traits have caused amplified diversification: an improved method based on a model of random speciation and extinction. \emph{American Naturalist}, \bold{142}, 1019--1024. } \author{Emmanuel Paradis} \seealso{ \code{\link{balance}}, \code{\link{mcconwaysims.test}}, \code{\link{diversity.contrast.test}}, \code{\link{richness.yule.test}}, \code{\link[geiger]{rc}} in \pkg{geiger}, \code{\link[apTreeshape]{shift.test}} in \pkg{apTreeshape} } \examples{ ### from Table 1 in Slowinski and Guyer(1993): viviparous <- c(98, 8, 193, 36, 7, 128, 2, 3, 23, 70) oviparous <- c(234, 17, 100, 4, 1, 12, 6, 1, 481, 11) x <- data.frame(viviparous, oviparous) slowinskiguyer.test(x, TRUE) # 'P ~ 0.32' in the paper xalt <- x xalt[3, 2] <- 1 slowinskiguyer.test(xalt) } \keyword{htest} ape/man/chiroptera.Rd0000644000175100001440000000137410775732361014257 0ustar hornikusers\name{chiroptera} \alias{chiroptera} \title{Bat Phylogeny} \description{ This phylogeny of bats (Mammalia: Chiroptera) is a supertree (i.e. a composite phylogeny constructed from several sources; see source for details). } \usage{ data(chiroptera) } \format{ The data are stored in RData (binary) format. } \source{ Jones, K. E., Purvis, A., MacLarnon, A., Bininda-Emonds, O. R. P. and Simmons, N. B. (2002) A phylogenetic supertree of the bats (Mammalia: Chiroptera). \emph{Biological Reviews of the Cambridge Philosophical Society}, \bold{77}, 223--259. } \seealso{ \code{\link{read.nexus}}, \code{\link{zoom}} } \examples{ data(chiroptera) str(chiroptera) op <- par() par(cex = 0.3) plot(chiroptera, type = "c") par(op) } \keyword{datasets} ape/man/as.phylo.Rd0000644000175100001440000000663612610174525013652 0ustar hornikusers\name{as.phylo} \alias{as.phylo} \alias{as.phylo.hclust} \alias{as.phylo.phylog} \alias{as.hclust.phylo} \alias{old2new.phylo} \alias{new2old.phylo} \alias{as.network.phylo} \alias{as.igraph} \alias{as.igraph.phylo} \title{Conversion Among Tree and Network Objects} \description{ \code{as.phylo} is a generic function which converts an object into a tree of class \code{"phylo"}. There are currently two methods for objects of class \code{"hclust"} and of class \code{"phylog"} (implemented in the package ade4). \code{as.hclust.phylo} is a method of the generic \code{\link[stats]{as.hclust}} which converts an object of class \code{"phylo"} into one of class \code{"hclust"}. This can used to convert an object of class \code{"phylo"} into one of class \code{"dendrogram"} (see examples). \code{as.network} and \code{as.igraph} convert trees of class \code{"phylo"} into these respective classes defined in the packages of the same names (where the generics are defined). \code{old2new.phylo} and \code{new2old.phylo} are utility functions for converting between the old and new coding of the class \code{"phylo"}. } \usage{ as.phylo(x, ...) \method{as.phylo}{hclust}(x, ...) \method{as.phylo}{phylog}(x, ...) \method{as.hclust}{phylo}(x, ...) old2new.phylo(phy) new2old.phylo(phy) \method{as.network}{phylo}(x, directed = is.rooted(x), ...) \method{as.igraph}{phylo}(x, directed = is.rooted(x), use.labels = TRUE, ...) } \arguments{ \item{x}{an object to be converted into another class.} \item{directed}{a logical value: should the network be directed? By default, this depends on whether the tree is rooted or not.} \item{use.labels}{a logical specifying whether to use labels to build the network of class \code{"igraph"}. If \code{TRUE} and the tree has no node labels, then some default labels are created first. If \code{FALSE}, the network is built with integers.} \item{\dots}{further arguments to be passed to or from other methods.} \item{phy}{an object of class \code{"phylo"}.} } \value{ An object of class \code{"hclust"}, \code{"phylo"}, \code{"network"}, or \code{"igraph"}. } \note{ In an object of class \code{"hclust"}, the \code{height} gives the distance between the two sets that are being agglomerated. So these distances are divided by two when setting the branch lengths of a phylogenetic tree. } \author{Emmanuel Paradis} \seealso{ \code{\link[stats]{hclust}}, \code{\link[stats]{as.hclust}}, \code{\link[stats]{dendrogram}}, \code{\link[ade4]{phylog}}, \code{\link{as.phylo.formula}} } \examples{ data(bird.orders) hc <- as.hclust(bird.orders) tr <- as.phylo(hc) all.equal(bird.orders, tr) # TRUE ### shows the three plots for tree objects: dend <- as.dendrogram(hc) layout(matrix(c(1:3, 3), 2, 2)) plot(bird.orders, font = 1) plot(hc) par(mar = c(8, 0, 0, 0)) # leave space for the labels plot(dend) ### how to get identical plots with ### plot.phylo and plot.dendrogram: layout(matrix(1:2, 2, 1)) plot(bird.orders, font = 1, no.margin = TRUE, label.offset = 0.4) par(mar = c(0, 0, 0, 8)) plot(dend, horiz = TRUE) layout(1) \dontrun{ ### convert into networks: if (require(network)) { x <- as.network(rtree(10)) print(x) plot(x, vertex.cex = 1:4) plot(x, displaylabels = TRUE) } tr <- rtree(5) if (require(igraph)) { print((x <- as.igraph(tr))) plot(x) print(as.igraph(tr, TRUE, FALSE)) print(as.igraph(tr, FALSE, FALSE)) } } } \keyword{manip} ape/man/lmorigin.Rd0000644000175100001440000001216611540425707013732 0ustar hornikusers\name{lmorigin} \alias{lmorigin} \alias{print.lmorigin} \alias{lmorigin.ex1} \alias{lmorigin.ex2} \title{ Multiple regression through the origin } \description{ Function \code{\link{lmorigin}} computes a multiple linear regression and performs tests of significance of the equation parameters (F-test of R-square and t-tests of regression coefficients) using permutations. The regression line can be forced through the origin. Testing the significance in that case requires a special permutation procedure. This option was developed for the analysis of independent contrasts, which requires regression through the origin. A permutation test, described by Legendre & Desdevises (2009), is needed to analyze contrasts that are not normally distributed. } \usage{ lmorigin(formula, data, origin=TRUE, nperm=999, method=NULL, silent=FALSE) } \arguments{ \item{formula }{ A formula specifying the bivariate model, as in \code{\link{lm}} and \code{\link{aov}}. } \item{data}{ A data frame containing the two variables specified in the formula. } \item{origin}{ \code{origin = TRUE} (default) to compute regression through the origin; \code{origin = FALSE} to compute multiple regression with estimation of the intercept. } \item{nperm}{ Number of permutations for the tests. If \code{nperm = 0}, permutation tests will not be computed. The default value is \code{nperm = 999}. For large data files, the permutation test is rather slow since the permutation procedure is not compiled. } \item{method}{ \code{method = "raw"} computes t-tests of the regression coefficients by permutation of the raw data. \code{method = "residuals"} computes t-tests of the regression coefficients by permutation of the residuals of the full model. If \code{method = NULL}, permutation of the raw data is used to test the regression coefficients in regression through the origin; permutation of the residuals of the full model is used to test the regression coefficients in ordinary multiple regression. } \item{silent}{ Informative messages and the time to compute the tests will not be written to the \R console if silent=TRUE. Useful when the function is called by a numerical simulation function. } } \details{ The permutation F-test of R-square is always done by permutation of the raw data. When there is a single explanatory variable, permutation of the raw data is used for the t-test of the single regression coefficient, whatever the method chosen by the user. The rationale is found in Anderson & Legendre (1999). The \code{print.lmorigin} function prints out the results of the parametric tests (in all cases) and the results of the permutational tests (when nperm > 0). } \value{ \item{reg }{The regression output object produced by function \code{lm}. } \item{p.param.t.2tail }{Parametric probabilities for 2-tailed tests of the regression coefficients. } \item{p.param.t.1tail }{Parametric probabilities for 1-tailed tests of the regression coefficients. Each test is carried out in the direction of the sign of the coefficient. } \item{p.perm.t.2tail }{Permutational probabilities for 2-tailed tests of the regression coefficients. } \item{p.perm.t.1tail }{Permutational probabilities for 1-tailed tests of the regression coefficients. Each test is carried out in the direction of the sign of the coefficient. } \item{p.perm.F }{Permutational probability for the F-test of R-square. } \item{origin }{TRUE is regression through the origin has been computed, FALSE if multiple regression with estimation of the intercept has been used. } \item{nperm }{Number of permutations used in the permutation tests. } \item{method }{Permutation method for the t-tests of the regression coefficients: \code{method = "raw"} or \code{method = "residuals"}. } \item{var.names }{Vector containing the names of the variables used in the regression. } \item{call }{The function call.} } \author{ Pierre Legendre, Universite de Montreal } \references{ Anderson, M. J. and Legendre, P. (1999) An empirical comparison of permutation methods for tests of partial regression coefficients in a linear model. \emph{Journal of Statistical Computation and Simulation}, \bold{62}, 271--303. Legendre, P. and Desdevises, Y. (2009) Independent contrasts and regression through the origin. \emph{Journal of Theoretical Biology}, \bold{259}, 727--743. Sokal, R. R. and Rohlf, F. J. (1995) \emph{Biometry - The principles and practice of statistics in biological research. Third edition.} New York: W. H. Freeman. } \examples{ ## Example 1 from Sokal & Rohlf (1995) Table 16.1 ## SO2 air pollution in 41 cities of the USA data(lmorigin.ex1) out <- lmorigin(SO2 ~ ., data=lmorigin.ex1, origin=FALSE, nperm=99) out ## Example 2: Contrasts computed on the phylogenetic tree of Lamellodiscus ## parasites. Response variable: non-specificity index (NSI); explanatory ## variable: maximum host size. Data from Table 1 of Legendre & Desdevises ## (2009). data(lmorigin.ex2) out <- lmorigin(NSI ~ MaxHostSize, data=lmorigin.ex2, origin=TRUE, nperm=99) out ## Example 3: random numbers y <- rnorm(50) X <- as.data.frame(matrix(rnorm(250),50,5)) out <- lmorigin(y ~ ., data=X, origin=FALSE, nperm=99) out } \keyword{ multivariate } ape/man/ltt.plot.Rd0000644000175100001440000001540312304606545013667 0ustar hornikusers\name{ltt.plot} \alias{ltt.plot} \alias{ltt.lines} \alias{mltt.plot} \alias{ltt.coplot} \alias{ltt.plot.coords} \title{Lineages Through Time Plot} \description{ These functions provide tools for plotting the numbers of lineages through time from phylogenetic trees. } \usage{ ltt.plot(phy, xlab = "Time", ylab = "N", backward = TRUE, tol = 1e-6, ...) ltt.lines(phy, backward = TRUE, tol = 1e-6, ...) mltt.plot(phy, ..., dcol = TRUE, dlty = FALSE, legend = TRUE, xlab = "Time", ylab = "N", log = "", backward = TRUE, tol = 1e-6) ltt.coplot(phy, backward = TRUE, ...) ltt.plot.coords(phy, backward = TRUE, tol = 1e-6) } \arguments{ \item{phy}{an object of class \code{"phylo"}; this could be an object of class \code{"multiPhylo"} in the case of \code{mltt.plot}.} \item{xlab}{a character string (or a variable of mode character) giving the label for the \eqn{x}-axis (default is "Time").} \item{ylab}{idem for the \eqn{y}-axis (default is "N").} \item{backward}{a logical value: should the time axis be traced from the present (the default), or from the root of the tree?} \item{tol}{a numeric value (see details).} \item{\dots}{in the cases of \code{ltt.plot()}, \code{ltt.lines()}, or \code{ltt.coplot()} these are further (graphical) arguments to be passed to \code{plot()}, \code{lines()}, or \code{plot.phylo()}, respectively (see details on how to transform the axes); in the case of \code{mltt.plot()} these are additional trees to be plotted (see details).} \item{dcol}{a logical specifying whether the different curves should be differentiated with colors (default is \code{TRUE}).} \item{dlty}{a logical specifying whether the different curves should be differentiated with patterns of dots and dashes (default is \code{FALSE}).} \item{legend}{a logical specifying whether a legend should be plotted.} \item{log}{a character string specifying which axis(es) to be log-transformed; must be one of the followings: \code{""}, \code{"x"}, \code{"y"}, or \code{"xy"}.} } \details{ \code{ltt.plot} does a simple lineages through time (LTT) plot. Additional arguments (\code{\dots}) may be used to change, for instance, the limits on the axes (with \code{xlim} and/or \code{ylim}) or other graphical settings (\code{col} for the color, \code{lwd} for the line thickness, \code{lty} for the line type may be useful; see \code{\link[graphics]{par}} for an exhaustive listing of graphical parameters). The \eqn{y}-axis can be log-transformed by adding the following option: \code{log = "y"}. The option \code{tol} is used as follows: first the most distant tip from the root is found, then all tips whose distance to the root is not different from the previous one more than \code{tol} are considered to be contemporaneous with it. If the tree is not ultrametric, the plot is done assuming the tips, except the most distant from the root, represent extinction events. If a root edge is present, it is taken into account. \code{ltt.lines} adds a LTT curve to an existing plot. Additional arguments (\code{\dots}) may be used to change the settings of the added line. \code{mltt.plot} does a multiple LTT plot taking as arguments one or several trees. These trees may be given as objects of class \code{"phylo"} (single trees) and/or \code{"multiPhylo"} (multiple trees). Any number of objects may be given. This function is mainly for exploratory analyses with the advantages that the axes are set properly to view all lines, and the legend is plotted by default. The plot will certainly make sense if all trees have their most-distant-from-the-root tips contemporaneous (i.e., trees with only extinct lineages will not be represented properly). For more flexible settings of line drawings, it may be better to combine \code{ltt.plot()} with successive calls of \code{ltt.lines()} (see examples). \code{ltt.coplot} is meant to show how to set a tree and a LTT plots on the same scales. All extra arguments modify only the appearance of the tree. The code can be easily edited and tailored. } \value{ \code{ltt.plot.coords} returns a two-column matrix with the time points and the number of lineages, respectively. The \eqn{i}th value of the second column is the number of lineages for the interval defined by the \eqn{(i - 1)}th and the \eqn{i}th values of the first column. These are then plotted with the option \code{type = "S"} by the other functions. } \references{ Harvey, P. H., May, R. M. and Nee, S. (1994) Phylogenies without fossils. \emph{Evolution}, \bold{48}, 523--529. Nee, S., Holmes, E. C., Rambaut, A. and Harvey, P. H. (1995) Inferring population history from molecular phylogenies. \emph{Philosophical Transactions of the Royal Society of London. Series B. Biological Sciences}, \bold{349}, 25--31. } \author{Emmanuel Paradis} \seealso{ \code{\link{kronoviz}}, \code{\link{skyline}}, \code{\link{LTT}}, \code{\link{branching.times}}, \code{\link{birthdeath}}, \code{\link{bd.ext}}, \code{\link{yule.cov}}, \code{\link{bd.time}}; \code{\link[graphics]{plot}} for the basic plotting function in R } \examples{ data(bird.families) opar <- par(mfrow = c(2, 1)) ltt.plot(bird.families) title("Lineages Through Time Plot of the Bird Families") ltt.plot(bird.families, log = "y") title(main = "Lineages Through Time Plot of the Bird Families", sub = "(with logarithmic transformation of the y-axis)") par(opar) ### to plot the tree and the LTT plot together data(bird.orders) layout(matrix(1:4, 2, 2)) plot(bird.families, show.tip.label = FALSE) ltt.plot(bird.families, main = "Bird families") plot(bird.orders, show.tip.label = FALSE) ltt.plot(bird.orders, main = "Bird orders") layout(1) ### better with ltt.coplot(): ltt.coplot(bird.families, show.tip.label = FALSE, x.lim = 27.5) data(chiroptera) chiroptera <- compute.brlen(chiroptera) ltt.coplot(chiroptera, show.tip.label = FALSE, type = "c") ### with extinct lineages and a root edge: omar <- par("mar") set.seed(31) tr <- rlineage(0.2, 0.15) tr$root.edge <- 5 ltt.coplot(tr, show.tip.label = FALSE, x.lim = 55) ## compare with: ## ltt.coplot(drop.fossil(tr), show.tip.label = FALSE) layout(1) par(mar = omar) mltt.plot(bird.families, bird.orders) ### Generates 10 random trees with 23 tips: TR <- replicate(10, rcoal(23), FALSE) ### Give names to each tree: names(TR) <- paste("random tree", 1:10) ### And specify the class of the list so that mltt.plot() ### does not trash it! class(TR) <- "multiPhylo" mltt.plot(TR, bird.orders) ### And now for something (not so) completely different: ltt.plot(bird.orders, lwd = 2) for (i in 1:10) ltt.lines(TR[[i]], lty = 2) legend(-20, 10, lwd = c(2, 1), lty = c(1, 2), bty = "n", legend = c("Bird orders", "Random (coalescent) trees")) } \keyword{hplot} \keyword{aplot} ape/man/dist.topo.Rd0000644000175100001440000000531213015651141014020 0ustar hornikusers\name{dist.topo} \alias{dist.topo} \title{Topological Distances Between Two Trees} \description{ This function computes the topological distance between two phylogenetic trees or among trees in a list (if \code{y = NULL} using different methods. } \usage{ dist.topo(x, y = NULL, method = "PH85") } \arguments{ \item{x}{an object of class \code{"phylo"} or of class \code{"multiPhylo"}.} \item{y}{an (optional) object of class \code{"phylo"}.} \item{method}{a character string giving the method to be used: either \code{"PH85"}, or \code{"score"}.} } \value{ a single numeric value. } \details{ Two methods are available: the one by Penny and Hendy (1985, originally from Robinson and Foulds 1981), and the branch length score by Kuhner and Felsenstein (1994). The trees are always considered as unrooted. The topological distance is defined as twice the number of internal branches defining different bipartitions of the tips (Robinson and Foulds 1981; Penny and Hendy 1985). Rzhetsky and Nei (1992) proposed a modification of the original formula to take multifurcations into account. The branch length score may be seen as similar to the previous distance but taking branch lengths into account. Kuhner and Felsenstein (1994) proposed to calculate the square root of the sum of the squared differences of the (internal) branch lengths defining similar bipartitions (or splits) in both trees. } \note{ The geodesic distance of Billera et al. (2001) has been disabled: see the package \pkg{distory} on CRAN. } \references{ Billera, L. J., Holmes, S. P. and Vogtmann, K. (2001) Geometry of the space of phylogenetic trees. \emph{Advances in Applied Mathematics}, \bold{27}, 733--767. Kuhner, M. K. and Felsenstein, J. (1994) Simulation comparison of phylogeny algorithms under equal and unequal evolutionary rates. \emph{Molecular Biology and Evolution}, \bold{11}, 459--468. Nei, M. and Kumar, S. (2000) \emph{Molecular Evolution and Phylogenetics}. Oxford: Oxford University Press. Penny, D. and Hendy, M. D. (1985) The use of tree comparison metrics. \emph{Systemetic Zoology}, \bold{34}, 75--82. Robinson, D. F. and Foulds, L. R. (1981) Comparison of phylogenetic trees. \emph{Mathematical Biosciences}, \bold{53}, 131--147. Rzhetsky, A. and Nei, M. (1992) A simple method for estimating and testing minimum-evolution trees. \emph{Molecular Biology and Evolution}, \bold{9}, 945--967. } \author{Emmanuel Paradis} \seealso{ \code{\link{read.tree}} to read tree files in Newick format, \code{\link{cophenetic.phylo}}, \code{\link{prop.part}} } \examples{ ta <- rtree(30) tb <- rtree(30) dist.topo(ta, ta) # 0 dist.topo(ta, tb) # unlikely to be 0 } \keyword{manip} ape/man/bionj.Rd0000644000175100001440000000231211746762253013213 0ustar hornikusers\name{BIONJ} \alias{bionj} \title{ Tree Estimation Based on an Improved Version of the NJ Algorithm } \description{ This function performs the BIONJ algorithm of Gascuel (1997). } \usage{ bionj(X) } \arguments{ \item{X}{a distance matrix; may be an object of class \code{"dist"}.} } \value{ an object of class \code{"phylo"}. } \references{ Gascuel, O. (1997) BIONJ: an improved version of the NJ algorithm based on a simple model of sequence data. \emph{Molecular Biology and Evolution}, \bold{14:}, 685--695. } \author{ original C code by Hoa Sien Cuong and Olivier Gascuel; adapted and ported to \R by Vincent Lefort \email{vincent.lefort@lirmm.fr} } \seealso{ \code{\link{nj}}, \code{\link{fastme}}, \code{\link{mvr}}, \code{\link{bionjs}}, \code{\link{SDM}}, \code{\link{dist.dna}} } \examples{ ### From Saitou and Nei (1987, Table 1): x <- c(7, 8, 11, 13, 16, 13, 17, 5, 8, 10, 13, 10, 14, 5, 7, 10, 7, 11, 8, 11, 8, 12, 5, 6, 10, 9, 13, 8) M <- matrix(0, 8, 8) M[lower.tri(M)] <- x M <- t(M) M[lower.tri(M)] <- x dimnames(M) <- list(1:8, 1:8) tr <- bionj(M) plot(tr, "u") ### a less theoretical example data(woodmouse) trw <- bionj(dist.dna(woodmouse)) plot(trw) } \keyword{models} ape/man/read.caic.Rd0000644000175100001440000000326412033451344013714 0ustar hornikusers\name{read.caic} \alias{read.caic} \title{Read Tree File in CAIC Format} \description{ This function reads one tree from a CAIC file. A second file containing branch lengths values may also be passed (experimental). } \usage{ read.caic(file, brlen = NULL, skip = 0, comment.char = "#", ...) } \arguments{ \item{file}{a file name specified by either a variable of mode character, or a double-quoted string.} \item{brlen}{a file name for the branch lengths file.} \item{skip}{the number of lines of the input file to skip before beginning to read data (this is passed directly to scan()).} \item{comment.char}{a single character, the remaining of the line after this character is ignored (this is passed directly to scan()).} \item{\dots}{Further arguments to be passed to scan().} } \details{ Read a tree from a file in the format used by the CAIC and MacroCAIc program. } \value{ an object of class \code{"phylo"}. } \references{ Purvis, A. and Rambaut, A. (1995) Comparative analysis by independent contrasts (CAIC): an Apple Macintosh application for analysing comparative data. \emph{CABIOS}, \bold{11} :241--251. } \author{Julien Dutheil \email{julien.dutheil@univ-montp2.fr}} \section{Warning }{The branch length support is still experimental and was not fully tested.} \seealso{ \code{\link{read.tree}}, \code{\link{read.nexus}} } \examples{ ### The same example than in read.tree, without branch lengths. ### An extract from Sibley and Ahlquist (1990) cat("AAA","Strix_aluco","AAB","Asio_otus", "AB","Athene_noctua","B","Tyto_alba", file = "ex.tre", sep = "\n") tree.owls <- read.caic("ex.tre") plot(tree.owls) tree.owls unlink("ex.tre") # delete the file "ex.tre" } \keyword{hplot} ape/man/image.DNAbin.Rd0000644000175100001440000000542213016363577014271 0ustar hornikusers\name{image.DNAbin} \alias{image.DNAbin} \title{Plot of DNA Sequence Alignement} \description{ This function plots an image of an alignment of nucleotide sequences. } \usage{ \method{image}{DNAbin}(x, what, col, bg = "white", xlab = "", ylab = "", show.labels = TRUE, cex.lab = 1, legend = TRUE, ...) } \arguments{ \item{x}{a matrix of DNA sequences (class \code{"DNAbin"}).} \item{what}{a vector of characters specifying the bases to visualize. If missing, this is set to ``a'', ``g'', ``c'', ``t'', ``n'', and ``-'' (in this order).} \item{col}{a vector of colours. If missing, this is set to ``red'', ``yellow'', ``green'', ``blue'', ``grey'', and ``black''. If it is shorter (or longer) than \code{what}, it is recycled (or shortened).} \item{bg}{the colour used for nucleotides whose base is not among \code{what}.} \item{xlab}{the label for the \emph{x}-axis; none by default.} \item{ylab}{Idem for the \emph{y}-axis. Note that by default, the labels of the sequences are printed on the \emph{y}-axis (see next option).} \item{show.labels}{a logical controlling whether the sequence labels are printed (\code{TRUE} by default).} \item{cex.lab}{a single numeric controlling the size of the sequence labels. Use \code{cex.axis} to control the size of the annotations on the \emph{x}-axis.} \item{legend}{a logical controlling whether the legend is plotted (\code{TRUE} by default).} \item{\dots}{further arguments passed to \code{\link[graphics]{image.default}} (e.g., \code{cex.axis}).} } \details{ The idea of this function is to allow flexible plotting and colouring of a nucleotide alignment. By default, the most common bases (a, g, c, t, and n) and alignment gap are plotted using a standard colour scheme. It is possible to plot only one base specified as \code{what} with a chosen colour: this might be useful to check, for instance, the distribution of alignment gaps (\code{image(x, "-")}) or missing data (see examples). } \author{Emmanuel Paradis} \seealso{ \code{\link{DNAbin}}, \code{\link{del.gaps}}, \code{\link{alex}}, \code{\link{alview}}, \code{\link{all.equal.DNAbin}}, \code{\link{clustal}}, \code{\link[graphics]{grid}}, \code{\link{image.AAbin}} } \examples{ data(woodmouse) image(woodmouse) rug(seg.sites(woodmouse), -0.02, 3, 1) image(woodmouse, "n", "blue") # show missing data image(woodmouse, c("g", "c"), "green") # G+C par(mfcol = c(2, 2)) ### barcoding style: for (x in c("a", "g", "c", "t")) image(woodmouse, x, "black", cex.lab = 0.5, cex.axis = 0.7) par(mfcol = c(1, 1)) ### zoom on a portion of the data: image(woodmouse[11:15, 1:50], c("a", "n"), c("blue", "grey")) grid(50, 5, col = "black") ### see the guanines on a black background: image(woodmouse, "g", "yellow", "black") } \keyword{hplot} ape/man/reconstruct.Rd0000644000175100001440000001072212744636626014474 0ustar hornikusers\name{reconstruct} \alias{reconstruct} \title{Continuous Ancestral Character Estimation} \description{ This function estimates ancestral character states, and the associated uncertainty, for continuous characters. It mainly works as the ace function, from which it differs, first, in the fact that computations are not performed by numerical optimisation but through matrix calculus. Second, besides classical Brownian-based reconstruction methods, it reconstructs ancestral states under Arithmetic Brownian Motion (ABM, i.e. Brownian with linear trend) and Ornstein-Uhlenbeck process (OU, i.e. Brownian with an attractive optimum). } \usage{ reconstruct(x, phyInit, method = "ML", alpha = NULL, CI = TRUE) } \arguments{ \item{x}{a numerical vector.} \item{phyInit}{an object of class \code{"phylo"}.} \item{method}{a character specifying the method used for estimation. Six choices are possible: \code{"ML"}, \code{"REML"}, \code{"GLS"}, \code{"GLS_ABM"}, \code{"GLS_OU"} or \code{"GLS_OUS"}.} \item{alpha}{a numerical value which accounts for the attractive strength parameter of \code{"GLS_OU"} or \code{"GLS_OUS"} (used only in these cases). If alpha = NULL (the default), then it is estimated by maximum likelihood using \code{optim} which may lead to convergence issue.} \item{CI}{a logical specifying whether to return the 95\% confidence intervals of the ancestral state estimates.} } \details{ For \code{"ML"}, \code{"REML"} and \code{"GLS"}, the default model is Brownian motion. This model can be fitted by maximum likelihood (\code{method = "ML"}, Felsenstein 1973, Schluter et al. 1997) - the default, residual maximum likelihood (\code{method = "REML"}), or generalized least squares (\code{method = "GLS"}, Martins and Hansen 1997, Garland T and Ives AR 2000). \code{"GLS_ABM"} is based on Brownian motion with trend model. Both \code{"GLS_OU"} and \code{"GLS_OUS"} are based on Ornstein-Uhlenbeck model. \code{"GLS_OU"} and \code{"GLS_OUS"} differs in the fact that \code{"GLS_OUS"} assume that the process starts from the optimum, while the root state has to be estimated for \code{"GLS_OU"}, which may rise some issues (see Royer-Carenzi and Didier, 2016). Users may provide the attractive strength parameter \code{alpha}, for these two models. \code{"GLS_ABM"}, \code{"GLS_OU"} and \code{"GLS_OUS"} are all fitted by generalized least squares (Royer-Carenzi and Didier, 2016). } \value{ an object of class \code{"ace"} with the following elements: \item{ace}{the estimates of the ancestral character values.} \item{CI95}{the estimated 95\% confidence intervals.} \item{sigma2}{if \code{method = "ML"}, the maximum likelihood estimate of the Brownian parameter.} \item{loglik}{if \code{method = "ML"}, the maximum log-likelihood.} } \references{ Felsenstein, J. (1973) Maximum likelihood estimation of evolutionary trees from continuous characters. \emph{American Journal of Human Genetics}, \bold{25}, 471--492. Garland T. and Ives A.R. (2000) Using the past to predict the present: confidence intervals for regression equations in phylogenetic comparative methods. \emph{American Naturalist}, \bold{155}, 346--364. Martins, E. P. and Hansen, T. F. (1997) Phylogenies and the comparative method: a general approach to incorporating phylogenetic information into the analysis of interspecific data. \emph{American Naturalist}, \bold{149}, 646--667. Royer-Carenzi, M. and Didier, G. (2016) A comparison of ancestral state reconstruction methods for quantitative characters. \emph{Journal of Theoretical Biology}, \bold{404}, 126--142. Schluter, D., Price, T., Mooers, A. O. and Ludwig, D. (1997) Likelihood of ancestor states in adaptive radiation. \emph{Evolution}, \bold{51}, 1699--1711. Yang, Z. (2006) \emph{Computational Molecular Evolution}. Oxford: Oxford University Press. } \author{Manuela Royer-Carenzi, Gilles Didier} \seealso{ \code{\link{MPR}}, \code{\link{corBrownian}}, \code{\link{compar.ou}} Reconstruction of ancestral sequences can be done with the package \pkg{phangorn} (see function \code{?ancestral.pml}). } \note{ \code{GLS_ABM} should not be used on ultrametric tree. \code{GLS_OU} may lead to aberrant reconstructions. } \examples{ ### Some random data... data(bird.orders) x <- rnorm(23, m=100) ### Reconstruct ancestral quantitative characters: reconstruct(x, bird.orders) reconstruct(x, bird.orders, method = "GLS_OUS", alpha=NULL) } \keyword{models} ape/man/mst.Rd0000644000175100001440000000567012425450445012717 0ustar hornikusers\name{mst} \alias{mst} \alias{plot.mst} \title{Minimum Spanning Tree} \usage{ mst(X) \method{plot}{mst}(x, graph = "circle", x1 = NULL, x2 = NULL, \dots) } \arguments{ \item{X}{either a matrix that can be interpreted as a distance matrix, or an object of class \code{"dist"}.} \item{x}{an object of class \code{"mst"} (e.g. returned by \code{mst()}).} \item{graph}{a character string indicating the type of graph to plot the minimum spanning tree; two choices are possible: \code{"circle"} where the observations are plotted regularly spaced on a circle, and \code{"nsca"} where the two first axes of a non-symmetric correspondence analysis are used to plot the observations (see Details below). If both arguments \code{x1} and \code{x2} are given, the argument \code{graph} is ignored.} \item{x1}{a numeric vector giving the coordinates of the observations on the \emph{x}-axis. Both \code{x1} and \code{x2} must be specified to be used.} \item{x2}{a numeric vector giving the coordinates of the observations on the \emph{y}-axis. Both \code{x1} and \code{x2} must be specified to be used.} \item{\dots}{further arguments to be passed to \code{plot()}.} } \description{ The function \code{mst} finds the minimum spanning tree between a set of observations using a matrix of pairwise distances. The \code{plot} method plots the minimum spanning tree showing the links where the observations are identified by their numbers. } \details{ These functions provide two ways to plot the minimum spanning tree which try to space as much as possible the observations in order to show as clearly as possible the links. The option \code{graph = "circle"} simply plots regularly the observations on a circle, whereas \code{graph = "nsca"} uses a non-symmetric correspondence analysis where each observation is represented at the centroid of its neighbours. Alternatively, the user may use any system of coordinates for the obsevations, for instance a principal components analysis (PCA) if the distances were computed from an original matrix of continous variables. } \value{ an object of class \code{"mst"} which is a square numeric matrix of size equal to the number of observations with either \code{1} if a link between the corresponding observations was found, or \code{0} otherwise. The names of the rows and columns of the distance matrix, if available, are given as rownames and colnames to the returned object. } \author{ Yvonnick Noel \email{noel@univ-lille3.fr}, Julien Claude \email{Julien.Claude@univ-montp2.fr} and Emmanuel Paradis } \seealso{ \code{\link{dist.dna}}, \code{\link{dist.gene}}, \code{\link[stats]{dist}}, \code{\link[graphics]{plot}} } \examples{ require(stats) X <- matrix(runif(200), 20, 10) d <- dist(X) PC <- prcomp(X) M <- mst(d) opar <- par() par(mfcol = c(2, 2)) plot(M) plot(M, graph = "nsca") plot(M, x1 = PC$x[, 1], x2 = PC$x[, 2]) par(opar) } \keyword{multivariate} ape/man/treePop.Rd0000644000175100001440000000065111647473757013544 0ustar hornikusers\name{treePop} \alias{treePop} \title{Tree Popping} \description{ Method for reconstructing phylogenetic trees from an object of class splits using tree popping. } \usage{ treePop(obj) } \arguments{ \item{obj}{an object of class \code{"bitsplit"}.} } \value{ an object of class "phylo" which displays all the splits in the input object. } \author{Andrei Popescu \email{niteloserpopescu@gmail.com}} \keyword{models} ape/man/all.equal.DNAbin.Rd0000644000175100001440000000420213016363444015051 0ustar hornikusers\name{all.equal.DNAbin} \alias{all.equal.DNAbin} \title{Compare DNA Sets} \description{ Comparison of DNA sequence sets, particularly when aligned. } \usage{ \method{all.equal}{DNAbin}(target, current, plot = FALSE, ...) } \arguments{ \item{target, current}{the two sets of sequences to be compared.} \item{plot}{a logical value specifying whether to plot the sites that are different (only if the labels of both alignments are the same).} \item{\dots}{further arguments passed to \code{\link{image.DNAbin}}.} } \details{ If the two sets of DNA sequences are exactly identical, this function returns \code{TRUE}. Otherwise, a detailed comparison is made only if the labels (i.e., rownames) of \code{target} and \code{current} are the same (possibly in different orders). In all other cases, a brief description of the differences is returned (sometimes with recommendations to make further comparisons). This function can be used for testing in programs using \code{\link[base]{isTRUE}} (see examples below). } \value{ \code{TRUE} if the two sets are identical; a list with two elements (message and different.sites) if a detailed comparison is done; or a vector of mode character. } \author{Emmanuel Paradis} \seealso{ \code{\link{image.DNAbin}}, \code{\link{clustal}}, \code{\link{checkAlignment}}, the generic function: \code{\link[base]{all.equal}} } \examples{ data(woodmouse) woodm2 <- woodmouse woodm2[1, c(1:5, 10:12, 30:40)] <- as.DNAbin("g") res <- all.equal(woodmouse, woodm2, plot = TRUE) str(res) ## if used for testing in R programs: isTRUE(all.equal(woodmouse, woodmouse)) # TRUE isTRUE(all.equal(woodmouse, woodm2)) # FALSE all.equal(woodmouse, woodmouse[15:1, ]) all.equal(woodmouse, woodmouse[-1, ]) all.equal(woodmouse, woodmouse[, -1]) \dontrun{ ## To run the followings you need internet and Clustal and MUSCLE ## correctly installed. ## Data from Johnson et al. (2006, Science) refs <- paste("DQ082", 505:545, sep = "") DNA <- read.GenBank(refs) DNA.clustal <- clustal(DNA) DNA.muscle <- muscle(DNA) isTRUE(all.equal(DNA.clustal, DNA.muscle)) # FALSE all.equal(DNA.clustal, DNA.muscle, TRUE) } } \keyword{manip} ape/man/fastme.Rd0000644000175100001440000000276112125466524013373 0ustar hornikusers\name{FastME} \alias{FastME} \alias{fastme} \alias{fastme.bal} \alias{fastme.ols} \title{ Tree Estimation Based on the Minimum Evolution Algorithm } \description{ The two FastME functions (balanced and OLS) perform the minimum evolution algorithm of Desper and Gascuel (2002). } \usage{ fastme.bal(X, nni = TRUE, spr = TRUE, tbr = TRUE) fastme.ols(X, nni = TRUE) } \arguments{ \item{X}{a distance matrix; may be an object of class \code{"dist"}.} \item{nni}{a boolean value; TRUE to do NNIs (default).} \item{spr}{ditto for SPRs.} \item{tbr}{ditto for TBRs.} } \value{ an object of class \code{"phylo"}. } \references{ Desper, R. and Gascuel, O. (2002) Fast and accurate phylogeny reconstruction algorithms based on the minimum-evolution principle. \emph{Journal of Computational Biology}, \bold{9(5)}, 687--705. } \author{ original C code by Richard Desper; adapted and ported to R by Vincent Lefort \email{vincent.lefort@lirmm.fr} } \seealso{ \code{\link{nj}}, \code{\link{bionj}}, \code{\link{write.tree}}, \code{\link{read.tree}}, \code{\link{dist.dna}} } \examples{ ### From Saitou and Nei (1987, Table 1): x <- c(7, 8, 11, 13, 16, 13, 17, 5, 8, 10, 13, 10, 14, 5, 7, 10, 7, 11, 8, 11, 8, 12, 5, 6, 10, 9, 13, 8) M <- matrix(0, 8, 8) M[lower.tri(M)] <- x M <- t(M) M[lower.tri(M)] <- x dimnames(M) <- list(1:8, 1:8) tr <- fastme.bal(M) plot(tr, "u") ### a less theoretical example data(woodmouse) trw <- fastme.bal(dist.dna(woodmouse)) plot(trw) } \keyword{models} ape/man/collapsed.intervals.Rd0000644000175100001440000000460012473400760016056 0ustar hornikusers\name{collapsed.intervals} \alias{collapsed.intervals} \title{Collapsed Coalescent Intervals} \usage{ collapsed.intervals(ci, epsilon=0) } \arguments{ \item{ci}{coalescent intervals (i.e. an object of class \code{"coalescentIntervals"}).} \item{epsilon}{collapsing parameter that controls the amount of smoothing (allowed range: from \code{0} to \code{ci$total.depth})} } \description{ This function takes a \code{"coalescentIntervals"} objects and collapses neighbouring coalescent intervals into a single combined interval so that every collapsed interval is larger than \code{epsilon}. Collapsed coalescent intervals are used, e.g., to obtain the generalized skyline plot (\code{\link{skyline}}). For \code{epsilon = 0} no interval is collapsed. } \details{ Proceeding from the tips to the root of the tree each small interval is pooled with the neighboring interval closer to the root. If the neighboring interval is also small, then pooling continues until the composite interval is larger than \code{epsilon}. Note that this approach prevents the occurrence of zero-length intervals at the present. For more details see Strimmer and Pybus (2001). } \value{ An object of class \code{"collapsedIntervals"} with the following entries: \item{lineages}{ A vector with the number of lineages at the start of each coalescent interval.} \item{interval.length}{ A vector with the length of each coalescent interval.} \item{collapsed.interval}{A vector indicating for each coalescent interval to which collapsed interval it belongs.} \item{interval.count}{ The total number of coalescent intervals.} \item{collapsed.interval.count}{The number of collapsed intervals.} \item{total.depth}{ The sum of the lengths of all coalescent intervals.} \item{epsilon}{The value of the underlying smoothing parameter.} } \author{Korbinian Strimmer} \seealso{ \code{\link{coalescent.intervals}},\code{\link{skyline}}. } \references{ Strimmer, K. and Pybus, O. G. (2001) Exploring the demographic history of DNA sequences using the generalized skyline plot. \emph{Molecular Biology and Evolution}, \bold{18}, 2298--2305. } \examples{ data("hivtree.table") # example tree # colescent intervals from vector of interval lengths ci <- coalescent.intervals(hivtree.table$size) ci # collapsed intervals cl1 <- collapsed.intervals(ci,0) cl2 <- collapsed.intervals(ci,0.0119) cl1 cl2 } \keyword{manip} ape/man/mrca.Rd0000644000175100001440000000212212143070705013015 0ustar hornikusers\name{mrca} \alias{mrca} \alias{getMRCA} \title{Find Most Recent Common Ancestors Between Pairs} \description{ \code{mrca} returns for each pair of tips (and nodes) its most recent common ancestor (MRCA). \code{getMRCA} returns the MRCA of two or more tips. } \usage{ mrca(phy, full = FALSE) getMRCA(phy, tip) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{full}{a logical indicating whether to return the MRCAs among all tips and nodes (if \code{TRUE}); the default is to return only the MRCAs among tips.} \item{tip}{a vector of mode numeric or character specifying the tips.} } \details{ For \code{mrca}, the diagonal is set to the number of the tips (and nodes if \code{full = TRUE}). If \code{full = FALSE}, the colnames and rownames are set with the tip labels of the tree; otherwise the numbers are given as names. For \code{getMRCA}, if \code{tip} is of length one or zero then \code{NULL} is returned. } \value{ a matrix of mode numeric (\code{mrca}) or a single numeric value (\code{getMRCA}). } \author{Emmanuel Paradis} \keyword{manip} ape/man/as.phylo.formula.Rd0000644000175100001440000000234110775732361015313 0ustar hornikusers\name{as.phylo.formula} \alias{as.phylo.formula} \title{ Conversion from Taxonomy Variables to Phylogenetic Trees } \description{ The function \code{as.phylo.formula} (short form \code{as.phylo}) builds a phylogenetic tree (an object of class \code{phylo}) from a set of nested taxonomic variables. } \usage{ \method{as.phylo}{formula}(x, data = parent.frame(), ...) } \arguments{ \item{x}{ a right-side formula describing the taxonomic relationship: \code{~C1/C2/.../Cn}. } \item{data}{ the data.frame where to look for the variables (default to environment). } \item{\dots}{ further arguments to be passed from other methods.} } \details{ Taxonomic variables must be nested and passed in the correct order: the higher clade must be on the left of the formula, for instance \code{~Order/Family/Genus/Species}. In most cases, the resulting tree will be unresolved and contain polytomies. } \value{ An object of class \code{phylo}. } \author{Julien Dutheil \email{Julien.Dutheil@univ-montp2.fr}} \seealso{ \code{\link{as.phylo}}, \code{\link{read.tree}} for a description of \code{phylo} objects, \code{\link{multi2di}} } \examples{ data(carnivora) plot(as.phylo(~SuperFamily/Family/Genus/Species, data=carnivora)) } \keyword{manip} ape/man/read.nexus.data.Rd0000644000175100001440000000733410775732361015105 0ustar hornikusers\name{read.nexus.data} \alias{read.nexus.data} \title{ Read Character Data In NEXUS Format } \description{ This function reads a file with sequences in the NEXUS format. } \usage{ read.nexus.data(file) } \arguments{ \item{file}{a file name specified by either a variable of mode character, or a double-quoted string.} } \details{ This parser tries to read data from a file written in a \emph{restricted} NEXUS format (see examples below). Please see files \file{data.nex} and \file{taxacharacters.nex} for examples of formats that will work. Some noticeable exceptions from the NEXUS standard (non-exhaustive list): \itemize{ \item{\bold{I}}{Comments must be either on separate lines or at the end of lines. Examples:\cr \code{[Comment]} \bold{--- OK}\cr \code{Taxon ACGTACG [Comment]} \bold{--- OK}\cr \code{[Comment line 1} \code{Comment line 2]} \bold{--- NOT OK!}\cr \code{Tax[Comment]on ACG[Comment]T} \bold{--- NOT OK!}} \item{\bold{II}}{No spaces (or comments) are allowed in the sequences. Examples:\cr \code{name ACGT} \bold{--- OK}\cr \code{name AC GT} \bold{--- NOT OK!}} \item{\bold{III}}{No spaces are allowed in taxon names, not even if names are in single quotes. That is, single-quoted names are not treated as such by the parser. Examples:\cr \code{Genus_species} \bold{--- OK}\cr \code{'Genus_species'} \bold{--- OK}\cr \code{'Genus species'} \bold{--- NOT OK!}} \item{\bold{IV}}{The trailing \code{end} that closes the \code{matrix} must be on a separate line. Examples:\cr \code{taxon AACCGGT} \code{end;} \bold{--- OK}\cr \code{taxon AACCGGT;} \code{end;} \bold{--- OK}\cr \code{taxon AACCCGT; end;} \bold{--- NOT OK!}} \item{\bold{V}}{Multistate characters are not allowed. That is, NEXUS allows you to specify multiple character states at a character position either as an uncertainty, \code{(XY)}, or as an actual appearance of multiple states, \code{\{XY\}}. This is information is not handled by the parser. Examples:\cr \code{taxon 0011?110} \bold{--- OK}\cr \code{taxon 0011{01}110} \bold{--- NOT OK!}\cr \code{taxon 0011(01)110} \bold{--- NOT OK!}} \item{\bold{VI}}{The number of taxa must be on the same line as \code{ntax}. The same applies to \code{nchar}. Examples:\cr \code{ntax = 12} \bold{--- OK}\cr \code{ntax =} \code{12} \bold{--- NOT OK!}} \item{\bold{VII}}{The word \dQuote{matrix} can not occur anywhere in the file before the actual \code{matrix} command, unless it is in a comment. Examples:\cr \code{BEGIN CHARACTERS;} \code{TITLE 'Data in file "03a-cytochromeB.nex"';} \code{DIMENSIONS NCHAR=382;} \code{FORMAT DATATYPE=Protein GAP=- MISSING=?;} \code{["This is The Matrix"]} \bold{--- OK} \code{MATRIX}\cr \code{BEGIN CHARACTERS;} \code{TITLE 'Matrix in file "03a-cytochromeB.nex"';} \bold{--- NOT OK!} \code{DIMENSIONS NCHAR=382;} \code{FORMAT DATATYPE=Protein GAP=- MISSING=?;} \code{MATRIX}} } } \value{ A list of sequences each made of a single vector of mode character where each element is a (phylogenetic) character state. } \references{ Maddison, D. R., Swofford, D. L. and Maddison, W. P. (1997) NEXUS: an extensible file format for systematic information. \emph{Systematic Biology}, \bold{46}, 590--621. } \author{Johan Nylander \email{nylander@scs.fsu.edu}} \seealso{ \code{\link{read.nexus}}, \code{\link{write.nexus}}, \code{\link{write.nexus.data}} } \examples{ ## Use read.nexus.data to read a file in NEXUS format into object x \dontrun{x <- read.nexus.data("file.nex")} } \keyword{file} ape/man/nodepath.Rd0000644000175100001440000000142712435626452013716 0ustar hornikusers\name{nodepath} \alias{nodepath} \title{Find Paths of Nodes} \description{ This function finds paths of nodes in a tree. The nodes can be internal and/or terminal (i.e., tips). } \usage{ nodepath(phy, from = NULL, to = NULL) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{from, to}{integers giving node or tip numbers.} } \details{ By default, this function returns all the paths from the root to each tip of the tree. If both arguments \code{from} and \code{to} are specified, the shortest path of nodes linking them is returned. } \value{ a list of vectors of integers (by default), or a single vector of integers. } \author{Emmanuel Paradis} \seealso{\code{\link{getMRCA}}} \examples{ tr <- rtree(2) nodepath(tr) nodepath(tr, 1, 2) } \keyword{manip} ape/man/collapse.singles.Rd0000644000175100001440000000257412542003550015350 0ustar hornikusers\name{collapse.singles} \alias{collapse.singles} \title{Collapse Single Nodes} \description{ This function deletes the single nodes (i.e., with a single descendant) in a tree. } \usage{ collapse.singles(tree, root.edge = FALSE) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{root.edge}{whether to get the singleton edges from the root until the first bifurcating node and put them as \code{root.edge} of the returned tree. By default, this is ignored or if the tree has no edge lengths (see examples).} } \value{ an object of class \code{"phylo"}. } \author{Emmanuel Paradis} \seealso{ \code{\link{plot.phylo}}, \code{\link{read.tree}} } \examples{ ## a tree with 3 tips and 3 nodes: e <- c(4L, 6L, 6L, 5L, 5L, 6L, 1L, 5L, 3L, 2L) dim(e) <- c(5, 2) tr <- structure(list(edge = e, tip.label = LETTERS[1:3], Nnode = 3L), class = "phylo") tr ## the following shows that node #4 (ie, the root) is a singleton ## and node #6 is the first bifurcating node tr$edge ## Normally, a tree has less nodes than it has tips: ## > plot(tr) ## Error in plot.phylo(tr) : ## there are single (non-splitting) nodes in your tree; ## you may need to use collapse.singles() collapse.singles(tr) # only 2 nodes ## give branch lengths to use the 'root.edge' option: tr$edge.length <- runif(5) str(collapse.singles(tr, TRUE)) # has a 'root.edge' } \keyword{manip} ape/man/balance.Rd0000644000175100001440000000201411353106056013461 0ustar hornikusers\name{balance} \alias{balance} \title{Balance of a Dichotomous Phylogenetic Tree} \usage{ balance(phy) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} } \description{ This function computes the balance of a phylogenetic tree, that is for each node of the tree the numbers of descendants (i.e. tips) on each of its daughter-branch. The tree must be fully dichotomous. } \value{ a numeric matrix with two columns and one row for each node of the tree. The columns give the numbers of descendants on each daughter-branches (the order of both columns being arbitrary). If the phylogeny \code{phy} has an element \code{node.label}, this is used as rownames for the returned matrix; otherwise the numbers (of mode character) of the matrix \code{edge} of \code{phy} are used as rownames. } \references{ Aldous, D. J. (2001) Stochastic models and descriptive statistics for phylogenetic trees, from Yule to today. \emph{Statistical Science}, \bold{16}, 23--34. } \author{Emmanuel Paradis} \keyword{manip} ape/man/woodmouse.Rd0000644000175100001440000000153512471072757014140 0ustar hornikusers\name{woodmouse} \alias{woodmouse} \title{Cytochrome b Gene Sequences of Woodmice} \description{ This is a set of 15 sequences of the mitochondrial gene cytochrome \emph{b} of the woodmouse (\emph{Apodemus sylvaticus}) which is a subset of the data analysed by Michaux et al. (2003). The full data set is available through GenBank (accession numbers AJ511877 to AJ511987). } \usage{ data(woodmouse) } \format{ An object of class \code{"DNAbin"}. } \source{ Michaux, J. R., Magnanou, E., Paradis, E., Nieberding, C. and Libois, R. (2003) Mitochondrial phylogeography of the Woodmouse (\emph{Apodemus sylvaticus}) in the Western Palearctic region. \emph{Molecular Ecology}, \bold{12}, 685--697. } \seealso{ \code{\link{read.dna}}, \code{\link{DNAbin}}, \code{\link{dist.dna}} } \examples{ data(woodmouse) str(woodmouse) } \keyword{datasets} ape/man/ladderize.Rd0000644000175100001440000000137711353106607014054 0ustar hornikusers\name{ladderize} \alias{ladderize} \title{Ladderize a Tree} \usage{ ladderize(phy, right = TRUE) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{right}{a logical specifying whether the smallest clade is on the right-hand side (when the tree is plotted upwards), or the opposite (if \code{FALSE}).} } \description{ This function reorganizes the internal structure of the tree to get the ladderized effect when plotted. } \author{Emmanuel Paradis} \seealso{ \code{\link{plot.phylo}}, \code{\link{reorder.phylo}} } \examples{ tr <- rcoal(50) layout(matrix(1:4, 2, 2)) plot(tr, main = "normal") plot(ladderize(tr), main = "right-ladderized") plot(ladderize(tr, FALSE), main = "left-ladderized") layout(matrix(1, 1)) } \keyword{manip} ape/man/cherry.Rd0000644000175100001440000000327611353106204013376 0ustar hornikusers\name{cherry} \alias{cherry} \title{Number of Cherries and Null Models of Trees} \usage{ cherry(phy) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} } \description{ This function calculates the number of cherries (see definition below) on a phylogenetic tree, and tests the null hypotheses whether this number agrees with those predicted from two null models of trees (the Yule model, and the uniform model). } \value{ A NULL value is returned, the results are simply printed. } \details{ A cherry is a pair of adjacent tips on a tree. The tree can be either rooted or unrooted, but the present function considers only rooted trees. The probability distribution function of the number of cherries on a tree depends on the speciation/extinction model that generated the tree. McKenzie and Steel (2000) derived the probability distribution function of the number of cherries for two models: the Yule model and the uniform model. Broadly, in the Yule model, each extant species is equally likely to split into two daughter-species; in the uniform model, a branch is added to tree on any of the already existing branches with a uniform probability. The probabilities are computed using recursive formulae; however, for both models, the probability density function converges to a normal law with increasing number of tips in the tree. The function uses these normal approximations for a number of tips greater than or equal to 20. } \references{ McKenzie, A. and Steel, M. (2000) Distributions of cherries for two models of trees. \emph{Mathematical Biosciences}, \bold{164}, 81--92. } \author{Emmanuel Paradis} \seealso{ \code{\link{gammaStat}} } \keyword{univar} ape/man/CADM.global.Rd0000644000175100001440000002143011746365672014063 0ustar hornikusers\name{CADM.global} \alias{CADM} \alias{CADM.global} \alias{CADM.post} \title{ Congruence among distance matrices } \description{ Function \code{\link{CADM.global}} compute and test the coefficient of concordance among several distance matrices through a permutation test. Function \code{\link{CADM.post}} carries out a posteriori permutation tests of the contributions of individual distance matrices to the overall concordance of the group. Use in phylogenetic analysis: to identify congruence among distance matrices (D) representing different genes or different types of data. Congruent D matrices correspond to data tables that can be used together in a combined phylogenetic or other type of multivariate analysis. } \usage{ CADM.global(Dmat, nmat, n, nperm=99, make.sym=TRUE, weights=NULL, silent=FALSE) CADM.post (Dmat, nmat, n, nperm=99, make.sym=TRUE, weights=NULL, mult="holm", mantel=FALSE, silent=FALSE) } \arguments{ \item{Dmat}{ A text file listing the distance matrices one after the other, with or without blank lines in-between. Each matrix is in the form of a square distance matrix with 0's on the diagonal. } \item{nmat}{ Number of distance matrices in file Dmat. } \item{n}{ Number of objects in each distance matrix. All matrices must have the same number of objects. } \item{nperm}{ Number of permutations for the tests of significance. } \item{make.sym}{ TRUE: turn asymmetric matrices into symmetric matrices by averaging the two triangular portions. FALSE: analyse asymmetric matrices as they are. } \item{weights}{ A vector of positive weights for the distance matrices. Example: weights = c(1,2,3). NULL (default): all matrices have same weight in the calculation of W. } \item{mult}{ Method for correcting P-values in multiple testing. The methods are "holm" (default), "sidak", and "bonferroni". The Bonferroni correction is overly conservative; it is not recommended. It is included to allow comparisons with the other methods. } \item{mantel}{ TRUE: Mantel statistics will be computed from ranked distances, as well as permutational P-values. FALSE (default): Mantel statistics and tests will not be computed. } \item{silent}{ TRUE: informative messages will not be printed, but stopping messages will. Option useful for simulation work. FALSE: informative messages will be printed. } } \details{ \code{Dmat} must contain two or more distance matrices, listed one after the other, all of the same size, and corresponding to the same objects in the same order. Raw data tables can be transformed into distance matrices before comparison with other such distance matrices, or with data that have been obtained as distance matrices, e.g. serological or DNA hybridization data. The distances will be transformed to ranks before computation of the coefficient of concordance and other statistics. \code{CADM.global} tests the global null hypothesis that all matrices are incongruent. If the global null is rejected, function \code{CADM.post} can be used to identify the concordant (H0 rejected) and discordant matrices (H0 not rejected) in the group. If a distance matrix has a negative value for the \code{Mantel.mean} statistic, that matrix clearly does not belong to the group. Remove that matrix (if there are more than one, remove first the matrix that has the most strongly negative value for \code{Mantel.mean}) and run the analysis again. The corrections used for multiple testing are applied to the list of P-values (P) produced in the a posteriori tests; they take into account the number of tests (k) carried out simulatenously (number of matrices, parameter \code{nmat}). The Holm correction is computed after ordering the P-values in a list with the smallest value to the left. Compute adjusted P-values as: \deqn{P_{corr} = (k-i+1)*P}{P_corr = (k-i+1)*P} where i is the position in the ordered list. Final step: from left to right, if an adjusted \eqn{P_{corr}}{P_corr} in the ordered list is smaller than the one occurring at its left, make the smallest one equal to the largest one. The Sidak correction is: \deqn{P_{corr} = 1 - (1 - P)^k}{P_corr = 1 - (1 - P)^k} The Bonferonni correction is: \deqn{P_{corr} = k*P}{P_corr = k*P} } \value{ \code{CADM.global} produces a small table containing the W, Chi2, and Prob.perm statistics described in the following list. \code{CADM.post} produces a table stored in element \code{A_posteriori_tests}, containing Mantel.mean, Prob, and Corrected.prob statistics in rows; the columns correspond to the k distance matrices under study, labeled Dmat.1 to Dmat.k. If parameter \code{mantel} is TRUE, tables of Mantel statistics and P-values are computed among the matrices. \item{W }{Kendall's coefficient of concordance, W (Kendall and Babington Smith 1939; see also Legendre 2010). } \item{Chi2 }{Friedman's chi-square statistic (Friedman 1937) used in the permutation test of W. } \item{Prob.perm }{Permutational probability. } \item{Mantel.mean }{Mean of the Mantel correlations, computed on rank-transformed distances, between the distance matrix under test and all the other matrices in the study. } \item{Prob }{Permutational probabilities, uncorrected. } \item{Corrected prob }{Permutational probabilities corrected using the method selected in parameter \code{mult}. } \item{Mantel.cor }{Matrix of Mantel correlations, computed on rank-transformed distances, among the distance matrices. } \item{Mantel.prob }{One-tailed P-values associated with the Mantel correlations of the previous table. The probabilities are computed in the right-hand tail. H0 is tested against the alternative one-tailed hypothesis that the Mantel correlation under test is positive. No correction is made for multiple testing. } } \references{ Campbell, V., Legendre, P. and Lapointe, F.-J. (2009) Assessing congruence among ultrametric distance matrices. \emph{Journal of Classification}, \bold{26}, 103--117. Campbell, V., Legendre, P. and Lapointe, F.-J. (2011) The performance of the Congruence Among Distance Matrices (CADM) test in phylogenetic analysis. \emph{BMC Evolutionary Biology}, \bold{11}, 64. \url{http://www.biomedcentral.com/1471-2148/11/64}. Friedman, M. (1937) The use of ranks to avoid the assumption of normality implicit in the analysis of variance. \emph{Journal of the American Statistical Association}, \bold{32}, 675--701. Kendall, M. G. and Babington Smith, B. (1939) The problem of m rankings. \emph{Annals of Mathematical Statistics}, \bold{10}, 275--287. Lapointe, F.-J., Kirsch, J. A. W. and Hutcheon, J. M. (1999) Total evidence, consensus, and bat phylogeny: a distance-based approach. \emph{Molecular Phylogenetics and Evolution}, \bold{11}, 55--66. Legendre, P. (2010) Coefficient of concordance. Pp. 164-169 in: Encyclopedia of Research Design, Vol. 1. N. J. Salkind, ed. SAGE Publications, Inc., Los Angeles. Legendre, P. and Lapointe, F.-J. (2004) Assessing congruence among distance matrices: single malt Scotch whiskies revisited. \emph{Australian and New Zealand Journal of Statistics}, \bold{46}, 615--629. Legendre, P. and Lapointe, F.-J. (2005) Congruence entre matrices de distance. P. 178-181 in: Makarenkov, V., G. Cucumel et F.-J. Lapointe [eds] Comptes rendus des 12emes Rencontres de la Societe Francophone de Classification, Montreal, 30 mai - 1er juin 2005. Siegel, S. and Castellan, N. J., Jr. (1988) \emph{Nonparametric statistics for the behavioral sciences. 2nd edition}. New York: McGraw-Hill. } \author{Pierre Legendre, Universite de Montreal} \examples{ # Examples 1 and 2: 5 genetic distance matrices computed from simulated DNA # sequences representing 50 taxa having evolved along additive trees with # identical evolutionary parameters (GTR+ Gamma + I). Distance matrices were # computed from the DNA sequence matrices using a p distance corrected with the # same parameters as those used to simulate the DNA sequences. See Campbell et # al. (2009) for details. # Example 1: five independent additive trees. Data provided by V. Campbell. data(mat5Mrand) res.global <- CADM.global(mat5Mrand, 5, 50) # Example 2: three partly similar trees, two independent trees. # Data provided by V. Campbell. data(mat5M3ID) res.global <- CADM.global(mat5M3ID, 5, 50) res.post <- CADM.post(mat5M3ID, 5, 50, mantel=TRUE) # Example 3: three matrices respectively representing Serological # (asymmetric), DNA hybridization (asymmetric) and Anatomical (symmetric) # distances among 9 families. Data from Lapointe et al. (1999). data(mat3) res.global <- CADM.global(mat3, 3, 9, nperm=999) res.post <- CADM.post(mat3, 3, 9, nperm=999, mantel=TRUE) # Example 4, showing how to bind two D matrices (cophenetic matrices # in this example) into a file using rbind(), then run the global test. a <- rtree(5) b <- rtree(5) A <- cophenetic(a) B <- cophenetic(b) x <- rownames(A) B <- B[x, x] M <- rbind(A, B) CADM.global(M, 2, 5) } \keyword{ multivariate } \keyword{ nonparametric } ape/man/base.freq.Rd0000644000175100001440000000372611746132625013764 0ustar hornikusers\name{base.freq} \alias{base.freq} \alias{GC.content} \alias{Ftab} \title{Base frequencies from DNA Sequences} \description{ \code{base.freq} computes the frequencies (absolute or relative) of the four DNA bases (adenine, cytosine, guanine, and thymidine) from a sample of sequences. \code{GC.content} computes the proportion of G+C (using the previous function). All missing or unknown sites are ignored. \code{Ftab} computes the contingency table with the absolute frequencies of the DNA bases from a pair of sequences. } \usage{ base.freq(x, freq = FALSE, all = FALSE) GC.content(x) Ftab(x, y = NULL) } \arguments{ \item{x}{a vector, a matrix, or a list which contains the DNA sequences.} \item{y}{a vector with a single DNA sequence.} \item{freq}{a logical specifying whether to return the proportions (the default) or the absolute frequencies (counts).} \item{all}{a logical; by default only the counts of A, C, G, and T are returned. If \code{all = TRUE}, all counts of bases, ambiguous codes, missing data, and alignment gaps are returned.} } \details{ The base frequencies are computed over all sequences in the sample. For \code{Ftab}, if the argument \code{y} is given then both \code{x} and \code{y} are coerced as vectors and must be of equal length. If \code{y} is not given, \code{x} must be a matrix or a list and only the two first sequences are used. } \value{ A numeric vector with names \code{c("a", "c", "g", "t")} (and possibly \code{"r", "m", ...}, a single numeric value, or a four by four matrix with similar dimnames. } \author{Emmanuel Paradis} \seealso{ \code{\link{seg.sites}}, \code{\link[pegas]{nuc.div}}, \code{\link{DNAbin}} } \examples{ data(woodmouse) base.freq(woodmouse) base.freq(woodmouse, TRUE) base.freq(woodmouse, TRUE, TRUE) GC.content(woodmouse) Ftab(woodmouse) Ftab(woodmouse[1, ], woodmouse[2, ]) # same than above Ftab(woodmouse[14:15, ]) # between the last two } \keyword{univar} \keyword{manip} ape/man/delta.plot.Rd0000644000175100001440000000313611562670115014154 0ustar hornikusers\name{delta.plot} \alias{delta.plot} \title{Delta Plots} \usage{ delta.plot(X, k = 20, plot = TRUE, which = 1:2) } \arguments{ \item{X}{a distance matrix, may be an object of class ``dist''.} \item{k}{an integer giving the number of intervals in the plot.} \item{plot}{a logical specifying whether to draw the \eqn{\delta}{delta} plot (the default).} \item{which}{a numeric vector indicating which plots are done; 1: the histogram of the \eqn{\delta_q}{delta_q} values, 2: the plot of the individual \eqn{\bar{\delta}}{delta.bar} values. By default, both plots are done.} } \description{ This function makes a \eqn{\delta}{delta} plot following Holland et al. (2002). } \details{ See Holland et al. (2002) for details and interpretation. The computing time of this function is proportional to the fourth power of the number of observations (\eqn{O(n^4)}), so calculations may be very long with only a slight increase in sample size. } \value{ This function returns invisibly a named list with two components: \itemize{ \item{counts}{the counts for the histogram of \eqn{\delta_q}{delta_q} values} \item{delta.bar}{the mean \eqn{\delta}{delta} value for each observation} } } \references{ Holland, B. R., Huber, K. T., Dress, A. and Moulton, V. (2002) Delta plots: a tool for analyzing phylogenetic distance data. \emph{Molecular Biology and Evolution}, \bold{12}, 2051--2059. } \author{Emmanuel Paradis} \seealso{ \code{\link{dist.dna}} } \examples{ data(woodmouse) d <- dist.dna(woodmouse) delta.plot(d) layout(1) delta.plot(d, 40, which = 1) } \keyword{hplot} ape/man/ace.Rd0000644000175100001440000002715612526045640012646 0ustar hornikusers\name{ace} \alias{ace} \alias{print.ace} \alias{logLik.ace} \alias{deviance.ace} \alias{AIC.ace} \alias{anova.ace} \title{Ancestral Character Estimation} \description{ This function estimates ancestral character states, and the associated uncertainty, for continuous and discrete characters. \code{logLik}, \code{deviance}, and \code{AIC} are generic functions used to extract the log-likelihood, the deviance, or the Akaike information criterion of a fitted object. If no such values are available, \code{NULL} is returned. \code{anova} is another generic function which is used to compare nested models: the significance of the additional parameter(s) is tested with likelihood ratio tests. You must ensure that the models are effectively nested (if they are not, the results will be meaningless). It is better to list the models from the smallest to the largest. } \usage{ ace(x, phy, type = "continuous", method = if (type == "continuous") "REML" else "ML", CI = TRUE, model = if (type == "continuous") "BM" else "ER", scaled = TRUE, kappa = 1, corStruct = NULL, ip = 0.1, use.expm = FALSE, use.eigen = TRUE, marginal = FALSE) \method{print}{ace}(x, digits = 4, ...) \method{logLik}{ace}(object, ...) \method{deviance}{ace}(object, ...) \method{AIC}{ace}(object, ..., k = 2) \method{anova}{ace}(object, ...) } \arguments{ \item{x}{a vector or a factor; an object of class \code{"ace"} in the case of \code{print}.} \item{phy}{an object of class \code{"phylo"}.} \item{type}{the variable type; either \code{"continuous"} or \code{"discrete"} (or an abbreviation of these).} \item{method}{a character specifying the method used for estimation. Four choices are possible: \code{"ML"}, \code{"REML"}, \code{"pic"}, or \code{"GLS"}.} \item{CI}{a logical specifying whether to return the 95\% confidence intervals of the ancestral state estimates (for continuous characters) or the likelihood of the different states (for discrete ones).} \item{model}{a character specifying the model (ignored if \code{method = "GLS"}), or a numeric matrix if \code{type = "discrete"} (see details).} \item{scaled}{a logical specifying whether to scale the contrast estimate (used only if \code{method = "pic"}).} \item{kappa}{a positive value giving the exponent transformation of the branch lengths (see details).} \item{corStruct}{if \code{method = "GLS"}, specifies the correlation structure to be used (this also gives the assumed model).} \item{ip}{the initial value(s) used for the ML estimation procedure when \code{type == "discrete"} (possibly recycled).} \item{use.expm}{a logical specifying whether to use the package \pkg{expm} to compute the matrix exponential (relevant only if \code{type = "d"}). If \code{FALSE}, the function \code{matexpo} from \pkg{ape} is used (see details). This option is ignored if \code{use.eigen = TRUE} (see next).} \item{use.eigen}{a logical (relevant if \code{type = "d"}); if \code{TRUE} then the probability matrix is computed with an eigen decomposition instead of a matrix exponential (see details).} \item{marginal}{a logical (relevant if \code{type = "d"}). By default, the joint reconstruction of the ancestral states are done. Set this option to \code{TRUE} if you want the marginal reconstruction (see details.)} \item{digits}{the number of digits to be printed.} \item{object}{an object of class \code{"ace"}.} \item{k}{a numeric value giving the penalty per estimated parameter; the default is \code{k = 2} which is the classical Akaike information criterion.} \item{\dots}{further arguments passed to or from other methods.} } \details{ If \code{type = "continuous"}, the default model is Brownian motion where characters evolve randomly following a random walk. This model can be fitted by residual maximum likelihood (the default), maximum likelihood (Felsenstein 1973, Schluter et al. 1997), least squares (\code{method = "pic"}, Felsenstein 1985), or generalized least squares (\code{method = "GLS"}, Martins and Hansen 1997, Cunningham et al. 1998). In the last case, the specification of \code{phy} and \code{model} are actually ignored: it is instead given through a correlation structure with the option \code{corStruct}. In the setting \code{method = "ML"} and \code{model = "BM"} (this used to be the default until \pkg{ape} 3.0-7) the maximum likelihood estimation is done simultaneously on the ancestral values and the variance of the Brownian motion process; these estimates are then used to compute the confidence intervals in the standard way. The REML method first estimates the ancestral value at the root (aka, the phylogenetic mean), then the variance of the Brownian motion process is estimated by optimizing the residual log-likelihood. The ancestral values are finally inferred from the likelihood function giving these two parameters. If \code{method = "pic"} or \code{"GLS"}, the confidence intervals are computed using the expected variances under the model, so they depend only on the tree. It could be shown that, with a continous character, REML results in unbiased estimates of the variance of the Brownian motion process while ML gives a downward bias. Therefore the former is recommanded. For discrete characters (\code{type = "discrete"}), only maximum likelihood estimation is available (Pagel 1994) (see \code{\link{MPR}} for an alternative method). The model is specified through a numeric matrix with integer values taken as indices of the parameters. The numbers of rows and of columns of this matrix must be equal, and are taken to give the number of states of the character. For instance, \code{matrix(c(0, 1, 1, 0), 2)} will represent a model with two character states and equal rates of transition, \code{matrix(c(0, 1, 2, 0), 2)} a model with unequal rates, \code{matrix(c(0, 1, 1, 1, 0, 1, 1, 1, 0), 3)} a model with three states and equal rates of transition (the diagonal is always ignored). There are short-cuts to specify these models: \code{"ER"} is an equal-rates model (e.g., the first and third examples above), \code{"ARD"} is an all-rates-different model (the second example), and \code{"SYM"} is a symmetrical model (e.g., \code{matrix(c(0, 1, 2, 1, 0, 3, 2, 3, 0), 3)}). If a short-cut is used, the number of states is determined from the data. By default, the likelihood of the different ancestral states of discrete characters are computed with a joint estimation procedure using a procedure similar to the one described in Pupko et al. (2000). If \code{marginal = TRUE}, a marginal estimation procedure is used (this was the only choice until ape 3.1-1). With this method, the likelihood values at a given node are computed using only the information from the tips (and branches) descending from this node. With the joint estimation, all information is used for each node. The difference between these two methods is further explained in Felsenstein (2004, pp. 259-260) and in Yang (2006, pp. 121-126). The present implementation of the joint estimation uses a ``two-pass'' algorithm which is much faster than stochastic mapping while the estimates of both methods are very close. With discrete characters it is necessary to compute the exponential of the rate matrix. The only possibility until \pkg{ape} 3.0-7 was the function \code{\link{matexpo}} in \pkg{ape}. If \code{use.expm = TRUE} and \code{use.eigen = FALSE}, the function \code{\link[expm]{expm}}, in the package of the same name, is used. \code{matexpo} is faster but quite inaccurate for large and/or asymmetric matrices. In case of doubt, use the latter. Since \pkg{ape} 3.0-10, it is possible to use an eigen decomposition avoiding the need to compute the matrix exponential; see details in Lebl (2013, sect. 3.8.3). This is much faster and is now the default. } \note{ Liam Revell points out that for discrete characters the ancestral likelihood values returned with \code{marginal = FALSE} are actually the marginal estimates, while setting \code{marginal = TRUE} returns the conditional (scaled) likelihoods of the subtree: \url{http://blog.phytools.org/2015/05/about-how-acemarginaltrue-does-not.html} } \value{ an object of class \code{"ace"} with the following elements: \item{ace}{if \code{type = "continuous"}, the estimates of the ancestral character values.} \item{CI95}{if \code{type = "continuous"}, the estimated 95\% confidence intervals.} \item{sigma2}{if \code{type = "continuous"}, \code{model = "BM"}, and \code{method = "ML"}, the maximum likelihood estimate of the Brownian parameter.} \item{rates}{if \code{type = "discrete"}, the maximum likelihood estimates of the transition rates.} \item{se}{if \code{type = "discrete"}, the standard-errors of estimated rates.} \item{index.matrix}{if \code{type = "discrete"}, gives the indices of the \code{rates} in the rate matrix.} \item{loglik}{if \code{method = "ML"}, the maximum log-likelihood.} \item{lik.anc}{if \code{type = "discrete"}, the scaled likelihoods of each ancestral state.} \item{call}{the function call.} } \references{ Cunningham, C. W., Omland, K. E. and Oakley, T. H. (1998) Reconstructing ancestral character states: a critical reappraisal. \emph{Trends in Ecology & Evolution}, \bold{13}, 361--366. Felsenstein, J. (1973) Maximum likelihood estimation of evolutionary trees from continuous characters. \emph{American Journal of Human Genetics}, \bold{25}, 471--492. Felsenstein, J. (1985) Phylogenies and the comparative method. \emph{American Naturalist}, \bold{125}, 1--15. Felsenstein, J. (2004) \emph{Inferring Phylogenies}. Sunderland: Sinauer Associates. Lebl, J. (2013) \emph{Notes on Diffy Qs: Differential Equations for Engineers}. \url{http://www.jirka.org/diffyqs/}. Martins, E. P. and Hansen, T. F. (1997) Phylogenies and the comparative method: a general approach to incorporating phylogenetic information into the analysis of interspecific data. \emph{American Naturalist}, \bold{149}, 646--667. Pagel, M. (1994) Detecting correlated evolution on phylogenies: a general method for the comparative analysis of discrete characters. \emph{Proceedings of the Royal Society of London. Series B. Biological Sciences}, \bold{255}, 37--45. Pupko, T., Pe'er, I, Shamir, R., and Graur, D. (2000) A fast algorithm for joint reconstruction of ancestral amino acid sequences. \emph{Molecular Biology and Evolution}, \bold{17}, 890--896. Schluter, D., Price, T., Mooers, A. O. and Ludwig, D. (1997) Likelihood of ancestor states in adaptive radiation. \emph{Evolution}, \bold{51}, 1699--1711. Yang, Z. (2006) \emph{Computational Molecular Evolution}. Oxford: Oxford University Press. } \author{Emmanuel Paradis, Ben Bolker} \seealso{ \code{\link{MPR}}, \code{\link{corBrownian}}, \code{\link{compar.ou}}, \code{\link[stats]{anova}} Reconstruction of ancestral sequences can be done with the package \pkg{phangorn} (see function \code{?ancestral.pml}). } \examples{ ### Some random data... data(bird.orders) x <- rnorm(23) ### Compare the three methods for continuous characters: ace(x, bird.orders) ace(x, bird.orders, method = "pic") ace(x, bird.orders, method = "GLS", corStruct = corBrownian(1, bird.orders)) ### For discrete characters: x <- factor(c(rep(0, 5), rep(1, 18))) ans <- ace(x, bird.orders, type = "d") #### Showing the likelihoods on each node: plot(bird.orders, type = "c", FALSE, label.offset = 1) co <- c("blue", "yellow") tiplabels(pch = 22, bg = co[as.numeric(x)], cex = 2, adj = 1) nodelabels(thermo = ans$lik.anc, piecol = co, cex = 0.75) } \keyword{models} ape/man/parafit.Rd0000644000175100001440000001657411540425516013545 0ustar hornikusers\name{parafit} \alias{parafit} \alias{print.parafit} \alias{gopher.D} \alias{lice.D} \alias{HP.links} \title{ Test of host-parasite coevolution } \description{ Function \code{\link{parafit}} tests the hypothesis of coevolution between a clade of hosts and a clade of parasites. The null hypothesis (H0) of the global test is that the evolution of the two groups, as revealed by the two phylogenetic trees and the set of host-parasite association links, has been independent. Tests of individual host-parasite links are also available as an option. The method, which is described in detail in Legendre et al. (2002), requires some estimates of the phylogenetic trees or phylogenetic distances, and also a description of the host-parasite associations (H-P links) observed in nature. } \usage{ parafit(host.D, para.D, HP, nperm = 999, test.links = FALSE, seed = NULL, correction = "none", silent = FALSE) } \arguments{ \item{host.D }{ A matrix of phylogenetic or patristic distances among the hosts (object class: \code{matrix}, \code{data.frame} or \code{dist}). A matrix of patristic distances exactly represents the information in a phylogenetic tree. } \item{para.D }{ A matrix of phylogenetic or patristic distances among the parasites (object class: \code{matrix}, \code{data.frame} or \code{dist}). A matrix of patristic distances exactly represents the information in a phylogenetic tree. } \item{HP }{ A rectangular matrix with hosts as rows and parasites as columns. The matrix contains 1's when a host-parasite link has been observed in nature between the host in the row and the parasite in the column, and 0's otherwise. } \item{nperm}{ Number of permutations for the tests. If \code{nperm = 0}, permutation tests will not be computed. The default value is \code{nperm = 999}. For large data files, the permutation test is rather slow since the permutation procedure is not compiled. } \item{test.links }{ \code{test.links = TRUE} will test the significance of individual host-parasite links. Default: \code{test.links = FALSE}. } \item{seed }{ \code{seed = NULL} (default): a seed is chosen at random by the function. That seed is used as the starting point for all tests of significance, i.e. the global H-P test and the tests of individual H-P links if they are requested. Users can select a seed of their choice by giving any integer value to \code{seed}, for example \code{seed = -123456}. Running the function again with the same seed value will produce the exact same test results. } \item{correction}{ Correction methods for negative eigenvalues (details below): \code{correction="lingoes"} and \code{correction="cailliez"}. Default value: \code{"none"}. } \item{silent}{ Informative messages and the time to compute the tests will not be written to the \R console if silent=TRUE. Useful when the function is called by a numerical simulation function. } } \details{ Two types of test are produced by the program: a global test of coevolution and, optionally, a test on the individual host-parasite (H-P) link. The function computes principal coordinates for the host and the parasite distance matrices. The principal coordinates (all of them) act as a complete representation of either the phylogenetic distance matrix or the phylogenetic tree. Phylogenetic distance matrices are normally Euclidean. Patristic distance matrices are additive, thus they are metric and Euclidean. Euclidean matrices are fully represented by real-valued principal coordinate axes. For non-Euclidean matrices, negative eigenvalues are produced; complex principal coordinate axes are associated with the negative eigenvalues. So, the program rejects matrices that are not Euclidean and stops. Negative eigenvalues can be corrected for by one of two methods: the Lingoes or the Caillez correction. It is up to the user to decide which correction method should be applied. This is done by selecting the option \code{correction="lingoes"} or \code{correction="cailliez"}. Details on these correction methods are given in the help file of the \code{pcoa} function. The principle of the global test is the following (H0: independent evolution of the hosts and parasites): (1) Compute matrix D = C t(A) B. Note: D is a fourth-corner matrix (sensu Legendre et al. 1997), where A is the H-P link matrix, B is the matrix of principal coordinates computed from the host.D matrix, and C is the matrix of principal coordinates computed from the para.D matrix. (2) Compute the statistic ParaFitGlobal, the sum of squares of all values in matrix D. (3) Permute at random, separately, each row of matrix A, obtaining matrix A.perm. Compute D.perm = C %*% t(A.perm) %*% B, and from it, compute a permuted value ParaFitGlobal.perm for the statistic. Save this value in a vector trace.perm for the tests of individual links (below). (4) Repeat step 4 a large number of times. (5) Add the reference value of ParaFitGlobal to the distribution of ParaFitGlobal.perm values. Calculate the permutational probability associated to ParaFitGlobal. The test of each individual H-P link is carried out as follows (H0: this particular link is random): (1) Remove one link (k) from matrix A. (2) Compute matrix D = C t(A) B. (3a) Compute trace(k), the sum of squares of all values in matrix D. (3b) Compute the statistic ParaFitLink1 = (trace - trace(k)) where trace is the ParaFitGlobal statistic. (3c) Compute the statistic ParaFitLink2 = (trace - trace(k)) / (tracemax - trace) where tracemax is the maximum value that can be taken by trace. (4) Permute at random, separately, each row of matrix A, obtaining A.perm. Use the same sequences of permutations as were used in the test of ParaFitGlobal. Using the values of trace and trace.perm saved during the global test, compute the permuted values of the two statistics, ParaFit1.perm and ParaFit2.perm. (5) Repeat step 4 a large number of times. (6) Add the reference value of ParaFit1 to the distribution of ParaFit1.perm values; add the reference value of ParaFit2 to the distribution of ParaFit2.perm values. Calculate the permutational probabilities associated to ParaFit1 and ParaFit2. The \code{print.parafit} function prints out the results of the global test and, optionally, the results of the tests of the individual host-parasite links. } \value{ \item{ParaFitGlobal }{The statistic of the global H-P test. } \item{p.global }{The permutational p-value associated with the ParaFitGlobal statistic. } \item{link.table }{The results of the tests of individual H-P links, including the ParaFitLink1 and ParaFitLink2 statistics and the p-values obtained from their respective permutational tests. } \item{para.per.host }{Number of parasites per host. } \item{host.per.para }{Number of hosts per parasite. } \item{nperm }{Number of permutations for the tests. } } \author{ Pierre Legendre, Universite de Montreal } \references{ Hafner, M. S, P. D. Sudman, F. X. Villablanca, T. A. Spradling, J. W. Demastes and S. A. Nadler. 1994. Disparate rates of molecular evolution in cospeciating hosts and parasites. \emph{Science}, \bold{265}, 1087--1090. Legendre, P., Y. Desdevises and E. Bazin. 2002. A statistical test for host-parasite coevolution. \emph{Systematic Biology}, \bold{51(2)}, 217--234. } \seealso{\code{\link{pcoa}} } \examples{ ## Gopher and lice data from Hafner et al. (1994) data(gopher.D) data(lice.D) data(HP.links) res <- parafit(gopher.D, lice.D, HP.links, nperm=99, test.links=TRUE) # res # or else: print(res) } \keyword{ multivariate } ape/man/plotTreeTime.Rd0000644000175100001440000000257212752420574014532 0ustar hornikusers\name{plotTreeTime} \alias{plotTreeTime} \title{Plot Tree With Time Axis} \description{ This function plots a non-ultrametric tree where the tips are not contemporary together with their dates on the x-axis. } \usage{ plotTreeTime(phy, tip.dates, show.tip.label = FALSE, y.lim = NULL, ...) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{tip.dates}{a vector of the same length than the number of tips in \code{phy} (see details).} \item{show.tip.label}{a logical value; see \code{\link{plot.phylo}}.} \item{y.lim}{by default, one fifth of the plot is left below the tree; use this option to change this behaviour.} \item{\dots}{other arguments to be passed to \code{plot.phylo}.} } \details{ The vector \code{tip.dates} may be numeric or of class \dQuote{\link[base]{Date}}. In either case, the time axis is set accordingly. The length of this vector must be equal to the number of tips of the tree: the dates are matched to the tips numbers. Missing values are allowed. } \value{NULL} \author{Emmanuel Paradis} \seealso{ \code{\link{plot.phylo}}, \code{\link{estimate.dates}} } \examples{ dates <- as.Date(.leap.seconds) tr <- rtree(length(dates)) plotTreeTime(tr, dates) ## handling NA's: dates[11:26] <- NA plotTreeTime(tr, dates) ## dates can be on an arbitrary scale, e.g., [-1, 1]: plotTreeTime(tr, runif(Ntip(tr), -1, 1)) } \keyword{hplot} ape/man/pcoa.Rd0000644000175100001440000001603011747715407013036 0ustar hornikusers\name{pcoa} \alias{pcoa} \alias{biplot.pcoa} \title{ Principal Coordinate Analysis } \description{ Function \code{\link{pcoa}} computes principal coordinate decomposition (also called classical scaling) of a distance matrix D (Gower 1966). It implements two correction methods for negative eigenvalues. } \usage{ pcoa(D, correction="none", rn=NULL) \method{biplot}{pcoa}(x, Y=NULL, plot.axes = c(1,2), dir.axis1=1, dir.axis2=1, rn=NULL, ...) } \arguments{ \item{D}{ A distance matrix of class \code{dist} or \code{matrix}. } \item{correction}{ Correction methods for negative eigenvalues (details below): \code{"lingoes"} and \code{"cailliez"}. Default value: \code{"none"}. } \item{rn}{ An optional vector of row names, of length n, for the n objects. } \item{x}{ Output object from \code{\link{pcoa}}. } \item{Y}{ Any rectangular data table containing explanatory variables to be projected onto the ordination plot. That table may contain, for example, the community composition data used to compute D, or any transformation of these data; see examples. } \item{plot.axes}{ The two PCoA axes to plot. } \item{dir.axis1}{ = -1 to revert axis 1 for the projection of points and variables. Default value: +1. } \item{dir.axis2}{ = -1 to revert axis 2 for the projection of points and variables. Default value: +1. } \item{...}{ Other graphical arguments passed to function. } } \details{ This function implements two methods for correcting for negative values in principal coordinate analysis (PCoA). Negative eigenvalues can be produced in PCoA when decomposing distance matrices produced by coefficients that are not Euclidean (Gower and Legendre 1986, Legendre and Legendre 1998). In \code{pcoa}, when negative eigenvalues are present in the decomposition results, the distance matrix D can be modified using either the Lingoes or the Cailliez procedure to produce results without negative eigenvalues. In the Lingoes (1971) procedure, a constant c1, equal to twice absolute value of the largest negative value of the original principal coordinate analysis, is added to each original squared distance in the distance matrix, except the diagonal values. A newe principal coordinate analysis, performed on the modified distances, has at most (n-2) positive eigenvalues, at least 2 null eigenvalues, and no negative eigenvalue. In the Cailliez (1983) procedure, a constant c2 is added to the original distances in the distance matrix, except the diagonal values. The calculation of c2 is described in Legendre and Legendre (1998). A new principal coordinate analysis, performed on the modified distances, has at most (n-2) positive eigenvalues, at least 2 null eigenvalues, and no negative eigenvalue. In all cases, only the eigenvectors corresponding to positive eigenvalues are shown in the output list. The eigenvectors are scaled to the square root of the corresponding eigenvalues. Gower (1966) has shown that eigenvectors scaled in that way preserve the original distance (in the D matrix) among the objects. These eigenvectors can be used to plot ordination graphs of the objects. We recommend not to use PCoA to produce ordinations from the chord, chi-square, abundance profile, or Hellinger distances. It is easier to first transform the community composition data using the following transformations, available in the \code{decostand} function of the \code{vegan} package, and then carry out a principal component analysis (PCA) on the transformed data: \describe{ \item{ }{Chord transformation: decostand(spiders,"normalize") } \item{ }{Transformation to relative abundance profiles: decostand(spiders,"total") } \item{ }{Hellinger transformation: decostand(spiders,"hellinger") } \item{ }{Chi-square transformation: decostand(spiders,"chi.square") } } The ordination results will be identical and the calculations shorter. This two-step ordination method, called transformation-based PCA (tb-PCA), was described by Legendre and Gallagher (2001). The \code{biplot.pcoa} function produces plots for any pair of principal coordinates. The original variables can be projected onto the ordination plot. } \value{ \item{correction }{The values of parameter \code{correction} and variable 'correct' in the function. } \item{note }{A note describing the type of correction done, if any. } \item{values }{The eigenvalues and related information: } \item{Eigenvalues}{All eigenvalues (positive, null, negative). } \item{Relative_eig}{Relative eigenvalues. } \item{Corr_eig}{Corrected eigenvalues (Lingoes correction); Legendre and Legendre (1998, p. 438, eq. 9.27). } \item{Rel_corr_eig}{Relative eigenvalues after Lingoes or Cailliez correction. } \item{Broken_stick}{Expected fractions of variance under the broken stick model. } \item{Cumul_eig}{Cumulative relative eigenvalues. } \item{Cum_corr_eig}{Cumulative corrected relative eigenvalues. } \item{Cumul_br_stick}{Cumulative broken stick fractions. } \item{vectors}{The principal coordinates with positive eigenvalues. } \item{trace}{The trace of the distance matrix. This is also the sum of all eigenvalues, positive and negative. } \item{vectors.cor }{The principal coordinates with positive eigenvalues from the distance matrix corrected using the method specified by parameter \code{correction}. } \item{trace.cor }{The trace of the corrected distance matrix. This is also the sum of its eigenvalues. } } \references{ Cailliez, F. (1983) The analytical solution of the additive constant problem. \emph{Psychometrika}, \bold{48}, 305--308. Gower, J. C. (1966) Some distance properties of latent root and vector methods used in multivariate analysis. \emph{Biometrika}, \bold{53}, 325--338. Gower, J. C. and Legendre, P. (1986) Metric and Euclidean properties of dissimilarity coefficients. \emph{Journal of Classification}, \bold{3}, 5--48. Legendre, P. and Gallagher, E. D. (2001) Ecologically meaningful transformations for ordination of species data. \emph{Oecologia}, \bold{129}, 271--280. Legendre, P. and Legendre, L. (1998) \emph{Numerical Ecology, 2nd English edition.} Amsterdam: Elsevier Science BV. Lingoes, J. C. (1971) Some boundary conditions for a monotone analysis of symmetric matrices. \emph{Psychometrika}, \bold{36}, 195--203. } \author{ Pierre Legendre, Universite de Montreal } \examples{ # Oribatid mite data from Borcard and Legendre (1994) \dontrun{ if (require(vegan)) { data(mite) # Community composition data, 70 peat cores, 35 species # Select rows 1:30. Species 35 is absent from these rows. Transform to log mite.log <- log(mite[1:30,-35]+1) # Equivalent: log1p(mite[1:30,-35]) # Principal coordinate analysis and simple ordination plot mite.D <- vegdist(mite.log, "bray") res <- pcoa(mite.D) res$values biplot(res) # Project unstandardized and standardized species on the PCoA ordination plot mite.log.st = apply(mite.log, 2, scale, center=TRUE, scale=TRUE) par(mfrow=c(1,2)) biplot(res, mite.log) biplot(res, mite.log.st) # Reverse the ordination axes in the plot par(mfrow=c(1,2)) biplot(res, mite.log, dir.axis1=-1, dir.axis2=-1) biplot(res, mite.log.st, dir.axis1=-1, dir.axis2=-1) } } } \keyword{ multivariate } ape/man/seg.sites.Rd0000644000175100001440000000133312466707232014014 0ustar hornikusers\name{seg.sites} \alias{seg.sites} \title{ Find Segregating Sites in DNA Sequences } \usage{ seg.sites(x) } \arguments{ \item{x}{a matrix or a list which contains the DNA sequences.} } \description{ This function gives the indices of segregating (polymorphic) sites in a sample of DNA sequences. } \details{ If the sequences are in a list, all the sequences must be of the same length. Ambiguous nucleotides are ignored. } \value{ A numeric (integer) vector giving the indices of the segregating sites. } \author{Emmanuel Paradis} \seealso{ \code{\link{base.freq}}, \code{\link[pegas]{theta.s}}, \code{\link[pegas]{nuc.div}} } \examples{ data(woodmouse) y <- seg.sites(woodmouse) y length(y) } \keyword{univar} ape/man/cynipids.Rd0000644000175100001440000000152210775732361013734 0ustar hornikusers\name{data.nex} \docType{data} \alias{data.nex} \alias{cynipids} \title{NEXUS Data Example} \description{ Example of Protein data in NEXUS format (Maddison et al., 1997). Data is written in interleaved format using a single DATA block. Original data from Rokas et al (2002). } \usage{data(cynipids)} \format{ASCII text in NEXUS format} \references{ Maddison, D. R., Swofford, D. L. and Maddison, W. P. (1997) NEXUS: an extensible file format for systematic information. \emph{Systematic Biology}, \bold{46}, 590--621. Rokas, A., Nylander, J. A. A., Ronquist, F. and Stone, G. N. (2002) A maximum likelihood analysis of eight phylogenetic markers in Gallwasps (Hymenoptera: Cynipidae): implications for insect phylogenetic studies. \emph{Molecular Phylogenetics and Evolution}, \bold{22}, 206--219. } \keyword{datasets} ape/man/gammaStat.Rd0000644000175100001440000000273711353106516014027 0ustar hornikusers\name{gammaStat} \alias{gammaStat} \title{Gamma-Statistic of Pybus and Harvey} \usage{ gammaStat(phy) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} } \description{ This function computes the gamma-statistic which summarizes the information contained in the inter-node intervals of a phylogeny. It is assumed that the tree is ultrametric. Note that the function does not check that the tree is effectively ultrametric, so if it is not, the returned result may not be meaningful. } \value{ a numeric vector of length one. } \details{ The gamma-statistic is a summary of the information contained in the inter-node intervals of a phylogeny; it follows, under the assumption that the clade diversified with constant rates, a normal distribution with mean zero and standard-deviation unity (Pybus and Harvey 2000). Thus, the null hypothesis that the clade diversified with constant rates may be tested with \code{2*(1 - pnorm(abs(gammaStat(phy))))} for a two-tailed test, or \code{1 - pnorm(abs(gammaStat(phy)))} for a one-tailed test, both returning the corresponding P-value. } \references{ Pybus, O. G. and Harvey, P. H. (2000) Testing macro-evolutionary models using incomplete molecular phylogenies. \emph{Proceedings of the Royal Society of London. Series B. Biological Sciences}, \bold{267}, 2267--2272. } \author{Emmanuel Paradis} \seealso{ \code{\link{branching.times}}, \code{\link{ltt.plot}}, \code{\link{skyline}} } \keyword{univar} ape/man/cophenetic.phylo.Rd0000644000175100001440000000165111353106324015353 0ustar hornikusers\name{cophenetic.phylo} \alias{cophenetic.phylo} \alias{dist.nodes} \title{Pairwise Distances from a Phylogenetic Tree} \usage{ \method{cophenetic}{phylo}(x) dist.nodes(x) } \arguments{ \item{x}{an object of class \code{"phylo"}.} } \description{ \code{cophenetic.phylo} computes the pairwise distances between the pairs of tips from a phylogenetic tree using its branch lengths. \code{dist.nodes} does the same but between all nodes, internal and terminal, of the tree. } \value{ a numeric matrix with colnames and rownames set to the names of the tips (as given by the element \code{tip.label} of the argument \code{phy}), or, in the case of \code{dist.nodes}, the numbers of the tips and the nodes (as given by the element \code{edge}). } \author{Emmanuel Paradis} \seealso{ \code{\link{read.tree}} to read tree files in Newick format, \code{\link[stats]{cophenetic}} for the generic function } \keyword{manip} ape/man/ape-internal.Rd0000644000175100001440000000340412744637003014465 0ustar hornikusers\name{ape-internal} \alias{tree.build} \alias{f.cherry.yule} \alias{f.cherry.uniform} \alias{sortIndex} \alias{nsca} \alias{perm.rowscols} \alias{mant.zstat} \alias{lower.triang} \alias{clado.build} \alias{phylogram.plot} \alias{cladogram.plot} \alias{circular.plot} \alias{unrooted.plot} \alias{unrooted.xy} \alias{birth.step} \alias{death.step} \alias{ht.move} \alias{loglik.pop} \alias{pos.move} \alias{BOTHlabels} \alias{chronopl.cv} \alias{floating.pie.asp} \alias{checkLabel} \alias{plotCophylo2} \alias{plotPhyloCoor} \alias{integrateTrapeze} \alias{CDF.birth.death} \alias{postprocess.prop.part} \alias{ONEwise} \alias{BaseProportion} \alias{C_additive} \alias{C_bionj} \alias{C_bionjs} \alias{C_ewLasso} \alias{C_mvr} \alias{C_mvrs} \alias{C_nj} \alias{C_njs} \alias{C_pic} \alias{C_rTraitCont} \alias{C_treePop} \alias{C_triangMtd} \alias{C_triangMtds} \alias{C_ultrametric} \alias{C_where} \alias{GlobalDeletionDNA} \alias{DNAbin2indelblock} \alias{SegSites} \alias{bipartition} \alias{delta_plot} \alias{dist_dna} \alias{dist_nodes} \alias{mat_expo} \alias{me_b} \alias{me_o} \alias{neworder_phylo} \alias{neworder_pruningwise} \alias{node_depth} \alias{node_depth_edgelength} \alias{node_height} \alias{node_height_clado} \alias{prop_part} \alias{rawStreamToDNAbin} \alias{seq_root2tip} \alias{treeBuildWithTokens} \alias{polar2rect} \alias{rect2polar} \alias{CountBipartitionsFromTrees} \alias{bitsplits_multiPhylo} \alias{bitsplits_phylo} \alias{racine} \alias{renumeroteArbre} \alias{calculeC} \alias{calculeC_ABM} \alias{calculeC_OU} \alias{glsABM} \alias{glsBM} \alias{glsOUv1} \alias{glsOUv2} \alias{getSumSquare} \alias{getMLHessian} \alias{getREMLHessian} \alias{trans_DNA2AA} \title{Internal Ape Functions} \description{ Internal \pkg{ape} functions. } \keyword{internal} ape/man/plot.phylo.Rd0000644000175100001440000002773412601201423014213 0ustar hornikusers\name{plot.phylo} \alias{plot.phylo} \alias{plot.multiPhylo} \title{Plot Phylogenies} \description{ These functions plot phylogenetic trees on the current graphical device. } \usage{ \method{plot}{phylo}(x, type = "phylogram", use.edge.length = TRUE, node.pos = NULL, show.tip.label = TRUE, show.node.label = FALSE, edge.color = "black", edge.width = 1, edge.lty = 1, font = 3, cex = par("cex"), adj = NULL, srt = 0, no.margin = FALSE, root.edge = FALSE, label.offset = 0, underscore = FALSE, x.lim = NULL, y.lim = NULL, direction = "rightwards", lab4ut = NULL, tip.color = "black", plot = TRUE, rotate.tree = 0, open.angle = 0, node.depth = 1, align.tip.label = FALSE, ...) \method{plot}{multiPhylo}(x, layout = 1, ...) } \arguments{ \item{x}{an object of class \code{"phylo"} or of class \code{"multiPhylo"}.} \item{type}{a character string specifying the type of phylogeny to be drawn; it must be one of "phylogram" (the default), "cladogram", "fan", "unrooted", "radial" or any unambiguous abbreviation of these.} \item{use.edge.length}{a logical indicating whether to use the edge lengths of the phylogeny to draw the branches (the default) or not (if \code{FALSE}). This option has no effect if the object of class \code{"phylo"} has no `edge.length' element.} \item{node.pos}{a numeric taking the value 1 or 2 which specifies the vertical position of the nodes with respect to their descendants. If \code{NULL} (the default), then the value is determined in relation to `type' and `use.edge.length' (see details).} \item{show.tip.label}{a logical indicating whether to show the tip labels on the phylogeny (defaults to \code{TRUE}, i.e. the labels are shown).} \item{show.node.label}{a logical indicating whether to show the node labels on the phylogeny (defaults to \code{FALSE}, i.e. the labels are not shown).} \item{edge.color}{a vector of mode character giving the colours used to draw the branches of the plotted phylogeny. These are taken to be in the same order than the component \code{edge} of \code{phy}. If fewer colours are given than the length of \code{edge}, then the colours are recycled.} \item{edge.width}{a numeric vector giving the width of the branches of the plotted phylogeny. These are taken to be in the same order than the component \code{edge} of \code{phy}. If fewer widths are given than the length of \code{edge}, then these are recycled.} \item{edge.lty}{same than the previous argument but for line types; 1: plain, 2: dashed, 3: dotted, 4: dotdash, 5: longdash, 6: twodash.} \item{font}{an integer specifying the type of font for the labels: 1 (plain text), 2 (bold), 3 (italic, the default), or 4 (bold italic).} \item{cex}{a numeric value giving the factor scaling of the tip and node labels (Character EXpansion). The default is to take the current value from the graphical parameters.} \item{adj}{a numeric specifying the justification of the text strings of the labels: 0 (left-justification), 0.5 (centering), or 1 (right-justification). This option has no effect if \code{type = "unrooted"}. If \code{NULL} (the default) the value is set with respect of \code{direction} (see details).} \item{srt}{a numeric giving how much the labels are rotated in degrees (negative values are allowed resulting in clock-like rotation); the value has an effect respectively to the value of \code{direction} (see Examples). This option has no effect if \code{type = "unrooted"}.} \item{no.margin}{a logical. If \code{TRUE}, the margins are set to zero and the plot uses all the space of the device (note that this was the behaviour of \code{plot.phylo} up to version 0.2-1 of `ape' with no way to modify it by the user, at least easily).} \item{root.edge}{a logical indicating whether to draw the root edge (defaults to FALSE); this has no effect if `use.edge.length = FALSE' or if `type = "unrooted"'.} \item{label.offset}{a numeric giving the space between the nodes and the tips of the phylogeny and their corresponding labels. This option has no effect if \code{type = "unrooted"}.} \item{underscore}{a logical specifying whether the underscores in tip labels should be written as spaces (the default) or left as are (if \code{TRUE}).} \item{x.lim}{a numeric vector of length one or two giving the limit(s) of the x-axis. If \code{NULL}, this is computed with respect to various parameters such as the string lengths of the labels and the branch lengths. If a single value is given, this is taken as the upper limit.} \item{y.lim}{same than above for the y-axis.} \item{direction}{a character string specifying the direction of the tree. Four values are possible: "rightwards" (the default), "leftwards", "upwards", and "downwards".} \item{lab4ut}{(= labels for unrooted trees) a character string specifying the display of tip labels for unrooted trees (can be abbreviated): either \code{"horizontal"} where all labels are horizontal (the default if \code{type = "u"}), or \code{"axial"} where the labels are displayed in the axis of the corresponding terminal branches. This option has an effect if \code{type = "u"}, \code{"f"}, or \code{"r"}.} \item{tip.color}{the colours used for the tip labels, eventually recycled (see examples).} \item{plot}{a logical controlling whether to draw the tree. If \code{FALSE}, the graphical device is set as if the tree was plotted, and the coordinates are saved as well.} \item{rotate.tree}{for "fan", "unrooted", or "radial" trees: the rotation of the whole tree in degrees (negative values are accepted).} \item{open.angle}{if \code{type = "f"} or \code{"r"}, the angle in degrees left blank. Use a non-zero value if you want to call \code{\link{axisPhylo}} after the tree is plotted.} \item{node.depth}{an integer value (1 or 2) used if branch lengths are not used to plot the tree; 1: the node depths are proportional to the number of tips descending from each node (the default and was the only possibility previously), 2: they are evenly spaced.} \item{align.tip.label}{a logical value or an integer. If \code{TRUE}, the tips are aligned and dotted lines are drawn between the tips of the tree and the labels. If an integer, the tips are aligned and this gives the type of the lines (\code{lty}).} \item{layout}{the number of trees to be plotted simultaneously.} \item{\dots}{further arguments to be passed to \code{plot} or to \code{plot.phylo}.} } \details{ If \code{x} is a list of trees (i.e., an object of class \code{"multiPhylo"}), then any further argument may be passed with \code{...} and could be any one of those listed above for a single tree. The font format of the labels of the nodes and the tips is the same. If \code{no.margin = TRUE}, the margins are set to zero and are not restored after plotting the tree, so that the user can access the coordinates system of the plot. The option `node.pos' allows the user to alter the vertical position (i.e., ordinates) of the nodes. If \code{node.pos = 1}, then the ordinate of a node is the mean of the ordinates of its direct descendants (nodes and/or tips). If \code{node.pos = 2}, then the ordinate of a node is the mean of the ordinates of all the tips of which it is the ancestor. If \code{node.pos = NULL} (the default), then its value is determined with respect to other options: if \code{type = "phylogram"} then `node.pos = 1'; if \code{type = "cladogram"} and \code{use.edge.length = FALSE} then `node.pos = 2'; if \code{type = "cladogram"} and \code{use.edge.length = TRUE} then `node.pos = 1'. Remember that in this last situation, the branch lengths make sense when projected on the x-axis. If \code{adj} is not specified, then the value is determined with respect to \code{direction}: if \code{direction = "leftwards"} then \code{adj = 1} (0 otherwise). If the arguments \code{x.lim} and \code{y.lim} are not specified by the user, they are determined roughly by the function. This may not always give a nice result: the user may check these values with the (invisibly) returned list (see ``Value:''). If you use \code{align.tip.label = TRUE} with \code{type = "fan"}, you will have certainly to set \code{x.lim} and \code{y.lim} manually. If you resize manually the graphical device (windows or X11) you may need to replot the tree. } \note{ The argument \code{asp} cannot be passed with \code{\dots}. } \value{ \code{plot.phylo} returns invisibly a list with the following components which values are those used for the current plot: \item{type}{} \item{use.edge.length}{} \item{node.pos}{} \item{node.depth}{} \item{show.tip.label}{} \item{show.node.label}{} \item{font}{} \item{cex}{} \item{adj}{} \item{srt}{} \item{no.margin}{} \item{label.offset}{} \item{x.lim}{} \item{y.lim}{} \item{direction}{} \item{tip.color}{} \item{Ntip}{} \item{Nnode}{} \item{root.time}{} \item{align.tip.label}{} } \author{Emmanuel Paradis} \seealso{ \code{\link{read.tree}}, \code{\link{trex}}, \code{\link{kronoviz}}, \code{\link{add.scale.bar}}, \code{\link{axisPhylo}}, \code{\link{nodelabels}}, \code{\link{edges}}, \code{\link[graphics]{plot}} for the basic plotting function in R } \examples{ ### An extract from Sibley and Ahlquist (1990) cat("(((Strix_aluco:4.2,Asio_otus:4.2):3.1,", "Athene_noctua:7.3):6.3,Tyto_alba:13.5);", file = "ex.tre", sep = "\n") tree.owls <- read.tree("ex.tre") plot(tree.owls) unlink("ex.tre") # delete the file "ex.tre" ### Show the types of trees. layout(matrix(1:6, 3, 2)) plot(tree.owls, main = "With branch lengths") plot(tree.owls, type = "c") plot(tree.owls, type = "u") plot(tree.owls, use.edge.length = FALSE, main = "Without branch lengths") plot(tree.owls, type = "c", use.edge.length = FALSE) plot(tree.owls, type = "u", use.edge.length = FALSE) layout(matrix(1)) data(bird.orders) ### using random colours and thickness plot(bird.orders, edge.color = sample(colors(), length(bird.orders$edge)/2), edge.width = sample(1:10, length(bird.orders$edge)/2, replace = TRUE)) title("Random colours and branch thickness") ### rainbow colouring... X <- c("red", "orange", "yellow", "green", "blue", "purple") plot(bird.orders, edge.color = sample(X, length(bird.orders$edge)/2, replace = TRUE), edge.width = sample(1:10, length(bird.orders$edge)/2, replace = TRUE)) title("Rainbow colouring") plot(bird.orders, type = "c", use.edge.length = FALSE, edge.color = sample(X, length(bird.orders$edge)/2, replace = TRUE), edge.width = rep(5, length(bird.orders$edge)/2)) segments(rep(0, 6), 6.5:1.5, rep(2, 6), 6.5:1.5, lwd = 5, col = X) text(rep(2.5, 6), 6.5:1.5, paste(X, "..."), adj = 0) title("Character mapping...") plot(bird.orders, "u", font = 1, cex = 0.75) data(bird.families) plot(bird.families, "u", lab4ut = "axial", font = 1, cex = 0.5) plot(bird.families, "r", font = 1, cex = 0.5) ### cladogram with oblique tip labels plot(bird.orders, "c", FALSE, direction = "u", srt = -40, x.lim = 25.5) ### facing trees with different informations... tr <- bird.orders tr$tip.label <- rep("", 23) layout(matrix(1:2, 1, 2), c(5, 4)) plot(bird.orders, "c", FALSE, adj = 0.5, no.margin = TRUE, label.offset = 0.8, edge.color = sample(X, length(bird.orders$edge)/2, replace = TRUE), edge.width = rep(5, length(bird.orders$edge)/2)) text(7.5, 23, "Facing trees with\ndifferent informations", font = 2) plot(tr, "p", direction = "l", no.margin = TRUE, edge.width = sample(1:10, length(bird.orders$edge)/2, replace = TRUE)) ### Recycling of arguments gives a lot of possibilities ### for tip labels: plot(bird.orders, tip.col = c(rep("red", 5), rep("blue", 18)), font = c(rep(3, 5), rep(2, 17), 1)) plot(bird.orders, tip.col = c("blue", "green"), cex = 23:1/23 + .3, font = 1:3) co <- c(rep("blue", 9), rep("green", 35)) plot(bird.orders, "f", edge.col = co) plot(bird.orders, edge.col = co) layout(1) } \keyword{hplot} ape/man/drop.tip.Rd0000644000175100001440000001004711353106467013646 0ustar hornikusers\name{drop.tip} \alias{drop.tip} \alias{extract.clade} \title{Remove Tips in a Phylogenetic Tree} \description{ \code{drop.tip} removes the terminal branches of a phylogenetic tree, possibly removing the corresponding internal branches. \code{extract.clade} does the inverse operation: it keeps all the tips from a given node, and deletes all the other tips. } \usage{ drop.tip(phy, tip, trim.internal = TRUE, subtree = FALSE, root.edge = 0, rooted = is.rooted(phy), interactive = FALSE) extract.clade(phy, node, root.edge = 0, interactive = FALSE) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} \item{tip}{a vector of mode numeric or character specifying the tips to delete.} \item{trim.internal}{a logical specifying whether to delete the corresponding internal branches.} \item{subtree}{a logical specifying whether to output in the tree how many tips have been deleted and where.} \item{root.edge}{an integer giving the number of internal branches to be used to build the new root edge. This has no effect if \code{trim.internal = FALSE}.} \item{rooted}{a logical indicating whether the tree must be treated as rooted or not. This allows to force the tree to be considered as unrooted (see examples).} \item{node}{a node number or label.} \item{interactive}{if \code{TRUE} the user is asked to select the tips or the node by clicking on the tree which must be plotted.} } \details{ The argument \code{tip} can be either character or numeric. In the first case, it gives the labels of the tips to be deleted; in the second case the numbers of these labels in the vector \code{phy$tip.label} are given. This also applies to \code{node}, but if this argument is character and the tree has no node label, this results in an error. If more than one value is given with \code{node} (i.e., a vector of length two or more), only the first one is used with a warning. If \code{trim.internal = FALSE}, the new tips are given \code{"NA"} as labels, unless there are node labels in the tree in which case they are used. If \code{subtree = TRUE}, the returned tree has one or several terminal branches indicating how many tips have been removed (with a label \code{"[x_tips]"}). This is done for as many monophyletic groups that have been deleted. Note that \code{subtree = TRUE} implies \code{trim.internal = TRUE}. To undestand how the option \code{root.edge} works, see the examples below. } \value{ an object of class \code{"phylo"}. } \author{Emmanuel Paradis} \seealso{ \code{\link{bind.tree}}, \code{\link{root}} } \examples{ data(bird.families) tip <- c( "Eopsaltriidae", "Acanthisittidae", "Pittidae", "Eurylaimidae", "Philepittidae", "Tyrannidae", "Thamnophilidae", "Furnariidae", "Formicariidae", "Conopophagidae", "Rhinocryptidae", "Climacteridae", "Menuridae", "Ptilonorhynchidae", "Maluridae", "Meliphagidae", "Pardalotidae", "Petroicidae", "Irenidae", "Orthonychidae", "Pomatostomidae", "Laniidae", "Vireonidae", "Corvidae", "Callaeatidae", "Picathartidae", "Bombycillidae", "Cinclidae", "Muscicapidae", "Sturnidae", "Sittidae", "Certhiidae", "Paridae", "Aegithalidae", "Hirundinidae", "Regulidae", "Pycnonotidae", "Hypocoliidae", "Cisticolidae", "Zosteropidae", "Sylviidae", "Alaudidae", "Nectariniidae", "Melanocharitidae", "Paramythiidae","Passeridae", "Fringillidae") plot(drop.tip(bird.families, tip)) plot(drop.tip(bird.families, tip, trim.internal = FALSE)) data(bird.orders) plot(drop.tip(bird.orders, 6:23, subtree = TRUE)) plot(drop.tip(bird.orders, c(1:5, 20:23), subtree = TRUE)) plot(drop.tip(bird.orders, c(1:20, 23), subtree = TRUE)) plot(drop.tip(bird.orders, c(1:20, 23), subtree = TRUE, rooted = FALSE)) ### Examples of the use of `root.edge' tr <- read.tree(text = "(A:1,(B:1,(C:1,(D:1,E:1):1):1):1):1;") drop.tip(tr, c("A", "B"), root.edge = 0) # = (C:1,(D:1,E:1):1); drop.tip(tr, c("A", "B"), root.edge = 1) # = (C:1,(D:1,E:1):1):1; drop.tip(tr, c("A", "B"), root.edge = 2) # = (C:1,(D:1,E:1):1):2; drop.tip(tr, c("A", "B"), root.edge = 3) # = (C:1,(D:1,E:1):1):3; } \keyword{manip} ape/man/coalescent.intervals.Rd0000644000175100001440000000275712473400715016243 0ustar hornikusers\name{coalescent.intervals} \alias{coalescent.intervals} \alias{coalescent.intervals.phylo} \alias{coalescent.intervals.default} \title{Coalescent Intervals} \usage{ coalescent.intervals(x) } \arguments{ \item{x}{either an ultra-metric phylogenetic tree (i.e. an object of class \code{"phylo"}) or, alternatively, a vector of interval lengths.} } \description{ This function extracts or generates information about coalescent intervals (number of lineages, interval lengths, interval count, total depth) from a phylogenetic tree or a list of internode distances. The input tree needs to be ultra-metric (i.e. clock-like). } \value{ An object of class \code{"coalescentIntervals"} with the following entries: \item{lineages}{ A vector with the number of lineages at the start of each coalescent interval.} \item{interval.length}{ A vector with the length of each coalescent interval.} \item{interval.count}{ The total number of coalescent intervals.} \item{total.depth}{ The sum of the lengths of all coalescent intervals.} } \seealso{ \code{\link{branching.times}}, \code{\link{collapsed.intervals}}, \code{\link{read.tree}}. } \author{Korbinian Strimmer} \examples{ data("hivtree.newick") # example tree in NH format tree.hiv <- read.tree(text = hivtree.newick) # load tree ci <- coalescent.intervals(tree.hiv) # from tree ci data("hivtree.table") # same tree, but in table format ci <- coalescent.intervals(hivtree.table$size) # from vector of interval lengths ci } \keyword{manip} ape/man/checkValidPhylo.Rd0000644000175100001440000000125212542213717015154 0ustar hornikusers\name{checkValidPhylo} \alias{checkValidPhylo} \title{Check the Structure of a "phylo" Object} \description{ This function takes as single argument an object (phy), checks its elements, and prints a diagnostic. All problems are printed with a label: FATAL (will likely cause an error or a crash) or MODERATE (may cause some problems). This function is mainly intended for developers creating \code{"phylo"} objects from scratch. } \usage{ checkValidPhylo(phy) } \arguments{ \item{phy}{an object of class \code{"phylo"}.} } \value{ NULL. } \author{Emmanuel Paradis} \examples{ tr <- rtree(3) checkValidPhylo(tr) tr$edge[1] <- 0 checkValidPhylo(tr) } \keyword{manip} ape/man/mcmc.popsize.Rd0000644000175100001440000001342612661357407014527 0ustar hornikusers\name{mcmc.popsize} \alias{mcmc.popsize} \alias{extract.popsize} \alias{plot.popsize} \alias{lines.popsize} \title{Reversible Jump MCMC to Infer Demographic History} \usage{ mcmc.popsize(tree,nstep, thinning=1, burn.in=0,progress.bar=TRUE, method.prior.changepoints=c("hierarchical", "fixed.lambda"), max.nodes=30, lambda=0.5, gamma.shape=0.5, gamma.scale=2, method.prior.heights=c("skyline", "constant", "custom"), prior.height.mean, prior.height.var) extract.popsize(mcmc.out, credible.interval=0.95, time.points=200, thinning=1, burn.in=0) \method{plot}{popsize}(x, show.median=TRUE, show.years=FALSE, subst.rate, present.year, ...) \method{lines}{popsize}(x, show.median=TRUE,show.years=FALSE, subst.rate, present.year, ...) } \arguments{ \item{tree}{Either an ultrametric tree (i.e. an object of class \code{"phylo"}), or coalescent intervals (i.e. an object of class \code{"coalescentIntervals"}). } \item{nstep}{Number of MCMC steps, i.e. length of the Markov chain (suggested value: 10,000-50,000).} \item{thinning}{Thinning factor (suggest value: 10-100).} \item{burn.in}{Number of steps dropped from the chain to allow for a burn-in phase (suggest value: 1000).} \item{progress.bar}{Show progress bar during the MCMC run.} \item{method.prior.changepoints}{If \code{hierarchical}is chosen (the default) then the smoothing parameter lambda is drawn from a gamma distribution with some specified shape and scale parameters. Alternatively, for \code{fixed.lambda} the value of lambda is a given constant. } \item{max.nodes}{Upper limit for the number of internal nodes of the approximating spline (default: 30).} \item{lambda}{Smoothing parameter. For \code{method="fixed.lambda"} the specifed value of lambda determines the mean of the prior distribution for the number of internal nodes of the approximating spline for the demographic function (suggested value: 0.1-1.0).} \item{gamma.shape}{Shape parameter of the gamma function from which \code{lambda} is drawn for \code{method="hierarchical"}.} \item{gamma.scale}{Scale parameter of the gamma function from which \code{lambda} is drawn for \code{method="hierarchical"}.} \item{method.prior.heights}{Determines the prior for the heights of the change points. If \code{custom} is chosen then two functions describing the mean and variance of the heigths in depence of time have to be specified (via \code{prior.height.mean} and \code{prior.height.var} options). Alternatively, two built-in priors are available: \code{constant} assumes constant population size and variance determined by Felsenstein (1992), and \code{skyline} assumes a skyline plot (see Opgen-Rhein et al. 2004 for more details).} \item{prior.height.mean}{Function describing the mean of the prior distribution for the heights (only used if \code{method.prior.heights = custom}).} \item{prior.height.var}{Function describing the variance of the prior distribution for the heights (only used if \code{method.prior.heights = custom}).} \item{mcmc.out}{Output from \code{mcmc.popsize} - this is needed as input for \code{extract.popsize}.} \item{credible.interval}{Probability mass of the confidence band (default: 0.95).} \item{time.points}{Number of discrete time points in the table output by \code{extract.popsize}.} \item{x}{Table with population size versus time, as computed by \code{extract.popsize}. } \item{show.median}{Plot median rather than mean as point estimate for demographic function (default: TRUE).} \item{show.years}{Option that determines whether the time is plotted in units of of substitutions (default) or in years (requires specification of substution rate and year of present).} \item{subst.rate}{Substitution rate (see option show.years).} \item{present.year}{Present year (see option show.years).} \item{\dots}{Further arguments to be passed on to \code{plot}.} } \description{ These functions implement a reversible jump MCMC framework to infer the demographic history, as well as corresponding confidence bands, from a genealogical tree. The computed demographic history is a continous and smooth function in time. \code{mcmc.popsize} runs the actual MCMC chain and outputs information about the sampling steps, \code{extract.popsize} generates from this MCMC output a table of population size in time, and \code{plot.popsize} and \code{lines.popsize} provide utility functions to plot the corresponding demographic functions. } \details{ Please refer to Opgen-Rhein et al. (2005) for methodological details, and the help page of \code{\link{skyline}} for information on a related approach. } \author{ Rainer Opgen-Rhein and Korbinian Strimmer (\url{http://strimmerlab.org}). Parts of the rjMCMC sampling procedure are adapted from \R code by Karl Browman (\url{http://kbroman.org/})} \seealso{ \code{\link{skyline}} and \code{\link{skylineplot}}. } \references{ Opgen-Rhein, R., Fahrmeir, L. and Strimmer, K. 2005. Inference of demographic history from genealogical trees using reversible jump Markov chain Monte Carlo. \emph{BMC Evolutionary Biology}, \bold{5}, 6. } \examples{ # get tree data("hivtree.newick") # example tree in NH format tree.hiv <- read.tree(text = hivtree.newick) # load tree # run mcmc chain mcmc.out <- mcmc.popsize(tree.hiv, nstep=100, thinning=1, burn.in=0,progress.bar=FALSE) # toy run #mcmc.out <- mcmc.popsize(tree.hiv, nstep=10000, thinning=5, burn.in=500) # remove comments!! # make list of population size versus time popsize <- extract.popsize(mcmc.out) # plot and compare with skyline plot sk <- skyline(tree.hiv) plot(sk, lwd=1, lty=3, show.years=TRUE, subst.rate=0.0023, present.year = 1997) lines(popsize, show.years=TRUE, subst.rate=0.0023, present.year = 1997) } \keyword{manip} ape/man/label2table.Rd0000644000175100001440000000405212623120167014251 0ustar hornikusers\name{label2table} \alias{label2table} \alias{stripLabel} \alias{abbreviateGenus} \title{Label Management} \description{ These functions work on a vector of character strings storing bi- or trinomial species names, typically ``Genus_species_subspecies''. } \usage{ label2table(x, sep = NULL, as.is = FALSE) stripLabel(x, species = FALSE, subsp = TRUE, sep = NULL) abbreviateGenus(x, genus = TRUE, species = FALSE, sep = NULL) } \arguments{ \item{x}{a vector of mode character.} \item{sep}{the separator (a single character) between the taxonomic levels (see details).} \item{as.is}{a logical specifying whether to convert characters into factors (like in \code{\link[utils]{read.table}}).} \item{species, subsp, genus}{a logical specifying whether the taxonomic level is concerned by the operation.} } \details{ \code{label2table} returns a data frame with three columns named ``genus'', ``species'', and ``subspecies'' (with \code{NA} if the level is missing). \code{stripLabel} deletes the subspecies names from the input. If \code{species = TRUE}, the species names are also removed, thus returning only the genus names. \code{abbreviateGenus} abbreviates the genus names keeping only the first letter. If \code{species = TRUE}, the species names are abbreviated. By default, these functions try to guess what is the separator between the genus, species and/or subspecies names. If an underscore is present in the input, then this character is assumed to be the separator; otherwise, a space. If this does not work, you can specify \code{sep} to its appropriate value. } \value{ A vector of mode character or a data frame. } \author{Emmanuel Paradis} \seealso{ \code{\link{makeLabel}}, \code{\link{makeNodeLabel}}, \code{\link{mixedFontLabel}} } \examples{ x <- c("Panthera_leo", "Panthera_pardus", "Panthera_onca", "Panthera_uncia", "Panthera_tigris_altaica", "Panthera_tigris_amoyensis") label2table(x) stripLabel(x) stripLabel(x, TRUE) abbreviateGenus(x) abbreviateGenus(x, species = TRUE) abbreviateGenus(x, genus = FALSE, species = TRUE) } \keyword{manip}