New Upstream Snapshot - r-cran-phytools
Ready changes
Summary
Merged new upstream version: 1.5-1+git20230225.1.06aba3c (was: 1.5-1).
Diff
diff --git a/DESCRIPTION b/DESCRIPTION
index 380d25a..1d9dd84 100644
--- a/DESCRIPTION
+++ b/DESCRIPTION
@@ -1,6 +1,6 @@
Package: phytools
-Version: 1.5-1
-Date: 2023-02-17
+Version: 1.5-8
+Date: 2023-02-25
Title: Phylogenetic Tools for Comparative Biology (and Other Things)
Author: Liam J. Revell
Maintainer: Liam J. Revell <liam.revell@umb.edu>
@@ -14,7 +14,7 @@ ZipData: no
Description: A wide range of methods for phylogenetic analysis - concentrated in phylogenetic comparative biology, but also including numerous techniques for visualizing, analyzing, manipulating, reading or writing, and even inferring phylogenetic trees. Included among the functions in phylogenetic comparative biology are various for ancestral state reconstruction, model-fitting, and simulation of phylogenies and trait data. A broad range of plotting methods for phylogenies and comparative data include (but are not restricted to) methods for mapping trait evolution on trees, for projecting trees into phenotype space or a onto a geographic map, and for visualizing correlated speciation between trees. Lastly, numerous functions are designed for reading, writing, analyzing, inferring, simulating, and manipulating phylogenetic trees and comparative data. For instance, there are functions for computing consensus phylogenies from a set, for simulating phylogenetic trees and data under a range of models, for randomly or non-randomly attaching species or clades to a tree, as well as for a wide range of other manipulations and analyses that phylogenetic biologists might find useful in their research.
License: GPL (>= 2)
URL: https://github.com/liamrevell/phytools
-Packaged: 2023-02-17 13:08:50 UTC; liamj
-Repository: CRAN
-Date/Publication: 2023-02-19 13:20:02 UTC
+Packaged: 2023-02-26 12:44:37 UTC; janitor
+Repository:
+Date/Publication:
NeedsCompilation: no
diff --git a/MD5 b/MD5
deleted file mode 100644
index c71029b..0000000
--- a/MD5
+++ /dev/null
@@ -1,307 +0,0 @@
-d784a9fcc06a6b579fba9cf870b0cd41 *DESCRIPTION
-7a383866ffd064b690a44cf5d4ca42ba *NAMESPACE
-ec1dee2fc5dce861a4a896e13a10a9a5 *R/Dtest.R
-ee8f279c7051fd15e5f3b69a78b13d42 *R/add.everywhere.R
-00125e455cd6c2a9a162f414c82b31d3 *R/add.random.R
-30f5b1a58539aec4b00e952018bed1d8 *R/add.species.to.genus.R
-f0df86c98d2fd0c6d76f49ca3172d129 *R/allFurcTrees.R
-24a634dd6c26e4e706ba8afef7591b40 *R/anc.Bayes.R
-717587314843beab5cc2e340d878fb54 *R/anc.ML.R
-227c5163b6303989b36dbe9d50a7f53b *R/anc.trend.R
-96a051e7661aa1e6e5bb86e2fc88b055 *R/ancThresh.R
-a47da3dc00dd6df56555a968d2902b01 *R/backbonePhylo.R
-257581027aa95c317e9b142070df4aa2 *R/bd.R
-f6cd6217da06c39a9a772bc12ed4f08e *R/bmPlot.R
-894d5f9b5dbf164c92714fd15d41dbf9 *R/branching.diffusion.R
-2a55cc93959376dc95536dcf662e5362 *R/brownie.lite.R
-77dabd05904e508c0a4212d428ad1c4e *R/brownieREML.R
-ac74214ded5662595cc95cbf8c4f49f5 *R/collapseTree.R
-1001c3a0359677faf03cd3912d5aacd5 *R/compare.chronograms.R
-9c0c21415d826b468679f6bc08ea85fa *R/consensus.edges.R
-caef8e0013c32733aee9f5c887025966 *R/contMap.R
-076fea423be1fde36126fb028e38ae67 *R/cophylo.R
-c6caa20ceaa72a8a1dc2e71efa9ea19e *R/cospeciation.R
-7bac2c7e46584bde715070a091a96588 *R/cotangleplot.R
-f7ffd39dc1f6c31378ee311508708bfb *R/ctt.R
-d952e7bac14657f6db38a2d061f17e86 *R/densityMap.R
-a651a11526c62a939580958d664aea3d *R/densityTree.R
-4d0db3cfa22ee367a93e56c4459c0db4 *R/dotTree.R
-b0107572580ae9aab4ba0fad010e68d2 *R/drop.tip.simmap.R
-bef780c00ce923e2306295f2dcd7bf8b *R/estDiversity.R
-c9d4a3228dab12645f5ba40b4f65e0bd *R/evol.rate.mcmc.R
-8cd153f13dd4178fc08a1c27392af646 *R/evol.vcv.R
-9c6f7941595c9c8ae1ed18367d332672 *R/evolvcv.lite.R
-164c5aba763c4823fae1a2747cbbdde8 *R/exhaustiveMP.R
-362547498225ba74362a42b118a56fa6 *R/export.as.xml.R
-fc0a8a0fdd8152f5be6036593472c8e6 *R/fancyTree.R
-56e4056490d7004f8d643bc326e4c63e *R/fastAnc.R
-1fb690b492fa00b02e86eaf49b5e48b6 *R/fastBM.R
-fd4043fe4370b493b19344fc752bcdf5 *R/fitBayes.R
-2180796336a37244d12cd384282ae33b *R/fitDiversityModel.R
-aec594586e0909f30cae491a22efcd63 *R/fitHRM.R
-0c258aaf390ba1033b27591f1e851f04 *R/fitMk.R
-eaad0cb4c702a9ba3f7b796a9bf55995 *R/fitMk.parallel.R
-1175bed813495328d4ae6b03e2e8cb8c *R/fitPagel.R
-2313c5868bb1a48ceb89a3f12af424b5 *R/fitmultiMk.R
-0c1b93f933d4df8cceefd43029e3be0f *R/fitpolyMk.R
-f76fee5f3a6c579fa48ee4c49968a49c *R/locate.fossil.R
-449c353c2342e175fee826d6006d1f84 *R/locate.yeti.R
-54b53787c2fab92344f41ede3e02fc0d *R/ls.consensus.R
-6ea4383e233cc9bad8f4d8bfbac954b9 *R/ltt.R
-d1669270abede61af74c637d742da68c *R/ltt95.R
-07c37a4c09941dfa8088c4eb91ef5c4a *R/make.era.map.R
-72295b42a0228c16d0c804c5d2ba9907 *R/make.simmap.R
-b535cd4a22f407601477a0c787a8f869 *R/map.overlap.R
-8835255c4e3fa2df39b3ee24b569db82 *R/map.to.singleton.R
-bf6c23b046ed30ee9e9183582aceb070 *R/mcmcBM.R
-659b234e9ff4b00daa511a06f72d53d2 *R/mcmcBM.full.R
-9fc1c1054aa693a9ad32044d21e9f8c4 *R/mcmcLambda.R
-6f9919970a1d335797cd885a871b5578 *R/mcmcMk.R
-306a63ca65efd0e16b7da49f772363f7 *R/mrp.supertree.R
-314991d69ef55a811ae81746e6c58cc3 *R/multi.mantel.R
-c3ef5e950b24d12acc2dee7d7e5d8a7a *R/multiRF.R
-5e712e1f12522da7e4757c863cc1824f *R/multirateBM.R
-88577354c3e54f3c98269577681df2c7 *R/optim.phylo.ls.R
-4251fbfa33b24cedd655a575878bee3a *R/paintSubTree.R
-86f26b836e23ca7099d522bc2c8ab79c *R/pbtree.R
-fef356d572879792545c304320125813 *R/pgls.Ives.R
-d6ae21d0453462f3a71d04494b9e5a08 *R/phenogram.R
-93cdbb83a29c009a6381af932cb78b87 *R/phyl.RMA.R
-3cbec3ddb43718bf824e1b4b5b1bb92b *R/phyl.cca.R
-c5a5ca010ce84d18d6dd6aa9d729036c *R/phyl.pairedttest.R
-66237234f99e5b0800539f3990998598 *R/phyl.pca.R
-17d0e8f613fafc8cf7e0a719120dd9cd *R/phyl.resid.R
-40e566b43e7ff3e033e03d6b5c4e0fff *R/phylANOVA.R
-82754e445e944f49ccacc078a185f36c *R/phylo.heatmap.R
-3fd0311c0d039889d2cca7347e3aaee8 *R/phylo.impute.R
-a790f313c41874bdc6d97d9a86e9a5ed *R/phylo.to.map.R
-963b45797954ac24ffab58bc0a91551b *R/phylomorphospace.R
-1047bf81c8871bdddbfbfb3080d4c6a6 *R/phylomorphospace3d.R
-7ffa39d663ee1c8c3f3cf747ab02164c *R/phylosig.R
-3a5045f97da2d4f697eea1e86e46edb7 *R/plotBranchbyTrait.R
-5c8483e6c088a66acb7c8284d1784bb5 *R/plotSimmap.R
-63e433890b55602e22ce473680828e9f *R/plotTree.datamatrix.R
-a58e6ab65dca2e69dde3266c9d05e51e *R/plotTree.errorbars.R
-9037dc151922c837a92591eb6edfc25b *R/plotTree.wBars.R
-bc0699095386afd623fa2385c68eb218 *R/project.phylomorphospace.R
-02df797e383cdddf592d59c24729cab7 *R/ratebystate.R
-c393517b7ce4f9ccd5a44dfa4d541583 *R/ratebytree.R
-a438d21b39fecc8c9cd0a3f309497dc7 *R/rateshift.R
-10aa4276f62187281eaa23d509df6f58 *R/read.newick.R
-970fb5a7146e3e1626e50fc14ffaef6f *R/read.simmap.R
-4ecad496058c6f0f515d3322084deb6f *R/readNexus.R
-2658841a3af53c82b86513482e4f0bd2 *R/rerootingMethod.R
-ba26eefe861f14105c46ee13652c5b66 *R/resolveNodes.R
-12f199b328667ae83060589b5d2db4fc *R/roundPhylogram.R
-d8a6bb753f6779a1dd49e769b18775a0 *R/sim.corrs.R
-a02ce76ea678143f57284dae55f34531 *R/sim.history.R
-f83f44a29df59f5ff489e0120c4c328b *R/sim.rates.R
-de02f79e452899513b9e72530461e288 *R/simBMphylo.R
-5ae6a2a091d203ecc04ad6081e11293d *R/skewers.R
-606ad5a902660277dce5f3ef7fed7461 *R/splitplotTree.R
-c8bfa07dd3238d97fcaafe5a369e5e89 *R/starTree.R
-0567456c325cbac2c305158ffa05df91 *R/strahlerNumber.R
-c37de78fdffbe7d46822429a2b8aa7ff *R/threshBayes.R
-5a8a89c2fe9a2e54e4d7ef961e241198 *R/tree.grow.R
-7e547545cd50de19581af1e1c179e967 *R/treeSlice.R
-7efc2dc32dcd7d39ab1ac62f3f259327 *R/utilities.R
-4c418f19c184c846f28f696969142bd0 *R/write.simmap.R
-330c6341bb2ec53e088179f3bae974b9 *R/writeAncestors.R
-65bf87a538f44806311e8914317b242c *R/writeNexus.R
-8e78dfc6a432989f6cf7c6d9459b88d9 *data/anole.data.rda
-0cc04b5f3865c524c8ec36dc84eccef6 *data/anoletree.rda
-7c9a9a27df82353d416095a61344c82f *data/bonyfish.data.rda
-9ac6133c528ddd36a866043de32a8bb3 *data/bonyfish.tree.rda
-39385e3cf494b74dbda4017ab260766f *data/datalist
-0416c11b7757a8a1b7d4ac5b1e4b4fb5 *data/flatworm.data.rda
-0a5fc0e193972b61d818e4fdf6b733d1 *data/flatworm.tree.rda
-2e7961b7ea60d665bfd7a65fd23b11db *data/mammal.data.rda
-114305e2f421cba146fd300da570ab92 *data/mammal.tree.rda
-5807bfb760e5b9d95822d9efe4524639 *data/salamanders.rda
-c7367501b639064f0b47dbc088213730 *data/sunfish.data.rda
-5e76e37fc53b3002673868b074ca89ff *data/sunfish.tree.rda
-e3023f4223c0c3863596df1581c4a468 *data/vertebrate.data.rda
-f5e1db184a75019f551868c00ed2293a *data/vertebrate.tree.rda
-b7fbd42a08d4aca73426dbb42de518c3 *data/wasp.data.rda
-5f4d2752a6176f1bc9ec31cab308b7ce *data/wasp.trees.rda
-ea3a903943df39c519dd98e446479623 *inst/CITATION
-9baa2b7ad35cd350693485c41eec6433 *man/Dtest.Rd
-f3ffbd3ce9b2aa5e6bccc43a46a7963b *man/add.arrow.Rd
-8ab4036c27665c7bf7fd78fd2351d83d *man/add.color.bar.Rd
-4c61574818477466c1e568cc917535b5 *man/add.everywhere.Rd
-64fcce9e642e54e9e857ba1fe7bb9198 *man/add.random.Rd
-be30fed5dd8d18153fd8178e1ac52062 *man/add.simmap.legend.Rd
-5f7cd32014aaecbccb39a497dd7bd580 *man/add.species.to.genus.Rd
-7729ccfc0cede7b953c44df20df475b0 *man/aic.w.Rd
-51a29f06f098a929844032c71aa53f35 *man/allFurcTrees.Rd
-b441a05f1f4c8618885f143b538ceb81 *man/anc.Bayes.Rd
-8d45c1801097c7ca3a251781a03bc21b *man/anc.ML.Rd
-d91b03e965d9e52e2e08675f6a3c2aba *man/anc.trend.Rd
-cdf59fe3e6b626f7b82f9a885b1a4bea *man/ancThresh.Rd
-e5514b4bacde14bc8a096fe34561885f *man/anoletree.Rd
-ab80b56f48d088bcd10b61b61e8ac17a *man/applyBranchLengths.Rd
-dec6e9ef3937c2a67e43e9d2a2cb39ba *man/as.Qmatrix.Rd
-9438d11405f55849b8b13173e0aa677f *man/as.multiPhylo.Rd
-003cb67223bec651d62da6e7b6cfdf19 *man/ave.rates.Rd
-7776d76cfb312b3dc85111783de0df0e *man/averageTree.Rd
-5f126f47d4639506e232b4d3b746a0f9 *man/bd.Rd
-1cc30821afeee52c4051c6fd3eeed029 *man/bind.tip.Rd
-f2030ef6c3676e46f6b3f433444fe849 *man/bind.tree.simmap.Rd
-dedac1a6ea11169e29142c41508bdeca *man/bmPlot.Rd
-34f07b971596f7bc060eb3a156d42efb *man/branching.diffusion.Rd
-3be5b3f4a70c91f85dbc69e6b6b713ec *man/brownie.lite.Rd
-15fd77547cbfc3c2a33d3bec5b3ed3a0 *man/brownieREML.Rd
-042de0e1cb33cae35557b371fab36408 *man/cladelabels.Rd
-bcc114c7da03ae5ef9f7f0ed4b7377d2 *man/collapse.to.star.Rd
-3e1aee85e346e45616e013c9a0985eb3 *man/collapseTree.Rd
-89c0b7b387c469ba02ce21ff56933924 *man/compare.chronograms.Rd
-f336f7a875848b994225d07909c433d8 *man/consensus.edges.Rd
-239aef5db5a15fb0e06d59832541a9a3 *man/contMap.Rd
-7d4b3f72e7725ad47d2ca7d78064eb3a *man/cophylo.Rd
-cbd91b7bb2eb7d09dadb9d92b11c206d *man/cospeciation.Rd
-4daad4906625e94557608e3d41dfcad0 *man/countSimmap.Rd
-f2716eeae1f6faa43fe563185382de30 *man/ctt.Rd
-f1dd7f74a70d0042c0c9798363f3af42 *man/density.multiSimmap.Rd
-e8cfd724105953042d14c8c1c4e4da70 *man/densityMap.Rd
-ac498b46bedc5b518ad07b7093e56608 *man/densityTree.Rd
-eb1c7747cd5cdf5175050313d2f52845 *man/describe.simmap.Rd
-2073a0159b94df58080986061fcd978a *man/di2multi.simmap.Rd
-76ba9e500f6c1f963cbd878a39ed0752 *man/dotTree.Rd
-f0113ae1157cbb8da2c43b522d2ca325 *man/drop.clade.Rd
-139cf35fd81a07386ea5489a3c8a549e *man/drop.leaves.Rd
-ffaac4ea05aa1e1da259ea1c278865d6 *man/drop.tip.contMap.Rd
-970b00bea470a4e2d7e9173dfb7cc041 *man/drop.tip.multiSimmap.Rd
-70116950bd4528bdfe248f9b6f480fdb *man/drop.tip.simmap.Rd
-bf7793b411b4187a2841b8cfb6a6fb64 *man/edge.widthMap.Rd
-a55500813fdde766a51df618a55bd053 *man/edgeProbs.Rd
-5de72444745ec120615c13cdb1b6161b *man/estDiversity.Rd
-6cce55fb1b9ccf3d9de445a1bdba0b17 *man/evol.rate.mcmc.Rd
-bc4d91a36af89e8388be706d2bf3d5d2 *man/evol.vcv.Rd
-734799ec4ee69c7023d460f2cd536338 *man/evolvcv.lite.Rd
-3c24a2e2a22e110bf5d8047befa0b386 *man/exhaustiveMP.Rd
-2049d1bf65553877271b5b8aed85d3fb *man/expand.clade.Rd
-a062b9e61c0e205ab20b47694a254f66 *man/export.as.xml.Rd
-ca0e6d0c2bc032a4781c2358f1eec100 *man/fancyTree.Rd
-22b3c3e03fbe2249a3907fe53ac9cc08 *man/fastAnc.Rd
-0740eff5f65876bedb4a6615feab198c *man/fastBM.Rd
-e4061e052807c4d2ff22a0266f2534e8 *man/fastMRCA.Rd
-e2101e9bb133b4469e5d727110a0ed1c *man/findMRCA.Rd
-2a45a9eb7050f770508ead57f30996c8 *man/fit.bd.Rd
-1376db8d3c1c2d22473299278f76f115 *man/fitBayes.Rd
-bdcf1bf6659f03fcde5836942c23fe31 *man/fitDiversityModel.Rd
-ef8788d3ea0f3601ab463949f638b361 *man/fitMk.Rd
-8e331b2f03806f3f3dd0e1b423a15919 *man/fitPagel.Rd
-fcdf2657aaa42c3ed52f740b6537f27b *man/force.ultrametric.Rd
-1b8c690f7a0c981bdeb6023ceea6986d *man/gammatest.Rd
-409c1773eea2348c051315cb382f8dc8 *man/genSeq.Rd
-99998f0b88edfe01dc75aa8d8c7b0396 *man/geo.legend.Rd
-695f2b282891d9f34ebff0382dc458be *man/get.treepos.Rd
-6ca10ad3d8ae7823a3ebebeaaa903a26 *man/getCladesofSize.Rd
-95c8b03bbb8189d93a9566684566aa1a *man/getDescendants.Rd
-cf52f3e1cbc04c7ac2480d0a0d9b16ce *man/getExtant.Rd
-f96761cc5d18a47e49048ab2cbe44c99 *man/getSisters.Rd
-498adc5e64a35e28efc8907eda1b15d3 *man/getStates.Rd
-347b1fb2ead9f3915361a6d0664b0b2d *man/labelnodes.Rd
-e342248d52a5a7f65523c61146e91e2f *man/ladderize.simmap.Rd
-e4211f0e2eb30c82318b651e3572c02c *man/lambda.transform.Rd
-2db4ff0b2532fe58551c6c87993d6cfe *man/likMlambda.Rd
-8006a4eee417ed3931723bd6e4de0ede *man/linklabels.Rd
-0d673df1987577167743f51fa319844e *man/locate.fossil.Rd
-c62bce45bf8eca394a2bb27cbe6422b1 *man/locate.yeti.Rd
-8f927ddb6808503a4d63c9c3b3adbbe2 *man/ls.tree.Rd
-08e7ea233d10bf4605157122be672f1d *man/ltt.Rd
-9af05dd775c73f2d52363ea184cc2735 *man/ltt95.Rd
-59cd0dc101f24549146b595a972ab837 *man/make.era.map.Rd
-2e5a324ae73f356b68cf35229d0150b1 *man/make.simmap.Rd
-63f3db99eb856d6c5e726d0636cf75d3 *man/map.overlap.Rd
-28dee44d23180929afe0f19e8b099043 *man/map.to.singleton.Rd
-7bc0bf4a400013d8506a144b98663d09 *man/mapped.states.Rd
-c88fb6787a7b5196eb62bdbecdfc2611 *man/markChanges.Rd
-b994ac9f0b2229caaba5edd75914e793 *man/matchNodes.Rd
-2b7fd0ab412661f29636eb5d5b1842e7 *man/mergeMappedStates.Rd
-061bddca6a7bd070f358f6f418aa4578 *man/midpoint.root.Rd
-3555d9d80a3dcd6fcb8b43fa6c94bca5 *man/minRotate.Rd
-adca1bf45a46f3054966f66989d06157 *man/minSplit.Rd
-e8471e729798e4dd977eaa323cf0d98d *man/modified.Grafen.Rd
-db146b40e62ef39bdd241a67e1336886 *man/mrp.supertree.Rd
-21cc9f90c7e6ad96f6d40b8927d43135 *man/multi.mantel.Rd
-75c73c1667a123cfcf70cce0832d2364 *man/multiC.Rd
-3ec09cb3680a1497d388b91696e11e70 *man/multiRF.Rd
-83a349179e5ef384fed23493edc09884 *man/multirateBM.Rd
-a6bb7615e039557d6da09ee7d210b73b *man/nodeHeights.Rd
-b8061afef967e33d70e5646761eea00e *man/nodelabels.cophylo.Rd
-d7e580ac4de7b40b2bd038b14c4a9af8 *man/optim.phylo.ls.Rd
-75452a5a15cfa926c155d2b816e85d76 *man/orderMappedEdge.Rd
-f31d5a84f32a1ed49460ba18d78e47f2 *man/paintSubTree.Rd
-5b044e7989c5746ec495187828e24e5d *man/paste.tree.Rd
-2d8680964051c98eebe3f12d2f3d40e6 *man/pbtree.Rd
-90db0184a1ea2cf3cc384f9d198980ef *man/pgls.Ives.Rd
-08d6e7044d069d7838f2c30f9037cb54 *man/phenogram.Rd
-fd8e21403e8feb774d026ab23ef801ef *man/phyl.RMA.Rd
-125d35d161e1197b9e3dd4dd4059a92b *man/phyl.cca.Rd
-5d1ae6e7f74de63389c378f834a9245d *man/phyl.pairedttest.Rd
-87d60319886073b860b693312eada927 *man/phyl.pca.Rd
-2dfb8b08b1d315ccc0b7e241e5f50664 *man/phyl.resid.Rd
-4bbc1adeba779718f8740aa24a39d180 *man/phyl.vcv.Rd
-a6def57a5d03f5357ec48f5bf2347fe5 *man/phylANOVA.Rd
-0ea23c0854c1fefff37c216bdea19d82 *man/phylo.heatmap.Rd
-78079b82c95d1ccc70a5d674bc4f0a0e *man/phylo.impute.Rd
-7278e58e4ecdd366cd7f62f3ae1da37a *man/phylo.to.map.Rd
-95aa8b498df77e1b9ea962512e42ce2f *man/phylo.toBackbone.Rd
-3a2d310bb460a7a129fc6fbffc3692ad *man/phyloDesign.Rd
-3dca18e27279f228f11b6c7f3d71028a *man/phylomorphospace.Rd
-bfd7e28984a7af08dc7770e75c7866a4 *man/phylomorphospace3d.Rd
-84cc3c145d7f8d968619b6f78bace46f *man/phylosig.Rd
-571e0a032be3fef223d6727c2c7d4b47 *man/phytools-package.Rd
-06d4022eaab8994e28e4f35e49447d3f *man/plot.backbonePhylo.Rd
-54364606905810782951e356353ffa6f *man/plotBranchbyTrait.Rd
-5b755405f35ed377518968d0411ffded *man/plotSimmap.Rd
-2fd988860baada6e88901ffff17aefc7 *man/plotThresh.Rd
-c671eab19f9dcae8772db77bcaed5568 *man/plotTree.Rd
-de3788fa075e72bb5352eff0ff82b81e *man/plotTree.datamatrix.Rd
-028fb0ca902c0cf9ffcdc47ad85da56e *man/plotTree.errorbars.Rd
-3d16d35355b6b4af575b3983425bc9f9 *man/plotTree.wBars.Rd
-21301f5d19f3fd05c80bacc240ec4f25 *man/posterior.evolrate.Rd
-90f7dcf4d5fa36e21680ebc792d5f8bb *man/posthoc.Rd
-4bfa72a7ac47c3e185164f8c35dd5e13 *man/print.backbonePhylo.Rd
-d0c826feb65800d66d8bcb4ee3d38a63 *man/ratebystate.Rd
-ff33585c3f68c8af29352e0ffea00e9b *man/ratebytree.Rd
-322eaebd24ca9a24a49d47c4e68a6361 *man/rateshift.Rd
-e5a2baef028e66e9920c8af0f45ae41d *man/read.newick.Rd
-9f8cbc3a9c914a0f11a438c0ab84a215 *man/read.simmap.Rd
-d48ff16c889ec853efdcdfd12744ed62 *man/reorder.backbonePhylo.Rd
-2f30293ebd76c2995c7a4e2def299a69 *man/reorderSimmap.Rd
-aa85c68c58fad5f095213754e50c64ab *man/rep.phylo.Rd
-c609849e47c5da5f448643036c25552f *man/reroot.Rd
-c122687233a98295b0c9c3762e472100 *man/rerootingMethod.Rd
-d93d28ae354577b0ba87b0aea8a2dce9 *man/rescale.Rd
-b00607302db0556a57825d725c7875e3 *man/rescaleSimmap.Rd
-15a472e42e237436d7bd9591dfdf654c *man/resolveNode.Rd
-e1d563fcfc4085113c43b6191046463f *man/rotateNodes.Rd
-de91db87181c6df1cfd4b221d8f9f1ee *man/roundBranches.Rd
-d609fd3437a2a0c8fee054e13eec0f4f *man/roundPhylogram.Rd
-56abc60b7e418eebb2aae1c089af0f63 *man/rstate.Rd
-d2fa304f06d7b8ef8401bf98e188f8ee *man/sampleFrom.Rd
-c93b1442ea7b26888b505f7c592332da *man/setMap.Rd
-32ab0d5989e36f5802f9b723a833d609 *man/sim.corrs.Rd
-14285b9f6f530cf3e0839e3361e6055a *man/sim.history.Rd
-0cfcbb88f15de5aecb5d9d13a80f5481 *man/sim.ratebystate.Rd
-9ffd1ec2ef5bd51e9bc09b88765994c4 *man/sim.rates.Rd
-ec834efa2579ef5cffa245566b2a52d5 *man/simBMphylo.Rd
-53a81f1ea9a78fd41bc1c9d19c0c6c37 *man/skewers.Rd
-2368b0b30f88863b359000af4baee23a *man/splitEdgeColor.Rd
-ec1eaa30fa7459e0960c20e09197c059 *man/splitTree.Rd
-ef0e9b45b5ed220bf4655a354e50690f *man/splitplotTree.Rd
-f2a23510b98418d2b3c84e6a1e193b17 *man/starTree.Rd
-a3944ac44ff4ebc744136ef2904b80f6 *man/strahlerNumber.Rd
-059528ef7fa394e33179fbede65012cf *man/threshBayes.Rd
-cfdd7195f747337380bf55fc11942030 *man/threshDIC.Rd
-291773729279996c42b731b80bde28b5 *man/threshState.Rd
-04b4515be794d5bb25b3905c43a5c2e2 *man/to.matrix.Rd
-a9f2727e48585ba8f0d5b114531ee0f4 *man/tree.grow.Rd
-aee4b91374ea4c70ee5d175b10907d36 *man/treeSlice.Rd
-667aa7eadae12091130a65d1601d4dce *man/untangle.Rd
-06e26926bffa2e051a46fe11a148c8d2 *man/vcvPhylo.Rd
-b28c15540be87b5604a42a5fb53c055e *man/write.simmap.Rd
-61b487f1d573209ae3c4ab4e3b4f0afb *man/writeAncestors.Rd
-7a6f6917b1ab5967b79654170969e290 *man/writeNexus.Rd
diff --git a/NAMESPACE b/NAMESPACE
index a865258..366823d 100644
--- a/NAMESPACE
+++ b/NAMESPACE
@@ -1,290 +1,293 @@
-export(add.arrow, add.color.bar, add.everywhere, add.random, add.simmap.legend)
-export(add.species.to.genus, aic.w, allFurcTrees, allRotations, anc.Bayes, anc.ML)
-export(anc.trend, ancThresh, applyBranchLengths, arc.cladelabels, as.multiPhylo)
-export(as.princomp, as.princomp.phyl.pca, as.Qmatrix, ave.rates, averageTree)
-export(backbone.toPhylo, bd, bmPlot, bind.tip, bind.tree.simmap, biplot.phyl.pca)
-export(branching.diffusion, brownie.lite, brownieREML)
-export(cladelabels, coef.phyl.RMA, collapse.to.star, collapseTree, compare.chronograms)
-export(consensus.edges, contMap, cophylo, countSimmap, compute.mr, cotangleplot, cospeciation)
-export(ctt)
-export(density.anc.Bayes, density.multiSimmap, densityMap, densityTree, describe.simmap)
-export(di2multi.simmap, dot.legend, dotTree, drop.clade, drop.leaves, drop.tip.contMap)
-export(drop.tip.densityMap, drop.tip.multiSimmap, drop.tip.simmap, drop.tip.singleton, Dtest)
-export(edge.widthMap, edgelabels.cophylo, edgeProbs, errorbar.contMap, estDiversity)
-export(evol.rate.mcmc, evol.vcv, evolvcv.lite, exhaustiveMP, expand.clade, export.as.xml)
-export(extract.clade.simmap, extract.strahlerNumber)
-export(fancyTree, fastAnc, fastBM, fastDist, fastHeight, fastMRCA, findMRCA, fit.bd)
-export(fit.yule, fitBayes, fitHRM, fitMk, fitMk.parallel, fitmultiMk, fitpolyMk, fitDiversityModel)
-export(fitPagel, force.ultrametric)
-export(gammatest, genus.to.species.tree, genSeq, geo.palette, geo.legend, get.treepos)
-export(getCladesofSize, getDescendants, getExtant, getExtinct, getnode, getParent)
-export(getSisters, getStates, graph.polyMk, gtt)
-export(keep.tip.contMap, keep.tip.densityMap, keep.tip.multiSimmap, keep.tip.simmap)
-export(labelnodes, ladderize.simmap, lambda.transform, lik.bd, likMlambda)
-export(likSurface.rateshift, linklabels, locate.fossil, locate.yeti)
-export(ls.consensus, ls.tree, ltt, ltt95, ltt.multiPhylo, ltt.multiSimmap, ltt.phylo, ltt.simmap)
-export(make.era.map, make.simmap, make.transparent, map.overlap, Map.Overlap)
-export(map.to.singleton, mapped.states, markChanges, matchLabels, matchNodes, mccr)
-export(mcmcMk, mergeMappedStates, midpoint.root, minRotate, minSplit, minTreeDist)
-export(modified.Grafen, mrp.supertree, multi.mantel, multiC, multiOU, multiRF)
-export(multirateBM)
-export(nodeheight, nodeHeights, nodelabels.cophylo, node.paths)
-export(optim.phylo.ls, orderMappedEdge)
-export(paintBranches, paintSubTree, paste.tree, pbtree, pgls.Ives, pgls.SEy, phenogram)
-export(phenogram95, phyl.cca, phyl.pairedttest, phyl.pca, phyl.resid, phyl.RMA)
-export(phyl.vcv, phylo.heatmap, phylo.impute, phylo.toBackbone, phylo.to.map, phylANOVA)
-export(phyloDesign, phylomorphospace, phylomorphospace3d, phyloScattergram, phylosig)
-export(plot.anc.Bayes, plot.changesMap, plot.contMap, plot.cophylo, plot.densityMap)
-export(plot.edge.widthMap, plot.fitMk, plot.fitPagel, plot.gfit, plot.phyl.RMA)
-export(plot.phylo.to.map, plot.Qmatrix, plot.simBMphylo, plotBranchbyTrait, plot.phylosig)
-export(plotSimmap, plotThresh, plotTree, plotTree.barplot, plotTree.boxplot)
-export(plotTree.datamatrix, plotTree.errorbars, plotTree.singletons, plotTree.splits)
-export(plotTree.wBars, posterior.evolrate, posthoc, posthoc.ratebytree, print.Qmatrix)
-export(project.phylomorphospace)
-export(ratebystate, ratebytree, rateshift, read.newick, read.simmap, readNexus)
-export(reorder.backbonePhylo, reorderSimmap, rep.multiPhylo, rep.phylo, repPhylo, reroot)
-export(rerootingMethod, rescale, rescale.multiSimmap, rescale.simmap, rescaleSimmap, resolveAllNodes)
-export(resolveNode, rootedge.to.singleton, rotate.multi, rotateNodes, roundBranches, roundPhylogram)
-export(rstate)
-export(sampleFrom, scores, scores.phyl.pca, setMap, sigmoidPhylogram, sim.corrs, sim.ctt)
-export(sim.history, sim.Mk, sim.multiCtt, sim.multiMk, sim.ratebystate, sim.rates)
-export(simBMphylo, skewers, splinePhylogram, splitEdgeColor, splitplotTree, splitTree, starTree)
-export(strahlerNumber)
-export(threshBayes, threshDIC, threshState, tiplabels.cophylo, tipRotate, to.matrix)
-export(tree.grow, treeSlice)
-export(untangle)
-export(vcvPhylo)
-export(write.simmap, writeAncestors, writeNexus)
-
-S3method(plot, densityMap)
-S3method(plot, contMap)
-S3method(plot, phylo.to.map)
-S3method(plot, backbonePhylo)
-S3method(reorder, backbonePhylo)
-S3method(print, backbonePhylo)
-S3method(print, phyl.pca)
-S3method(summary, phyl.pca)
-S3method(biplot, phyl.pca)
-S3method(print, brownie.lite)
-S3method(print, densityMap)
-S3method(print, contMap)
-S3method(print, rateshift)
-S3method(logLik, rateshift)
-S3method(print, evol.vcv)
-S3method(plot, ltt95)
-S3method(print, ltt95)
-S3method(plot, describe.simmap)
-S3method(print, describe.simmap)
-S3method(rep, phylo)
-S3method(rep, multiPhylo)
-S3method(print, fitPagel)
-S3method(print, ltt)
-S3method(print, multiLtt)
-S3method(plot, ltt)
-S3method(plot, multiLtt)
-S3method(plot, cophylo)
-S3method(print, cophylo)
-S3method(plot, simmap)
-S3method(print, simmap)
-S3method(summary, simmap)
-S3method(plot, multiSimmap)
-S3method(print, multiSimmap)
-S3method(summary, multiSimmap)
-S3method(reorder, simmap)
-S3method(plot, rateshift)
-S3method(print, fastAnc)
-S3method(print, anc.ML)
-S3method(print, fitMk)
-S3method(summary, fitMk)
-S3method(logLik, fitMk)
-S3method(print, brownieREML)
-S3method(print, phylo.to.map)
-S3method(as.phylo, simmap)
-S3method(as.multiPhylo, multiSimmap)
-S3method(as.multiPhylo, phylo)
-S3method(plot, fitPagel)
-S3method(plot, fitMk)
-S3method(plot, gfit)
-S3method(plot, phyl.pca)
-S3method(summary, cophylo)
-S3method(print, multiCophylo)
-S3method(plot, multiCophylo)
-S3method(logLik, simmap)
-S3method(logLik, multiSimmap)
-S3method(plot, cospeciation)
-S3method(print, cospeciation)
-S3method(density, multiSimmap)
-S3method(plot, changesMap)
-S3method(print, changesMap)
-S3method(plot, phyloScattergram)
-S3method(print, phyloScattergram)
-S3method(di2multi, simmap)
-S3method(print, aic.w)
-S3method(print, phyl.RMA)
-S3method(coef, phyl.RMA)
-S3method(residuals, phyl.RMA)
-S3method(plot, phyl.RMA)
-S3method(print, ratebytree)
-S3method(print, evolvcv.lite)
-S3method(print, expand.clade)
-S3method(plot, expand.clade)
-S3method(posthoc, ratebytree)
-S3method(print, posthoc.ratebytree)
-S3method(AIC, ratebytree)
-S3method(print, fit.bd)
-S3method(logLik, fit.bd)
-S3method(print, anc.trend)
-S3method(logLik, anc.trend)
-S3method(print, ancThresh)
-S3method(plot, ancThresh)
-S3method(print, evol.rate.mcmc)
-S3method(print, threshBayes)
-S3method(plot, threshBayes)
-S3method(print, rerootingMethod)
-S3method(plot, rerootingMethod)
-S3method(logLik, rerootingMethod)
-S3method(print, fitBayes)
-S3method(plot, fitBayes)
-S3method(print, ratebystate)
-S3method(print, phylANOVA)
-S3method(print, pgls.Ives)
-S3method(logLik, pgls.Ives)
-S3method(print, phyl.cca)
-S3method(print, anc.Bayes)
-S3method(plot, anc.Bayes)
-S3method(print, phyl.pairedttest)
-S3method(print, multi.mantel)
-S3method(residuals, multi.mantel)
-S3method(fitted, multi.mantel)
-S3method(print, ctt)
-S3method(print, multiCtt)
-S3method(plot, ctt)
-S3method(plot, multiCtt)
-S3method(print, fitmultiMk)
-S3method(summary, fitmultiMk)
-S3method(logLik, fitmultiMk)
-S3method(plot, gtt)
-S3method(print, gtt)
-S3method(print, mcmcMk)
-S3method(print, Dtest)
-S3method(print, mccr)
-S3method(plot, mccr)
-S3method(print, fitpolyMk)
-S3method(logLik, fitpolyMk)
-S3method(plot, fitpolyMk)
-S3method(plot, mcmcMk)
-S3method(summary, mcmcMk)
-S3method(density, mcmcMk)
-S3method(print, density.mcmcMk)
-S3method(plot, density.mcmcMk)
-S3method(multi2di, simmap)
-S3method(di2multi, multiSimmap)
-S3method(multi2di, multiSimmap)
-S3method(di2multi, contMap)
-S3method(multi2di, contMap)
-S3method(di2multi, densityMap)
-S3method(multi2di, densityMap)
-S3method(summary, evol.rate.mcmc)
-S3method(print, summary.evol.rate.mcmc)
-S3method(plot, summary.evol.rate.mcmc)
-S3method(setMap, contMap)
-S3method(setMap, densityMap)
-S3method(setMap, phyloScattergram)
-S3method(print, fitDiversityModel)
-S3method(logLik, fitDiversityModel)
-S3method(print, gammatest)
-S3method(print, geo.legend)
-S3method(print, geo.palette)
-S3method(scores, phyl.pca)
-S3method(logLik, brownie.lite)
-S3method(plot, simBMphylo)
-S3method(print, simBMphylo)
-S3method(print, phylosig)
-S3method(plot, phylosig)
-S3method(density, threshBayes)
-S3method(plot, density.threshBayes)
-S3method(as.Qmatrix, fitMk)
-S3method(print, Qmatrix)
-S3method(density, anc.Bayes)
-S3method(summary, anc.Bayes)
-S3method(plot, Qmatrix)
-S3method(logLik, anc.ML)
-S3method(print, edge.widthMap)
-S3method(plot, edge.widthMap)
-S3method(plot, fitHRM)
-S3method(print, fitHRM)
-S3method(as.Qmatrix, corhmm)
-S3method(plot, multirateBM)
-S3method(print, multirateBM)
-S3method(logLik, multirateBM)
-S3method(plot, multirateBM_plot)
-S3method(setMap, multirateBM_plot)
-S3method(print, multirateBM_plot)
-S3method(as.princomp, phyl.pca)
-S3method(ltt, phylo)
-S3method(ltt, multiPhylo)
-S3method(ltt, simmap)
-S3method(plot, ltt.simmap)
-S3method(print, ltt.simmap)
-S3method(ltt, multiSimmap)
-S3method(print, ltt.multiSimmap)
-S3method(plot, ltt.multiSimmap)
-S3method(as.Qmatrix, fitpolyMk)
-S3method(anova, evolvcv.lite)
-S3method(anova, fitPagel)
-S3method(anova, fit.bd)
-S3method(anova, fitMk)
-S3method(as.Qmatrix, matrix)
-S3method(drop.tip, singleton)
-S3method(drop.tip, simmap)
-S3method(drop.tip, contMap)
-S3method(drop.tip, densityMap)
-S3method(drop.tip, multiSimmap)
-S3method(keep.tip, contMap)
-S3method(keep.tip, densityMap)
-S3method(keep.tip, multiSimmap)
-S3method(keep.tip, simmap)
-S3method(anova, fitpolyMk)
-S3method(rescale, simmap)
-S3method(rescale, multiSimmap)
-
-importFrom(ape, .PlotPhyloEnv, .uncompressTipLabel, ace, all.equal.phylo, as.DNAbin)
-importFrom(ape, as.phylo, bind.tree, branching.times, collapse.singles, consensus)
-importFrom(ape, compute.brlen, cophenetic.phylo, corBrownian, di2multi, dist.dna)
-importFrom(ape, dist.nodes, drop.tip, edgelabels, extract.clade, getMRCA, is.binary)
-importFrom(ape, is.monophyletic, is.rooted, is.ultrametric, keep.tip, ladderize, matexpo, mrca)
-importFrom(ape, multi2di, nodelabels, Ntip, pic, plot.phylo, prop.part, read.nexus, read.tree)
-importFrom(ape, reorder.phylo, root.phylo, rotate, rtree, stree, tiplabels, unroot, vcv)
-importFrom(ape, vcv.phylo, write.tree)
-importFrom(coda, as.mcmc, HPDinterval)
-importFrom(combinat, permn)
-importFrom(clusterGeneration, genPositiveDefMat)
-importFrom(doParallel, registerDoParallel)
-importFrom(expm, expm)
-importFrom(foreach, "%dopar%", foreach)
-importFrom(graphics, strwidth, par, segments, locator, lines, text, strheight, symbols)
-importFrom(graphics, plot, layout, plot.new, title, axis, points, plot.window, polygon)
-importFrom(graphics, rect, curve, image, mtext, arrows, barplot, boxplot, contour, hist)
-importFrom(graphics, abline, legend, grid)
-importFrom(grDevices, palette, colors, dev.hold, dev.flush, rainbow, heat.colors, gray)
-importFrom(grDevices, colorRamp, colorRampPalette, dev.new, rgb, pdf, dev.off, col2rgb, dev.size)
-importFrom(maps, map)
-importFrom(MASS, ginv)
-importFrom(methods, hasArg, is)
-importFrom(mnormt, dmnorm, pd.solve)
-importFrom(nlme, gls, varFixed)
-importFrom(numDeriv, hessian)
-importFrom(optimParallel, optimParallel)
-importFrom(parallel, detectCores, makeCluster, stopCluster)
-importFrom(phangorn, allTrees, Ancestors, as.phyDat, dist.hamming, midpoint, NJ, nni)
-importFrom(phangorn, nnls.tree, optim.parsimony, parsimony, phyDat, pratchet, treedist)
-importFrom(phangorn, RF.dist, KF.dist, path.dist, SPR.dist, Children, Descendants)
-importFrom(phangorn, threshStateC)
-importFrom(plotrix, arctext, draw.arc, draw.circle, draw.ellipse, textbox)
-importFrom(scatterplot3d, scatterplot3d)
-importFrom(stats, cophenetic, reorder, runif, setNames, optim, dexp, dnorm, rnorm, var)
-importFrom(stats, nlminb, biplot, pchisq, rexp, optimize, logLik, as.dist, pnorm, median)
-importFrom(stats, cor, aggregate, rgamma, dgamma, lm, rbinom, rgeom, pt, anova, p.adjust)
-importFrom(stats, screeplot, rchisq, optimHess, rmultinom, sd, dunif, dist, plogis)
-importFrom(stats, density, coef, cmdscale, AIC, smooth.spline, predict)
-importFrom(utils, flush.console, head, installed.packages, str, capture.output, combn)
+export(add.arrow, add.color.bar, add.everywhere, add.random, add.simmap.legend)
+export(add.species.to.genus, aic.w, allFurcTrees, allRotations, anc.Bayes, anc.ML)
+export(anc.trend, ancThresh, applyBranchLengths, arc.cladelabels, as.multiPhylo)
+export(as.princomp, as.princomp.phyl.pca, as.Qmatrix, ave.rates, averageTree)
+export(backbone.toPhylo, bd, bmPlot, bind.tip, bind.tree.simmap, biplot.phyl.pca)
+export(branching.diffusion, brownie.lite, brownieREML)
+export(cladelabels, coef.phyl.RMA, collapse.to.star, collapseTree, compare.chronograms)
+export(consensus.edges, contMap, cophylo, countSimmap, compute.mr, cotangleplot, cospeciation)
+export(ctt)
+export(density.anc.Bayes, density.multiSimmap, densityMap, densityTree, describe.simmap)
+export(di2multi.simmap, dot.legend, dotTree, drop.clade, drop.leaves, drop.tip.contMap)
+export(drop.tip.densityMap, drop.tip.multiSimmap, drop.tip.simmap, drop.tip.singleton, Dtest)
+export(edge.widthMap, edgelabels.cophylo, edgeProbs, errorbar.contMap, estDiversity)
+export(evol.rate.mcmc, evol.vcv, evolvcv.lite, exhaustiveMP, expand.clade, export.as.xml)
+export(extract.clade.simmap, extract.strahlerNumber)
+export(fancyTree, fastAnc, fastBM, fastDist, fastHeight, fastMRCA, findMRCA, fit.bd)
+export(fit.yule, fitBayes, fitHRM, fitMk, fitMk.parallel, fitmultiMk, fitpolyMk, fitDiversityModel)
+export(fitPagel, force.ultrametric)
+export(gammatest, genus.to.species.tree, genSeq, geo.palette, geo.legend, get.treepos)
+export(getCladesofSize, getDescendants, getExtant, getExtinct, getnode, getParent)
+export(getSisters, getStates, graph.polyMk, gtt)
+export(keep.tip.contMap, keep.tip.densityMap, keep.tip.multiSimmap, keep.tip.simmap)
+export(labelnodes, ladderize.simmap, lambda.transform, lik.bd, likMlambda)
+export(likSurface.rateshift, linklabels, locate.fossil, locate.yeti)
+export(ls.consensus, ls.tree, ltt, ltt95, ltt.multiPhylo, ltt.multiSimmap, ltt.phylo, ltt.simmap)
+export(make.era.map, make.simmap, make.transparent, map.overlap, Map.Overlap)
+export(map.to.singleton, mapped.states, markChanges, matchLabels, matchNodes, mccr)
+export(mcmcMk, mergeMappedStates, midpoint.root, minRotate, minSplit, minTreeDist)
+export(modified.Grafen, mrp.supertree, multi.mantel, multiC, multiOU, multiRF)
+export(multirateBM)
+export(nodeheight, nodeHeights, nodelabels.cophylo, node.paths)
+export(optim.phylo.ls, orderMappedEdge)
+export(paintBranches, paintSubTree, paste.tree, pbtree, pgls.Ives, pgls.SEy, phenogram)
+export(phenogram95, phyl.cca, phyl.pairedttest, phyl.pca, phyl.resid, phyl.RMA)
+export(phyl.vcv, phylo.heatmap, phylo.impute, phylo.toBackbone, phylo.to.map, phylANOVA)
+export(phyloDesign, phylomorphospace, phylomorphospace3d, phyloScattergram, phylosig)
+export(plot.anc.Bayes, plot.changesMap, plot.contMap, plot.cophylo, plot.densityMap)
+export(plot.edge.widthMap, plot.fitMk, plot.fitPagel, plot.gfit, plot.phyl.RMA)
+export(plot.phylo.to.map, plot.Qmatrix, plot.simBMphylo, plotBranchbyTrait, plot.phylosig)
+export(plotSimmap, plotThresh, plotTree, plotTree.barplot, plotTree.boxplot)
+export(plotTree.datamatrix, plotTree.errorbars, plotTree.singletons, plotTree.splits)
+export(plotTree.wBars, posterior.evolrate, posthoc, posthoc.ratebytree, print.Qmatrix)
+export(project.phylomorphospace)
+export(ratebystate, ratebytree, rateshift, read.newick, read.simmap, readNexus)
+export(reorder.backbonePhylo, reorderSimmap, rep.multiPhylo, rep.phylo, repPhylo, reroot)
+export(rerootingMethod, rescale, rescale.multiSimmap, rescale.simmap, rescaleSimmap, resolveAllNodes)
+export(resolveNode, rootedge.to.singleton, rotate.multi, rotateNodes, roundBranches, roundPhylogram)
+export(rstate)
+export(sampleFrom, scores, scores.phyl.pca, setMap, sigmoidPhylogram, sim.corrs, sim.ctt)
+export(sim.history, sim.Mk, sim.multiCtt, sim.multiMk, sim.ratebystate, sim.rates)
+export(simBMphylo, simmap, skewers, splinePhylogram, splitEdgeColor, splitplotTree, splitTree)
+export(starTree, strahlerNumber)
+export(threshBayes, threshDIC, threshState, tiplabels.cophylo, tipRotate, to.matrix)
+export(tree.grow, treeSlice)
+export(untangle)
+export(vcvPhylo)
+export(write.simmap, writeAncestors, writeNexus)
+
+S3method(plot, densityMap)
+S3method(plot, contMap)
+S3method(plot, phylo.to.map)
+S3method(plot, backbonePhylo)
+S3method(reorder, backbonePhylo)
+S3method(print, backbonePhylo)
+S3method(print, phyl.pca)
+S3method(summary, phyl.pca)
+S3method(biplot, phyl.pca)
+S3method(print, brownie.lite)
+S3method(print, densityMap)
+S3method(print, contMap)
+S3method(print, rateshift)
+S3method(logLik, rateshift)
+S3method(print, evol.vcv)
+S3method(plot, ltt95)
+S3method(print, ltt95)
+S3method(plot, describe.simmap)
+S3method(print, describe.simmap)
+S3method(rep, phylo)
+S3method(rep, multiPhylo)
+S3method(print, fitPagel)
+S3method(print, ltt)
+S3method(print, multiLtt)
+S3method(plot, ltt)
+S3method(plot, multiLtt)
+S3method(plot, cophylo)
+S3method(print, cophylo)
+S3method(plot, simmap)
+S3method(print, simmap)
+S3method(summary, simmap)
+S3method(plot, multiSimmap)
+S3method(print, multiSimmap)
+S3method(summary, multiSimmap)
+S3method(reorder, simmap)
+S3method(plot, rateshift)
+S3method(print, fastAnc)
+S3method(print, anc.ML)
+S3method(print, fitMk)
+S3method(summary, fitMk)
+S3method(logLik, fitMk)
+S3method(print, brownieREML)
+S3method(print, phylo.to.map)
+S3method(as.phylo, simmap)
+S3method(as.multiPhylo, multiSimmap)
+S3method(as.multiPhylo, phylo)
+S3method(plot, fitPagel)
+S3method(plot, fitMk)
+S3method(plot, gfit)
+S3method(plot, phyl.pca)
+S3method(summary, cophylo)
+S3method(print, multiCophylo)
+S3method(plot, multiCophylo)
+S3method(logLik, simmap)
+S3method(logLik, multiSimmap)
+S3method(plot, cospeciation)
+S3method(print, cospeciation)
+S3method(density, multiSimmap)
+S3method(plot, changesMap)
+S3method(print, changesMap)
+S3method(plot, phyloScattergram)
+S3method(print, phyloScattergram)
+S3method(di2multi, simmap)
+S3method(print, aic.w)
+S3method(print, phyl.RMA)
+S3method(coef, phyl.RMA)
+S3method(residuals, phyl.RMA)
+S3method(plot, phyl.RMA)
+S3method(print, ratebytree)
+S3method(print, evolvcv.lite)
+S3method(print, expand.clade)
+S3method(plot, expand.clade)
+S3method(posthoc, ratebytree)
+S3method(print, posthoc.ratebytree)
+S3method(AIC, ratebytree)
+S3method(print, fit.bd)
+S3method(logLik, fit.bd)
+S3method(print, anc.trend)
+S3method(logLik, anc.trend)
+S3method(print, ancThresh)
+S3method(plot, ancThresh)
+S3method(print, evol.rate.mcmc)
+S3method(print, threshBayes)
+S3method(plot, threshBayes)
+S3method(print, rerootingMethod)
+S3method(plot, rerootingMethod)
+S3method(logLik, rerootingMethod)
+S3method(print, fitBayes)
+S3method(plot, fitBayes)
+S3method(print, ratebystate)
+S3method(print, phylANOVA)
+S3method(print, pgls.Ives)
+S3method(logLik, pgls.Ives)
+S3method(print, phyl.cca)
+S3method(print, anc.Bayes)
+S3method(plot, anc.Bayes)
+S3method(print, phyl.pairedttest)
+S3method(print, multi.mantel)
+S3method(residuals, multi.mantel)
+S3method(fitted, multi.mantel)
+S3method(print, ctt)
+S3method(print, multiCtt)
+S3method(plot, ctt)
+S3method(plot, multiCtt)
+S3method(print, fitmultiMk)
+S3method(summary, fitmultiMk)
+S3method(logLik, fitmultiMk)
+S3method(plot, gtt)
+S3method(print, gtt)
+S3method(print, mcmcMk)
+S3method(print, Dtest)
+S3method(print, mccr)
+S3method(plot, mccr)
+S3method(print, fitpolyMk)
+S3method(logLik, fitpolyMk)
+S3method(plot, fitpolyMk)
+S3method(plot, mcmcMk)
+S3method(summary, mcmcMk)
+S3method(density, mcmcMk)
+S3method(print, density.mcmcMk)
+S3method(plot, density.mcmcMk)
+S3method(multi2di, simmap)
+S3method(di2multi, multiSimmap)
+S3method(multi2di, multiSimmap)
+S3method(di2multi, contMap)
+S3method(multi2di, contMap)
+S3method(di2multi, densityMap)
+S3method(multi2di, densityMap)
+S3method(summary, evol.rate.mcmc)
+S3method(print, summary.evol.rate.mcmc)
+S3method(plot, summary.evol.rate.mcmc)
+S3method(setMap, contMap)
+S3method(setMap, densityMap)
+S3method(setMap, phyloScattergram)
+S3method(print, fitDiversityModel)
+S3method(logLik, fitDiversityModel)
+S3method(print, gammatest)
+S3method(print, geo.legend)
+S3method(print, geo.palette)
+S3method(scores, phyl.pca)
+S3method(logLik, brownie.lite)
+S3method(plot, simBMphylo)
+S3method(print, simBMphylo)
+S3method(print, phylosig)
+S3method(plot, phylosig)
+S3method(density, threshBayes)
+S3method(plot, density.threshBayes)
+S3method(as.Qmatrix, fitMk)
+S3method(print, Qmatrix)
+S3method(density, anc.Bayes)
+S3method(summary, anc.Bayes)
+S3method(plot, Qmatrix)
+S3method(logLik, anc.ML)
+S3method(print, edge.widthMap)
+S3method(plot, edge.widthMap)
+S3method(plot, fitHRM)
+S3method(print, fitHRM)
+S3method(as.Qmatrix, corhmm)
+S3method(plot, multirateBM)
+S3method(print, multirateBM)
+S3method(logLik, multirateBM)
+S3method(plot, multirateBM_plot)
+S3method(setMap, multirateBM_plot)
+S3method(print, multirateBM_plot)
+S3method(as.princomp, phyl.pca)
+S3method(ltt, phylo)
+S3method(ltt, multiPhylo)
+S3method(ltt, simmap)
+S3method(plot, ltt.simmap)
+S3method(print, ltt.simmap)
+S3method(ltt, multiSimmap)
+S3method(print, ltt.multiSimmap)
+S3method(plot, ltt.multiSimmap)
+S3method(as.Qmatrix, fitpolyMk)
+S3method(anova, evolvcv.lite)
+S3method(anova, fitPagel)
+S3method(anova, fit.bd)
+S3method(anova, fitMk)
+S3method(as.Qmatrix, matrix)
+S3method(drop.tip, singleton)
+S3method(drop.tip, simmap)
+S3method(drop.tip, contMap)
+S3method(drop.tip, densityMap)
+S3method(drop.tip, multiSimmap)
+S3method(keep.tip, contMap)
+S3method(keep.tip, densityMap)
+S3method(keep.tip, multiSimmap)
+S3method(keep.tip, simmap)
+S3method(anova, fitpolyMk)
+S3method(rescale, simmap)
+S3method(rescale, multiSimmap)
+S3method(simmap, fitMk)
+S3method(simmap, anova.fitMk)
+S3method(simmap, fitpolyMk)
+
+importFrom(ape, .PlotPhyloEnv, .uncompressTipLabel, ace, all.equal.phylo, as.DNAbin)
+importFrom(ape, as.phylo, bind.tree, branching.times, collapse.singles, consensus)
+importFrom(ape, compute.brlen, cophenetic.phylo, corBrownian, di2multi, dist.dna)
+importFrom(ape, dist.nodes, drop.tip, edgelabels, extract.clade, getMRCA, is.binary)
+importFrom(ape, is.monophyletic, is.rooted, is.ultrametric, keep.tip, ladderize, matexpo, mrca)
+importFrom(ape, multi2di, nodelabels, Ntip, pic, plot.phylo, prop.part, read.nexus, read.tree)
+importFrom(ape, reorder.phylo, root.phylo, rotate, rtree, stree, tiplabels, unroot, vcv)
+importFrom(ape, vcv.phylo, write.tree)
+importFrom(coda, as.mcmc, HPDinterval)
+importFrom(combinat, permn)
+importFrom(clusterGeneration, genPositiveDefMat)
+importFrom(doParallel, registerDoParallel)
+importFrom(expm, expm)
+importFrom(foreach, "%dopar%", foreach)
+importFrom(graphics, strwidth, par, segments, locator, lines, text, strheight, symbols)
+importFrom(graphics, plot, layout, plot.new, title, axis, points, plot.window, polygon)
+importFrom(graphics, rect, curve, image, mtext, arrows, barplot, boxplot, contour, hist)
+importFrom(graphics, abline, legend, grid)
+importFrom(grDevices, palette, colors, dev.hold, dev.flush, rainbow, heat.colors, gray)
+importFrom(grDevices, colorRamp, colorRampPalette, dev.new, rgb, pdf, dev.off, col2rgb, dev.size)
+importFrom(maps, map)
+importFrom(MASS, ginv)
+importFrom(methods, hasArg, is)
+importFrom(mnormt, dmnorm, pd.solve)
+importFrom(nlme, gls, varFixed)
+importFrom(numDeriv, hessian)
+importFrom(optimParallel, optimParallel)
+importFrom(parallel, detectCores, makeCluster, stopCluster)
+importFrom(phangorn, allTrees, Ancestors, as.phyDat, dist.hamming, midpoint, NJ, nni)
+importFrom(phangorn, nnls.tree, optim.parsimony, parsimony, phyDat, pratchet, treedist)
+importFrom(phangorn, RF.dist, KF.dist, path.dist, SPR.dist, Children, Descendants)
+importFrom(phangorn, threshStateC)
+importFrom(plotrix, arctext, draw.arc, draw.circle, draw.ellipse, textbox)
+importFrom(scatterplot3d, scatterplot3d)
+importFrom(stats, cophenetic, reorder, runif, setNames, optim, dexp, dnorm, rnorm, var)
+importFrom(stats, nlminb, biplot, pchisq, rexp, optimize, logLik, as.dist, pnorm, median)
+importFrom(stats, cor, aggregate, rgamma, dgamma, lm, rbinom, rgeom, pt, anova, p.adjust)
+importFrom(stats, screeplot, rchisq, optimHess, rmultinom, sd, dunif, dist, plogis)
+importFrom(stats, density, coef, cmdscale, AIC, smooth.spline, predict)
+importFrom(utils, flush.console, head, installed.packages, str, capture.output, combn)
diff --git a/R/Dtest.R b/R/Dtest.R
index b129f84..d8099d6 100644
--- a/R/Dtest.R
+++ b/R/Dtest.R
@@ -1,61 +1,61 @@
-## function to conduct the correlation test of Huelsenbeck et al.
-## written by Liam J. Revell
-
-calcD<-function(t1,t2){
- Do<-mapply(Map.Overlap,t1,t2,SIMPLIFY=FALSE)
- foo<-function(M){
- m1<-rowSums(M)
- m2<-colSums(M)
- as.matrix(m1)%*%t(m2)
- }
- De<-lapply(Do,foo)
- Dij<-mapply("-",Do,De,SIMPLIFY=FALSE)
- D<-sapply(Dij,function(x) sum(abs(x)))
- E_DX<-mean(D)
- E_Dij<-Reduce("+",Dij)/length(t1)
- list(E_DX=E_DX,E_Dij=E_Dij)
-}
-
-Dtest<-function(t1,t2,nsim=100,...){
- cat("Note that this function is provided without much testing.\n")
- cat("Please use with caution.\n\n")
- cat("Running. (This may take some time.)\n")
- levs1<-sort(unique(as.vector(getStates(t1,"tips"))))
- k1<-length(levs1)
- levs2<-sort(unique(as.vector(getStates(t2,"tips"))))
- k2<-length(levs2)
- nrep<-length(t1)
- obj<-calcD(t1,t2)
- E_DX<-obj$E_DX
- E_Dij<-obj$E_Dij
- ## posterior prediction
- PD<-0
- Pdij<-matrix(0,k1,k2,dimnames=list(levs1,levs2))
- cat("|")
- for(i in 1:nrep){
- x<-to.matrix(sim.Mk(t1[[i]],t1[[i]]$Q),levs1)
- y<-to.matrix(sim.Mk(t2[[i]],t2[[i]]$Q),levs2)
- T1<-make.simmap(t1[[i]],x,nsim=nsim,message=FALSE,...)
- T2<-make.simmap(t2[[i]],y,nsim=nsim,message=FALSE,...)
- tmp<-calcD(T1,T2)
- PD<-PD+(tmp$E_DX>=E_DX)/nrep
- Pdij<-Pdij+(tmp$E_Dij>=E_Dij)/nrep
- cat(".")
- if(i%%10==0&&i!=nrep) cat("\n")
- dev.flush()
- }
- cat("|\nDone.\n")
- obj<-list("E(D|X)"=E_DX,"P(D)"=PD,"E(Dij)"=E_Dij,
- "P(Dij)"=Pdij)
- class(obj)<-"Dtest"
- obj
-}
-
-print.Dtest<-function(x,...){
- if(hasArg(digits)) digits<-list(...)$digits
- else digits<-4
- x<-lapply(x,function(a,b) if(is.numeric(a)) round(a,b) else a,b=digits)
- cat("Summary of results from D-test:\n")
- cat(paste(" E(D|X) = ",x$'E(D|X)',", P(D) = ",x$'P(D)',"\n",sep=""))
- cat("\n(Type ...$'E(Dij)' and ...$'P(Dij)' for\n pairwise E(D) and P-values.)\n")
-}
+## function to conduct the correlation test of Huelsenbeck et al.
+## written by Liam J. Revell
+
+calcD<-function(t1,t2){
+ Do<-mapply(Map.Overlap,t1,t2,SIMPLIFY=FALSE)
+ foo<-function(M){
+ m1<-rowSums(M)
+ m2<-colSums(M)
+ as.matrix(m1)%*%t(m2)
+ }
+ De<-lapply(Do,foo)
+ Dij<-mapply("-",Do,De,SIMPLIFY=FALSE)
+ D<-sapply(Dij,function(x) sum(abs(x)))
+ E_DX<-mean(D)
+ E_Dij<-Reduce("+",Dij)/length(t1)
+ list(E_DX=E_DX,E_Dij=E_Dij)
+}
+
+Dtest<-function(t1,t2,nsim=100,...){
+ cat("Note that this function is provided without much testing.\n")
+ cat("Please use with caution.\n\n")
+ cat("Running. (This may take some time.)\n")
+ levs1<-sort(unique(as.vector(getStates(t1,"tips"))))
+ k1<-length(levs1)
+ levs2<-sort(unique(as.vector(getStates(t2,"tips"))))
+ k2<-length(levs2)
+ nrep<-length(t1)
+ obj<-calcD(t1,t2)
+ E_DX<-obj$E_DX
+ E_Dij<-obj$E_Dij
+ ## posterior prediction
+ PD<-0
+ Pdij<-matrix(0,k1,k2,dimnames=list(levs1,levs2))
+ cat("|")
+ for(i in 1:nrep){
+ x<-to.matrix(sim.Mk(t1[[i]],t1[[i]]$Q),levs1)
+ y<-to.matrix(sim.Mk(t2[[i]],t2[[i]]$Q),levs2)
+ T1<-make.simmap(t1[[i]],x,nsim=nsim,message=FALSE,...)
+ T2<-make.simmap(t2[[i]],y,nsim=nsim,message=FALSE,...)
+ tmp<-calcD(T1,T2)
+ PD<-PD+(tmp$E_DX>=E_DX)/nrep
+ Pdij<-Pdij+(tmp$E_Dij>=E_Dij)/nrep
+ cat(".")
+ if(i%%10==0&&i!=nrep) cat("\n")
+ dev.flush()
+ }
+ cat("|\nDone.\n")
+ obj<-list("E(D|X)"=E_DX,"P(D)"=PD,"E(Dij)"=E_Dij,
+ "P(Dij)"=Pdij)
+ class(obj)<-"Dtest"
+ obj
+}
+
+print.Dtest<-function(x,...){
+ if(hasArg(digits)) digits<-list(...)$digits
+ else digits<-4
+ x<-lapply(x,function(a,b) if(is.numeric(a)) round(a,b) else a,b=digits)
+ cat("Summary of results from D-test:\n")
+ cat(paste(" E(D|X) = ",x$'E(D|X)',", P(D) = ",x$'P(D)',"\n",sep=""))
+ cat("\n(Type ...$'E(Dij)' and ...$'P(Dij)' for\n pairwise E(D) and P-values.)\n")
+}
diff --git a/R/add.species.to.genus.R b/R/add.species.to.genus.R
index 7c44ece..9b744f1 100644
--- a/R/add.species.to.genus.R
+++ b/R/add.species.to.genus.R
@@ -1,59 +1,59 @@
-## function identifies the genus from a species name & attempts to add it to the tree
-## written by Liam J. Revell 2013
-
-add.species.to.genus<-function(tree,species,genus=NULL,where=c("root","random")){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- if(!is.ultrametric(tree))
- warning("this code has only been tested with ultrametric tree\n your tree may be returned without edge lengths")
- where<-where[1]
- if(is.null(genus)){
- ## get genus from species name
- x<-strsplit(species,"")[[1]]
- i<-1
- while(x[i]!="_"&&x[i]!=" ") i<-i+1
- genus<-paste(x[2:i-1],collapse="")
- }
- ii<-grep(paste(genus,"_",sep=""),tree$tip.label)
- if(length(ii)>1){
- if(!is.monophyletic(tree,tree$tip.label[ii]))
- warning(paste(genus,"may not be monophyletic\n attaching to the most inclusive group containing members of this genus"))
- nn<-findMRCA(tree,tree$tip.label[ii])
- if(where=="root") tree<-bind.tip(tree,gsub(" ","_",species),where=nn)
- else if(where=="random"){
- tt<-splitTree(tree,list(node=nn,bp=tree$edge.length[which(tree$edge[,2]==nn)]))
- tt[[2]]<-add.random(tt[[2]],tips=gsub(" ","_",species))
- tree<-paste.tree(tt[[1]],tt[[2]])
- } else stop("option 'where' not recognized")
- } else if(length(ii)==1){
- nn<-ii
- if(where=="root")
- tree<-bind.tip(tree,gsub(" ","_",species),where=nn,position=0.5*tree$edge.length[which(tree$edge[,2]==nn)])
- else if(where=="random")
- tree<-bind.tip(tree,gsub(" ","_",species),where=nn,position=runif(n=1)*tree$edge.length[which(tree$edge[,2]==nn)])
- else
- stop("option 'where' not recognized")
- } else
- warning("could not match your species to a genus\n check spelling, including case")
- tree
-}
-
-## function take genus backbone tree & converts genus tree to species tree by simulating pure-birth subtrees
-## written by Liam J. Revell 2015
-
-genus.to.species.tree<-function(tree,species){
- N<-Ntip(tree)
- genera<-tree$tip.label
- species<-gsub(" ","_",species)
- for(i in 1:N){
- jj<-grep(paste(genera[i],"_",sep=""),species)
- nn<-which(tree$tip.label==genera[i])
- if(length(jj)>1){
- h<-runif(n=1)*tree$edge.length[which(tree$edge[,2]==nn)]
- tree$edge.length[which(tree$edge[,2]==nn)]<-
- tree$edge.length[which(tree$edge[,2]==nn)]-h
- sub.tree<-pbtree(n=length(jj),scale=h,tip.label=species[jj])
- tree<-bind.tree(tree,sub.tree,where=nn)
- } else if(length(jj)==1) tree$tip.label[nn]<-species[jj]
- }
- tree
-}
+## function identifies the genus from a species name & attempts to add it to the tree
+## written by Liam J. Revell 2013
+
+add.species.to.genus<-function(tree,species,genus=NULL,where=c("root","random")){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ if(!is.ultrametric(tree))
+ warning("this code has only been tested with ultrametric tree\n your tree may be returned without edge lengths")
+ where<-where[1]
+ if(is.null(genus)){
+ ## get genus from species name
+ x<-strsplit(species,"")[[1]]
+ i<-1
+ while(x[i]!="_"&&x[i]!=" ") i<-i+1
+ genus<-paste(x[2:i-1],collapse="")
+ }
+ ii<-grep(paste(genus,"_",sep=""),tree$tip.label)
+ if(length(ii)>1){
+ if(!is.monophyletic(tree,tree$tip.label[ii]))
+ warning(paste(genus,"may not be monophyletic\n attaching to the most inclusive group containing members of this genus"))
+ nn<-findMRCA(tree,tree$tip.label[ii])
+ if(where=="root") tree<-bind.tip(tree,gsub(" ","_",species),where=nn)
+ else if(where=="random"){
+ tt<-splitTree(tree,list(node=nn,bp=tree$edge.length[which(tree$edge[,2]==nn)]))
+ tt[[2]]<-add.random(tt[[2]],tips=gsub(" ","_",species))
+ tree<-paste.tree(tt[[1]],tt[[2]])
+ } else stop("option 'where' not recognized")
+ } else if(length(ii)==1){
+ nn<-ii
+ if(where=="root")
+ tree<-bind.tip(tree,gsub(" ","_",species),where=nn,position=0.5*tree$edge.length[which(tree$edge[,2]==nn)])
+ else if(where=="random")
+ tree<-bind.tip(tree,gsub(" ","_",species),where=nn,position=runif(n=1)*tree$edge.length[which(tree$edge[,2]==nn)])
+ else
+ stop("option 'where' not recognized")
+ } else
+ warning("could not match your species to a genus\n check spelling, including case")
+ tree
+}
+
+## function take genus backbone tree & converts genus tree to species tree by simulating pure-birth subtrees
+## written by Liam J. Revell 2015
+
+genus.to.species.tree<-function(tree,species){
+ N<-Ntip(tree)
+ genera<-tree$tip.label
+ species<-gsub(" ","_",species)
+ for(i in 1:N){
+ jj<-grep(paste(genera[i],"_",sep=""),species)
+ nn<-which(tree$tip.label==genera[i])
+ if(length(jj)>1){
+ h<-runif(n=1)*tree$edge.length[which(tree$edge[,2]==nn)]
+ tree$edge.length[which(tree$edge[,2]==nn)]<-
+ tree$edge.length[which(tree$edge[,2]==nn)]-h
+ sub.tree<-pbtree(n=length(jj),scale=h,tip.label=species[jj])
+ tree<-bind.tree(tree,sub.tree,where=nn)
+ } else if(length(jj)==1) tree$tip.label[nn]<-species[jj]
+ }
+ tree
+}
diff --git a/R/allFurcTrees.R b/R/allFurcTrees.R
index 9c17253..c6f2950 100644
--- a/R/allFurcTrees.R
+++ b/R/allFurcTrees.R
@@ -1,48 +1,48 @@
-# function returns all unrooted multi & bifurcating tree topologies
-# written by Liam Revell 2011, 2013
-
-allFurcTrees<-function(n,tip.label=NULL,to.plot=TRUE){
- # check to see if tip labels have been provided
- if(is.null(tip.label)) tip.label=as.character(1:n)
- # now pick three species at random to start
- new<-list(stree(n=3,tip.label=sample(tip.label,3)))
- class(new)<-"multiPhylo"
- added<-new[[1]]$tip.label; remaining<-setdiff(tip.label,added)
- # loop
- while(length(remaining)>0){
- old<-new; new<-list()
- new.tip<-sample(remaining,1)
- for(i in 1:length(old)){
- temp<-add.to.branches.and.nodes(old[[i]],new.tip)
- new<-unlist(list(new,temp),recursive=FALSE); class(new)<-"multiPhylo"
- }
- added<-c(added,new.tip)
- remaining<-setdiff(tip.label,added)
- }
- if(to.plot) new<-read.tree(text=write.tree(new))
- return(new) # return all trees
-}
-
-# function adds a tip to all branches and nodes
-# written by Liam Revell 2011
-
-add.to.branches.and.nodes<-function(tree,tip.name){
- n.edge<-nrow(tree$edge)
- tree$edge.length<-rep(1,n.edge) # set all edge lengths to 1.0
- # create new tip
- new.tip<-list(edge=matrix(c(2L,1L),1,2),tip.label=tip.name,edge.length=1,Nnode=1L); class(new.tip)<-"phylo"
- # first add the tip to all edges
- trees<-list(); class(trees)<-"multiPhylo"
- for(i in 1:n.edge){
- trees[[i]]<-bind.tree(tree,new.tip,where=tree$edge[i,2],position=0.5) # add tip to edge
- trees[[i]]$edge.length<-NULL
- }
- # ok, now add the tip to all internal nodes
- intnodes<-unique(tree$edge[,1])
- for(i in 1:tree$Nnode){
- trees[[i+n.edge]]<-bind.tree(tree,new.tip,where=intnodes[i]) # add tip to node
- trees[[i+n.edge]]$edge.length<-NULL
- }
- return(trees)
-}
-
+# function returns all unrooted multi & bifurcating tree topologies
+# written by Liam Revell 2011, 2013
+
+allFurcTrees<-function(n,tip.label=NULL,to.plot=TRUE){
+ # check to see if tip labels have been provided
+ if(is.null(tip.label)) tip.label=as.character(1:n)
+ # now pick three species at random to start
+ new<-list(stree(n=3,tip.label=sample(tip.label,3)))
+ class(new)<-"multiPhylo"
+ added<-new[[1]]$tip.label; remaining<-setdiff(tip.label,added)
+ # loop
+ while(length(remaining)>0){
+ old<-new; new<-list()
+ new.tip<-sample(remaining,1)
+ for(i in 1:length(old)){
+ temp<-add.to.branches.and.nodes(old[[i]],new.tip)
+ new<-unlist(list(new,temp),recursive=FALSE); class(new)<-"multiPhylo"
+ }
+ added<-c(added,new.tip)
+ remaining<-setdiff(tip.label,added)
+ }
+ if(to.plot) new<-read.tree(text=write.tree(new))
+ return(new) # return all trees
+}
+
+# function adds a tip to all branches and nodes
+# written by Liam Revell 2011
+
+add.to.branches.and.nodes<-function(tree,tip.name){
+ n.edge<-nrow(tree$edge)
+ tree$edge.length<-rep(1,n.edge) # set all edge lengths to 1.0
+ # create new tip
+ new.tip<-list(edge=matrix(c(2L,1L),1,2),tip.label=tip.name,edge.length=1,Nnode=1L); class(new.tip)<-"phylo"
+ # first add the tip to all edges
+ trees<-list(); class(trees)<-"multiPhylo"
+ for(i in 1:n.edge){
+ trees[[i]]<-bind.tree(tree,new.tip,where=tree$edge[i,2],position=0.5) # add tip to edge
+ trees[[i]]$edge.length<-NULL
+ }
+ # ok, now add the tip to all internal nodes
+ intnodes<-unique(tree$edge[,1])
+ for(i in 1:tree$Nnode){
+ trees[[i+n.edge]]<-bind.tree(tree,new.tip,where=intnodes[i]) # add tip to node
+ trees[[i+n.edge]]$edge.length<-NULL
+ }
+ return(trees)
+}
+
diff --git a/R/anc.Bayes.R b/R/anc.Bayes.R
index ac0a7f7..98eff40 100644
--- a/R/anc.Bayes.R
+++ b/R/anc.Bayes.R
@@ -1,170 +1,170 @@
-## function does Bayes ancestral character estimation
-## written by Liam J. Revell 2011, 2013, 2015, 2017, 2020
-
-anc.Bayes<-function(tree,x,ngen=10000,control=list(),...){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- # give the function some defaults (in case none are provided)
- temp<-phyl.vcv(as.matrix(x),vcv(tree),1)
- sig2<-temp$R[1,1]
- a<-temp$alpha
- y<-rep(a,tree$Nnode-1)
- pr.mean<-c(1000,rep(0,tree$Nnode))
- pr.var<-c(pr.mean[1]^2,rep(1000,tree$Nnode))
- prop<-rep(0.01*max(temp$C)*sig2,tree$Nnode+1)
-
- # populate control list
- con=list(sig2=sig2,a=a,y=y,pr.mean=pr.mean,pr.var=pr.var,prop=prop,sample=100)
- con[(namc<-names(control))]<-control
- con<-con[!sapply(con,is.null)]
- # print control parameters to screen
- message("Control parameters (set by user or default):"); str(con)
-
- # function returns the log-likelihood
- likelihood<-function(C,invC,detC,x,sig2,a,y){
- z<-c(x,y)-rep(a,nrow(C))
- logLik<--z%*%invC%*%z/(2*sig2)-nrow(C)*log(2*pi)/2-nrow(C)*log(sig2)/2-detC/2
- return(logLik)
- }
-
- # function returns the prior
- log.prior<-function(pr.mean,pr.var,sig2,a,y)
- pp<-dexp(sig2,rate=1/pr.mean[1],log=TRUE)+sum(dnorm(c(a,y),mean=pr.mean[2:length(pr.mean)],sd=sqrt(pr.var[1+1:tree$Nnode]),log=TRUE))
-
- # compute C
- C<-vcvPhylo(tree)
- # check to make sure that C will be non-singular
- if(any(tree$edge.length<=(10*.Machine$double.eps)))
- stop("some branch lengths are 0 or nearly zero")
- invC<-solve(C)
- detC<-determinant(C,logarithm=TRUE)$modulus[1]
-
- # now set starting values for MCMC
- sig2<-con$sig2; a<-con$a; y<-con$y
- x<-x[tree$tip.label]
- if(is.null(names(y))) names(y)<-length(tree$tip)+2:tree$Nnode
- else y[as.character(length(tree$tip)+2:tree$Nnode)]
- L<-likelihood(C,invC,detC,x,sig2,a,y)
- Pr<-log.prior(con$pr.mean,con$pr.var,sig2,a,y)
-
- # store
- X<-matrix(NA,ngen/con$sample+1,tree$Nnode+3,dimnames=list(NULL,c("gen","sig2",length(tree$tip)+1:tree$Nnode,"logLik")))
- X[1,]<-c(0,sig2,a,y,L)
-
- message("Starting MCMC...")
-
- # start MCMC
- for(i in 1:ngen){
- j<-(i-1)%%(tree$Nnode+1)
- if(j==0){
- # update sig2
- sig2.prime<-sig2+rnorm(n=1,sd=sqrt(con$prop[j+1]))
- if(sig2.prime<0) sig2.prime<--sig2.prime
- L.prime<-likelihood(C,invC,detC,x,sig2.prime,a,y)
- Pr.prime<-log.prior(con$pr.mean,con$pr.var,sig2.prime,a,y)
- post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L))
- if(post.odds>runif(n=1)){
- if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2.prime,a,y,L.prime)
- sig2<-sig2.prime
- L<-L.prime
- Pr<-Pr.prime
- } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,y,L)
- } else if(j==1){
- # update a
- a.prime<-a+rnorm(n=1,sd=sqrt(con$prop[j+1]))
- L.prime<-likelihood(C,invC,detC,x,sig2,a.prime,y)
- Pr.prime<-log.prior(con$pr.mean,con$pr.var,sig2,a.prime,y)
- post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L))
- if(post.odds>runif(n=1)){
- if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a.prime,y,L.prime)
- a<-a.prime
- L<-L.prime
- Pr<-Pr.prime
- } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,y,L)
- } else {
- k<-j-1 # update node k
- y.prime<-y
- y.prime[k]<-y[k]+rnorm(n=1,sd=sqrt(con$prop[j+1]))
- L.prime<-likelihood(C,invC,detC,x,sig2,a,y.prime)
- Pr.prime<-log.prior(con$pr.mean,con$pr.var,sig2,a,y.prime)
- post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L))
- if(post.odds>runif(n=1)){
- if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,y.prime,L.prime)
- y<-y.prime
- L<-L.prime
- Pr<-Pr.prime
- } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,y,L)
- }
- }
-
- # done MCMC
- message("Done MCMC.")
- obj<-list(mcmc=as.data.frame(X),tree=tree)
- class(obj)<-"anc.Bayes"
- obj
-}
-
-## S3 methods
-print.anc.Bayes<-function(x,digits=6,printlen=NULL,...){
- cat("\nObject of class \"anc.Bayes\" consisting of a posterior")
- cat("\n sample from a Bayesian ancestral state analysis:\n")
- if(hasArg(burnin)) burnin<-list(...)$burnin
- else burnin<-0.2*max(x$mcmc$gen)
- ii<-which(((x$mcmc$gen-burnin)^2)==min((x$mcmc$gen-burnin)^2))
- Nnode<-x$tree$Nnode
- cat("\nMean ancestral states from posterior distribution:\n")
- ace<-colMeans(x$mcmc[ii:nrow(x$mcmc),as.character(1:Nnode+Ntip(x$tree))])
- if(is.null(printlen)||printlen>=Nnode) print(round(ace,digits))
- else printDotDot(ace,digits,printlen)
- cat(paste("\nBased on a burn-in of ",burnin," generations.\n\n",sep=""))
- invisible(ace)
-}
-
-summary.anc.Bayes<-function(object,...) print(object,...)
-
-plot.anc.Bayes<-function(x,...){
- args<-list(...)
- if(is.null(args$what)) what<-"logLik"
- else {
- what<-args$what
- args$what<-NULL
- }
- if(is.null(args$burnin)) burnin<-0.2*max(x$mcmc$gen)
- else {
- burnin<-args$burnin
- args$burnin<-NULL
- }
- if(what=="logLik"){
- args$x<-x$mcmc$gen
- args$y<-x$mcmc$logLik
- if(is.null(args$xlab)) args$xlab<-"generation"
- if(is.null(args$ylab)) args$ylab<-"log(L)"
- if(is.null(args$type)) args$type<-"l"
- if(is.null(args$col)) args$col<-make.transparent("blue",0.5)
- do.call(plot,args)
- } else {
- args$x<-x$mcmc$gen
- args$y<-x$mcmc[,as.character(what)]
- if(is.null(args$xlab)) args$xlab<-"generation"
- if(is.null(args$ylab)) args$ylab<-paste("state for node",what)
- if(is.null(args$type)) args$type<-"l"
- if(is.null(args$col)) args$col<-make.transparent("blue",0.5)
- if(is.null(args$ylim)) args$ylim<-range(x$mcmc[,2:(ncol(x$mcmc)-1)])
- do.call(plot,args)
- }
-}
-
-density.anc.Bayes<-function(x,...){
- if(hasArg(what)) what<-list(...)$what
- else what<-Ntip(x$tree)+1
- if(hasArg(burnin)) burnin<-list(...)$burnin
- else burnin<-0.2*max(x$mcmc$gen)
- ii<-which(abs(x$mcmc$gen-burnin)==min(abs(x$mcmc$gen-burnin)))
- if(hasArg(bw)) bw<-list(...)$bw
- else bw<-"nrd0"
- args<-list(x=x$mcmc[ii:nrow(x$mcmc),as.character(what)],
- bw=bw)
- d<-do.call(density,args)
- d$call<-match.call()
- d$data.name<-if(what=="logLik") what else paste("node",what)
- d
+## function does Bayes ancestral character estimation
+## written by Liam J. Revell 2011, 2013, 2015, 2017, 2020
+
+anc.Bayes<-function(tree,x,ngen=10000,control=list(),...){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ # give the function some defaults (in case none are provided)
+ temp<-phyl.vcv(as.matrix(x),vcv(tree),1)
+ sig2<-temp$R[1,1]
+ a<-temp$alpha
+ y<-rep(a,tree$Nnode-1)
+ pr.mean<-c(1000,rep(0,tree$Nnode))
+ pr.var<-c(pr.mean[1]^2,rep(1000,tree$Nnode))
+ prop<-rep(0.01*max(temp$C)*sig2,tree$Nnode+1)
+
+ # populate control list
+ con=list(sig2=sig2,a=a,y=y,pr.mean=pr.mean,pr.var=pr.var,prop=prop,sample=100)
+ con[(namc<-names(control))]<-control
+ con<-con[!sapply(con,is.null)]
+ # print control parameters to screen
+ message("Control parameters (set by user or default):"); str(con)
+
+ # function returns the log-likelihood
+ likelihood<-function(C,invC,detC,x,sig2,a,y){
+ z<-c(x,y)-rep(a,nrow(C))
+ logLik<--z%*%invC%*%z/(2*sig2)-nrow(C)*log(2*pi)/2-nrow(C)*log(sig2)/2-detC/2
+ return(logLik)
+ }
+
+ # function returns the prior
+ log.prior<-function(pr.mean,pr.var,sig2,a,y)
+ pp<-dexp(sig2,rate=1/pr.mean[1],log=TRUE)+sum(dnorm(c(a,y),mean=pr.mean[2:length(pr.mean)],sd=sqrt(pr.var[1+1:tree$Nnode]),log=TRUE))
+
+ # compute C
+ C<-vcvPhylo(tree)
+ # check to make sure that C will be non-singular
+ if(any(tree$edge.length<=(10*.Machine$double.eps)))
+ stop("some branch lengths are 0 or nearly zero")
+ invC<-solve(C)
+ detC<-determinant(C,logarithm=TRUE)$modulus[1]
+
+ # now set starting values for MCMC
+ sig2<-con$sig2; a<-con$a; y<-con$y
+ x<-x[tree$tip.label]
+ if(is.null(names(y))) names(y)<-length(tree$tip)+2:tree$Nnode
+ else y[as.character(length(tree$tip)+2:tree$Nnode)]
+ L<-likelihood(C,invC,detC,x,sig2,a,y)
+ Pr<-log.prior(con$pr.mean,con$pr.var,sig2,a,y)
+
+ # store
+ X<-matrix(NA,ngen/con$sample+1,tree$Nnode+3,dimnames=list(NULL,c("gen","sig2",length(tree$tip)+1:tree$Nnode,"logLik")))
+ X[1,]<-c(0,sig2,a,y,L)
+
+ message("Starting MCMC...")
+
+ # start MCMC
+ for(i in 1:ngen){
+ j<-(i-1)%%(tree$Nnode+1)
+ if(j==0){
+ # update sig2
+ sig2.prime<-sig2+rnorm(n=1,sd=sqrt(con$prop[j+1]))
+ if(sig2.prime<0) sig2.prime<--sig2.prime
+ L.prime<-likelihood(C,invC,detC,x,sig2.prime,a,y)
+ Pr.prime<-log.prior(con$pr.mean,con$pr.var,sig2.prime,a,y)
+ post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L))
+ if(post.odds>runif(n=1)){
+ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2.prime,a,y,L.prime)
+ sig2<-sig2.prime
+ L<-L.prime
+ Pr<-Pr.prime
+ } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,y,L)
+ } else if(j==1){
+ # update a
+ a.prime<-a+rnorm(n=1,sd=sqrt(con$prop[j+1]))
+ L.prime<-likelihood(C,invC,detC,x,sig2,a.prime,y)
+ Pr.prime<-log.prior(con$pr.mean,con$pr.var,sig2,a.prime,y)
+ post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L))
+ if(post.odds>runif(n=1)){
+ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a.prime,y,L.prime)
+ a<-a.prime
+ L<-L.prime
+ Pr<-Pr.prime
+ } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,y,L)
+ } else {
+ k<-j-1 # update node k
+ y.prime<-y
+ y.prime[k]<-y[k]+rnorm(n=1,sd=sqrt(con$prop[j+1]))
+ L.prime<-likelihood(C,invC,detC,x,sig2,a,y.prime)
+ Pr.prime<-log.prior(con$pr.mean,con$pr.var,sig2,a,y.prime)
+ post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L))
+ if(post.odds>runif(n=1)){
+ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,y.prime,L.prime)
+ y<-y.prime
+ L<-L.prime
+ Pr<-Pr.prime
+ } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,y,L)
+ }
+ }
+
+ # done MCMC
+ message("Done MCMC.")
+ obj<-list(mcmc=as.data.frame(X),tree=tree)
+ class(obj)<-"anc.Bayes"
+ obj
+}
+
+## S3 methods
+print.anc.Bayes<-function(x,digits=6,printlen=NULL,...){
+ cat("\nObject of class \"anc.Bayes\" consisting of a posterior")
+ cat("\n sample from a Bayesian ancestral state analysis:\n")
+ if(hasArg(burnin)) burnin<-list(...)$burnin
+ else burnin<-0.2*max(x$mcmc$gen)
+ ii<-which(((x$mcmc$gen-burnin)^2)==min((x$mcmc$gen-burnin)^2))
+ Nnode<-x$tree$Nnode
+ cat("\nMean ancestral states from posterior distribution:\n")
+ ace<-colMeans(x$mcmc[ii:nrow(x$mcmc),as.character(1:Nnode+Ntip(x$tree))])
+ if(is.null(printlen)||printlen>=Nnode) print(round(ace,digits))
+ else printDotDot(ace,digits,printlen)
+ cat(paste("\nBased on a burn-in of ",burnin," generations.\n\n",sep=""))
+ invisible(ace)
+}
+
+summary.anc.Bayes<-function(object,...) print(object,...)
+
+plot.anc.Bayes<-function(x,...){
+ args<-list(...)
+ if(is.null(args$what)) what<-"logLik"
+ else {
+ what<-args$what
+ args$what<-NULL
+ }
+ if(is.null(args$burnin)) burnin<-0.2*max(x$mcmc$gen)
+ else {
+ burnin<-args$burnin
+ args$burnin<-NULL
+ }
+ if(what=="logLik"){
+ args$x<-x$mcmc$gen
+ args$y<-x$mcmc$logLik
+ if(is.null(args$xlab)) args$xlab<-"generation"
+ if(is.null(args$ylab)) args$ylab<-"log(L)"
+ if(is.null(args$type)) args$type<-"l"
+ if(is.null(args$col)) args$col<-make.transparent("blue",0.5)
+ do.call(plot,args)
+ } else {
+ args$x<-x$mcmc$gen
+ args$y<-x$mcmc[,as.character(what)]
+ if(is.null(args$xlab)) args$xlab<-"generation"
+ if(is.null(args$ylab)) args$ylab<-paste("state for node",what)
+ if(is.null(args$type)) args$type<-"l"
+ if(is.null(args$col)) args$col<-make.transparent("blue",0.5)
+ if(is.null(args$ylim)) args$ylim<-range(x$mcmc[,2:(ncol(x$mcmc)-1)])
+ do.call(plot,args)
+ }
+}
+
+density.anc.Bayes<-function(x,...){
+ if(hasArg(what)) what<-list(...)$what
+ else what<-Ntip(x$tree)+1
+ if(hasArg(burnin)) burnin<-list(...)$burnin
+ else burnin<-0.2*max(x$mcmc$gen)
+ ii<-which(abs(x$mcmc$gen-burnin)==min(abs(x$mcmc$gen-burnin)))
+ if(hasArg(bw)) bw<-list(...)$bw
+ else bw<-"nrd0"
+ args<-list(x=x$mcmc[ii:nrow(x$mcmc),as.character(what)],
+ bw=bw)
+ d<-do.call(density,args)
+ d$call<-match.call()
+ d$data.name<-if(what=="logLik") what else paste("node",what)
+ d
}
\ No newline at end of file
diff --git a/R/anc.ML.R b/R/anc.ML.R
index 27ada5e..3a5d2ca 100644
--- a/R/anc.ML.R
+++ b/R/anc.ML.R
@@ -1,271 +1,271 @@
-## lightweight version of ace(...,method="ML") for continuous traits
-## also allows missing data in x, in which case missing data are also estimated
-## written by Liam J. Revell 2011, 2013, 2014, 2015
-
-anc.ML<-function(tree,x,maxit=2000,model=c("BM","OU","EB"),...){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- if(model[1]=="BM") obj<-anc.BM(tree,x,maxit,...)
- else if(model[1]=="OU") obj<-anc.OU(tree,x,maxit,...)
- else if(model[1]=="EB") obj<-anc.EB(tree,x,maxit,...)
- else stop(paste("Do not recognize method",model))
- obj
-}
-
-## internal to estimate ancestral states under a BM model
-## written by Liam J. Revell 2011, 2013, 2014, 2016, 2018
-anc.BM<-function(tree,x,maxit,...){
- if(hasArg(trace)) trace<-list(...)$trace
- else trace<-FALSE
- if(hasArg(vars)) vars<-list(...)$vars
- else vars<-FALSE
- if(hasArg(CI)) CI<-list(...)$CI
- else CI<-FALSE
- if(hasArg(se)) se<-list(...)$se
- else se<-setNames(rep(0,length(x)),names(x))
- SE<-setNames(rep(0,Ntip(tree)),tree$tip.label)
- SE[names(se)]<-se
- E<-diag(SE)
- colnames(E)<-rownames(E)<-names(SE)
- if(hasArg(tol)) tol<-list(...)$tol
- else tol<-10*.Machine$double.eps
- ## check to see if any tips are missing data
- xx<-setdiff(tree$tip.label,names(x))
- ## function returns the log-likelihood
- likelihood<-function(par,C,invC,detC,xvals,msp,trace,E=0){
- sig2<-par[1]
- a<-par[2]
- y<-par[1:(tree$Nnode-1)+2]
- xvals<-c(xvals,setNames(par[1:length(msp)+tree$Nnode+1],msp))
- xvals<-xvals[rownames(C)[1:length(tree$tip.label)]]
- z<-c(xvals,y)-a
- if(trace) cat(paste(round(sig2,6)," --- ",sep=""))
- if(sum(E)>0){
- C<-sig2*C
- C[rownames(E),colnames(E)]<-C[rownames(E),colnames(E)]+E
- invC<-solve(C)
- detC<-determinant(C,logarithm=TRUE)$modulus[1]
- }
- logLik<-(-z%*%invC%*%z/(2*sig2)-nrow(C)*log(2*pi)/2-nrow(C)*log(sig2)/2-
- detC/2)[1,1]
- if(trace) cat(paste(round(logLik,6),"\n"))
- -logLik
- }
- ## compute C
- C<-vcvPhylo(tree)
- invC<-solve(C)
- detC<-determinant(C,logarithm=TRUE)$modulus[1]
- ## assign starting values
- zz<-fastAnc(tree,c(x,setNames(rep(mean(x),length(xx)),xx)))
- y<-zz[2:length(zz)]
- a<-zz[1]
- bb<-c(c(x,setNames(rep(mean(x),length(xx)),xx))[tree$tip.label],y)
- sig2<-((bb-a)%*%invC%*%(bb-a)/nrow(C))[1,1]
- fit<-optim(c(sig2,a,y,rep(mean(x),length(xx))),fn=likelihood,C=C,invC=invC,
- detC=detC,xvals=x,msp=xx,trace=trace,E=E,method="L-BFGS-B",
- lower=c(tol,rep(-Inf,tree$Nnode+length(xx))),
- control=list(maxit=maxit))
- if(vars||CI){
- H<-hessian(likelihood,fit$par,C=C,invC=invC,detC=detC,
- xvals=x,msp=xx,trace=trace,E=E)
- vcv<-solve(H)
- }
- states<-fit$par[1:tree$Nnode+1]
- names(states)<-c(length(tree$tip)+1,rownames(C)[(length(tree$tip)+1):nrow(C)])
- obj<-list(sig2=fit$par[1],ace=states,logLik=-fit$value,counts=fit$counts,
- convergence=fit$convergence,message=fit$message,model="BM")
- if(vars) obj$var<-setNames(diag(vcv)[1:tree$Nnode+1],
- c(length(tree$tip)+1,rownames(C)[(length(tree$tip)+1):nrow(C)]))
- if(CI){
- obj$CI95<-cbind(obj$ace-1.96*sqrt(diag(vcv)[1:tree$Nnode+1]),
- obj$ace+1.96*sqrt(diag(vcv)[1:tree$Nnode+1]))
- rownames(obj$CI95)<-c(length(tree$tip)+1,
- rownames(C)[(length(tree$tip)+1):nrow(C)])
- }
- if(length(xx)>0){
- obj$missing.x<-setNames(fit$par[1:length(xx)+tree$Nnode+1],xx)
- if(vars) obj$missing.var<-setNames(diag(vcv)[1:length(xx)+
- tree$Nnode+1],xx)
- if(CI){
- obj$missing.CI95<-cbind(obj$missing.x-
- 1.96*sqrt(diag(vcv)[1:length(xx)+tree$Nnode+1]),
- obj$missing.x+1.96*sqrt(diag(vcv)[1:length(xx)+tree$Nnode+1]))
- rownames(obj$missing.CI95)<-xx
- }
- }
- class(obj)<-"anc.ML"
- obj
-}
-
-## internal to estimate ancestral states under an OU model (this may not work)
-## written by Liam J. Revell 2014
-anc.OU<-function(tree,x,maxit=2000,...){
- ## check to see if any tips are missing data
- xx<-setdiff(tree$tip.label,names(x))
- if(length(xx)>0) stop("Some tips of the tree do not have data. Try model=\"BM\".")
- if(hasArg(tol)) tol<-list(...)$tol
- else tol<-1e-8
- if(hasArg(trace)) trace<-list(...)$trace
- else trace<-FALSE
- if(hasArg(a.init)) a.init<-list(...)$a.init
- else a.init<-2*log(2)/max(nodeHeights(tree))
- likOU<-function(par,tree,x,trace){
- sig2<-par[1]
- alpha<-par[2]
- a0<-par[3]
- a<-par[1:(tree$Nnode-1)+3]
- logLik<-logMNORM(c(x,a),rep(a0,Ntip(tree)+tree$Nnode-1),sig2*vcvPhylo(tree,model="OU",alpha=alpha))
- if(trace) print(c(sig2,alpha,logLik))
- -logLik
- }
- x<-x[tree$tip.label]
- pp<-rep(NA,tree$Nnode+2)
- pp[1:tree$Nnode+2]<-fastAnc(tree,x)
- pp[1]<-phyl.vcv(as.matrix(c(x,pp[2:tree$Nnode+2])),vcvPhylo(tree),lambda=1)$R[1,1]
- pp[2]<-a.init ## arbitrarily
- fit<-optim(pp,likOU,tree=tree,x=x,trace=trace,method="L-BFGS-B",
- lower=c(tol,tol,rep(-Inf,tree$Nnode)),upper=rep(Inf,length(pp)),
- control=list(maxit=maxit))
- obj<-list(sig2=fit$par[1],alpha=fit$par[2],
- ace=setNames(fit$par[1:tree$Nnode+2],1:tree$Nnode+length(tree$tip.label)),
- logLik=-fit$value,counts=fit$counts,convergence=fit$convergence,
- message=fit$message,model="OU")
- class(obj)<-"anc.ML"
- obj
-}
-
-## EB is the Early-burst model (Harmon et al. 2010) and also called the ACDC model
-## (accelerating-decelerating; Blomberg et al. 2003). Set by the a rate parameter, EB fits a model where
-## the rate of evolution increases or decreases exponentially through time, under the model
-## r[t] = r[0] * exp(a * t), where r[0] is the initial rate, a is the rate change parameter, and t is
-## time. The maximum bound is set to -0.000001, representing a decelerating rate of evolution. The minimum
-## bound is set to log(10^-5)/depth of the tree.
-
-## internal to estimate ancestral states under an EB model
-## written by Liam J. Revell 2017
-anc.EB<-function(tree,x,maxit=2000,...){
- ## check to see if any tips are missing data
- xx<-setdiff(tree$tip.label,names(x))
- if(length(xx)>0) stop("Some tips of the tree do not have data. Try model=\"BM\".")
- if(hasArg(tol)) tol<-list(...)$tol
- else tol<-1e-8
- if(hasArg(trace)) trace<-list(...)$trace
- else trace<-FALSE
- if(hasArg(vars)) vars<-list(...)$vars
- else vars<-FALSE
- if(hasArg(CI)) CI<-list(...)$CI
- else CI<-FALSE
- if(hasArg(r.init)){
- r.init<-list(...)$r.init
- obj<-phyl.vcv(as.matrix(x[tree$tip.label]),
- vcv(ebTree(tree,r.init)),1)
- s2.init<-obj$R[1,1]
- a0.init<-obj$alpha[1,1]
- } else {
- ## optimize r.init
- lik<-function(p,tree,x)
- logLik<--logMNORM(x,rep(p[3],Ntip(tree)),
- p[1]*vcvPhylo(tree,model="EB",r=p[2],anc.nodes=F))
- obj<-phyl.vcv(as.matrix(x[tree$tip.label]),vcv(tree),1)
- fit.init<-optim(c(obj$R[1,1],0,obj$alpha[1,1]),
- lik,tree=tree,x=x,method="L-BFGS-B",lower=c(tol,-Inf,-Inf),
- upper=rep(Inf,3))
- r.init<-fit.init$par[2]
- s2.init<-fit.init$par[1]
- a0.init<-fit.init$par[3]
- }
- likEB<-function(par,tree,x,trace){
- sig2<-par[1]
- r<-par[2]
- obj<-fastAnc(ebTree(tree,r),x)
- a0<-obj[1]
- a<-obj[2:length(obj)]
- logLik<-logMNORM(c(x,a),rep(a0,Ntip(tree)+tree$Nnode-1),
- sig2*vcvPhylo(tree,model="EB",r=r))
- if(trace) print(c(sig2,r,logLik))
- -logLik
- }
- x<-x[tree$tip.label]
- pp<-rep(NA,2)
- pp[1]<-s2.init
- pp[2]<-r.init
- fit<-optim(pp,likEB,tree=tree,x=x,trace=trace,method="L-BFGS-B",
- lower=c(tol,-Inf),upper=rep(Inf,2),control=list(maxit=maxit))
- obj<-list(sig2=fit$par[1],r=fit$par[2],
- ace=unclass(fastAnc(ebTree(tree,fit$par[2]),x)),
- logLik=-fit$value,counts=fit$counts,convergence=fit$convergence,
- message=fit$message,model="EB")
- if(vars||CI){
- likEB.hessian<-function(par,tree,y){
- sig2<-par[1]
- r<-par[2]
- a<-par[3:length(par)]
- logLik<-logMNORM(c(y,a[2:length(a)]),rep(a[1],Ntip(tree)+tree$Nnode-1),
- sig2*vcvPhylo(tree,model="EB",r=r))
- -logLik
- }
- H<-hessian(likEB.hessian,c(fit$par,obj$ace),tree=tree,y=x)
- vcv<-solve(H)
- if(vars) obj$var<-setNames(diag(vcv)[1:tree$Nnode+1],1:tree$Nnode+Ntip(tree))
- if(CI){
- obj$CI95<-cbind(obj$ace-1.96*sqrt(diag(vcv)[1:tree$Nnode+2]),
- obj$ace+1.96*sqrt(diag(vcv)[1:tree$Nnode+2]))
- rownames(obj$CI95)<-1:tree$Nnode+Ntip(tree)
- }
- }
- class(obj)<-"anc.ML"
- obj
-}
-
-logMNORM<-function(x,x0,vcv)
- -t(x-x0)%*%solve(vcv)%*%(x-x0)/2-length(x)*log(2*pi)/2-determinant(vcv,logarithm=TRUE)$modulus[1]/2
-
-## print method for "anc.ML"
-## written by Liam J. Revell 2015, 2016
-print.anc.ML<-function(x,digits=6,printlen=NULL,...){
- cat(paste("Ancestral character estimates using anc.ML under a(n)",
- x$model,"model:\n"))
- Nnode<-length(x$ace)
- if(is.null(printlen)||printlen>=Nnode) print(round(x$ace,digits))
- else printDotDot(x$ace,digits,printlen)
- if(!is.null(x$var)){
- cat("\nVariances on ancestral states:\n")
- if(is.null(printlen)||printlen>=Nnode) print(round(x$var,digits))
- else printDotDot(x$var,digits,printlen)
- }
- if(!is.null(x$CI95)){
- cat("\nLower & upper 95% CIs:\n")
- colnames(x$CI95)<-c("lower","upper")
- if(is.null(printlen)||printlen>=Nnode) print(round(x$CI95,digits))
- else printDotDot(x$CI95,digits,printlen)
- }
- cat("\nFitted model parameters & likelihood:\n")
- if(x$model=="BM"){
- obj<-data.frame(round(x$sig2,digits),round(x$logLik,digits))
- colnames(obj)<-c("sig2","log-likelihood")
- rownames(obj)<-""
- print(obj)
- } else if(x$model=="OU"){
- obj<-data.frame(round(x$sig2,digits),round(x$alpha,digits),
- round(x$logLik,digits))
- colnames(obj)<-c("sigma^2","alpha","logLik")
- rownames(obj)<-""
- print(obj)
- } else if(x$model=="EB"){
- obj<-data.frame(round(x$sig2,digits),round(x$r,digits),
- round(x$logLik,digits))
- colnames(obj)<-c("sigma^2","r","logLik")
- rownames(obj)<-""
- print(obj)
- }
- if(x$convergence==0) cat("\nR thinks it has found the ML solution.\n\n")
- else cat("\nOptimization may not have converged.\n\n")
-}
-
-## S3 logLik method for "anc.ML" object class
-logLik.anc.ML<-function(object,...){
- lik<-object$logLik
- if(object$model=="BM") attr(lik,"df")<-length(object$ace)+1
- else if(object$model=="EB") attr(lik,"df")<-length(object$ace)+2
- else if(object$model=="OU") attr(lik,"df")<-length(object$ace)+2
- lik
-}
+## lightweight version of ace(...,method="ML") for continuous traits
+## also allows missing data in x, in which case missing data are also estimated
+## written by Liam J. Revell 2011, 2013, 2014, 2015
+
+anc.ML<-function(tree,x,maxit=2000,model=c("BM","OU","EB"),...){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ if(model[1]=="BM") obj<-anc.BM(tree,x,maxit,...)
+ else if(model[1]=="OU") obj<-anc.OU(tree,x,maxit,...)
+ else if(model[1]=="EB") obj<-anc.EB(tree,x,maxit,...)
+ else stop(paste("Do not recognize method",model))
+ obj
+}
+
+## internal to estimate ancestral states under a BM model
+## written by Liam J. Revell 2011, 2013, 2014, 2016, 2018
+anc.BM<-function(tree,x,maxit,...){
+ if(hasArg(trace)) trace<-list(...)$trace
+ else trace<-FALSE
+ if(hasArg(vars)) vars<-list(...)$vars
+ else vars<-FALSE
+ if(hasArg(CI)) CI<-list(...)$CI
+ else CI<-FALSE
+ if(hasArg(se)) se<-list(...)$se
+ else se<-setNames(rep(0,length(x)),names(x))
+ SE<-setNames(rep(0,Ntip(tree)),tree$tip.label)
+ SE[names(se)]<-se
+ E<-diag(SE)
+ colnames(E)<-rownames(E)<-names(SE)
+ if(hasArg(tol)) tol<-list(...)$tol
+ else tol<-10*.Machine$double.eps
+ ## check to see if any tips are missing data
+ xx<-setdiff(tree$tip.label,names(x))
+ ## function returns the log-likelihood
+ likelihood<-function(par,C,invC,detC,xvals,msp,trace,E=0){
+ sig2<-par[1]
+ a<-par[2]
+ y<-par[1:(tree$Nnode-1)+2]
+ xvals<-c(xvals,setNames(par[1:length(msp)+tree$Nnode+1],msp))
+ xvals<-xvals[rownames(C)[1:length(tree$tip.label)]]
+ z<-c(xvals,y)-a
+ if(trace) cat(paste(round(sig2,6)," --- ",sep=""))
+ if(sum(E)>0){
+ C<-sig2*C
+ C[rownames(E),colnames(E)]<-C[rownames(E),colnames(E)]+E
+ invC<-solve(C)
+ detC<-determinant(C,logarithm=TRUE)$modulus[1]
+ }
+ logLik<-(-z%*%invC%*%z/(2*sig2)-nrow(C)*log(2*pi)/2-nrow(C)*log(sig2)/2-
+ detC/2)[1,1]
+ if(trace) cat(paste(round(logLik,6),"\n"))
+ -logLik
+ }
+ ## compute C
+ C<-vcvPhylo(tree)
+ invC<-solve(C)
+ detC<-determinant(C,logarithm=TRUE)$modulus[1]
+ ## assign starting values
+ zz<-fastAnc(tree,c(x,setNames(rep(mean(x),length(xx)),xx)))
+ y<-zz[2:length(zz)]
+ a<-zz[1]
+ bb<-c(c(x,setNames(rep(mean(x),length(xx)),xx))[tree$tip.label],y)
+ sig2<-((bb-a)%*%invC%*%(bb-a)/nrow(C))[1,1]
+ fit<-optim(c(sig2,a,y,rep(mean(x),length(xx))),fn=likelihood,C=C,invC=invC,
+ detC=detC,xvals=x,msp=xx,trace=trace,E=E,method="L-BFGS-B",
+ lower=c(tol,rep(-Inf,tree$Nnode+length(xx))),
+ control=list(maxit=maxit))
+ if(vars||CI){
+ H<-hessian(likelihood,fit$par,C=C,invC=invC,detC=detC,
+ xvals=x,msp=xx,trace=trace,E=E)
+ vcv<-solve(H)
+ }
+ states<-fit$par[1:tree$Nnode+1]
+ names(states)<-c(length(tree$tip)+1,rownames(C)[(length(tree$tip)+1):nrow(C)])
+ obj<-list(sig2=fit$par[1],ace=states,logLik=-fit$value,counts=fit$counts,
+ convergence=fit$convergence,message=fit$message,model="BM")
+ if(vars) obj$var<-setNames(diag(vcv)[1:tree$Nnode+1],
+ c(length(tree$tip)+1,rownames(C)[(length(tree$tip)+1):nrow(C)]))
+ if(CI){
+ obj$CI95<-cbind(obj$ace-1.96*sqrt(diag(vcv)[1:tree$Nnode+1]),
+ obj$ace+1.96*sqrt(diag(vcv)[1:tree$Nnode+1]))
+ rownames(obj$CI95)<-c(length(tree$tip)+1,
+ rownames(C)[(length(tree$tip)+1):nrow(C)])
+ }
+ if(length(xx)>0){
+ obj$missing.x<-setNames(fit$par[1:length(xx)+tree$Nnode+1],xx)
+ if(vars) obj$missing.var<-setNames(diag(vcv)[1:length(xx)+
+ tree$Nnode+1],xx)
+ if(CI){
+ obj$missing.CI95<-cbind(obj$missing.x-
+ 1.96*sqrt(diag(vcv)[1:length(xx)+tree$Nnode+1]),
+ obj$missing.x+1.96*sqrt(diag(vcv)[1:length(xx)+tree$Nnode+1]))
+ rownames(obj$missing.CI95)<-xx
+ }
+ }
+ class(obj)<-"anc.ML"
+ obj
+}
+
+## internal to estimate ancestral states under an OU model (this may not work)
+## written by Liam J. Revell 2014
+anc.OU<-function(tree,x,maxit=2000,...){
+ ## check to see if any tips are missing data
+ xx<-setdiff(tree$tip.label,names(x))
+ if(length(xx)>0) stop("Some tips of the tree do not have data. Try model=\"BM\".")
+ if(hasArg(tol)) tol<-list(...)$tol
+ else tol<-1e-8
+ if(hasArg(trace)) trace<-list(...)$trace
+ else trace<-FALSE
+ if(hasArg(a.init)) a.init<-list(...)$a.init
+ else a.init<-2*log(2)/max(nodeHeights(tree))
+ likOU<-function(par,tree,x,trace){
+ sig2<-par[1]
+ alpha<-par[2]
+ a0<-par[3]
+ a<-par[1:(tree$Nnode-1)+3]
+ logLik<-logMNORM(c(x,a),rep(a0,Ntip(tree)+tree$Nnode-1),sig2*vcvPhylo(tree,model="OU",alpha=alpha))
+ if(trace) print(c(sig2,alpha,logLik))
+ -logLik
+ }
+ x<-x[tree$tip.label]
+ pp<-rep(NA,tree$Nnode+2)
+ pp[1:tree$Nnode+2]<-fastAnc(tree,x)
+ pp[1]<-phyl.vcv(as.matrix(c(x,pp[2:tree$Nnode+2])),vcvPhylo(tree),lambda=1)$R[1,1]
+ pp[2]<-a.init ## arbitrarily
+ fit<-optim(pp,likOU,tree=tree,x=x,trace=trace,method="L-BFGS-B",
+ lower=c(tol,tol,rep(-Inf,tree$Nnode)),upper=rep(Inf,length(pp)),
+ control=list(maxit=maxit))
+ obj<-list(sig2=fit$par[1],alpha=fit$par[2],
+ ace=setNames(fit$par[1:tree$Nnode+2],1:tree$Nnode+length(tree$tip.label)),
+ logLik=-fit$value,counts=fit$counts,convergence=fit$convergence,
+ message=fit$message,model="OU")
+ class(obj)<-"anc.ML"
+ obj
+}
+
+## EB is the Early-burst model (Harmon et al. 2010) and also called the ACDC model
+## (accelerating-decelerating; Blomberg et al. 2003). Set by the a rate parameter, EB fits a model where
+## the rate of evolution increases or decreases exponentially through time, under the model
+## r[t] = r[0] * exp(a * t), where r[0] is the initial rate, a is the rate change parameter, and t is
+## time. The maximum bound is set to -0.000001, representing a decelerating rate of evolution. The minimum
+## bound is set to log(10^-5)/depth of the tree.
+
+## internal to estimate ancestral states under an EB model
+## written by Liam J. Revell 2017
+anc.EB<-function(tree,x,maxit=2000,...){
+ ## check to see if any tips are missing data
+ xx<-setdiff(tree$tip.label,names(x))
+ if(length(xx)>0) stop("Some tips of the tree do not have data. Try model=\"BM\".")
+ if(hasArg(tol)) tol<-list(...)$tol
+ else tol<-1e-8
+ if(hasArg(trace)) trace<-list(...)$trace
+ else trace<-FALSE
+ if(hasArg(vars)) vars<-list(...)$vars
+ else vars<-FALSE
+ if(hasArg(CI)) CI<-list(...)$CI
+ else CI<-FALSE
+ if(hasArg(r.init)){
+ r.init<-list(...)$r.init
+ obj<-phyl.vcv(as.matrix(x[tree$tip.label]),
+ vcv(ebTree(tree,r.init)),1)
+ s2.init<-obj$R[1,1]
+ a0.init<-obj$alpha[1,1]
+ } else {
+ ## optimize r.init
+ lik<-function(p,tree,x)
+ logLik<--logMNORM(x,rep(p[3],Ntip(tree)),
+ p[1]*vcvPhylo(tree,model="EB",r=p[2],anc.nodes=F))
+ obj<-phyl.vcv(as.matrix(x[tree$tip.label]),vcv(tree),1)
+ fit.init<-optim(c(obj$R[1,1],0,obj$alpha[1,1]),
+ lik,tree=tree,x=x,method="L-BFGS-B",lower=c(tol,-Inf,-Inf),
+ upper=rep(Inf,3))
+ r.init<-fit.init$par[2]
+ s2.init<-fit.init$par[1]
+ a0.init<-fit.init$par[3]
+ }
+ likEB<-function(par,tree,x,trace){
+ sig2<-par[1]
+ r<-par[2]
+ obj<-fastAnc(ebTree(tree,r),x)
+ a0<-obj[1]
+ a<-obj[2:length(obj)]
+ logLik<-logMNORM(c(x,a),rep(a0,Ntip(tree)+tree$Nnode-1),
+ sig2*vcvPhylo(tree,model="EB",r=r))
+ if(trace) print(c(sig2,r,logLik))
+ -logLik
+ }
+ x<-x[tree$tip.label]
+ pp<-rep(NA,2)
+ pp[1]<-s2.init
+ pp[2]<-r.init
+ fit<-optim(pp,likEB,tree=tree,x=x,trace=trace,method="L-BFGS-B",
+ lower=c(tol,-Inf),upper=rep(Inf,2),control=list(maxit=maxit))
+ obj<-list(sig2=fit$par[1],r=fit$par[2],
+ ace=unclass(fastAnc(ebTree(tree,fit$par[2]),x)),
+ logLik=-fit$value,counts=fit$counts,convergence=fit$convergence,
+ message=fit$message,model="EB")
+ if(vars||CI){
+ likEB.hessian<-function(par,tree,y){
+ sig2<-par[1]
+ r<-par[2]
+ a<-par[3:length(par)]
+ logLik<-logMNORM(c(y,a[2:length(a)]),rep(a[1],Ntip(tree)+tree$Nnode-1),
+ sig2*vcvPhylo(tree,model="EB",r=r))
+ -logLik
+ }
+ H<-hessian(likEB.hessian,c(fit$par,obj$ace),tree=tree,y=x)
+ vcv<-solve(H)
+ if(vars) obj$var<-setNames(diag(vcv)[1:tree$Nnode+1],1:tree$Nnode+Ntip(tree))
+ if(CI){
+ obj$CI95<-cbind(obj$ace-1.96*sqrt(diag(vcv)[1:tree$Nnode+2]),
+ obj$ace+1.96*sqrt(diag(vcv)[1:tree$Nnode+2]))
+ rownames(obj$CI95)<-1:tree$Nnode+Ntip(tree)
+ }
+ }
+ class(obj)<-"anc.ML"
+ obj
+}
+
+logMNORM<-function(x,x0,vcv)
+ -t(x-x0)%*%solve(vcv)%*%(x-x0)/2-length(x)*log(2*pi)/2-determinant(vcv,logarithm=TRUE)$modulus[1]/2
+
+## print method for "anc.ML"
+## written by Liam J. Revell 2015, 2016
+print.anc.ML<-function(x,digits=6,printlen=NULL,...){
+ cat(paste("Ancestral character estimates using anc.ML under a(n)",
+ x$model,"model:\n"))
+ Nnode<-length(x$ace)
+ if(is.null(printlen)||printlen>=Nnode) print(round(x$ace,digits))
+ else printDotDot(x$ace,digits,printlen)
+ if(!is.null(x$var)){
+ cat("\nVariances on ancestral states:\n")
+ if(is.null(printlen)||printlen>=Nnode) print(round(x$var,digits))
+ else printDotDot(x$var,digits,printlen)
+ }
+ if(!is.null(x$CI95)){
+ cat("\nLower & upper 95% CIs:\n")
+ colnames(x$CI95)<-c("lower","upper")
+ if(is.null(printlen)||printlen>=Nnode) print(round(x$CI95,digits))
+ else printDotDot(x$CI95,digits,printlen)
+ }
+ cat("\nFitted model parameters & likelihood:\n")
+ if(x$model=="BM"){
+ obj<-data.frame(round(x$sig2,digits),round(x$logLik,digits))
+ colnames(obj)<-c("sig2","log-likelihood")
+ rownames(obj)<-""
+ print(obj)
+ } else if(x$model=="OU"){
+ obj<-data.frame(round(x$sig2,digits),round(x$alpha,digits),
+ round(x$logLik,digits))
+ colnames(obj)<-c("sigma^2","alpha","logLik")
+ rownames(obj)<-""
+ print(obj)
+ } else if(x$model=="EB"){
+ obj<-data.frame(round(x$sig2,digits),round(x$r,digits),
+ round(x$logLik,digits))
+ colnames(obj)<-c("sigma^2","r","logLik")
+ rownames(obj)<-""
+ print(obj)
+ }
+ if(x$convergence==0) cat("\nR thinks it has found the ML solution.\n\n")
+ else cat("\nOptimization may not have converged.\n\n")
+}
+
+## S3 logLik method for "anc.ML" object class
+logLik.anc.ML<-function(object,...){
+ lik<-object$logLik
+ if(object$model=="BM") attr(lik,"df")<-length(object$ace)+1
+ else if(object$model=="EB") attr(lik,"df")<-length(object$ace)+2
+ else if(object$model=="OU") attr(lik,"df")<-length(object$ace)+2
+ lik
+}
diff --git a/R/anc.trend.R b/R/anc.trend.R
index 28e1efc..4023941 100644
--- a/R/anc.trend.R
+++ b/R/anc.trend.R
@@ -1,83 +1,83 @@
-## this function estimates ancestral traits with a trend
-## written by Liam J. Revell 2011, 2013, 2015, 2017
-
-anc.trend<-function(tree,x,maxit=2000){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
-
- ## check if tree is ultrametric
- if(is.ultrametric(tree))
- cat("Warning: the trend model is generally non-identifiable for ultrametric trees.\n")
-
- # preliminaries
- # set global
- tol<-1e-8
- # check to make sure that C will be non-singular
- if(any(tree$edge.length<=(10*.Machine$double.eps)))
- stop("some branch lengths are 0 or nearly zero")
- # compute C
- D<-dist.nodes(tree)
- ntips<-length(tree$tip.label)
- Cii<-D[ntips+1,]
- C<-D; C[,]<-0
- counts<-vector()
- for(i in 1:nrow(D)) for(j in 1:ncol(D)) C[i,j]<-(Cii[i]+Cii[j]-D[i,j])/2
- dimnames(C)[[1]][1:length(tree$tip)]<-tree$tip.label
- dimnames(C)[[2]][1:length(tree$tip)]<-tree$tip.label
- C<-C[c(1:ntips,(ntips+2):nrow(C)),c(1:ntips,(ntips+2):ncol(C))]
- # sort x by tree$tip.label
- x<-x[tree$tip.label]
-
- # function returns the negative log-likelihood
- likelihood<-function(theta,x,C){
- a<-theta[1]
- u<-theta[2]
- sig2<-theta[3]
- y<-theta[4:length(theta)]
- logLik<-dmnorm(x=c(x,y),mean=(a+diag(C)*u),
- varcov=sig2*C,log=TRUE)
- return(-logLik)
- }
-
- # get reasonable starting values for the optimizer
- a<-mean(x)
- sig2<-var(x)/max(C)
-
- # perform ML optimization
- result<-optim(par=c(a,0,sig2,rep(a,tree$Nnode-1)),likelihood,
- x=x,C=C,method="L-BFGS-B",lower=c(-Inf,-Inf,tol,rep(-Inf,tree$Nnode-1)),
- control=list(maxit=maxit))
-
- # return the result
- ace<-c(result$par[c(1,4:length(result$par))])
- names(ace)<-c(as.character(tree$edge[1,1]),
- rownames(C)[(length(tree$tip.label)+1):nrow(C)])
- obj<-list(ace=ace,mu=result$par[2],sig2=result$par[3],
- logL=-result$value,convergence=result$convergence,
- message=result$message)
- class(obj)<-"anc.trend"
- obj
-}
-
-
-## print method for "anc.trend"
-## written by Liam J. Revell 2015, 2017
-print.anc.trend<-function(x,digits=6,printlen=NULL,...){
- cat("Ancestral character estimates using anc.trend:\n")
- Nnode<-length(x$ace)
- if(is.null(printlen)||printlen>=Nnode) print(round(x$ace,digits))
- else printDotDot(x$ace,digits,printlen)
- cat("\nParameter estimates:\n")
- cat(paste("\tmu",paste(rep(" ",digits),collapse=""),"\tsig^2",
- paste(rep(" ",max(digits-3,1)),collapse=""),"\tlog(L)\n",sep=""))
- cat(paste("\t",round(x$mu,digits),"\t",round(x$sig2,digits),"\t",
- round(x$logL,digits),"\n"),sep="")
- if(x$convergence==0) cat("\nR thinks it has converged.\n\n")
- else cat("\nR thinks function may not have converged.\n\n")
-}
-
-## logLik method for "anc.trend"
-logLik.anc.trend<-function(object,...){
- lik<-object$logL
- attr(lik,"df")<-length(object$ace)+2
- lik
-}
+## this function estimates ancestral traits with a trend
+## written by Liam J. Revell 2011, 2013, 2015, 2017
+
+anc.trend<-function(tree,x,maxit=2000){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+
+ ## check if tree is ultrametric
+ if(is.ultrametric(tree))
+ cat("Warning: the trend model is generally non-identifiable for ultrametric trees.\n")
+
+ # preliminaries
+ # set global
+ tol<-1e-8
+ # check to make sure that C will be non-singular
+ if(any(tree$edge.length<=(10*.Machine$double.eps)))
+ stop("some branch lengths are 0 or nearly zero")
+ # compute C
+ D<-dist.nodes(tree)
+ ntips<-length(tree$tip.label)
+ Cii<-D[ntips+1,]
+ C<-D; C[,]<-0
+ counts<-vector()
+ for(i in 1:nrow(D)) for(j in 1:ncol(D)) C[i,j]<-(Cii[i]+Cii[j]-D[i,j])/2
+ dimnames(C)[[1]][1:length(tree$tip)]<-tree$tip.label
+ dimnames(C)[[2]][1:length(tree$tip)]<-tree$tip.label
+ C<-C[c(1:ntips,(ntips+2):nrow(C)),c(1:ntips,(ntips+2):ncol(C))]
+ # sort x by tree$tip.label
+ x<-x[tree$tip.label]
+
+ # function returns the negative log-likelihood
+ likelihood<-function(theta,x,C){
+ a<-theta[1]
+ u<-theta[2]
+ sig2<-theta[3]
+ y<-theta[4:length(theta)]
+ logLik<-dmnorm(x=c(x,y),mean=(a+diag(C)*u),
+ varcov=sig2*C,log=TRUE)
+ return(-logLik)
+ }
+
+ # get reasonable starting values for the optimizer
+ a<-mean(x)
+ sig2<-var(x)/max(C)
+
+ # perform ML optimization
+ result<-optim(par=c(a,0,sig2,rep(a,tree$Nnode-1)),likelihood,
+ x=x,C=C,method="L-BFGS-B",lower=c(-Inf,-Inf,tol,rep(-Inf,tree$Nnode-1)),
+ control=list(maxit=maxit))
+
+ # return the result
+ ace<-c(result$par[c(1,4:length(result$par))])
+ names(ace)<-c(as.character(tree$edge[1,1]),
+ rownames(C)[(length(tree$tip.label)+1):nrow(C)])
+ obj<-list(ace=ace,mu=result$par[2],sig2=result$par[3],
+ logL=-result$value,convergence=result$convergence,
+ message=result$message)
+ class(obj)<-"anc.trend"
+ obj
+}
+
+
+## print method for "anc.trend"
+## written by Liam J. Revell 2015, 2017
+print.anc.trend<-function(x,digits=6,printlen=NULL,...){
+ cat("Ancestral character estimates using anc.trend:\n")
+ Nnode<-length(x$ace)
+ if(is.null(printlen)||printlen>=Nnode) print(round(x$ace,digits))
+ else printDotDot(x$ace,digits,printlen)
+ cat("\nParameter estimates:\n")
+ cat(paste("\tmu",paste(rep(" ",digits),collapse=""),"\tsig^2",
+ paste(rep(" ",max(digits-3,1)),collapse=""),"\tlog(L)\n",sep=""))
+ cat(paste("\t",round(x$mu,digits),"\t",round(x$sig2,digits),"\t",
+ round(x$logL,digits),"\n"),sep="")
+ if(x$convergence==0) cat("\nR thinks it has converged.\n\n")
+ else cat("\nR thinks function may not have converged.\n\n")
+}
+
+## logLik method for "anc.trend"
+logLik.anc.trend<-function(object,...){
+ lik<-object$logL
+ attr(lik,"df")<-length(object$ace)+2
+ lik
+}
diff --git a/R/ancThresh.R b/R/ancThresh.R
index e6a5c13..7ba65c8 100644
--- a/R/ancThresh.R
+++ b/R/ancThresh.R
@@ -1,455 +1,455 @@
-## function performs ancestral character estimation under the threshold model
-## written by Liam J. Revell 2012, 2013, 2014, 2017, 2019, 2020
-
-ancThresh<-function(tree,x,ngen=100000,sequence=NULL,method="mcmc",
- model=c("BM","OU","lambda"),control=list(),...){
-
- if(!inherits(tree,"phylo"))
- stop("tree should be an object of class \"phylo\".")
-
- if(hasArg(auto.tune)) auto.tune<-list(...)$auto.tune
- else auto.tune<-TRUE
- if(is.logical(auto.tune)) if(auto.tune==TRUE) auto.tune<-0.234
- else if(is.numeric(auto.tune)) if(auto.tune>=1.0||auto.tune<=0.0){
- cat("value for auto.tune outside allowable range. Resetting....\n")
- auto.tune<-0.234
- }
-
- # check method
- if(method!="mcmc") stop(paste(c("do not recognize method =",method,
- ",quitting")))
-
- # get model for the evolution of liability
- model<-model[1]
-
- # check x
- if(is.factor(x)) x<-setNames(as.character(x),names(x))
- if(is.data.frame(x)) x<-as.matrix(x)
- if(is.matrix(x)){
- X<-x[tree$tip.label,]
- if(is.null(sequence)){
- message("**** NOTE: no sequence provided, column order in x")
- seq<-colnames(X)
- } else seq<-sequence
- } else if(is.vector(x)){
- x<-x[tree$tip.label]
- if(is.null(sequence)){
- message("**** NOTE: no sequence provided, using alphabetical or numerical order")
- seq<-sort(levels(as.factor(x)))
- } else seq<-sequence
- X<-to.matrix(x,seq)
- }
- # row scale X
- X<-X/apply(X,1,sum)
- X<-X[,seq] # order columns by seq
-
- # ok, now set starting thresholds
- th<-c(1:length(seq))-1
- names(th)<-seq
- x<-to.vector(X)
- ## set plausible starting liabilities
- MU<-mean(th)
- SD<-2*sd(th)
- # now change the upper limit of th to Inf
- th[length(th)]<-Inf
- l<-setNames(vector(mode="numeric",length=length(x)),names(x))
- for(i in 1:length(l)){
- l[i]<-rnorm(n=1,mean=MU,sd=SD)
- while(threshState(l[i],thresholds=th)!=x[i]) l[i]<-rnorm(n=1,mean=MU,
- sd=SD)
- }
- ## set plausible starting liability
- ## l<-sapply(x,function(x) runif(n=1,min=th[x]-1,max=th[x]))
- if(model=="OU") alpha<-0.1*max(nodeHeights(tree))
- if(model=="lambda") lambda<-1.0
-
- # for MCMC
- n<-length(tree$tip)
- m<-length(th)
- npar<-if(model=="BM") tree$Nnode+n+m-2 else tree$Nnode+n+m-1
-
-
- # populate control list
- PrA<-matrix(1/m,tree$Nnode,m,dimnames=list(1:tree$Nnode+n,seq))
- if(!is.null(control$pr.anc)){
- if(!is.matrix(control$pr.anc)){
- message("**** NOTE: prior on ancestral states must be in matrix form; using default prior")
- control$pr.anc<-NULL
- } else {
- control$pr.anc<-control$pr.anc[,seq,drop=FALSE]
- PrA[rownames(control$pr.anc),]<-control$pr.anc
- control$pr.anc<-PrA
- }
- }
- con=list(sample=1000,
- propliab=0.5*max(nodeHeights(tree)),
- propthresh=0.05*max(nodeHeights(tree)),
- propalpha=0.1*max(nodeHeights(tree)),
- proplambda=0.01,
- pr.anc=PrA,
- pr.th=0.01,
- burnin=round(0.2*ngen),
- plot=FALSE,
- print=TRUE,
- piecol=setNames(palette()[1:length(seq)],seq),
- tipcol="input",
- quiet=FALSE)
- con[(namc<-names(control))]<-control
- con<-con[!sapply(con,is.null)]
-
- # now set ancestral liabilities, by first picking ancestral states from their prior
- temp<-apply(con$pr.anc,1,rstate)
- # assign random liabilities consistent with the starting thresholds
- ## a<-sapply(temp,function(x) runif(n=1,min=th[x]-1,max=th[x]))
- a<-setNames(vector(mode="numeric",length=length(temp)),names(temp))
- for(i in 1:length(a)){
- a[i]<-rnorm(n=1,mean=MU,sd=SD)
- while(threshState(a[i],thresholds=th)!=temp[i]) a[i]<-rnorm(n=1,mean=MU,
- sd=SD)
- }
-
- # compute some matrices & values
- V<-if(model=="BM") vcvPhylo(tree)
- else if(model=="OU") vcvPhylo(tree,model="OU",alpha=alpha)
- else if(model=="lambda") vcvPhylo(tree,model="lambda",lambda=lambda)
- # check to make sure that V will be non-singular
- if(any(tree$edge.length<=(10*.Machine$double.eps)))
- stop("some branch lengths are 0 or nearly zero")
- invV<-solve(V)
- detV<-determinant(V,logarithm=TRUE)$modulus[1]
- lik1<-likLiab(l,a,V,invV,detV)+log(probMatch(X,l,th,seq))
-
- # store
- A<-matrix(NA,ngen/con$sample+1,tree$Nnode,dimnames=list(NULL,
- n+1:tree$Nnode))
- B<-if(model=="BM") matrix(NA,ngen/con$sample+1,m+2,
- dimnames=list(NULL,c("gen",names(th),"logLik")))
- else if(model=="OU") matrix(NA,ngen/con$sample+1,m+3,
- dimnames=list(NULL,c("gen",names(th),"alpha","logLik")))
- else if(model=="lambda") matrix(NA,ngen/con$sample+1,m+3,
- dimnames=list(NULL,c("gen",names(th),"lambda","logLik")))
-
- C<-matrix(NA,ngen/con$sample+1,tree$Nnode+n,dimnames=list(NULL,
- c(tree$tip.label,1:tree$Nnode+n)))
- A[1,]<-threshState(a,thresholds=th)
- B[1,]<-if(model=="BM") c(0,th,lik1) else
- if(model=="OU") c(0,th,alpha,lik1) else
- if(model=="lambda") c(0,th,lambda,lik1)
- C[1,]<-c(l[tree$tip.label],a[as.character(1:tree$Nnode+n)])
-
- # run MCMC
- message("MCMC starting....")
- logL<-lik1<-likLiab(l,a,V,invV,detV)+log(probMatch(X,l,th,seq))
- for(i in 1:ngen){
- lik1<-logL
- d<-i%%npar
- if(ngen>=1000) if(i%%1000==0) if(con$print) message(paste("gen",i))
- ap<-a; lp<-l; thp<-th
- if(model=="OU") alphap<-alpha
- if(model=="lambda") lambdap<-lambda
- Vp<-V; invVp<-invV; detVp<-detV
- if(d<=tree$Nnode&&d!=0){
- # update node liabilities
- ind<-d%%tree$Nnode; if(ind==0) ind<-tree$Nnode
- ap[ind]<-a[ind]+rnorm(n=1,sd=sqrt(con$propliab))
- } else {
- if((d>tree$Nnode&&d<=(tree$Nnode+n))||(npar==(tree$Nnode+n)&&d==0)){
- # update tip liabilities
- if(d==0) ind<-n
- else { ind<-(d-tree$Nnode)%%n; if(ind==0) ind<-n }
- lp[ind]<-l[ind]+rnorm(n=1,sd=sqrt(con$propliab))
- } else if(d>(tree$Nnode+n)&&d<=(tree$Nnode+n+m-2)||(npar==(tree$Nnode+n+m-2)&&d==0)) {
- # update thresholds
- if(d) ind<-(d-tree$Nnode-n)%%m+1
- else ind<-m-1
- thp[ind]<-bounce(th[ind],rnorm(n=1,sd=sqrt(con$propthresh)),c(th[ind-1],th[ind+1]))
- } else {
- if(model=="OU"){
- alphap<-bounce(alpha,rnorm(n=1,sd=sqrt(con$propalpha)),c(0,Inf))
- Vp<-vcvPhylo(tree,model="OU",alpha=alphap)
- } else if(model=="lambda"){
- lambdap<-bounce(lambda,rnorm(n=1,sd=sqrt(con$proplambda)),c(0,1))
- Vp<-vcvPhylo(tree,model="lambda",lambda=lambdap)
- }
- invVp<-solve(Vp)
- detVp<-determinant(Vp,logarithm=TRUE)$modulus[1]
- }
- }
- lik2<-likLiab(lp,ap,Vp,invVp,detVp)+log(probMatch(X,lp,thp,seq))
- p.odds<-min(c(1,exp(lik2+logPrior(threshState(ap,thresholds=thp),thp,con)-
- lik1-logPrior(threshState(a,thresholds=th),th,con))))
-
- if(p.odds>runif(n=1)){
- a<-ap; l<-lp; th<-thp
- V<-Vp; detV<-detVp; invV<-invVp
- if(model=="OU") alpha<-alphap
- if(model=="lambda") lambda<-lambdap
- logL<-lik2
- } else logL<-lik1
- if(i%%con$sample==0){
- A[i/con$sample+1,]<-threshState(a,thresholds=th)
- B[i/con$sample+1,]<-if(model=="BM") c(i,th[colnames(B)[1+1:m]],logL) else
- if(model=="OU") c(i,th[colnames(B)[1+1:m]],alpha,logL) else
- if(model=="lambda") c(i,th[colnames(B)[1+1:m]],lambda,logL)
- C[i/con$sample+1,]<-c(l[tree$tip.label],a[as.character(1:tree$Nnode+n)])
- }
- }
- mcmc<-as.data.frame(A)
- param<-as.data.frame(B)
- liab<-as.data.frame(C)
- ace<-matrix(0,tree$Nnode,m,dimnames=list(colnames(A),seq))
- burnin<-which(param[,"gen"]==con$burnin)
- for(i in 1:tree$Nnode){
- mcmc[[i]]<-as.factor(mcmc[[i]])
- temp<-summary(mcmc[burnin:nrow(mcmc),i])/(nrow(mcmc)-burnin+1)
- ace[i,names(temp)]<-temp
- }
- obj<-list(ace=ace,mcmc=mcmc,par=param,liab=liab,
- tree=tree,x=x,model=model,
- seq=seq,
- ngen=ngen,sample=con$sample,
- burnin=con$burnin)
- class(obj)<-"ancThresh"
- if(con$plot) plot(obj)
- obj
-}
-
-## some S3 methods (added in 2017)
-
-print.ancThresh<-function(x,...){
- cat("\nObject containing the results from an MCMC analysis\n")
- cat("of the threshold model using ancThresh.\n\n")
- cat("List with the following components:\n")
- cat(paste("ace:\tmatrix with posterior probabilities assuming",x$burnin,
- "\n\tburn-in generations.\n"))
- cat("mcmc:\tposterior sample of liabilities at tips & internal\n")
- cat(paste("\tnodes (a matrix with",nrow(x$mcmc),"rows &",ncol(x$mcmc),
- "columns).\n"))
- cat("par:\tposterior sample of the relative positions of the\n")
- cat(paste("\tthresholds, the log-likelihoods, and any other\n",
- "\tmodel variables (a matrix with",nrow(x$par),"rows).\n\n"))
- cat("The MCMC was run under the following conditions:\n")
- cat(paste("\tseq =",paste(x$seq,collapse=" <-> "),
- "\n\tmodel =",x$model,"\n\tnumber of generations =",x$ngen,
- "\n\tsample interval=",x$sample,
- "\n\tburn-in =",x$burnin,"\n\n"))
-}
-
-plot.ancThresh<-function(x,...){
- if(hasArg(burnin)) burnin<-list(...)$burnin
- else burnin<-x$burnin
- args<-list(...)
- if(is.null(args$lwd)) args$lwd<-1
- if(is.null(args$type)) args$type<-"phylogram"
- if(is.null(args$ylim))
- if(args$type=="phylogram")
- args$ylim<-c(-0.1*Ntip(x$tree),Ntip(x$tree))
- if(is.null(args$offset)) args$offset<-0.5
- if(is.null(args$ftype)) args$ftype="i"
- args$tree<-x$tree
- do.call(plotTree,args)
- ii<-which(x$par[,1]==burnin)+1
- LIAB<-as.matrix(x$liab)[ii:nrow(x$liab),]
- THRESH<-as.matrix(x$par)[ii:nrow(x$par),1:length(x$seq)+1]
- STATES<-matrix(NA,nrow(LIAB),ncol(LIAB),dimnames=dimnames(LIAB))
- for(i in 1:nrow(LIAB)) STATES[i,]<-threshState(LIAB[i,],THRESH[i,])
- PP<-t(apply(STATES,2,function(x,levs)
- summary(factor(x,levels=levs))/length(x),levs=x$seq))
- if(hasArg(piecol)) piecol<-list(...)$piecol
- else piecol<-setNames(colorRampPalette(c("blue",
- "yellow"))(length(x$seq)),x$seq)
- if(hasArg(node.cex)) node.cex<-list(...)$node.cex
- else node.cex<-0.6
- nodelabels(pie=PP[1:x$tree$Nnode+Ntip(x$tree),],
- piecol=piecol,cex=node.cex)
- if(hasArg(tip.cex)) tip.cex<-list(...)$tip.cex
- else tip.cex<-0.4
- tiplabels(pie=PP[x$tree$tip.label,],piecol=piecol,
- cex=tip.cex)
- legend(x="bottomleft",legend=x$seq,pch=21,pt.bg=piecol,
- pt.cex=2.2,bty="n")
- invisible(PP)
-}
-
-# plots ancestral states from the threshold model
-# written by Liam J. Revell 2012, 2014
-
-plotThresh<-function(tree,x,mcmc,burnin=NULL,piecol,tipcol="input",legend=TRUE,...){
-
- if(is.logical(legend)||is.vector(legend)){
- if(is.logical(legend)&&legend==TRUE) leg<-setNames(names(piecol),names(piecol))
- else if(is.vector(legend)){
- leg<-legend[names(piecol)]
- legend<-TRUE
- }
- }
-
- # plot tree
- par(lend=2)
- plotTree(tree,ftype="i",lwd=1,ylim=if(legend) c(-0.1*length(tree$tip.label),
- length(tree$tip.label)) else NULL,...)
- if(legend){
- zz<-par()$cex; par(cex=0.6)
- for(i in 1:length(piecol))
- add.simmap.legend(leg=leg[i],colors=piecol[i],prompt=FALSE,
- x=0.02*max(nodeHeights(tree)),y=-0.1*length(tree$tip.label),vertical=FALSE,
- shape="square",fsize=1)
- par(cex=zz)
- }
- # pull matrices from mcmc
- ace<-mcmc$ace
- liab<-mcmc$liab
- param<-mcmc$par
-
- # get burnin
- if(is.null(burnin)) burnin<-round(0.2*max(param[,"gen"]))
- burnin<-which(param[,"gen"]==burnin)
-
- # check x
- if(is.data.frame(x)) x<-as.matrix(x)
- if(is.matrix(x)) X<-x[tree$tip.label,]
- else if(is.vector(x)){
- x<-x[tree$tip.label]
- X<-to.matrix(x,names(piecol))
- }
- # row scale X
- X/apply(X,1,sum)->X
-
- # plot node labels
- nodelabels(pie=ace,piecol=piecol[colnames(ace)],cex=0.6)
-
- # plot tip labels
- if(tipcol=="input") tiplabels(pie=X,piecol=piecol[colnames(X)],cex=0.6)
- else if(tipcol=="estimated") {
- XX<-matrix(NA,nrow(liab),length(tree$tip),dimnames=list(rownames(liab),
- colnames(liab)[1:length(tree$tip)]))
- for(i in 1:nrow(liab)) XX[i,]<-threshState(liab[i,1:length(tree$tip)],
- thresholds=param[i,1:ncol(X)+1])
- X<-t(apply(XX,2,function(x) summary(factor(x,levels=colnames(X)))))
- tiplabels(pie=X/rowSums(X),piecol=piecol[colnames(X)],cex=0.6)
- }
-}
-
-# computes DIC for threshold model
-# written by Liam J. Revell 2012, 2014
-
-threshDIC<-function(tree,x,mcmc,burnin=NULL,sequence=NULL,method="pD"){
- ## identify model
- if(any(colnames(mcmc$par)=="alpha")) model<-"OU"
- else if(any(colnames(mcmc$par)=="lambda")) model<-"lambda"
- else model<-"BM"
- # check x
- if(is.data.frame(x)) x<-as.matrix(x)
- if(is.matrix(x)){
- X<-x[tree$tip.label,]
- if(is.null(sequence)){
- message("**** NOTE: no sequence provided, column order in x")
- seq<-colnames(X)
- } else seq<-sequence
- } else if(is.vector(x)){
- x<-x[tree$tip.label]
- if(is.null(sequence)){
- message("**** NOTE: no sequence provided, using alphabetical or numerical order")
- seq<-sort(levels(as.factor(x)))
- } else seq<-sequence
- X<-to.matrix(x,seq)
- }
- # row scale X
- X<-X/apply(X,1,sum)
- X<-X[,seq] # order columns by seq
- # convert burnin to starting row
- if(is.null(burnin)) burnin<-0.2*max(mcmc$par[,"gen"])
- start<-which(mcmc$par[,"gen"]==burnin)+1
- # compute
- k<-if(model=="BM") 1 else 2
- thBar<-colMeans(mcmc$par[start:nrow(mcmc$par),2:(ncol(mcmc$par)-k)])
- liabBar<-colMeans(mcmc$liab[start:nrow(mcmc$liab),])
- if(model=="BM") V<-vcvPhylo(tree)
- else if(model=="OU") V<-vcvPhylo(tree,model="OU",
- alpha=mean(mcmc$par[start:nrow(mcmc$par),"alpha"]))
- else if(model=="lambda") V<-vcvPhylo(tree,model="lambda",
- lambda=mean(mcmc$par[start:nrow(mcmc$par),"lambda"]))
- Dtheta<--2*(likLiab(liabBar[tree$tip.label],
- liabBar[as.character(1:tree$Nnode+length(tree$tip))],V,solve(V),
- determinant(V,logarithm=TRUE)$modulus[1])+log(probMatch(X[tree$tip.label,],
- liabBar[tree$tip.label],thBar,seq)))
- D<--2*mcmc$par[start:nrow(mcmc$par),"logLik"]
- Dbar<-mean(D)
- if(method=="pD"){
- pD<-Dbar-Dtheta
- DIC<-pD+Dbar
- result<-setNames(c(Dbar,Dtheta,pD,DIC),c("Dbar","Dhat","pD","DIC"))
- } else if(method=="pV"){
- pV<-var(D)/2
- DIC<-pV+Dbar
- result<-setNames(c(Dbar,Dtheta,pV,DIC),c("Dbar","Dhat","pV","DIC"))
- }
- return(result)
-}
-
-# internal functions for ancThresh, plotThresh, and threshDIC
-
-## returns a state based on position relative to thresholds
-## threshStateC is a function from phangorn>=2.3.1
-threshState<-if(packageVersion("phangorn")>='2.3.1'){
- function(x,thresholds){
- res <- names(thresholds)[threshStateC(x, thresholds)]
- names(res) <- names(x)
- res
- }
-} else function(x,thresholds){
- t<-c(-Inf,thresholds,Inf)
- names(t)[length(t)]<-names(t)[length(t)-1]
- i<-1
- while(x>t[i]) i<-i+1
- names(t)[i]
-}
-
-# likelihood function for the liabilities
-likLiab<-function(l,a,V,invV,detV){
- y<-c(l,a[2:length(a)])-a[1]
- logL<--y%*%invV%*%y/2-nrow(V)*log(2*pi)/2-detV/2
- return(logL)
-}
-
-# function for the log-prior
-logPrior<-function(a,t,control){
-# pp<-sum(log(diag(control$pr.anc[names(a),a])))+
- pp<-sum(log(control$pr.anc[cbind(names(a),a)])) +
- if(length(t)>2) sum(dexp(t[2:(length(t)-1)],rate=control$pr.th,log=TRUE)) else 0
- return(pp)
-}
-
-# check if the liability predictions match observed data
-allMatch<-function(x,l,thresholds){
- result<-all(threshState(l,thresholds=thresholds)==x)
- if(!is.na(result)) return(result)
- else return(FALSE)
-}
-
-# check if the liability predictions match observed data & return a probability
-# (this allows states to be uncertain)
-probMatch<-function(X,l,thresholds,sequence){
- Y<-to.matrix(threshState(l,thresholds=thresholds),sequence)
- return(prod(rowSums(X*Y)))
-}
-
-# bounds parameter by bouncing
-bounce<-function(start,step,bounds){
- x<-start+step
- while(x>bounds[2]||x<bounds[1]){
- if(x>bounds[2]) x<-2*bounds[2]-x
- if(x<bounds[1]) x<-2*bounds[1]-x
- }
- return(x)
-}
-
-# convert vector of x to binary matrix
-to.matrix<-function(x,seq){
- X<-matrix(0,length(x),length(seq),dimnames=list(names(x),seq))
- for(i in 1:length(seq)) X[x==seq[i],i]<-1
- return(X)
-}
-
-# convert binary matrix to vector
-to.vector<-function(X) apply(X,1,rstate)
+## function performs ancestral character estimation under the threshold model
+## written by Liam J. Revell 2012, 2013, 2014, 2017, 2019, 2020
+
+ancThresh<-function(tree,x,ngen=100000,sequence=NULL,method="mcmc",
+ model=c("BM","OU","lambda"),control=list(),...){
+
+ if(!inherits(tree,"phylo"))
+ stop("tree should be an object of class \"phylo\".")
+
+ if(hasArg(auto.tune)) auto.tune<-list(...)$auto.tune
+ else auto.tune<-TRUE
+ if(is.logical(auto.tune)) if(auto.tune==TRUE) auto.tune<-0.234
+ else if(is.numeric(auto.tune)) if(auto.tune>=1.0||auto.tune<=0.0){
+ cat("value for auto.tune outside allowable range. Resetting....\n")
+ auto.tune<-0.234
+ }
+
+ # check method
+ if(method!="mcmc") stop(paste(c("do not recognize method =",method,
+ ",quitting")))
+
+ # get model for the evolution of liability
+ model<-model[1]
+
+ # check x
+ if(is.factor(x)) x<-setNames(as.character(x),names(x))
+ if(is.data.frame(x)) x<-as.matrix(x)
+ if(is.matrix(x)){
+ X<-x[tree$tip.label,]
+ if(is.null(sequence)){
+ message("**** NOTE: no sequence provided, column order in x")
+ seq<-colnames(X)
+ } else seq<-sequence
+ } else if(is.vector(x)){
+ x<-x[tree$tip.label]
+ if(is.null(sequence)){
+ message("**** NOTE: no sequence provided, using alphabetical or numerical order")
+ seq<-sort(levels(as.factor(x)))
+ } else seq<-sequence
+ X<-to.matrix(x,seq)
+ }
+ # row scale X
+ X<-X/apply(X,1,sum)
+ X<-X[,seq] # order columns by seq
+
+ # ok, now set starting thresholds
+ th<-c(1:length(seq))-1
+ names(th)<-seq
+ x<-to.vector(X)
+ ## set plausible starting liabilities
+ MU<-mean(th)
+ SD<-2*sd(th)
+ # now change the upper limit of th to Inf
+ th[length(th)]<-Inf
+ l<-setNames(vector(mode="numeric",length=length(x)),names(x))
+ for(i in 1:length(l)){
+ l[i]<-rnorm(n=1,mean=MU,sd=SD)
+ while(threshState(l[i],thresholds=th)!=x[i]) l[i]<-rnorm(n=1,mean=MU,
+ sd=SD)
+ }
+ ## set plausible starting liability
+ ## l<-sapply(x,function(x) runif(n=1,min=th[x]-1,max=th[x]))
+ if(model=="OU") alpha<-0.1*max(nodeHeights(tree))
+ if(model=="lambda") lambda<-1.0
+
+ # for MCMC
+ n<-length(tree$tip)
+ m<-length(th)
+ npar<-if(model=="BM") tree$Nnode+n+m-2 else tree$Nnode+n+m-1
+
+
+ # populate control list
+ PrA<-matrix(1/m,tree$Nnode,m,dimnames=list(1:tree$Nnode+n,seq))
+ if(!is.null(control$pr.anc)){
+ if(!is.matrix(control$pr.anc)){
+ message("**** NOTE: prior on ancestral states must be in matrix form; using default prior")
+ control$pr.anc<-NULL
+ } else {
+ control$pr.anc<-control$pr.anc[,seq,drop=FALSE]
+ PrA[rownames(control$pr.anc),]<-control$pr.anc
+ control$pr.anc<-PrA
+ }
+ }
+ con=list(sample=1000,
+ propliab=0.5*max(nodeHeights(tree)),
+ propthresh=0.05*max(nodeHeights(tree)),
+ propalpha=0.1*max(nodeHeights(tree)),
+ proplambda=0.01,
+ pr.anc=PrA,
+ pr.th=0.01,
+ burnin=round(0.2*ngen),
+ plot=FALSE,
+ print=TRUE,
+ piecol=setNames(palette()[1:length(seq)],seq),
+ tipcol="input",
+ quiet=FALSE)
+ con[(namc<-names(control))]<-control
+ con<-con[!sapply(con,is.null)]
+
+ # now set ancestral liabilities, by first picking ancestral states from their prior
+ temp<-apply(con$pr.anc,1,rstate)
+ # assign random liabilities consistent with the starting thresholds
+ ## a<-sapply(temp,function(x) runif(n=1,min=th[x]-1,max=th[x]))
+ a<-setNames(vector(mode="numeric",length=length(temp)),names(temp))
+ for(i in 1:length(a)){
+ a[i]<-rnorm(n=1,mean=MU,sd=SD)
+ while(threshState(a[i],thresholds=th)!=temp[i]) a[i]<-rnorm(n=1,mean=MU,
+ sd=SD)
+ }
+
+ # compute some matrices & values
+ V<-if(model=="BM") vcvPhylo(tree)
+ else if(model=="OU") vcvPhylo(tree,model="OU",alpha=alpha)
+ else if(model=="lambda") vcvPhylo(tree,model="lambda",lambda=lambda)
+ # check to make sure that V will be non-singular
+ if(any(tree$edge.length<=(10*.Machine$double.eps)))
+ stop("some branch lengths are 0 or nearly zero")
+ invV<-solve(V)
+ detV<-determinant(V,logarithm=TRUE)$modulus[1]
+ lik1<-likLiab(l,a,V,invV,detV)+log(probMatch(X,l,th,seq))
+
+ # store
+ A<-matrix(NA,ngen/con$sample+1,tree$Nnode,dimnames=list(NULL,
+ n+1:tree$Nnode))
+ B<-if(model=="BM") matrix(NA,ngen/con$sample+1,m+2,
+ dimnames=list(NULL,c("gen",names(th),"logLik")))
+ else if(model=="OU") matrix(NA,ngen/con$sample+1,m+3,
+ dimnames=list(NULL,c("gen",names(th),"alpha","logLik")))
+ else if(model=="lambda") matrix(NA,ngen/con$sample+1,m+3,
+ dimnames=list(NULL,c("gen",names(th),"lambda","logLik")))
+
+ C<-matrix(NA,ngen/con$sample+1,tree$Nnode+n,dimnames=list(NULL,
+ c(tree$tip.label,1:tree$Nnode+n)))
+ A[1,]<-threshState(a,thresholds=th)
+ B[1,]<-if(model=="BM") c(0,th,lik1) else
+ if(model=="OU") c(0,th,alpha,lik1) else
+ if(model=="lambda") c(0,th,lambda,lik1)
+ C[1,]<-c(l[tree$tip.label],a[as.character(1:tree$Nnode+n)])
+
+ # run MCMC
+ message("MCMC starting....")
+ logL<-lik1<-likLiab(l,a,V,invV,detV)+log(probMatch(X,l,th,seq))
+ for(i in 1:ngen){
+ lik1<-logL
+ d<-i%%npar
+ if(ngen>=1000) if(i%%1000==0) if(con$print) message(paste("gen",i))
+ ap<-a; lp<-l; thp<-th
+ if(model=="OU") alphap<-alpha
+ if(model=="lambda") lambdap<-lambda
+ Vp<-V; invVp<-invV; detVp<-detV
+ if(d<=tree$Nnode&&d!=0){
+ # update node liabilities
+ ind<-d%%tree$Nnode; if(ind==0) ind<-tree$Nnode
+ ap[ind]<-a[ind]+rnorm(n=1,sd=sqrt(con$propliab))
+ } else {
+ if((d>tree$Nnode&&d<=(tree$Nnode+n))||(npar==(tree$Nnode+n)&&d==0)){
+ # update tip liabilities
+ if(d==0) ind<-n
+ else { ind<-(d-tree$Nnode)%%n; if(ind==0) ind<-n }
+ lp[ind]<-l[ind]+rnorm(n=1,sd=sqrt(con$propliab))
+ } else if(d>(tree$Nnode+n)&&d<=(tree$Nnode+n+m-2)||(npar==(tree$Nnode+n+m-2)&&d==0)) {
+ # update thresholds
+ if(d) ind<-(d-tree$Nnode-n)%%m+1
+ else ind<-m-1
+ thp[ind]<-bounce(th[ind],rnorm(n=1,sd=sqrt(con$propthresh)),c(th[ind-1],th[ind+1]))
+ } else {
+ if(model=="OU"){
+ alphap<-bounce(alpha,rnorm(n=1,sd=sqrt(con$propalpha)),c(0,Inf))
+ Vp<-vcvPhylo(tree,model="OU",alpha=alphap)
+ } else if(model=="lambda"){
+ lambdap<-bounce(lambda,rnorm(n=1,sd=sqrt(con$proplambda)),c(0,1))
+ Vp<-vcvPhylo(tree,model="lambda",lambda=lambdap)
+ }
+ invVp<-solve(Vp)
+ detVp<-determinant(Vp,logarithm=TRUE)$modulus[1]
+ }
+ }
+ lik2<-likLiab(lp,ap,Vp,invVp,detVp)+log(probMatch(X,lp,thp,seq))
+ p.odds<-min(c(1,exp(lik2+logPrior(threshState(ap,thresholds=thp),thp,con)-
+ lik1-logPrior(threshState(a,thresholds=th),th,con))))
+
+ if(p.odds>runif(n=1)){
+ a<-ap; l<-lp; th<-thp
+ V<-Vp; detV<-detVp; invV<-invVp
+ if(model=="OU") alpha<-alphap
+ if(model=="lambda") lambda<-lambdap
+ logL<-lik2
+ } else logL<-lik1
+ if(i%%con$sample==0){
+ A[i/con$sample+1,]<-threshState(a,thresholds=th)
+ B[i/con$sample+1,]<-if(model=="BM") c(i,th[colnames(B)[1+1:m]],logL) else
+ if(model=="OU") c(i,th[colnames(B)[1+1:m]],alpha,logL) else
+ if(model=="lambda") c(i,th[colnames(B)[1+1:m]],lambda,logL)
+ C[i/con$sample+1,]<-c(l[tree$tip.label],a[as.character(1:tree$Nnode+n)])
+ }
+ }
+ mcmc<-as.data.frame(A)
+ param<-as.data.frame(B)
+ liab<-as.data.frame(C)
+ ace<-matrix(0,tree$Nnode,m,dimnames=list(colnames(A),seq))
+ burnin<-which(param[,"gen"]==con$burnin)
+ for(i in 1:tree$Nnode){
+ mcmc[[i]]<-as.factor(mcmc[[i]])
+ temp<-summary(mcmc[burnin:nrow(mcmc),i])/(nrow(mcmc)-burnin+1)
+ ace[i,names(temp)]<-temp
+ }
+ obj<-list(ace=ace,mcmc=mcmc,par=param,liab=liab,
+ tree=tree,x=x,model=model,
+ seq=seq,
+ ngen=ngen,sample=con$sample,
+ burnin=con$burnin)
+ class(obj)<-"ancThresh"
+ if(con$plot) plot(obj)
+ obj
+}
+
+## some S3 methods (added in 2017)
+
+print.ancThresh<-function(x,...){
+ cat("\nObject containing the results from an MCMC analysis\n")
+ cat("of the threshold model using ancThresh.\n\n")
+ cat("List with the following components:\n")
+ cat(paste("ace:\tmatrix with posterior probabilities assuming",x$burnin,
+ "\n\tburn-in generations.\n"))
+ cat("mcmc:\tposterior sample of liabilities at tips & internal\n")
+ cat(paste("\tnodes (a matrix with",nrow(x$mcmc),"rows &",ncol(x$mcmc),
+ "columns).\n"))
+ cat("par:\tposterior sample of the relative positions of the\n")
+ cat(paste("\tthresholds, the log-likelihoods, and any other\n",
+ "\tmodel variables (a matrix with",nrow(x$par),"rows).\n\n"))
+ cat("The MCMC was run under the following conditions:\n")
+ cat(paste("\tseq =",paste(x$seq,collapse=" <-> "),
+ "\n\tmodel =",x$model,"\n\tnumber of generations =",x$ngen,
+ "\n\tsample interval=",x$sample,
+ "\n\tburn-in =",x$burnin,"\n\n"))
+}
+
+plot.ancThresh<-function(x,...){
+ if(hasArg(burnin)) burnin<-list(...)$burnin
+ else burnin<-x$burnin
+ args<-list(...)
+ if(is.null(args$lwd)) args$lwd<-1
+ if(is.null(args$type)) args$type<-"phylogram"
+ if(is.null(args$ylim))
+ if(args$type=="phylogram")
+ args$ylim<-c(-0.1*Ntip(x$tree),Ntip(x$tree))
+ if(is.null(args$offset)) args$offset<-0.5
+ if(is.null(args$ftype)) args$ftype="i"
+ args$tree<-x$tree
+ do.call(plotTree,args)
+ ii<-which(x$par[,1]==burnin)+1
+ LIAB<-as.matrix(x$liab)[ii:nrow(x$liab),]
+ THRESH<-as.matrix(x$par)[ii:nrow(x$par),1:length(x$seq)+1]
+ STATES<-matrix(NA,nrow(LIAB),ncol(LIAB),dimnames=dimnames(LIAB))
+ for(i in 1:nrow(LIAB)) STATES[i,]<-threshState(LIAB[i,],THRESH[i,])
+ PP<-t(apply(STATES,2,function(x,levs)
+ summary(factor(x,levels=levs))/length(x),levs=x$seq))
+ if(hasArg(piecol)) piecol<-list(...)$piecol
+ else piecol<-setNames(colorRampPalette(c("blue",
+ "yellow"))(length(x$seq)),x$seq)
+ if(hasArg(node.cex)) node.cex<-list(...)$node.cex
+ else node.cex<-0.6
+ nodelabels(pie=PP[1:x$tree$Nnode+Ntip(x$tree),],
+ piecol=piecol,cex=node.cex)
+ if(hasArg(tip.cex)) tip.cex<-list(...)$tip.cex
+ else tip.cex<-0.4
+ tiplabels(pie=PP[x$tree$tip.label,],piecol=piecol,
+ cex=tip.cex)
+ legend(x="bottomleft",legend=x$seq,pch=21,pt.bg=piecol,
+ pt.cex=2.2,bty="n")
+ invisible(PP)
+}
+
+# plots ancestral states from the threshold model
+# written by Liam J. Revell 2012, 2014
+
+plotThresh<-function(tree,x,mcmc,burnin=NULL,piecol,tipcol="input",legend=TRUE,...){
+
+ if(is.logical(legend)||is.vector(legend)){
+ if(is.logical(legend)&&legend==TRUE) leg<-setNames(names(piecol),names(piecol))
+ else if(is.vector(legend)){
+ leg<-legend[names(piecol)]
+ legend<-TRUE
+ }
+ }
+
+ # plot tree
+ par(lend=2)
+ plotTree(tree,ftype="i",lwd=1,ylim=if(legend) c(-0.1*length(tree$tip.label),
+ length(tree$tip.label)) else NULL,...)
+ if(legend){
+ zz<-par()$cex; par(cex=0.6)
+ for(i in 1:length(piecol))
+ add.simmap.legend(leg=leg[i],colors=piecol[i],prompt=FALSE,
+ x=0.02*max(nodeHeights(tree)),y=-0.1*length(tree$tip.label),vertical=FALSE,
+ shape="square",fsize=1)
+ par(cex=zz)
+ }
+ # pull matrices from mcmc
+ ace<-mcmc$ace
+ liab<-mcmc$liab
+ param<-mcmc$par
+
+ # get burnin
+ if(is.null(burnin)) burnin<-round(0.2*max(param[,"gen"]))
+ burnin<-which(param[,"gen"]==burnin)
+
+ # check x
+ if(is.data.frame(x)) x<-as.matrix(x)
+ if(is.matrix(x)) X<-x[tree$tip.label,]
+ else if(is.vector(x)){
+ x<-x[tree$tip.label]
+ X<-to.matrix(x,names(piecol))
+ }
+ # row scale X
+ X/apply(X,1,sum)->X
+
+ # plot node labels
+ nodelabels(pie=ace,piecol=piecol[colnames(ace)],cex=0.6)
+
+ # plot tip labels
+ if(tipcol=="input") tiplabels(pie=X,piecol=piecol[colnames(X)],cex=0.6)
+ else if(tipcol=="estimated") {
+ XX<-matrix(NA,nrow(liab),length(tree$tip),dimnames=list(rownames(liab),
+ colnames(liab)[1:length(tree$tip)]))
+ for(i in 1:nrow(liab)) XX[i,]<-threshState(liab[i,1:length(tree$tip)],
+ thresholds=param[i,1:ncol(X)+1])
+ X<-t(apply(XX,2,function(x) summary(factor(x,levels=colnames(X)))))
+ tiplabels(pie=X/rowSums(X),piecol=piecol[colnames(X)],cex=0.6)
+ }
+}
+
+# computes DIC for threshold model
+# written by Liam J. Revell 2012, 2014
+
+threshDIC<-function(tree,x,mcmc,burnin=NULL,sequence=NULL,method="pD"){
+ ## identify model
+ if(any(colnames(mcmc$par)=="alpha")) model<-"OU"
+ else if(any(colnames(mcmc$par)=="lambda")) model<-"lambda"
+ else model<-"BM"
+ # check x
+ if(is.data.frame(x)) x<-as.matrix(x)
+ if(is.matrix(x)){
+ X<-x[tree$tip.label,]
+ if(is.null(sequence)){
+ message("**** NOTE: no sequence provided, column order in x")
+ seq<-colnames(X)
+ } else seq<-sequence
+ } else if(is.vector(x)){
+ x<-x[tree$tip.label]
+ if(is.null(sequence)){
+ message("**** NOTE: no sequence provided, using alphabetical or numerical order")
+ seq<-sort(levels(as.factor(x)))
+ } else seq<-sequence
+ X<-to.matrix(x,seq)
+ }
+ # row scale X
+ X<-X/apply(X,1,sum)
+ X<-X[,seq] # order columns by seq
+ # convert burnin to starting row
+ if(is.null(burnin)) burnin<-0.2*max(mcmc$par[,"gen"])
+ start<-which(mcmc$par[,"gen"]==burnin)+1
+ # compute
+ k<-if(model=="BM") 1 else 2
+ thBar<-colMeans(mcmc$par[start:nrow(mcmc$par),2:(ncol(mcmc$par)-k)])
+ liabBar<-colMeans(mcmc$liab[start:nrow(mcmc$liab),])
+ if(model=="BM") V<-vcvPhylo(tree)
+ else if(model=="OU") V<-vcvPhylo(tree,model="OU",
+ alpha=mean(mcmc$par[start:nrow(mcmc$par),"alpha"]))
+ else if(model=="lambda") V<-vcvPhylo(tree,model="lambda",
+ lambda=mean(mcmc$par[start:nrow(mcmc$par),"lambda"]))
+ Dtheta<--2*(likLiab(liabBar[tree$tip.label],
+ liabBar[as.character(1:tree$Nnode+length(tree$tip))],V,solve(V),
+ determinant(V,logarithm=TRUE)$modulus[1])+log(probMatch(X[tree$tip.label,],
+ liabBar[tree$tip.label],thBar,seq)))
+ D<--2*mcmc$par[start:nrow(mcmc$par),"logLik"]
+ Dbar<-mean(D)
+ if(method=="pD"){
+ pD<-Dbar-Dtheta
+ DIC<-pD+Dbar
+ result<-setNames(c(Dbar,Dtheta,pD,DIC),c("Dbar","Dhat","pD","DIC"))
+ } else if(method=="pV"){
+ pV<-var(D)/2
+ DIC<-pV+Dbar
+ result<-setNames(c(Dbar,Dtheta,pV,DIC),c("Dbar","Dhat","pV","DIC"))
+ }
+ return(result)
+}
+
+# internal functions for ancThresh, plotThresh, and threshDIC
+
+## returns a state based on position relative to thresholds
+## threshStateC is a function from phangorn>=2.3.1
+threshState<-if(packageVersion("phangorn")>='2.3.1'){
+ function(x,thresholds){
+ res <- names(thresholds)[threshStateC(x, thresholds)]
+ names(res) <- names(x)
+ res
+ }
+} else function(x,thresholds){
+ t<-c(-Inf,thresholds,Inf)
+ names(t)[length(t)]<-names(t)[length(t)-1]
+ i<-1
+ while(x>t[i]) i<-i+1
+ names(t)[i]
+}
+
+# likelihood function for the liabilities
+likLiab<-function(l,a,V,invV,detV){
+ y<-c(l,a[2:length(a)])-a[1]
+ logL<--y%*%invV%*%y/2-nrow(V)*log(2*pi)/2-detV/2
+ return(logL)
+}
+
+# function for the log-prior
+logPrior<-function(a,t,control){
+# pp<-sum(log(diag(control$pr.anc[names(a),a])))+
+ pp<-sum(log(control$pr.anc[cbind(names(a),a)])) +
+ if(length(t)>2) sum(dexp(t[2:(length(t)-1)],rate=control$pr.th,log=TRUE)) else 0
+ return(pp)
+}
+
+# check if the liability predictions match observed data
+allMatch<-function(x,l,thresholds){
+ result<-all(threshState(l,thresholds=thresholds)==x)
+ if(!is.na(result)) return(result)
+ else return(FALSE)
+}
+
+# check if the liability predictions match observed data & return a probability
+# (this allows states to be uncertain)
+probMatch<-function(X,l,thresholds,sequence){
+ Y<-to.matrix(threshState(l,thresholds=thresholds),sequence)
+ return(prod(rowSums(X*Y)))
+}
+
+# bounds parameter by bouncing
+bounce<-function(start,step,bounds){
+ x<-start+step
+ while(x>bounds[2]||x<bounds[1]){
+ if(x>bounds[2]) x<-2*bounds[2]-x
+ if(x<bounds[1]) x<-2*bounds[1]-x
+ }
+ return(x)
+}
+
+# convert vector of x to binary matrix
+to.matrix<-function(x,seq){
+ X<-matrix(0,length(x),length(seq),dimnames=list(names(x),seq))
+ for(i in 1:length(seq)) X[x==seq[i],i]<-1
+ return(X)
+}
+
+# convert binary matrix to vector
+to.vector<-function(X) apply(X,1,rstate)
diff --git a/R/backbonePhylo.R b/R/backbonePhylo.R
index d9695e1..80f07bf 100644
--- a/R/backbonePhylo.R
+++ b/R/backbonePhylo.R
@@ -1,294 +1,294 @@
-## function to manipulate & plot objects of class "backbonePhylo"
-## written by Liam J. Revell 2013, 2016
-
-backbone.toTrans<-function(obj){
- tip.label<-obj$tip.label
- clade.label<-sapply(obj$tip.clade,function(x) x$label)
- N<-sapply(obj$tip.clade,function(x) x$N)
- depth<-sapply(obj$tip.clade,function(x) x$depth)
- data.frame(tip.label,clade.label,N,depth)
-}
-
-## convert "phylo" to "backbonePhylo"
-phylo.toBackbone<-function(x,trans=NULL,...){
- if(!inherits(x,"phylo"))
- stop("tree should be an object of class \"phylo\".")
- if(hasArg(interactive)) interactive<-list(...)$interactive
- else interactive<-is.null(trans)
- if(hasArg(height)) height<-list(...)$height
- else height<-"mean"
- if(interactive){
- options(locatorBell=FALSE)
- if(is.null(x$node.label)) x$node.label<-as.character(1:x$Nnode+Ntip(x))
- if(inherits(x,"backbonePhylo")) plot(x,...) else plotTree(x,...)
- cat(" Select clade to collapse.\n")
- flush.console()
- check<-textbox(x=c(par()$usr[1],par()$usr[1]+
- 0.1*(par()$usr[2]-par()$usr[1])),
- y=par()$usr[4],c("click to stop"),justify="c")
- xy<-unlist(locator(1))
- while(!(xy[1]>par()$usr[1]&&xy[1]<par()$usr[1]+0.1*(par()$usr[2]-
- par()$usr[1])&&xy[2]>check&&xy[2]<par()$usr[4])){
- obj<-get.treepos(message=FALSE,x=xy[1],y=xy[2])
- cat(" Enter name of clade (or press ENTER). > ")
- flush.console()
- clab<-readLines(n=1)
- if(obj$where<=Ntip(x)){
- if(clab=="") clab<-x$tip.label[obj$where]
- tlab<-x$tip.label[obj$where]
- depth<-obj$pos
- N<-if(inherits(x,"backbonePhylo"))
- x$tip.clade[[obj$where]]$N else 1
- if(!inherits(x,"backbonePhylo")){
- trans<-data.frame(tip.label=as.character(tlab),
- clade.label=as.character(clab),N=N,depth=depth)
- x<-phylo.toBackbone(x,trans)
- } else {
- x$tip.clade[[obj$where]]<-list(label=as.character(clab),
- N=N,depth=depth,
- id=paste(sample(c(letters,LETTERS,0:9),6,replace=TRUE),
- collapse=""))
- x$tip.label[obj$where]<-x$tip.clade[[obj$where]]$id
- }
- } else {
- if(clab=="") clab<-x$node.label[obj$where-Ntip(x)]
- tlab<-x$node.label[obj$where-Ntip(x)]
- split<-list(node=obj$where,
- bp=x$edge.length[which(x$edge[,2]==obj$where)]-obj$pos)
- tip.clade<-if(!is.null(x$tip.clade)) x$tip.clade else NULL
- aclass<-class(x)
- tmp<-splitTree(x,split)
- tip<-which(tmp[[1]]$tip.label=="NA")
- if(height=="mean") depth<-obj$pos+
- mean(sapply(1:Ntip(tmp[[2]]),nodeheight,tree=tmp[[2]]))
- else if(height=="max") depth<-obj$pos+
- max(sapply(1:Ntip(tmp[[2]]),nodeheight,tree=tmp[[2]]))
- else if(height=="min") depth<-obj$pos+
- min(sapply(1:Ntip(tmp[[2]]),nodeheight,tree=tmp[[2]]))
- tmp[[1]]$edge.length[which(tmp[[1]]$edge[,2]==tip)]<-
- tmp[[1]]$edge.length[which(tmp[[1]]$edge[,2]==tip)]+depth
- if(inherits(x,"backbonePhylo")){
- dd<-getDescendants(x,obj$where)
- N<-sum(sapply(x$tip.clade[dd[dd<=Ntip(x)]],function(x) x$N))
- } else {
- dd<-getDescendants(x,obj$where)
- N<-sum(dd<=Ntip(x))
- }
- x<-tmp[[1]]
- x$tip.label[tip]<-tlab
- trans<-data.frame(tip.label=as.character(tlab),
- clade.label=as.character(clab),N=N,depth=depth)
- x<-phylo.toBackbone(x,trans)
- }
- if(inherits(x,"backbonePhylo")) plot(x,...) else plotTree(x,...)
- cat("\n Select clade to collapse (or STOP).\n")
- flush.console()
- check<-textbox(x=c(par()$usr[1],par()$usr[1]+
- 0.1*(par()$usr[2]-par()$usr[1])),
- y=par()$usr[4],c("click to stop"),justify="c")
- xy<-unlist(locator(1))
- }
- } else {
- if(!inherits(x,"backbonePhylo")){
- x$tip.clade<-list()
- for(i in 1:length(x$tip.label)){
- if(x$tip.label[i]%in%trans$tip.label){
- ii<-which(trans$tip.label==x$tip.label[i])
- x$tip.clade[[i]]<-list()
- x$tip.clade[[i]]$label<-as.character(trans$clade.label[ii])
- x$tip.clade[[i]]$N<-trans$N[ii]
- x$tip.clade[[i]]$depth<-trans$depth[ii]
- } else {
- x$tip.clade[[i]]<-list()
- x$tip.clade[[i]]$label<-as.character(x$tip.label[i])
- x$tip.clade[[i]]$N<-1
- x$tip.clade[[i]]$depth<-x$edge.length[which(x$edge[,2]==i)]
- }
- x$tip.clade[[i]]$id<-paste(sample(c(letters,LETTERS,0:9),6,
- replace=TRUE),collapse="")
- }
- x$tip.label<-sapply(x$tip.clade,function(y) y$id)
- class(x)<-c("backbonePhylo","phylo")
- } else {
- for(i in 1:nrow(trans)){
- ii<-which(x$tip.label==trans$tip.label[i])
- tmp<-as.character(trans$clade.label[i])
- x$tip.clade[[length(x$tip.clade)+1]]<-
- list(label=tmp,N=trans$N[i],depth=trans$depth[i],
- id=paste(sample(c(letters,LETTERS,0:9),6,replace=TRUE),
- collapse=""))
- x$tip.label[ii]<-x$tip.clade[[length(x$tip.clade)]]$id
- clade.id<-sapply(x$tip.clade,function(y) y$id)
- ii<-sapply(clade.id,function(x,y) if(x%in%y) which(y==x) else -1,
- y=x$tip.label)
- x$tip.clade<-x$tip.clade[ii>0]
- x$tip.clade<-x$tip.clade[ii[ii>0]]
- }
- }
- }
- x
-}
-
-## convert to object of class "phylo"
-backbone.toPhylo<-function(x){
- if(!inherits(x,"backbonePhylo"))
- stop("x not an object of class \"backbonePhylo\"")
- x$tip.label<-sapply(x$tip.clade,function(x) x$label)
- x$tip.clade<-NULL
- class(x)<-"phylo"
- x
-}
-
-## reorder backbone phylogeny
-reorder.backbonePhylo<-function(x,order="cladewise",...){
- ii<-reorder(backbone.toPhylo(x),order,index.only=TRUE)
- x$edge<-x$edge[ii,]
- x$edge.length<-x$edge.length[ii]
- attr(x,"order")<-order
- x
-}
-
-## print method
-print.backbonePhylo<-function(x,...){
- cat(paste("\nBackbone phylogenetic tree with",length(x$tip.clade),
- "subtrees and",x$Nnode,"resolved internal nodes.\n"))
- n<-min(length(x$tip.clade),5)
- cat("\nLabels: ")
- cat(paste(sapply(x$tip.clade[1:n],function(y) y$label),collapse=", "))
- cat(", ...\nDiversities: ")
- cat(paste(sapply(x$tip.clade[1:n],function(y) y$N),collapse=", "))
- cat(", ...\n\n")
-}
-
-## scale N
-scaleN<-function(x,k){
- for(i in 1:length(x$tip.clade)) if(x$tip.clade[[i]]$N>1)
- x$tip.clade[[i]]$N<-x$tip.clade[[i]]$N*k
- x
-}
-
-## plot backbone phylogeny with triangles
-plot.backbonePhylo<-function(x,...){
- if(!inherits(x,"backbonePhylo"))
- stop("x not an object of class \"backbonePhylo\"")
- if(hasArg(vscale)) vscale<-list(...)$vscale
- else vscale<-1
- if(hasArg(col)) col<-list(...)$col
- else col<-"grey"
- if(length(col)!=Ntip(x)){
- if(!is.null(names(col))){
- tmp<-setNames(rep("grey",Ntip(x)),sapply(x$tip.clade,function(x) x$label))
- for(i in 1:length(col)) tmp[which(names(tmp)==names(col)[i])]<-col[i]
- col<-tmp
- } else col<-setNames(rep(col[1],Ntip(x)),sapply(x$tip.clade,
- function(x) x$label))
- }
- if(is.null(names(col))) names(col)<-sapply(x$tip.clade,
- function(x) x$label)
- col<-col[sapply(x$tip.clade,function(x) x$label)]
- names(col)<-sapply(x$tip.clade,function(x) x$id)
- if(hasArg(lwd)) lwd<-list(...)$lwd
- else lwd<-2
- if(hasArg(sep)) sep<-list(...)$sep
- else sep<-1
- if(hasArg(fixed.height)) fixed.height<-list(...)$fixed.height
- else fixed.height<-FALSE
- if(hasArg(print.clade.size))
- print.clade.size<-list(...)$print.clade.size
- else print.clade.size<-FALSE
- if(hasArg(fixed.n1)) fixed.n1<-list(...)$fixed.n1
- else fixed.n1<-FALSE
- if(hasArg(xlim)) xlim<-list(...)$xlim
- else xlim<-NULL
- if(hasArg(ylim)) ylim<-list(...)$ylim
- else ylim<-NULL
- if(hasArg(cex)) cex<-list(...)$cex
- else cex<-par("cex")
- if(fixed.height||print.clade.size){
- obj<-x
- for(i in 1:Ntip(obj)){
- if(print.clade.size){
- obj$tip.clade[[i]]$label<-if(x$tip.clade[[i]]$N>1||fixed.n1)
- paste(x$tip.clade[[i]]$label," (n=",
- x$tip.clade[[i]]$N,")",sep="")
- else x$tip.clade[[i]]$label
- ii<-which(names(col)==x$tip.clade[[i]]$label)
- names(col)[ii]<-obj$tip.clade[[i]]$label
- }
- if(fixed.height)
- obj$tip.clade[[i]]$N<-if(x$tip.clade[[i]]$N>1||fixed.n1)
- sum(sapply(x$tip.clade,function(y) y$N))/Ntip(x)
- else 1
- }
- x<-obj
- }
- x<-scaleN(x,vscale)
- tt<-backbone.toPhylo(x)
- n<-sum(sapply(x$tip.clade,function(x) x$N))
- cw<-reorder.backbonePhylo(x,"cladewise")
- y<-vector(length=length(cw$tip.clade)+cw$Nnode)
- ii<-order(cw$edge[,2][cw$edge[,2]<=Ntip(cw)])
- z<-c(0,cumsum(sapply(cw$tip.clade[order(ii)],function(x) x$N)))
- nn<-sapply(2:length(z),function(i,x) (x[i]-x[i-1])/2+x[i-1],x=z)
- y[cw$edge[cw$edge[,2]<=length(cw$tip.clade),2]]<-nn[1:length(cw$tip.clade)]
- pw<-reorder.backbonePhylo(x,"pruningwise")
- nn<-unique(pw$edge[,1])
- for(i in 1:length(nn)){
- yy<-y[pw$edge[which(pw$edge[,1]==nn[i]),2]]
- y[nn[i]]<-mean(range(yy))
- }
- # compute start & end points of each edge
- X<-nodeHeights(tt)
- # open & size a new plot
- plot.new()
- par(mar=rep(0.1,4))
- pp<-par("pin")[1]
- sw<-cex*(max(strwidth(sapply(cw$tip.clade,function(x) x$label),
- units="inches")))+1.37*cex*strwidth("W",units="inches")
- alp<-optimize(function(a,H,sw,pp) (a*1.04*max(H)+sw-pp)^2,H=X,sw=sw,pp=pp,
- interval=c(0,1e6))$minimum
- if(is.null(xlim)) xlim<-c(min(X),max(X)+sw/alp)
- if(is.null(ylim)) ylim<-c(0,n)
- plot.window(xlim=xlim,ylim=ylim)
- # plot horizontal edges
- for(i in 1:nrow(X)){
- if(cw$edge[i,2]>length(cw$tip.clade)) lines(X[i,],rep(y[cw$edge[i,2]],2),
- lwd=lwd,lend=2)
- else lines(c(X[i,1],X[i,2]-cw$tip.clade[[cw$edge[i,2]]]$depth),
- rep(y[cw$edge[i,2]],2),lwd=lwd,lend=2)
- }
- # plot vertical relationships
- for(i in 1:x$Nnode+length(x$tip.clade)) lines(X[which(cw$edge[,1]==i),1],
- range(y[cw$edge[which(cw$edge[,1]==i),2]]),lwd=lwd,lend=2)
- for(i in 1:length(x$tip.clade)){
- if(x$tip.clade[[i]]$N==1){
- tmp<-sep
- sep<-1
- } else tmp<-sep
- xx<-c(X[which(cw$edge[,2]==i),2]-cw$tip.clade[[i]]$depth,
- X[which(cw$edge[,2]==i),2],X[which(cw$edge[,2]==i),2])
- yy<-c(y[cw$edge[which(cw$edge[,2]==i),2]],
- y[cw$edge[which(cw$edge[,2]==i),2]]+cw$tip.clade[[i]]$N/2-
- sep/2,y[cw$edge[which(cw$edge[,2]==i),2]]-
- cw$tip.clade[[i]]$N/2+sep/2)
- if(yy[2]<yy[3]) yy[2]<-yy[3]<-yy[1]
- polygon(x=xx,y=yy,col=col[cw$tip.clade[[i]]$id],lwd=lwd)
- sep<-tmp
- }
- for(i in 1:length(cw$tip.clade))
- text(X[which(cw$edge[,2]==i),2],y[i],cw$tip.clade[[i]]$label,pos=4,
- offset=0.1,cex=cex)
- PP<-list(type="phylogram",use.edge.length=TRUE,node.pos=1,
- show.tip.label=TRUE,show.node.label=FALSE,
- font=1,cex=cex,adj=0,srt=0,no.margin=FALSE,label.offset=0.1,
- x.lim=par()$usr[1:2],y.lim=par()$usr[3:4],
- direction="rightwards",tip.color="black",Ntip=Ntip(cw),Nnode=cw$Nnode,
- edge=cw$edge,xx=sapply(1:(Ntip(cw)+cw$Nnode),
- function(x,y,z) y[match(x,z)],y=X,z=cw$edge),yy=y)
- assign("last_plot.phylo",PP,envir=.PlotPhyloEnv)
-}
-
-
-
-
-
+## function to manipulate & plot objects of class "backbonePhylo"
+## written by Liam J. Revell 2013, 2016
+
+backbone.toTrans<-function(obj){
+ tip.label<-obj$tip.label
+ clade.label<-sapply(obj$tip.clade,function(x) x$label)
+ N<-sapply(obj$tip.clade,function(x) x$N)
+ depth<-sapply(obj$tip.clade,function(x) x$depth)
+ data.frame(tip.label,clade.label,N,depth)
+}
+
+## convert "phylo" to "backbonePhylo"
+phylo.toBackbone<-function(x,trans=NULL,...){
+ if(!inherits(x,"phylo"))
+ stop("tree should be an object of class \"phylo\".")
+ if(hasArg(interactive)) interactive<-list(...)$interactive
+ else interactive<-is.null(trans)
+ if(hasArg(height)) height<-list(...)$height
+ else height<-"mean"
+ if(interactive){
+ options(locatorBell=FALSE)
+ if(is.null(x$node.label)) x$node.label<-as.character(1:x$Nnode+Ntip(x))
+ if(inherits(x,"backbonePhylo")) plot(x,...) else plotTree(x,...)
+ cat(" Select clade to collapse.\n")
+ flush.console()
+ check<-textbox(x=c(par()$usr[1],par()$usr[1]+
+ 0.1*(par()$usr[2]-par()$usr[1])),
+ y=par()$usr[4],c("click to stop"),justify="c")
+ xy<-unlist(locator(1))
+ while(!(xy[1]>par()$usr[1]&&xy[1]<par()$usr[1]+0.1*(par()$usr[2]-
+ par()$usr[1])&&xy[2]>check&&xy[2]<par()$usr[4])){
+ obj<-get.treepos(message=FALSE,x=xy[1],y=xy[2])
+ cat(" Enter name of clade (or press ENTER). > ")
+ flush.console()
+ clab<-readLines(n=1)
+ if(obj$where<=Ntip(x)){
+ if(clab=="") clab<-x$tip.label[obj$where]
+ tlab<-x$tip.label[obj$where]
+ depth<-obj$pos
+ N<-if(inherits(x,"backbonePhylo"))
+ x$tip.clade[[obj$where]]$N else 1
+ if(!inherits(x,"backbonePhylo")){
+ trans<-data.frame(tip.label=as.character(tlab),
+ clade.label=as.character(clab),N=N,depth=depth)
+ x<-phylo.toBackbone(x,trans)
+ } else {
+ x$tip.clade[[obj$where]]<-list(label=as.character(clab),
+ N=N,depth=depth,
+ id=paste(sample(c(letters,LETTERS,0:9),6,replace=TRUE),
+ collapse=""))
+ x$tip.label[obj$where]<-x$tip.clade[[obj$where]]$id
+ }
+ } else {
+ if(clab=="") clab<-x$node.label[obj$where-Ntip(x)]
+ tlab<-x$node.label[obj$where-Ntip(x)]
+ split<-list(node=obj$where,
+ bp=x$edge.length[which(x$edge[,2]==obj$where)]-obj$pos)
+ tip.clade<-if(!is.null(x$tip.clade)) x$tip.clade else NULL
+ aclass<-class(x)
+ tmp<-splitTree(x,split)
+ tip<-which(tmp[[1]]$tip.label=="NA")
+ if(height=="mean") depth<-obj$pos+
+ mean(sapply(1:Ntip(tmp[[2]]),nodeheight,tree=tmp[[2]]))
+ else if(height=="max") depth<-obj$pos+
+ max(sapply(1:Ntip(tmp[[2]]),nodeheight,tree=tmp[[2]]))
+ else if(height=="min") depth<-obj$pos+
+ min(sapply(1:Ntip(tmp[[2]]),nodeheight,tree=tmp[[2]]))
+ tmp[[1]]$edge.length[which(tmp[[1]]$edge[,2]==tip)]<-
+ tmp[[1]]$edge.length[which(tmp[[1]]$edge[,2]==tip)]+depth
+ if(inherits(x,"backbonePhylo")){
+ dd<-getDescendants(x,obj$where)
+ N<-sum(sapply(x$tip.clade[dd[dd<=Ntip(x)]],function(x) x$N))
+ } else {
+ dd<-getDescendants(x,obj$where)
+ N<-sum(dd<=Ntip(x))
+ }
+ x<-tmp[[1]]
+ x$tip.label[tip]<-tlab
+ trans<-data.frame(tip.label=as.character(tlab),
+ clade.label=as.character(clab),N=N,depth=depth)
+ x<-phylo.toBackbone(x,trans)
+ }
+ if(inherits(x,"backbonePhylo")) plot(x,...) else plotTree(x,...)
+ cat("\n Select clade to collapse (or STOP).\n")
+ flush.console()
+ check<-textbox(x=c(par()$usr[1],par()$usr[1]+
+ 0.1*(par()$usr[2]-par()$usr[1])),
+ y=par()$usr[4],c("click to stop"),justify="c")
+ xy<-unlist(locator(1))
+ }
+ } else {
+ if(!inherits(x,"backbonePhylo")){
+ x$tip.clade<-list()
+ for(i in 1:length(x$tip.label)){
+ if(x$tip.label[i]%in%trans$tip.label){
+ ii<-which(trans$tip.label==x$tip.label[i])
+ x$tip.clade[[i]]<-list()
+ x$tip.clade[[i]]$label<-as.character(trans$clade.label[ii])
+ x$tip.clade[[i]]$N<-trans$N[ii]
+ x$tip.clade[[i]]$depth<-trans$depth[ii]
+ } else {
+ x$tip.clade[[i]]<-list()
+ x$tip.clade[[i]]$label<-as.character(x$tip.label[i])
+ x$tip.clade[[i]]$N<-1
+ x$tip.clade[[i]]$depth<-x$edge.length[which(x$edge[,2]==i)]
+ }
+ x$tip.clade[[i]]$id<-paste(sample(c(letters,LETTERS,0:9),6,
+ replace=TRUE),collapse="")
+ }
+ x$tip.label<-sapply(x$tip.clade,function(y) y$id)
+ class(x)<-c("backbonePhylo","phylo")
+ } else {
+ for(i in 1:nrow(trans)){
+ ii<-which(x$tip.label==trans$tip.label[i])
+ tmp<-as.character(trans$clade.label[i])
+ x$tip.clade[[length(x$tip.clade)+1]]<-
+ list(label=tmp,N=trans$N[i],depth=trans$depth[i],
+ id=paste(sample(c(letters,LETTERS,0:9),6,replace=TRUE),
+ collapse=""))
+ x$tip.label[ii]<-x$tip.clade[[length(x$tip.clade)]]$id
+ clade.id<-sapply(x$tip.clade,function(y) y$id)
+ ii<-sapply(clade.id,function(x,y) if(x%in%y) which(y==x) else -1,
+ y=x$tip.label)
+ x$tip.clade<-x$tip.clade[ii>0]
+ x$tip.clade<-x$tip.clade[ii[ii>0]]
+ }
+ }
+ }
+ x
+}
+
+## convert to object of class "phylo"
+backbone.toPhylo<-function(x){
+ if(!inherits(x,"backbonePhylo"))
+ stop("x not an object of class \"backbonePhylo\"")
+ x$tip.label<-sapply(x$tip.clade,function(x) x$label)
+ x$tip.clade<-NULL
+ class(x)<-"phylo"
+ x
+}
+
+## reorder backbone phylogeny
+reorder.backbonePhylo<-function(x,order="cladewise",...){
+ ii<-reorder(backbone.toPhylo(x),order,index.only=TRUE)
+ x$edge<-x$edge[ii,]
+ x$edge.length<-x$edge.length[ii]
+ attr(x,"order")<-order
+ x
+}
+
+## print method
+print.backbonePhylo<-function(x,...){
+ cat(paste("\nBackbone phylogenetic tree with",length(x$tip.clade),
+ "subtrees and",x$Nnode,"resolved internal nodes.\n"))
+ n<-min(length(x$tip.clade),5)
+ cat("\nLabels: ")
+ cat(paste(sapply(x$tip.clade[1:n],function(y) y$label),collapse=", "))
+ cat(", ...\nDiversities: ")
+ cat(paste(sapply(x$tip.clade[1:n],function(y) y$N),collapse=", "))
+ cat(", ...\n\n")
+}
+
+## scale N
+scaleN<-function(x,k){
+ for(i in 1:length(x$tip.clade)) if(x$tip.clade[[i]]$N>1)
+ x$tip.clade[[i]]$N<-x$tip.clade[[i]]$N*k
+ x
+}
+
+## plot backbone phylogeny with triangles
+plot.backbonePhylo<-function(x,...){
+ if(!inherits(x,"backbonePhylo"))
+ stop("x not an object of class \"backbonePhylo\"")
+ if(hasArg(vscale)) vscale<-list(...)$vscale
+ else vscale<-1
+ if(hasArg(col)) col<-list(...)$col
+ else col<-"grey"
+ if(length(col)!=Ntip(x)){
+ if(!is.null(names(col))){
+ tmp<-setNames(rep("grey",Ntip(x)),sapply(x$tip.clade,function(x) x$label))
+ for(i in 1:length(col)) tmp[which(names(tmp)==names(col)[i])]<-col[i]
+ col<-tmp
+ } else col<-setNames(rep(col[1],Ntip(x)),sapply(x$tip.clade,
+ function(x) x$label))
+ }
+ if(is.null(names(col))) names(col)<-sapply(x$tip.clade,
+ function(x) x$label)
+ col<-col[sapply(x$tip.clade,function(x) x$label)]
+ names(col)<-sapply(x$tip.clade,function(x) x$id)
+ if(hasArg(lwd)) lwd<-list(...)$lwd
+ else lwd<-2
+ if(hasArg(sep)) sep<-list(...)$sep
+ else sep<-1
+ if(hasArg(fixed.height)) fixed.height<-list(...)$fixed.height
+ else fixed.height<-FALSE
+ if(hasArg(print.clade.size))
+ print.clade.size<-list(...)$print.clade.size
+ else print.clade.size<-FALSE
+ if(hasArg(fixed.n1)) fixed.n1<-list(...)$fixed.n1
+ else fixed.n1<-FALSE
+ if(hasArg(xlim)) xlim<-list(...)$xlim
+ else xlim<-NULL
+ if(hasArg(ylim)) ylim<-list(...)$ylim
+ else ylim<-NULL
+ if(hasArg(cex)) cex<-list(...)$cex
+ else cex<-par("cex")
+ if(fixed.height||print.clade.size){
+ obj<-x
+ for(i in 1:Ntip(obj)){
+ if(print.clade.size){
+ obj$tip.clade[[i]]$label<-if(x$tip.clade[[i]]$N>1||fixed.n1)
+ paste(x$tip.clade[[i]]$label," (n=",
+ x$tip.clade[[i]]$N,")",sep="")
+ else x$tip.clade[[i]]$label
+ ii<-which(names(col)==x$tip.clade[[i]]$label)
+ names(col)[ii]<-obj$tip.clade[[i]]$label
+ }
+ if(fixed.height)
+ obj$tip.clade[[i]]$N<-if(x$tip.clade[[i]]$N>1||fixed.n1)
+ sum(sapply(x$tip.clade,function(y) y$N))/Ntip(x)
+ else 1
+ }
+ x<-obj
+ }
+ x<-scaleN(x,vscale)
+ tt<-backbone.toPhylo(x)
+ n<-sum(sapply(x$tip.clade,function(x) x$N))
+ cw<-reorder.backbonePhylo(x,"cladewise")
+ y<-vector(length=length(cw$tip.clade)+cw$Nnode)
+ ii<-order(cw$edge[,2][cw$edge[,2]<=Ntip(cw)])
+ z<-c(0,cumsum(sapply(cw$tip.clade[order(ii)],function(x) x$N)))
+ nn<-sapply(2:length(z),function(i,x) (x[i]-x[i-1])/2+x[i-1],x=z)
+ y[cw$edge[cw$edge[,2]<=length(cw$tip.clade),2]]<-nn[1:length(cw$tip.clade)]
+ pw<-reorder.backbonePhylo(x,"pruningwise")
+ nn<-unique(pw$edge[,1])
+ for(i in 1:length(nn)){
+ yy<-y[pw$edge[which(pw$edge[,1]==nn[i]),2]]
+ y[nn[i]]<-mean(range(yy))
+ }
+ # compute start & end points of each edge
+ X<-nodeHeights(tt)
+ # open & size a new plot
+ plot.new()
+ par(mar=rep(0.1,4))
+ pp<-par("pin")[1]
+ sw<-cex*(max(strwidth(sapply(cw$tip.clade,function(x) x$label),
+ units="inches")))+1.37*cex*strwidth("W",units="inches")
+ alp<-optimize(function(a,H,sw,pp) (a*1.04*max(H)+sw-pp)^2,H=X,sw=sw,pp=pp,
+ interval=c(0,1e6))$minimum
+ if(is.null(xlim)) xlim<-c(min(X),max(X)+sw/alp)
+ if(is.null(ylim)) ylim<-c(0,n)
+ plot.window(xlim=xlim,ylim=ylim)
+ # plot horizontal edges
+ for(i in 1:nrow(X)){
+ if(cw$edge[i,2]>length(cw$tip.clade)) lines(X[i,],rep(y[cw$edge[i,2]],2),
+ lwd=lwd,lend=2)
+ else lines(c(X[i,1],X[i,2]-cw$tip.clade[[cw$edge[i,2]]]$depth),
+ rep(y[cw$edge[i,2]],2),lwd=lwd,lend=2)
+ }
+ # plot vertical relationships
+ for(i in 1:x$Nnode+length(x$tip.clade)) lines(X[which(cw$edge[,1]==i),1],
+ range(y[cw$edge[which(cw$edge[,1]==i),2]]),lwd=lwd,lend=2)
+ for(i in 1:length(x$tip.clade)){
+ if(x$tip.clade[[i]]$N==1){
+ tmp<-sep
+ sep<-1
+ } else tmp<-sep
+ xx<-c(X[which(cw$edge[,2]==i),2]-cw$tip.clade[[i]]$depth,
+ X[which(cw$edge[,2]==i),2],X[which(cw$edge[,2]==i),2])
+ yy<-c(y[cw$edge[which(cw$edge[,2]==i),2]],
+ y[cw$edge[which(cw$edge[,2]==i),2]]+cw$tip.clade[[i]]$N/2-
+ sep/2,y[cw$edge[which(cw$edge[,2]==i),2]]-
+ cw$tip.clade[[i]]$N/2+sep/2)
+ if(yy[2]<yy[3]) yy[2]<-yy[3]<-yy[1]
+ polygon(x=xx,y=yy,col=col[cw$tip.clade[[i]]$id],lwd=lwd)
+ sep<-tmp
+ }
+ for(i in 1:length(cw$tip.clade))
+ text(X[which(cw$edge[,2]==i),2],y[i],cw$tip.clade[[i]]$label,pos=4,
+ offset=0.1,cex=cex)
+ PP<-list(type="phylogram",use.edge.length=TRUE,node.pos=1,
+ show.tip.label=TRUE,show.node.label=FALSE,
+ font=1,cex=cex,adj=0,srt=0,no.margin=FALSE,label.offset=0.1,
+ x.lim=par()$usr[1:2],y.lim=par()$usr[3:4],
+ direction="rightwards",tip.color="black",Ntip=Ntip(cw),Nnode=cw$Nnode,
+ edge=cw$edge,xx=sapply(1:(Ntip(cw)+cw$Nnode),
+ function(x,y,z) y[match(x,z)],y=X,z=cw$edge),yy=y)
+ assign("last_plot.phylo",PP,envir=.PlotPhyloEnv)
+}
+
+
+
+
+
diff --git a/R/bd.R b/R/bd.R
index 17632e1..8b92ed1 100644
--- a/R/bd.R
+++ b/R/bd.R
@@ -1,119 +1,119 @@
-## likelihood functions for birth-death & Yule model with incomplete sampling
-## written by Liam J. Revell 2017, 2018, 2019, 2020, 2021, 2022
-## based on likelihood functions in Stadler (2012)
-
-anova.fit.bd<-function(object,...){
- fits<-list(...)
- nm<-c(
- deparse(substitute(object)),
- if(length(fits)>0)
- sapply(substitute(list(...))[-1],deparse)
- )
- fits<-if(length(fits)==0) list(object) else c(list(object),fits)
- logL<-sapply(fits,logLik)
- df<-sapply(fits,function(x) attr(logLik(x),"df"))
- AIC<-sapply(fits,AIC)
- weight<-unclass(aic.w(AIC))
- result<-data.frame(logL,df,AIC,weight)
- rownames(result)<-nm
- colnames(result)<-c("log(L)","d.f.","AIC","weight")
- print(result)
- invisible(result)
-}
-
-lik.bd<-function(theta,t,rho=1,N=NULL){
- lam<-theta[1]
- mu<-if(length(theta)==2) theta[2] else 0
- if(is.null(N)) N<-length(t)+1
- p0ti<-function(rho,lam,mu,t)
- 1-rho*(lam-mu)/(rho*lam+(lam*(1-rho)-mu)*exp(-(lam-mu)*t))
- p1ti<-function(rho,lam,mu,t)
- rho*(lam-mu)^2*exp(-(lam-mu)*t)/(rho*lam+(lam*(1-rho)-mu)*exp(-(lam-mu)*t))^2
- lik<-2*log(p1ti(rho,lam,mu,t[1]))-2*log(1-p0ti(rho,lam,mu,t[1]))
- for(i in 2:length(t)) lik<-lik+log(lam)+log(p1ti(rho,lam,mu,t[i]))
- -(lik+lfactorial(N-1))
-}
-
-## model-fitting function for birth-death model
-
-fit.bd<-function(tree,b=NULL,d=NULL,rho=1,...){
- if(!is.ultrametric(tree)){
- cat("tree fails is.ultrametric.\n")
- cat("If you believe your tree actually is ultrametric ")
- cat("use force.ultrametric & try again.\n")
- stop()
- }
- init<-vector(length=2)
- if(hasArg(init.b)) init.b<-list(...)$init.b
- else init.b<-1.1*qb(tree)
- if(hasArg(init.d)) init.d<-list(...)$init.d
- else init.d<-0.1*qb(tree)
- if(hasArg(iter)) iter<-list(...)$iter
- else iter<-10
- if(!is.binary(tree)) tree<-multi2di(tree,random=FALSE)
- T<-sort(branching.times(tree),decreasing=TRUE)
- fit<-nlminb(c(init.b,init.d),lik.bd,t=T,rho=rho,lower=rep(0,2),
- upper=rep(Inf,2))
- if(!is.finite(fit$objective)){
- count<-0
- while(!is.finite(fit$objective)&&count<iter){
- fit<-nlminb(runif(n=2,0,2)*c(init.b,init.d),lik.bd,t=T,rho=rho,
- lower=rep(0,2),upper=rep(Inf,2))
- count<-count+1
- }
- }
- obj<-list(b=fit$par[1],d=fit$par[2],rho=rho,logL=-fit$objective,
- opt=list(counts=fit$counts,convergence=fit$convergence,
- message=fit$message),model="birth-death",
- lik=function(theta) -lik.bd(theta,t=T,rho=rho))
- class(obj)<-"fit.bd"
- obj
-}
-
-## fit Yule model
-
-fit.yule<-function(tree,b=NULL,d=NULL,rho=1,...){
- if(hasArg(interval)) interval<-list(...)$interval
- else interval<-c(0,2*qb(tree)/rho)
- if(!is.binary(tree)) tree<-multi2di(tree,random=FALSE)
- T<-sort(branching.times(tree),decreasing=TRUE)
- fit<-optimize(lik.bd,interval,t=T,rho=rho)
- obj<-list(b=fit$minimum,d=0,rho=rho,logL=-fit$objective,
- opt=list(convergence=0),model="Yule",
- lik=function(theta) -lik.bd(c(theta,0),t=T,rho=rho))
- class(obj)<-"fit.bd"
- obj
-}
-
-## S3 print method for object class 'fit.bd'
-
-SIGNIF<-function(x,dd){
- tens<-if(abs(x)>1) ceiling(log10(abs(x))) else 0
- signif(x,dd+tens)
-}
-
-print.fit.bd<-function(x,...){
- if(hasArg(digits)) digits<-list(...)$digits
- else digits<-4
- cat(paste("\nFitted",x$model,"model:\n\n"))
- cat(paste("ML(b/lambda) =",SIGNIF(x$b,digits),"\n"))
- if(x$model=="birth-death")
- cat(paste("ML(d/mu) =",SIGNIF(x$d,digits),"\n"))
- cat(paste("log(L) =",SIGNIF(x$logL,digits),"\n"))
- cat(paste("\nAssumed sampling fraction (rho) =",SIGNIF(x$rho,digits),"\n"))
- if(x$opt$convergence==0) cat("\nR thinks it has converged.\n\n")
- else cat("\nR thinks optimization may not have converged.\n\n")
-}
-
-## S3 logLik method
-
-logLik.fit.bd<-function(object,...){
- logLik<-object$logL
- attr(logLik,"df")<-if(object$model=="birth-death") 2 else 1
- logLik
-}
-
-## helper function
-
-qb<-function(tree) (Ntip(tree)-2)/sum(tree$edge.length)
-
+## likelihood functions for birth-death & Yule model with incomplete sampling
+## written by Liam J. Revell 2017, 2018, 2019, 2020, 2021, 2022
+## based on likelihood functions in Stadler (2012)
+
+anova.fit.bd<-function(object,...){
+ fits<-list(...)
+ nm<-c(
+ deparse(substitute(object)),
+ if(length(fits)>0)
+ sapply(substitute(list(...))[-1],deparse)
+ )
+ fits<-if(length(fits)==0) list(object) else c(list(object),fits)
+ logL<-sapply(fits,logLik)
+ df<-sapply(fits,function(x) attr(logLik(x),"df"))
+ AIC<-sapply(fits,AIC)
+ weight<-unclass(aic.w(AIC))
+ result<-data.frame(logL,df,AIC,weight)
+ rownames(result)<-nm
+ colnames(result)<-c("log(L)","d.f.","AIC","weight")
+ print(result)
+ invisible(result)
+}
+
+lik.bd<-function(theta,t,rho=1,N=NULL){
+ lam<-theta[1]
+ mu<-if(length(theta)==2) theta[2] else 0
+ if(is.null(N)) N<-length(t)+1
+ p0ti<-function(rho,lam,mu,t)
+ 1-rho*(lam-mu)/(rho*lam+(lam*(1-rho)-mu)*exp(-(lam-mu)*t))
+ p1ti<-function(rho,lam,mu,t)
+ rho*(lam-mu)^2*exp(-(lam-mu)*t)/(rho*lam+(lam*(1-rho)-mu)*exp(-(lam-mu)*t))^2
+ lik<-2*log(p1ti(rho,lam,mu,t[1]))-2*log(1-p0ti(rho,lam,mu,t[1]))
+ for(i in 2:length(t)) lik<-lik+log(lam)+log(p1ti(rho,lam,mu,t[i]))
+ -(lik+lfactorial(N-1))
+}
+
+## model-fitting function for birth-death model
+
+fit.bd<-function(tree,b=NULL,d=NULL,rho=1,...){
+ if(!is.ultrametric(tree)){
+ cat("tree fails is.ultrametric.\n")
+ cat("If you believe your tree actually is ultrametric ")
+ cat("use force.ultrametric & try again.\n")
+ stop()
+ }
+ init<-vector(length=2)
+ if(hasArg(init.b)) init.b<-list(...)$init.b
+ else init.b<-1.1*qb(tree)
+ if(hasArg(init.d)) init.d<-list(...)$init.d
+ else init.d<-0.1*qb(tree)
+ if(hasArg(iter)) iter<-list(...)$iter
+ else iter<-10
+ if(!is.binary(tree)) tree<-multi2di(tree,random=FALSE)
+ T<-sort(branching.times(tree),decreasing=TRUE)
+ fit<-nlminb(c(init.b,init.d),lik.bd,t=T,rho=rho,lower=rep(0,2),
+ upper=rep(Inf,2))
+ if(!is.finite(fit$objective)){
+ count<-0
+ while(!is.finite(fit$objective)&&count<iter){
+ fit<-nlminb(runif(n=2,0,2)*c(init.b,init.d),lik.bd,t=T,rho=rho,
+ lower=rep(0,2),upper=rep(Inf,2))
+ count<-count+1
+ }
+ }
+ obj<-list(b=fit$par[1],d=fit$par[2],rho=rho,logL=-fit$objective,
+ opt=list(counts=fit$counts,convergence=fit$convergence,
+ message=fit$message),model="birth-death",
+ lik=function(theta) -lik.bd(theta,t=T,rho=rho))
+ class(obj)<-"fit.bd"
+ obj
+}
+
+## fit Yule model
+
+fit.yule<-function(tree,b=NULL,d=NULL,rho=1,...){
+ if(hasArg(interval)) interval<-list(...)$interval
+ else interval<-c(0,2*qb(tree)/rho)
+ if(!is.binary(tree)) tree<-multi2di(tree,random=FALSE)
+ T<-sort(branching.times(tree),decreasing=TRUE)
+ fit<-optimize(lik.bd,interval,t=T,rho=rho)
+ obj<-list(b=fit$minimum,d=0,rho=rho,logL=-fit$objective,
+ opt=list(convergence=0),model="Yule",
+ lik=function(theta) -lik.bd(c(theta,0),t=T,rho=rho))
+ class(obj)<-"fit.bd"
+ obj
+}
+
+## S3 print method for object class 'fit.bd'
+
+SIGNIF<-function(x,dd){
+ tens<-if(abs(x)>1) ceiling(log10(abs(x))) else 0
+ signif(x,dd+tens)
+}
+
+print.fit.bd<-function(x,...){
+ if(hasArg(digits)) digits<-list(...)$digits
+ else digits<-4
+ cat(paste("\nFitted",x$model,"model:\n\n"))
+ cat(paste("ML(b/lambda) =",SIGNIF(x$b,digits),"\n"))
+ if(x$model=="birth-death")
+ cat(paste("ML(d/mu) =",SIGNIF(x$d,digits),"\n"))
+ cat(paste("log(L) =",SIGNIF(x$logL,digits),"\n"))
+ cat(paste("\nAssumed sampling fraction (rho) =",SIGNIF(x$rho,digits),"\n"))
+ if(x$opt$convergence==0) cat("\nR thinks it has converged.\n\n")
+ else cat("\nR thinks optimization may not have converged.\n\n")
+}
+
+## S3 logLik method
+
+logLik.fit.bd<-function(object,...){
+ logLik<-object$logL
+ attr(logLik,"df")<-if(object$model=="birth-death") 2 else 1
+ logLik
+}
+
+## helper function
+
+qb<-function(tree) (Ntip(tree)-2)/sum(tree$edge.length)
+
diff --git a/R/bmPlot.R b/R/bmPlot.R
index f0e7b8b..46fa3de 100644
--- a/R/bmPlot.R
+++ b/R/bmPlot.R
@@ -1,137 +1,137 @@
-## visualize discrete time Brownian simulation on a tree
-## written by Liam J. Revell 2012, 2013, 2015, 2020, 2022
-
-bmPlot<-function(tree,type="BM",anc=0,sig2=1/1000,ngen=1000,...){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- if(hasArg(return.tree)) return.tree<-list(...)$return.tree
- else return.tree<-TRUE
-
- tr<-reorder(tree)
- H<-nodeHeights(tr)
- tr$edge.length<-round(tr$edge.length/max(H)*ngen)
- tr<-di2multi(tr)
- h<-nodeHeights(tr)[,1]
-
- bmSim<-function(start,n)
- cumsum(c(start,rnorm(n,sd=sqrt(sig2))))
-
- X<-T<-list()
- N<-length(tr$tip)
- for(i in 1:nrow(tr$edge)){
- if(tr$edge[i,1]==(N+1)) X[[i]]<-bmSim(anc,tr$edge.length[i])
- else {
- parent<-match(tr$edge[i,1],tr$edge[,2])
- X[[i]]<-bmSim(X[[parent]][length(X[[parent]])],tr$edge.length[i])
- }
- T[[i]]<-h[i]+0:tr$edge.length[i]
- }
-
- if(type=="BM") cols<-bm(X,T,...)
- else if(type=="threshold") cols<-th(X,T,...)
-
- if(return.tree){
- if(type=="BM") tr$X<-X
- else if(type=="threshold"){
- if(hasArg(thresholds)) thresholds<-list(...)$thresholds
- else stop("no thresholds provided for type=\"threshold\"")
- thresholds<-setNames(c(thresholds,Inf),letters[1:(length(thresholds)+1)])
- xx<-lapply(X,function(x,y) sapply(x[2:length(x)],threshState,thresholds=y),y=thresholds)
- maps<-lapply(tr$edge.length,function(x) rep(1,x))
- maps<-mapply(function(x,y) setNames(x,y),x=maps,y=xx)
- maps<-lapply(maps,mergeAdjacent)
- tr$maps<-maps
- class(tr)<-c("simmap",setdiff(class(tr),"simmap"))
- }
- }
-
- Y<-matrix(NA,nrow(tr$edge),2)
- Y[,1]<-sapply(X,function(x) x[1])
- Y[,2]<-sapply(X,function(x) x[length(x)])
-
- x<-Y[tr$edge[,2]%in%1:N,2]
- names(x)<-tr$tip.label[tr$edge[tr$edge[,2]%in%1:N,2]]
- a<-c(anc,Y[tr$edge[,2]%in%(N+2:tr$Nnode),2])
- names(a)<-c(N+1,tr$edge[tr$edge[,2]%in%(N+2:tr$Nnode),2])
-
- xx<-c(x[tr$tip],a[as.character(N+1:tr$Nnode)])
- if(!return.tree) return(xx)
- else return(list(x=xx,tree=tr,colors=cols))
-}
-
-# plots type="BM"
-bm<-function(X,T,...){
- if(hasArg(bty)) bty<-list(...)$bty
- else bty<-"o"
- if(hasArg(lwd)) lwd<-list(...)$lwd
- else lwd<-1
- minX<-min(sapply(X,min))
- maxX<-max(sapply(X,max))
- plot(X[[1]][1],T[[1]][1],ylim=c(0,max(sapply(T,max))),
- xlim=c(minX,maxX),ylab="time",xlab="phenotype",
- bty=bty)
- for(i in 1:length(X)) lines(X[[i]],T[[i]],lwd=lwd)
- if(hasArg(colors)) cols<-list(...)$colors
- else cols<-"black"
- return(cols)
-}
-
-# plots type="threshold"
-th<-function(X,T,...){
- if(hasArg(bty)) bty<-list(...)$bty
- else bty<-"o"
- if(hasArg(lwd)) lwd<-list(...)$lwd
- else lwd<-1
- minX<-min(sapply(X,min))
- maxX<-max(sapply(X,max))
- if(hasArg(thresholds)) thresholds<-list(...)$thresholds
- else stop("no thresholds provided for type='threshold'")
- if(hasArg(colors)) cols<-list(...)$colors
- else {
- cols<-c("black","red","blue","green")
- while(length(thresholds)>(length(cols)-1)) cols<-c(cols,c("black","red","blue","green"))
- }
- thresholds<-thresholds+1e-16
- plot(X[[1]][1],T[[1]][1],ylim=c(0,max(sapply(T,max))),xlim=c(minX,maxX),ylab="time",xlab="liability",
- bty=bty)
- for(i in 1:length(X))
- if(length(X[[i]])>1)
- for(j in 1:(length(X[[i]])-1))
- if(threshCol(X[[i]][j],thresholds,cols)==threshCol(X[[i]][j+1],thresholds,cols))
- lines(X[[i]][c(j,j+1)],T[[i]][c(j,j+1)],
- col=threshCol(X[[i]][j+1],thresholds,cols),lwd=lwd)
- else {
- t<-thresholds[which(sort(c(thresholds,min(X[[i]][c(j,j+1)])))==min(X[[i]][c(j,j+1)]))]
- lines(c(X[[i]][j],t),c(T[[i]][j],
- T[[i]][j]+abs(diff(c(X[[i]][j],t))/diff(X[[i]][c(j,j+1)]))),
- col=threshCol(X[[i]][j],thresholds,cols),lwd=lwd)
- lines(c(X[[i]][j+1],t),c(T[[i]][j+1],
- T[[i]][j+1]-abs(diff(c(X[[i]][j+1],t))/diff(X[[i]][c(j,j+1)]))),
- col=threshCol(X[[i]][j+1],thresholds,cols),lwd=lwd)
- }
- for(i in 1:length(thresholds)) lines(rep(thresholds[i],2),c(0,max(sapply(T,max))),lty="dashed")
- return(setNames(cols[1:(length(thresholds)+1)],letters[1:(length(thresholds)+1)]))
-}
-
-# returns a color based on position relative to thresholds
-threshCol<-function(x,thresholds,cols){
- t<-c(-Inf,thresholds,Inf); i<-1
- while(x>t[i]) i<-i+1
- return(cols[i-1])
-}
-
-# merge adjacent map in the same state
-mergeAdjacent<-function(x){
- ii<-1
- y<-x[1]
- if(length(x)>1){
- for(i in 2:length(x)){
- if(names(x)[i]==names(y)[ii]) y[ii]<-y[ii]+x[i]
- else{
- y<-c(y,x[i])
- ii<-ii+1
- }
- }
- }
- return(y)
-}
-
+## visualize discrete time Brownian simulation on a tree
+## written by Liam J. Revell 2012, 2013, 2015, 2020, 2022
+
+bmPlot<-function(tree,type="BM",anc=0,sig2=1/1000,ngen=1000,...){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ if(hasArg(return.tree)) return.tree<-list(...)$return.tree
+ else return.tree<-TRUE
+
+ tr<-reorder(tree)
+ H<-nodeHeights(tr)
+ tr$edge.length<-round(tr$edge.length/max(H)*ngen)
+ tr<-di2multi(tr)
+ h<-nodeHeights(tr)[,1]
+
+ bmSim<-function(start,n)
+ cumsum(c(start,rnorm(n,sd=sqrt(sig2))))
+
+ X<-T<-list()
+ N<-length(tr$tip)
+ for(i in 1:nrow(tr$edge)){
+ if(tr$edge[i,1]==(N+1)) X[[i]]<-bmSim(anc,tr$edge.length[i])
+ else {
+ parent<-match(tr$edge[i,1],tr$edge[,2])
+ X[[i]]<-bmSim(X[[parent]][length(X[[parent]])],tr$edge.length[i])
+ }
+ T[[i]]<-h[i]+0:tr$edge.length[i]
+ }
+
+ if(type=="BM") cols<-bm(X,T,...)
+ else if(type=="threshold") cols<-th(X,T,...)
+
+ if(return.tree){
+ if(type=="BM") tr$X<-X
+ else if(type=="threshold"){
+ if(hasArg(thresholds)) thresholds<-list(...)$thresholds
+ else stop("no thresholds provided for type=\"threshold\"")
+ thresholds<-setNames(c(thresholds,Inf),letters[1:(length(thresholds)+1)])
+ xx<-lapply(X,function(x,y) sapply(x[2:length(x)],threshState,thresholds=y),y=thresholds)
+ maps<-lapply(tr$edge.length,function(x) rep(1,x))
+ maps<-mapply(function(x,y) setNames(x,y),x=maps,y=xx)
+ maps<-lapply(maps,mergeAdjacent)
+ tr$maps<-maps
+ class(tr)<-c("simmap",setdiff(class(tr),"simmap"))
+ }
+ }
+
+ Y<-matrix(NA,nrow(tr$edge),2)
+ Y[,1]<-sapply(X,function(x) x[1])
+ Y[,2]<-sapply(X,function(x) x[length(x)])
+
+ x<-Y[tr$edge[,2]%in%1:N,2]
+ names(x)<-tr$tip.label[tr$edge[tr$edge[,2]%in%1:N,2]]
+ a<-c(anc,Y[tr$edge[,2]%in%(N+2:tr$Nnode),2])
+ names(a)<-c(N+1,tr$edge[tr$edge[,2]%in%(N+2:tr$Nnode),2])
+
+ xx<-c(x[tr$tip],a[as.character(N+1:tr$Nnode)])
+ if(!return.tree) return(xx)
+ else return(list(x=xx,tree=tr,colors=cols))
+}
+
+# plots type="BM"
+bm<-function(X,T,...){
+ if(hasArg(bty)) bty<-list(...)$bty
+ else bty<-"o"
+ if(hasArg(lwd)) lwd<-list(...)$lwd
+ else lwd<-1
+ minX<-min(sapply(X,min))
+ maxX<-max(sapply(X,max))
+ plot(X[[1]][1],T[[1]][1],ylim=c(0,max(sapply(T,max))),
+ xlim=c(minX,maxX),ylab="time",xlab="phenotype",
+ bty=bty)
+ for(i in 1:length(X)) lines(X[[i]],T[[i]],lwd=lwd)
+ if(hasArg(colors)) cols<-list(...)$colors
+ else cols<-"black"
+ return(cols)
+}
+
+# plots type="threshold"
+th<-function(X,T,...){
+ if(hasArg(bty)) bty<-list(...)$bty
+ else bty<-"o"
+ if(hasArg(lwd)) lwd<-list(...)$lwd
+ else lwd<-1
+ minX<-min(sapply(X,min))
+ maxX<-max(sapply(X,max))
+ if(hasArg(thresholds)) thresholds<-list(...)$thresholds
+ else stop("no thresholds provided for type='threshold'")
+ if(hasArg(colors)) cols<-list(...)$colors
+ else {
+ cols<-c("black","red","blue","green")
+ while(length(thresholds)>(length(cols)-1)) cols<-c(cols,c("black","red","blue","green"))
+ }
+ thresholds<-thresholds+1e-16
+ plot(X[[1]][1],T[[1]][1],ylim=c(0,max(sapply(T,max))),xlim=c(minX,maxX),ylab="time",xlab="liability",
+ bty=bty)
+ for(i in 1:length(X))
+ if(length(X[[i]])>1)
+ for(j in 1:(length(X[[i]])-1))
+ if(threshCol(X[[i]][j],thresholds,cols)==threshCol(X[[i]][j+1],thresholds,cols))
+ lines(X[[i]][c(j,j+1)],T[[i]][c(j,j+1)],
+ col=threshCol(X[[i]][j+1],thresholds,cols),lwd=lwd)
+ else {
+ t<-thresholds[which(sort(c(thresholds,min(X[[i]][c(j,j+1)])))==min(X[[i]][c(j,j+1)]))]
+ lines(c(X[[i]][j],t),c(T[[i]][j],
+ T[[i]][j]+abs(diff(c(X[[i]][j],t))/diff(X[[i]][c(j,j+1)]))),
+ col=threshCol(X[[i]][j],thresholds,cols),lwd=lwd)
+ lines(c(X[[i]][j+1],t),c(T[[i]][j+1],
+ T[[i]][j+1]-abs(diff(c(X[[i]][j+1],t))/diff(X[[i]][c(j,j+1)]))),
+ col=threshCol(X[[i]][j+1],thresholds,cols),lwd=lwd)
+ }
+ for(i in 1:length(thresholds)) lines(rep(thresholds[i],2),c(0,max(sapply(T,max))),lty="dashed")
+ return(setNames(cols[1:(length(thresholds)+1)],letters[1:(length(thresholds)+1)]))
+}
+
+# returns a color based on position relative to thresholds
+threshCol<-function(x,thresholds,cols){
+ t<-c(-Inf,thresholds,Inf); i<-1
+ while(x>t[i]) i<-i+1
+ return(cols[i-1])
+}
+
+# merge adjacent map in the same state
+mergeAdjacent<-function(x){
+ ii<-1
+ y<-x[1]
+ if(length(x)>1){
+ for(i in 2:length(x)){
+ if(names(x)[i]==names(y)[ii]) y[ii]<-y[ii]+x[i]
+ else{
+ y<-c(y,x[i])
+ ii<-ii+1
+ }
+ }
+ }
+ return(y)
+}
+
diff --git a/R/branching.diffusion.R b/R/branching.diffusion.R
index 1a46fbe..da65f5b 100644
--- a/R/branching.diffusion.R
+++ b/R/branching.diffusion.R
@@ -1,58 +1,58 @@
-## function animates branching random diffusion
-## written by Liam Revell 2011, 2013, 2015, 2020
-
-branching.diffusion<-function(sig2=1,b=0.0023,time.stop=1000,ylim=NULL,smooth=TRUE,
- pause=0.02,record=NULL,path=NULL,...){
- if(hasArg(bty)) bty<-list(...)$bty
- else bty<-"l"
- N<-1
- Y<-matrix(0,1,N)
- if(is.null(ylim)) ylim<-c(-2*sqrt(sig2*time.stop),2*sqrt(sig2*time.stop))
- par(bg="white")
- plot(0,0,xlim=c(0,time.stop),ylim=ylim,xlab="time",ylab="phenotype",
- main="branching diffusion",font.main=3,bty=bty)
- chk<-.check.pkg("animation")
- if(!chk){
- cat(" record != NULL requires the package \"animation\"\n")
- cat(" Animation will play but not record\n\n")
- record<-NULL
- ani.options<-function(...) NULL
- ani.record<-function(...) NULL
- ani.replay<-function(...) NULL
- saveVideo<-function(...) NULL
- }
- if(!is.null(record)){
- if(is.null(path)) path="C:/Program Files/ffmpeg/bin/ffmpeg.exe"
- tmp<-strsplit(path,"/")[[1]]
- ll<-list.files(paste(tmp[2:length(tmp)-1],collapse="/"))
- if(length(grep(tmp[length(tmp)],ll))>0){
- ani.options(interval=0.01,ffmpeg=path,outdir=getwd())
- ani.record(reset=TRUE)
- } else {
- cat(" record != NULL requires correct path supplied to video renderer\n")
- cat(" Animation will play but not record\n\n")
- record<-NULL
- }
- }
- for(i in 2:time.stop){
- time<-1:i
- Y<-rbind(Y,Y[i-1,])
- for(j in 1:N){
- if(b>runif(n=1)){
- Y<-cbind(Y,Y[,j])
- N<-N+1
- Y[i,N]<-Y[i,j]+rnorm(n=1,sd=sqrt(sig2))
- }
- Y[i,j]<-Y[i,j]+rnorm(n=1,sd=sqrt(sig2))
- }
- dev.hold()
- plot(0,0,xlim=c(0,time.stop),ylim=ylim,xlab="time",ylab="phenotype",
- main="branching diffusion",font.main=3,bty=bty)
- apply(Y,2,lines)
- dev.flush()
- if(!is.null(record)) ani.record()
- Sys.sleep(pause)
- }
- if(!is.null(record)) saveVideo(ani.replay(),video.name=record,other.opts="-b 300k",
- clean=TRUE)
-}
+## function animates branching random diffusion
+## written by Liam Revell 2011, 2013, 2015, 2020
+
+branching.diffusion<-function(sig2=1,b=0.0023,time.stop=1000,ylim=NULL,smooth=TRUE,
+ pause=0.02,record=NULL,path=NULL,...){
+ if(hasArg(bty)) bty<-list(...)$bty
+ else bty<-"l"
+ N<-1
+ Y<-matrix(0,1,N)
+ if(is.null(ylim)) ylim<-c(-2*sqrt(sig2*time.stop),2*sqrt(sig2*time.stop))
+ par(bg="white")
+ plot(0,0,xlim=c(0,time.stop),ylim=ylim,xlab="time",ylab="phenotype",
+ main="branching diffusion",font.main=3,bty=bty)
+ chk<-.check.pkg("animation")
+ if(!chk){
+ cat(" record != NULL requires the package \"animation\"\n")
+ cat(" Animation will play but not record\n\n")
+ record<-NULL
+ ani.options<-function(...) NULL
+ ani.record<-function(...) NULL
+ ani.replay<-function(...) NULL
+ saveVideo<-function(...) NULL
+ }
+ if(!is.null(record)){
+ if(is.null(path)) path="C:/Program Files/ffmpeg/bin/ffmpeg.exe"
+ tmp<-strsplit(path,"/")[[1]]
+ ll<-list.files(paste(tmp[2:length(tmp)-1],collapse="/"))
+ if(length(grep(tmp[length(tmp)],ll))>0){
+ ani.options(interval=0.01,ffmpeg=path,outdir=getwd())
+ ani.record(reset=TRUE)
+ } else {
+ cat(" record != NULL requires correct path supplied to video renderer\n")
+ cat(" Animation will play but not record\n\n")
+ record<-NULL
+ }
+ }
+ for(i in 2:time.stop){
+ time<-1:i
+ Y<-rbind(Y,Y[i-1,])
+ for(j in 1:N){
+ if(b>runif(n=1)){
+ Y<-cbind(Y,Y[,j])
+ N<-N+1
+ Y[i,N]<-Y[i,j]+rnorm(n=1,sd=sqrt(sig2))
+ }
+ Y[i,j]<-Y[i,j]+rnorm(n=1,sd=sqrt(sig2))
+ }
+ dev.hold()
+ plot(0,0,xlim=c(0,time.stop),ylim=ylim,xlab="time",ylab="phenotype",
+ main="branching diffusion",font.main=3,bty=bty)
+ apply(Y,2,lines)
+ dev.flush()
+ if(!is.null(record)) ani.record()
+ Sys.sleep(pause)
+ }
+ if(!is.null(record)) saveVideo(ani.replay(),video.name=record,other.opts="-b 300k",
+ clean=TRUE)
+}
diff --git a/R/brownie.lite.R b/R/brownie.lite.R
index 9d05539..0c67eec 100644
--- a/R/brownie.lite.R
+++ b/R/brownie.lite.R
@@ -1,157 +1,157 @@
-## this function fits two or more evolutionary rates for a continuous trait on the tree
-## based on O'Meara et al. (2006)
-## written by Liam J. Revell 2011/2012, 2019, 2022
-
-brownie.lite<-function(tree,x,maxit=2000,test="chisq",nsim=100,se=NULL,...){
- if(hasArg(quiet)) quiet<-list(...)$quiet
- else quiet<-FALSE
- # some minor error checking
- if(!inherits(tree,"phylo"))
- stop("tree should be an object of class \"phylo\".")
- if(!inherits(tree,"simmap"))
- tree<-paintSubTree(tree,Ntip(tree)+1,"1")
- x<-matchDatatoTree(tree,x,"x")
- x<-x[tree$tip.label]
- if(!is.null(se)){
- se<-matchDatatoTree(tree,se,"se")
- se<-se[tree$tip.label]
- } else {
- se<-rep(0,length(x))
- names(se)<-names(x)
- }
- n<-length(x) # number of species
- p<-ncol(tree$mapped.edge) # number of states
- C1<-vcv.phylo(tree)
- a<-as.numeric(colSums(solve(C1))%*%x/sum(solve(C1)))
- sig<-as.numeric(t(x-a)%*%solve(C1)%*%(x-a)/n)
- # single rate model
- model1<-optim(c(sig,a),fn=lik.single,y=x,C=C1,se=se,
- control=list(maxit=maxit),hessian=TRUE,
- method="L-BFGS-B",
- lower=c(0,-Inf))
- logL1<--model1$value
- sig1<-model1$par[1]
- a1<-model1$par[2]
- vcv1<-solve(model1$hessian)
- rownames(vcv1)<-c("sig","a")
- colnames(vcv1)<-rownames(vcv1)
- # multiple rate model
- C2<-multiC(tree)
- s<-c(rep(sig1,p),a1)
- l<-c(rep(0.0001*sig1,p),-Inf)
- model2<-optim(s,fn=lik.multiple,y=x,C=C2,se=se,
- control=list(maxit=maxit),hessian=TRUE,
- method="L-BFGS-B",lower=l)
- logL2<--model2$value
- while(logL2<logL1){
- if(!quiet){
- message("False convergence on first try; trying again with new starting values.")
- }
- model2<-optim(s*2*runif(n=length(s)),fn=lik.multiple,
- y=x,C=C2,se=se,control=list(maxit=maxit),
- hessian=TRUE,method="L-BFGS-B",lower=l)
- logL2<--model2$value
- }
- sig.i<-model2$par[1:p]
- names(sig.i)<-colnames(tree$mapped.edge)
- a2<-model2$par[p+1]
- vcv2<-solve(model2$hessian)
- rownames(vcv2)<-c(colnames(tree$mapped.edge),"a")
- colnames(vcv2)<-rownames(vcv2)
- if(model2$convergence==0) converged<-"Optimization has converged."
- else converged<-"Optimization may not have converged. Consider increasing maxit."
- if(test=="chisq")
- xx<-list(sig2.single=sig1,a.single=a1,var.single=vcv1[1,1],
- logL1=logL1,k1=2,sig2.multiple=sig.i,a.multiple=a2,
- vcv.multiple=vcv2[1:p,1:p],logL.multiple=logL2,k2=p+1,
- P.chisq=pchisq(2*(logL2-as.numeric(logL1)),p-1,
- lower.tail=FALSE),convergence=converged)
- else if(test=="simulation"){
- LR<-2*(logL2-logL1)
- X<-fastBM(tree,a=a1,sig2=sig1,nsim=(nsim-1))
- Xe<-matrix(rnorm(n=length(X),mean=X,sd=rep(se,nsim-1)),
- nrow(X),ncol(X),dimnames=dimnames(X))
- # now compute the P-value based on simulation
- Psim<-1/nsim
- for(i in 1:(nsim-1)){
- sim<-brownie.lite(tree,Xe[,i],se=se)
- while(sim$convergence!="Optimization has converged."||
- (sim$logL.multiple-sim$logL1)<0){
- Xe[,i]<-rnorm(n=length(x),fastBM(tree,a=a1,sig2=sig1),sd=se)
- sim<-brownie.lite(tree,Xe[,i])
- }
- Psim<-Psim+(LR<=2*(sim$logL.multiple-sim$logL1))/nsim
- }
- xx<-list(sig2.single=sig1,a.single=a1,var.single=vcv1[1,1],logL1=logL1,
- k1=2,sig2.multiple=sig.i,a.multiple=a2,vcv.multiple=vcv2[1:p,1:p],
- logL.multiple=logL2,k2=p+1,P.sim=Psim,convergence=converged)
- }
- class(xx)<-"brownie.lite"
- return(xx)
-}
-
-## S3 print method for object of class "brownie.lite"
-## written by Liam J. Revell 2013, 2020
-
-print.brownie.lite<-function(x, ...){
- if(hasArg(digits)) digits<-list(...)$digits
- else digits<-getOption("digits")
- x<-lapply(x,function(a,b) if(is.numeric(a)) round(a,b) else a,b=digits)
- cat("ML single-rate model:\n")
- obj<-matrix(c(x$sig2.single,sqrt(x$var.single),
- x$a.single,x$k1,x$logL1),1,5,
- dimnames=list("value",c("s^2","se","a","k","logL")))
- print(obj,digits=digits)
- cat("\nML multi-rate model:\n")
- nn<-c(unlist(strsplit(paste("s^2(",names(x$sig2.multiple),")__",
- "se(",names(x$sig2.multiple),")",sep=""),"__")),"a","k",
- "logL")
- obj<-matrix(c(as.vector(rbind(x$sig2.multiple,sqrt(diag(x$vcv.multiple)))),
- x$a.multiple,x$k2,x$logL.multiple),1,2*length(x$sig2.multiple)+3,
- dimnames=list("value",nn))
- print(obj,digits=digits)
- if(!is.null(x$P.chisq)) cat(paste("\nP-value (based on X^2):",x$P.chisq,"\n\n"))
- else if(!is.null(x$P.sim)) cat(paste("\nP-value (based on simulation):",
- x$P.sim,"\n\n"))
- if(x$convergence[1]=="Optimization has converged.")
- cat("R thinks it has found the ML solution.\n\n")
- else cat("Optimization may not have converged.\n\n")
-}
-
-# function computes the likelihood for a single rate with sampling error
-# written by Liam J. Revell 2012
-
-lik.single<-function(theta,y,C,se){
- n<-length(y)
- sig<-theta[1]
- a<-theta[2]
- E<-diag(se^2)
- logL<-as.numeric(-t(y-a)%*%solve(sig*C+E)%*%(y-a)/2-
- n*log(2*pi)/2-determinant(sig*C+E)$modulus[1]/2)
- return(-logL)
-}
-
-# function computes the likelihood for multiple rates
-# written by Liam J. Revell 2012
-
-lik.multiple<-function(theta,y,C,se=NULL){
- n<-length(y); p<-length(C)
- sig<-theta[1:p]
- a<-theta[p+1]
- V<-matrix(0,length(y),length(y))
- for(i in 1:p) V<-V+sig[i]*C[[i]]
- E<-diag(se^2)
- logL<--t(y-a)%*%solve(V+E)%*%(y-a)/2-n*log(2*pi)/2-
- determinant(V+E)$modulus[1]/2
- return(-logL)
-}
-
-## S3 logLik method for object class
-
-logLik.brownie.lite<-function(object,...){
- lik<-setNames(
- c(object$logL1,object$logL.multiple),
- c("single-rate","multi-rate"))
- attr(lik,"df")<-c(object$k1,object$k2)
- lik
-}
+## this function fits two or more evolutionary rates for a continuous trait on the tree
+## based on O'Meara et al. (2006)
+## written by Liam J. Revell 2011/2012, 2019, 2022
+
+brownie.lite<-function(tree,x,maxit=2000,test="chisq",nsim=100,se=NULL,...){
+ if(hasArg(quiet)) quiet<-list(...)$quiet
+ else quiet<-FALSE
+ # some minor error checking
+ if(!inherits(tree,"phylo"))
+ stop("tree should be an object of class \"phylo\".")
+ if(!inherits(tree,"simmap"))
+ tree<-paintSubTree(tree,Ntip(tree)+1,"1")
+ x<-matchDatatoTree(tree,x,"x")
+ x<-x[tree$tip.label]
+ if(!is.null(se)){
+ se<-matchDatatoTree(tree,se,"se")
+ se<-se[tree$tip.label]
+ } else {
+ se<-rep(0,length(x))
+ names(se)<-names(x)
+ }
+ n<-length(x) # number of species
+ p<-ncol(tree$mapped.edge) # number of states
+ C1<-vcv.phylo(tree)
+ a<-as.numeric(colSums(solve(C1))%*%x/sum(solve(C1)))
+ sig<-as.numeric(t(x-a)%*%solve(C1)%*%(x-a)/n)
+ # single rate model
+ model1<-optim(c(sig,a),fn=lik.single,y=x,C=C1,se=se,
+ control=list(maxit=maxit),hessian=TRUE,
+ method="L-BFGS-B",
+ lower=c(0,-Inf))
+ logL1<--model1$value
+ sig1<-model1$par[1]
+ a1<-model1$par[2]
+ vcv1<-solve(model1$hessian)
+ rownames(vcv1)<-c("sig","a")
+ colnames(vcv1)<-rownames(vcv1)
+ # multiple rate model
+ C2<-multiC(tree)
+ s<-c(rep(sig1,p),a1)
+ l<-c(rep(0.0001*sig1,p),-Inf)
+ model2<-optim(s,fn=lik.multiple,y=x,C=C2,se=se,
+ control=list(maxit=maxit),hessian=TRUE,
+ method="L-BFGS-B",lower=l)
+ logL2<--model2$value
+ while(logL2<logL1){
+ if(!quiet){
+ message("False convergence on first try; trying again with new starting values.")
+ }
+ model2<-optim(s*2*runif(n=length(s)),fn=lik.multiple,
+ y=x,C=C2,se=se,control=list(maxit=maxit),
+ hessian=TRUE,method="L-BFGS-B",lower=l)
+ logL2<--model2$value
+ }
+ sig.i<-model2$par[1:p]
+ names(sig.i)<-colnames(tree$mapped.edge)
+ a2<-model2$par[p+1]
+ vcv2<-solve(model2$hessian)
+ rownames(vcv2)<-c(colnames(tree$mapped.edge),"a")
+ colnames(vcv2)<-rownames(vcv2)
+ if(model2$convergence==0) converged<-"Optimization has converged."
+ else converged<-"Optimization may not have converged. Consider increasing maxit."
+ if(test=="chisq")
+ xx<-list(sig2.single=sig1,a.single=a1,var.single=vcv1[1,1],
+ logL1=logL1,k1=2,sig2.multiple=sig.i,a.multiple=a2,
+ vcv.multiple=vcv2[1:p,1:p],logL.multiple=logL2,k2=p+1,
+ P.chisq=pchisq(2*(logL2-as.numeric(logL1)),p-1,
+ lower.tail=FALSE),convergence=converged)
+ else if(test=="simulation"){
+ LR<-2*(logL2-logL1)
+ X<-fastBM(tree,a=a1,sig2=sig1,nsim=(nsim-1))
+ Xe<-matrix(rnorm(n=length(X),mean=X,sd=rep(se,nsim-1)),
+ nrow(X),ncol(X),dimnames=dimnames(X))
+ # now compute the P-value based on simulation
+ Psim<-1/nsim
+ for(i in 1:(nsim-1)){
+ sim<-brownie.lite(tree,Xe[,i],se=se)
+ while(sim$convergence!="Optimization has converged."||
+ (sim$logL.multiple-sim$logL1)<0){
+ Xe[,i]<-rnorm(n=length(x),fastBM(tree,a=a1,sig2=sig1),sd=se)
+ sim<-brownie.lite(tree,Xe[,i])
+ }
+ Psim<-Psim+(LR<=2*(sim$logL.multiple-sim$logL1))/nsim
+ }
+ xx<-list(sig2.single=sig1,a.single=a1,var.single=vcv1[1,1],logL1=logL1,
+ k1=2,sig2.multiple=sig.i,a.multiple=a2,vcv.multiple=vcv2[1:p,1:p],
+ logL.multiple=logL2,k2=p+1,P.sim=Psim,convergence=converged)
+ }
+ class(xx)<-"brownie.lite"
+ return(xx)
+}
+
+## S3 print method for object of class "brownie.lite"
+## written by Liam J. Revell 2013, 2020
+
+print.brownie.lite<-function(x, ...){
+ if(hasArg(digits)) digits<-list(...)$digits
+ else digits<-getOption("digits")
+ x<-lapply(x,function(a,b) if(is.numeric(a)) round(a,b) else a,b=digits)
+ cat("ML single-rate model:\n")
+ obj<-matrix(c(x$sig2.single,sqrt(x$var.single),
+ x$a.single,x$k1,x$logL1),1,5,
+ dimnames=list("value",c("s^2","se","a","k","logL")))
+ print(obj,digits=digits)
+ cat("\nML multi-rate model:\n")
+ nn<-c(unlist(strsplit(paste("s^2(",names(x$sig2.multiple),")__",
+ "se(",names(x$sig2.multiple),")",sep=""),"__")),"a","k",
+ "logL")
+ obj<-matrix(c(as.vector(rbind(x$sig2.multiple,sqrt(diag(x$vcv.multiple)))),
+ x$a.multiple,x$k2,x$logL.multiple),1,2*length(x$sig2.multiple)+3,
+ dimnames=list("value",nn))
+ print(obj,digits=digits)
+ if(!is.null(x$P.chisq)) cat(paste("\nP-value (based on X^2):",x$P.chisq,"\n\n"))
+ else if(!is.null(x$P.sim)) cat(paste("\nP-value (based on simulation):",
+ x$P.sim,"\n\n"))
+ if(x$convergence[1]=="Optimization has converged.")
+ cat("R thinks it has found the ML solution.\n\n")
+ else cat("Optimization may not have converged.\n\n")
+}
+
+# function computes the likelihood for a single rate with sampling error
+# written by Liam J. Revell 2012
+
+lik.single<-function(theta,y,C,se){
+ n<-length(y)
+ sig<-theta[1]
+ a<-theta[2]
+ E<-diag(se^2)
+ logL<-as.numeric(-t(y-a)%*%solve(sig*C+E)%*%(y-a)/2-
+ n*log(2*pi)/2-determinant(sig*C+E)$modulus[1]/2)
+ return(-logL)
+}
+
+# function computes the likelihood for multiple rates
+# written by Liam J. Revell 2012
+
+lik.multiple<-function(theta,y,C,se=NULL){
+ n<-length(y); p<-length(C)
+ sig<-theta[1:p]
+ a<-theta[p+1]
+ V<-matrix(0,length(y),length(y))
+ for(i in 1:p) V<-V+sig[i]*C[[i]]
+ E<-diag(se^2)
+ logL<--t(y-a)%*%solve(V+E)%*%(y-a)/2-n*log(2*pi)/2-
+ determinant(V+E)$modulus[1]/2
+ return(-logL)
+}
+
+## S3 logLik method for object class
+
+logLik.brownie.lite<-function(object,...){
+ lik<-setNames(
+ c(object$logL1,object$logL.multiple),
+ c("single-rate","multi-rate"))
+ attr(lik,"df")<-c(object$k1,object$k2)
+ lik
+}
diff --git a/R/brownieREML.R b/R/brownieREML.R
index 9640b50..00b7789 100644
--- a/R/brownieREML.R
+++ b/R/brownieREML.R
@@ -1,87 +1,87 @@
-## This function is a simplified REML version of brownie.lite()
-## written by Liam J. Revell 2011, 2013, 2019, 2021
-
-brownieREML<-function(tree,x,maxit=2000,...){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- if(!inherits(tree,"simmap")) tree<-paintSubTree(tree,Ntip(tree)+1,"1")
- ## optional arguments
- if(hasArg(tol)) tol<-list(...)$tol
- else tol<-1e-8
- # bookkeeping
- if(!is.binary(tree)) tree<-multi2di(tree,random=FALSE)
- x<-x[tree$tip.label] # order in tip.label order
- n<-length(x) # number of species
- p<-ncol(tree$mapped.edge) # number of states
- # fit the single rate model
- lik1<-function(sig1,tree,x){
- tt<-scaleByMap(tree,setNames(rep(sig1,p),colnames(tree$mapped.edge)))
- picX<-pic(x,tt,scaled=FALSE,var.contrasts=TRUE)
- logL<-sum(dnorm(picX[,1],sd=sqrt(picX[,2]),log=TRUE))
- return(-logL)
- }
- sig1<-mean(pic(x,tree)^2)
- logL1<--lik1(sig1,tree,x)
- H<-optimHess(sig1,lik1,tree=tree,x=x)
- v1<-1/H
- # fit the multiple rate model
- lik2<-function(sig2,tree,x){
- tt<-scaleByMap(tree,sig2)
- picX<-pic(x,tt,scaled=F,var.contrasts=T)
- logL<-sum(dnorm(picX[,1],sd=sqrt(picX[,2]),log=TRUE))
- return(-logL)
- }
- YY<-optim(setNames(rep(1,p)*runif(n=p),colnames(tree$mapped.edge)),lik2,tree=tree,x=x,method="L-BFGS-B",lower=rep(1e-8,p))
- sig2<-YY$par
- obj<-optimHess(sig2,lik2,tree=tree,x=x)
- if(any(diag(obj)<tol)){
- ii<-which(diag(obj)>0)
- H<-obj[ii,ii]
- v2<-matrix(Inf,nrow(obj),ncol(obj))
- v2[ii,ii]<-if(length(H)>1) solve(H) else 1/H
- } else v2<-if(length(sig2)>1) solve(obj) else 1/obj
- logL2<--YY$value
- if(YY$convergence==0) converged<-"Optimization has converged."
- else converged<-"Optimization may not have converged. Consider increasing maxit."
- convergence=(YY$convergence==0)
- obj<-list(sig2.single=sig1,var.single=v1,logL1=logL1,k1=1,sig2.multiple=sig2,vcv.multiple=v2,logL.multiple=logL2,
- k2=length(sig2),convergence=converged)
- class(obj)<-"brownieREML"
- obj
-}
-
-# This function scales a mapped tree by sig2
-# written by Liam J. Revell 2011
-scaleByMap<-function(mtree,sig2){
- edge.length<-if(length(sig2)>1) mtree$mapped.edge[,names(sig2)]%*%sig2 else mtree$mapped.edge*sig2
- tree<-list(Nnode=mtree$Nnode,edge=mtree$edge,tip.label=mtree$tip.label,edge.length=edge.length[,1])
- class(tree)<-"phylo"
- return(tree)
-}
-
-## S3 print method for "brownieREML"
-## S3 print method for object of class "brownie.lite"
-## written by Liam J. Revell 2013, 2022
-
-print.brownieREML<-function(x, ...){
- if(hasArg(digits)) digits<-list(...)$digits
- else digits<-getOption("digits")
- x<-lapply(x,function(a,b) if(is.numeric(a)) round(a,b) else a,b=digits)
- cat("REML single-rate model:\n")
- obj<-matrix(c(x$sig2.single,sqrt(x$var.single),x$k1,x$logL1),1,4,
- dimnames=list("value",c("s^2","se","k","logL")))
- print(obj,digits=digits)
- cat("\nREML multi-rate model:\n")
- nn<-c(unlist(strsplit(paste("s^2(",names(x$sig2.multiple),")__",
- "se(",names(x$sig2.multiple),")",sep=""),"__")),"k",
- "logL")
- obj<-matrix(c(as.vector(rbind(x$sig2.multiple,sqrt(diag(x$vcv.multiple)))),
- x$k2,x$logL.multiple),1,2*length(x$sig2.multiple)+2,
- dimnames=list("value",nn))
- print(obj,digits=digits)
- if(!is.null(x$P.chisq)) cat(paste("\nP-value (based on X^2):",x$P.chisq,"\n\n"))
- else if(!is.null(x$P.sim)) cat(paste("\nP-value (based on simulation):",
- x$P.sim,"\n\n"))
- if(x$convergence[1]=="Optimization has converged.")
- cat("R thinks it has found the ML solution.\n\n")
- else cat("Optimization may not have converged.\n\n")
-}
+## This function is a simplified REML version of brownie.lite()
+## written by Liam J. Revell 2011, 2013, 2019, 2021
+
+brownieREML<-function(tree,x,maxit=2000,...){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ if(!inherits(tree,"simmap")) tree<-paintSubTree(tree,Ntip(tree)+1,"1")
+ ## optional arguments
+ if(hasArg(tol)) tol<-list(...)$tol
+ else tol<-1e-8
+ # bookkeeping
+ if(!is.binary(tree)) tree<-multi2di(tree,random=FALSE)
+ x<-x[tree$tip.label] # order in tip.label order
+ n<-length(x) # number of species
+ p<-ncol(tree$mapped.edge) # number of states
+ # fit the single rate model
+ lik1<-function(sig1,tree,x){
+ tt<-scaleByMap(tree,setNames(rep(sig1,p),colnames(tree$mapped.edge)))
+ picX<-pic(x,tt,scaled=FALSE,var.contrasts=TRUE)
+ logL<-sum(dnorm(picX[,1],sd=sqrt(picX[,2]),log=TRUE))
+ return(-logL)
+ }
+ sig1<-mean(pic(x,tree)^2)
+ logL1<--lik1(sig1,tree,x)
+ H<-optimHess(sig1,lik1,tree=tree,x=x)
+ v1<-1/H
+ # fit the multiple rate model
+ lik2<-function(sig2,tree,x){
+ tt<-scaleByMap(tree,sig2)
+ picX<-pic(x,tt,scaled=F,var.contrasts=T)
+ logL<-sum(dnorm(picX[,1],sd=sqrt(picX[,2]),log=TRUE))
+ return(-logL)
+ }
+ YY<-optim(setNames(rep(1,p)*runif(n=p),colnames(tree$mapped.edge)),lik2,tree=tree,x=x,method="L-BFGS-B",lower=rep(1e-8,p))
+ sig2<-YY$par
+ obj<-optimHess(sig2,lik2,tree=tree,x=x)
+ if(any(diag(obj)<tol)){
+ ii<-which(diag(obj)>0)
+ H<-obj[ii,ii]
+ v2<-matrix(Inf,nrow(obj),ncol(obj))
+ v2[ii,ii]<-if(length(H)>1) solve(H) else 1/H
+ } else v2<-if(length(sig2)>1) solve(obj) else 1/obj
+ logL2<--YY$value
+ if(YY$convergence==0) converged<-"Optimization has converged."
+ else converged<-"Optimization may not have converged. Consider increasing maxit."
+ convergence=(YY$convergence==0)
+ obj<-list(sig2.single=sig1,var.single=v1,logL1=logL1,k1=1,sig2.multiple=sig2,vcv.multiple=v2,logL.multiple=logL2,
+ k2=length(sig2),convergence=converged)
+ class(obj)<-"brownieREML"
+ obj
+}
+
+# This function scales a mapped tree by sig2
+# written by Liam J. Revell 2011
+scaleByMap<-function(mtree,sig2){
+ edge.length<-if(length(sig2)>1) mtree$mapped.edge[,names(sig2)]%*%sig2 else mtree$mapped.edge*sig2
+ tree<-list(Nnode=mtree$Nnode,edge=mtree$edge,tip.label=mtree$tip.label,edge.length=edge.length[,1])
+ class(tree)<-"phylo"
+ return(tree)
+}
+
+## S3 print method for "brownieREML"
+## S3 print method for object of class "brownie.lite"
+## written by Liam J. Revell 2013, 2022
+
+print.brownieREML<-function(x, ...){
+ if(hasArg(digits)) digits<-list(...)$digits
+ else digits<-getOption("digits")
+ x<-lapply(x,function(a,b) if(is.numeric(a)) round(a,b) else a,b=digits)
+ cat("REML single-rate model:\n")
+ obj<-matrix(c(x$sig2.single,sqrt(x$var.single),x$k1,x$logL1),1,4,
+ dimnames=list("value",c("s^2","se","k","logL")))
+ print(obj,digits=digits)
+ cat("\nREML multi-rate model:\n")
+ nn<-c(unlist(strsplit(paste("s^2(",names(x$sig2.multiple),")__",
+ "se(",names(x$sig2.multiple),")",sep=""),"__")),"k",
+ "logL")
+ obj<-matrix(c(as.vector(rbind(x$sig2.multiple,sqrt(diag(x$vcv.multiple)))),
+ x$k2,x$logL.multiple),1,2*length(x$sig2.multiple)+2,
+ dimnames=list("value",nn))
+ print(obj,digits=digits)
+ if(!is.null(x$P.chisq)) cat(paste("\nP-value (based on X^2):",x$P.chisq,"\n\n"))
+ else if(!is.null(x$P.sim)) cat(paste("\nP-value (based on simulation):",
+ x$P.sim,"\n\n"))
+ if(x$convergence[1]=="Optimization has converged.")
+ cat("R thinks it has found the ML solution.\n\n")
+ else cat("Optimization may not have converged.\n\n")
+}
diff --git a/R/collapseTree.R b/R/collapseTree.R
index a084045..5d807af 100644
--- a/R/collapseTree.R
+++ b/R/collapseTree.R
@@ -1,253 +1,253 @@
-## function to interactively expand and contract subtrees on a phylogeny
-## inspired by the phylogeny interface of sharksrays.org by Gavin Naylor
-## written by Liam J. Revell 2015, 2016, 2017, 2018, 2020
-
-collapseTree<-function(tree,...){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- if(inherits(tree,"simmap")) tree<-as.phylo(tree)
- if(hasArg(nodes)) nodes<-list(...)$nodes
- else nodes<-TRUE
- if(hasArg(hold)) hold<-list(...)$hold
- else hold<-TRUE
- if(hasArg(drop.extinct)) drop.extinct<-list(...)$drop.extinct
- else drop.extinct<-TRUE
- if(is.null(tree$edge.length)){
- no.edge<-TRUE
- tree<-compute.brlen(tree,power=0.5)
- } else no.edge<-FALSE
- cat("Click on the nodes that you would like to collapse...\n")
- flush.console()
- ## turn off locator bell (it's annoying)
- options(locatorBell=FALSE)
- ## check for node labels
- if(is.null(tree$node.label)) tree$node.label<-as.character(Ntip(tree)+1:tree$Nnode)
- else if(any(tree$node.label=="")){
- tree$node.label[which(tree$node.label)==""]<-
- which(tree$node.label=="")+Ntip(tree)
- }
- ## remove any spaces
- tree$node.label<-sapply(tree$node.label,gsub,pattern=" ",replacement="_")
- tree$tip.label<-sapply(tree$tip.label,gsub,pattern=" ",replacement="_")
- ## copy original tree:
- otree<-tree<-reorder(tree)
- ## plot initial tree:
- if(hold) dev.hold()
- fan(tree,...)
- lastPP<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- points(x=lastPP$xx[1:Ntip(tree)],y=lastPP$yy[1:Ntip(tree)],
- pch=21,col="blue",bg="white",cex=0.8)
- points(x=lastPP$xx[1:tree$Nnode+Ntip(tree)],
- y=lastPP$yy[1:tree$Nnode+Ntip(tree)],pch=21,
- col="blue",bg="white",cex=1.2)
- rect(par()$usr[1],par()$usr[4]-3*strheight("W"),par()$usr[2],par()$usr[4],
- border=0,col=make.transparent("blue",0.2))
- textbox(x=par()$usr[1:2],y=par()$usr[4],
- c("Click nodes to collapse or expand\nRIGHT CLICK to stop"),
- justify="c",border=0)
- dev.flush()
- x<-unlist(locator(1))
- if(!is.null(x)){
- y<-x[2]
- x<-x[1]
- d<-sqrt((x-lastPP$xx)^2+(y-lastPP$yy)^2)
- nn<-which(d==min(d,na.rm=TRUE))
- ## collapse tree & replot:
- while(!is.null(x)){
- obj<-list(tree)
- if(nn>(Ntip(tree)+1)){
- obj<-splitTree(tree,list(node=nn,
- bp=tree$edge.length[which(tree$edge[,2]==nn)]))
- obj[[1]]$tip.label[which(obj[[1]]$tip.label=="NA")]<-
- tree$node.label[nn-Ntip(tree)]
- tips<-which(tree$tip.label%in%obj[[1]]$tip.label)
- theta<-atan(lastPP$yy[nn]/lastPP$xx[nn])
- if(lastPP$yy[nn]>0&&lastPP$xx[nn]<0) theta<-pi+theta
- else if(lastPP$yy[nn]<0&&lastPP$xx[nn]<0) theta<-pi+theta
- else if(lastPP$yy[nn]<0&&lastPP$xx[nn]>0) theta<-2*pi+theta
- ii<-which((c(tips,Ntip(tree)+1)-c(0,tips))>1)
- if(ii>1&&ii<=length(tips))
- tips<-c(tips[1:(ii-1)],theta/(2*pi)*Ntip(tree),tips[ii:length(tips)])
- else if(ii==1) tips<-c(theta/(2*pi)*Ntip(tree),tips)
- else if(ii>length(tips)) tips<-c(tips,theta/(2*pi)*Ntip(tree))
- tree<-read.tree(text=write.tree(obj[[1]]))
- M<-matrix(NA,min(c(max(4,Ntip(obj[[2]])),10)),length(tips))
- for(i in 1:ncol(M)) M[,i]<-seq(from=tips[i],to=i,length.out=nrow(M))
- colnames(M)<-tree$tip.label
- maxY<-seq(from=sum(sapply(obj,Ntip))-length(obj)+1,to=Ntip(tree),
- length.out=nrow(M))
- pw<-reorder(tree,"pruningwise")
- H<-nodeHeights(tree)
- for(i in 1:nrow(M)){
- if(hold) dev.hold()
- fan(tree,pw,H,xlim=lastPP$x.lim,ylim=lastPP$y.lim,
- tips=M[i,],maxY=maxY[i],...)
- rect(par()$usr[1],par()$usr[4]-3*strheight("W"),
- par()$usr[2],par()$usr[4],
- border=0,col=make.transparent("blue",0.2))
- textbox(x=par()$usr[1:2],y=par()$usr[4],
- c("Click nodes to collapse or expand\nRIGHT CLICK to stop"),
- justify="c",border=0)
- if(nodes||i==nrow(M)){
- lastPP<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- points(x=lastPP$xx[1:Ntip(tree)],y=lastPP$yy[1:Ntip(tree)],
- pch=21,col="blue",bg="white",cex=0.8)
- points(x=lastPP$xx[1:tree$Nnode+Ntip(tree)],
- y=lastPP$yy[1:tree$Nnode+Ntip(tree)],pch=21,
- col="blue",bg="white",cex=1.2)
- }
- dev.flush()
- }
- } else if(nn<=Ntip(tree)) {
- if(tree$tip.label[nn]%in%otree$node.label){
- on<-which(otree$node.label==tree$tip.label[nn])+Ntip(otree)
- obj<-splitTree(otree,list(node=on,
- bp=otree$edge.length[which(otree$edge[,2]==on)]))
- nlabel<-tree$tip.label[nn]
- tree$tip.label[nn]<-"NA"
- if(nn==1) tips<-c(rep(nn,Ntip(obj[[2]])),(nn+1):Ntip(tree))
- else if(nn>1&&nn<Ntip(tree))
- tips<-c(1:(nn-1),rep(nn,Ntip(obj[[2]])),(nn+1):Ntip(tree))
- else if(nn==Ntip(tree)) tips<-c(1:(nn-1),rep(nn,Ntip(obj[[2]])))
- tree<-read.tree(text=write.tree(paste.tree(tree,obj[[2]])))
- M<-matrix(NA,min(c(max(4,Ntip(obj[[2]])),10)),length(tips))
- for(i in 1:ncol(M)) M[,i]<-seq(from=tips[i],to=i,length.out=nrow(M))
- colnames(M)<-tree$tip.label
- pw<-reorder(tree,"pruningwise")
- H<-nodeHeights(tree)
- for(i in 1:nrow(M)){
- if(hold) dev.hold()
- fan(tree,pw,H,xlim=lastPP$x.lim,ylim=lastPP$y.lim,
- tips=M[i,],maxY=NULL,...)
- rect(par()$usr[1],par()$usr[4]-3*strheight("W"),
- par()$usr[2],par()$usr[4],
- border=0,col=make.transparent("blue",0.2))
- textbox(x=par()$usr[1:2],y=par()$usr[4],
- c("Click nodes to collapse or expand \nRIGHT CLICK to stop"),
- justify="c",border=0)
- if(nodes||i==nrow(M)){
- lastPP<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- points(x=lastPP$xx[1:Ntip(tree)],y=lastPP$yy[1:Ntip(tree)],
- pch=21,col="blue",bg="white",cex=0.8)
- points(x=lastPP$xx[1:tree$Nnode+Ntip(tree)],
- y=lastPP$yy[1:tree$Nnode+Ntip(tree)],pch=21,
- col="blue",bg="white",cex=1.2)
- }
- dev.flush()
- }
- }
- } else {
- cat("Collapsing to the root is not permitted. Choose another node.\n")
- flush.console()
- }
- x<-unlist(locator(1))
- if(!is.null(x)){
- y<-x[2]
- x<-x[1]
- lastPP<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- d<-sqrt((x-lastPP$xx)^2+(y-lastPP$yy)^2)
- nn<-which(d==min(d,na.rm=TRUE))
- }
- }
- }
- ## turn locator bell back on
- options(locatorBell=TRUE)
- if(drop.extinct){
- if(!is.ultrametric(otree))
- cat("Input tree was not ultrametric. Ignoring argument drop.extinct.\n")
- else {
- th<-setNames(sapply(1:Ntip(tree),nodeheight,tree=tree),tree$tip.label)
- tips<-names(th)[which(th<(mean(sapply(1:Ntip(otree),
- nodeheight,tree=otree))-.Machine$double.eps^0.5))]
- tree<-drop.tip(tree,tips)
- }
- }
- if(no.edge) tree$edge.length<-NULL
- tree
-}
-
-circles<-function(x,y,r,col="blue")
- nulo<-mapply(draw.circle,x=x,y=y,radius=r,MoreArgs=list(border=col,
- col="white",nv=20))
-
-# simplified function to plot tree in type "fan"
-# written by Liam J. Revell 2015
-fan<-function(tree,pw=NULL,nH=NULL,colors="black",fsize=0.6,ftype="i",lwd=1,mar=rep(0.1,4),
- add=FALSE,part=1,xlim=NULL,ylim=NULL,tips=NULL,maxY=NULL,...){
- ## set colors
- if(length(colors)==1) colors<-rep(colors,nrow(tree$edge))
- ## set font
- ftype<-which(c("off","reg","b","i","bi")==ftype)-1
- # reorder
- cw<-tree
- if(is.null(pw)) pw<-reorder(tree,"pruningwise")
- # count nodes and tips
- n<-Ntip(cw)
- m<-cw$Nnode
- # get Y coordinates on uncurved space
- Y<-vector(length=m+n)
- if(is.null(tips)) tips<-1:n
- if(part<1.0) Y[cw$edge[cw$edge[,2]<=n,2]]<-0:(n-1)
- else Y[cw$edge[cw$edge[,2]<=n,2]]<-tips
- nodes<-unique(pw$edge[,1])
- for(i in 1:m){
- desc<-pw$edge[which(pw$edge[,1]==nodes[i]),2]
- Y[nodes[i]]<-(min(Y[desc])+max(Y[desc]))/2
- }
- if(is.null(maxY)) maxY<-max(Y)
- Y<-setNames(Y/maxY*2*pi,1:(n+m))
- Y<-part*cbind(Y[as.character(tree$edge[,2])],Y[as.character(tree$edge[,2])])
- R<-if(is.null(nH)) nodeHeights(cw) else nH
- # now put into a circular coordinate system
- x<-R*cos(Y)
- y<-R*sin(Y)
- # optimize x & y limits
- par(mar=mar)
- offsetFudge<-1.37 # empirically determined
- offset<-0
- if(is.null(xlim)||is.null(ylim)){
- pp<-par("pin")[1]
- sw<-fsize*(max(strwidth(cw$tip.label,units="inches")))+
- offsetFudge*offset*fsize*strwidth("W",units="inches")
- alp<-optimize(function(a,H,sw,pp) (2*a*1.04*max(H)+2*sw-pp)^2,H=R,sw=sw,pp=pp,
- interval=c(0,1e6))$minimum
- if(part<=0.25) x.lim<-y.lim<-c(0,max(R)+sw/alp)
- else if(part>0.25&&part<=0.5){
- x.lim<-c(-max(R)-sw/alp,max(R)+sw/alp)
- y.lim<-c(0,max(R)+sw/alp)
- } else x.lim<-y.lim<-c(-max(R)-sw/alp,max(R)+sw/alp)
- xlim<-x.lim
- ylim<-y.lim
- }
- # plot tree
- if(!add) plot.new()
- plot.window(xlim=xlim,ylim=ylim,asp=1)
- # plot radial lines (edges)
- segments(x[,1],y[,1],x[,2],y[,2],col=colors,lwd=lwd,lend=2)
- # plot circular lines
- ii<-sapply(1:m+n,function(x,y) which(y==x),y=cw$edge)
- r<-sapply(1:m+n,function(x,y,R) R[match(x,y)],y=cw$edge,R=R)
- a1<-sapply(ii,function(x,Y) min(Y[x]),Y=Y)
- a2<-sapply(ii,function(x,Y) max(Y[x]),Y=Y)
- draw.arc(rep(0,tree$Nnode),rep(0,tree$Nnode),r,a1,a2,lwd=lwd,col=colors)
- # plot labels
- cw$tip.label<-gsub("_"," ",cw$tip.label)
- for(i in 1:n){
- ii<-which(cw$edge[,2]==i)
- aa<-Y[ii,2]/(2*pi)*360
- adj<-if(aa>90&&aa<270) c(1,0.25) else c(0,0.25)
- tt<-if(aa>90&&aa<270) paste(cw$tip.label[i]," ",sep="") else paste(" ",
- cw$tip.label[i],sep="")
- aa<-if(aa>90&&aa<270) 180+aa else aa
- if(ftype) text(x[ii,2],y[ii,2],tt,srt=aa,adj=adj,cex=fsize,font=ftype)
- }
- PP<-list(type="fan",use.edge.length=TRUE,node.pos=1,
- show.tip.label=if(ftype) TRUE else FALSE,show.node.label=FALSE,
- font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE,label.offset=offset,
- x.lim=xlim,y.lim=ylim,direction="rightwards",tip.color="black",
- Ntip=Ntip(cw),Nnode=cw$Nnode,edge=cw$edge,
- xx=c(x[sapply(1:n,function(x,y) which(x==y)[1],y=tree$edge[,2]),2],x[1,1],
- if(m>1) x[sapply(2:m+n,function(x,y) which(x==y)[1],y=tree$edge[,2]),2] else c()),
- yy=c(y[sapply(1:n,function(x,y) which(x==y)[1],y=tree$edge[,2]),2],y[1,1],
- if(m>1) y[sapply(2:m+n,function(x,y) which(x==y)[1],y=tree$edge[,2]),2] else c()))
- assign("last_plot.phylo",PP,envir=.PlotPhyloEnv)
-}
+## function to interactively expand and contract subtrees on a phylogeny
+## inspired by the phylogeny interface of sharksrays.org by Gavin Naylor
+## written by Liam J. Revell 2015, 2016, 2017, 2018, 2020
+
+collapseTree<-function(tree,...){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ if(inherits(tree,"simmap")) tree<-as.phylo(tree)
+ if(hasArg(nodes)) nodes<-list(...)$nodes
+ else nodes<-TRUE
+ if(hasArg(hold)) hold<-list(...)$hold
+ else hold<-TRUE
+ if(hasArg(drop.extinct)) drop.extinct<-list(...)$drop.extinct
+ else drop.extinct<-TRUE
+ if(is.null(tree$edge.length)){
+ no.edge<-TRUE
+ tree<-compute.brlen(tree,power=0.5)
+ } else no.edge<-FALSE
+ cat("Click on the nodes that you would like to collapse...\n")
+ flush.console()
+ ## turn off locator bell (it's annoying)
+ options(locatorBell=FALSE)
+ ## check for node labels
+ if(is.null(tree$node.label)) tree$node.label<-as.character(Ntip(tree)+1:tree$Nnode)
+ else if(any(tree$node.label=="")){
+ tree$node.label[which(tree$node.label)==""]<-
+ which(tree$node.label=="")+Ntip(tree)
+ }
+ ## remove any spaces
+ tree$node.label<-sapply(tree$node.label,gsub,pattern=" ",replacement="_")
+ tree$tip.label<-sapply(tree$tip.label,gsub,pattern=" ",replacement="_")
+ ## copy original tree:
+ otree<-tree<-reorder(tree)
+ ## plot initial tree:
+ if(hold) dev.hold()
+ fan(tree,...)
+ lastPP<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ points(x=lastPP$xx[1:Ntip(tree)],y=lastPP$yy[1:Ntip(tree)],
+ pch=21,col="blue",bg="white",cex=0.8)
+ points(x=lastPP$xx[1:tree$Nnode+Ntip(tree)],
+ y=lastPP$yy[1:tree$Nnode+Ntip(tree)],pch=21,
+ col="blue",bg="white",cex=1.2)
+ rect(par()$usr[1],par()$usr[4]-3*strheight("W"),par()$usr[2],par()$usr[4],
+ border=0,col=make.transparent("blue",0.2))
+ textbox(x=par()$usr[1:2],y=par()$usr[4],
+ c("Click nodes to collapse or expand\nRIGHT CLICK to stop"),
+ justify="c",border=0)
+ dev.flush()
+ x<-unlist(locator(1))
+ if(!is.null(x)){
+ y<-x[2]
+ x<-x[1]
+ d<-sqrt((x-lastPP$xx)^2+(y-lastPP$yy)^2)
+ nn<-which(d==min(d,na.rm=TRUE))
+ ## collapse tree & replot:
+ while(!is.null(x)){
+ obj<-list(tree)
+ if(nn>(Ntip(tree)+1)){
+ obj<-splitTree(tree,list(node=nn,
+ bp=tree$edge.length[which(tree$edge[,2]==nn)]))
+ obj[[1]]$tip.label[which(obj[[1]]$tip.label=="NA")]<-
+ tree$node.label[nn-Ntip(tree)]
+ tips<-which(tree$tip.label%in%obj[[1]]$tip.label)
+ theta<-atan(lastPP$yy[nn]/lastPP$xx[nn])
+ if(lastPP$yy[nn]>0&&lastPP$xx[nn]<0) theta<-pi+theta
+ else if(lastPP$yy[nn]<0&&lastPP$xx[nn]<0) theta<-pi+theta
+ else if(lastPP$yy[nn]<0&&lastPP$xx[nn]>0) theta<-2*pi+theta
+ ii<-which((c(tips,Ntip(tree)+1)-c(0,tips))>1)
+ if(ii>1&&ii<=length(tips))
+ tips<-c(tips[1:(ii-1)],theta/(2*pi)*Ntip(tree),tips[ii:length(tips)])
+ else if(ii==1) tips<-c(theta/(2*pi)*Ntip(tree),tips)
+ else if(ii>length(tips)) tips<-c(tips,theta/(2*pi)*Ntip(tree))
+ tree<-read.tree(text=write.tree(obj[[1]]))
+ M<-matrix(NA,min(c(max(4,Ntip(obj[[2]])),10)),length(tips))
+ for(i in 1:ncol(M)) M[,i]<-seq(from=tips[i],to=i,length.out=nrow(M))
+ colnames(M)<-tree$tip.label
+ maxY<-seq(from=sum(sapply(obj,Ntip))-length(obj)+1,to=Ntip(tree),
+ length.out=nrow(M))
+ pw<-reorder(tree,"pruningwise")
+ H<-nodeHeights(tree)
+ for(i in 1:nrow(M)){
+ if(hold) dev.hold()
+ fan(tree,pw,H,xlim=lastPP$x.lim,ylim=lastPP$y.lim,
+ tips=M[i,],maxY=maxY[i],...)
+ rect(par()$usr[1],par()$usr[4]-3*strheight("W"),
+ par()$usr[2],par()$usr[4],
+ border=0,col=make.transparent("blue",0.2))
+ textbox(x=par()$usr[1:2],y=par()$usr[4],
+ c("Click nodes to collapse or expand\nRIGHT CLICK to stop"),
+ justify="c",border=0)
+ if(nodes||i==nrow(M)){
+ lastPP<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ points(x=lastPP$xx[1:Ntip(tree)],y=lastPP$yy[1:Ntip(tree)],
+ pch=21,col="blue",bg="white",cex=0.8)
+ points(x=lastPP$xx[1:tree$Nnode+Ntip(tree)],
+ y=lastPP$yy[1:tree$Nnode+Ntip(tree)],pch=21,
+ col="blue",bg="white",cex=1.2)
+ }
+ dev.flush()
+ }
+ } else if(nn<=Ntip(tree)) {
+ if(tree$tip.label[nn]%in%otree$node.label){
+ on<-which(otree$node.label==tree$tip.label[nn])+Ntip(otree)
+ obj<-splitTree(otree,list(node=on,
+ bp=otree$edge.length[which(otree$edge[,2]==on)]))
+ nlabel<-tree$tip.label[nn]
+ tree$tip.label[nn]<-"NA"
+ if(nn==1) tips<-c(rep(nn,Ntip(obj[[2]])),(nn+1):Ntip(tree))
+ else if(nn>1&&nn<Ntip(tree))
+ tips<-c(1:(nn-1),rep(nn,Ntip(obj[[2]])),(nn+1):Ntip(tree))
+ else if(nn==Ntip(tree)) tips<-c(1:(nn-1),rep(nn,Ntip(obj[[2]])))
+ tree<-read.tree(text=write.tree(paste.tree(tree,obj[[2]])))
+ M<-matrix(NA,min(c(max(4,Ntip(obj[[2]])),10)),length(tips))
+ for(i in 1:ncol(M)) M[,i]<-seq(from=tips[i],to=i,length.out=nrow(M))
+ colnames(M)<-tree$tip.label
+ pw<-reorder(tree,"pruningwise")
+ H<-nodeHeights(tree)
+ for(i in 1:nrow(M)){
+ if(hold) dev.hold()
+ fan(tree,pw,H,xlim=lastPP$x.lim,ylim=lastPP$y.lim,
+ tips=M[i,],maxY=NULL,...)
+ rect(par()$usr[1],par()$usr[4]-3*strheight("W"),
+ par()$usr[2],par()$usr[4],
+ border=0,col=make.transparent("blue",0.2))
+ textbox(x=par()$usr[1:2],y=par()$usr[4],
+ c("Click nodes to collapse or expand \nRIGHT CLICK to stop"),
+ justify="c",border=0)
+ if(nodes||i==nrow(M)){
+ lastPP<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ points(x=lastPP$xx[1:Ntip(tree)],y=lastPP$yy[1:Ntip(tree)],
+ pch=21,col="blue",bg="white",cex=0.8)
+ points(x=lastPP$xx[1:tree$Nnode+Ntip(tree)],
+ y=lastPP$yy[1:tree$Nnode+Ntip(tree)],pch=21,
+ col="blue",bg="white",cex=1.2)
+ }
+ dev.flush()
+ }
+ }
+ } else {
+ cat("Collapsing to the root is not permitted. Choose another node.\n")
+ flush.console()
+ }
+ x<-unlist(locator(1))
+ if(!is.null(x)){
+ y<-x[2]
+ x<-x[1]
+ lastPP<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ d<-sqrt((x-lastPP$xx)^2+(y-lastPP$yy)^2)
+ nn<-which(d==min(d,na.rm=TRUE))
+ }
+ }
+ }
+ ## turn locator bell back on
+ options(locatorBell=TRUE)
+ if(drop.extinct){
+ if(!is.ultrametric(otree))
+ cat("Input tree was not ultrametric. Ignoring argument drop.extinct.\n")
+ else {
+ th<-setNames(sapply(1:Ntip(tree),nodeheight,tree=tree),tree$tip.label)
+ tips<-names(th)[which(th<(mean(sapply(1:Ntip(otree),
+ nodeheight,tree=otree))-.Machine$double.eps^0.5))]
+ tree<-drop.tip(tree,tips)
+ }
+ }
+ if(no.edge) tree$edge.length<-NULL
+ tree
+}
+
+circles<-function(x,y,r,col="blue")
+ nulo<-mapply(draw.circle,x=x,y=y,radius=r,MoreArgs=list(border=col,
+ col="white",nv=20))
+
+# simplified function to plot tree in type "fan"
+# written by Liam J. Revell 2015
+fan<-function(tree,pw=NULL,nH=NULL,colors="black",fsize=0.6,ftype="i",lwd=1,mar=rep(0.1,4),
+ add=FALSE,part=1,xlim=NULL,ylim=NULL,tips=NULL,maxY=NULL,...){
+ ## set colors
+ if(length(colors)==1) colors<-rep(colors,nrow(tree$edge))
+ ## set font
+ ftype<-which(c("off","reg","b","i","bi")==ftype)-1
+ # reorder
+ cw<-tree
+ if(is.null(pw)) pw<-reorder(tree,"pruningwise")
+ # count nodes and tips
+ n<-Ntip(cw)
+ m<-cw$Nnode
+ # get Y coordinates on uncurved space
+ Y<-vector(length=m+n)
+ if(is.null(tips)) tips<-1:n
+ if(part<1.0) Y[cw$edge[cw$edge[,2]<=n,2]]<-0:(n-1)
+ else Y[cw$edge[cw$edge[,2]<=n,2]]<-tips
+ nodes<-unique(pw$edge[,1])
+ for(i in 1:m){
+ desc<-pw$edge[which(pw$edge[,1]==nodes[i]),2]
+ Y[nodes[i]]<-(min(Y[desc])+max(Y[desc]))/2
+ }
+ if(is.null(maxY)) maxY<-max(Y)
+ Y<-setNames(Y/maxY*2*pi,1:(n+m))
+ Y<-part*cbind(Y[as.character(tree$edge[,2])],Y[as.character(tree$edge[,2])])
+ R<-if(is.null(nH)) nodeHeights(cw) else nH
+ # now put into a circular coordinate system
+ x<-R*cos(Y)
+ y<-R*sin(Y)
+ # optimize x & y limits
+ par(mar=mar)
+ offsetFudge<-1.37 # empirically determined
+ offset<-0
+ if(is.null(xlim)||is.null(ylim)){
+ pp<-par("pin")[1]
+ sw<-fsize*(max(strwidth(cw$tip.label,units="inches")))+
+ offsetFudge*offset*fsize*strwidth("W",units="inches")
+ alp<-optimize(function(a,H,sw,pp) (2*a*1.04*max(H)+2*sw-pp)^2,H=R,sw=sw,pp=pp,
+ interval=c(0,1e6))$minimum
+ if(part<=0.25) x.lim<-y.lim<-c(0,max(R)+sw/alp)
+ else if(part>0.25&&part<=0.5){
+ x.lim<-c(-max(R)-sw/alp,max(R)+sw/alp)
+ y.lim<-c(0,max(R)+sw/alp)
+ } else x.lim<-y.lim<-c(-max(R)-sw/alp,max(R)+sw/alp)
+ xlim<-x.lim
+ ylim<-y.lim
+ }
+ # plot tree
+ if(!add) plot.new()
+ plot.window(xlim=xlim,ylim=ylim,asp=1)
+ # plot radial lines (edges)
+ segments(x[,1],y[,1],x[,2],y[,2],col=colors,lwd=lwd,lend=2)
+ # plot circular lines
+ ii<-sapply(1:m+n,function(x,y) which(y==x),y=cw$edge)
+ r<-sapply(1:m+n,function(x,y,R) R[match(x,y)],y=cw$edge,R=R)
+ a1<-sapply(ii,function(x,Y) min(Y[x]),Y=Y)
+ a2<-sapply(ii,function(x,Y) max(Y[x]),Y=Y)
+ draw.arc(rep(0,tree$Nnode),rep(0,tree$Nnode),r,a1,a2,lwd=lwd,col=colors)
+ # plot labels
+ cw$tip.label<-gsub("_"," ",cw$tip.label)
+ for(i in 1:n){
+ ii<-which(cw$edge[,2]==i)
+ aa<-Y[ii,2]/(2*pi)*360
+ adj<-if(aa>90&&aa<270) c(1,0.25) else c(0,0.25)
+ tt<-if(aa>90&&aa<270) paste(cw$tip.label[i]," ",sep="") else paste(" ",
+ cw$tip.label[i],sep="")
+ aa<-if(aa>90&&aa<270) 180+aa else aa
+ if(ftype) text(x[ii,2],y[ii,2],tt,srt=aa,adj=adj,cex=fsize,font=ftype)
+ }
+ PP<-list(type="fan",use.edge.length=TRUE,node.pos=1,
+ show.tip.label=if(ftype) TRUE else FALSE,show.node.label=FALSE,
+ font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE,label.offset=offset,
+ x.lim=xlim,y.lim=ylim,direction="rightwards",tip.color="black",
+ Ntip=Ntip(cw),Nnode=cw$Nnode,edge=cw$edge,
+ xx=c(x[sapply(1:n,function(x,y) which(x==y)[1],y=tree$edge[,2]),2],x[1,1],
+ if(m>1) x[sapply(2:m+n,function(x,y) which(x==y)[1],y=tree$edge[,2]),2] else c()),
+ yy=c(y[sapply(1:n,function(x,y) which(x==y)[1],y=tree$edge[,2]),2],y[1,1],
+ if(m>1) y[sapply(2:m+n,function(x,y) which(x==y)[1],y=tree$edge[,2]),2] else c()))
+ assign("last_plot.phylo",PP,envir=.PlotPhyloEnv)
+}
diff --git a/R/compare.chronograms.R b/R/compare.chronograms.R
index a3ab1c8..115aecf 100644
--- a/R/compare.chronograms.R
+++ b/R/compare.chronograms.R
@@ -1,38 +1,38 @@
-## function to compare two time-trees
-## written by Liam J. Revell 2017
-
-compare.chronograms<-function(t1,t2,...){
- if(hasArg(colors)) colors<-list(...)$colors
- else colors<-sapply(c("blue","red"),make.transparent,alpha=0.4)
- if(hasArg(arr.colors)) arr.colors<-list(...)$arr.colors
- else arr.colors<-sapply(c("blue","red"),make.transparent,alpha=0.7)
- h1<-sapply(1:Ntip(t1),nodeheight,tree=t1)
- h2<-sapply(1:Ntip(t2),nodeheight,tree=t2)
- plotTree(if(max(h1)>max(h2)) t1 else t2,plot=FALSE,
- mar=c(4.1,1.1,1.1,1.1),direction="leftwards")
- xlim<-get("last_plot.phylo",envir=.PlotPhyloEnv)$x.lim[2:1]
- par(fg="transparent",new=TRUE)
- plotTree(t1,color=colors[1],mar=c(4.1,1.1,1.1,1.1),
- xlim=xlim,direction="leftwards",lwd=3)
- T1<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- par(fg="black")
- axis(1)
- par(fg="transparent")
- plotTree(t2,color=colors[2],mar=c(4.1,1.1,1.1,1.1),
- xlim=xlim,add=TRUE,direction="leftwards",ftype="off",lwd=3)
- T2<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- par(fg="black")
- for(i in 1:t1$Nnode+Ntip(t1)){
- arrows(T1$xx[i],T1$yy[i],T2$xx[i],T2$yy[i],lwd=2,
- col=if(T1$xx[i]>T2$xx[i]) arr.colors[2] else arr.colors[1],
- length=0.1)
- }
- h<-mapply(function(x,y) if(x<y) x else y,x=T1$xx[1:Ntip(t1)],
- y=T2$xx[1:Ntip(t2)])
- text(rep(min(h),Ntip(t1)),T1$yy[1:Ntip(t1)],
- labels=t1$tip.label,font=3,pos=4,offset=0.1*max(c(h1,h2)))
- for(i in 1:Ntip(t1)) lines(c(h[i]+
- if(h[i]>min(h)) 0.005*diff(xlim) else 0,min(h)),
- rep(T1$yy[i],2),lty="dotted")
-}
-
+## function to compare two time-trees
+## written by Liam J. Revell 2017
+
+compare.chronograms<-function(t1,t2,...){
+ if(hasArg(colors)) colors<-list(...)$colors
+ else colors<-sapply(c("blue","red"),make.transparent,alpha=0.4)
+ if(hasArg(arr.colors)) arr.colors<-list(...)$arr.colors
+ else arr.colors<-sapply(c("blue","red"),make.transparent,alpha=0.7)
+ h1<-sapply(1:Ntip(t1),nodeheight,tree=t1)
+ h2<-sapply(1:Ntip(t2),nodeheight,tree=t2)
+ plotTree(if(max(h1)>max(h2)) t1 else t2,plot=FALSE,
+ mar=c(4.1,1.1,1.1,1.1),direction="leftwards")
+ xlim<-get("last_plot.phylo",envir=.PlotPhyloEnv)$x.lim[2:1]
+ par(fg="transparent",new=TRUE)
+ plotTree(t1,color=colors[1],mar=c(4.1,1.1,1.1,1.1),
+ xlim=xlim,direction="leftwards",lwd=3)
+ T1<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ par(fg="black")
+ axis(1)
+ par(fg="transparent")
+ plotTree(t2,color=colors[2],mar=c(4.1,1.1,1.1,1.1),
+ xlim=xlim,add=TRUE,direction="leftwards",ftype="off",lwd=3)
+ T2<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ par(fg="black")
+ for(i in 1:t1$Nnode+Ntip(t1)){
+ arrows(T1$xx[i],T1$yy[i],T2$xx[i],T2$yy[i],lwd=2,
+ col=if(T1$xx[i]>T2$xx[i]) arr.colors[2] else arr.colors[1],
+ length=0.1)
+ }
+ h<-mapply(function(x,y) if(x<y) x else y,x=T1$xx[1:Ntip(t1)],
+ y=T2$xx[1:Ntip(t2)])
+ text(rep(min(h),Ntip(t1)),T1$yy[1:Ntip(t1)],
+ labels=t1$tip.label,font=3,pos=4,offset=0.1*max(c(h1,h2)))
+ for(i in 1:Ntip(t1)) lines(c(h[i]+
+ if(h[i]>min(h)) 0.005*diff(xlim) else 0,min(h)),
+ rep(T1$yy[i],2),lty="dotted")
+}
+
diff --git a/R/consensus.edges.R b/R/consensus.edges.R
index 8b8eadc..5718c06 100644
--- a/R/consensus.edges.R
+++ b/R/consensus.edges.R
@@ -1,37 +1,40 @@
-## compute consensus edge lengths from a set of trees given (or not) a consensus topology
-## written by Liam J. Revell 2016, 2023
-
-consensus.edges<-function(trees,method=c("mean.edge","least.squares"),...){
- if(hasArg(rooted)) rooted<-list(...)$rooted
- else rooted<-if(all(sapply(trees,is.rooted))) TRUE else FALSE
- if(hasArg(consensus.tree)) consensus.tree<-list(...)$consensus.tree
- else consensus.tree<-consensus(trees,p=0.5,rooted=rooted)
- tree<-consensus.tree ## get rid of this cumbersome name
- if(hasArg(if.absent)) if.absent<-list(...)$if.absent
- else if.absent<-"zero"
- N<-length(trees)
- if(method[1]=="mean.edge"){
- M<-lapply(trees,function(x,y) rbind(matchLabels(y,x),matchNodes(y,x)),y=tree)
- nodes<-M[[1]][,1]
- edge.length<-vector(mode="numeric",length=length(nodes))
- for(i in 1:length(nodes)){
- ii<-which(tree$edge[,2]==nodes[i])
- n.absent<-0
- for(j in 1:N){
- edge.length[ii]<-edge.length[ii] +
- if(!is.na(M[[j]][i,2])) trees[[j]]$edge.length[which(trees[[j]]$edge[,2]==M[[j]][i,2])]/N
- else 0
- if(is.na(M[[j]][i,2])) n.absent<-n.absent+1
- }
- if(if.absent=="ignore") edge.length[ii]<-edge.length[ii]*N/(N-n.absent)
- }
- tree$edge.length<-edge.length
- } else if(method[1]=="least.squares"){
- D<-Reduce('+',lapply(trees,function(x,t) cophenetic(x)[t,t],t=tree$tip.label))/N
- if(rooted)
- method<-if(all(sapply(trees,is.ultrametric))) "ultrametric" else "tipdated"
- else method<-"unrooted"
- tree<-nnls.tree(D,tree=tree,rooted=rooted,method=method)
- }
- tree
+## compute consensus edge lengths from a set of trees given (or not) a consensus topology
+## written by Liam J. Revell 2016, 2023
+
+consensus.edges<-function(trees,method=c("mean.edge","least.squares"),...){
+ if(hasArg(rooted)) rooted<-list(...)$rooted
+ else rooted<-if(all(sapply(trees,is.rooted))) TRUE else FALSE
+ if(hasArg(consensus.tree)) consensus.tree<-list(...)$consensus.tree
+ else consensus.tree<-consensus(trees,p=0.5,rooted=rooted)
+ tree<-consensus.tree ## get rid of this cumbersome name
+ if(hasArg(if.absent)) if.absent<-list(...)$if.absent
+ else if.absent<-"zero"
+ N<-length(trees)
+ if(method[1]=="mean.edge"){
+ M<-lapply(trees,function(x,y) rbind(matchLabels(y,x),
+ matchNodes(y,x)),y=tree)
+ nodes<-M[[1]][,1]
+ edge.length<-vector(mode="numeric",length=length(nodes))
+ for(i in 1:length(nodes)){
+ ii<-which(tree$edge[,2]==nodes[i])
+ n.absent<-0
+ for(j in 1:N){
+ edge.length[ii]<-edge.length[ii] +
+ if(!is.na(M[[j]][i,2])) trees[[j]]$edge.length[which(trees[[j]]$edge[,2]==M[[j]][i,2])]/N
+ else 0
+ if(is.na(M[[j]][i,2])) n.absent<-n.absent+1
+ }
+ if(if.absent=="ignore")
+ edge.length[ii]<-edge.length[ii]*N/(N-n.absent)
+ }
+ tree$edge.length<-edge.length
+ } else if(method[1]=="least.squares"){
+ D<-Reduce('+',lapply(trees,function(x,t)
+ cophenetic(x)[t,t],t=tree$tip.label))/N
+ if(rooted){
+ method<-if(all(sapply(trees,is.ultrametric))) "ultrametric" else "unrooted"
+ } else method<-"unrooted"
+ tree<-nnls.tree(D,tree=tree,method=method)
+ }
+ tree
}
\ No newline at end of file
diff --git a/R/contMap.R b/R/contMap.R
index b3cf3d3..a9d62fd 100644
--- a/R/contMap.R
+++ b/R/contMap.R
@@ -1,215 +1,215 @@
-## function plots reconstructed values for ancestral characters along the edges of the tree
-## written by Liam J. Revell 2012-2023
-contMap<-function(tree,x,res=100,fsize=NULL,ftype=NULL,lwd=4,legend=NULL,
- lims=NULL,outline=TRUE,sig=3,type="phylogram",direction="rightwards",
- plot=TRUE,...){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- if(hasArg(mar)) mar<-list(...)$mar
- else mar<-rep(0.3,4)
- if(hasArg(offset)) offset<-list(...)$offset
- else offset<-NULL
- if(hasArg(method)) method<-list(...)$method
- else method<-"fastAnc"
- if(hasArg(hold)) hold<-list(...)$hold
- else hold<-TRUE
- if(hasArg(leg.txt)) leg.txt<-list(...)$leg.txt
- else leg.txt<-"trait value"
- h<-max(nodeHeights(tree))
- steps<-c(0:(res-1)/(res-1)*h,h+h/(res-1)) ## 0:res/res*(h+h/res)
- H<-nodeHeights(tree)
- if(method=="fastAnc") a<-fastAnc(tree,x)
- else if(method=="anc.ML") {
- fit<-anc.ML(tree,x)
- a<-fit$ace
- if(!is.null(fit$missing.x)) x<-c(x,fit$missing.x)
- } else if(method=="user"){
- if(hasArg(anc.states)) anc.states<-list(...)$anc.states
- else {
- cat("No ancestral states have been provided. Using states estimated with fastAnc.\n\n")
- a<-fastAnc(tree,x)
- }
- if(length(anc.states)<tree$Nnode){
- nodes<-as.numeric(names(anc.states))
- tt<-tree
- for(i in 1:length(nodes)){
- M<-matchNodes(tt,tree,method="distances")
- ii<-M[which(M[,2]==nodes[i]),1]
- tt<-bind.tip(tt,nodes[i],edge.length=0,where=ii)
- }
- a<-fastAnc(tt,c(x,anc.states))
- M<-matchNodes(tree,tt,method="distances")
- a<-a[as.character(M[,2])]
- names(a)<-M[,1]
- } else {
- if(is.null(names(anc.states))) names(anc.states)<-1:tree$Nnode+Ntip(tree)
- a<-anc.states[as.character(1:tree$Nnode+Ntip(tree))]
- }
- }
- y<-c(a,x[tree$tip.label])
- names(y)[1:Ntip(tree)+tree$Nnode]<-1:Ntip(tree)
- A<-matrix(y[as.character(tree$edge)],nrow(tree$edge),ncol(tree$edge))
- cols<-rainbow(1001,start=0,end=0.7)
- names(cols)<-0:1000
- if(is.null(lims)) lims<-c(min(y),max(y))
- trans<-0:1000/1000*(lims[2]-lims[1])+lims[1]
- names(trans)<-0:1000
- tree$maps<-vector(mode="list",length=nrow(tree$edge))
- for(i in 1:nrow(tree$edge)){
- XX<-cbind(c(H[i,1],steps[intersect(which(steps>H[i,1]),which(steps<H[i,2]))]),
- c(steps[intersect(which(steps>H[i,1]),which(steps<H[i,2]))],H[i,2]))-H[i,1]
- YY<-rowMeans(XX)
- if(!all(YY==0)){
- b<-vector()
- for(j in 1:length(YY))
- b[j]<-(A[i,1]/YY[j]+A[i,2]/(max(XX)-YY[j]))/(1/YY[j]+1/(max(XX)-YY[j]))
- } else b<-A[i,1]
- d<-sapply(b,getState,trans=trans)
- tree$maps[[i]]<-XX[,2]-XX[,1]
- names(tree$maps[[i]])<-d
- }
- tree$mapped.edge<-makeMappedEdge(tree$edge,tree$maps)
- tree$mapped.edge<-tree$mapped.edge[,order(as.numeric(colnames(tree$mapped.edge)))]
- class(tree)<-c("simmap",setdiff(class(tree),"simmap"))
- attr(tree,"map.order")<-"right-to-left"
- xx<-list(tree=tree,cols=cols,lims=lims)
- class(xx)<-"contMap"
- if(plot) plot.contMap(xx,fsize=fsize,ftype=ftype,lwd=lwd,legend=legend,outline=outline,
- sig=sig,type=type,mar=mar,direction=direction,offset=offset,hold=hold,leg.txt=leg.txt)
- invisible(xx)
-}
-
-## internally used function
-## written by Liam J. Revell 2012, 2017
-getState<-function(x,trans){
- if(x<=trans[1]) state<-names(trans)[1]
- else if(x>=trans[length(trans)]) state<-names(trans)[length(trans)]
- else {
- i<-1
- while(x>trans[i]){
- state<-names(trans)[i]
- i<-i+1
- }
- }
- state
-}
-
-## S3 print method for objects of class "contMap"
-## uses print.densityMap internally
-## written by Liam J. Revell 2012, 2013, 2014, 2015, 2016, 2023
-
-plot.contMap<-function(x,...){
- if(inherits(x,"contMap")){
- lims<-x$lims
- x<-list(tree=x$tree,cols=x$cols)
- class(x)<-"densityMap"
- } else stop("x should be an object of class \"contMap\"")
- H<-nodeHeights(x$tree)
- # get & set optional arguments
- if(hasArg(legend)) legend<-list(...)$legend
- else legend<-NULL
- if(hasArg(fsize)) fsize<-list(...)$fsize
- else fsize<-NULL
- if(hasArg(ftype)) ftype<-list(...)$ftype
- else ftype<-NULL
- if(hasArg(outline)) outline<-list(...)$outline
- else outline<-TRUE
- if(hasArg(lwd)) lwd<-list(...)$lwd
- else lwd<-4
- if(hasArg(sig)) sig<-list(...)$sig
- else sig<-3
- if(hasArg(type)) type<-list(...)$type
- else type<-"phylogram"
- if(hasArg(mar)) mar<-list(...)$mar
- else mar<-rep(0.3,4)
- if(hasArg(direction)) direction<-list(...)$direction
- else direction<-"rightwards"
- if(hasArg(offset)) offset<-list(...)$offset
- else offset<-NULL
- if(hasArg(xlim)) xlim<-list(...)$xlim
- else xlim<-NULL
- if(hasArg(ylim)) ylim<-list(...)$ylim
- else ylim<-NULL
- if(hasArg(hold)) hold<-list(...)$hold
- else hold<-TRUE
- if(is.null(legend)) legend<-0.5*max(H)
- if(is.null(fsize)) fsize<-c(1,1)
- if(length(fsize)==1) fsize<-rep(fsize,2)
- if(is.null(ftype)) ftype<-c("i","reg")
- if(length(ftype)==1) ftype<-c(ftype,"reg")
- if(hasArg(leg.txt)) leg.txt<-list(...)$leg.txt
- else leg.txt<-"trait value"
- if(hasArg(underscore)) underscore<-list(...)$underscore
- else underscore<-FALSE
- # done optional arguments
- leg.txt<-c(round(lims[1],sig),leg.txt,round(lims[2],sig))
- plot(x,fsize=fsize,ftype=ftype,lwd=lwd,legend=legend,outline=outline,leg.txt=leg.txt,
- type=type,mar=mar,direction=direction,offset=offset,xlim=xlim,ylim=ylim,hold=hold,
- underscore=underscore)
-}
-
-## S3 print method for object of class 'contMap'
-## written by Liam J. Revell 2013
-print.contMap<-function(x,digits=6,...){
- cat("Object of class \"contMap\" containing:\n\n")
- cat(paste("(1) A phylogenetic tree with ",length(x$tree$tip.label)," tips and ",x$tree$Nnode," internal nodes.\n\n",sep=""))
- cat(paste("(2) A mapped continuous trait on the range (",round(x$lims[1],digits),", ",round(x$lims[2],digits),").\n\n",sep=""))
-}
-
-## drop tips from an object of class 'contMap'
-## written by Liam J. Revell 2014, 2023
-drop.tip.contMap<-function(phy,tip,...){
- if(!inherits(phy,"contMap")) cat("phy should be an object of class \"contMap\"\n")
- else {
- phy$tree<-drop.tip.simmap(phy$tree,tip,...)
- return(phy)
- }
-}
-
-## add error bars to contMap plot
-## written by Liam J. Revell 2017
-errorbar.contMap<-function(obj,...){
- if(hasArg(x)) x<-list(...)$x
- else x<-setNames(sapply(1:Ntip(obj$tree),function(x,obj){
- ii<-which(obj$tree$edge[,2]==x)
- ss<-names(obj$tree$maps[[ii]][length(obj$tree$maps[[ii]])])
- obj$lims[1]+as.numeric(ss)/(length(obj$cols)-1)*diff(obj$lims)
- },obj=obj),obj$tree$tip.label)
- if(hasArg(scale.by.ci)) scale.by.ci<-list(...)$scale.by.ci
- else scale.by.ci<-TRUE
- if(hasArg(lwd)) lwd<-list(...)$lwd
- else lwd<-14
- tree<-obj$tree
- aa<-fastAnc(tree,x,CI=TRUE)
- xlim<-range(aa$CI95)
- if(xlim[2]>obj$lims[2]||xlim[1]<obj$lims[1]){
- cat(paste(" -----\n The range of the contMap object, presently (",
- round(obj$lims[1],4),",",
- round(obj$lims[2],4),
- "), should be equal to\n or greater than the range of the CIs on ancestral states: (",
- round(xlim[1],4),",",round(xlim[2],4),").\n",sep=""))
- cat(paste(" To ensure that your error bars are correctly plotted, please recompute your\n",
- " contMap object and increase lims.\n -----\n",sep=""))
- }
- d<-diff(obj$lims)
- if(scale.by.ci){
- v<-aa$CI95[,2]-aa$CI95[,1]
- v<-v/max(v)
- } else v<-rep(0.5,tree$Nnode)
- n<-length(obj$cols)-1
- lastPP<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- h<-max(nodeHeights(tree))
- for(i in 1:tree$Nnode){
- ii<-round((aa$CI95[i,1]-obj$lims[1])/d*n)
- jj<-round((aa$CI95[i,2]-obj$lims[1])/d*(n+1))
- cols<-obj$cols[ii:jj]
- add.color.bar(leg=0.1*h*v[i],cols=cols,prompt=FALSE,
- x=lastPP$xx[i+Ntip(tree)]-0.05*h*v[i],
- y=lastPP$yy[i+Ntip(tree)],title="",subtitle="",lims=NULL,
- lwd=lwd)
- }
-}
-
-keep.tip.contMap<-function(phy,tip,...){
- tips<-setdiff(phy$tree$tip.label,tip)
- drop.tip.contMap(phy,tip=tips,...)
-}
+## function plots reconstructed values for ancestral characters along the edges of the tree
+## written by Liam J. Revell 2012-2023
+contMap<-function(tree,x,res=100,fsize=NULL,ftype=NULL,lwd=4,legend=NULL,
+ lims=NULL,outline=TRUE,sig=3,type="phylogram",direction="rightwards",
+ plot=TRUE,...){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ if(hasArg(mar)) mar<-list(...)$mar
+ else mar<-rep(0.3,4)
+ if(hasArg(offset)) offset<-list(...)$offset
+ else offset<-NULL
+ if(hasArg(method)) method<-list(...)$method
+ else method<-"fastAnc"
+ if(hasArg(hold)) hold<-list(...)$hold
+ else hold<-TRUE
+ if(hasArg(leg.txt)) leg.txt<-list(...)$leg.txt
+ else leg.txt<-"trait value"
+ h<-max(nodeHeights(tree))
+ steps<-c(0:(res-1)/(res-1)*h,h+h/(res-1)) ## 0:res/res*(h+h/res)
+ H<-nodeHeights(tree)
+ if(method=="fastAnc") a<-fastAnc(tree,x)
+ else if(method=="anc.ML") {
+ fit<-anc.ML(tree,x)
+ a<-fit$ace
+ if(!is.null(fit$missing.x)) x<-c(x,fit$missing.x)
+ } else if(method=="user"){
+ if(hasArg(anc.states)) anc.states<-list(...)$anc.states
+ else {
+ cat("No ancestral states have been provided. Using states estimated with fastAnc.\n\n")
+ a<-fastAnc(tree,x)
+ }
+ if(length(anc.states)<tree$Nnode){
+ nodes<-as.numeric(names(anc.states))
+ tt<-tree
+ for(i in 1:length(nodes)){
+ M<-matchNodes(tt,tree,method="distances")
+ ii<-M[which(M[,2]==nodes[i]),1]
+ tt<-bind.tip(tt,nodes[i],edge.length=0,where=ii)
+ }
+ a<-fastAnc(tt,c(x,anc.states))
+ M<-matchNodes(tree,tt,method="distances")
+ a<-a[as.character(M[,2])]
+ names(a)<-M[,1]
+ } else {
+ if(is.null(names(anc.states))) names(anc.states)<-1:tree$Nnode+Ntip(tree)
+ a<-anc.states[as.character(1:tree$Nnode+Ntip(tree))]
+ }
+ }
+ y<-c(a,x[tree$tip.label])
+ names(y)[1:Ntip(tree)+tree$Nnode]<-1:Ntip(tree)
+ A<-matrix(y[as.character(tree$edge)],nrow(tree$edge),ncol(tree$edge))
+ cols<-rainbow(1001,start=0,end=0.7)
+ names(cols)<-0:1000
+ if(is.null(lims)) lims<-c(min(y),max(y))
+ trans<-0:1000/1000*(lims[2]-lims[1])+lims[1]
+ names(trans)<-0:1000
+ tree$maps<-vector(mode="list",length=nrow(tree$edge))
+ for(i in 1:nrow(tree$edge)){
+ XX<-cbind(c(H[i,1],steps[intersect(which(steps>H[i,1]),which(steps<H[i,2]))]),
+ c(steps[intersect(which(steps>H[i,1]),which(steps<H[i,2]))],H[i,2]))-H[i,1]
+ YY<-rowMeans(XX)
+ if(!all(YY==0)){
+ b<-vector()
+ for(j in 1:length(YY))
+ b[j]<-(A[i,1]/YY[j]+A[i,2]/(max(XX)-YY[j]))/(1/YY[j]+1/(max(XX)-YY[j]))
+ } else b<-A[i,1]
+ d<-sapply(b,getState,trans=trans)
+ tree$maps[[i]]<-XX[,2]-XX[,1]
+ names(tree$maps[[i]])<-d
+ }
+ tree$mapped.edge<-makeMappedEdge(tree$edge,tree$maps)
+ tree$mapped.edge<-tree$mapped.edge[,order(as.numeric(colnames(tree$mapped.edge)))]
+ class(tree)<-c("simmap",setdiff(class(tree),"simmap"))
+ attr(tree,"map.order")<-"right-to-left"
+ xx<-list(tree=tree,cols=cols,lims=lims)
+ class(xx)<-"contMap"
+ if(plot) plot.contMap(xx,fsize=fsize,ftype=ftype,lwd=lwd,legend=legend,outline=outline,
+ sig=sig,type=type,mar=mar,direction=direction,offset=offset,hold=hold,leg.txt=leg.txt)
+ invisible(xx)
+}
+
+## internally used function
+## written by Liam J. Revell 2012, 2017
+getState<-function(x,trans){
+ if(x<=trans[1]) state<-names(trans)[1]
+ else if(x>=trans[length(trans)]) state<-names(trans)[length(trans)]
+ else {
+ i<-1
+ while(x>trans[i]){
+ state<-names(trans)[i]
+ i<-i+1
+ }
+ }
+ state
+}
+
+## S3 print method for objects of class "contMap"
+## uses print.densityMap internally
+## written by Liam J. Revell 2012, 2013, 2014, 2015, 2016, 2023
+
+plot.contMap<-function(x,...){
+ if(inherits(x,"contMap")){
+ lims<-x$lims
+ x<-list(tree=x$tree,cols=x$cols)
+ class(x)<-"densityMap"
+ } else stop("x should be an object of class \"contMap\"")
+ H<-nodeHeights(x$tree)
+ # get & set optional arguments
+ if(hasArg(legend)) legend<-list(...)$legend
+ else legend<-NULL
+ if(hasArg(fsize)) fsize<-list(...)$fsize
+ else fsize<-NULL
+ if(hasArg(ftype)) ftype<-list(...)$ftype
+ else ftype<-NULL
+ if(hasArg(outline)) outline<-list(...)$outline
+ else outline<-TRUE
+ if(hasArg(lwd)) lwd<-list(...)$lwd
+ else lwd<-4
+ if(hasArg(sig)) sig<-list(...)$sig
+ else sig<-3
+ if(hasArg(type)) type<-list(...)$type
+ else type<-"phylogram"
+ if(hasArg(mar)) mar<-list(...)$mar
+ else mar<-rep(0.3,4)
+ if(hasArg(direction)) direction<-list(...)$direction
+ else direction<-"rightwards"
+ if(hasArg(offset)) offset<-list(...)$offset
+ else offset<-NULL
+ if(hasArg(xlim)) xlim<-list(...)$xlim
+ else xlim<-NULL
+ if(hasArg(ylim)) ylim<-list(...)$ylim
+ else ylim<-NULL
+ if(hasArg(hold)) hold<-list(...)$hold
+ else hold<-TRUE
+ if(is.null(legend)) legend<-0.5*max(H)
+ if(is.null(fsize)) fsize<-c(1,1)
+ if(length(fsize)==1) fsize<-rep(fsize,2)
+ if(is.null(ftype)) ftype<-c("i","reg")
+ if(length(ftype)==1) ftype<-c(ftype,"reg")
+ if(hasArg(leg.txt)) leg.txt<-list(...)$leg.txt
+ else leg.txt<-"trait value"
+ if(hasArg(underscore)) underscore<-list(...)$underscore
+ else underscore<-FALSE
+ # done optional arguments
+ leg.txt<-c(round(lims[1],sig),leg.txt,round(lims[2],sig))
+ plot(x,fsize=fsize,ftype=ftype,lwd=lwd,legend=legend,outline=outline,leg.txt=leg.txt,
+ type=type,mar=mar,direction=direction,offset=offset,xlim=xlim,ylim=ylim,hold=hold,
+ underscore=underscore)
+}
+
+## S3 print method for object of class 'contMap'
+## written by Liam J. Revell 2013
+print.contMap<-function(x,digits=6,...){
+ cat("Object of class \"contMap\" containing:\n\n")
+ cat(paste("(1) A phylogenetic tree with ",length(x$tree$tip.label)," tips and ",x$tree$Nnode," internal nodes.\n\n",sep=""))
+ cat(paste("(2) A mapped continuous trait on the range (",round(x$lims[1],digits),", ",round(x$lims[2],digits),").\n\n",sep=""))
+}
+
+## drop tips from an object of class 'contMap'
+## written by Liam J. Revell 2014, 2023
+drop.tip.contMap<-function(phy,tip,...){
+ if(!inherits(phy,"contMap")) cat("phy should be an object of class \"contMap\"\n")
+ else {
+ phy$tree<-drop.tip.simmap(phy$tree,tip,...)
+ return(phy)
+ }
+}
+
+## add error bars to contMap plot
+## written by Liam J. Revell 2017
+errorbar.contMap<-function(obj,...){
+ if(hasArg(x)) x<-list(...)$x
+ else x<-setNames(sapply(1:Ntip(obj$tree),function(x,obj){
+ ii<-which(obj$tree$edge[,2]==x)
+ ss<-names(obj$tree$maps[[ii]][length(obj$tree$maps[[ii]])])
+ obj$lims[1]+as.numeric(ss)/(length(obj$cols)-1)*diff(obj$lims)
+ },obj=obj),obj$tree$tip.label)
+ if(hasArg(scale.by.ci)) scale.by.ci<-list(...)$scale.by.ci
+ else scale.by.ci<-TRUE
+ if(hasArg(lwd)) lwd<-list(...)$lwd
+ else lwd<-14
+ tree<-obj$tree
+ aa<-fastAnc(tree,x,CI=TRUE)
+ xlim<-range(aa$CI95)
+ if(xlim[2]>obj$lims[2]||xlim[1]<obj$lims[1]){
+ cat(paste(" -----\n The range of the contMap object, presently (",
+ round(obj$lims[1],4),",",
+ round(obj$lims[2],4),
+ "), should be equal to\n or greater than the range of the CIs on ancestral states: (",
+ round(xlim[1],4),",",round(xlim[2],4),").\n",sep=""))
+ cat(paste(" To ensure that your error bars are correctly plotted, please recompute your\n",
+ " contMap object and increase lims.\n -----\n",sep=""))
+ }
+ d<-diff(obj$lims)
+ if(scale.by.ci){
+ v<-aa$CI95[,2]-aa$CI95[,1]
+ v<-v/max(v)
+ } else v<-rep(0.5,tree$Nnode)
+ n<-length(obj$cols)-1
+ lastPP<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ h<-max(nodeHeights(tree))
+ for(i in 1:tree$Nnode){
+ ii<-round((aa$CI95[i,1]-obj$lims[1])/d*n)
+ jj<-round((aa$CI95[i,2]-obj$lims[1])/d*(n+1))
+ cols<-obj$cols[ii:jj]
+ add.color.bar(leg=0.1*h*v[i],cols=cols,prompt=FALSE,
+ x=lastPP$xx[i+Ntip(tree)]-0.05*h*v[i],
+ y=lastPP$yy[i+Ntip(tree)],title="",subtitle="",lims=NULL,
+ lwd=lwd)
+ }
+}
+
+keep.tip.contMap<-function(phy,tip,...){
+ tips<-setdiff(phy$tree$tip.label,tip)
+ drop.tip.contMap(phy,tip=tips,...)
+}
diff --git a/R/cophylo.R b/R/cophylo.R
index a8fcc87..5fe0185 100644
--- a/R/cophylo.R
+++ b/R/cophylo.R
@@ -1,574 +1,576 @@
-## creates an object of class "cophylo"
-## written by Liam J. Revell 2015, 2016, 2017, 2019, 2021
-
-cophylo<-function(tr1,tr2,assoc=NULL,rotate=TRUE,...){
- if(!inherits(tr1,"phylo")||!inherits(tr2,"phylo"))
- stop("tr1 & tr2 should be objects of class \"phylo\".")
- ## check optional arguments
- if(hasArg(methods)) methods<-list(...)$methods
- else methods<-"pre"
- if("exhaustive"%in%methods) methods<-"exhaustive"
- ## hack to make sure tip labels of each tree are in cladewise order
- tr1<-untangle(tr1,"read.tree")
- tr2<-untangle(tr2,"read.tree")
- ## if no association matrix check for exact matches
- if(is.null(assoc)){
- assoc<-intersect(tr1$tip.label,tr2$tip.label)
- assoc<-if(length(assoc)>0) cbind(assoc,assoc) else NULL
- if(is.null(assoc)){
- cat("No associations provided or found.\n")
- rotate<-FALSE
- }
- }
- ## check to verify that all taxa in assoc are in tree
- ii<-sapply(assoc[,1],"%in%",tr1$tip.label)
- if(any(!ii)){
- assoc<-assoc[ii,]
- cat("Some species in assoc[,1] not in tr1. Removing species & links.\n")
- }
- ii<-sapply(assoc[,2],"%in%",tr2$tip.label)
- if(any(!ii)){
- assoc<-assoc[ii,]
- cat("Some species in assoc[,2] not in tr2. Removing species & links.\n")
- }
- ## now check if rotation is to be performed
- if(rotate){
- cat("Rotating nodes to optimize matching...\n")
- flush.console()
- if("exhaustive"%in%methods){
- tt1<-allRotations(tr1)
- tt2<-allRotations(tr2)
- M1<-M2<-matrix(NA,length(tt1),length(tt2))
- for(i in 1:length(tt1)){
- for(j in 1:length(tt2)){
- x<-setNames(sapply(assoc[,2],match,table=tt2[[j]]$tip.label),assoc[,1])
- y<-setNames(sapply(assoc[,1],match,table=tt1[[i]]$tip.label),assoc[,2])
- M1[i,j]<-attr(tipRotate(tt1[[i]],x*Ntip(tr1)/Ntip(tr2),methods="just.compute"),"minRotate")
- M2[i,j]<-attr(tipRotate(tt2[[j]],y*Ntip(tr2)/Ntip(tr1),methods="just.compute"),"minRotate")
- }
- }
- MM<-M1+M2
- ij<-which(MM==min(MM),arr.ind=TRUE)
- obj<-list()
- for(i in 1:nrow(ij)){
- tr1<-tt1[[ij[i,1]]]
- attr(tr1,"minRotate")<-M1[ij[i,1],ij[i,2]]
- tr2<-tt2[[ij[i,2]]]
- attr(tr2,"minRotate")<-M2[ij[i,1],ij[i,2]]
- tt<-list(tr1,tr2)
- class(tt)<-"multiPhylo"
- obj[[i]]<-list(trees=tt,assoc=assoc)
- class(obj[[i]])<-"cophylo"
- }
- if(length(obj)>1) class(obj)<-"multiCophylo"
- else obj<-obj[[1]]
- } else if ("all"%in%methods){
- tt1<-allRotations(tr1)
- tt2<-allRotations(tr2)
- obj<-vector(mode="list",length=length(tt1)*length(tt2))
- ij<-1
- for(i in 1:length(tt1)){
- for(j in 1:length(tt2)){
- x<-setNames(sapply(assoc[,2],match,table=tt2[[j]]$tip.label),assoc[,1])
- y<-setNames(sapply(assoc[,1],match,table=tt1[[i]]$tip.label),assoc[,2])
- obj[[ij]]<-list(trees=c(
- tipRotate(tt1[[i]],x*Ntip(tr1)/Ntip(tr2),methods="just.compute"),
- tipRotate(tt2[[j]],y*Ntip(tr2)/Ntip(tr1),methods="just.compute")),
- assoc=assoc)
- class(obj[[ij]])<-"cophylo"
- ij<-ij+1
- }
- }
- class(obj)<-"multiCophylo"
- } else {
- x<-setNames(sapply(assoc[,2],match,table=tr2$tip.label),assoc[,1])
- tr1<-tipRotate(tr1,x*Ntip(tr1)/Ntip(tr2),right=tr2,assoc=assoc,...)
- best.tr1<-Inf
- x<-setNames(sapply(assoc[,1],match,table=tr1$tip.label),assoc[,2])
- tr2<-tipRotate(tr2,x*Ntip(tr2)/Ntip(tr1),left=tr1,assoc=assoc,...)
- best.tr2<-Inf
- while((best.tr2-attr(tr2,"minRotate"))>0||(best.tr1-attr(tr1,"minRotate"))>0){
- best.tr1<-attr(tr1,"minRotate")
- best.tr2<-attr(tr2,"minRotate")
- x<-setNames(sapply(assoc[,2],match,table=tr2$tip.label),assoc[,1])
- tr1<-tipRotate(tr1,x*Ntip(tr1)/Ntip(tr2),right=tr2,assoc=assoc,...)
- x<-setNames(sapply(assoc[,1],match,table=tr1$tip.label),assoc[,2])
- tr2<-tipRotate(tr2,x*Ntip(tr2)/Ntip(tr1),left=tr1,assoc=assoc,...)
- }
- tt<-list(tr1,tr2)
- class(tt)<-"multiPhylo"
- obj<-list(trees=tt,assoc=assoc)
- class(obj)<-"cophylo"
- }
- cat("Done.\n")
- } else {
- tt<-list(tr1,tr2)
- class(tt)<-"multiPhylo"
- obj<-list(trees=tt,assoc=assoc)
- class(obj)<-"cophylo"
- }
- obj
-}
-
-## called internally by plot.cophylo to plot a phylogram
-## written by Liam J. Revell
-
-phylogram<-function(tree,part=1,direction="rightwards",fsize=1,ftype="i",lwd=1,...){
- if(hasArg(pts)) pts<-list(...)$pts
- else pts<-TRUE
- if(hasArg(edge.col)) edge.col<-list(...)$edge.col
- else edge.col<-rep("black",nrow(tree$edge))
- if(hasArg(tip.lwd)) tip.lwd<-list(...)$tip.lwd
- else tip.lwd<-1
- if(hasArg(tip.lty)) tip.lty<-list(...)$tip.lty
- else tip.lty<-"dotted"
- if(hasArg(tip.len)) tip.len<-list(...)$tip.len
- else tip.len<-0.1
- if(pts==TRUE&&tip.len==0) tip.len<-0.1
- d<-if(direction=="rightwards") 1 else -1
- ## sub "_" for " "
- tree$tip.label<-gsub("_"," ",tree$tip.label)
- ## check if edge lenths
- if(is.null(tree$edge.length)) tree<-compute.brlen(tree)
- ## rescale tree so it fits in one half of the plot
- ## with enough space for labels
- if(ftype=="off") fsize<-0
- n<-Ntip(tree)
- sh<-fsize*strwidth(tree$tip.label)
- H<-nodeHeights(tree)
- th<-sapply(1:n,function(i,x,e) x[which(e==i)],x=H[,2],
- e=tree$edge[,2])+tip.len*max(H)
- tree$edge.length<-tree$edge.length/max(th/(part-sh))
- ## reorder cladewise to assign tip positions
- cw<-reorder(tree,"cladewise")
- y<-vector(length=n+cw$Nnode)
- y[cw$edge[cw$edge[,2]<=n,2]]<-0:(n-1)/(n-1)
- ## reorder pruningwise for post-order traversal
- pw<-reorder(tree,"pruningwise")
- nn<-unique(pw$edge[,1])
- ## compute vertical position of each edge
- for(i in 1:length(nn)){
- yy<-y[pw$edge[which(pw$edge[,1]==nn[i]),2]]
- y[nn[i]]<-mean(range(yy))
- }
- ## compute start & end points of each edge
- X<-nodeHeights(cw)-0.5
- ## plot horizontal edges
- for(i in 1:nrow(X)) lines(d*X[i,],rep(y[cw$edge[i,2]],2),lwd=lwd,lend=2,
- col=edge.col[i])
- ## plot vertical relationships
- for(i in 1:tree$Nnode+n){
- ee<-which(cw$edge[,1]==i)
- p<-if(i%in%cw$edge[,2]) which(cw$edge[,2]==i) else NULL
- if(!is.null(p)){
- xx<-c(X[ee,1],X[p,2])
- yy<-sort(c(y[cw$edge[ee,2]],y[cw$edge[p,2]]))
- } else {
- xx<-c(X[ee,1],X[ee[1],1])
- yy<-sort(c(y[cw$edge[ee,2]],mean(y[cw$edge[ee,2]])))
- }
- segments(x0=d*xx[1:(length(xx)-1)],y0=yy[1:(length(yy)-1)],
- x1=d*xx[2:length(xx)],y1=yy[2:length(yy)],lwd=lwd,lend=2,col=edge.col[ee])
- }
- h<-part-0.5-tip.len*(max(X)-min(X))-fsize*strwidth(tree$tip.label)
- ## plot links to tips
- for(i in 1:n){
- lines(d*c(X[which(cw$edge[,2]==i),2],h[i]+tip.len*(max(X)-min(X))),rep(y[i],2),
- lwd=tip.lwd,lty=tip.lty)
- if(pts) points(d*X[which(cw$edge[,2]==i),2],y[i],pch=16,cex=pts*0.7*sqrt(lwd))
- }
- ## plot tip labels
- font<-which(c("off","reg","b","i","bi")==ftype)-1
- if(font>0){
- for(i in 1:n) TEXTBOX(d*(h[i]+fsize*strwidth(tree$tip.label[i])+
- tip.len*(max(X)-min(X))),y[i],
- tree$tip.label[i], pos=if(d<0) 4 else 2,offset=0,
- cex=fsize,font=font)
- }
- PP<-list(type="phylogram",use.edge.length=TRUE,node.pos=1,
- show.tip.label=if(ftype!="off") TRUE else FALSE,show.node.label=FALSE,
- font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE,label.offset=0,
- x.lim=par()$usr[1:2],y.lim=par()$usr[3:4],
- direction=direction,tip.color="black",Ntip=Ntip(cw),Nnode=cw$Nnode,
- edge=cw$edge,xx=d*sapply(1:(Ntip(cw)+cw$Nnode),
- function(x,y,z) y[match(x,z)],y=X,z=cw$edge),yy=y)
- assign("last_plot.phylo",PP,envir=.PlotPhyloEnv)
- ## return rightmost or leftmost edge of tip labels
- invisible(d*max(h+fsize*strwidth(tree$tip.label)+tip.len*(max(X)-min(X))))
-}
-
-cladogram<-function(tree,part=1,direction="rightwards",fsize=1,ftype="i",lwd=1,...){
- if(hasArg(pts)) pts<-list(...)$pts
- else pts<-TRUE
- if(hasArg(edge.col)) edge.col<-list(...)$edge.col
- else edge.col<-rep("black",nrow(tree$edge))
- if(hasArg(tip.lwd)) tip.lwd<-list(...)$tip.lwd
- else tip.lwd<-1
- if(hasArg(tip.lty)) tip.lty<-list(...)$tip.lty
- else tip.lty<-"dotted"
- if(hasArg(tip.len)) tip.len<-list(...)$tip.len
- else tip.len<-0.1
- if(pts==TRUE&&tip.len==0) tip.len<-0.1
- d<-if(direction=="rightwards") 1 else -1
- ## sub "_" for " "
- tree$tip.label<-gsub("_"," ",tree$tip.label)
- ## check if edge lenths
- if(is.null(tree$edge.length)) tree<-compute.brlen(tree)
- ## rescale tree so it fits in one half of the plot
- ## with enough space for labels
- if(ftype=="off") fsize<-0
- n<-Ntip(tree)
- sh<-fsize*strwidth(tree$tip.label)
- H<-nodeHeights(tree)
- th<-sapply(1:n,function(i,x,e) x[which(e==i)],x=H[,2],
- e=tree$edge[,2])+tip.len*max(H)
- tree$edge.length<-tree$edge.length/max(th/(part-sh))
- ## reorder cladewise to assign tip positions
- cw<-reorder(tree,"cladewise")
- y<-vector(length=n+cw$Nnode)
- y[cw$edge[cw$edge[,2]<=n,2]]<-0:(n-1)/(n-1)
- ## reorder pruningwise for post-order traversal
- pw<-reorder(tree,"pruningwise")
- nn<-unique(pw$edge[,1])
- ## compute vertical position of each edge
- for(i in 1:length(nn)){
- desc<-pw$edge[which(pw$edge[,1]==nn[i]),2]
- n1<-desc[which(y[desc]==min(y[desc]))]
- n2<-desc[which(y[desc]==max(y[desc]))]
- v1<-pw$edge.length[which(pw$edge[,2]==n1)]
- v2<-pw$edge.length[which(pw$edge[,2]==n2)]
- y[nn[i]]<-((1/v1)*y[n1]+(1/v2)*y[n2])/(1/v1+1/v2)
- }
- ## compute start & end points of each edge
- X<-nodeHeights(cw)-0.5
- ## plot horizontal edges
- for(i in 1:nrow(X)) lines(d*X[i,],y[cw$edge[i,]],lwd=lwd,lend=2,
- col=edge.col[i])
- h<-part-0.5-tip.len*(max(X)-min(X))-fsize*strwidth(tree$tip.label)
- ## plot links to tips
- for(i in 1:n){
- lines(d*c(X[which(cw$edge[,2]==i),2],h[i]+tip.len*(max(X)-min(X))),rep(y[i],2),
- lwd=tip.lwd,lty=tip.lty)
- if(pts) points(d*X[which(cw$edge[,2]==i),2],y[i],pch=16,cex=pts*0.7*sqrt(lwd))
- }
- ## plot tip labels
- font<-which(c("off","reg","b","i","bi")==ftype)-1
- if(font>0){
- for(i in 1:n) TEXTBOX(d*(h[i]+fsize*strwidth(tree$tip.label[i])+
- tip.len*(max(X)-min(X))),y[i],
- tree$tip.label[i], pos=if(d<0) 4 else 2,offset=0,
- cex=fsize,font=font)
- }
- PP<-list(type="cladogram",use.edge.length=TRUE,node.pos=1,
- show.tip.label=if(ftype!="off") TRUE else FALSE,show.node.label=FALSE,
- font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE,label.offset=0,
- x.lim=par()$usr[1:2],y.lim=par()$usr[3:4],
- direction=direction,tip.color="black",Ntip=Ntip(cw),Nnode=cw$Nnode,
- edge=cw$edge,xx=d*sapply(1:(Ntip(cw)+cw$Nnode),
- function(x,y,z) y[match(x,z)],y=X,z=cw$edge),yy=y)
- assign("last_plot.phylo",PP,envir=.PlotPhyloEnv)
- ## return rightmost or leftmost edge of tip labels
- invisible(d*max(h+fsize*strwidth(tree$tip.label)+tip.len*(max(X)-min(X))))
-}
-
-## internally used function
-
-TEXTBOX<-function(x,y,label,pos,offset,cex,font){
- rect(x,y-0.5*strheight(label,cex=cex,font=font),x+if(pos==4) strwidth(label,
- cex=cex,font=font) else -strwidth(label,cex=cex,font=font),
- y+0.5*strheight(label,cex=cex,font=font),border=FALSE,
- col=if(par()$bg%in%c("white","transparent")) "white" else par()$bg)
- text(x=x,y=y,label=label,pos=pos,offset=offset,cex=cex,font=font)
-}
-
-
-## plot links between tip taxa according to assoc
-## written by Liam J. Revell 2015, 2016, 2019
-
-makelinks<-function(obj,x,link.type="curved",link.lwd=1,link.col="black",
- link.lty="dashed"){
- if(length(link.lwd)==1) link.lwd<-rep(link.lwd,nrow(obj$assoc))
- if(length(link.col)==1) link.col<-rep(link.col,nrow(obj$assoc))
- if(length(link.lty)==1) link.lty<-rep(link.lty,nrow(obj$assoc))
- for(i in 1:nrow(obj$assoc)){
- ii<-which(obj$trees[[1]]$tip.label==obj$assoc[i,1])
- jj<-which(obj$trees[[2]]$tip.label==obj$assoc[i,2])
- for(j in 1:length(ii)) for(k in 1:length(jj)){
- y<-c((ii[j]-1)/(Ntip(obj$trees[[1]])-1),
- (jj[k]-1)/(Ntip(obj$trees[[2]])-1))
- if(link.type=="straight") lines(x,y,lty=link.lty[i],
- lwd=link.lwd[i],col=link.col[i])
- else if(link.type=="curved") drawCurve(x,y,lty=link.lty[i],
- lwd=link.lwd[i],col=link.col[i])
- }
- }
-}
-
-## plot method for class "multiCophylo"
-
-plot.multiCophylo<-function(x,...){
- par(ask=TRUE)
- for(i in 1:length(x)) plot.cophylo(x[[i]],...)
-}
-
-## plot an object of class "cophylo"
-## written by Liam J. Revell 2015, 2016, 2017, 2021
-
-plot.cophylo<-function(x,...){
- plot.new()
- if(hasArg(type)) type<-list(...)$type
- else type<-"phylogram"
- if(hasArg(mar)) mar<-list(...)$mar
- else mar<-c(0.1,0.1,0.1,0.1)
- if(hasArg(xlim)) xlim<-list(...)$xlim
- else xlim<-c(-0.5,0.5)
- if(hasArg(scale.bar)) scale.bar<-list(...)$scale.bar
- else scale.bar<-rep(0,2)
- if(hasArg(ylim)) ylim<-list(...)$ylim
- else ylim<-if(any(scale.bar>0)) c(-0.1,1) else c(0,1)
- if(hasArg(link.type)) link.type<-list(...)$link.type
- else link.type<-"straight"
- if(hasArg(link.lwd)) link.lwd<-list(...)$link.lwd
- else link.lwd<-1
- if(hasArg(link.col)) link.col<-list(...)$link.col
- else link.col<-"black"
- if(hasArg(link.lty)) link.lty<-list(...)$link.lty
- else link.lty<-"dashed"
- if(hasArg(edge.col)) edge.col<-list(...)$edge.col
- else edge.col<-list(
- left=rep("black",nrow(x$trees[[1]]$edge)),
- right=rep("black",nrow(x$trees[[2]]$edge)))
- obj<-list(...)
- if(is.null(obj$part)) obj$part<-0.4
- par(mar=mar)
- plot.window(xlim=xlim,ylim=ylim)
- leftArgs<-rightArgs<-obj
- leftArgs$edge.col<-edge.col$left
- rightArgs$edge.col<-edge.col$right
- if(!is.null(obj$fsize)){
- if(length(obj$fsize)>1){
- leftArgs$fsize<-obj$fsize[1]
- rightArgs$fsize<-obj$fsize[2]
- sb.fsize<- if(length(obj$fsize)>2) obj$fsize[3] else 1
- } else sb.fsize<-1
- } else sb.fsize<-1
- plotter<-if(type=="cladogram") "cladogram" else "phylogram"
- x1<-do.call(plotter,c(list(tree=x$trees[[1]]),leftArgs))
- left<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- x2<-do.call(plotter,c(list(tree=x$trees[[2]],direction="leftwards"),
- rightArgs))
- right<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- if(!is.null(x$assoc)) makelinks(x,c(x1,x2),link.type,link.lwd,link.col,
- link.lty)
- else cat("No associations provided.\n")
- if(any(scale.bar>0)) add.scalebar(x,scale.bar,sb.fsize)
- assign("last_plot.cophylo",list(left=left,right=right),envir=.PlotPhyloEnv)
-}
-
-## add scale bar
-## written by Liam J. Revell 2015
-
-add.scalebar<-function(obj,scale.bar,fsize){
- if(scale.bar[1]>0){
- s1<-(0.4-max(fsize*strwidth(obj$trees[[1]]$tip.label)))/max(nodeHeights(obj$trees[[1]]))
- lines(c(-0.5,-0.5+scale.bar[1]*s1),rep(-0.05,2))
- lines(rep(-0.5,2),c(-0.05,-0.06))
- lines(rep(-0.5+scale.bar[1]*s1,2),c(-0.05,-0.06))
- text(mean(c(-0.5,-0.5+scale.bar[1]*s1)),rep(-0.05,2),scale.bar[1],pos=1)
- }
- if(scale.bar[2]>0){
- s2<-(0.4-max(fsize*strwidth(obj$trees[[2]]$tip.label)))/max(nodeHeights(obj$trees[[2]]))
- lines(c(0.5-scale.bar[2]*s2,0.5),rep(-0.05,2))
- lines(rep(0.5-scale.bar[2]*s2,2),c(-0.05,-0.06))
- lines(rep(0.5,2),c(-0.05,-0.06))
- text(mean(c(0.5-scale.bar[2]*s2,0.5)),rep(-0.05,2),scale.bar[2],pos=1)
- }
-}
-
-## print an object of class "cophylo"
-## written by Liam J. Revell 2015
-
-print.cophylo<-function(x, ...){
- cat("Object of class \"cophylo\" containing:\n\n")
- cat("(1) 2 (possibly rotated) phylogenetic trees in an object of class \"multiPhylo\".\n\n")
- cat("(2) A table of associations between the tips of both trees.\n\n")
-}
-
-## print method for "multiCophylo" object
-
-print.multiCophylo<-function(x, ...)
- cat("Object of class \"multiCophylo\" containg",length(x),"objects of class \"cophylo\".\n\n")
-
-## written by Liam J. Revell 2015, 2016
-
-tipRotate<-function(tree,x,...){
- if(hasArg(fn)) fn<-list(...)$fn
- else fn<-function(x) x^2
- if(hasArg(methods)) methods<-list(...)$methods
- else methods<-"pre"
- if("exhaustive"%in%methods) methods<-"exhaustive"
- if(hasArg(print)) print<-list(...)$print
- else print<-FALSE
- if(hasArg(max.exhaustive)) max.exhaustive<-list(...)$max.exhaustive
- else max.exhaustive<-20
- if(hasArg(rotate.multi)) rotate.multi<-list(...)$rotate.multi
- else rotate.multi<-FALSE
- if(rotate.multi) rotate.multi<-!is.binary(tree)
- if(hasArg(anim.cophylo)) anim.cophylo<-list(...)$anim.cophylo
- else anim.cophylo<-FALSE
- if(anim.cophylo){
- if(hasArg(left)) left<-list(...)$left
- else left<-NULL
- if(hasArg(right)) right<-list(...)$right
- else right<-NULL
- if(hasArg(assoc)) assoc<-list(...)$assoc
- else assoc<-NULL
- if(is.null(left)&&is.null(right)) anim.cophylo<-FALSE
- if(hasArg(only.accepted)) only.accepted<-list(...)$only.accepted
- else only.accepted<-TRUE
- }
- tree<-reorder(tree)
- nn<-1:tree$Nnode+length(tree$tip.label)
- if("just.compute"%in%methods){
- foo<-function(phy,x) sum(fn(x-setNames(1:length(phy$tip.label),phy$tip.label)[names(x)]))
- oo<-pp<-foo(tree,x)
- }
- if("exhaustive"%in%methods){
- if(Ntip(tree)>max.exhaustive){
- cat(paste("\nmethods=\"exhaustive\" not permitted for more than",
- max.exhaustive,"tips.\n",
- "If you are sure you want to run an exhaustive search for a tree of this size\n",
- "increasing argument max.exhaustive & re-run.\n",
- "Setting methods to \"pre\".\n\n"))
- methods<-"pre"
- } else {
- cat("Running exhaustive search. May be slow!\n")
- oo<-Inf
- tt<-allRotations(tree)
- foo<-function(phy,x) sum(fn(x-setNames(1:length(phy$tip.label),phy$tip.label)[names(x)]))
- pp<-sapply(tt,foo,x=x)
- ii<-which(pp==min(pp))
- ii<-if(length(ii)>1) sample(ii,1) else ii
- tt<-tt[[ii]]
- pp<-pp[ii]
- }
- if(print) message(paste("objective:",pp))
- tree<-tt
- }
- ANIM.COPHYLO<-function(tree){
- dev.hold()
- if(is.null(left)) plot(cophylo(tree,right,assoc=assoc,rotate=FALSE),...)
- else if(is.null(right)) plot(cophylo(left,tree,assoc=assoc,rotate=FALSE),...)
- nodelabels.cophylo(node=i+Ntip(tree),pie=1,col="red",cex=0.4,
- which=if(is.null(left)) "left" else "right")
- dev.flush()
- }
- if("pre"%in%methods){
- for(i in 1:tree$Nnode){
- if(anim.cophylo) ANIM.COPHYLO(tree)
- tt<-if(rotate.multi) rotate.multi(tree,nn[i]) else untangle(rotate(tree,nn[i]),"read.tree")
- oo<-sum(fn(x-setNames(1:length(tree$tip.label),tree$tip.label)[names(x)]))
- if(inherits(tt,"phylo")) pp<-sum(fn(x-setNames(1:length(tt$tip.label),tt$tip.label)[names(x)]))
- if(anim.cophylo&&!only.accepted) ANIM.COPHYLO(tt)
- else if(inherits(tt,"multiPhylo")){
- foo<-function(phy,x) sum(fn(x-setNames(1:length(phy$tip.label),phy$tip.label)[names(x)]))
- pp<-sapply(tt,foo,x=x)
- if(anim.cophylo&&!only.accepted) nulo<-lapply(tt,ANIM.COPHYLO)
- ii<-which(pp==min(pp))
- ii<-if(length(ii)>1) sample(ii,1) else ii
- tt<-tt[[ii]]
- pp<-pp[ii]
- }
- if(oo>pp) tree<-tt
- if(print) message(paste("objective:",min(oo,pp)))
- }
- }
- if("post"%in%methods){
- for(i in tree$Nnode:1){
- if(anim.cophylo) ANIM.COPHYLO(tree)
- tt<-if(rotate.multi) rotate.multi(tree,nn[i]) else untangle(rotate(tree,nn[i]),"read.tree")
- oo<-sum(fn(x-setNames(1:length(tree$tip.label),tree$tip.label)[names(x)]))
- if(inherits(tt,"phylo")) pp<-sum(fn(x-setNames(1:length(tt$tip.label),tt$tip.label)[names(x)]))
- if(anim.cophylo&&!only.accepted) ANIM.COPHYLO(tt)
- else if(inherits(tt,"multiPhylo")){
- foo<-function(phy,x) sum(fn(x-setNames(1:length(phy$tip.label),phy$tip.label)[names(x)]))
- pp<-sapply(tt,foo,x=x)
- if(anim.cophylo&&!only.accepted) nulo<-lapply(tt,ANIM.COPHYLO)
- ii<-which(pp==min(pp))
- ii<-if(length(ii)>1) sample(ii,1) else ii
- tt<-tt[[ii]]
- pp<-pp[ii]
- }
- if(oo>pp) tree<-tt
- if(print) message(paste("objective:",min(oo,pp)))
- }
- }
- attr(tree,"minRotate")<-min(oo,pp)
- if(anim.cophylo) ANIM.COPHYLO(tree)
- tree
-}
-
-## multi2di for "multiPhylo" object
-
-MULTI2DI<-function(x,...){
- obj<-lapply(x,multi2di,...)
- class(obj)<-"multiPhylo"
- obj
-}
-
-## labeling methods for plotted "cophylo" object
-## written by Liam J. Revell 2015
-
-nodelabels.cophylo<-function(...,which=c("left","right")){
- obj<-get("last_plot.cophylo",envir=.PlotPhyloEnv)
- if(which[1]=="left") assign("last_plot.phylo",obj[[1]],envir=.PlotPhyloEnv)
- else if(which[1]=="right") assign("last_plot.phylo",obj[[2]],envir=.PlotPhyloEnv)
- nodelabels(...)
-}
-
-edgelabels.cophylo<-function(...,which=c("left","right")){
- obj<-get("last_plot.cophylo",envir=.PlotPhyloEnv)
- if(which[1]=="left") assign("last_plot.phylo",obj[[1]],envir=.PlotPhyloEnv)
- else if(which[1]=="right") assign("last_plot.phylo",obj[[2]],envir=.PlotPhyloEnv)
- edgelabels(...)
-}
-
-tiplabels.cophylo<-function(...,which=c("left","right")){
- obj<-get("last_plot.cophylo",envir=.PlotPhyloEnv)
- if(which[1]=="left") assign("last_plot.phylo",obj[[1]],envir=.PlotPhyloEnv)
- else if(which[1]=="right") assign("last_plot.phylo",obj[[2]],envir=.PlotPhyloEnv)
- tiplabels(...)
-}
-
-## function to draw sigmoidal links
-## modified from https://stackoverflow.com/questions/32046889/connecting-two-points-with-curved-lines-s-ish-curve-in-r
-
-drawCurve<-function(x,y,scale=0.01,...){
- x1<-x[1]
- x2<-x[2]
- y1<-y[1]
- y2<-y[2]
- curve(plogis(x,scale=scale,location=(x1+x2)/2)*(y2-y1)+y1,
- x1,x2,add=TRUE,...)
-}
-
-## S3 summary method
-## written by Liam J. Revell 2016
-
-summary.cophylo<-function(object,...){
- cat("\nCo-phylogenetic (\"cophylo\") object:",deparse(substitute(object)),
- "\n\n")
- cat(paste("Tree 1 (left tree) is an object of class \"phylo\" containing",
- Ntip(object$trees[[1]]),"species.\n\n"))
- cat(paste("Tree 2 (right tree) is an object of class \"phylo\" containing",
- Ntip(object$trees[[2]]),"species.\n\n"))
- cat("Association (assoc) table as follows:\n\n")
- maxl<-max(sapply(strsplit(object$assoc[,1],""),length))
- cat(paste("\tleft:",paste(rep(" ",max(0,maxl-5)),collapse=""),
- "\t----\tright:\n",sep=""))
- nulo<-apply(object$assoc,1,function(x,maxl) cat(paste("\t",x[1],
- paste(rep(" ",maxl-length(strsplit(x[1],split="")[[1]])),
- collapse=""),"\t----\t",x[2],"\n",sep="")),maxl=maxl)
- cat("\n")
-}
-
+## creates an object of class "cophylo"
+## written by Liam J. Revell 2015, 2016, 2017, 2019, 2021, 2023
+
+cophylo<-function(tr1,tr2,assoc=NULL,rotate=TRUE,...){
+ if(!inherits(tr1,"phylo")||!inherits(tr2,"phylo"))
+ stop("tr1 & tr2 should be objects of class \"phylo\".")
+ ## check optional arguments
+ if(hasArg(methods)) methods<-list(...)$methods
+ else methods<-"pre"
+ if("exhaustive"%in%methods) methods<-"exhaustive"
+ ## hack to make sure tip labels of each tree are in cladewise order
+ tr1<-untangle(tr1,"read.tree")
+ tr2<-untangle(tr2,"read.tree")
+ ## if no association matrix check for exact matches
+ if(is.null(assoc)){
+ assoc<-intersect(tr1$tip.label,tr2$tip.label)
+ assoc<-if(length(assoc)>0) cbind(assoc,assoc) else NULL
+ if(is.null(assoc)){
+ cat("No associations provided or found.\n")
+ rotate<-FALSE
+ }
+ }
+ ## check to verify that all taxa in assoc are in tree
+ ii<-sapply(assoc[,1],"%in%",tr1$tip.label)
+ if(any(!ii)){
+ assoc<-assoc[ii,]
+ cat("Some species in assoc[,1] not in tr1. Removing species & links.\n")
+ }
+ ii<-sapply(assoc[,2],"%in%",tr2$tip.label)
+ if(any(!ii)){
+ assoc<-assoc[ii,]
+ cat("Some species in assoc[,2] not in tr2. Removing species & links.\n")
+ }
+ ## now check if rotation is to be performed
+ if(rotate){
+ cat("Rotating nodes to optimize matching...\n")
+ flush.console()
+ if("exhaustive"%in%methods){
+ tt1<-allRotations(tr1)
+ tt2<-allRotations(tr2)
+ M1<-M2<-matrix(NA,length(tt1),length(tt2))
+ for(i in 1:length(tt1)){
+ for(j in 1:length(tt2)){
+ x<-setNames(sapply(assoc[,2],match,table=tt2[[j]]$tip.label),assoc[,1])
+ y<-setNames(sapply(assoc[,1],match,table=tt1[[i]]$tip.label),assoc[,2])
+ M1[i,j]<-attr(tipRotate(tt1[[i]],x*Ntip(tr1)/Ntip(tr2),methods="just.compute"),"minRotate")
+ M2[i,j]<-attr(tipRotate(tt2[[j]],y*Ntip(tr2)/Ntip(tr1),methods="just.compute"),"minRotate")
+ }
+ }
+ MM<-M1+M2
+ ij<-which(MM==min(MM),arr.ind=TRUE)
+ obj<-list()
+ for(i in 1:nrow(ij)){
+ tr1<-tt1[[ij[i,1]]]
+ attr(tr1,"minRotate")<-M1[ij[i,1],ij[i,2]]
+ tr2<-tt2[[ij[i,2]]]
+ attr(tr2,"minRotate")<-M2[ij[i,1],ij[i,2]]
+ tt<-list(tr1,tr2)
+ class(tt)<-"multiPhylo"
+ obj[[i]]<-list(trees=tt,assoc=assoc)
+ class(obj[[i]])<-"cophylo"
+ }
+ if(length(obj)>1) class(obj)<-"multiCophylo"
+ else obj<-obj[[1]]
+ } else if ("all"%in%methods){
+ tt1<-allRotations(tr1)
+ tt2<-allRotations(tr2)
+ obj<-vector(mode="list",length=length(tt1)*length(tt2))
+ ij<-1
+ for(i in 1:length(tt1)){
+ for(j in 1:length(tt2)){
+ x<-setNames(sapply(assoc[,2],match,table=tt2[[j]]$tip.label),assoc[,1])
+ y<-setNames(sapply(assoc[,1],match,table=tt1[[i]]$tip.label),assoc[,2])
+ obj[[ij]]<-list(trees=c(
+ tipRotate(tt1[[i]],x*Ntip(tr1)/Ntip(tr2),methods="just.compute"),
+ tipRotate(tt2[[j]],y*Ntip(tr2)/Ntip(tr1),methods="just.compute")),
+ assoc=assoc)
+ class(obj[[ij]])<-"cophylo"
+ ij<-ij+1
+ }
+ }
+ class(obj)<-"multiCophylo"
+ } else {
+ x<-setNames(sapply(assoc[,2],match,table=tr2$tip.label),assoc[,1])
+ tr1<-tipRotate(tr1,x*Ntip(tr1)/Ntip(tr2),right=tr2,assoc=assoc,...)
+ best.tr1<-Inf
+ x<-setNames(sapply(assoc[,1],match,table=tr1$tip.label),assoc[,2])
+ tr2<-tipRotate(tr2,x*Ntip(tr2)/Ntip(tr1),left=tr1,assoc=assoc,...)
+ best.tr2<-Inf
+ while((best.tr2-attr(tr2,"minRotate"))>0||(best.tr1-attr(tr1,"minRotate"))>0){
+ best.tr1<-attr(tr1,"minRotate")
+ best.tr2<-attr(tr2,"minRotate")
+ x<-setNames(sapply(assoc[,2],match,table=tr2$tip.label),assoc[,1])
+ tr1<-tipRotate(tr1,x*Ntip(tr1)/Ntip(tr2),right=tr2,assoc=assoc,...)
+ x<-setNames(sapply(assoc[,1],match,table=tr1$tip.label),assoc[,2])
+ tr2<-tipRotate(tr2,x*Ntip(tr2)/Ntip(tr1),left=tr1,assoc=assoc,...)
+ }
+ tt<-list(tr1,tr2)
+ class(tt)<-"multiPhylo"
+ obj<-list(trees=tt,assoc=assoc)
+ class(obj)<-"cophylo"
+ }
+ cat("Done.\n")
+ } else {
+ tt<-list(tr1,tr2)
+ class(tt)<-"multiPhylo"
+ obj<-list(trees=tt,assoc=assoc)
+ class(obj)<-"cophylo"
+ }
+ obj
+}
+
+## called internally by plot.cophylo to plot a phylogram
+## written by Liam J. Revell
+
+phylogram<-function(tree,part=1,direction="rightwards",fsize=1,ftype="i",lwd=1,...){
+ if(hasArg(pts)) pts<-list(...)$pts
+ else pts<-TRUE
+ if(hasArg(edge.col)) edge.col<-list(...)$edge.col
+ else edge.col<-rep("black",nrow(tree$edge))
+ if(hasArg(tip.lwd)) tip.lwd<-list(...)$tip.lwd
+ else tip.lwd<-1
+ if(hasArg(tip.lty)) tip.lty<-list(...)$tip.lty
+ else tip.lty<-"dotted"
+ if(hasArg(tip.len)) tip.len<-list(...)$tip.len
+ else tip.len<-0.1
+ if(pts==TRUE&&tip.len==0) tip.len<-0.1
+ d<-if(direction=="rightwards") 1 else -1
+ ## sub "_" for " "
+ tree$tip.label<-gsub("_"," ",tree$tip.label)
+ ## check if edge lenths
+ if(is.null(tree$edge.length)) tree<-compute.brlen(tree)
+ ## rescale tree so it fits in one half of the plot
+ ## with enough space for labels
+ if(ftype=="off") fsize<-0
+ n<-Ntip(tree)
+ sh<-fsize*strwidth(tree$tip.label)
+ H<-nodeHeights(tree)
+ th<-sapply(1:n,function(i,x,e) x[which(e==i)],x=H[,2],
+ e=tree$edge[,2])+tip.len*max(H)
+ tree$edge.length<-tree$edge.length/max(th/(part-sh))
+ ## reorder cladewise to assign tip positions
+ cw<-reorder(tree,"cladewise")
+ y<-vector(length=n+cw$Nnode)
+ y[cw$edge[cw$edge[,2]<=n,2]]<-0:(n-1)/(n-1)
+ ## reorder pruningwise for post-order traversal
+ pw<-reorder(tree,"pruningwise")
+ nn<-unique(pw$edge[,1])
+ ## compute vertical position of each edge
+ for(i in 1:length(nn)){
+ yy<-y[pw$edge[which(pw$edge[,1]==nn[i]),2]]
+ y[nn[i]]<-mean(range(yy))
+ }
+ ## compute start & end points of each edge
+ X<-nodeHeights(cw)-0.5
+ ## plot horizontal edges
+ for(i in 1:nrow(X)) lines(d*X[i,],rep(y[cw$edge[i,2]],2),lwd=lwd,lend=2,
+ col=edge.col[i])
+ ## plot vertical relationships
+ for(i in 1:tree$Nnode+n){
+ ee<-which(cw$edge[,1]==i)
+ p<-if(i%in%cw$edge[,2]) which(cw$edge[,2]==i) else NULL
+ if(!is.null(p)){
+ xx<-c(X[ee,1],X[p,2])
+ yy<-sort(c(y[cw$edge[ee,2]],y[cw$edge[p,2]]))
+ } else {
+ xx<-c(X[ee,1],X[ee[1],1])
+ yy<-sort(c(y[cw$edge[ee,2]],mean(y[cw$edge[ee,2]])))
+ }
+ segments(x0=d*xx[1:(length(xx)-1)],y0=yy[1:(length(yy)-1)],
+ x1=d*xx[2:length(xx)],y1=yy[2:length(yy)],lwd=lwd,lend=2,col=edge.col[ee])
+ }
+ h<-part-0.5-tip.len*(max(X)-min(X))-fsize*strwidth(tree$tip.label)
+ ## plot links to tips
+ for(i in 1:n){
+ lines(d*c(X[which(cw$edge[,2]==i),2],h[i]+tip.len*(max(X)-min(X))),rep(y[i],2),
+ lwd=tip.lwd,lty=tip.lty)
+ if(pts) points(d*X[which(cw$edge[,2]==i),2],y[i],pch=16,cex=pts*0.7*sqrt(lwd))
+ }
+ ## plot tip labels
+ font<-which(c("off","reg","b","i","bi")==ftype)-1
+ if(font>0){
+ for(i in 1:n) TEXTBOX(d*(h[i]+fsize*strwidth(tree$tip.label[i])+
+ tip.len*(max(X)-min(X))),y[i],
+ tree$tip.label[i], pos=if(d<0) 4 else 2,offset=0,
+ cex=fsize,font=font)
+ }
+ PP<-list(type="phylogram",use.edge.length=TRUE,node.pos=1,
+ show.tip.label=if(ftype!="off") TRUE else FALSE,show.node.label=FALSE,
+ font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE,label.offset=0,
+ x.lim=par()$usr[1:2],y.lim=par()$usr[3:4],
+ direction=direction,tip.color="black",Ntip=Ntip(cw),Nnode=cw$Nnode,
+ edge=cw$edge,xx=d*sapply(1:(Ntip(cw)+cw$Nnode),
+ function(x,y,z) y[match(x,z)],y=X,z=cw$edge),yy=y)
+ assign("last_plot.phylo",PP,envir=.PlotPhyloEnv)
+ ## return rightmost or leftmost edge of tip labels
+ invisible(d*max(h+fsize*strwidth(tree$tip.label)+tip.len*(max(X)-min(X))))
+}
+
+cladogram<-function(tree,part=1,direction="rightwards",fsize=1,ftype="i",lwd=1,...){
+ if(hasArg(pts)) pts<-list(...)$pts
+ else pts<-TRUE
+ if(hasArg(edge.col)) edge.col<-list(...)$edge.col
+ else edge.col<-rep("black",nrow(tree$edge))
+ if(hasArg(tip.lwd)) tip.lwd<-list(...)$tip.lwd
+ else tip.lwd<-1
+ if(hasArg(tip.lty)) tip.lty<-list(...)$tip.lty
+ else tip.lty<-"dotted"
+ if(hasArg(tip.len)) tip.len<-list(...)$tip.len
+ else tip.len<-0.1
+ if(pts==TRUE&&tip.len==0) tip.len<-0.1
+ d<-if(direction=="rightwards") 1 else -1
+ ## sub "_" for " "
+ tree$tip.label<-gsub("_"," ",tree$tip.label)
+ ## check if edge lenths
+ if(is.null(tree$edge.length)) tree<-compute.brlen(tree)
+ ## rescale tree so it fits in one half of the plot
+ ## with enough space for labels
+ if(ftype=="off") fsize<-0
+ n<-Ntip(tree)
+ sh<-fsize*strwidth(tree$tip.label)
+ H<-nodeHeights(tree)
+ th<-sapply(1:n,function(i,x,e) x[which(e==i)],x=H[,2],
+ e=tree$edge[,2])+tip.len*max(H)
+ tree$edge.length<-tree$edge.length/max(th/(part-sh))
+ ## reorder cladewise to assign tip positions
+ cw<-reorder(tree,"cladewise")
+ y<-vector(length=n+cw$Nnode)
+ y[cw$edge[cw$edge[,2]<=n,2]]<-0:(n-1)/(n-1)
+ ## reorder pruningwise for post-order traversal
+ pw<-reorder(tree,"pruningwise")
+ nn<-unique(pw$edge[,1])
+ ## compute vertical position of each edge
+ for(i in 1:length(nn)){
+ desc<-pw$edge[which(pw$edge[,1]==nn[i]),2]
+ n1<-desc[which(y[desc]==min(y[desc]))]
+ n2<-desc[which(y[desc]==max(y[desc]))]
+ v1<-pw$edge.length[which(pw$edge[,2]==n1)]
+ v2<-pw$edge.length[which(pw$edge[,2]==n2)]
+ y[nn[i]]<-((1/v1)*y[n1]+(1/v2)*y[n2])/(1/v1+1/v2)
+ }
+ ## compute start & end points of each edge
+ X<-nodeHeights(cw)-0.5
+ ## plot horizontal edges
+ for(i in 1:nrow(X)) lines(d*X[i,],y[cw$edge[i,]],lwd=lwd,lend=2,
+ col=edge.col[i])
+ h<-part-0.5-tip.len*(max(X)-min(X))-fsize*strwidth(tree$tip.label)
+ ## plot links to tips
+ for(i in 1:n){
+ lines(d*c(X[which(cw$edge[,2]==i),2],h[i]+tip.len*(max(X)-min(X))),rep(y[i],2),
+ lwd=tip.lwd,lty=tip.lty)
+ if(pts) points(d*X[which(cw$edge[,2]==i),2],y[i],pch=16,cex=pts*0.7*sqrt(lwd))
+ }
+ ## plot tip labels
+ font<-which(c("off","reg","b","i","bi")==ftype)-1
+ if(font>0){
+ for(i in 1:n) TEXTBOX(d*(h[i]+fsize*strwidth(tree$tip.label[i])+
+ tip.len*(max(X)-min(X))),y[i],
+ tree$tip.label[i], pos=if(d<0) 4 else 2,offset=0,
+ cex=fsize,font=font)
+ }
+ PP<-list(type="cladogram",use.edge.length=TRUE,node.pos=1,
+ show.tip.label=if(ftype!="off") TRUE else FALSE,show.node.label=FALSE,
+ font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE,label.offset=0,
+ x.lim=par()$usr[1:2],y.lim=par()$usr[3:4],
+ direction=direction,tip.color="black",Ntip=Ntip(cw),Nnode=cw$Nnode,
+ edge=cw$edge,xx=d*sapply(1:(Ntip(cw)+cw$Nnode),
+ function(x,y,z) y[match(x,z)],y=X,z=cw$edge),yy=y)
+ assign("last_plot.phylo",PP,envir=.PlotPhyloEnv)
+ ## return rightmost or leftmost edge of tip labels
+ invisible(d*max(h+fsize*strwidth(tree$tip.label)+tip.len*(max(X)-min(X))))
+}
+
+## internally used function
+
+TEXTBOX<-function(x,y,label,pos,offset,cex,font){
+ rect(x,y-0.5*strheight(label,cex=cex,font=font),x+if(pos==4) strwidth(label,
+ cex=cex,font=font) else -strwidth(label,cex=cex,font=font),
+ y+0.5*strheight(label,cex=cex,font=font),border=FALSE,
+ col=if(par()$bg%in%c("white","transparent")) "white" else par()$bg)
+ text(x=x,y=y,label=label,pos=pos,offset=offset,cex=cex,font=font)
+}
+
+
+## plot links between tip taxa according to assoc
+## written by Liam J. Revell 2015, 2016, 2019
+
+makelinks<-function(obj,x,link.type="curved",link.lwd=1,link.col="black",
+ link.lty="dashed"){
+ if(length(link.lwd)==1) link.lwd<-rep(link.lwd,nrow(obj$assoc))
+ if(length(link.col)==1) link.col<-rep(link.col,nrow(obj$assoc))
+ if(length(link.lty)==1) link.lty<-rep(link.lty,nrow(obj$assoc))
+ for(i in 1:nrow(obj$assoc)){
+ ii<-which(obj$trees[[1]]$tip.label==obj$assoc[i,1])
+ jj<-which(obj$trees[[2]]$tip.label==obj$assoc[i,2])
+ for(j in 1:length(ii)) for(k in 1:length(jj)){
+ y<-c((ii[j]-1)/(Ntip(obj$trees[[1]])-1),
+ (jj[k]-1)/(Ntip(obj$trees[[2]])-1))
+ if(link.type=="straight") lines(x,y,lty=link.lty[i],
+ lwd=link.lwd[i],col=link.col[i])
+ else if(link.type=="curved") drawCurve(x,y,lty=link.lty[i],
+ lwd=link.lwd[i],col=link.col[i])
+ }
+ }
+}
+
+## plot method for class "multiCophylo"
+
+plot.multiCophylo<-function(x,...){
+ par(ask=TRUE)
+ for(i in 1:length(x)) plot.cophylo(x[[i]],...)
+}
+
+## plot an object of class "cophylo"
+## written by Liam J. Revell 2015, 2016, 2017, 2021, 2023
+
+plot.cophylo<-function(x,...){
+ plot.new()
+ if(hasArg(type)) type<-list(...)$type
+ else type<-"phylogram"
+ if(hasArg(mar)) mar<-list(...)$mar
+ else mar<-c(0.1,0.1,0.1,0.1)
+ if(hasArg(xlim)) xlim<-list(...)$xlim
+ else xlim<-c(-0.5,0.5)
+ if(hasArg(scale.bar)) scale.bar<-list(...)$scale.bar
+ else scale.bar<-rep(0,2)
+ if(hasArg(ylim)) ylim<-list(...)$ylim
+ else ylim<-if(any(scale.bar>0)) c(-0.1,1) else c(0,1)
+ if(hasArg(link.type)) link.type<-list(...)$link.type
+ else link.type<-"straight"
+ if(hasArg(link.lwd)) link.lwd<-list(...)$link.lwd
+ else link.lwd<-1
+ if(hasArg(link.col)) link.col<-list(...)$link.col
+ else link.col<-"black"
+ if(hasArg(link.lty)) link.lty<-list(...)$link.lty
+ else link.lty<-"dashed"
+ if(hasArg(edge.col)) edge.col<-list(...)$edge.col
+ else edge.col<-list(
+ left=rep("black",nrow(x$trees[[1]]$edge)),
+ right=rep("black",nrow(x$trees[[2]]$edge)))
+ obj<-list(...)
+ if(is.null(obj$part)) obj$part<-0.4
+ par(mar=mar)
+ plot.window(xlim=xlim,ylim=ylim)
+ leftArgs<-rightArgs<-obj
+ leftArgs$edge.col<-edge.col$left
+ rightArgs$edge.col<-edge.col$right
+ if(!is.null(obj$fsize)){
+ if(length(obj$fsize)>1){
+ leftArgs$fsize<-obj$fsize[1]
+ rightArgs$fsize<-obj$fsize[2]
+ sb.fsize<- if(length(obj$fsize)>2) obj$fsize[3] else 1
+ } else sb.fsize<-1
+ } else sb.fsize<-1
+ plotter<-if(type=="cladogram") "cladogram" else "phylogram"
+ x1<-do.call(plotter,c(list(tree=x$trees[[1]]),leftArgs))
+ left<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ x2<-do.call(plotter,c(list(tree=x$trees[[2]],direction="leftwards"),
+ rightArgs))
+ right<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ if(!is.null(x$assoc)) makelinks(x,c(x1,x2),link.type,link.lwd,link.col,
+ link.lty)
+ else cat("No associations provided.\n")
+ assign("last_plot.cophylo",list(left=left,right=right),envir=.PlotPhyloEnv)
+ if(any(scale.bar>0)) add.scalebar(x,scale.bar,sb.fsize)
+}
+
+## add scale bar
+## written by Liam J. Revell 2015, 2023
+
+add.scalebar<-function(obj,scale.bar,fsize){
+ if(scale.bar[1]>0){
+ pp<-get("last_plot.cophylo",envir=.PlotPhyloEnv)[[1]]
+ s1<-diff(range(pp$xx))/max(nodeHeights(obj$trees[[1]]))
+ lines(c(-0.5,-0.5+scale.bar[1]*s1),rep(-0.05,2))
+ lines(rep(-0.5,2),c(-0.05,-0.06))
+ lines(rep(-0.5+scale.bar[1]*s1,2),c(-0.05,-0.06))
+ text(mean(c(-0.5,-0.5+scale.bar[1]*s1)),rep(-0.05,2),scale.bar[1],pos=1)
+ }
+ if(scale.bar[2]>0){
+ pp<-get("last_plot.cophylo",envir=.PlotPhyloEnv)[[2]]
+ s2<-diff(range(pp$xx))/max(nodeHeights(obj$trees[[2]]))
+ lines(c(0.5-scale.bar[2]*s2,0.5),rep(-0.05,2))
+ lines(rep(0.5-scale.bar[2]*s2,2),c(-0.05,-0.06))
+ lines(rep(0.5,2),c(-0.05,-0.06))
+ text(mean(c(0.5-scale.bar[2]*s2,0.5)),rep(-0.05,2),scale.bar[2],pos=1)
+ }
+}
+
+## print an object of class "cophylo"
+## written by Liam J. Revell 2015
+
+print.cophylo<-function(x, ...){
+ cat("Object of class \"cophylo\" containing:\n\n")
+ cat("(1) 2 (possibly rotated) phylogenetic trees in an object of class \"multiPhylo\".\n\n")
+ cat("(2) A table of associations between the tips of both trees.\n\n")
+}
+
+## print method for "multiCophylo" object
+
+print.multiCophylo<-function(x, ...)
+ cat("Object of class \"multiCophylo\" containg",length(x),"objects of class \"cophylo\".\n\n")
+
+## written by Liam J. Revell 2015, 2016
+
+tipRotate<-function(tree,x,...){
+ if(hasArg(fn)) fn<-list(...)$fn
+ else fn<-function(x) x^2
+ if(hasArg(methods)) methods<-list(...)$methods
+ else methods<-"pre"
+ if("exhaustive"%in%methods) methods<-"exhaustive"
+ if(hasArg(print)) print<-list(...)$print
+ else print<-FALSE
+ if(hasArg(max.exhaustive)) max.exhaustive<-list(...)$max.exhaustive
+ else max.exhaustive<-20
+ if(hasArg(rotate.multi)) rotate.multi<-list(...)$rotate.multi
+ else rotate.multi<-FALSE
+ if(rotate.multi) rotate.multi<-!is.binary(tree)
+ if(hasArg(anim.cophylo)) anim.cophylo<-list(...)$anim.cophylo
+ else anim.cophylo<-FALSE
+ if(anim.cophylo){
+ if(hasArg(left)) left<-list(...)$left
+ else left<-NULL
+ if(hasArg(right)) right<-list(...)$right
+ else right<-NULL
+ if(hasArg(assoc)) assoc<-list(...)$assoc
+ else assoc<-NULL
+ if(is.null(left)&&is.null(right)) anim.cophylo<-FALSE
+ if(hasArg(only.accepted)) only.accepted<-list(...)$only.accepted
+ else only.accepted<-TRUE
+ }
+ tree<-reorder(tree)
+ nn<-1:tree$Nnode+length(tree$tip.label)
+ if("just.compute"%in%methods){
+ foo<-function(phy,x) sum(fn(x-setNames(1:length(phy$tip.label),phy$tip.label)[names(x)]))
+ oo<-pp<-foo(tree,x)
+ }
+ if("exhaustive"%in%methods){
+ if(Ntip(tree)>max.exhaustive){
+ cat(paste("\nmethods=\"exhaustive\" not permitted for more than",
+ max.exhaustive,"tips.\n",
+ "If you are sure you want to run an exhaustive search for a tree of this size\n",
+ "increasing argument max.exhaustive & re-run.\n",
+ "Setting methods to \"pre\".\n\n"))
+ methods<-"pre"
+ } else {
+ cat("Running exhaustive search. May be slow!\n")
+ oo<-Inf
+ tt<-allRotations(tree)
+ foo<-function(phy,x) sum(fn(x-setNames(1:length(phy$tip.label),phy$tip.label)[names(x)]))
+ pp<-sapply(tt,foo,x=x)
+ ii<-which(pp==min(pp))
+ ii<-if(length(ii)>1) sample(ii,1) else ii
+ tt<-tt[[ii]]
+ pp<-pp[ii]
+ }
+ if(print) message(paste("objective:",pp))
+ tree<-tt
+ }
+ ANIM.COPHYLO<-function(tree){
+ dev.hold()
+ if(is.null(left)) plot(cophylo(tree,right,assoc=assoc,rotate=FALSE),...)
+ else if(is.null(right)) plot(cophylo(left,tree,assoc=assoc,rotate=FALSE),...)
+ nodelabels.cophylo(node=i+Ntip(tree),pie=1,col="red",cex=0.4,
+ which=if(is.null(left)) "left" else "right")
+ dev.flush()
+ }
+ if("pre"%in%methods){
+ for(i in 1:tree$Nnode){
+ if(anim.cophylo) ANIM.COPHYLO(tree)
+ tt<-if(rotate.multi) rotate.multi(tree,nn[i]) else untangle(rotate(tree,nn[i]),"read.tree")
+ oo<-sum(fn(x-setNames(1:length(tree$tip.label),tree$tip.label)[names(x)]))
+ if(inherits(tt,"phylo")) pp<-sum(fn(x-setNames(1:length(tt$tip.label),tt$tip.label)[names(x)]))
+ if(anim.cophylo&&!only.accepted) ANIM.COPHYLO(tt)
+ else if(inherits(tt,"multiPhylo")){
+ foo<-function(phy,x) sum(fn(x-setNames(1:length(phy$tip.label),phy$tip.label)[names(x)]))
+ pp<-sapply(tt,foo,x=x)
+ if(anim.cophylo&&!only.accepted) nulo<-lapply(tt,ANIM.COPHYLO)
+ ii<-which(pp==min(pp))
+ ii<-if(length(ii)>1) sample(ii,1) else ii
+ tt<-tt[[ii]]
+ pp<-pp[ii]
+ }
+ if(oo>pp) tree<-tt
+ if(print) message(paste("objective:",min(oo,pp)))
+ }
+ }
+ if("post"%in%methods){
+ for(i in tree$Nnode:1){
+ if(anim.cophylo) ANIM.COPHYLO(tree)
+ tt<-if(rotate.multi) rotate.multi(tree,nn[i]) else untangle(rotate(tree,nn[i]),"read.tree")
+ oo<-sum(fn(x-setNames(1:length(tree$tip.label),tree$tip.label)[names(x)]))
+ if(inherits(tt,"phylo")) pp<-sum(fn(x-setNames(1:length(tt$tip.label),tt$tip.label)[names(x)]))
+ if(anim.cophylo&&!only.accepted) ANIM.COPHYLO(tt)
+ else if(inherits(tt,"multiPhylo")){
+ foo<-function(phy,x) sum(fn(x-setNames(1:length(phy$tip.label),phy$tip.label)[names(x)]))
+ pp<-sapply(tt,foo,x=x)
+ if(anim.cophylo&&!only.accepted) nulo<-lapply(tt,ANIM.COPHYLO)
+ ii<-which(pp==min(pp))
+ ii<-if(length(ii)>1) sample(ii,1) else ii
+ tt<-tt[[ii]]
+ pp<-pp[ii]
+ }
+ if(oo>pp) tree<-tt
+ if(print) message(paste("objective:",min(oo,pp)))
+ }
+ }
+ attr(tree,"minRotate")<-min(oo,pp)
+ if(anim.cophylo) ANIM.COPHYLO(tree)
+ tree
+}
+
+## multi2di for "multiPhylo" object
+
+MULTI2DI<-function(x,...){
+ obj<-lapply(x,multi2di,...)
+ class(obj)<-"multiPhylo"
+ obj
+}
+
+## labeling methods for plotted "cophylo" object
+## written by Liam J. Revell 2015
+
+nodelabels.cophylo<-function(...,which=c("left","right")){
+ obj<-get("last_plot.cophylo",envir=.PlotPhyloEnv)
+ if(which[1]=="left") assign("last_plot.phylo",obj[[1]],envir=.PlotPhyloEnv)
+ else if(which[1]=="right") assign("last_plot.phylo",obj[[2]],envir=.PlotPhyloEnv)
+ nodelabels(...)
+}
+
+edgelabels.cophylo<-function(...,which=c("left","right")){
+ obj<-get("last_plot.cophylo",envir=.PlotPhyloEnv)
+ if(which[1]=="left") assign("last_plot.phylo",obj[[1]],envir=.PlotPhyloEnv)
+ else if(which[1]=="right") assign("last_plot.phylo",obj[[2]],envir=.PlotPhyloEnv)
+ edgelabels(...)
+}
+
+tiplabels.cophylo<-function(...,which=c("left","right")){
+ obj<-get("last_plot.cophylo",envir=.PlotPhyloEnv)
+ if(which[1]=="left") assign("last_plot.phylo",obj[[1]],envir=.PlotPhyloEnv)
+ else if(which[1]=="right") assign("last_plot.phylo",obj[[2]],envir=.PlotPhyloEnv)
+ tiplabels(...)
+}
+
+## function to draw sigmoidal links
+## modified from https://stackoverflow.com/questions/32046889/connecting-two-points-with-curved-lines-s-ish-curve-in-r
+
+drawCurve<-function(x,y,scale=0.01,...){
+ x1<-x[1]
+ x2<-x[2]
+ y1<-y[1]
+ y2<-y[2]
+ curve(plogis(x,scale=scale,location=(x1+x2)/2)*(y2-y1)+y1,
+ x1,x2,add=TRUE,...)
+}
+
+## S3 summary method
+## written by Liam J. Revell 2016
+
+summary.cophylo<-function(object,...){
+ cat("\nCo-phylogenetic (\"cophylo\") object:",deparse(substitute(object)),
+ "\n\n")
+ cat(paste("Tree 1 (left tree) is an object of class \"phylo\" containing",
+ Ntip(object$trees[[1]]),"species.\n\n"))
+ cat(paste("Tree 2 (right tree) is an object of class \"phylo\" containing",
+ Ntip(object$trees[[2]]),"species.\n\n"))
+ cat("Association (assoc) table as follows:\n\n")
+ maxl<-max(sapply(strsplit(object$assoc[,1],""),length))
+ cat(paste("\tleft:",paste(rep(" ",max(0,maxl-5)),collapse=""),
+ "\t----\tright:\n",sep=""))
+ nulo<-apply(object$assoc,1,function(x,maxl) cat(paste("\t",x[1],
+ paste(rep(" ",maxl-length(strsplit(x[1],split="")[[1]])),
+ collapse=""),"\t----\t",x[2],"\n",sep="")),maxl=maxl)
+ cat("\n")
+}
+
diff --git a/R/cospeciation.R b/R/cospeciation.R
index 22711f9..053551f 100644
--- a/R/cospeciation.R
+++ b/R/cospeciation.R
@@ -1,107 +1,107 @@
-## cospeciation method
-## written by Liam J. Revell 2016
-
-cospeciation<-function(t1,t2,distance=c("RF","SPR"),
- method=c("simulation","permutation"),assoc=NULL,
- nsim=100,...){
- distance<-distance[1]
- if(!distance%in%c("RF","SPR")) distance<-"RF"
- method<-method[1]
- if(!method%in%c("simulation","permutation"))
- method<-"simulation"
- if(is.null(assoc)){
- ## assume exact match
- tips<-intersect(t1$tip.label,t2$tip.label)
- assoc<-cbind(tips,tips)
- }
- if(any(!t1$tip.label%in%assoc[,1]))
- t1<-drop.tip(t1,setdiff(t1$tip.label,assoc[,1]))
- if(any(!assoc[,1]%in%t1$tip.label))
- assoc<-assoc[assoc[,1]%in%t1$tip.label,]
- if(any(!t2$tip.label%in%assoc[,2]))
- t2<-drop.tip(t2,setdiff(t2$tip.label,assoc[,2]))
- if(any(!assoc[,2]%in%t2$tip.label))
- assoc<-assoc[assoc[,2]%in%t2$tip.label,]
- if(method=="permutation"){
- perm.labels<-function(tree){
- tree$tip.label<-sample(tree$tip.label)
- tree
- }
- tt1<-replicate(nsim,perm.labels(t1),simplify=FALSE)
- swap.t2<-t2
- swap.t2$tip.label<-sapply(t2$tip.label,function(x,y)
- y[which(y[,2]==x),1],y=assoc)
- tt2<-replicate(nsim,perm.labels(swap.t2),simplify=FALSE)
- } else {
- tt1<-pbtree(n=Ntip(t1),tip.label=t1$tip.label,
- nsim=nsim)
- swap.t2<-t2
- swap.t2$tip.label<-sapply(t2$tip.label,function(x,y)
- y[which(y[,2]==x),1],y=assoc)
- tt2<-pbtree(n=Ntip(t2),tip.label=swap.t2$tip.label,
- nsim=nsim)
-
- }
- if(distance=="SPR"){
- d.null<-mapply(SPR.dist,tt1,tt2)
- d<-SPR.dist(t1,swap.t2)
- P.val<-mean(c(d,d.null)<=d)
- } else {
- d.null<-mapply(RF.dist,tt1,tt2)
- d<-RF.dist(t1,swap.t2)
- P.val<-mean(c(d,d.null)<=d)
- }
- obj<-list(d=d,d.null=d.null,P.val=P.val,
- distance=if(distance=="SPR") "SPR" else "RF",
- method=if(method=="simulation") "simulation" else
- "permutation")
- class(obj)<-"cospeciation"
- obj
-}
-
-print.cospeciation<-function(x,...){
- cat(paste("\nCo-speciation test based on",x$distance,
- "distance.\n"))
- cat(paste("P-value obtained via",x$method,".\n\n"))
- if(x$distance=="SPR")
- cat(paste(" SPR distance:",x$d,"\n"))
- else
- cat(paste(" RF distance:",x$d,"\n"))
- cat(paste(" Mean(SD) from null: ",
- round(mean(x$d.null),1),"(",
- round(sd(x$d.null),1),")\n",sep=""))
- cat(paste(" P-value:",round(x$P.val,6),"\n\n"))
-}
-
-plot.cospeciation<-function(x,...){
- if(hasArg(bty)) bty<-list(...)$bty
- else bty<-"l"
- if(x$distance=="RF")
- p<-hist(x$d.null,breaks=seq(min(c(x$d,x$d.null))-3,
- max(c(x$d,x$d.null))+3,2),plot=FALSE)
- else if(x$distance=="SPR")
- p<-hist(x$d.null,breaks=seq(min(c(x$d,x$d.null))-1.5,
- max(c(x$d,x$d.null))+1.5,1),plot=FALSE)
- plot(p$mids,p$density,xlim=c(min(c(x$d,x$d.null))-2,
- max(c(x$d,x$d.null))+1),ylim=c(0,1.2*max(p$density)),
- type="n",bty=bty,
- xlab=paste(x$distance," distance (null by ",
- x$method,")",sep=""),ylab="relative frequency")
- y2<-rep(p$density,each=2)
- y2<-y2[-length(y2)]
- x2<-rep(p$breaks[2:length(p$breaks)-1],each=2)[-1]
- x3<-c(min(x2),x2,max(x2))
- y3<-c(0,y2,0)
- polygon(x3,y3,col=make.transparent("blue",0.3),
- border=FALSE)
- lines(p$breaks[2:length(p$breaks)-1],p$density,type="s")
- arrows(x$d,max(c(0.2*max(p$density),
- 1.1*p$density[which(p$mids==x$d)])),
- x$d,0,lend="round",
- length=0.15,lwd=2,col="black")
- text(x$d-diff(par()$usr[1:2])/40,
- 1.1*max(c(0.2*max(p$density),
- 1.1*p$density[which(p$mids==x$d)])),
- "observed distance",
- srt=60,pos=4)
-}
+## cospeciation method
+## written by Liam J. Revell 2016
+
+cospeciation<-function(t1,t2,distance=c("RF","SPR"),
+ method=c("simulation","permutation"),assoc=NULL,
+ nsim=100,...){
+ distance<-distance[1]
+ if(!distance%in%c("RF","SPR")) distance<-"RF"
+ method<-method[1]
+ if(!method%in%c("simulation","permutation"))
+ method<-"simulation"
+ if(is.null(assoc)){
+ ## assume exact match
+ tips<-intersect(t1$tip.label,t2$tip.label)
+ assoc<-cbind(tips,tips)
+ }
+ if(any(!t1$tip.label%in%assoc[,1]))
+ t1<-drop.tip(t1,setdiff(t1$tip.label,assoc[,1]))
+ if(any(!assoc[,1]%in%t1$tip.label))
+ assoc<-assoc[assoc[,1]%in%t1$tip.label,]
+ if(any(!t2$tip.label%in%assoc[,2]))
+ t2<-drop.tip(t2,setdiff(t2$tip.label,assoc[,2]))
+ if(any(!assoc[,2]%in%t2$tip.label))
+ assoc<-assoc[assoc[,2]%in%t2$tip.label,]
+ if(method=="permutation"){
+ perm.labels<-function(tree){
+ tree$tip.label<-sample(tree$tip.label)
+ tree
+ }
+ tt1<-replicate(nsim,perm.labels(t1),simplify=FALSE)
+ swap.t2<-t2
+ swap.t2$tip.label<-sapply(t2$tip.label,function(x,y)
+ y[which(y[,2]==x),1],y=assoc)
+ tt2<-replicate(nsim,perm.labels(swap.t2),simplify=FALSE)
+ } else {
+ tt1<-pbtree(n=Ntip(t1),tip.label=t1$tip.label,
+ nsim=nsim)
+ swap.t2<-t2
+ swap.t2$tip.label<-sapply(t2$tip.label,function(x,y)
+ y[which(y[,2]==x),1],y=assoc)
+ tt2<-pbtree(n=Ntip(t2),tip.label=swap.t2$tip.label,
+ nsim=nsim)
+
+ }
+ if(distance=="SPR"){
+ d.null<-mapply(SPR.dist,tt1,tt2)
+ d<-SPR.dist(t1,swap.t2)
+ P.val<-mean(c(d,d.null)<=d)
+ } else {
+ d.null<-mapply(RF.dist,tt1,tt2)
+ d<-RF.dist(t1,swap.t2)
+ P.val<-mean(c(d,d.null)<=d)
+ }
+ obj<-list(d=d,d.null=d.null,P.val=P.val,
+ distance=if(distance=="SPR") "SPR" else "RF",
+ method=if(method=="simulation") "simulation" else
+ "permutation")
+ class(obj)<-"cospeciation"
+ obj
+}
+
+print.cospeciation<-function(x,...){
+ cat(paste("\nCo-speciation test based on",x$distance,
+ "distance.\n"))
+ cat(paste("P-value obtained via",x$method,".\n\n"))
+ if(x$distance=="SPR")
+ cat(paste(" SPR distance:",x$d,"\n"))
+ else
+ cat(paste(" RF distance:",x$d,"\n"))
+ cat(paste(" Mean(SD) from null: ",
+ round(mean(x$d.null),1),"(",
+ round(sd(x$d.null),1),")\n",sep=""))
+ cat(paste(" P-value:",round(x$P.val,6),"\n\n"))
+}
+
+plot.cospeciation<-function(x,...){
+ if(hasArg(bty)) bty<-list(...)$bty
+ else bty<-"l"
+ if(x$distance=="RF")
+ p<-hist(x$d.null,breaks=seq(min(c(x$d,x$d.null))-3,
+ max(c(x$d,x$d.null))+3,2),plot=FALSE)
+ else if(x$distance=="SPR")
+ p<-hist(x$d.null,breaks=seq(min(c(x$d,x$d.null))-1.5,
+ max(c(x$d,x$d.null))+1.5,1),plot=FALSE)
+ plot(p$mids,p$density,xlim=c(min(c(x$d,x$d.null))-2,
+ max(c(x$d,x$d.null))+1),ylim=c(0,1.2*max(p$density)),
+ type="n",bty=bty,
+ xlab=paste(x$distance," distance (null by ",
+ x$method,")",sep=""),ylab="relative frequency")
+ y2<-rep(p$density,each=2)
+ y2<-y2[-length(y2)]
+ x2<-rep(p$breaks[2:length(p$breaks)-1],each=2)[-1]
+ x3<-c(min(x2),x2,max(x2))
+ y3<-c(0,y2,0)
+ polygon(x3,y3,col=make.transparent("blue",0.3),
+ border=FALSE)
+ lines(p$breaks[2:length(p$breaks)-1],p$density,type="s")
+ arrows(x$d,max(c(0.2*max(p$density),
+ 1.1*p$density[which(p$mids==x$d)])),
+ x$d,0,lend="round",
+ length=0.15,lwd=2,col="black")
+ text(x$d-diff(par()$usr[1:2])/40,
+ 1.1*max(c(0.2*max(p$density),
+ 1.1*p$density[which(p$mids==x$d)])),
+ "observed distance",
+ srt=60,pos=4)
+}
diff --git a/R/cotangleplot.R b/R/cotangleplot.R
index 4a9aa7b..5c787ed 100644
--- a/R/cotangleplot.R
+++ b/R/cotangleplot.R
@@ -1,100 +1,100 @@
-cotangleplot<-function(tr1,tr2,type=c("cladogram","phylogram"),
- use.edge.length=TRUE,tangle=c("both","tree1","tree2"),...){
- tr1<-untangle(tr1,"read.tree")
- tr2<-untangle(tr2,"read.tree")
- type<-type[1]
- tangle<-tangle[1]
- if(!use.edge.length){
- tr1<-compute.brlen(tr1)
- tr2<-compute.brlen(tr2)
- }
- if(hasArg(layout)) layout<-list(...)$layout
- else layout<-c(0.45,0.1,0.45)
- if(hasArg(nodes)) nodes<-list(...)$nodes
- else nodes<-"centered"
- if(hasArg(lty)) lty<-list(...)$lty
- else lty<-if(type=="phylogram") c("dotted","solid") else
- if(type=="cladogram") "solid"
- if(type=="phylogram") if(length(lty)==1) lty<-rep(lty,2)
- if(hasArg(lwd)) lwd<-list(...)$lwd
- else lwd<-2
- if(hasArg(cex)) cex<-list(...)$cex
- else cex<-1
- if(hasArg(color)) color<-list(...)$color
- else color<-palette()[4]
- if(tangle=="both"){
- capture.output(tmp<-cophylo(tr1,tr2))
- tips.tr1<-setNames(1:Ntip(tr1),tmp$trees[[1]]$tip.label)
- tips.tr2<-setNames(1:Ntip(tr2),tmp$trees[[2]]$tip.label)
- tips<-sort(rowMeans(cbind(tips.tr1,tips.tr2[names(tips.tr1)])))
- tips[]<-1:length(tips)
- } else if(tangle=="tree1"){
- tips<-setNames(1:Ntip(tr2),tr2$tip.label)
- } else if(tangle=="tree2"){
- tips<-setNames(1:Ntip(tr1),tr1$tip.label)
- }
- layout(matrix(c(1,2,3),1,3),widths=layout)
- plotTree(tr1,color="transparent",ftype="off",tips=tips,type=type,
- nodes=nodes)
- h<-par()$usr[2]
- pp<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- for(i in 1:Ntip(tr1)) lines(c(pp$xx[i],h),rep(pp$yy[i],2),
- lty="dotted")
- if(type=="phylogram"){
- for(i in 1:nrow(tr1$edge))
- lines(pp$xx[tr1$edge[i,]],rep(pp$yy[tr1$edge[i,2]],2),
- lwd=lwd,col=color,lty=lty[2])
- for(i in Ntip(tr1)+1:tr1$Nnode){
- dd<-Children(tr1,i)
- lines(rep(pp$xx[i],length(dd)),pp$yy[dd],lwd=lwd,
- col=color,lty=lty[1])
- }
- } else if(type=="cladogram"){
- par(ljoin=2)
- for(i in 1:Ntip(tr1)){
- AA<-c(i,Ancestors(tr1,i))
- ii<-sapply(AA[1:(length(AA)-1)],function(x,y)
- which(y==x), y=tr1$edge[,2])
- lines(c(pp$xx[tr1$edge[ii,2]],pp$xx[Ntip(tr1)+1]),
- c(pp$yy[tr1$edge[ii,2]],pp$yy[Ntip(tr1)+1]),
- lwd=lwd+2,
- col=if(par()$bg=="transparent") "white" else par()$bg,
- lty="solid")
- lines(c(pp$xx[tr1$edge[ii,2]],pp$xx[Ntip(tr1)+1]),
- c(pp$yy[tr1$edge[ii,2]],pp$yy[Ntip(tr1)+1]),
- lwd=lwd,col=color,lty=lty)
- }
- }
- plot(NA,xlim=c(-1,1),ylim=pp$y.lim,axes=FALSE,xlab="",ylab="")
- text(rep(0,Ntip(tr1)),tips,gsub("_"," ",names(tips)),cex=cex,font=3)
- plotTree(tr2,color="transparent",ftype="off",direction="leftwards",
- tips=tips,type=type)
- h<-par()$usr[1]
- pp<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- for(i in 1:Ntip(tr2)) lines(c(pp$xx[i],h),rep(pp$yy[i],2),
- lty="dotted")
- if(type=="phylogram"){
- for(i in 1:nrow(tr2$edge))
- lines(pp$xx[tr2$edge[i,]],rep(pp$yy[tr2$edge[i,2]],2),
- lwd=lwd,col=color,lty=lty[2])
- for(i in Ntip(tr2)+1:tr2$Nnode){
- dd<-Children(tr2,i)
- lines(rep(pp$xx[i],length(dd)),sort(pp$yy[dd]),
- lwd=lwd,col=color,lty=lty[1])
- }
- } else if(type=="cladogram"){
- for(i in 1:Ntip(tr2)){
- AA<-c(i,Ancestors(tr2,i))
- ii<-sapply(AA[1:(length(AA)-1)],function(x,y)
- which(y==x), y=tr2$edge[,2])
- lines(c(pp$xx[tr2$edge[ii,2]],pp$xx[Ntip(tr2)+1]),
- c(pp$yy[tr2$edge[ii,2]],pp$yy[Ntip(tr2)+1]),
- lwd=lwd+2,
- col=if(par()$bg=="transparent") "white" else par()$bg,
- lty="solid")
- lines(c(pp$xx[tr2$edge[ii,2]],pp$xx[Ntip(tr2)+1]),
- c(pp$yy[tr2$edge[ii,2]],pp$yy[Ntip(tr2)+1]),
- lwd=lwd,col=color,lty=lty)
- }
- }
+cotangleplot<-function(tr1,tr2,type=c("cladogram","phylogram"),
+ use.edge.length=TRUE,tangle=c("both","tree1","tree2"),...){
+ tr1<-untangle(tr1,"read.tree")
+ tr2<-untangle(tr2,"read.tree")
+ type<-type[1]
+ tangle<-tangle[1]
+ if(!use.edge.length){
+ tr1<-compute.brlen(tr1)
+ tr2<-compute.brlen(tr2)
+ }
+ if(hasArg(layout)) layout<-list(...)$layout
+ else layout<-c(0.45,0.1,0.45)
+ if(hasArg(nodes)) nodes<-list(...)$nodes
+ else nodes<-"centered"
+ if(hasArg(lty)) lty<-list(...)$lty
+ else lty<-if(type=="phylogram") c("dotted","solid") else
+ if(type=="cladogram") "solid"
+ if(type=="phylogram") if(length(lty)==1) lty<-rep(lty,2)
+ if(hasArg(lwd)) lwd<-list(...)$lwd
+ else lwd<-2
+ if(hasArg(cex)) cex<-list(...)$cex
+ else cex<-1
+ if(hasArg(color)) color<-list(...)$color
+ else color<-palette()[4]
+ if(tangle=="both"){
+ capture.output(tmp<-cophylo(tr1,tr2))
+ tips.tr1<-setNames(1:Ntip(tr1),tmp$trees[[1]]$tip.label)
+ tips.tr2<-setNames(1:Ntip(tr2),tmp$trees[[2]]$tip.label)
+ tips<-sort(rowMeans(cbind(tips.tr1,tips.tr2[names(tips.tr1)])))
+ tips[]<-1:length(tips)
+ } else if(tangle=="tree1"){
+ tips<-setNames(1:Ntip(tr2),tr2$tip.label)
+ } else if(tangle=="tree2"){
+ tips<-setNames(1:Ntip(tr1),tr1$tip.label)
+ }
+ layout(matrix(c(1,2,3),1,3),widths=layout)
+ plotTree(tr1,color="transparent",ftype="off",tips=tips,type=type,
+ nodes=nodes)
+ h<-par()$usr[2]
+ pp<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ for(i in 1:Ntip(tr1)) lines(c(pp$xx[i],h),rep(pp$yy[i],2),
+ lty="dotted")
+ if(type=="phylogram"){
+ for(i in 1:nrow(tr1$edge))
+ lines(pp$xx[tr1$edge[i,]],rep(pp$yy[tr1$edge[i,2]],2),
+ lwd=lwd,col=color,lty=lty[2])
+ for(i in Ntip(tr1)+1:tr1$Nnode){
+ dd<-Children(tr1,i)
+ lines(rep(pp$xx[i],length(dd)),pp$yy[dd],lwd=lwd,
+ col=color,lty=lty[1])
+ }
+ } else if(type=="cladogram"){
+ par(ljoin=2)
+ for(i in 1:Ntip(tr1)){
+ AA<-c(i,Ancestors(tr1,i))
+ ii<-sapply(AA[1:(length(AA)-1)],function(x,y)
+ which(y==x), y=tr1$edge[,2])
+ lines(c(pp$xx[tr1$edge[ii,2]],pp$xx[Ntip(tr1)+1]),
+ c(pp$yy[tr1$edge[ii,2]],pp$yy[Ntip(tr1)+1]),
+ lwd=lwd+2,
+ col=if(par()$bg=="transparent") "white" else par()$bg,
+ lty="solid")
+ lines(c(pp$xx[tr1$edge[ii,2]],pp$xx[Ntip(tr1)+1]),
+ c(pp$yy[tr1$edge[ii,2]],pp$yy[Ntip(tr1)+1]),
+ lwd=lwd,col=color,lty=lty)
+ }
+ }
+ plot(NA,xlim=c(-1,1),ylim=pp$y.lim,axes=FALSE,xlab="",ylab="")
+ text(rep(0,Ntip(tr1)),tips,gsub("_"," ",names(tips)),cex=cex,font=3)
+ plotTree(tr2,color="transparent",ftype="off",direction="leftwards",
+ tips=tips,type=type)
+ h<-par()$usr[1]
+ pp<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ for(i in 1:Ntip(tr2)) lines(c(pp$xx[i],h),rep(pp$yy[i],2),
+ lty="dotted")
+ if(type=="phylogram"){
+ for(i in 1:nrow(tr2$edge))
+ lines(pp$xx[tr2$edge[i,]],rep(pp$yy[tr2$edge[i,2]],2),
+ lwd=lwd,col=color,lty=lty[2])
+ for(i in Ntip(tr2)+1:tr2$Nnode){
+ dd<-Children(tr2,i)
+ lines(rep(pp$xx[i],length(dd)),sort(pp$yy[dd]),
+ lwd=lwd,col=color,lty=lty[1])
+ }
+ } else if(type=="cladogram"){
+ for(i in 1:Ntip(tr2)){
+ AA<-c(i,Ancestors(tr2,i))
+ ii<-sapply(AA[1:(length(AA)-1)],function(x,y)
+ which(y==x), y=tr2$edge[,2])
+ lines(c(pp$xx[tr2$edge[ii,2]],pp$xx[Ntip(tr2)+1]),
+ c(pp$yy[tr2$edge[ii,2]],pp$yy[Ntip(tr2)+1]),
+ lwd=lwd+2,
+ col=if(par()$bg=="transparent") "white" else par()$bg,
+ lty="solid")
+ lines(c(pp$xx[tr2$edge[ii,2]],pp$xx[Ntip(tr2)+1]),
+ c(pp$yy[tr2$edge[ii,2]],pp$yy[Ntip(tr2)+1]),
+ lwd=lwd,col=color,lty=lty)
+ }
+ }
}
\ No newline at end of file
diff --git a/R/ctt.R b/R/ctt.R
index 8e0c3fd..d64ec8c 100644
--- a/R/ctt.R
+++ b/R/ctt.R
@@ -1,158 +1,158 @@
-## computing the mean number of character changes through time from a set of stochastic map trees
-## written by Liam J. Revell 2017, 2020
-
-ctt<-function(trees,segments=20,...){
- if(!(inherits(trees,"multiSimmap")))
- stop("trees should be an object of class \"multiSimmap\".")
- tree<-as.phylo(trees[[1]])
- changes<-sapply(trees,getChanges)
- h<-max(nodeHeights(tree))
- b<-segments
- segs<-cbind(seq(0,h-h/b,h/b),
- seq(1/b*h,h,h/b))
- nchanges<-rep(0,b)
- for(i in 1:length(changes)){
- for(j in 1:length(changes[[i]])){
- ind<-which((changes[[i]][j]>segs[,1])+
- (changes[[i]][j]<=segs[,2])==2)
- nchanges[ind]<-nchanges[ind]+1/length(changes)
- }
- }
- LTT<-ltt(tree,plot=FALSE)
- LTT<-cbind(LTT$ltt[2:(length(LTT$ltt)-1)],
- LTT$times[2:(length(LTT$ltt)-1)],
- LTT$times[3:length(LTT$ltt)])
- ii<-1
- edge.length<-rep(0,b)
- for(i in 1:nrow(segs)){
- done.seg<-FALSE
- while(LTT[ii,2]<=segs[i,2]&&done.seg==FALSE){
- edge.length[i]<-edge.length[i]+
- LTT[ii,1]*(min(segs[i,2],LTT[ii,3])-
- max(segs[i,1],LTT[ii,2]))
- if(LTT[ii,3]>=segs[i,2]) done.seg<-TRUE
- if(LTT[ii,3]<=segs[i,2]) ii<-if(ii<nrow(LTT)) ii+1 else ii
- }
- }
- object<-list(segments=segs,nchanges=nchanges,edge.length=edge.length,tree=tree)
- class(object)<-"ctt"
- object
-}
-
-plot.ctt<-function(x,...){
- h<-max(nodeHeights(x$tree))
- args<-list(...)
- if(!is.null(args$type)){
- type<-args$type
- args$type<-NULL
- } else type<-"rate"
- if(!is.null(args$show.tree)){
- show.tree<-args$show.tree
- args$show.tree<-NULL
- } else show.tree<-FALSE
- if(!is.null(args$add)){
- add<-args$add
- args$add<-NULL
- } else add<-FALSE
- if(is.null(args$ylim))
- args$ylim<-if(type=="number")c(0,max(x$nchanges)) else
- c(0,max(x$nchanges/x$edge.length))
- if(is.null(args$xlim))
- args$xlim<-c(max(x$segments),min(x$segments))
- if(is.null(args$lwd)) args$lwd<-2
- if(is.null(args$xlab)) args$xlab<-"time since the present"
- if(is.null(args$ylab))
- args$ylab<-if(type=="number") "mean number of changes" else
- "mean number of changes / total edge length"
- args$type<-"l"
- args$x<-h-as.vector(t(x$segments))
- args$y<-if(type=="number") rbind(x$nchanges,x$nchanges) else
- rbind(x$nchanges/x$edge.length,x$nchanges/x$edge.length)
- if(!add) do.call(plot,args)
- else do.call(lines,args)
- if(show.tree) plotTree(x$tree,add=TRUE,ftype="off",lwd=1,
- color=make.transparent("blue",0.1),mar=par()$mar,
- direction="leftwards",xlim=args$xlim)
-}
-
-sim.ctt<-function(tree,Q,anc=NULL,nmaps=100,...){
- x<-as.factor(sim.history(tree,Q,anc=anc,message=FALSE)$states)
- while(length(levels(x))!=ncol(Q))
- x<-as.factor(sim.history(tree,Q,anc=anc,message=FALSE)$states)
- flush.console()
- cat("Starting stochastic mapping with simulated data vector.... ")
- flush.console()
- trees<-make.simmap(tree,x,Q=Q,nsim=nmaps,message=FALSE)
- cat("Done.\n")
- flush.console()
- ctt(trees,...)
-}
-
-sim.multiCtt<-function(tree,Q,anc=NULL,nmaps=100,nsim=100,...){
- object<-lapply(1:nsim,sim.ctt,tree=tree,Q=Q,anc=anc,nmaps=nmaps,...)
-## object<-replicate(nsim,sim.ctt(tree,Q,anc=anc,nmaps=nmaps,...),simplify=FALSE)
- class(object)<-"multiCtt"
- object
-}
-
-getChanges<-function(tree){
- states<-sort(unique(getStates(tree)))
- nc<-sapply(tree$maps,length)-1
- b<-which(nc>0)
- nc<-nc[b]
- xx<-vector()
- H<-nodeHeights(tree)
- for(i in 1:length(b)){
- for(j in 1:nc[i]){
- ss<-names(tree$maps[[b[i]]])[j+1]
- x<-rep(H[b[i],1]+cumsum(tree$maps[[b[i]]])[j],2)
- xx<-c(xx,setNames(x[1],
- paste(names(tree$maps[[b[i]]])[j:(j+1)],
- collapse="->")))
- }
- }
- xx
-}
-
-print.ctt<-function(x,...){
- cat("Object of class \"ctt\" consisting of:\n")
- cat(" (1) a matrix (segments) with the beginning & ending time of each segment.\n")
- cat(" (2) a vector (nchanges) with the mean number of changes in each segment.\n")
- cat(" (3) a vector (edge.length) containing the total edge length of each segement.\n")
- cat(" (4) an object of class \"phylo\".\n\n")
-}
-
-print.multiCtt<-function(x,...){
- cat(paste(length(x),"objects of class \"ctt\" in a list.\n\n"))
-}
-
-plot.multiCtt<-function(x,...){
- if(hasArg(alpha)) alpha<-list(...)$alpha
- else alpha<-0.05
- segments<-x[[1]]$segments
- nchanges<-sapply(x,function(x) x$nchanges)
- if(hasArg(type)) type<-list(...)$type
- else type<-"rate"
- edge.length<-sapply(x,function(x) x$edge.length)
- obj<-list(segments=segments,nchanges=rowMeans(nchanges),
- edge.length=rowMeans(edge.length),tree=x[[1]]$tree)
- class(obj)<-"ctt"
- lower<-max(floor(alpha/2*length(x)),1)
- upper<-min(ceiling((1-alpha/2)*length(x)),ncol(nchanges))
- xx<-max(nodeHeights(x[[1]]$tree))-as.vector(t(segments))
- xx<-c(xx,xx[length(xx):1])
- y.lower<-if(type=="number") apply(nchanges,1,sort)[lower,] else
- if(type=="rate") apply(nchanges/edge.length,1,sort)[lower,]
- y.upper<-if(type=="number") apply(nchanges,1,sort)[upper,] else
- if(type=="rate") apply(nchanges/edge.length,1,sort)[upper,]
- y.lower<-as.vector(rbind(y.lower,y.lower))
- y.upper<-as.vector(rbind(y.upper,y.upper))
- yy<-c(y.lower,y.upper[length(y.upper):1])
- args<-list(...)
- if(!is.null(args$alpha)) args$alpha<-NULL
- if(is.null(args$col)) args$col<-"blue"
- if(is.null(args$ylim)) args$ylim<-range(yy)
- args$x<-obj
- do.call(plot,args)
- polygon(xx,yy,col=make.transparent("grey",0.4),border=0)
-}
+## computing the mean number of character changes through time from a set of stochastic map trees
+## written by Liam J. Revell 2017, 2020
+
+ctt<-function(trees,segments=20,...){
+ if(!(inherits(trees,"multiSimmap")))
+ stop("trees should be an object of class \"multiSimmap\".")
+ tree<-as.phylo(trees[[1]])
+ changes<-sapply(trees,getChanges)
+ h<-max(nodeHeights(tree))
+ b<-segments
+ segs<-cbind(seq(0,h-h/b,h/b),
+ seq(1/b*h,h,h/b))
+ nchanges<-rep(0,b)
+ for(i in 1:length(changes)){
+ for(j in 1:length(changes[[i]])){
+ ind<-which((changes[[i]][j]>segs[,1])+
+ (changes[[i]][j]<=segs[,2])==2)
+ nchanges[ind]<-nchanges[ind]+1/length(changes)
+ }
+ }
+ LTT<-ltt(tree,plot=FALSE)
+ LTT<-cbind(LTT$ltt[2:(length(LTT$ltt)-1)],
+ LTT$times[2:(length(LTT$ltt)-1)],
+ LTT$times[3:length(LTT$ltt)])
+ ii<-1
+ edge.length<-rep(0,b)
+ for(i in 1:nrow(segs)){
+ done.seg<-FALSE
+ while(LTT[ii,2]<=segs[i,2]&&done.seg==FALSE){
+ edge.length[i]<-edge.length[i]+
+ LTT[ii,1]*(min(segs[i,2],LTT[ii,3])-
+ max(segs[i,1],LTT[ii,2]))
+ if(LTT[ii,3]>=segs[i,2]) done.seg<-TRUE
+ if(LTT[ii,3]<=segs[i,2]) ii<-if(ii<nrow(LTT)) ii+1 else ii
+ }
+ }
+ object<-list(segments=segs,nchanges=nchanges,edge.length=edge.length,tree=tree)
+ class(object)<-"ctt"
+ object
+}
+
+plot.ctt<-function(x,...){
+ h<-max(nodeHeights(x$tree))
+ args<-list(...)
+ if(!is.null(args$type)){
+ type<-args$type
+ args$type<-NULL
+ } else type<-"rate"
+ if(!is.null(args$show.tree)){
+ show.tree<-args$show.tree
+ args$show.tree<-NULL
+ } else show.tree<-FALSE
+ if(!is.null(args$add)){
+ add<-args$add
+ args$add<-NULL
+ } else add<-FALSE
+ if(is.null(args$ylim))
+ args$ylim<-if(type=="number")c(0,max(x$nchanges)) else
+ c(0,max(x$nchanges/x$edge.length))
+ if(is.null(args$xlim))
+ args$xlim<-c(max(x$segments),min(x$segments))
+ if(is.null(args$lwd)) args$lwd<-2
+ if(is.null(args$xlab)) args$xlab<-"time since the present"
+ if(is.null(args$ylab))
+ args$ylab<-if(type=="number") "mean number of changes" else
+ "mean number of changes / total edge length"
+ args$type<-"l"
+ args$x<-h-as.vector(t(x$segments))
+ args$y<-if(type=="number") rbind(x$nchanges,x$nchanges) else
+ rbind(x$nchanges/x$edge.length,x$nchanges/x$edge.length)
+ if(!add) do.call(plot,args)
+ else do.call(lines,args)
+ if(show.tree) plotTree(x$tree,add=TRUE,ftype="off",lwd=1,
+ color=make.transparent("blue",0.1),mar=par()$mar,
+ direction="leftwards",xlim=args$xlim)
+}
+
+sim.ctt<-function(tree,Q,anc=NULL,nmaps=100,...){
+ x<-as.factor(sim.history(tree,Q,anc=anc,message=FALSE)$states)
+ while(length(levels(x))!=ncol(Q))
+ x<-as.factor(sim.history(tree,Q,anc=anc,message=FALSE)$states)
+ flush.console()
+ cat("Starting stochastic mapping with simulated data vector.... ")
+ flush.console()
+ trees<-make.simmap(tree,x,Q=Q,nsim=nmaps,message=FALSE)
+ cat("Done.\n")
+ flush.console()
+ ctt(trees,...)
+}
+
+sim.multiCtt<-function(tree,Q,anc=NULL,nmaps=100,nsim=100,...){
+ object<-lapply(1:nsim,sim.ctt,tree=tree,Q=Q,anc=anc,nmaps=nmaps,...)
+## object<-replicate(nsim,sim.ctt(tree,Q,anc=anc,nmaps=nmaps,...),simplify=FALSE)
+ class(object)<-"multiCtt"
+ object
+}
+
+getChanges<-function(tree){
+ states<-sort(unique(getStates(tree)))
+ nc<-sapply(tree$maps,length)-1
+ b<-which(nc>0)
+ nc<-nc[b]
+ xx<-vector()
+ H<-nodeHeights(tree)
+ for(i in 1:length(b)){
+ for(j in 1:nc[i]){
+ ss<-names(tree$maps[[b[i]]])[j+1]
+ x<-rep(H[b[i],1]+cumsum(tree$maps[[b[i]]])[j],2)
+ xx<-c(xx,setNames(x[1],
+ paste(names(tree$maps[[b[i]]])[j:(j+1)],
+ collapse="->")))
+ }
+ }
+ xx
+}
+
+print.ctt<-function(x,...){
+ cat("Object of class \"ctt\" consisting of:\n")
+ cat(" (1) a matrix (segments) with the beginning & ending time of each segment.\n")
+ cat(" (2) a vector (nchanges) with the mean number of changes in each segment.\n")
+ cat(" (3) a vector (edge.length) containing the total edge length of each segement.\n")
+ cat(" (4) an object of class \"phylo\".\n\n")
+}
+
+print.multiCtt<-function(x,...){
+ cat(paste(length(x),"objects of class \"ctt\" in a list.\n\n"))
+}
+
+plot.multiCtt<-function(x,...){
+ if(hasArg(alpha)) alpha<-list(...)$alpha
+ else alpha<-0.05
+ segments<-x[[1]]$segments
+ nchanges<-sapply(x,function(x) x$nchanges)
+ if(hasArg(type)) type<-list(...)$type
+ else type<-"rate"
+ edge.length<-sapply(x,function(x) x$edge.length)
+ obj<-list(segments=segments,nchanges=rowMeans(nchanges),
+ edge.length=rowMeans(edge.length),tree=x[[1]]$tree)
+ class(obj)<-"ctt"
+ lower<-max(floor(alpha/2*length(x)),1)
+ upper<-min(ceiling((1-alpha/2)*length(x)),ncol(nchanges))
+ xx<-max(nodeHeights(x[[1]]$tree))-as.vector(t(segments))
+ xx<-c(xx,xx[length(xx):1])
+ y.lower<-if(type=="number") apply(nchanges,1,sort)[lower,] else
+ if(type=="rate") apply(nchanges/edge.length,1,sort)[lower,]
+ y.upper<-if(type=="number") apply(nchanges,1,sort)[upper,] else
+ if(type=="rate") apply(nchanges/edge.length,1,sort)[upper,]
+ y.lower<-as.vector(rbind(y.lower,y.lower))
+ y.upper<-as.vector(rbind(y.upper,y.upper))
+ yy<-c(y.lower,y.upper[length(y.upper):1])
+ args<-list(...)
+ if(!is.null(args$alpha)) args$alpha<-NULL
+ if(is.null(args$col)) args$col<-"blue"
+ if(is.null(args$ylim)) args$ylim<-range(yy)
+ args$x<-obj
+ do.call(plot,args)
+ polygon(xx,yy,col=make.transparent("grey",0.4),border=0)
+}
diff --git a/R/densityMap.R b/R/densityMap.R
index b9d3a63..3e14464 100644
--- a/R/densityMap.R
+++ b/R/densityMap.R
@@ -1,278 +1,278 @@
-# function plots posterior density of mapped states from stochastic mapping
-# written by Liam J. Revell 2012, 2013, 2014, 2015, 2016, 2021, 2022, 2023
-
-densityMap<-function(trees,res=100,fsize=NULL,ftype=NULL,lwd=3,check=FALSE,legend=NULL,
- outline=FALSE,type="phylogram",direction="rightwards",plot=TRUE,...){
- if(hasArg(mar)) mar<-list(...)$mar
- else mar<-rep(0.3,4)
- if(hasArg(offset)) offset<-list(...)$offset
- else offset<-NULL
- if(hasArg(states)) states<-list(...)$states
- else states<-NULL
- if(hasArg(hold)) hold<-list(...)$hold
- else hold<-TRUE
- if(length(lwd)==1) lwd<-rep(lwd,2)
- else if(length(lwd)>2) lwd<-lwd[1:2]
- tol<-1e-10
- if(!inherits(trees,"multiPhylo")&&inherits(trees,"phylo")) stop("trees not \"multiPhylo\" object; just use plotSimmap.")
- if(!inherits(trees,"multiPhylo")) stop("trees should be an object of class \"multiPhylo\".")
- h<-sapply(unclass(trees),function(x) max(nodeHeights(x)))
- steps<-0:res/res*max(h)
- trees<-rescaleSimmap(trees,totalDepth=max(h))
- if(check){
- X<-matrix(FALSE,length(trees),length(trees))
- for(i in 1:length(trees)) X[i,]<-sapply(trees,all.equal.phylo,current=trees[[i]])
- if(!all(X)) stop("some of the trees don't match in topology or relative branch lengths")
- }
- tree<-trees[[1]]
- trees<-unclass(trees)
- if(is.null(states)) ss<-sort(unique(c(getStates(tree,"nodes"),getStates(tree,"tips"))))
- else ss<-states
- if(!all(ss==c("0","1"))){
- c1<-paste(sample(c(letters,LETTERS),6),collapse="")
- c2<-paste(sample(c(letters,LETTERS),6),collapse="")
- trees<-lapply(trees,mergeMappedStates,ss[1],c1)
- trees<-lapply(trees,mergeMappedStates,ss[2],c2)
- trees<-lapply(trees,mergeMappedStates,c1,"0")
- trees<-lapply(trees,mergeMappedStates,c2,"1")
- }
- H<-nodeHeights(tree)
- message("sorry - this might take a while; please be patient")
- tree$maps<-vector(mode="list",length=nrow(tree$edge))
- for(i in 1:nrow(tree$edge)){
- YY<-cbind(c(H[i,1],steps[intersect(which(steps>H[i,1]),which(steps<H[i,2]))]),
- c(steps[intersect(which(steps>H[i,1]),which(steps<H[i,2]))],H[i,2]))-H[i,1]
- ZZ<-rep(0,nrow(YY))
- for(j in 1:length(trees)){
- XX<-matrix(0,length(trees[[j]]$maps[[i]]),2,dimnames=list(names(trees[[j]]$maps[[i]]),
- c("start","end")))
- XX[1,2]<-trees[[j]]$maps[[i]][1]
- if(length(trees[[j]]$maps[[i]])>1){
- for(k in 2:length(trees[[j]]$maps[[i]])){
- XX[k,1]<-XX[k-1,2]
- XX[k,2]<-XX[k,1]+trees[[j]]$maps[[i]][k]
- }
- }
- for(k in 1:nrow(YY)){
- lower<-which(XX[,1]<=YY[k,1]); lower<-lower[length(lower)]
- upper<-which(XX[,2]>=(YY[k,2]-tol))[1]; AA<-0
- names(lower)<-names(upper)<-NULL
- if(!all(XX==0)){
- for(l in lower:upper)
- AA<-AA+(min(XX[l,2],YY[k,2])-max(XX[l,1],YY[k,1]))/(YY[k,2]-
- YY[k,1])*as.numeric(rownames(XX)[l])
- } else AA<-as.numeric(rownames(XX)[1])
- ZZ[k]<-ZZ[k]+AA/length(trees)
- }
- }
- tree$maps[[i]]<-YY[,2]-YY[,1]
- names(tree$maps[[i]])<-round(ZZ*1000)
- }
- cols<-rainbow(1001,start=0.7,end=0); names(cols)<-0:1000
- tree$mapped.edge<-makeMappedEdge(tree$edge,tree$maps)
- tree$mapped.edge<-tree$mapped.edge[,order(as.numeric(colnames(tree$mapped.edge)))]
- class(tree)<-c("simmap",setdiff(class(tree),"simmap"))
- attr(tree,"map.order")<-"right-to-left"
- x<-list(tree=tree,cols=cols,states=ss)
- class(x)<-"densityMap"
- if(plot) plot.densityMap(x,fsize=fsize,ftype=ftype,lwd=lwd,legend=legend,outline=outline,
- type=type,mar=mar,direction=direction,offset=offset,hold=hold)
- invisible(x)
-}
-
-## S3 plot method for objects of class "densityMap"
-## also used internally by plot.contMap
-## written by Liam J. Revell 2012, 2013, 2014, 2015, 2016, 2020, 2022, 2023
-
-plot.densityMap<-function(x,...){
- if(inherits(x,"densityMap")){
- tree<-x$tree
- cols<-x$cols
- } else stop("x should be an object of class \"densityMap\"")
- H<-nodeHeights(tree)
- # get & set optional arguments
- if(hasArg(legend)) legend<-list(...)$legend
- else legend<-NULL
- if(hasArg(fsize)) fsize<-list(...)$fsize
- else fsize<-NULL
- if(hasArg(ftype)) ftype<-list(...)$ftype
- else ftype<-NULL
- if(hasArg(outline)) outline<-list(...)$outline
- else outline<-FALSE
- if(hasArg(lwd)) lwd<-list(...)$lwd
- else lwd<-3
- if(length(lwd)==1) lwd<-rep(lwd,2)
- else if(length(lwd)>2) lwd<-lwd[1:2]
- if(hasArg(leg.txt)) leg.txt<-list(...)$leg.txt
- else leg.txt<-c("0",paste("PP(state=",x$states[2],")",sep=""),"1")
- if(hasArg(type)) type<-list(...)$type
- else type<-"phylogram"
- if(hasArg(mar)) mar<-list(...)$mar
- else mar<-rep(0.3,4)
- if(hasArg(direction)) direction<-list(...)$direction
- else direction<-"rightwards"
- if(hasArg(offset)) offset<-list(...)$offset
- else offset<-NULL
- if(hasArg(xlim)) xlim<-list(...)$xlim
- else xlim<-NULL
- if(hasArg(ylim)) ylim<-list(...)$ylim
- else ylim<-NULL
- if(hasArg(hold)) hold<-list(...)$hold
- else hold<-TRUE
- if(hasArg(underscore)) underscore<-list(...)$underscore
- else underscore<-FALSE
- if(is.null(legend)) legend<-0.5*max(H)
- if(is.null(fsize)) fsize<-c(1,1)
- if(length(fsize)==1) fsize<-rep(fsize,2)
- if(is.null(ftype)) ftype<-c("i","reg")
- if(length(ftype)==1) ftype<-c(ftype,"reg")
- # done optional arguments
- if(legend){
- if(legend>max(H)){
- message("legend scale cannot be longer than total tree length; resetting")
- legend<-0.5*max(H)
- }
- }
- if(hold) null<-dev.hold()
- if(type=="phylogram"){
- if(direction%in%c("upwards","downwards")&&legend){
- par(mar=mar)
- plot.new()
- }
- N<-length(tree$tip.label)
- if(legend&&is.null(ylim)){
- if(direction%in%c("rightwards","leftwards")) ylim<-c(1-0.12*(N-1),N)
- else {
- pp<-par("pin")[2]
- sw<-(fsize*(max(strwidth(x$tree$tip.label,units="inches")))+
- 1.37*fsize*strwidth("W",units="inches"))[1]
- alp<-optimize(function(a,H,sw,pp) (a*1.2*max(H)+sw-pp)^2,H=H,sw=sw,pp=pp,
- interval=c(0,1e6))$minimum
- ylim<-if(direction=="downwards") c(min(H)-sw/alp-0.16*max(H),max(H)) else
- c(min(H)-0.16*max(H),max(H)+sw/alp)
- }
- } else if(is.null(ylim)) ylim<-NULL
- if(outline){
- COL<-par()$col
- par(col="transparent")
- plotTree(tree,fsize=fsize[1],lwd=lwd[1]+2,
- offset=offset+0.2*lwd[1]/3+0.2/3,
- color=par()$fg,
- ftype=ftype[1],xlim=xlim,
- ylim=ylim,mar=mar,direction=direction,hold=FALSE,
- add=direction%in%c("upwards","downwards")&&legend,
- underscore=underscore)
- par(col=COL)
- }
- plotSimmap(tree,cols,pts=FALSE,lwd=lwd[1],fsize=fsize[1],mar=mar,ftype=ftype[1],add=outline,
- xlim=xlim,ylim=ylim,direction=direction,offset=offset,hold=FALSE,underscore=underscore)
- if(legend){
- ff<-function(dd){
- if(!("."%in%dd)) dig<-0
- else dig<-length(dd)-which(dd==".")
- dig
- }
- dig<-max(sapply(strsplit(leg.txt[c(1,3)],split=""),ff))
- if(direction%in%c("rightwards","leftwards"))
- add.color.bar(legend,cols,title=leg.txt[2],lims<-as.numeric(leg.txt[c(1,3)]),
- digits=dig,prompt=FALSE,x=if(direction=="leftwards") max(H)-legend else 0,
- y=1-0.08*(N-1),lwd=lwd[2],
- fsize=fsize[2],outline=outline,
- direction=if(!is.null(xlim)) if(xlim[2]<xlim[1]) "leftwards" else
- "rightwards" else "rightwards")
- else if(direction%in%c("upwards","downwards")){
- sf<-abs(diff(par()$usr[1:2])/diff(par()$usr[3:4]))*
- par()$pin[2]/par()$pin[1]
- add.color.bar(legend*sf,cols,title=leg.txt[2],outline=outline,
- lims<-as.numeric(leg.txt[c(1,3)]),
- digits=dig,prompt=FALSE,x=1,y=ylim[1]+0.04*max(nodeHeights(x$tree)),lwd=lwd[2],
- fsize=fsize[2],direction="rightwards",subtitle=paste("length=",round(legend,
- 3),sep=""))
- }
- }
- } else if(type=="fan"){
- if(outline){
- COL<-par()$col
- par(col="white")
- invisible(capture.output(plotTree(tree,type="fan",lwd=lwd[1]+2,
- mar=mar,fsize=fsize[1],color=par()$fg,
- ftype=ftype[1],xlim=xlim,ylim=ylim,hold=FALSE,offset=offset,
- underscore=underscore)))
- par(col=COL)
- }
- invisible(capture.output(plotSimmap(tree,cols,lwd=lwd[1],
- mar=mar,fsize=fsize[1],add=outline,ftype=ftype[1],
- type="fan",xlim=xlim,ylim=ylim,hold=FALSE,offset=offset,
- underscore=underscore)))
- if(legend){
- ff<-function(dd){
- if(!("."%in%dd)) dig<-0
- else dig<-length(dd)-which(dd==".")
- dig
- }
- dig<-max(sapply(strsplit(leg.txt[c(1,3)],split=""),ff))
- add.color.bar(legend,cols,title=leg.txt[2],lims<-as.numeric(leg.txt[c(1,3)]),digits=dig,
- outline=outline,
- prompt=FALSE,x=0.9*par()$usr[1],y=0.9*par()$usr[3],lwd=lwd[2],
- fsize=fsize[2])
- }
- }
- if(hold) null<-dev.flush()
-}
-
-## S3 print method for object of class "densityMap"
-## written by Liam J. Revell 2013
-
-print.densityMap<-function(x,...){
- cat("Object of class \"densityMap\" containing:\n\n")
- cat(paste("(1) A phylogenetic tree with ",length(x$tree$tip.label)," tips and ",x$tree$Nnode," internal nodes.\n\n",sep=""))
- cat(paste("(2) The mapped posterior density of a discrete binary character with states (",x$states[1],", ",x$states[2],").\n\n",sep=""))
-}
-
-## set new color map for object of class 'densityMap', 'contMap', or
-## 'phyloScattergram'
-## written by Liam J. Revell 2014, 2019
-
-setMap<-function(x,...) UseMethod("setMap")
-
-setMap.default<-function(x,...){
- warning(paste(
- "setMap does not know how to handle objects of class ",
- class(x),
- "\nand can only be used on classes contMap, densityMap, & phyloScattergram."))
-}
-
-setMap.contMap<-function(x,...) SetMap(x,...)
-
-setMap.densityMap<-function(x,...) SetMap(x,...)
-
-setMap.phyloScattergram<-function(x,...){
- x$contMaps<-lapply(x$contMaps,setMap,...)
- x
-}
-
-SetMap<-function(x,...){
- if(hasArg(invert)) invert<-list(...)$invert
- else invert<-FALSE
- n<-length(x$cols)
- if(invert) x$cols<-setNames(rev(x$cols),names(x$cols))
- else x$cols[1:n]<-colorRampPalette(...)(n)
- x
-}
-
-## drop tips from an object of class 'densityMap'
-## written by Liam J. Revell 2014, 2015, 2023
-
-drop.tip.densityMap<-function(phy,tip,...){
- if(inherits(phy,"densityMap")){
- class(phy)<-"contMap"
- phy<-drop.tip.contMap(phy,tip,...)
- class(phy)<-"densityMap"
- return(phy)
- } else cat("phy should be an object of class \"densityMap\"\n")
-}
-
-keep.tip.densityMap<-function(phy,tip,...){
- tips<-setdiff(phy$tree$tip.label,tip)
- drop.tip.densityMap(phy,tip=tips,...)
-}
+# function plots posterior density of mapped states from stochastic mapping
+# written by Liam J. Revell 2012, 2013, 2014, 2015, 2016, 2021, 2022, 2023
+
+densityMap<-function(trees,res=100,fsize=NULL,ftype=NULL,lwd=3,check=FALSE,legend=NULL,
+ outline=FALSE,type="phylogram",direction="rightwards",plot=TRUE,...){
+ if(hasArg(mar)) mar<-list(...)$mar
+ else mar<-rep(0.3,4)
+ if(hasArg(offset)) offset<-list(...)$offset
+ else offset<-NULL
+ if(hasArg(states)) states<-list(...)$states
+ else states<-NULL
+ if(hasArg(hold)) hold<-list(...)$hold
+ else hold<-TRUE
+ if(length(lwd)==1) lwd<-rep(lwd,2)
+ else if(length(lwd)>2) lwd<-lwd[1:2]
+ tol<-1e-10
+ if(!inherits(trees,"multiPhylo")&&inherits(trees,"phylo")) stop("trees not \"multiPhylo\" object; just use plotSimmap.")
+ if(!inherits(trees,"multiPhylo")) stop("trees should be an object of class \"multiPhylo\".")
+ h<-sapply(unclass(trees),function(x) max(nodeHeights(x)))
+ steps<-0:res/res*max(h)
+ trees<-rescaleSimmap(trees,totalDepth=max(h))
+ if(check){
+ X<-matrix(FALSE,length(trees),length(trees))
+ for(i in 1:length(trees)) X[i,]<-sapply(trees,all.equal.phylo,current=trees[[i]])
+ if(!all(X)) stop("some of the trees don't match in topology or relative branch lengths")
+ }
+ tree<-trees[[1]]
+ trees<-unclass(trees)
+ if(is.null(states)) ss<-sort(unique(c(getStates(tree,"nodes"),getStates(tree,"tips"))))
+ else ss<-states
+ if(!all(ss==c("0","1"))){
+ c1<-paste(sample(c(letters,LETTERS),6),collapse="")
+ c2<-paste(sample(c(letters,LETTERS),6),collapse="")
+ trees<-lapply(trees,mergeMappedStates,ss[1],c1)
+ trees<-lapply(trees,mergeMappedStates,ss[2],c2)
+ trees<-lapply(trees,mergeMappedStates,c1,"0")
+ trees<-lapply(trees,mergeMappedStates,c2,"1")
+ }
+ H<-nodeHeights(tree)
+ message("sorry - this might take a while; please be patient")
+ tree$maps<-vector(mode="list",length=nrow(tree$edge))
+ for(i in 1:nrow(tree$edge)){
+ YY<-cbind(c(H[i,1],steps[intersect(which(steps>H[i,1]),which(steps<H[i,2]))]),
+ c(steps[intersect(which(steps>H[i,1]),which(steps<H[i,2]))],H[i,2]))-H[i,1]
+ ZZ<-rep(0,nrow(YY))
+ for(j in 1:length(trees)){
+ XX<-matrix(0,length(trees[[j]]$maps[[i]]),2,dimnames=list(names(trees[[j]]$maps[[i]]),
+ c("start","end")))
+ XX[1,2]<-trees[[j]]$maps[[i]][1]
+ if(length(trees[[j]]$maps[[i]])>1){
+ for(k in 2:length(trees[[j]]$maps[[i]])){
+ XX[k,1]<-XX[k-1,2]
+ XX[k,2]<-XX[k,1]+trees[[j]]$maps[[i]][k]
+ }
+ }
+ for(k in 1:nrow(YY)){
+ lower<-which(XX[,1]<=YY[k,1]); lower<-lower[length(lower)]
+ upper<-which(XX[,2]>=(YY[k,2]-tol))[1]; AA<-0
+ names(lower)<-names(upper)<-NULL
+ if(!all(XX==0)){
+ for(l in lower:upper)
+ AA<-AA+(min(XX[l,2],YY[k,2])-max(XX[l,1],YY[k,1]))/(YY[k,2]-
+ YY[k,1])*as.numeric(rownames(XX)[l])
+ } else AA<-as.numeric(rownames(XX)[1])
+ ZZ[k]<-ZZ[k]+AA/length(trees)
+ }
+ }
+ tree$maps[[i]]<-YY[,2]-YY[,1]
+ names(tree$maps[[i]])<-round(ZZ*1000)
+ }
+ cols<-rainbow(1001,start=0.7,end=0); names(cols)<-0:1000
+ tree$mapped.edge<-makeMappedEdge(tree$edge,tree$maps)
+ tree$mapped.edge<-tree$mapped.edge[,order(as.numeric(colnames(tree$mapped.edge)))]
+ class(tree)<-c("simmap",setdiff(class(tree),"simmap"))
+ attr(tree,"map.order")<-"right-to-left"
+ x<-list(tree=tree,cols=cols,states=ss)
+ class(x)<-"densityMap"
+ if(plot) plot.densityMap(x,fsize=fsize,ftype=ftype,lwd=lwd,legend=legend,outline=outline,
+ type=type,mar=mar,direction=direction,offset=offset,hold=hold)
+ invisible(x)
+}
+
+## S3 plot method for objects of class "densityMap"
+## also used internally by plot.contMap
+## written by Liam J. Revell 2012, 2013, 2014, 2015, 2016, 2020, 2022, 2023
+
+plot.densityMap<-function(x,...){
+ if(inherits(x,"densityMap")){
+ tree<-x$tree
+ cols<-x$cols
+ } else stop("x should be an object of class \"densityMap\"")
+ H<-nodeHeights(tree)
+ # get & set optional arguments
+ if(hasArg(legend)) legend<-list(...)$legend
+ else legend<-NULL
+ if(hasArg(fsize)) fsize<-list(...)$fsize
+ else fsize<-NULL
+ if(hasArg(ftype)) ftype<-list(...)$ftype
+ else ftype<-NULL
+ if(hasArg(outline)) outline<-list(...)$outline
+ else outline<-FALSE
+ if(hasArg(lwd)) lwd<-list(...)$lwd
+ else lwd<-3
+ if(length(lwd)==1) lwd<-rep(lwd,2)
+ else if(length(lwd)>2) lwd<-lwd[1:2]
+ if(hasArg(leg.txt)) leg.txt<-list(...)$leg.txt
+ else leg.txt<-c("0",paste("PP(state=",x$states[2],")",sep=""),"1")
+ if(hasArg(type)) type<-list(...)$type
+ else type<-"phylogram"
+ if(hasArg(mar)) mar<-list(...)$mar
+ else mar<-rep(0.3,4)
+ if(hasArg(direction)) direction<-list(...)$direction
+ else direction<-"rightwards"
+ if(hasArg(offset)) offset<-list(...)$offset
+ else offset<-NULL
+ if(hasArg(xlim)) xlim<-list(...)$xlim
+ else xlim<-NULL
+ if(hasArg(ylim)) ylim<-list(...)$ylim
+ else ylim<-NULL
+ if(hasArg(hold)) hold<-list(...)$hold
+ else hold<-TRUE
+ if(hasArg(underscore)) underscore<-list(...)$underscore
+ else underscore<-FALSE
+ if(is.null(legend)) legend<-0.5*max(H)
+ if(is.null(fsize)) fsize<-c(1,1)
+ if(length(fsize)==1) fsize<-rep(fsize,2)
+ if(is.null(ftype)) ftype<-c("i","reg")
+ if(length(ftype)==1) ftype<-c(ftype,"reg")
+ # done optional arguments
+ if(legend){
+ if(legend>max(H)){
+ message("legend scale cannot be longer than total tree length; resetting")
+ legend<-0.5*max(H)
+ }
+ }
+ if(hold) null<-dev.hold()
+ if(type=="phylogram"){
+ if(direction%in%c("upwards","downwards")&&legend){
+ par(mar=mar)
+ plot.new()
+ }
+ N<-length(tree$tip.label)
+ if(legend&&is.null(ylim)){
+ if(direction%in%c("rightwards","leftwards")) ylim<-c(1-0.12*(N-1),N)
+ else {
+ pp<-par("pin")[2]
+ sw<-(fsize*(max(strwidth(x$tree$tip.label,units="inches")))+
+ 1.37*fsize*strwidth("W",units="inches"))[1]
+ alp<-optimize(function(a,H,sw,pp) (a*1.2*max(H)+sw-pp)^2,H=H,sw=sw,pp=pp,
+ interval=c(0,1e6))$minimum
+ ylim<-if(direction=="downwards") c(min(H)-sw/alp-0.16*max(H),max(H)) else
+ c(min(H)-0.16*max(H),max(H)+sw/alp)
+ }
+ } else if(is.null(ylim)) ylim<-NULL
+ if(outline){
+ COL<-par()$col
+ par(col="transparent")
+ plotTree(tree,fsize=fsize[1],lwd=lwd[1]+2,
+ offset=offset+0.2*lwd[1]/3+0.2/3,
+ color=par()$fg,
+ ftype=ftype[1],xlim=xlim,
+ ylim=ylim,mar=mar,direction=direction,hold=FALSE,
+ add=direction%in%c("upwards","downwards")&&legend,
+ underscore=underscore)
+ par(col=COL)
+ }
+ plotSimmap(tree,cols,pts=FALSE,lwd=lwd[1],fsize=fsize[1],mar=mar,ftype=ftype[1],add=outline,
+ xlim=xlim,ylim=ylim,direction=direction,offset=offset,hold=FALSE,underscore=underscore)
+ if(legend){
+ ff<-function(dd){
+ if(!("."%in%dd)) dig<-0
+ else dig<-length(dd)-which(dd==".")
+ dig
+ }
+ dig<-max(sapply(strsplit(leg.txt[c(1,3)],split=""),ff))
+ if(direction%in%c("rightwards","leftwards"))
+ add.color.bar(legend,cols,title=leg.txt[2],lims<-as.numeric(leg.txt[c(1,3)]),
+ digits=dig,prompt=FALSE,x=if(direction=="leftwards") max(H)-legend else 0,
+ y=1-0.08*(N-1),lwd=lwd[2],
+ fsize=fsize[2],outline=outline,
+ direction=if(!is.null(xlim)) if(xlim[2]<xlim[1]) "leftwards" else
+ "rightwards" else "rightwards")
+ else if(direction%in%c("upwards","downwards")){
+ sf<-abs(diff(par()$usr[1:2])/diff(par()$usr[3:4]))*
+ par()$pin[2]/par()$pin[1]
+ add.color.bar(legend*sf,cols,title=leg.txt[2],outline=outline,
+ lims<-as.numeric(leg.txt[c(1,3)]),
+ digits=dig,prompt=FALSE,x=1,y=ylim[1]+0.04*max(nodeHeights(x$tree)),lwd=lwd[2],
+ fsize=fsize[2],direction="rightwards",subtitle=paste("length=",round(legend,
+ 3),sep=""))
+ }
+ }
+ } else if(type=="fan"){
+ if(outline){
+ COL<-par()$col
+ par(col="white")
+ invisible(capture.output(plotTree(tree,type="fan",lwd=lwd[1]+2,
+ mar=mar,fsize=fsize[1],color=par()$fg,
+ ftype=ftype[1],xlim=xlim,ylim=ylim,hold=FALSE,offset=offset,
+ underscore=underscore)))
+ par(col=COL)
+ }
+ invisible(capture.output(plotSimmap(tree,cols,lwd=lwd[1],
+ mar=mar,fsize=fsize[1],add=outline,ftype=ftype[1],
+ type="fan",xlim=xlim,ylim=ylim,hold=FALSE,offset=offset,
+ underscore=underscore)))
+ if(legend){
+ ff<-function(dd){
+ if(!("."%in%dd)) dig<-0
+ else dig<-length(dd)-which(dd==".")
+ dig
+ }
+ dig<-max(sapply(strsplit(leg.txt[c(1,3)],split=""),ff))
+ add.color.bar(legend,cols,title=leg.txt[2],lims<-as.numeric(leg.txt[c(1,3)]),digits=dig,
+ outline=outline,
+ prompt=FALSE,x=0.9*par()$usr[1],y=0.9*par()$usr[3],lwd=lwd[2],
+ fsize=fsize[2])
+ }
+ }
+ if(hold) null<-dev.flush()
+}
+
+## S3 print method for object of class "densityMap"
+## written by Liam J. Revell 2013
+
+print.densityMap<-function(x,...){
+ cat("Object of class \"densityMap\" containing:\n\n")
+ cat(paste("(1) A phylogenetic tree with ",length(x$tree$tip.label)," tips and ",x$tree$Nnode," internal nodes.\n\n",sep=""))
+ cat(paste("(2) The mapped posterior density of a discrete binary character with states (",x$states[1],", ",x$states[2],").\n\n",sep=""))
+}
+
+## set new color map for object of class 'densityMap', 'contMap', or
+## 'phyloScattergram'
+## written by Liam J. Revell 2014, 2019
+
+setMap<-function(x,...) UseMethod("setMap")
+
+setMap.default<-function(x,...){
+ warning(paste(
+ "setMap does not know how to handle objects of class ",
+ class(x),
+ "\nand can only be used on classes contMap, densityMap, & phyloScattergram."))
+}
+
+setMap.contMap<-function(x,...) SetMap(x,...)
+
+setMap.densityMap<-function(x,...) SetMap(x,...)
+
+setMap.phyloScattergram<-function(x,...){
+ x$contMaps<-lapply(x$contMaps,setMap,...)
+ x
+}
+
+SetMap<-function(x,...){
+ if(hasArg(invert)) invert<-list(...)$invert
+ else invert<-FALSE
+ n<-length(x$cols)
+ if(invert) x$cols<-setNames(rev(x$cols),names(x$cols))
+ else x$cols[1:n]<-colorRampPalette(...)(n)
+ x
+}
+
+## drop tips from an object of class 'densityMap'
+## written by Liam J. Revell 2014, 2015, 2023
+
+drop.tip.densityMap<-function(phy,tip,...){
+ if(inherits(phy,"densityMap")){
+ class(phy)<-"contMap"
+ phy<-drop.tip.contMap(phy,tip,...)
+ class(phy)<-"densityMap"
+ return(phy)
+ } else cat("phy should be an object of class \"densityMap\"\n")
+}
+
+keep.tip.densityMap<-function(phy,tip,...){
+ tips<-setdiff(phy$tree$tip.label,tip)
+ drop.tip.densityMap(phy,tip=tips,...)
+}
diff --git a/R/densityTree.R b/R/densityTree.R
index bb3d435..012d649 100644
--- a/R/densityTree.R
+++ b/R/densityTree.R
@@ -1,121 +1,121 @@
-## function to make a color (e.g., "blue") transparent with alpha level alpha
-make.transparent<-function(color,alpha){
- if(length(color)>1 && length(alpha)>1){
- if(length(color) != length(alpha)){
- cat("Lengths of color and alpha should match.\n")
- cat("Using only first alpha value....\n")
- cols<-make.transparent(color,alpha[1])
- } else {
- cols<-mapply(make.transparent,color=color,alpha=alpha)
- }
- } else if(length(color)>1 && length(alpha)==1){
- cols<-sapply(color,make.transparent,alpha=alpha)
- } else if(length(color)==1 && length(alpha)>1){
- cols<-sapply(alpha,make.transparent,color=color)
- } else {
- RGB<-col2rgb(color)[,1]/255
- cols<-rgb(RGB[1],RGB[2],RGB[3],alpha)
- }
- cols
-}
-
-## function to be used internally
-rescaleTree<-function(tree,scale){
- tree$edge.length<-tree$edge.length/max(nodeHeights(tree))*scale
- tree
-}
-## function to plot a posterior density of trees (e.g., densiTree in phangorn)
-## written by Liam J. Revell 2016, 2017
-densityTree<-function(trees,colors="blue",alpha=NULL,method="plotTree",
- fix.depth=FALSE,use.edge.length=TRUE,compute.consensus=TRUE,
- use.gradient=FALSE,show.axis=TRUE,...){
- N<-length(trees)
- if(any(sapply(trees,function(x) is.null(x$edge.length))))
- use.edge.length<-FALSE
- if(!use.edge.length){
- trees<-lapply(trees,compute.brlen)
- class(trees)<-"multiPhylo"
- }
- h<-sapply(trees,function(x) max(nodeHeights(x)))
- if(fix.depth){
- if(method=="plotTree"){
- trees<-lapply(trees,rescaleTree,mean(h))
- class(trees)<-"multiPhylo"
- } else if(method=="plotSimmap"){
- trees<-rescaleSimmap(trees,depth=mean(h))
- }
- h<-sapply(trees,function(x) max(nodeHeights(x)))
- }
- tips<-setNames(1:Ntip(trees[[1]]),
- if(compute.consensus) untangle(consensus(trees),
- "read.tree")$tip.label
- else trees[[1]]$tip.label)
- if(is.null(alpha)) alpha<-max(c(1/N,0.01))
- args<-list(...)
- args$direction<-"leftwards"
- args$tips<-tips
- args$add<-FALSE
- if(is.null(args$nodes)) args$nodes<-"inner"
- if(is.null(args$mar)) args$mar<-if(show.axis) c(4.1,1.1,1.1,1.1) else rep(1.1,4)
- if(is.null(args$ftype)) args$ftype<-"i"
- if(!use.gradient){
- plotTree(trees[[which(h==max(h))[1]]],direction="leftwards",mar=args$mar,
- plot=FALSE)
- par(new=TRUE)
- args$xlim<-get("last_plot.phylo",envir=.PlotPhyloEnv)$x.lim[2:1]
- if(method=="plotTree"){
- args$color<-make.transparent(colors[1],alpha)
- for(i in 1:length(trees)){
- args$tree<-trees[[i]]
- do.call(plotTree,args)
- if(i==1){
- if(show.axis) axis(1)
- args$ftype<-"off"
- args$add<-TRUE
- }
- }
- } else if(method=="plotSimmap"){
- states<-sort(unique(as.vector(mapped.states(trees))))
- if(length(colors)!=length(states)){
- colors<-setNames(c("grey",palette()[2:length(states)]),
- states)
- }
- colors<-sapply(colors,make.transparent,alpha=alpha)
- args$colors<-colors
- for(i in 1:length(trees)){
- args$tree<-trees[[i]]
- do.call(plotSimmap,args)
- if(i==1){
- if(show.axis) axis(1)
- args$ftype<-"off"
- args$add<-TRUE
- }
- }
- }
- } else if(use.gradient){
- rf<-multiRF(trees,quiet=TRUE)
- mds<-cmdscale(rf,k=1)[,1]
- trees<-trees[order(mds)]
- h<-h[order(mds)]
- args$ylim<-c(0,Ntip(trees[[1]])+1)
- plotTree(trees[[which(h==max(h))[1]]],direction="leftwards",mar=args$mar,
- ylim=args$ylim,plot=FALSE)
- par(new=TRUE)
- args$xlim<-get("last_plot.phylo",envir=.PlotPhyloEnv)$x.lim[2:1]
- colors<-sapply(rainbow(n=length(trees)),make.transparent,alpha=alpha)
- ftype<-args$ftype
- for(i in 1:length(trees)){
- y.shift<-(i-median(1:length(trees)))/length(trees)/2
- args$tree<-trees[[i]]
- args$tips<-tips+y.shift
- args$color<-colors[i]
- args$ftype<-if(i==floor(median(1:length(trees)))) ftype else "off"
- do.call(plotTree,args)
- if(i==1){
- if(show.axis) axis(1)
- args$ftype<-"off"
- args$add<-TRUE
- }
- }
- }
-}
+## function to make a color (e.g., "blue") transparent with alpha level alpha
+make.transparent<-function(color,alpha){
+ if(length(color)>1 && length(alpha)>1){
+ if(length(color) != length(alpha)){
+ cat("Lengths of color and alpha should match.\n")
+ cat("Using only first alpha value....\n")
+ cols<-make.transparent(color,alpha[1])
+ } else {
+ cols<-mapply(make.transparent,color=color,alpha=alpha)
+ }
+ } else if(length(color)>1 && length(alpha)==1){
+ cols<-sapply(color,make.transparent,alpha=alpha)
+ } else if(length(color)==1 && length(alpha)>1){
+ cols<-sapply(alpha,make.transparent,color=color)
+ } else {
+ RGB<-col2rgb(color)[,1]/255
+ cols<-rgb(RGB[1],RGB[2],RGB[3],alpha)
+ }
+ cols
+}
+
+## function to be used internally
+rescaleTree<-function(tree,scale){
+ tree$edge.length<-tree$edge.length/max(nodeHeights(tree))*scale
+ tree
+}
+## function to plot a posterior density of trees (e.g., densiTree in phangorn)
+## written by Liam J. Revell 2016, 2017
+densityTree<-function(trees,colors="blue",alpha=NULL,method="plotTree",
+ fix.depth=FALSE,use.edge.length=TRUE,compute.consensus=TRUE,
+ use.gradient=FALSE,show.axis=TRUE,...){
+ N<-length(trees)
+ if(any(sapply(trees,function(x) is.null(x$edge.length))))
+ use.edge.length<-FALSE
+ if(!use.edge.length){
+ trees<-lapply(trees,compute.brlen)
+ class(trees)<-"multiPhylo"
+ }
+ h<-sapply(trees,function(x) max(nodeHeights(x)))
+ if(fix.depth){
+ if(method=="plotTree"){
+ trees<-lapply(trees,rescaleTree,mean(h))
+ class(trees)<-"multiPhylo"
+ } else if(method=="plotSimmap"){
+ trees<-rescaleSimmap(trees,depth=mean(h))
+ }
+ h<-sapply(trees,function(x) max(nodeHeights(x)))
+ }
+ tips<-setNames(1:Ntip(trees[[1]]),
+ if(compute.consensus) untangle(consensus(trees),
+ "read.tree")$tip.label
+ else trees[[1]]$tip.label)
+ if(is.null(alpha)) alpha<-max(c(1/N,0.01))
+ args<-list(...)
+ args$direction<-"leftwards"
+ args$tips<-tips
+ args$add<-FALSE
+ if(is.null(args$nodes)) args$nodes<-"inner"
+ if(is.null(args$mar)) args$mar<-if(show.axis) c(4.1,1.1,1.1,1.1) else rep(1.1,4)
+ if(is.null(args$ftype)) args$ftype<-"i"
+ if(!use.gradient){
+ plotTree(trees[[which(h==max(h))[1]]],direction="leftwards",mar=args$mar,
+ plot=FALSE)
+ par(new=TRUE)
+ args$xlim<-get("last_plot.phylo",envir=.PlotPhyloEnv)$x.lim[2:1]
+ if(method=="plotTree"){
+ args$color<-make.transparent(colors[1],alpha)
+ for(i in 1:length(trees)){
+ args$tree<-trees[[i]]
+ do.call(plotTree,args)
+ if(i==1){
+ if(show.axis) axis(1)
+ args$ftype<-"off"
+ args$add<-TRUE
+ }
+ }
+ } else if(method=="plotSimmap"){
+ states<-sort(unique(as.vector(mapped.states(trees))))
+ if(length(colors)!=length(states)){
+ colors<-setNames(c("grey",palette()[2:length(states)]),
+ states)
+ }
+ colors<-sapply(colors,make.transparent,alpha=alpha)
+ args$colors<-colors
+ for(i in 1:length(trees)){
+ args$tree<-trees[[i]]
+ do.call(plotSimmap,args)
+ if(i==1){
+ if(show.axis) axis(1)
+ args$ftype<-"off"
+ args$add<-TRUE
+ }
+ }
+ }
+ } else if(use.gradient){
+ rf<-multiRF(trees,quiet=TRUE)
+ mds<-cmdscale(rf,k=1)[,1]
+ trees<-trees[order(mds)]
+ h<-h[order(mds)]
+ args$ylim<-c(0,Ntip(trees[[1]])+1)
+ plotTree(trees[[which(h==max(h))[1]]],direction="leftwards",mar=args$mar,
+ ylim=args$ylim,plot=FALSE)
+ par(new=TRUE)
+ args$xlim<-get("last_plot.phylo",envir=.PlotPhyloEnv)$x.lim[2:1]
+ colors<-sapply(rainbow(n=length(trees)),make.transparent,alpha=alpha)
+ ftype<-args$ftype
+ for(i in 1:length(trees)){
+ y.shift<-(i-median(1:length(trees)))/length(trees)/2
+ args$tree<-trees[[i]]
+ args$tips<-tips+y.shift
+ args$color<-colors[i]
+ args$ftype<-if(i==floor(median(1:length(trees)))) ftype else "off"
+ do.call(plotTree,args)
+ if(i==1){
+ if(show.axis) axis(1)
+ args$ftype<-"off"
+ args$add<-TRUE
+ }
+ }
+ }
+}
diff --git a/R/dotTree.R b/R/dotTree.R
index 2de618e..d03110a 100644
--- a/R/dotTree.R
+++ b/R/dotTree.R
@@ -1,250 +1,250 @@
-## function to plot a tree with dots/circles for a plotted phenotype
-## written by Liam J. Revell 2016, 2017, 2018
-
-dotTree<-function(tree,x,legend=TRUE,method="plotTree",standardize=FALSE,...){
- if(is.data.frame(x)) x<-as.matrix(x)
- if(hasArg(data.type)) data.type<-list(...)$data.type
- else {
- ## try to detect type
- if(is.numeric(x)) data.type<-"continuous"
- else data.type<-"discrete"
- }
- if(data.type=="continuous"){
- if(hasArg(colors)) colors<-list(...)$colors
- else colors<-"blue"
- dotTree.continuous(tree,x,colors[1],legend,method,standardize,...)
- } else if(data.type=="discrete"){
- if(hasArg(colors)) colors<-list(...)$colors
- else {
- ss<-unique(as.vector(x))
- colors<-setNames(palette()[1:length(ss)],ss)
- }
- dotTree.discrete(tree,x,colors,legend,method,...)
- }
-}
-
-dotTree.continuous<-function(tree,x,color,legend,method,standardize,...){
- if(is.data.frame(x)) x<-as.matrix(x)
- if(is.matrix(x)&&method=="plotTree"){
- if(ncol(x)>1) method<-"phylogram"
- else x<-x[,1]
- }
- if(hasArg(fsize)) fsize<-list(...)$fsize
- else fsize<-c(1,0.8)
- if(length(fsize)==1) fsize<-rep(fsize,2)
- if(hasArg(x.space)) x.space<-list(...)$x.space
- else x.space<-0.1
- if(hasArg(k)) k<-list(...)$k
- else k<-0.8
- ## reorder tree
- tree<-reorder(tree,"cladewise")
- ## if standardize==TRUE
- if(standardize){
- if(is.matrix(x)){
- sd<-apply(x,2,function(x) sqrt(var(x)))
- x<-(x-matrix(rep(1,Ntip(tree)),Ntip(tree),1)%*%colMeans(x))/
- (matrix(rep(1,Ntip(tree)),Ntip(tree),1)%*%sd)
- } else if(is.vector(x)) x<-(x-mean(x))/sqrt(var(x))
- }
- ## in case any x<0
- min.x<-min(x)
- max.x<-max(x)
- if(any(x<0)) x<-x-min(x)
- if(method=="plotTree"){
- fsize<-fsize[1]
- x<-x[tree$tip.label]
- ## plot tree
- plotTree(tree,offset=1.7,ylim=c(-Ntip(tree)/25,
- Ntip(tree)),...)
- ## get last phylo plot parameters
- obj<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- x.tip<-obj$xx[1:obj$Ntip]
- y.tip<-obj$yy[1:obj$Ntip]
- ## plot points
- rr<-(k*x/max(x)+x.space)/2*diff(par()$usr[1:2])/
- diff(par()$usr[3:4])
- if(k<=0.8&&any(rr>(strwidth("W")*fsize/2)))
- rr<-rr/max(rr)*strwidth("W")*fsize/2
- nulo<-mapply(draw.circle,x=x.tip+1.2*strwidth("W"),y=y.tip,
- radius=rr,MoreArgs=list(nv=200,col=color))
- ## add legend
- if(legend){
- h<-dot.legend(x=par()$usr[1]+0.1*max(nodeHeights(tree)),
- y=0,min.x,max.x,Ntip=Ntip(tree),
- method="plotTree",...)
- if(standardize) text(h,0.1*(1+par()$usr[3]),"(SD units)",pos=4)
- }
- } else if(method=="phylogram"){
- if(is.vector(x)) x<-as.matrix(x)
- x[]<-x[tree$tip.label,]
- if(hasArg(mar)) mar<-list(...)$mar
- else mar<-rep(0.1,4)
- if(hasArg(xlim)) xlim<-list(...)$xlim
- else xlim<-c(-0.5,0.55+x.space*ncol(x)+x.space/2)
- if(hasArg(labels)) labels<-list(...)$labels
- else labels<-FALSE
- if(hasArg(ylim)) ylim<-list(...)$ylim
- else ylim<-c(if(legend) -0.1 else 0,if(labels) 1.1 else 1)
- ## plot tree
- plot.new()
- par(mar=mar)
- plot.window(xlim=xlim,ylim=ylim)
- h<-phylogram(tree,...)
- ## get last phylo plot parameters
- obj<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- x.tip<-rep(h,obj$Ntip)
- y.tip<-obj$yy[1:obj$Ntip]
- ## plot points
- rr<-(k*x/max(x)+x.space)/2*diff(par()$usr[1:2])/diff(par()$usr[3:4])/
- (Ntip(tree)-1)
- if(k<=0.8&&any(rr>(strwidth("W")*fsize[1]/2)))
- rr<-rr/max(rr)*strwidth("W")*fsize[1]/2
- for(i in 1:ncol(x)){
- nulo<-mapply(draw.circle,x=x.tip+1.2*strwidth("W")+x.space*(i-1),
- y=y.tip,radius=rr[,i],MoreArgs=list(nv=200,col=color))
- }
- ## add legend
- if(legend){
- h<-dot.legend(x=-0.45,y=-0.04,min.x,max.x,Ntip=Ntip(tree),
- method="phylogram",...)
- if(standardize) text(h,-0.04,"(SD units)",pos=4)
- }
- if(labels){
- text(x=seq(max(x.tip)+1.2*strwidth("W"),
- max(x.tip)+1.2*strwidth("W")+x.space*(ncol(x)-1),by=x.space),
- y=rep(1.02,ncol(x)),colnames(x),srt=70,adj=c(0,0.5),cex=fsize[2])
- }
- }
-}
-
-dotTree.discrete<-function(tree,x,color,legend,method,...){
- if(is.data.frame(x)) x<-as.matrix(x)
- if(is.matrix(x)&&method=="plotTree"){
- if(ncol(x)>1) method<-"phylogram"
- else x<-x[,1]
- }
- if(hasArg(fsize)) fsize<-list(...)$fsize
- else fsize<-c(1,0.8)
- if(length(fsize)==1) fsize<-rep(fsize,2)
- if(hasArg(x.space)) x.space<-list(...)$x.space
- else x.space<-0.1
- ## reorder tree
- tree<-reorder(tree,"cladewise")
- if(method=="plotTree"){
- x<-x[tree$tip.label]
- ## plot tree
- plotTree(tree,offset=1.7,ylim=c(-1/25*Ntip(tree),
- Ntip(tree)),...)
- ## get last phylo plot parameters
- obj<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- x.tip<-obj$xx[1:obj$Ntip]
- y.tip<-obj$yy[1:obj$Ntip]
- ## plot points
- r<-min(0.8/2*diff(par()$usr[1:2])/diff(par()$usr[3:4]),
- strwidth("W")*fsize/2)
- nulo<-mapply(draw.circle,x=x.tip+1.2*strwidth("W"),y=y.tip,
- col=color[as.character(x)],MoreArgs=list(nv=200,radius=r))
- if(legend){
- add.simmap.legend(colors=color,prompt=FALSE,
- vertical=FALSE,shape="circle",
- x=par()$usr[1]+0.1*max(nodeHeights(tree)),
- y=-1/25*Ntip(tree))
- }
- } else if(method=="phylogram"){
- if(is.vector(x)) x<-as.matrix(x)
- x[]<-x[tree$tip.label,]
- if(hasArg(mar)) mar<-list(...)$mar
- else mar<-rep(0.1,4)
- if(hasArg(xlim)) xlim<-list(...)$xlim
- else xlim<-c(-0.5,0.55+x.space*ncol(x)+x.space/2)
- if(hasArg(labels)) labels<-list(...)$labels
- else labels<-FALSE
- if(hasArg(ylim)) ylim<-list(...)$ylim
- else ylim<-c(if(legend) -0.1 else 0,if(labels) 1.1 else 1)
- ## plot tree
- plot.new()
- par(mar=mar)
- plot.window(xlim=xlim,ylim=ylim)
- h<-phylogram(tree,...)
- ## get last phylo plot parameters
- obj<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- x.tip<-rep(h,obj$Ntip)
- y.tip<-obj$yy[1:obj$Ntip]
- ## plot points
- r<-min(0.8/2*diff(par()$usr[1:2])/diff(par()$usr[3:4])/(Ntip(tree)-1),
- strwidth("W")*fsize/2)
- for(i in 1:ncol(x)){
- nulo<-mapply(draw.circle,x=x.tip+1.2*strwidth("W")+x.space*(i-1),
- y=y.tip,col=color[as.character(x[,i])],MoreArgs=list(nv=20,
- radius=r))
- }
- ## add legend
- if(legend){
- add.simmap.legend(colors=color,prompt=FALSE,
- vertical=FALSE,shape="circle",x=-0.45,y=-0.06)
- }
- if(labels){
- text(x=seq(max(x.tip)+1.2*strwidth("W"),
- max(x.tip)+1.2*strwidth("W")+x.space*(ncol(x)-1),by=x.space),
- y=rep(1.02,ncol(x)),colnames(x),srt=70,adj=c(0,0.5),cex=fsize[2])
- }
- }
-}
-
-## dot legend
-## written by Liam J. Revell 2016
-
-dot.legend<-function(x,y,min,max,Ntip,length=5,prompt=FALSE,
- method="plotTree",...){
- if(hasArg(cex)) cex<-list(...)$cex
- else cex<-1
- if(hasArg(fsize)) fsize<-list(...)$fsize
- else fsize<-1
- if(hasArg(colors)) colors<-list(...)$colors
- else colors<-"blue"
- if(hasArg(leg.space)) leg.space<-list(...)$leg.space
- else leg.space<-0.2
- if(hasArg(k)) k<-list(...)$k
- else k<-0.8
- if(prompt){
- obj<-locator(1)
- x<-obj$x
- y<-obj$y
- }
- if(method=="plotTree"){
- text(x,y-0.5*(Ntip/25),round(min,2),pos=1,cex=cex)
- s<-(k*max(min,0)/min(max,max+min)+0.1)/2*diff(par()$usr[1:2])/
- diff(par()$usr[3:4])
- e<-(k+0.1)/2*diff(par()$usr[1:2])/diff(par()$usr[3:4])
- rr<-seq(s,e,length.out=length)
- if(k<=0.8&&any(rr>(strwidth("W")*fsize/2)))
- rr<-rr/max(rr)*strwidth("W")*fsize/2
- temp<-c(0,cumsum((1+leg.space)*rep(2*max(rr),length-1)))
- nulo<-mapply(draw.circle,x=x+temp,y=rep(y,length),radius=rr,
- MoreArgs=list(nv=200,col=colors))
- ## draw.circle(x+temp,rep(y,length),nv=200,radius=rr,col=colors)
- text(max(x+temp),y-0.5*(Ntip/25),round(max,2),pos=1,cex=cex)
- y1<-0.1/25*Ntip
- lines(c(x,max(x+temp)),rep(y-0.5*(Ntip/25)-y1,2))
- lines(c(x,x),y-c(y1+0.5*(Ntip/25),2*y1+0.5*(Ntip/25)))
- lines(c(max(x+temp),max(x+temp)),y-c(y1+0.5*(Ntip/25),2*y1+0.5*(Ntip/25)))
- } else if(method=="phylogram"){
- text(x,y-0.04,round(min,2),pos=1,cex=cex)
- s<-(k*max(min,0)/(min(max,max+min))+0.1)/2*
- diff(par()$usr[1:2])/diff(par()$usr[3:4])/(Ntip-1)
- e<-(k+0.1)/2*diff(par()$usr[1:2])/diff(par()$usr[3:4])/(Ntip-1)
- rr<-seq(s,e,length.out=length)
- if(k<=0.8&&any(rr>(strwidth("W")*fsize/2)))
- rr<-rr/max(rr)*strwidth("W")*fsize/2
- temp<-c(0,cumsum((1+leg.space)*rep(2*max(rr),length-1)))
- nulo<-mapply(draw.circle,x=x+temp,y=rep(y,length),radius=rr,
- MoreArgs=list(nv=200,col=colors))
- ## draw.circle(x+temp,rep(y,length),nv=200,radius=rr,col=colors)
- text(max(x+temp),y-0.04,round(max,2),pos=1,cex=cex)
- y1<-0.01
- lines(c(x,max(x+temp)),rep(y-0.02-y1,2))
- lines(c(x,x),y-c(y1+0.02,2*y1+0.02))
- lines(c(max(x+temp),max(x+temp)),y-c(y1+0.02,2*y1+0.02))
- }
- invisible(max(x+temp)+0.5*max(rr))
+## function to plot a tree with dots/circles for a plotted phenotype
+## written by Liam J. Revell 2016, 2017, 2018
+
+dotTree<-function(tree,x,legend=TRUE,method="plotTree",standardize=FALSE,...){
+ if(is.data.frame(x)) x<-as.matrix(x)
+ if(hasArg(data.type)) data.type<-list(...)$data.type
+ else {
+ ## try to detect type
+ if(is.numeric(x)) data.type<-"continuous"
+ else data.type<-"discrete"
+ }
+ if(data.type=="continuous"){
+ if(hasArg(colors)) colors<-list(...)$colors
+ else colors<-"blue"
+ dotTree.continuous(tree,x,colors[1],legend,method,standardize,...)
+ } else if(data.type=="discrete"){
+ if(hasArg(colors)) colors<-list(...)$colors
+ else {
+ ss<-unique(as.vector(x))
+ colors<-setNames(palette()[1:length(ss)],ss)
+ }
+ dotTree.discrete(tree,x,colors,legend,method,...)
+ }
+}
+
+dotTree.continuous<-function(tree,x,color,legend,method,standardize,...){
+ if(is.data.frame(x)) x<-as.matrix(x)
+ if(is.matrix(x)&&method=="plotTree"){
+ if(ncol(x)>1) method<-"phylogram"
+ else x<-x[,1]
+ }
+ if(hasArg(fsize)) fsize<-list(...)$fsize
+ else fsize<-c(1,0.8)
+ if(length(fsize)==1) fsize<-rep(fsize,2)
+ if(hasArg(x.space)) x.space<-list(...)$x.space
+ else x.space<-0.1
+ if(hasArg(k)) k<-list(...)$k
+ else k<-0.8
+ ## reorder tree
+ tree<-reorder(tree,"cladewise")
+ ## if standardize==TRUE
+ if(standardize){
+ if(is.matrix(x)){
+ sd<-apply(x,2,function(x) sqrt(var(x)))
+ x<-(x-matrix(rep(1,Ntip(tree)),Ntip(tree),1)%*%colMeans(x))/
+ (matrix(rep(1,Ntip(tree)),Ntip(tree),1)%*%sd)
+ } else if(is.vector(x)) x<-(x-mean(x))/sqrt(var(x))
+ }
+ ## in case any x<0
+ min.x<-min(x)
+ max.x<-max(x)
+ if(any(x<0)) x<-x-min(x)
+ if(method=="plotTree"){
+ fsize<-fsize[1]
+ x<-x[tree$tip.label]
+ ## plot tree
+ plotTree(tree,offset=1.7,ylim=c(-Ntip(tree)/25,
+ Ntip(tree)),...)
+ ## get last phylo plot parameters
+ obj<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ x.tip<-obj$xx[1:obj$Ntip]
+ y.tip<-obj$yy[1:obj$Ntip]
+ ## plot points
+ rr<-(k*x/max(x)+x.space)/2*diff(par()$usr[1:2])/
+ diff(par()$usr[3:4])
+ if(k<=0.8&&any(rr>(strwidth("W")*fsize/2)))
+ rr<-rr/max(rr)*strwidth("W")*fsize/2
+ nulo<-mapply(draw.circle,x=x.tip+1.2*strwidth("W"),y=y.tip,
+ radius=rr,MoreArgs=list(nv=200,col=color))
+ ## add legend
+ if(legend){
+ h<-dot.legend(x=par()$usr[1]+0.1*max(nodeHeights(tree)),
+ y=0,min.x,max.x,Ntip=Ntip(tree),
+ method="plotTree",...)
+ if(standardize) text(h,0.1*(1+par()$usr[3]),"(SD units)",pos=4)
+ }
+ } else if(method=="phylogram"){
+ if(is.vector(x)) x<-as.matrix(x)
+ x[]<-x[tree$tip.label,]
+ if(hasArg(mar)) mar<-list(...)$mar
+ else mar<-rep(0.1,4)
+ if(hasArg(xlim)) xlim<-list(...)$xlim
+ else xlim<-c(-0.5,0.55+x.space*ncol(x)+x.space/2)
+ if(hasArg(labels)) labels<-list(...)$labels
+ else labels<-FALSE
+ if(hasArg(ylim)) ylim<-list(...)$ylim
+ else ylim<-c(if(legend) -0.1 else 0,if(labels) 1.1 else 1)
+ ## plot tree
+ plot.new()
+ par(mar=mar)
+ plot.window(xlim=xlim,ylim=ylim)
+ h<-phylogram(tree,...)
+ ## get last phylo plot parameters
+ obj<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ x.tip<-rep(h,obj$Ntip)
+ y.tip<-obj$yy[1:obj$Ntip]
+ ## plot points
+ rr<-(k*x/max(x)+x.space)/2*diff(par()$usr[1:2])/diff(par()$usr[3:4])/
+ (Ntip(tree)-1)
+ if(k<=0.8&&any(rr>(strwidth("W")*fsize[1]/2)))
+ rr<-rr/max(rr)*strwidth("W")*fsize[1]/2
+ for(i in 1:ncol(x)){
+ nulo<-mapply(draw.circle,x=x.tip+1.2*strwidth("W")+x.space*(i-1),
+ y=y.tip,radius=rr[,i],MoreArgs=list(nv=200,col=color))
+ }
+ ## add legend
+ if(legend){
+ h<-dot.legend(x=-0.45,y=-0.04,min.x,max.x,Ntip=Ntip(tree),
+ method="phylogram",...)
+ if(standardize) text(h,-0.04,"(SD units)",pos=4)
+ }
+ if(labels){
+ text(x=seq(max(x.tip)+1.2*strwidth("W"),
+ max(x.tip)+1.2*strwidth("W")+x.space*(ncol(x)-1),by=x.space),
+ y=rep(1.02,ncol(x)),colnames(x),srt=70,adj=c(0,0.5),cex=fsize[2])
+ }
+ }
+}
+
+dotTree.discrete<-function(tree,x,color,legend,method,...){
+ if(is.data.frame(x)) x<-as.matrix(x)
+ if(is.matrix(x)&&method=="plotTree"){
+ if(ncol(x)>1) method<-"phylogram"
+ else x<-x[,1]
+ }
+ if(hasArg(fsize)) fsize<-list(...)$fsize
+ else fsize<-c(1,0.8)
+ if(length(fsize)==1) fsize<-rep(fsize,2)
+ if(hasArg(x.space)) x.space<-list(...)$x.space
+ else x.space<-0.1
+ ## reorder tree
+ tree<-reorder(tree,"cladewise")
+ if(method=="plotTree"){
+ x<-x[tree$tip.label]
+ ## plot tree
+ plotTree(tree,offset=1.7,ylim=c(-1/25*Ntip(tree),
+ Ntip(tree)),...)
+ ## get last phylo plot parameters
+ obj<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ x.tip<-obj$xx[1:obj$Ntip]
+ y.tip<-obj$yy[1:obj$Ntip]
+ ## plot points
+ r<-min(0.8/2*diff(par()$usr[1:2])/diff(par()$usr[3:4]),
+ strwidth("W")*fsize/2)
+ nulo<-mapply(draw.circle,x=x.tip+1.2*strwidth("W"),y=y.tip,
+ col=color[as.character(x)],MoreArgs=list(nv=200,radius=r))
+ if(legend){
+ add.simmap.legend(colors=color,prompt=FALSE,
+ vertical=FALSE,shape="circle",
+ x=par()$usr[1]+0.1*max(nodeHeights(tree)),
+ y=-1/25*Ntip(tree))
+ }
+ } else if(method=="phylogram"){
+ if(is.vector(x)) x<-as.matrix(x)
+ x[]<-x[tree$tip.label,]
+ if(hasArg(mar)) mar<-list(...)$mar
+ else mar<-rep(0.1,4)
+ if(hasArg(xlim)) xlim<-list(...)$xlim
+ else xlim<-c(-0.5,0.55+x.space*ncol(x)+x.space/2)
+ if(hasArg(labels)) labels<-list(...)$labels
+ else labels<-FALSE
+ if(hasArg(ylim)) ylim<-list(...)$ylim
+ else ylim<-c(if(legend) -0.1 else 0,if(labels) 1.1 else 1)
+ ## plot tree
+ plot.new()
+ par(mar=mar)
+ plot.window(xlim=xlim,ylim=ylim)
+ h<-phylogram(tree,...)
+ ## get last phylo plot parameters
+ obj<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ x.tip<-rep(h,obj$Ntip)
+ y.tip<-obj$yy[1:obj$Ntip]
+ ## plot points
+ r<-min(0.8/2*diff(par()$usr[1:2])/diff(par()$usr[3:4])/(Ntip(tree)-1),
+ strwidth("W")*fsize/2)
+ for(i in 1:ncol(x)){
+ nulo<-mapply(draw.circle,x=x.tip+1.2*strwidth("W")+x.space*(i-1),
+ y=y.tip,col=color[as.character(x[,i])],MoreArgs=list(nv=20,
+ radius=r))
+ }
+ ## add legend
+ if(legend){
+ add.simmap.legend(colors=color,prompt=FALSE,
+ vertical=FALSE,shape="circle",x=-0.45,y=-0.06)
+ }
+ if(labels){
+ text(x=seq(max(x.tip)+1.2*strwidth("W"),
+ max(x.tip)+1.2*strwidth("W")+x.space*(ncol(x)-1),by=x.space),
+ y=rep(1.02,ncol(x)),colnames(x),srt=70,adj=c(0,0.5),cex=fsize[2])
+ }
+ }
+}
+
+## dot legend
+## written by Liam J. Revell 2016
+
+dot.legend<-function(x,y,min,max,Ntip,length=5,prompt=FALSE,
+ method="plotTree",...){
+ if(hasArg(cex)) cex<-list(...)$cex
+ else cex<-1
+ if(hasArg(fsize)) fsize<-list(...)$fsize
+ else fsize<-1
+ if(hasArg(colors)) colors<-list(...)$colors
+ else colors<-"blue"
+ if(hasArg(leg.space)) leg.space<-list(...)$leg.space
+ else leg.space<-0.2
+ if(hasArg(k)) k<-list(...)$k
+ else k<-0.8
+ if(prompt){
+ obj<-locator(1)
+ x<-obj$x
+ y<-obj$y
+ }
+ if(method=="plotTree"){
+ text(x,y-0.5*(Ntip/25),round(min,2),pos=1,cex=cex)
+ s<-(k*max(min,0)/min(max,max+min)+0.1)/2*diff(par()$usr[1:2])/
+ diff(par()$usr[3:4])
+ e<-(k+0.1)/2*diff(par()$usr[1:2])/diff(par()$usr[3:4])
+ rr<-seq(s,e,length.out=length)
+ if(k<=0.8&&any(rr>(strwidth("W")*fsize/2)))
+ rr<-rr/max(rr)*strwidth("W")*fsize/2
+ temp<-c(0,cumsum((1+leg.space)*rep(2*max(rr),length-1)))
+ nulo<-mapply(draw.circle,x=x+temp,y=rep(y,length),radius=rr,
+ MoreArgs=list(nv=200,col=colors))
+ ## draw.circle(x+temp,rep(y,length),nv=200,radius=rr,col=colors)
+ text(max(x+temp),y-0.5*(Ntip/25),round(max,2),pos=1,cex=cex)
+ y1<-0.1/25*Ntip
+ lines(c(x,max(x+temp)),rep(y-0.5*(Ntip/25)-y1,2))
+ lines(c(x,x),y-c(y1+0.5*(Ntip/25),2*y1+0.5*(Ntip/25)))
+ lines(c(max(x+temp),max(x+temp)),y-c(y1+0.5*(Ntip/25),2*y1+0.5*(Ntip/25)))
+ } else if(method=="phylogram"){
+ text(x,y-0.04,round(min,2),pos=1,cex=cex)
+ s<-(k*max(min,0)/(min(max,max+min))+0.1)/2*
+ diff(par()$usr[1:2])/diff(par()$usr[3:4])/(Ntip-1)
+ e<-(k+0.1)/2*diff(par()$usr[1:2])/diff(par()$usr[3:4])/(Ntip-1)
+ rr<-seq(s,e,length.out=length)
+ if(k<=0.8&&any(rr>(strwidth("W")*fsize/2)))
+ rr<-rr/max(rr)*strwidth("W")*fsize/2
+ temp<-c(0,cumsum((1+leg.space)*rep(2*max(rr),length-1)))
+ nulo<-mapply(draw.circle,x=x+temp,y=rep(y,length),radius=rr,
+ MoreArgs=list(nv=200,col=colors))
+ ## draw.circle(x+temp,rep(y,length),nv=200,radius=rr,col=colors)
+ text(max(x+temp),y-0.04,round(max,2),pos=1,cex=cex)
+ y1<-0.01
+ lines(c(x,max(x+temp)),rep(y-0.02-y1,2))
+ lines(c(x,x),y-c(y1+0.02,2*y1+0.02))
+ lines(c(max(x+temp),max(x+temp)),y-c(y1+0.02,2*y1+0.02))
+ }
+ invisible(max(x+temp)+0.5*max(rr))
}
\ No newline at end of file
diff --git a/R/drop.tip.simmap.R b/R/drop.tip.simmap.R
index b5a12fb..92a9759 100644
--- a/R/drop.tip.simmap.R
+++ b/R/drop.tip.simmap.R
@@ -1,123 +1,123 @@
-## function drops tip or tips from an object of class "simmap"
-## written by Liam J. Revell 2012, 2015, 2018, 2021, 2023
-
-drop.tip.simmap<-function(phy,tip,...){
- if(hasArg(untangle)) untangle<-list(...)$untangle
- else untangle<-FALSE
- if(!inherits(phy,"phylo"))
- stop("phy should be object of class \"phylo\".")
- tip<-which(phy$tip.label%in%tip)
- edges<-match(tip,phy$edge[,2])
- z<-setdiff(1:nrow(phy$edge),edges)
- phy$edge<-phy$edge[z,]
- phy$edge.length<-phy$edge.length[z]
- phy$maps<-phy$maps[z]
- z<-setdiff(phy$edge[,2],phy$edge[,1])
- z<-z[z>Ntip(phy)]
- while(length(z)>0){
- edges<-match(z,phy$edge[,2])
- y<-setdiff(1:nrow(phy$edge),edges)
- phy$edge<-phy$edge[y,]
- phy$edge.length<-phy$edge.length[y]
- phy$maps<-phy$maps[y]
- z<-setdiff(phy$edge[,2],phy$edge[,1])
- z<-z[z>Ntip(phy)]
- }
- z<-setdiff(phy$edge[,2],phy$edge[,1])
- phy$tip.label<-phy$tip.label[z]
- phy$edge[which(phy$edge[,2]%in%z),2]<-1:Ntip(phy)
- while(sum(phy$edge[1,1]==phy$edge[,1])==1){
- phy$edge<-phy$edge[2:nrow(phy$edge),]
- phy$edge.length<-phy$edge.length[2:length(phy$edge.length)]
- phy$maps<-phy$maps[2:length(phy$maps)]
- }
- i<-1
- while(i<nrow(phy$edge)){
- single<-sum(phy$edge[i,2]==phy$edge[,1])==1
- while(single){
- z<-match(phy$edge[i,2],phy$edge[,1])
- phy$edge[i,2]<-phy$edge[z,2]
- phy$edge.length[i]<-phy$edge.length[i]+phy$edge.length[z]
- if(names(phy$maps[[i]])[length(phy$maps[[i]])]!=names(phy$maps[[z]])[1]){
- phy$maps[[i]]<-c(phy$maps[[i]],phy$maps[[z]])
- } else {
- phy$maps[[i]][length(phy$maps[[i]])]<-
- phy$maps[[i]][length(phy$maps[[i]])]+phy$maps[[z]][1]
- if(length(phy$maps[[z]])>1) phy$maps[[i]]<-
- c(phy$maps[[i]],phy$maps[[z]][2:length(phy$maps[[z]])])
- }
- y<-setdiff(1:nrow(phy$edge),z)
- phy$edge<-phy$edge[y,]
- phy$edge.length<-phy$edge.length[y]
- phy$maps<-phy$maps[y]
- single<-sum(phy$edge[i,2]==phy$edge[,1])==1
- }
- i<-i+1
- }
- z<-unique(as.vector(phy$edge))
- z<-z[z>Ntip(phy)]
- y<-order(z)+Ntip(phy)
- for(i in 1:nrow(phy$edge))
- for(j in 1:2)
- if(phy$edge[i,j]%in%z) phy$edge[i,j]<-y[which(phy$edge[i,j]==z)]
- phy$Nnode<-max(phy$edge)-Ntip(phy)
- phy$node.states<-matrix(NA,nrow(phy$edge),2)
- for(i in 1:nrow(phy$edge)) phy$node.states[i,]<-
- c(names(phy$maps[[i]])[1],names(phy$maps[[i]])[length(phy$maps[[i]])])
- if(!is.null(phy$states)) phy$states<-phy$states[phy$tip.label]
- allstates<-vector()
- for(i in 1:nrow(phy$edge)) allstates<-c(allstates,names(phy$maps[[i]]))
- allstates<-unique(allstates)
- phy$mapped.edge<-matrix(data=0,length(phy$edge.length),length(allstates),
- dimnames=list(edge=apply(phy$edge,1,function(x) paste(x,collapse=",")),
- state=allstates))
- for(i in 1:length(phy$maps)) for(j in 1:length(phy$maps[[i]]))
- phy$mapped.edge[i,names(phy$maps[[i]])[j]]<-phy$mapped.edge[i,
- names(phy$maps[[i]])[j]]+phy$maps[[i]][j]
- class(phy)<-c("simmap",setdiff(class(phy),"simmap"))
- if(untangle) phy<-untangle(phy,"read.tree")
- phy
-}
-
-## drop.tip.multiPhylo
-## written by Liam J. Revell 2020, 2021
-## removed from phytools because 16-1-2023 because redundant with ape
-
-# drop.tip.multiPhylo<-function(phy,tip,...){
- # if(!inherits(phy,"multiPhylo"))
- # stop("phy is not an object of class \"multiPhylo\".")
- # else {
- # if(!inherits(phy,"multiSimmap")){
- # if(hasArg(interactive)) interactive<-list(...)$interactive
- # else interactive<-FALSE
- # if(interactive) stop("interactive=TRUE does not work for drop.tip.multiPhylo.")
- # else {
- # trees<-lapply(phy,drop.tip,tip=tip,...)
- # class(trees)<-class(phy)
- # }
- # } else {
- # trees<-lapply(phy,drop.tip.simmap,tip=tip,...)
- # class(trees)<-class(phy)
- # }
- # }
- # trees
-# }
-
-drop.tip.multiSimmap<-function(phy,tip,...){
- if(!inherits(phy,"multiSimmap"))
- stop("phy is not an object of class \"multiSimmap\".")
- trees<-lapply(phy,drop.tip.simmap,tip=tip,...)
- class(trees)<-class(phy)
- trees
-}
-
-keep.tip.simmap<-function(phy,tip,...){
- tips<-setdiff(phy$tip.label,tip)
- drop.tip.simmap(phy,tip=tips,...)
-}
-
-keep.tip.multiSimmap<-function(phy,tip,...){
- trees<-lapply(phy,keep.tip.simmap,tip=tip,...)
- class(trees)<-class(phy)
- trees
-}
+## function drops tip or tips from an object of class "simmap"
+## written by Liam J. Revell 2012, 2015, 2018, 2021, 2023
+
+drop.tip.simmap<-function(phy,tip,...){
+ if(hasArg(untangle)) untangle<-list(...)$untangle
+ else untangle<-FALSE
+ if(!inherits(phy,"phylo"))
+ stop("phy should be object of class \"phylo\".")
+ tip<-which(phy$tip.label%in%tip)
+ edges<-match(tip,phy$edge[,2])
+ z<-setdiff(1:nrow(phy$edge),edges)
+ phy$edge<-phy$edge[z,]
+ phy$edge.length<-phy$edge.length[z]
+ phy$maps<-phy$maps[z]
+ z<-setdiff(phy$edge[,2],phy$edge[,1])
+ z<-z[z>Ntip(phy)]
+ while(length(z)>0){
+ edges<-match(z,phy$edge[,2])
+ y<-setdiff(1:nrow(phy$edge),edges)
+ phy$edge<-phy$edge[y,]
+ phy$edge.length<-phy$edge.length[y]
+ phy$maps<-phy$maps[y]
+ z<-setdiff(phy$edge[,2],phy$edge[,1])
+ z<-z[z>Ntip(phy)]
+ }
+ z<-setdiff(phy$edge[,2],phy$edge[,1])
+ phy$tip.label<-phy$tip.label[z]
+ phy$edge[which(phy$edge[,2]%in%z),2]<-1:Ntip(phy)
+ while(sum(phy$edge[1,1]==phy$edge[,1])==1){
+ phy$edge<-phy$edge[2:nrow(phy$edge),]
+ phy$edge.length<-phy$edge.length[2:length(phy$edge.length)]
+ phy$maps<-phy$maps[2:length(phy$maps)]
+ }
+ i<-1
+ while(i<nrow(phy$edge)){
+ single<-sum(phy$edge[i,2]==phy$edge[,1])==1
+ while(single){
+ z<-match(phy$edge[i,2],phy$edge[,1])
+ phy$edge[i,2]<-phy$edge[z,2]
+ phy$edge.length[i]<-phy$edge.length[i]+phy$edge.length[z]
+ if(names(phy$maps[[i]])[length(phy$maps[[i]])]!=names(phy$maps[[z]])[1]){
+ phy$maps[[i]]<-c(phy$maps[[i]],phy$maps[[z]])
+ } else {
+ phy$maps[[i]][length(phy$maps[[i]])]<-
+ phy$maps[[i]][length(phy$maps[[i]])]+phy$maps[[z]][1]
+ if(length(phy$maps[[z]])>1) phy$maps[[i]]<-
+ c(phy$maps[[i]],phy$maps[[z]][2:length(phy$maps[[z]])])
+ }
+ y<-setdiff(1:nrow(phy$edge),z)
+ phy$edge<-phy$edge[y,]
+ phy$edge.length<-phy$edge.length[y]
+ phy$maps<-phy$maps[y]
+ single<-sum(phy$edge[i,2]==phy$edge[,1])==1
+ }
+ i<-i+1
+ }
+ z<-unique(as.vector(phy$edge))
+ z<-z[z>Ntip(phy)]
+ y<-order(z)+Ntip(phy)
+ for(i in 1:nrow(phy$edge))
+ for(j in 1:2)
+ if(phy$edge[i,j]%in%z) phy$edge[i,j]<-y[which(phy$edge[i,j]==z)]
+ phy$Nnode<-max(phy$edge)-Ntip(phy)
+ phy$node.states<-matrix(NA,nrow(phy$edge),2)
+ for(i in 1:nrow(phy$edge)) phy$node.states[i,]<-
+ c(names(phy$maps[[i]])[1],names(phy$maps[[i]])[length(phy$maps[[i]])])
+ if(!is.null(phy$states)) phy$states<-phy$states[phy$tip.label]
+ allstates<-vector()
+ for(i in 1:nrow(phy$edge)) allstates<-c(allstates,names(phy$maps[[i]]))
+ allstates<-unique(allstates)
+ phy$mapped.edge<-matrix(data=0,length(phy$edge.length),length(allstates),
+ dimnames=list(edge=apply(phy$edge,1,function(x) paste(x,collapse=",")),
+ state=allstates))
+ for(i in 1:length(phy$maps)) for(j in 1:length(phy$maps[[i]]))
+ phy$mapped.edge[i,names(phy$maps[[i]])[j]]<-phy$mapped.edge[i,
+ names(phy$maps[[i]])[j]]+phy$maps[[i]][j]
+ class(phy)<-c("simmap",setdiff(class(phy),"simmap"))
+ if(untangle) phy<-untangle(phy,"read.tree")
+ phy
+}
+
+## drop.tip.multiPhylo
+## written by Liam J. Revell 2020, 2021
+## removed from phytools because 16-1-2023 because redundant with ape
+
+# drop.tip.multiPhylo<-function(phy,tip,...){
+ # if(!inherits(phy,"multiPhylo"))
+ # stop("phy is not an object of class \"multiPhylo\".")
+ # else {
+ # if(!inherits(phy,"multiSimmap")){
+ # if(hasArg(interactive)) interactive<-list(...)$interactive
+ # else interactive<-FALSE
+ # if(interactive) stop("interactive=TRUE does not work for drop.tip.multiPhylo.")
+ # else {
+ # trees<-lapply(phy,drop.tip,tip=tip,...)
+ # class(trees)<-class(phy)
+ # }
+ # } else {
+ # trees<-lapply(phy,drop.tip.simmap,tip=tip,...)
+ # class(trees)<-class(phy)
+ # }
+ # }
+ # trees
+# }
+
+drop.tip.multiSimmap<-function(phy,tip,...){
+ if(!inherits(phy,"multiSimmap"))
+ stop("phy is not an object of class \"multiSimmap\".")
+ trees<-lapply(phy,drop.tip.simmap,tip=tip,...)
+ class(trees)<-class(phy)
+ trees
+}
+
+keep.tip.simmap<-function(phy,tip,...){
+ tips<-setdiff(phy$tip.label,tip)
+ drop.tip.simmap(phy,tip=tips,...)
+}
+
+keep.tip.multiSimmap<-function(phy,tip,...){
+ trees<-lapply(phy,keep.tip.simmap,tip=tip,...)
+ class(trees)<-class(phy)
+ trees
+}
diff --git a/R/estDiversity.R b/R/estDiversity.R
index f19c46d..a5e3eba 100644
--- a/R/estDiversity.R
+++ b/R/estDiversity.R
@@ -1,76 +1,76 @@
-## function computes an estimate of the standing diversity in each category
-## given by x at each node
-## written by Liam J. Revell 2011-2013, 2019
-
-estDiversity<-function(tree,x,method=c("asr","simulation"),model="ER",...){
- if(!inherits(tree,"phylo"))
- stop("tree should be object of class \"phylo\".")
- method<-matchType(method[1],c("asr","simulation"))
- if(hasArg(nsim)) nsim<-list(...)$nsim else nsim=100
- if(method=="asr"){
- tree<-reorder(tree,"cladewise") # reorder tree
- H<-nodeHeights(tree)
- if(!(model=="ER"||model=="SYM"||if(is.matrix(model)) isSymmetric(model) else FALSE)){
- cat("Warning:\n only symmetric models allowed for method=\"asr\"\n")
- cat(" changing to model=\"ER\".\n")
- model<-"ER"
- }
- bb<-rerootingMethod(tree,x,model=model)
- aa<-bb$marginal.anc
- Q<-bb$Q
- D<-matrix(0,nrow(aa),ncol(aa),dimnames=dimnames(aa))
- # now loop through every node above the root
- message("Please wait. . . . Warning - this may take a while!")
- flush.console()
- for(i in 2:nrow(aa)){
- tt<-H[match(as.numeric(rownames(aa)[i]),tree$edge[,2]),2]
- ii<-H[,1]<tt&H[,2]>tt
- ee<-tree$edge[ii,2]
- hh<-H[ii,1]
- for(j in 1:length(ee)){
- tr<-reroot(tree,node.number=ee[j],position=tt-hh[j])
- D[i,]<-D[i,]+apeAce(tr,x[tr$tip.label],model=model,
- fixedQ=Q)$lik.anc[1,]
- }
- D[i,]<-D[i,]*aa[i,]
- if(i%%10==0){
- message(paste("Completed",i,"nodes"))
- flush.console()
- }
- }
- d<-rowSums(D)
- } else if(method=="simulation") {
- mtrees<-make.simmap(tree,x,nsim=nsim,model=model,message=FALSE)
- st<-sort(unique(x)); nn<-1:tree$Nnode+length(tree$tip)
- aa<-lapply(mtrees,function(x) describe.simmap(x,
- message=FALSE)$states)
- H<-nodeHeights(tree)
- D<-matrix(0,tree$Nnode,length(st),dimnames=list(nn,st))
- CC<-lapply(mtrees,function(x) lapply(x$maps,cumsum))
- # now loop through every node above the root
- message("Please wait. . . . Warning - this may take a while!")
- flush.console()
- for(i in 2:tree$Nnode){
- tt<-H[match(nn[i],tree$edge[,2]),2]
- ii<-H[,1]<tt&H[,2]>tt
- ee<-tree$edge[ii,2]
- hh<-H[ii,1]
- for(j in 1:length(ee)){
- dd<-setNames(rep(0,length(st)),st)
- for(k in 1:nsim){
- jj<-1; while((tt-hh[j])>CC[[k]][[which(tree$edge[,2]==
- ee[j])]][jj]) jj<-jj+1
- ss<-names(mtrees[[k]]$maps[[which(tree$edge[,2]==
- ee[j])]])[jj]
- dd[ss]<-dd[ss]+ if(ss==aa[[k]][i]) 1/nsim else 0
- }
- D[i,]<-D[i,]+dd
- }
- D[i,]<-D[i,]
- if(i%%10==0) message(paste("Completed",i,"nodes"))
- }
- d<-rowSums(D)
- }
- return(d)
-}
-
+## function computes an estimate of the standing diversity in each category
+## given by x at each node
+## written by Liam J. Revell 2011-2013, 2019
+
+estDiversity<-function(tree,x,method=c("asr","simulation"),model="ER",...){
+ if(!inherits(tree,"phylo"))
+ stop("tree should be object of class \"phylo\".")
+ method<-matchType(method[1],c("asr","simulation"))
+ if(hasArg(nsim)) nsim<-list(...)$nsim else nsim=100
+ if(method=="asr"){
+ tree<-reorder(tree,"cladewise") # reorder tree
+ H<-nodeHeights(tree)
+ if(!(model=="ER"||model=="SYM"||if(is.matrix(model)) isSymmetric(model) else FALSE)){
+ cat("Warning:\n only symmetric models allowed for method=\"asr\"\n")
+ cat(" changing to model=\"ER\".\n")
+ model<-"ER"
+ }
+ bb<-rerootingMethod(tree,x,model=model)
+ aa<-bb$marginal.anc
+ Q<-bb$Q
+ D<-matrix(0,nrow(aa),ncol(aa),dimnames=dimnames(aa))
+ # now loop through every node above the root
+ message("Please wait. . . . Warning - this may take a while!")
+ flush.console()
+ for(i in 2:nrow(aa)){
+ tt<-H[match(as.numeric(rownames(aa)[i]),tree$edge[,2]),2]
+ ii<-H[,1]<tt&H[,2]>tt
+ ee<-tree$edge[ii,2]
+ hh<-H[ii,1]
+ for(j in 1:length(ee)){
+ tr<-reroot(tree,node.number=ee[j],position=tt-hh[j])
+ D[i,]<-D[i,]+apeAce(tr,x[tr$tip.label],model=model,
+ fixedQ=Q)$lik.anc[1,]
+ }
+ D[i,]<-D[i,]*aa[i,]
+ if(i%%10==0){
+ message(paste("Completed",i,"nodes"))
+ flush.console()
+ }
+ }
+ d<-rowSums(D)
+ } else if(method=="simulation") {
+ mtrees<-make.simmap(tree,x,nsim=nsim,model=model,message=FALSE)
+ st<-sort(unique(x)); nn<-1:tree$Nnode+length(tree$tip)
+ aa<-lapply(mtrees,function(x) describe.simmap(x,
+ message=FALSE)$states)
+ H<-nodeHeights(tree)
+ D<-matrix(0,tree$Nnode,length(st),dimnames=list(nn,st))
+ CC<-lapply(mtrees,function(x) lapply(x$maps,cumsum))
+ # now loop through every node above the root
+ message("Please wait. . . . Warning - this may take a while!")
+ flush.console()
+ for(i in 2:tree$Nnode){
+ tt<-H[match(nn[i],tree$edge[,2]),2]
+ ii<-H[,1]<tt&H[,2]>tt
+ ee<-tree$edge[ii,2]
+ hh<-H[ii,1]
+ for(j in 1:length(ee)){
+ dd<-setNames(rep(0,length(st)),st)
+ for(k in 1:nsim){
+ jj<-1; while((tt-hh[j])>CC[[k]][[which(tree$edge[,2]==
+ ee[j])]][jj]) jj<-jj+1
+ ss<-names(mtrees[[k]]$maps[[which(tree$edge[,2]==
+ ee[j])]])[jj]
+ dd[ss]<-dd[ss]+ if(ss==aa[[k]][i]) 1/nsim else 0
+ }
+ D[i,]<-D[i,]+dd
+ }
+ D[i,]<-D[i,]
+ if(i%%10==0) message(paste("Completed",i,"nodes"))
+ }
+ d<-rowSums(D)
+ }
+ return(d)
+}
+
diff --git a/R/evol.rate.mcmc.R b/R/evol.rate.mcmc.R
index 5265c6b..fdb5f0c 100644
--- a/R/evol.rate.mcmc.R
+++ b/R/evol.rate.mcmc.R
@@ -1,554 +1,554 @@
-## these functions uses a Bayesian MCMC approach to estimate heterogeneity
-## in the evolutionary rate for a
-## continuous character (Revell, Mahler, Peres-Neto, & Redelings. 2012.)
-## code written by Liam J. Revell 2010, 2011, 2013, 2015, 2017, 2019, 2022
-
-## function for Bayesian MCMC
-## written by Liam J. Revell 2010, 2011, 2017, 2019
-evol.rate.mcmc<-function(tree,x,ngen=10000,control=list(),...){
- if(hasArg(quiet)) quiet<-list(...)$quiet
- else quiet<-FALSE
- # some minor error checking
- if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".")
- if(is.matrix(x)) x<-x[,1]
- if(is.null(names(x))){
- if(length(x)==length(tree$tip)){
- message("x has no names; assuming x is in the same order as tree$tip.label")
- names(x)<-tree$tip.label
- } else
- stop("x has no names and is a different length than tree$tip.label")
- }
- if(any(is.na(match(tree$tip.label,names(x))))){
- message("some species in tree are missing from data, dropping missing taxa from the tree")
- tree<-drop.tip(tree,tree$tip.label[-match(names(x),tree$tip.label)])
- }
- if(any(is.na(match(names(x),tree$tip.label)))){
- message("some species in data are missing from tree, dropping missing taxa from the data")
- x<-x[tree$tip.label]
- }
- if(any(is.na(x))){
- message("some data given as 'NA', dropping corresponding species from tree")
- tree<-drop.tip(tree,names(which(is.na(x))))
- }
- # first, try and obtain reasonable estimates for control parameters
- # and starting values for the MCMC
- C<-vcv.phylo(tree)
- C<-C[names(x),names(x)]
- n<-nrow(C)
- one<-matrix(1,n,1)
- a<-colSums(solve(C))%*%x/sum(solve(C)) # MLE ancestral value, used to start MCMC
- sig1<-as.numeric(t(x-one%*%a)%*%solve(C)%*%(x-one%*%a)/n) # MLE sigma-squared, used to start MCMC
- sig2<-sig1 # used to start MCMC
- flipped=FALSE # used to start MCMC
- # populate control list
- con=list(sig1=sig1,sig2=sig2,a=as.numeric(a),sd1=0.2*sig1,sd2=0.2*sig2,
- sda=0.2*abs(as.numeric(a)),kloc=0.2*mean(diag(C)),sdlnr=1,
- rand.shift=0.05,print=100,sample=100)
- # also might use: sig1mu=1000,sig2mu=1000
- con[(namc <- names(control))] <- control
- con<-con[!sapply(con,is.null)]
- # print control parameters to screen
- if(!quiet){
- message("Control parameters (set by user or default):")
- str(con)
- flush.console()
- }
- # now detach the starting parameter values (to be compatible with downstream code)
- sig1<-con$sig1
- sig2<-con$sig1
- a<-con$a
- # all internal functions start here
- # function to return the index of a random edge
- random.node<-function(phy){
- # sum edges cumulatively
- cum.edge<-vector(mode="numeric")
- index<-vector(mode="numeric")
- for(i in 1:length(phy$edge.length)){
- if(i==1) cum.edge[i]<-phy$edge.length[1]
- else cum.edge[i]<-cum.edge[i-1]+phy$edge.length[i]
- index[i]<-phy$edge[i,2]
- }
- # pick random position
- pos<-runif(1)*cum.edge[length(phy$edge.length)]
- edge<-1
- while(pos>cum.edge[edge]) edge<-edge+1
- return (index[edge])
- }
- # return the indices of a vector that match a scalar
- match.all<-function(s,v){
- result<-vector(mode="numeric")
- j=1
- for(i in 1:length(v)){
- if(s==v[i]){
- result[j]=i
- j=j+1
- }
- }
- if(j==1) result<-NA
- return(result)
- }
- # function to return a matrix of the descendant tips from each internal & terminal node
- compute.descendant.species<-function(phy){
- D<-dist.nodes(phy)
- ntips<-length(phy$tip.label)
- Cii<-D[ntips+1,]
- C<-D
- C[,]<-0
- counts<-vector()
- for(i in 1:nrow(D)) for(j in 1:ncol(D)) C[i,j]<-(Cii[i]+Cii[j]-D[i,j])/2
- tol<-1e-10
- descendants<-matrix(0,nrow(D),ntips,dimnames=list(rownames(D)))
- for(i in 1:nrow(C)){
- k<-0
- for(j in 1:ntips){
- if(C[i,j]>=(C[i,i]-tol)){
- k<-k+1
- descendants[i,k]<-phy$tip.label[j]
- }
- }
- counts[i]<-k
- }
- names(counts)<-rownames(descendants)
- return(descendants=list(species=descendants,counts=counts))
- }
- # take a step on the tree (used in MCMC)
- tree.step<-function(phy,node,bp,step,up=NA,flip=FALSE){
- if(step<0)
- step=-step # if user has given -step, positivize
- if(is.na(up))
- up=(runif(1)>0.5) # if up/down is not assigned, we must be in the middle of a branch
- # decide to go up (1) or down (0) with equal probability
- if(up){
- # pick a new position along the branch (or go to the end)
- new.bp<-min(bp+step,phy$edge.length[match(node,phy$edge[,2])])
- # adjust step length to remain step
- step=step-(new.bp-bp)
- # check to see if we're done
- if(step<1e-6){
- return(list(node=node,bp=new.bp,flip=flip))
- } else {
- # we're going up, so get the daughters
- daughters<-phy$edge[match.all(node,phy$edge[,1]),2]
- # pick a random daughter
- new.node<-daughters[ceiling(runif(1)*length(daughters))]
- if(is.na(new.node)){
- location<-tree.step(phy,node,phy$edge.length[match(node,phy$edge[,2])],
- step,up=FALSE,flip) # we're at a tip
- } else {
- location<-tree.step(phy,new.node,0,step,up=TRUE,flip)
- }
- }
- } else {
- # pick a new position along the branch (or go to the start)
- new.bp<-max(bp-step,0)
- # adjust step length
- step=step-(bp-new.bp)
- # check to see if we're done
- if(step<1e-6){
- return(list(node=node,bp=new.bp,flip=flip))
- } else {
- # we're going down so find out who the parent is
- parent<-phy$edge[match(node,phy$edge[,2]),][1]
- # find the other daughter(s)
- daughters<-phy$edge[match.all(parent,phy$edge[,1]),2]
- # don't use parent if root
- if(parent==(length(phy$tip.label)+1)){
- parent=NULL # if at the base of the tree
- }
- # create a vector of the possible nodes: the parent, and sister(s)
- possible.nodes<-c(parent,daughters[-match(node,daughters)])
- # now pick randomly
- new.node<-possible.nodes[ceiling(runif(1)*length(possible.nodes))]
- # if parent
- if(is.null(parent)==FALSE&&new.node==parent){
- location<-tree.step(phy,new.node,phy$edge.length[match(new.node,
- phy$edge[,2])],step,up=FALSE,flip)
- } else {
- location<-tree.step(phy,new.node,0,step,up=TRUE,flip=TRUE)
- }
- }
- }
- }
- # log-likelihood function
- likelihood<-function(y,phy,C,descendants,sig1,sig2,a,loc){
- C1<-matrix(0,nrow(C),ncol(C),dimnames=dimnames(C))
- C2<-matrix(0,nrow(C),ncol(C),dimnames=dimnames(C))
- n<-length(y)
- D<-matrix(1,n,1)
- if(loc$node>length(phy$tip.label)){
- tr1<-extract.clade(phy,loc$node)
- tr1$root.edge<-phy$edge.length[match(loc$node,phy$edge[,2])]-loc$bp
- temp<-vcv.phylo(tr1)+tr1$root.edge
- } else {
- temp<-matrix(phy$edge.length[match(loc$node,phy$edge[,2])]-loc$bp,
- 1,1,dimnames=list(c(phy$tip.label[loc$node]),c(phy$tip.label[loc$node])))
- }
- C2[rownames(temp),colnames(temp)]<-temp
- C1<-C-C2
- # tips<-phy$tip.label[-match(rownames(temp),phy$tip.label)]
- tips<-rownames(temp)
- V<-sig1*C1+sig2*C2
- logL<-as.numeric(-t(y-D%*%a)%*%solve(V)%*%(y-D%*%a)/2-n*log(2*pi)/2-determinant(V)$modulus[1]/2)
- return(list(logL=logL,tips=tips))
- }
- # prior probability function
- log.prior<-function(s1,s2,a,location){
- # logpr<-dexp(s1,rate=1/con$sig1mu,log=TRUE)+dexp(s2,rate=1/con$sig2mu,log=TRUE) # exponential prior
- logpr<-dnorm(log(s1)-log(s2),mean=0,sd=con$sdlnr,log=TRUE)-log(s1*s2) # log-normal
- return(logpr)
- }
- # proposal on sig1 or sig2
- propose.sig<-function(sig,scale){
- # if normal
- sig.prime<-abs(sig+rnorm(n=1,sd=scale)) # normal proposal distribution
- # if cauchy
- # sig.prime<-abs(sig+rcauchy(n=1,scale=scale))
- return(sig.prime)
- }
- # proposal on a
- propose.a<-function(a,scale){
- # if normal
- a.prime<-a+rnorm(n=1,sd=scale) # normal proposal distribution
- return(a.prime)
- }
- # proposal on loc
- propose.loc<-function(phy,loc,k,r){
- loc.prime<-list()
- loc.prime$flip=FALSE
- if(runif(1)>r){
- loc.prime<-tree.step(phy,loc$node,loc$bp,
- step=rexp(n=1,rate=1/k)) # update node & bp by random walk: rexp()
- # loc.prime<-tree.step(phy,loc$node,loc$bp,
- # step=abs(rnorm(n=1,sd=sqrt(2)/k))) # update node & bp by random walk: rnorm()
- } else {
- loc.prime$node<-random.node(phy) # pick random branch
- loc.prime$bp<-runif(1)*phy$edge.length[match(loc.prime$node,phy$edge[,2])]
- if((runif(1)>0.5)) loc.prime$flip=TRUE
- }
- return(loc.prime)
- }
- # obtain remaining starting values for the MCMC
- location<-list()
- location$node<-random.node(tree)
- location$bp<-runif(1)*tree$edge.length[match(location$node,tree$edge[,2])]
- location$flip<-FALSE
- descendants<-compute.descendant.species(tree) # compute descendants
- logL<-likelihood(x,tree,C,descendants,sig1,sig2,a,location)$logL
- logpr<-log.prior(sig1,sig2,a,location)
- # create matrix for results
- results<-matrix(NA,floor(ngen/con$sample)+1,7,
- dimnames=list(c(0,1:(ngen/con$sample)),c("state","sig1","sig2","a",
- "node","bp","likelihood")))
- curr.gen<-matrix(NA,1,7,dimnames=list("curr",c("state","sig1","sig2","a","node","bp","likelihood")))
- results[1,]<-c(0,sig1,sig2,a,location$node,location$bp,logL) # populate the first row
- curr.gen[1,]<-results[1,]
- group.tips<-list()
- tips<-list()
- group.tips[[1]]<-likelihood(x,tree,C,descendants,sig1,sig2,a,location)$tips
- tips[[1]]<-group.tips[[1]]
- message("Starting MCMC run....")
- if(!quiet){
- cat("gen\tsig2(1)\tsig2(2)\ta \tnode\tpos\'n\tlogLik\n")
- cat(paste(round(results[1,],4),collapse="\t"))
- cat("\n")
- flush.console()
- }
- j<-2
- # now run Markov-chain
- for(i in 1:ngen){
- if(i%%4==1) sig1.prime<-propose.sig(sig1,scale=con$sd1) # update sig1
- else sig1.prime<-sig1
- if(i%%4==2) sig2.prime<-propose.sig(sig2,scale=con$sd2) # update sig2
- else sig2.prime<-sig2
- if(i%%4==3) a.prime<-propose.a(a,scale=con$sda) # update a
- else a.prime<-a
- if(i%%4==0){
- location.prime<-propose.loc(phy=tree,loc=location,k=con$kloc,r=con$rand.shift)
- if(location.prime$flip==TRUE){
- flipped.prime<-!flipped # flip the sigmas
- } else flipped.prime<-flipped
- } else {
- location.prime<-location
- flipped.prime<-flipped
- }
- if(!flipped.prime){
- temp<-likelihood(x,tree,C,descendants,sig1.prime,sig2.prime,a.prime,location.prime)
- logpr.prime<-log.prior(sig1.prime,sig2.prime,a.prime,location.prime)
- if(exp(temp$logL+logpr.prime-curr.gen[1,"likelihood"]-logpr)>runif(1)){
- sig1<-sig1.prime
- sig2<-sig2.prime
- a<-a.prime
- location<-location.prime
- logL<-temp$logL
- logpr<-logpr.prime
- flipped<-flipped.prime
- group.tips[[i+1]]<-temp$tips
- } else group.tips[[i+1]]<-group.tips[[i]]
- } else {
- temp<-likelihood(x,tree,C,descendants,sig2.prime,sig1.prime,a.prime,location.prime)
- logpr.prime<-log.prior(sig2.prime,sig1.prime,a.prime,location.prime)
- if(exp(temp$logL+logpr.prime-curr.gen[1,"likelihood"]-logpr)>runif(1)){
- sig1<-sig1.prime
- sig2<-sig2.prime
- a<-a.prime
- location<-location.prime
- logL<-temp$logL
- logpr<-logpr.prime
- flipped<-flipped.prime
- group.tips[[i+1]]<-setdiff(tree$tip.label,temp$tips)
- } else group.tips[[i+1]]<-group.tips[[i]]
- }
- rm(temp)
- curr.gen[1,]<-c(i,sig1,sig2,a,location$node,location$bp,logL)
- if(i%%con$print==0)
- if(!quiet){
- cat(paste(round(curr.gen[1,],4),collapse="\t"))
- cat("\n")
- flush.console()
- }
- if(i%%con$sample==0){
- results[j,]<-curr.gen
- tips[[j]]<-group.tips[[i+1]]
- j<-j+1
- }
- }
- message("Done MCMC run.")
- # return results
- obj<-list(mcmc=results,tips=tips,ngen=ngen,sample=con$sample,
- tree=tree)
- class(obj)<-"evol.rate.mcmc"
- obj
-}
-
-## S3 print method
-print.evol.rate.mcmc<-function(x, ...){
- cat("\nObject of class \"evol.rate.mcmc\" containing the results from a\n")
- cat("the Bayesian MCMC analysis of a Brownian-motion rate-shift model.\n\n")
- cat(paste("MCMC was conducted for",x$ngen,"generations sampling every",x$sample,"\n"))
- cat("generations.\n\n")
- cat("The most commonly sampled rate shift(s) occurred on the edge(s)\n")
- pp<-table(x$mcmc[,"node"])/nrow(x$mcmc)
- node<-names(pp)[which(pp==max(pp))]
- if(length(node)==1) cat(paste("to node(s) ",node,".\n\n",sep=""))
- else cat(paste("leading to node(s) ",paste(node,collapse=", "),".\n\n",sep=""))
- cat("Use the functions posterior.evolrate and minSplit for more detailed\n")
- cat("analysis of the posterior sample from this analysis.\n\n")
-}
-
-# this function finds the split with the minimum the distance to all the other splits in the sample
-# written by Liam J. Revell 2010, 2015, 2022
-minSplit<-function(tree,split.list,method="sum",printD=FALSE){
- # some minor error checking
- if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".")
- ## determine is split.list is an object from our MCMC, or a matrix
- if(inherits(split.list,"evol.rate.mcmc")) split.list<-split.list$mcmc[,c("node","bp")]
- else if(inherits(split.list,"matrix")) split.list<-split.list[,c("node","bp")]
- # start by creating a matrix of the nodes of the tree with their descendant nodes
- D<-dist.nodes(tree)
- ntips<-length(tree$tip.label)
- Cii<-D[ntips+1,]
- C<-D
- C[,]<-0
- for(i in 1:nrow(D)) for(j in 1:ncol(D)) C[i,j]<-(Cii[i]+Cii[j]-D[i,j])/2
- tol<-1e-10
- descendants<-matrix(0,nrow(D),ncol(D),dimnames=list(rownames(D)))
- for(i in 1:nrow(C)){
- k<-1
- for(j in 1:ncol(C)){
- if(C[i,j]>=(C[i,i]-tol)){
- descendants[i,k]<-j
- k<-k+1
- }
- }
- }
- distances<-matrix(0,nrow(split.list),nrow(split.list))
- for(i in 1:nrow(split.list)){
- for(j in i:nrow(split.list)){
- if(i!=j){
- # first, if on the same branch as current average - then just compute the difference
- if(split.list[i,1]==split.list[j,1]){
- distances[i,j]<-abs(split.list[i,2]-split.list[j,2])
- } else {
- distances[i,j]<-D[split.list[i,1],split.list[j,1]]
- # is the split j downstream
- if(split.list[j,1]%in%descendants[split.list[i,1],]){
- # downstream
- distances[i,j]<-distances[i,j]-(tree$edge.length[match(split.list[j,1],tree$edge[,2])]-split.list[j,2])
- distances[i,j]<-distances[i,j]+(tree$edge.length[match(split.list[i,1],tree$edge[,2])]-split.list[i,2])
- } else if(split.list[i,1]%in%descendants[split.list[j,1],]){
- # ancestral
- distances[i,j]<-distances[i,j]-(tree$edge.length[match(split.list[i,1],tree$edge[,2])]-split.list[i,2])
- distances[i,j]<-distances[i,j]+(tree$edge.length[match(split.list[j,1],tree$edge[,2])]-split.list[j,2])
- } else {
- # neither
- distances[i,j]<-distances[i,j]-(tree$edge.length[match(split.list[i,1],tree$edge[,2])]-split.list[i,2])
- distances[i,j]<-distances[i,j]-(tree$edge.length[match(split.list[j,1],tree$edge[,2])]-split.list[j,2])
- }
- }
- distances[j,i]<-distances[i,j]
- }
- }
- }
- if(method=="sumsq") distances<-distances^2
- if(method!="sumsq"&&method!="sum") message("allowable methods are 'sum' and 'sumsq' - using default method ('sum')")
- if(printD) print(distances)
- sum.dist<-colSums(distances)
- ind<-which.min(sum.dist) # this is the index of the minimum split
- # return minimum split
- return(list(node=split.list[ind,1],bp=split.list[ind,2]))
-}
-
-# function to analyze the posterior from evol.rate.mcmc()
-# written by Liam Revell 2011
-posterior.evolrate<-function(tree,ave.shift,mcmc,tips,showTree=FALSE){
- result<-matrix(NA,nrow(mcmc),7,dimnames=list(NULL,c("state","sig1","sig2","a","node","bp","likelihood")))
- tree$node.label<-NULL
- for(i in 1:nrow(mcmc)){
- shift=list(node=mcmc[i,"node"],bp=mcmc[i,"bp"])
- temp<-ave.rates(tree,shift,tips[[i]],mcmc[i,"sig1"],mcmc[i,"sig2"],ave.shift,showTree=showTree)
- result[i,]<-c(mcmc[i,"state"],temp[[1]],temp[[2]],mcmc[i,"a"],mcmc[i,"node"],mcmc[i,"bp"],mcmc[i,"likelihood"])
- }
- return(result)
-}
-
-# average the posterior rates
-# written by Liam Revell 2011
-ave.rates<-function(tree,shift,tips,sig1,sig2,ave.shift,showTree=TRUE){
- # first split and scale at shift
- unscaled<-splitTree(tree,shift)
- # now scale
- scaled<-unscaled
- if(length(setdiff(scaled[[1]]$tip.label,tips))!=1){
- scaled[[1]]$edge.length<-scaled[[1]]$edge.length*sig1
- scaled[[2]]$edge.length<-scaled[[2]]$edge.length*sig2
- if(!is.null(scaled[[2]]$root.edge)) scaled[[2]]$root.edge<-scaled[[2]]$root.edge*sig2
- } else {
- scaled[[1]]$edge.length<-scaled[[1]]$edge.length*sig2
- scaled[[2]]$edge.length<-scaled[[2]]$edge.length*sig1
- if(!is.null(scaled[[2]]$root.edge)) scaled[[2]]$root.edge<-scaled[[2]]$root.edge*sig1
- }
- # now bind
- tr.scaled<-paste.tree(scaled[[1]],scaled[[2]])
- if(showTree==TRUE) plot(tr.scaled)
- # now split tr.scaled and tree at ave.shift
- unscaled<-splitTree(tree,ave.shift)
- scaled<-splitTree(tr.scaled,ave.shift)
- # now compute the sig1 and sig2 to return
- sig1<-sum(scaled[[1]]$edge.length)/sum(unscaled[[1]]$edge.length)
- sig2<-sum(scaled[[2]]$edge.length)/sum(unscaled[[2]]$edge.length)
- return(list(sig1=sig1,sig2=sig2))
-}
-
-## a bunch of new S3 methods
-## written by Liam J. Revell 2019
-
-summary.evol.rate.mcmc<-function(object,...){
- if(hasArg(burnin)) burnin<-list(...)$burnin
- else {
- burnin<-round(0.2*max(object$mcmc[,"state"]))
- cat("\nNo burn-in specified. Excluding the first 20% by default.\n\n")
- }
- if(hasArg(method)) method<-list(...)$method
- else method<-"sumsq"
- ii<-min(which(object$mcmc[,"state"]>=burnin))
- mcmc<-object$mcmc[ii:nrow(object$mcmc),]
- tips<-object$tips[ii:length(object$tips)]
- tree<-object$tree
- ms<-minSplit(tree,mcmc,method=method)
- ps<-posterior.evolrate(tree,ms,mcmc,tips)
- prob<-(table(factor(ps[,"node"],
- levels=1:(Ntip(tree)+tree$Nnode)))/
- nrow(ps))[tree$edge[,2]]
- result<-list(min.split=ms,posterior.rates=ps,
- hpd=setNames(list(HPD(ps[,"sig1"]),
- HPD(ps[,"sig2"])),c("sig1","sig2")),
- edge.prob=prob,
- tree=tree,method=method)
- class(result)<-"summary.evol.rate.mcmc"
- result
-}
-
-HPD<-function(x){
- if(.check.pkg("coda")) object<-HPDinterval(as.mcmc(x))
- else {
- cat(" HPDinterval requires package coda.\n")
- cat(" Computing 95% interval from samples only.\n\n")
- object<-setNames(c(sort(x)[round(0.025*length(x))],
- sort(x)[round(0.975*length(x))]),c("lower",
- "upper"))
- attr(object, "Probability")<-0.95
- }
- object
-}
-
-print.summary.evol.rate.mcmc<-function(x,...){
- if(x$method=="sum")
- cat("\nThe shift location with the minimum distance to all shifts in the\n")
- else
- cat("\nThe shift with the minimum (squared) distance to all shifts in the\n")
- cat(paste("posterior set is found ",round(x$min.split$bp,4),
- " along the branch leading to node ",
- x$min.split$node,".\n",sep=""))
- cat("\nMean \'root-wise\' rate from the posterior sample (sig1): ")
- cat(round(mean(x$posterior[,"sig1"]),4))
- cat(paste("\n 95% HPD for sig1: [",round(x$hpd[["sig1"]][1],4),", ",
- round(x$hpd[["sig1"]][2],4),"]",sep=""))
- cat("\nMean \'tip-wise\' rate from the posterior sample (sig2): ")
- cat(round(mean(x$posterior[,"sig2"]),4))
- cat(paste("\n 95% HPD for sig1: [",round(x$hpd[["sig2"]][1],4),", ",
- round(x$hpd[["sig2"]][2],4),"]",sep=""))
- cat("\n\n")
- cat("To plot the mean shift point run plot(...,type=\"min.split\") on the object\n")
- cat("produced by this function.\n\n")
- cat("To plot the probability of a shift by edge run plot(...,method=\"edge.prob\")\n")
- cat("on the object produced by this function.\n\n")
-}
-
-HPD<-function(x){
- if(.check.pkg("coda")) hpd<-HPDinterval(as.mcmc(x))
- else {
- cat(" HPDinterval requires package coda.\n")
- cat(" Computing 95% interval from samples only.\n\n")
- hpd<-setNames(c(sort(x)[round(0.025*length(x))],
- sort(x)[round(0.975*length(x))]),c("lower",
- "upper"))
- attr(hpd, "Probability")<-0.95
- }
- hpd
-}
-
-plot.summary.evol.rate.mcmc<-function(x,...){
- if(hasArg(method)) method<-list(...)$method
- else method<-"min.split"
- if(method=="min.split"){
- if(hasArg(cex)) cex<-list(...)$cex
- else cex<-0.5
- if(hasArg(lwd.split)) lwd.split<-list(...)$lwd.split
- else lwd.split<-4
- if(hasArg(col.split)) col.split<-list(...)$col.split
- else col.split<-"red"
- if(hasArg(col)) col<-list(...)$col
- else col<-setNames(c("blue","red"),1:2)
- if(is.null(names(col))) names(col)<-1:2
- ii<-which(x$tree$edge[,2]==x$min.split$node)
- plot(paintSubTree(x$tree,node=x$min.split$node,"2",
- stem=(x$tree$edge.length[ii]-x$min.split$bp)/
- x$tree$edge.length[ii]),col,...)
- pp<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- h<-nodeheight(x$tree,getParent(x$tree,
- x$min.split$node))+x$min.split$bp
- lines(rep(h,2),rep(pp$yy[x$min.split$node],2)+
- cex*c(-1,1),lwd=lwd.split,
- col=col.split,lend=2)
- } else if(method=="edge.prob"){
- if(hasArg(cex)) cex<-list(...)$cex
- else cex<-0.5
- if(hasArg(piecol)) piecol<-list(...)$piecol
- else piecol<-c("darkgrey","white")
- plotTree(x$tree,...)
- edgelabels(pie=cbind(x$edge.prob,1-x$edge.prob),
- cex=cex,piecol=piecol)
- }
-}
-
-
+## these functions uses a Bayesian MCMC approach to estimate heterogeneity
+## in the evolutionary rate for a
+## continuous character (Revell, Mahler, Peres-Neto, & Redelings. 2012.)
+## code written by Liam J. Revell 2010, 2011, 2013, 2015, 2017, 2019, 2022
+
+## function for Bayesian MCMC
+## written by Liam J. Revell 2010, 2011, 2017, 2019
+evol.rate.mcmc<-function(tree,x,ngen=10000,control=list(),...){
+ if(hasArg(quiet)) quiet<-list(...)$quiet
+ else quiet<-FALSE
+ # some minor error checking
+ if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".")
+ if(is.matrix(x)) x<-x[,1]
+ if(is.null(names(x))){
+ if(length(x)==length(tree$tip)){
+ message("x has no names; assuming x is in the same order as tree$tip.label")
+ names(x)<-tree$tip.label
+ } else
+ stop("x has no names and is a different length than tree$tip.label")
+ }
+ if(any(is.na(match(tree$tip.label,names(x))))){
+ message("some species in tree are missing from data, dropping missing taxa from the tree")
+ tree<-drop.tip(tree,tree$tip.label[-match(names(x),tree$tip.label)])
+ }
+ if(any(is.na(match(names(x),tree$tip.label)))){
+ message("some species in data are missing from tree, dropping missing taxa from the data")
+ x<-x[tree$tip.label]
+ }
+ if(any(is.na(x))){
+ message("some data given as 'NA', dropping corresponding species from tree")
+ tree<-drop.tip(tree,names(which(is.na(x))))
+ }
+ # first, try and obtain reasonable estimates for control parameters
+ # and starting values for the MCMC
+ C<-vcv.phylo(tree)
+ C<-C[names(x),names(x)]
+ n<-nrow(C)
+ one<-matrix(1,n,1)
+ a<-colSums(solve(C))%*%x/sum(solve(C)) # MLE ancestral value, used to start MCMC
+ sig1<-as.numeric(t(x-one%*%a)%*%solve(C)%*%(x-one%*%a)/n) # MLE sigma-squared, used to start MCMC
+ sig2<-sig1 # used to start MCMC
+ flipped=FALSE # used to start MCMC
+ # populate control list
+ con=list(sig1=sig1,sig2=sig2,a=as.numeric(a),sd1=0.2*sig1,sd2=0.2*sig2,
+ sda=0.2*abs(as.numeric(a)),kloc=0.2*mean(diag(C)),sdlnr=1,
+ rand.shift=0.05,print=100,sample=100)
+ # also might use: sig1mu=1000,sig2mu=1000
+ con[(namc <- names(control))] <- control
+ con<-con[!sapply(con,is.null)]
+ # print control parameters to screen
+ if(!quiet){
+ message("Control parameters (set by user or default):")
+ str(con)
+ flush.console()
+ }
+ # now detach the starting parameter values (to be compatible with downstream code)
+ sig1<-con$sig1
+ sig2<-con$sig1
+ a<-con$a
+ # all internal functions start here
+ # function to return the index of a random edge
+ random.node<-function(phy){
+ # sum edges cumulatively
+ cum.edge<-vector(mode="numeric")
+ index<-vector(mode="numeric")
+ for(i in 1:length(phy$edge.length)){
+ if(i==1) cum.edge[i]<-phy$edge.length[1]
+ else cum.edge[i]<-cum.edge[i-1]+phy$edge.length[i]
+ index[i]<-phy$edge[i,2]
+ }
+ # pick random position
+ pos<-runif(1)*cum.edge[length(phy$edge.length)]
+ edge<-1
+ while(pos>cum.edge[edge]) edge<-edge+1
+ return (index[edge])
+ }
+ # return the indices of a vector that match a scalar
+ match.all<-function(s,v){
+ result<-vector(mode="numeric")
+ j=1
+ for(i in 1:length(v)){
+ if(s==v[i]){
+ result[j]=i
+ j=j+1
+ }
+ }
+ if(j==1) result<-NA
+ return(result)
+ }
+ # function to return a matrix of the descendant tips from each internal & terminal node
+ compute.descendant.species<-function(phy){
+ D<-dist.nodes(phy)
+ ntips<-length(phy$tip.label)
+ Cii<-D[ntips+1,]
+ C<-D
+ C[,]<-0
+ counts<-vector()
+ for(i in 1:nrow(D)) for(j in 1:ncol(D)) C[i,j]<-(Cii[i]+Cii[j]-D[i,j])/2
+ tol<-1e-10
+ descendants<-matrix(0,nrow(D),ntips,dimnames=list(rownames(D)))
+ for(i in 1:nrow(C)){
+ k<-0
+ for(j in 1:ntips){
+ if(C[i,j]>=(C[i,i]-tol)){
+ k<-k+1
+ descendants[i,k]<-phy$tip.label[j]
+ }
+ }
+ counts[i]<-k
+ }
+ names(counts)<-rownames(descendants)
+ return(descendants=list(species=descendants,counts=counts))
+ }
+ # take a step on the tree (used in MCMC)
+ tree.step<-function(phy,node,bp,step,up=NA,flip=FALSE){
+ if(step<0)
+ step=-step # if user has given -step, positivize
+ if(is.na(up))
+ up=(runif(1)>0.5) # if up/down is not assigned, we must be in the middle of a branch
+ # decide to go up (1) or down (0) with equal probability
+ if(up){
+ # pick a new position along the branch (or go to the end)
+ new.bp<-min(bp+step,phy$edge.length[match(node,phy$edge[,2])])
+ # adjust step length to remain step
+ step=step-(new.bp-bp)
+ # check to see if we're done
+ if(step<1e-6){
+ return(list(node=node,bp=new.bp,flip=flip))
+ } else {
+ # we're going up, so get the daughters
+ daughters<-phy$edge[match.all(node,phy$edge[,1]),2]
+ # pick a random daughter
+ new.node<-daughters[ceiling(runif(1)*length(daughters))]
+ if(is.na(new.node)){
+ location<-tree.step(phy,node,phy$edge.length[match(node,phy$edge[,2])],
+ step,up=FALSE,flip) # we're at a tip
+ } else {
+ location<-tree.step(phy,new.node,0,step,up=TRUE,flip)
+ }
+ }
+ } else {
+ # pick a new position along the branch (or go to the start)
+ new.bp<-max(bp-step,0)
+ # adjust step length
+ step=step-(bp-new.bp)
+ # check to see if we're done
+ if(step<1e-6){
+ return(list(node=node,bp=new.bp,flip=flip))
+ } else {
+ # we're going down so find out who the parent is
+ parent<-phy$edge[match(node,phy$edge[,2]),][1]
+ # find the other daughter(s)
+ daughters<-phy$edge[match.all(parent,phy$edge[,1]),2]
+ # don't use parent if root
+ if(parent==(length(phy$tip.label)+1)){
+ parent=NULL # if at the base of the tree
+ }
+ # create a vector of the possible nodes: the parent, and sister(s)
+ possible.nodes<-c(parent,daughters[-match(node,daughters)])
+ # now pick randomly
+ new.node<-possible.nodes[ceiling(runif(1)*length(possible.nodes))]
+ # if parent
+ if(is.null(parent)==FALSE&&new.node==parent){
+ location<-tree.step(phy,new.node,phy$edge.length[match(new.node,
+ phy$edge[,2])],step,up=FALSE,flip)
+ } else {
+ location<-tree.step(phy,new.node,0,step,up=TRUE,flip=TRUE)
+ }
+ }
+ }
+ }
+ # log-likelihood function
+ likelihood<-function(y,phy,C,descendants,sig1,sig2,a,loc){
+ C1<-matrix(0,nrow(C),ncol(C),dimnames=dimnames(C))
+ C2<-matrix(0,nrow(C),ncol(C),dimnames=dimnames(C))
+ n<-length(y)
+ D<-matrix(1,n,1)
+ if(loc$node>length(phy$tip.label)){
+ tr1<-extract.clade(phy,loc$node)
+ tr1$root.edge<-phy$edge.length[match(loc$node,phy$edge[,2])]-loc$bp
+ temp<-vcv.phylo(tr1)+tr1$root.edge
+ } else {
+ temp<-matrix(phy$edge.length[match(loc$node,phy$edge[,2])]-loc$bp,
+ 1,1,dimnames=list(c(phy$tip.label[loc$node]),c(phy$tip.label[loc$node])))
+ }
+ C2[rownames(temp),colnames(temp)]<-temp
+ C1<-C-C2
+ # tips<-phy$tip.label[-match(rownames(temp),phy$tip.label)]
+ tips<-rownames(temp)
+ V<-sig1*C1+sig2*C2
+ logL<-as.numeric(-t(y-D%*%a)%*%solve(V)%*%(y-D%*%a)/2-n*log(2*pi)/2-determinant(V)$modulus[1]/2)
+ return(list(logL=logL,tips=tips))
+ }
+ # prior probability function
+ log.prior<-function(s1,s2,a,location){
+ # logpr<-dexp(s1,rate=1/con$sig1mu,log=TRUE)+dexp(s2,rate=1/con$sig2mu,log=TRUE) # exponential prior
+ logpr<-dnorm(log(s1)-log(s2),mean=0,sd=con$sdlnr,log=TRUE)-log(s1*s2) # log-normal
+ return(logpr)
+ }
+ # proposal on sig1 or sig2
+ propose.sig<-function(sig,scale){
+ # if normal
+ sig.prime<-abs(sig+rnorm(n=1,sd=scale)) # normal proposal distribution
+ # if cauchy
+ # sig.prime<-abs(sig+rcauchy(n=1,scale=scale))
+ return(sig.prime)
+ }
+ # proposal on a
+ propose.a<-function(a,scale){
+ # if normal
+ a.prime<-a+rnorm(n=1,sd=scale) # normal proposal distribution
+ return(a.prime)
+ }
+ # proposal on loc
+ propose.loc<-function(phy,loc,k,r){
+ loc.prime<-list()
+ loc.prime$flip=FALSE
+ if(runif(1)>r){
+ loc.prime<-tree.step(phy,loc$node,loc$bp,
+ step=rexp(n=1,rate=1/k)) # update node & bp by random walk: rexp()
+ # loc.prime<-tree.step(phy,loc$node,loc$bp,
+ # step=abs(rnorm(n=1,sd=sqrt(2)/k))) # update node & bp by random walk: rnorm()
+ } else {
+ loc.prime$node<-random.node(phy) # pick random branch
+ loc.prime$bp<-runif(1)*phy$edge.length[match(loc.prime$node,phy$edge[,2])]
+ if((runif(1)>0.5)) loc.prime$flip=TRUE
+ }
+ return(loc.prime)
+ }
+ # obtain remaining starting values for the MCMC
+ location<-list()
+ location$node<-random.node(tree)
+ location$bp<-runif(1)*tree$edge.length[match(location$node,tree$edge[,2])]
+ location$flip<-FALSE
+ descendants<-compute.descendant.species(tree) # compute descendants
+ logL<-likelihood(x,tree,C,descendants,sig1,sig2,a,location)$logL
+ logpr<-log.prior(sig1,sig2,a,location)
+ # create matrix for results
+ results<-matrix(NA,floor(ngen/con$sample)+1,7,
+ dimnames=list(c(0,1:(ngen/con$sample)),c("state","sig1","sig2","a",
+ "node","bp","likelihood")))
+ curr.gen<-matrix(NA,1,7,dimnames=list("curr",c("state","sig1","sig2","a","node","bp","likelihood")))
+ results[1,]<-c(0,sig1,sig2,a,location$node,location$bp,logL) # populate the first row
+ curr.gen[1,]<-results[1,]
+ group.tips<-list()
+ tips<-list()
+ group.tips[[1]]<-likelihood(x,tree,C,descendants,sig1,sig2,a,location)$tips
+ tips[[1]]<-group.tips[[1]]
+ message("Starting MCMC run....")
+ if(!quiet){
+ cat("gen\tsig2(1)\tsig2(2)\ta \tnode\tpos\'n\tlogLik\n")
+ cat(paste(round(results[1,],4),collapse="\t"))
+ cat("\n")
+ flush.console()
+ }
+ j<-2
+ # now run Markov-chain
+ for(i in 1:ngen){
+ if(i%%4==1) sig1.prime<-propose.sig(sig1,scale=con$sd1) # update sig1
+ else sig1.prime<-sig1
+ if(i%%4==2) sig2.prime<-propose.sig(sig2,scale=con$sd2) # update sig2
+ else sig2.prime<-sig2
+ if(i%%4==3) a.prime<-propose.a(a,scale=con$sda) # update a
+ else a.prime<-a
+ if(i%%4==0){
+ location.prime<-propose.loc(phy=tree,loc=location,k=con$kloc,r=con$rand.shift)
+ if(location.prime$flip==TRUE){
+ flipped.prime<-!flipped # flip the sigmas
+ } else flipped.prime<-flipped
+ } else {
+ location.prime<-location
+ flipped.prime<-flipped
+ }
+ if(!flipped.prime){
+ temp<-likelihood(x,tree,C,descendants,sig1.prime,sig2.prime,a.prime,location.prime)
+ logpr.prime<-log.prior(sig1.prime,sig2.prime,a.prime,location.prime)
+ if(exp(temp$logL+logpr.prime-curr.gen[1,"likelihood"]-logpr)>runif(1)){
+ sig1<-sig1.prime
+ sig2<-sig2.prime
+ a<-a.prime
+ location<-location.prime
+ logL<-temp$logL
+ logpr<-logpr.prime
+ flipped<-flipped.prime
+ group.tips[[i+1]]<-temp$tips
+ } else group.tips[[i+1]]<-group.tips[[i]]
+ } else {
+ temp<-likelihood(x,tree,C,descendants,sig2.prime,sig1.prime,a.prime,location.prime)
+ logpr.prime<-log.prior(sig2.prime,sig1.prime,a.prime,location.prime)
+ if(exp(temp$logL+logpr.prime-curr.gen[1,"likelihood"]-logpr)>runif(1)){
+ sig1<-sig1.prime
+ sig2<-sig2.prime
+ a<-a.prime
+ location<-location.prime
+ logL<-temp$logL
+ logpr<-logpr.prime
+ flipped<-flipped.prime
+ group.tips[[i+1]]<-setdiff(tree$tip.label,temp$tips)
+ } else group.tips[[i+1]]<-group.tips[[i]]
+ }
+ rm(temp)
+ curr.gen[1,]<-c(i,sig1,sig2,a,location$node,location$bp,logL)
+ if(i%%con$print==0)
+ if(!quiet){
+ cat(paste(round(curr.gen[1,],4),collapse="\t"))
+ cat("\n")
+ flush.console()
+ }
+ if(i%%con$sample==0){
+ results[j,]<-curr.gen
+ tips[[j]]<-group.tips[[i+1]]
+ j<-j+1
+ }
+ }
+ message("Done MCMC run.")
+ # return results
+ obj<-list(mcmc=results,tips=tips,ngen=ngen,sample=con$sample,
+ tree=tree)
+ class(obj)<-"evol.rate.mcmc"
+ obj
+}
+
+## S3 print method
+print.evol.rate.mcmc<-function(x, ...){
+ cat("\nObject of class \"evol.rate.mcmc\" containing the results from a\n")
+ cat("the Bayesian MCMC analysis of a Brownian-motion rate-shift model.\n\n")
+ cat(paste("MCMC was conducted for",x$ngen,"generations sampling every",x$sample,"\n"))
+ cat("generations.\n\n")
+ cat("The most commonly sampled rate shift(s) occurred on the edge(s)\n")
+ pp<-table(x$mcmc[,"node"])/nrow(x$mcmc)
+ node<-names(pp)[which(pp==max(pp))]
+ if(length(node)==1) cat(paste("to node(s) ",node,".\n\n",sep=""))
+ else cat(paste("leading to node(s) ",paste(node,collapse=", "),".\n\n",sep=""))
+ cat("Use the functions posterior.evolrate and minSplit for more detailed\n")
+ cat("analysis of the posterior sample from this analysis.\n\n")
+}
+
+# this function finds the split with the minimum the distance to all the other splits in the sample
+# written by Liam J. Revell 2010, 2015, 2022
+minSplit<-function(tree,split.list,method="sum",printD=FALSE){
+ # some minor error checking
+ if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".")
+ ## determine is split.list is an object from our MCMC, or a matrix
+ if(inherits(split.list,"evol.rate.mcmc")) split.list<-split.list$mcmc[,c("node","bp")]
+ else if(inherits(split.list,"matrix")) split.list<-split.list[,c("node","bp")]
+ # start by creating a matrix of the nodes of the tree with their descendant nodes
+ D<-dist.nodes(tree)
+ ntips<-length(tree$tip.label)
+ Cii<-D[ntips+1,]
+ C<-D
+ C[,]<-0
+ for(i in 1:nrow(D)) for(j in 1:ncol(D)) C[i,j]<-(Cii[i]+Cii[j]-D[i,j])/2
+ tol<-1e-10
+ descendants<-matrix(0,nrow(D),ncol(D),dimnames=list(rownames(D)))
+ for(i in 1:nrow(C)){
+ k<-1
+ for(j in 1:ncol(C)){
+ if(C[i,j]>=(C[i,i]-tol)){
+ descendants[i,k]<-j
+ k<-k+1
+ }
+ }
+ }
+ distances<-matrix(0,nrow(split.list),nrow(split.list))
+ for(i in 1:nrow(split.list)){
+ for(j in i:nrow(split.list)){
+ if(i!=j){
+ # first, if on the same branch as current average - then just compute the difference
+ if(split.list[i,1]==split.list[j,1]){
+ distances[i,j]<-abs(split.list[i,2]-split.list[j,2])
+ } else {
+ distances[i,j]<-D[split.list[i,1],split.list[j,1]]
+ # is the split j downstream
+ if(split.list[j,1]%in%descendants[split.list[i,1],]){
+ # downstream
+ distances[i,j]<-distances[i,j]-(tree$edge.length[match(split.list[j,1],tree$edge[,2])]-split.list[j,2])
+ distances[i,j]<-distances[i,j]+(tree$edge.length[match(split.list[i,1],tree$edge[,2])]-split.list[i,2])
+ } else if(split.list[i,1]%in%descendants[split.list[j,1],]){
+ # ancestral
+ distances[i,j]<-distances[i,j]-(tree$edge.length[match(split.list[i,1],tree$edge[,2])]-split.list[i,2])
+ distances[i,j]<-distances[i,j]+(tree$edge.length[match(split.list[j,1],tree$edge[,2])]-split.list[j,2])
+ } else {
+ # neither
+ distances[i,j]<-distances[i,j]-(tree$edge.length[match(split.list[i,1],tree$edge[,2])]-split.list[i,2])
+ distances[i,j]<-distances[i,j]-(tree$edge.length[match(split.list[j,1],tree$edge[,2])]-split.list[j,2])
+ }
+ }
+ distances[j,i]<-distances[i,j]
+ }
+ }
+ }
+ if(method=="sumsq") distances<-distances^2
+ if(method!="sumsq"&&method!="sum") message("allowable methods are 'sum' and 'sumsq' - using default method ('sum')")
+ if(printD) print(distances)
+ sum.dist<-colSums(distances)
+ ind<-which.min(sum.dist) # this is the index of the minimum split
+ # return minimum split
+ return(list(node=split.list[ind,1],bp=split.list[ind,2]))
+}
+
+# function to analyze the posterior from evol.rate.mcmc()
+# written by Liam Revell 2011
+posterior.evolrate<-function(tree,ave.shift,mcmc,tips,showTree=FALSE){
+ result<-matrix(NA,nrow(mcmc),7,dimnames=list(NULL,c("state","sig1","sig2","a","node","bp","likelihood")))
+ tree$node.label<-NULL
+ for(i in 1:nrow(mcmc)){
+ shift=list(node=mcmc[i,"node"],bp=mcmc[i,"bp"])
+ temp<-ave.rates(tree,shift,tips[[i]],mcmc[i,"sig1"],mcmc[i,"sig2"],ave.shift,showTree=showTree)
+ result[i,]<-c(mcmc[i,"state"],temp[[1]],temp[[2]],mcmc[i,"a"],mcmc[i,"node"],mcmc[i,"bp"],mcmc[i,"likelihood"])
+ }
+ return(result)
+}
+
+# average the posterior rates
+# written by Liam Revell 2011
+ave.rates<-function(tree,shift,tips,sig1,sig2,ave.shift,showTree=TRUE){
+ # first split and scale at shift
+ unscaled<-splitTree(tree,shift)
+ # now scale
+ scaled<-unscaled
+ if(length(setdiff(scaled[[1]]$tip.label,tips))!=1){
+ scaled[[1]]$edge.length<-scaled[[1]]$edge.length*sig1
+ scaled[[2]]$edge.length<-scaled[[2]]$edge.length*sig2
+ if(!is.null(scaled[[2]]$root.edge)) scaled[[2]]$root.edge<-scaled[[2]]$root.edge*sig2
+ } else {
+ scaled[[1]]$edge.length<-scaled[[1]]$edge.length*sig2
+ scaled[[2]]$edge.length<-scaled[[2]]$edge.length*sig1
+ if(!is.null(scaled[[2]]$root.edge)) scaled[[2]]$root.edge<-scaled[[2]]$root.edge*sig1
+ }
+ # now bind
+ tr.scaled<-paste.tree(scaled[[1]],scaled[[2]])
+ if(showTree==TRUE) plot(tr.scaled)
+ # now split tr.scaled and tree at ave.shift
+ unscaled<-splitTree(tree,ave.shift)
+ scaled<-splitTree(tr.scaled,ave.shift)
+ # now compute the sig1 and sig2 to return
+ sig1<-sum(scaled[[1]]$edge.length)/sum(unscaled[[1]]$edge.length)
+ sig2<-sum(scaled[[2]]$edge.length)/sum(unscaled[[2]]$edge.length)
+ return(list(sig1=sig1,sig2=sig2))
+}
+
+## a bunch of new S3 methods
+## written by Liam J. Revell 2019
+
+summary.evol.rate.mcmc<-function(object,...){
+ if(hasArg(burnin)) burnin<-list(...)$burnin
+ else {
+ burnin<-round(0.2*max(object$mcmc[,"state"]))
+ cat("\nNo burn-in specified. Excluding the first 20% by default.\n\n")
+ }
+ if(hasArg(method)) method<-list(...)$method
+ else method<-"sumsq"
+ ii<-min(which(object$mcmc[,"state"]>=burnin))
+ mcmc<-object$mcmc[ii:nrow(object$mcmc),]
+ tips<-object$tips[ii:length(object$tips)]
+ tree<-object$tree
+ ms<-minSplit(tree,mcmc,method=method)
+ ps<-posterior.evolrate(tree,ms,mcmc,tips)
+ prob<-(table(factor(ps[,"node"],
+ levels=1:(Ntip(tree)+tree$Nnode)))/
+ nrow(ps))[tree$edge[,2]]
+ result<-list(min.split=ms,posterior.rates=ps,
+ hpd=setNames(list(HPD(ps[,"sig1"]),
+ HPD(ps[,"sig2"])),c("sig1","sig2")),
+ edge.prob=prob,
+ tree=tree,method=method)
+ class(result)<-"summary.evol.rate.mcmc"
+ result
+}
+
+HPD<-function(x){
+ if(.check.pkg("coda")) object<-HPDinterval(as.mcmc(x))
+ else {
+ cat(" HPDinterval requires package coda.\n")
+ cat(" Computing 95% interval from samples only.\n\n")
+ object<-setNames(c(sort(x)[round(0.025*length(x))],
+ sort(x)[round(0.975*length(x))]),c("lower",
+ "upper"))
+ attr(object, "Probability")<-0.95
+ }
+ object
+}
+
+print.summary.evol.rate.mcmc<-function(x,...){
+ if(x$method=="sum")
+ cat("\nThe shift location with the minimum distance to all shifts in the\n")
+ else
+ cat("\nThe shift with the minimum (squared) distance to all shifts in the\n")
+ cat(paste("posterior set is found ",round(x$min.split$bp,4),
+ " along the branch leading to node ",
+ x$min.split$node,".\n",sep=""))
+ cat("\nMean \'root-wise\' rate from the posterior sample (sig1): ")
+ cat(round(mean(x$posterior[,"sig1"]),4))
+ cat(paste("\n 95% HPD for sig1: [",round(x$hpd[["sig1"]][1],4),", ",
+ round(x$hpd[["sig1"]][2],4),"]",sep=""))
+ cat("\nMean \'tip-wise\' rate from the posterior sample (sig2): ")
+ cat(round(mean(x$posterior[,"sig2"]),4))
+ cat(paste("\n 95% HPD for sig1: [",round(x$hpd[["sig2"]][1],4),", ",
+ round(x$hpd[["sig2"]][2],4),"]",sep=""))
+ cat("\n\n")
+ cat("To plot the mean shift point run plot(...,type=\"min.split\") on the object\n")
+ cat("produced by this function.\n\n")
+ cat("To plot the probability of a shift by edge run plot(...,method=\"edge.prob\")\n")
+ cat("on the object produced by this function.\n\n")
+}
+
+HPD<-function(x){
+ if(.check.pkg("coda")) hpd<-HPDinterval(as.mcmc(x))
+ else {
+ cat(" HPDinterval requires package coda.\n")
+ cat(" Computing 95% interval from samples only.\n\n")
+ hpd<-setNames(c(sort(x)[round(0.025*length(x))],
+ sort(x)[round(0.975*length(x))]),c("lower",
+ "upper"))
+ attr(hpd, "Probability")<-0.95
+ }
+ hpd
+}
+
+plot.summary.evol.rate.mcmc<-function(x,...){
+ if(hasArg(method)) method<-list(...)$method
+ else method<-"min.split"
+ if(method=="min.split"){
+ if(hasArg(cex)) cex<-list(...)$cex
+ else cex<-0.5
+ if(hasArg(lwd.split)) lwd.split<-list(...)$lwd.split
+ else lwd.split<-4
+ if(hasArg(col.split)) col.split<-list(...)$col.split
+ else col.split<-"red"
+ if(hasArg(col)) col<-list(...)$col
+ else col<-setNames(c("blue","red"),1:2)
+ if(is.null(names(col))) names(col)<-1:2
+ ii<-which(x$tree$edge[,2]==x$min.split$node)
+ plot(paintSubTree(x$tree,node=x$min.split$node,"2",
+ stem=(x$tree$edge.length[ii]-x$min.split$bp)/
+ x$tree$edge.length[ii]),col,...)
+ pp<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ h<-nodeheight(x$tree,getParent(x$tree,
+ x$min.split$node))+x$min.split$bp
+ lines(rep(h,2),rep(pp$yy[x$min.split$node],2)+
+ cex*c(-1,1),lwd=lwd.split,
+ col=col.split,lend=2)
+ } else if(method=="edge.prob"){
+ if(hasArg(cex)) cex<-list(...)$cex
+ else cex<-0.5
+ if(hasArg(piecol)) piecol<-list(...)$piecol
+ else piecol<-c("darkgrey","white")
+ plotTree(x$tree,...)
+ edgelabels(pie=cbind(x$edge.prob,1-x$edge.prob),
+ cex=cex,piecol=piecol)
+ }
+}
+
+
diff --git a/R/evol.vcv.R b/R/evol.vcv.R
index 9de529c..0fdfefe 100644
--- a/R/evol.vcv.R
+++ b/R/evol.vcv.R
@@ -1,230 +1,230 @@
-# this function fits the model of Revell & Collar (2009; Evolution)
-# written by Liam J. Revell 2010, 2011, 2013, 2014, 2015, 2016, 2020, 2021
-
-evol.vcv<-function(tree,X,maxit=2000,vars=FALSE,...){
-
- ## start checks
-
- if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".")
-
- ## end checks
-
- ## likelihood functions (to be used internally)
-
- # compute the log-likelihood (from the cholesky matrices)
- lik.chol<-function(theta,y,C,D,E){
- m<-length(y)/dim(C[[1]])[1]
- n<-length(y)/m
- p<-length(C)
- cholR<-array(data=0,dim=c(m,m,p))
- l<-1
- for(i in 1:p) for(j in 1:m) for(k in j:m){
- cholR[j,k,i]<-theta[l]
- l<-l+1
- }
- V<-matrix(0,nrow(D),nrow(D))
- for(i in 1:p) V<-V+kronecker(t(cholR[,,i])%*%cholR[,,i],C[[i]])
- V<-V+E
- a<-solve(t(D)%*%solve(V)%*%D)%*%(t(D)%*%solve(V)%*%y)
- logL<--t(y-D%*%a)%*%solve(V)%*%(y-D%*%a)/2-n*m*log(2*pi)/2-
- determinant(V)$modulus[1]/2
- return(-logL)
- }
-
- # compute the log-likelihood (from the original matrices)
- lik.R<-function(theta,y,C,D,E){
- m<-length(y)/nrow(C[[1]])
- n<-length(y)/m
- p<-length(C)
- R<-array(data=0,dim=c(m,m,p)); l<-1
- for(i in 1:p) for(j in 1:m) for(k in j:m){
- R[j,k,i]<-theta[l]
- R[k,j,i]<-theta[l]
- l<-l+1
- }
- V<-matrix(0,nrow(D),nrow(D))
- for(i in 1:p) V<-V+kronecker(R[,,i],C[[i]])
- V<-V+E
- a<-solve(t(D)%*%solve(V)%*%D)%*%(t(D)%*%solve(V)%*%y)
- logL<--t(y-D%*%a)%*%solve(V)%*%(y-D%*%a)/2-n*m*log(2*pi)/2-determinant(V)$modulus[1]/2
- return(-logL)
- }
-
- ## end likelihood functions
-
- ## start preliminaries
-
- if(is.data.frame(X)) X<-as.matrix(X)
- n<-nrow(X) # number of species
- m<-ncol(X) # number of traits
- if(hasArg(err_vcv)){
- err_vcv<-list(...)$err_vcv
- err_vcv<-err_vcv[tree$tip.label]
- } else {
- err_vcv<-replicate(n,matrix(0,m,m),simplify=FALSE)
- names(err_vcv)<-tree$tip.label
- }
- E<-matrix(0,n*m,n*m)
- for(i in 1:n){
- ii<-0:(m-1)*n+i
- E[ii,ii]<-err_vcv[[i]]
- }
- tree1rate<-paintSubTree(tree,Ntip(tree)+1,"fitted")
- tree<-if(inherits(tree,"simmap")) tree else tree1rate
- p<-ncol(tree$mapped.edge) # number of states
- D<-matrix(0,n*m,m)
- for(i in 1:(n*m)) for(j in 1:m) if((j-1)*n<i&&i<=j*n) D[i,j]=1.0
- X<-X[rownames(C<-vcv(tree)),,drop=FALSE]
- y<-as.matrix(as.vector(X))
-
- ## end preliminaries
-
- ## get starting parameter values
-
- a<-colSums(solve(C))%*%X/sum(solve(C)) # ancestral states
- R<-t(X-rep(1,nrow(X))%*%a)%*%solve(C)%*%(X-rep(1,nrow(X))%*%a)/n
-
- ## end starting parameter values
-
- ## start fit single matrix model
-
- C<-multiC(tree1rate)
-
- # populate the starting parameter vector
- ss<-vector(mode="numeric")
- for(i in 1:p) ss<-c(ss,to.upper(chol(R)))
- # optimize using generic optimizer
- r=optim(ss,fn=lik.chol,y=y,C=C,D=D,E=E,control=list(maxit=maxit))
- # update R
- R<-matrix(data=t(upper.diag(r$par[((i-1)*m*(m+1)/2+1):(i*(m*(m+1)/2))]))%*%
- upper.diag(r$par[((i-1)*m*(m+1)/2+1):(i*(m*(m+1)/2))]),m,m,dimnames=list(colnames(X),
- colnames(X)))
- dimnames(R)<-list(rownames(R),colnames(R))
- # log-likelihood for the single model
- logL1<--r$value
- # convert R to a vector
- Rv<-to.upper(R)
- H<-hessian(lik.R,Rv,y=y,C=C,D=D,E=E)
- # convert Hessian diagonal to matrices
- if(vars){
- print(H)
- Vh<-diag(solve(H))
- vars.single<-matrix(data=t(to.symmetric(Vh[((i-1)*m*(m+1)/2+1):(i*(m*(m+1)/2))])),m,m)
- dimnames(vars.single)<-list(rownames(R),colnames(R))
- }
- # report convergence
- convergence<-r$convergence
-
- ## end fitting single matrix model
-
- ## start fit multi-matrix model
-
- if(p>1){
-
- C<-multiC(tree) # compute separate C for each state
-
- # compute the starting parameter values
- ss<-vector(mode="numeric")
- for(i in 1:p) ss<-c(ss,to.upper(chol(R)))
- # optimize using generic optimizer
- r=optim(ss,fn=lik.chol,y=y,C=C,D=D,E=E,control=list(maxit=maxit))
- # convert parameter estimates to matrices
- R.i<-array(dim=c(m,m,p))
- ss<-colnames(tree$mapped.edge)
- for(i in 1:p)
- R.i[,,i]<-matrix(data=t(upper.diag(r$par[((i-1)*m*(m+1)/2+1):(i*(m*(m+1)/2))]))%*%
- upper.diag(r$par[((i-1)*m*(m+1)/2+1):(i*(m*(m+1)/2))]),m,m,dimnames=list(colnames(X),
- colnames(X)))
- dimnames(R.i)<-list(rownames(R),colnames(R),ss)
- # log-likelihood for the multi-matrix model
- logL2<--r$value
-
- # convert R.i to a vector
- Rv<-vector(mode="numeric")
- for(i in 1:p) Rv<-c(Rv,to.upper(R.i[,,i]))
- H<-hessian(lik.R,Rv,y=y,C=C,D=D,E=E)
- # convert Hessian diagonal to matrices
- if(vars){
- Vars<-array(dim=c(m,m,p))
- Vh<-diag(solve(H))
- for(i in 1:p) Vars[,,i]<-matrix(data=t(to.symmetric(Vh[((i-1)*m*(m+1)/2+1):(i*(m*(m+1)/2))])),m,m)
- dimnames(Vars)<-list(rownames(R),colnames(R),ss)
- }
- # report convergence
- convergence[2]==r$convergence
- }
- if(all(convergence==0)) converged<-"Optimization has converged."
- else converged<-"Optimization may not have converged. Consider increasing maxit."
-
- if(p>1){
- if(vars) obj<-list(R.single=R,vars.single=vars.single,logL1=as.numeric(logL1),
- k1=m*(m+1)/2+m,R.multiple=R.i,vars.multiple=Vars,logL.multiple=logL2,
- k2=p*m*(m+1)/2+m,P.chisq=pchisq(2*(logL2-as.numeric(logL1)),(p-1)*m*(m+1)/2,
- lower.tail=FALSE),convergence=converged)
- else obj<-list(R.single=R,logL1=as.numeric(logL1),k1=m*(m+1)/2+m,R.multiple=R.i,
- logL.multiple=logL2,k2=p*m*(m+1)/2+m,P.chisq=pchisq(2*(logL2-as.numeric(logL1)),
- (p-1)*m*(m+1)/2,lower.tail=FALSE),convergence=converged)
- } else {
- if(vars) obj<-list(R.single=R,vars.single=vars.single,logL1=as.numeric(logL1),
- k1=m*(m+1)/2+m,convergence="Optimization has converged.")
- else obj<-list(R.single=R,logL1=as.numeric(logL1),k1=m*(m+1)/2+m,
- convergence="Optimization has converged.")
- }
- class(obj)<-"evol.vcv"
- obj
-}
-
-# function puts the upper triangle of a square matrix in a vector, by row
-# written by Liam J. Revell 2013
-to.upper<-function(X) t(X)[lower.tri(X,diag=TRUE)]
-
-# function puts a vector into the upper triangle of a square matrix, by row
-# written by Liam J. Revell 2013
-upper.diag<-function(x){
- m<-(-1+sqrt(1+8*length(x)))/2
- X<-lower.tri(matrix(NA,m,m),diag=TRUE)
- X[X==TRUE]<-x
- t(X)
-}
-
-# function converts vector to symmetric matrix
-# written by Liam J. Revell 2013
-to.symmetric<-function(x){
- if(length(x)==1) X<-matrix(x,1,1)
- else {
- X<-upper.diag(x)
- for(i in 2:nrow(X)) for(j in 1:(i-1)) X[i,j]<-X[j,i]
- }
- X
-}
-
-## S3 print method for object of class "evol.vcv"
-## written by Liam J. Revell 2013
-print.evol.vcv<-function(x,...){
- if(hasArg(digits)) digits<-list(...)$digits
- else digits<-4
- x<-lapply(x,function(a,b) if(is.numeric(a)) round(a,b) else a,b=digits)
- cat("ML single-matrix model:\n")
- nn<-paste("R[",t(sapply(1:ncol(x$R.single),paste,
- 1:ncol(x$R.single),sep=","))[upper.tri(x$R.single,diag=TRUE)],"]",
- sep="")
- cat(paste("\t",paste(nn,collapse="\t"),"\tk\tlog(L)","\n",sep=""))
- cat(paste("fitted",paste(x$R.single[upper.tri(x$R.single,diag=TRUE)],
- collapse="\t"),x$k1,x$logL1,"\n",sep="\t"))
- cat("\n")
- if(!is.null(x$R.multiple)){
- cat("ML multi-matrix model:\n")
- cat(paste("\t",paste(nn,collapse="\t"),"\tk\tlog(L)","\n",sep=""))
- for(i in 1:dim(x$R.multiple)[3]){
- if(i==1) cat(paste(dimnames(x$R.multiple)[[3]][i],
- paste(x$R.multiple[,,i][upper.tri(x$R.single,diag=TRUE)],
- collapse="\t"),x$k2,x$logL.multiple,"\n",sep="\t"))
- else cat(paste(dimnames(x$R.multiple)[[3]][i],paste(x$R.multiple[,,i][upper.tri(x$R.single,
- diag=TRUE)],collapse="\t"),"\n",sep="\t"))
- }
- cat("\n")
- cat(paste("P-value (based on X^2):",x$P.chisq,"\n\n"))
- }
- if(x$convergence[1]=="Optimization has converged.") cat("R thinks it has found the ML solution.\n\n")
- else cat("Optimization may not have converged.\n\n")
-}
+# this function fits the model of Revell & Collar (2009; Evolution)
+# written by Liam J. Revell 2010, 2011, 2013, 2014, 2015, 2016, 2020, 2021
+
+evol.vcv<-function(tree,X,maxit=2000,vars=FALSE,...){
+
+ ## start checks
+
+ if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".")
+
+ ## end checks
+
+ ## likelihood functions (to be used internally)
+
+ # compute the log-likelihood (from the cholesky matrices)
+ lik.chol<-function(theta,y,C,D,E){
+ m<-length(y)/dim(C[[1]])[1]
+ n<-length(y)/m
+ p<-length(C)
+ cholR<-array(data=0,dim=c(m,m,p))
+ l<-1
+ for(i in 1:p) for(j in 1:m) for(k in j:m){
+ cholR[j,k,i]<-theta[l]
+ l<-l+1
+ }
+ V<-matrix(0,nrow(D),nrow(D))
+ for(i in 1:p) V<-V+kronecker(t(cholR[,,i])%*%cholR[,,i],C[[i]])
+ V<-V+E
+ a<-solve(t(D)%*%solve(V)%*%D)%*%(t(D)%*%solve(V)%*%y)
+ logL<--t(y-D%*%a)%*%solve(V)%*%(y-D%*%a)/2-n*m*log(2*pi)/2-
+ determinant(V)$modulus[1]/2
+ return(-logL)
+ }
+
+ # compute the log-likelihood (from the original matrices)
+ lik.R<-function(theta,y,C,D,E){
+ m<-length(y)/nrow(C[[1]])
+ n<-length(y)/m
+ p<-length(C)
+ R<-array(data=0,dim=c(m,m,p)); l<-1
+ for(i in 1:p) for(j in 1:m) for(k in j:m){
+ R[j,k,i]<-theta[l]
+ R[k,j,i]<-theta[l]
+ l<-l+1
+ }
+ V<-matrix(0,nrow(D),nrow(D))
+ for(i in 1:p) V<-V+kronecker(R[,,i],C[[i]])
+ V<-V+E
+ a<-solve(t(D)%*%solve(V)%*%D)%*%(t(D)%*%solve(V)%*%y)
+ logL<--t(y-D%*%a)%*%solve(V)%*%(y-D%*%a)/2-n*m*log(2*pi)/2-determinant(V)$modulus[1]/2
+ return(-logL)
+ }
+
+ ## end likelihood functions
+
+ ## start preliminaries
+
+ if(is.data.frame(X)) X<-as.matrix(X)
+ n<-nrow(X) # number of species
+ m<-ncol(X) # number of traits
+ if(hasArg(err_vcv)){
+ err_vcv<-list(...)$err_vcv
+ err_vcv<-err_vcv[tree$tip.label]
+ } else {
+ err_vcv<-replicate(n,matrix(0,m,m),simplify=FALSE)
+ names(err_vcv)<-tree$tip.label
+ }
+ E<-matrix(0,n*m,n*m)
+ for(i in 1:n){
+ ii<-0:(m-1)*n+i
+ E[ii,ii]<-err_vcv[[i]]
+ }
+ tree1rate<-paintSubTree(tree,Ntip(tree)+1,"fitted")
+ tree<-if(inherits(tree,"simmap")) tree else tree1rate
+ p<-ncol(tree$mapped.edge) # number of states
+ D<-matrix(0,n*m,m)
+ for(i in 1:(n*m)) for(j in 1:m) if((j-1)*n<i&&i<=j*n) D[i,j]=1.0
+ X<-X[rownames(C<-vcv(tree)),,drop=FALSE]
+ y<-as.matrix(as.vector(X))
+
+ ## end preliminaries
+
+ ## get starting parameter values
+
+ a<-colSums(solve(C))%*%X/sum(solve(C)) # ancestral states
+ R<-t(X-rep(1,nrow(X))%*%a)%*%solve(C)%*%(X-rep(1,nrow(X))%*%a)/n
+
+ ## end starting parameter values
+
+ ## start fit single matrix model
+
+ C<-multiC(tree1rate)
+
+ # populate the starting parameter vector
+ ss<-vector(mode="numeric")
+ for(i in 1:p) ss<-c(ss,to.upper(chol(R)))
+ # optimize using generic optimizer
+ r=optim(ss,fn=lik.chol,y=y,C=C,D=D,E=E,control=list(maxit=maxit))
+ # update R
+ R<-matrix(data=t(upper.diag(r$par[((i-1)*m*(m+1)/2+1):(i*(m*(m+1)/2))]))%*%
+ upper.diag(r$par[((i-1)*m*(m+1)/2+1):(i*(m*(m+1)/2))]),m,m,dimnames=list(colnames(X),
+ colnames(X)))
+ dimnames(R)<-list(rownames(R),colnames(R))
+ # log-likelihood for the single model
+ logL1<--r$value
+ # convert R to a vector
+ Rv<-to.upper(R)
+ H<-hessian(lik.R,Rv,y=y,C=C,D=D,E=E)
+ # convert Hessian diagonal to matrices
+ if(vars){
+ print(H)
+ Vh<-diag(solve(H))
+ vars.single<-matrix(data=t(to.symmetric(Vh[((i-1)*m*(m+1)/2+1):(i*(m*(m+1)/2))])),m,m)
+ dimnames(vars.single)<-list(rownames(R),colnames(R))
+ }
+ # report convergence
+ convergence<-r$convergence
+
+ ## end fitting single matrix model
+
+ ## start fit multi-matrix model
+
+ if(p>1){
+
+ C<-multiC(tree) # compute separate C for each state
+
+ # compute the starting parameter values
+ ss<-vector(mode="numeric")
+ for(i in 1:p) ss<-c(ss,to.upper(chol(R)))
+ # optimize using generic optimizer
+ r=optim(ss,fn=lik.chol,y=y,C=C,D=D,E=E,control=list(maxit=maxit))
+ # convert parameter estimates to matrices
+ R.i<-array(dim=c(m,m,p))
+ ss<-colnames(tree$mapped.edge)
+ for(i in 1:p)
+ R.i[,,i]<-matrix(data=t(upper.diag(r$par[((i-1)*m*(m+1)/2+1):(i*(m*(m+1)/2))]))%*%
+ upper.diag(r$par[((i-1)*m*(m+1)/2+1):(i*(m*(m+1)/2))]),m,m,dimnames=list(colnames(X),
+ colnames(X)))
+ dimnames(R.i)<-list(rownames(R),colnames(R),ss)
+ # log-likelihood for the multi-matrix model
+ logL2<--r$value
+
+ # convert R.i to a vector
+ Rv<-vector(mode="numeric")
+ for(i in 1:p) Rv<-c(Rv,to.upper(R.i[,,i]))
+ H<-hessian(lik.R,Rv,y=y,C=C,D=D,E=E)
+ # convert Hessian diagonal to matrices
+ if(vars){
+ Vars<-array(dim=c(m,m,p))
+ Vh<-diag(solve(H))
+ for(i in 1:p) Vars[,,i]<-matrix(data=t(to.symmetric(Vh[((i-1)*m*(m+1)/2+1):(i*(m*(m+1)/2))])),m,m)
+ dimnames(Vars)<-list(rownames(R),colnames(R),ss)
+ }
+ # report convergence
+ convergence[2]==r$convergence
+ }
+ if(all(convergence==0)) converged<-"Optimization has converged."
+ else converged<-"Optimization may not have converged. Consider increasing maxit."
+
+ if(p>1){
+ if(vars) obj<-list(R.single=R,vars.single=vars.single,logL1=as.numeric(logL1),
+ k1=m*(m+1)/2+m,R.multiple=R.i,vars.multiple=Vars,logL.multiple=logL2,
+ k2=p*m*(m+1)/2+m,P.chisq=pchisq(2*(logL2-as.numeric(logL1)),(p-1)*m*(m+1)/2,
+ lower.tail=FALSE),convergence=converged)
+ else obj<-list(R.single=R,logL1=as.numeric(logL1),k1=m*(m+1)/2+m,R.multiple=R.i,
+ logL.multiple=logL2,k2=p*m*(m+1)/2+m,P.chisq=pchisq(2*(logL2-as.numeric(logL1)),
+ (p-1)*m*(m+1)/2,lower.tail=FALSE),convergence=converged)
+ } else {
+ if(vars) obj<-list(R.single=R,vars.single=vars.single,logL1=as.numeric(logL1),
+ k1=m*(m+1)/2+m,convergence="Optimization has converged.")
+ else obj<-list(R.single=R,logL1=as.numeric(logL1),k1=m*(m+1)/2+m,
+ convergence="Optimization has converged.")
+ }
+ class(obj)<-"evol.vcv"
+ obj
+}
+
+# function puts the upper triangle of a square matrix in a vector, by row
+# written by Liam J. Revell 2013
+to.upper<-function(X) t(X)[lower.tri(X,diag=TRUE)]
+
+# function puts a vector into the upper triangle of a square matrix, by row
+# written by Liam J. Revell 2013
+upper.diag<-function(x){
+ m<-(-1+sqrt(1+8*length(x)))/2
+ X<-lower.tri(matrix(NA,m,m),diag=TRUE)
+ X[X==TRUE]<-x
+ t(X)
+}
+
+# function converts vector to symmetric matrix
+# written by Liam J. Revell 2013
+to.symmetric<-function(x){
+ if(length(x)==1) X<-matrix(x,1,1)
+ else {
+ X<-upper.diag(x)
+ for(i in 2:nrow(X)) for(j in 1:(i-1)) X[i,j]<-X[j,i]
+ }
+ X
+}
+
+## S3 print method for object of class "evol.vcv"
+## written by Liam J. Revell 2013
+print.evol.vcv<-function(x,...){
+ if(hasArg(digits)) digits<-list(...)$digits
+ else digits<-4
+ x<-lapply(x,function(a,b) if(is.numeric(a)) round(a,b) else a,b=digits)
+ cat("ML single-matrix model:\n")
+ nn<-paste("R[",t(sapply(1:ncol(x$R.single),paste,
+ 1:ncol(x$R.single),sep=","))[upper.tri(x$R.single,diag=TRUE)],"]",
+ sep="")
+ cat(paste("\t",paste(nn,collapse="\t"),"\tk\tlog(L)","\n",sep=""))
+ cat(paste("fitted",paste(x$R.single[upper.tri(x$R.single,diag=TRUE)],
+ collapse="\t"),x$k1,x$logL1,"\n",sep="\t"))
+ cat("\n")
+ if(!is.null(x$R.multiple)){
+ cat("ML multi-matrix model:\n")
+ cat(paste("\t",paste(nn,collapse="\t"),"\tk\tlog(L)","\n",sep=""))
+ for(i in 1:dim(x$R.multiple)[3]){
+ if(i==1) cat(paste(dimnames(x$R.multiple)[[3]][i],
+ paste(x$R.multiple[,,i][upper.tri(x$R.single,diag=TRUE)],
+ collapse="\t"),x$k2,x$logL.multiple,"\n",sep="\t"))
+ else cat(paste(dimnames(x$R.multiple)[[3]][i],paste(x$R.multiple[,,i][upper.tri(x$R.single,
+ diag=TRUE)],collapse="\t"),"\n",sep="\t"))
+ }
+ cat("\n")
+ cat(paste("P-value (based on X^2):",x$P.chisq,"\n\n"))
+ }
+ if(x$convergence[1]=="Optimization has converged.") cat("R thinks it has found the ML solution.\n\n")
+ else cat("Optimization may not have converged.\n\n")
+}
diff --git a/R/evolvcv.lite.R b/R/evolvcv.lite.R
index 78554b2..be198ea 100644
--- a/R/evolvcv.lite.R
+++ b/R/evolvcv.lite.R
@@ -1,675 +1,675 @@
-## function is simplified version of evol.vcv
-## written by Liam J. Revell 2011, 2012, 2013, 2017, 2019, 2020, 2021, 2022
-
-anova.evolvcv.lite<-function(object,...){
- models<-paste("model",sapply(strsplit(names(object),"model"),
- function(x) x[2]))
- logL<-sapply(object,function(x) x$logLik)
- df<-sapply(object,function(x) x$k)
- AIC<-sapply(object,function(x) x$AIC)
- value<-data.frame(logL=logL,df=df,AIC=AIC,weight=unclass(aic.w(AIC)))
- rownames(value)<-models
- colnames(value)<-c("log(L)","d.f.","AIC","weight")
- print(value)
- invisible(value)
-}
-
-evolvcv.lite<-function(tree,X,maxit=2000,tol=1e-10,...){
- ## check 'phylo' object
- if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".")
- ## get some optional arguments
- if(hasArg(models)) models<-list(...)$models
- else models<-as.character(1:4)
- if(models[1]=="all models") models<-c("1","2","2b","2c","3","3b","3c","4")
- models<-as.character(models)
- if(hasArg(try.iter)) try.iter<-list(...)$try.iter
- else try.iter<-10
- if(hasArg(lower)){
- lower<-list(...)$lower
- if(length(lower)==1) lower<-c(rep(lower,2),-1)
- if(length(lower)>3) lower<-lower[1:3]
- } else lower<-NULL
- if(hasArg(upper)){
- upper<-list(...)$upper
- if(length(upper)==1) upper<-c(rep(upper,2),1)
- if(length(upper)>3) upper<-upper[1:3]
- } else upper<-NULL
-
- if(!inherits(tree,"simmap")) models<-intersect("1",models)
-
- if(length(models)==0) stop("for models!=\"1\" tree must be an object of class \"simmap\".")
-
- # model 1: common variances & correlation
- lik1<-function(theta,C,D,y,E){
- v<-exp(theta[1:2])
- r<-theta[3]
- R<-matrix(c(v[1],r*sqrt(v[1]*v[2]),r*sqrt(v[1]*v[2]),
- v[2]),2,2)
- V<-kronecker(R,C)+E
- a<-solve(t(D)%*%solve(V)%*%D)%*%(t(D)%*%solve(V)%*%y)
- logL<--t(y-D%*%a)%*%solve(V)%*%(y-D%*%a)/2-
- n*m*log(2*pi)/2-determinant(V)$modulus[1]/2
- return(-logL)
- }
-
- # model 2: different variances, same correlation
- lik2<-function(theta,C,D,y,E){
- p<-(length(theta)-1)/2
- v<-matrix(exp(theta[1:(2*p)]),p,2,byrow=T)
- r<-theta[length(theta)]
- R<-list()
- for(i in 1:p) R[[i]]<-matrix(c(v[i,1],r*sqrt(v[i,1]*v[i,2]),
- r*sqrt(v[i,1]*v[i,2]),v[i,2]),2,2)
- V<-matrix(0,length(y),length(y))
- for(i in 1:p) V<-V+kronecker(R[[i]],C[[i]])
- V<-V+E
- a<-solve(t(D)%*%solve(V)%*%D)%*%(t(D)%*%solve(V)%*%y)
- logL<--t(y-D%*%a)%*%solve(V)%*%(y-D%*%a)/2-n*m*log(2*pi)/2-
- determinant(V)$modulus[1]/2
- return(-logL)
- }
-
- ## model 2b: different variances for only trait 1, same correlation
- lik2b<-function(theta,C,D,y,E){
- p<-length(theta)-2
- v<-matrix(exp(c(theta[1:p],rep(theta[p+1],p))),p,2,byrow=FALSE)
- r<-theta[length(theta)]
- R<-list()
- for(i in 1:p) R[[i]]<-matrix(c(v[i,1],r*sqrt(v[i,1]*v[i,2]),
- r*sqrt(v[i,1]*v[i,2]),v[i,2]),2,2)
- V<-matrix(0,length(y),length(y))
- for(i in 1:p) V<-V+kronecker(R[[i]],C[[i]])
- V<-V+E
- a<-solve(t(D)%*%solve(V)%*%D)%*%(t(D)%*%solve(V)%*%y)
- logL<--t(y-D%*%a)%*%solve(V)%*%(y-D%*%a)/2-n*m*log(2*pi)/2-
- determinant(V)$modulus[1]/2
- return(-logL)
- }
-
- ## model 2c: different variances for only trait 2, same correlation
- lik2c<-function(theta,C,D,y,E){
- p<-length(theta)-2
- v<-matrix(exp(c(rep(theta[1],p),theta[1:p+1])),p,2,byrow=FALSE)
- r<-theta[length(theta)]
- R<-list()
- for(i in 1:p) R[[i]]<-matrix(c(v[i,1],r*sqrt(v[i,1]*v[i,2]),
- r*sqrt(v[i,1]*v[i,2]),v[i,2]),2,2)
- V<-matrix(0,length(y),length(y))
- for(i in 1:p) V<-V+kronecker(R[[i]],C[[i]])
- V<-V+E
- a<-solve(t(D)%*%solve(V)%*%D)%*%(t(D)%*%solve(V)%*%y)
- logL<--t(y-D%*%a)%*%solve(V)%*%(y-D%*%a)/2-n*m*log(2*pi)/2-
- determinant(V)$modulus[1]/2
- return(-logL)
- }
-
- # model 3: same variances, different correlations
- lik3<-function(theta,C,D,y,E){
- p<-length(theta)-2
- v<-exp(theta[1:2])
- r<-theta[3:length(theta)]
- R<-list()
- for(i in 1:p) R[[i]]<-matrix(c(v[1],r[i]*sqrt(v[1]*v[2]),
- r[i]*sqrt(v[1]*v[2]),v[2]),2,2)
- V<-matrix(0,length(y),length(y))
- for(i in 1:p) V<-V+kronecker(R[[i]],C[[i]])
- V<-V+E
- a<-solve(t(D)%*%solve(V)%*%D)%*%(t(D)%*%solve(V)%*%y)
- logL<--t(y-D%*%a)%*%solve(V)%*%(y-D%*%a)/2-n*m*log(2*pi)/2-
- determinant(V)$modulus[1]/2
- return(-logL)
- }
-
- # model 3b: different variances for only trait 1, different correlation
- lik3b<-function(theta,C,D,y,E){
- p<-(length(theta)-1)/2
- v<-matrix(exp(c(theta[1:p],rep(theta[p+1],p))),p,2,byrow=FALSE)
- r<-theta[1:p+(p+1)]
- R<-list()
- for(i in 1:p) R[[i]]<-matrix(c(v[i,1],r[i]*sqrt(v[i,1]*v[i,2]),
- r[i]*sqrt(v[i,1]*v[i,2]),v[i,2]),2,2)
- V<-matrix(0,length(y),length(y))
- for(i in 1:p) V<-V+kronecker(R[[i]],C[[i]])
- V<-V+E
- a<-solve(t(D)%*%solve(V)%*%D)%*%(t(D)%*%solve(V)%*%y)
- logL<--t(y-D%*%a)%*%solve(V)%*%(y-D%*%a)/2-n*m*log(2*pi)/2-
- determinant(V)$modulus[1]/2
- return(-logL)
- }
-
- # model 3c: different variances for only trait 2, different correlations
- lik3c<-function(theta,C,D,y,E){
- p<-(length(theta)-1)/2
- v<-matrix(exp(c(rep(theta[1],p),theta[1:p+1])),p,2,byrow=FALSE)
- r<-theta[1:p+(p+1)]
- R<-list()
- for(i in 1:p) R[[i]]<-matrix(c(v[i,1],r[i]*sqrt(v[i,1]*v[i,2]),
- r[i]*sqrt(v[i,1]*v[i,2]),v[i,2]),2,2)
- V<-matrix(0,length(y),length(y))
- for(i in 1:p) V<-V+kronecker(R[[i]],C[[i]])
- V<-V+E
- a<-solve(t(D)%*%solve(V)%*%D)%*%(t(D)%*%solve(V)%*%y)
- logL<--t(y-D%*%a)%*%solve(V)%*%(y-D%*%a)/2-n*m*log(2*pi)/2-
- determinant(V)$modulus[1]/2
- return(-logL)
- }
-
- # model 4: everything different
- lik4<-function(theta,C,D,y,E){
- p<-length(theta)/3
- v<-matrix(exp(theta[1:(2*p)]),p,2,byrow=TRUE)
- r<-theta[(2*p+1):length(theta)]
- R<-list()
- for(i in 1:p) R[[i]]<-matrix(c(v[i,1],r[i]*sqrt(v[i,1]*v[i,2]),
- r[i]*sqrt(v[i,1]*v[i,2]),v[i,2]),2,2)
- V<-matrix(0,length(y),length(y))
- for(i in 1:p) V<-V+kronecker(R[[i]],C[[i]])
- V<-V+E
- a<-solve(t(D)%*%solve(V)%*%D)%*%(t(D)%*%solve(V)%*%y)
- logL<--t(y-D%*%a)%*%solve(V)%*%(y-D%*%a)/2-n*m*log(2*pi)/2-
- determinant(V)$modulus[1]/2
- return(-logL)
- }
-
- # done internal functions
-
- # bookkeeping
- X<-as.matrix(X)
- X<-X[tree$tip.label,]
- n<-nrow(X) # number of species
- m<-ncol(X) # number of traits
- if(m!=2) stop("number of traits must equal 2")
-
- ## get error covariance matrices
- if(hasArg(err_vcv)){
- err_vcv<-list(...)$err_vcv
- err_vcv<-err_vcv[tree$tip.label]
- } else {
- err_vcv<-replicate(n,matrix(0,m,m),simplify=FALSE)
- names(err_vcv)<-tree$tip.label
- }
- E<-matrix(0,n*m,n*m)
- for(i in 1:n){
- ii<-0:(m-1)*n+i
- E[ii,ii]<-err_vcv[[i]]
- }
- ## end get error covariances
-
- ## more bookkeeping
- p<-if(inherits(tree,"simmap")) ncol(tree$mapped.edge) else 1 # number of states
- D<-matrix(0,n*m,m)
- for(i in 1:(n*m)) for(j in 1:m)
- if((j-1)*n<i&&i<=j*n) D[i,j]=1.0
- y<-as.matrix(as.vector(X))
- if(inherits(tree,"simmap")){
- mC<-multiC(tree)
- C<-Reduce("+",mC)
- } else C<-vcv.phylo(tree)
- sv1<-mean(pic(X[,1],multi2di(as.phylo(tree)))^2)
- sv2<-mean(pic(X[,2],multi2di(as.phylo(tree)))^2)
- sr<-mean(pic(X[,1],tree)*pic(X[,2],tree))/sqrt(sv1*sv2)
- if(is.null(lower)) lower<-c(log(0.1*c(sv1,sv2)),-1)
- if(is.null(upper)) upper<-c(log(10*c(sv1,sv2)),1)
-
- object<-list()
- class(object)<-"evolvcv.lite"
-
- loglik_model1<-if(hasArg(err_vcv))
- evol.vcv(as.phylo(tree),X,err_vcv=err_vcv)$logL1 else
- evol.vcv(as.phylo(tree),X)$logL1
-
- # now optimize models
- msg<-function(text){
- cat(text)
- flush.console()
- }
- if("1"%in%models){
- msg("Fitting model 1: common rates, common correlation...\n")
- res1<-list()
- res1$convergence<-99
- class(res1)<-"try-error"
- iter<-0
- best<--loglik_model1+tol
- LOWER<-lower
- UPPER<-upper
- while((inherits(res1,"try-error")||res1$convergence!=0)&&iter<try.iter){
- init<-c(rnorm(n=2)*log(c(sv1,sv2)),runif(n=1,-1,1))
- res1<-try(optim(init,lik1,C=C,D=D,y=y,E=E,
- method="L-BFGS-B",lower=LOWER+tol,
- upper=UPPER-tol))
- if(inherits(res1,"try-error")){
- res1<-list()
- res1$convergence<-99
- class(res1)<-"try-error"
- res1$value<-best+tol
- }
- if(res1$value>best){
- if(res1$convergence==0) res1$convergence<-99
- } else best<-res1$value
- iter<-iter+1
- }
- if(inherits(res1,"try-error")){
- m1<-list(description="common rates, common correlation",
- R=matrix(NA,p,p),logLik=NA,k=5,AIC=NA)
- } else {
- if(any(res1$par<(LOWER+2*tol))||any(res1$par>(UPPER-2*tol)))
- res1$convergence<-77
- res1$par[1:2]<-exp(res1$par[1:2])
- m1<-list(description="common rates, common correlation",
- R=matrix(c(res1$par[1],res1$par[3]*sqrt(res1$par[1]*res1$par[2]),
- res1$par[3]*sqrt(res1$par[1]*res1$par[2]),res1$par[2]),2,2),
- logLik=-res1$value,
- convergence=res1$convergence,
- k=length(res1$par)+2,
- AIC=2*(length(res1$par)+2)+2*res1$value)
- }
- object$model1=m1
- msg(paste("Best log(L) from model 1: ",round(m1$logLik,4),".\n",sep=""))
- } else m1<-NULL
- makeError<-function(description,names,p,k){
- list(description=description,
- R=setNames(replicate(p,matrix(NA,2,2),simplify=FALSE),names),
- logLik=NA,
- convergence=99,
- k=k,
- AIC=NA)
- }
- if("2"%in%models){
- msg("Fitting model 2: different rates, common correlation...\n")
- res2<-list()
- res2$convergence<-99
- class(res2)<-"try-error"
- iter<-0
- best<-if(is.null(m1)) -loglik_model1+tol else
- -m1$logLik
- LOWER<-c(rep(lower[1:2],p),lower[3])
- UPPER<-c(rep(upper[1:2],p),upper[3])
- while((inherits(res2,"try-error")||res2$convergence!=0)&&iter<try.iter){
- init<-c(rnorm(n=2*p)*log(c(sv1,sv2)),runif(n=1,-1,1))
- res2<-try(optim(init,lik2,C=mC,
- D=D,y=y,E=E,method="L-BFGS-B",
- lower=tol+LOWER,upper=UPPER-tol))
- if(inherits(res2,"try-error")){
- res2<-list()
- res2$convergence<-99
- class(res2)<-"try-error"
- res2$value<-best+tol
- }
- if(res2$value>best){
- if(res2$convergence==0) res2$convergence<-99
- } else best<-res2$value
- iter<-iter+1
- }
- if(inherits(res2,"try-error")){
- m2<-makeError("different rates, common correlation",
- colnames(tree$mapped.edge),
- ncol(tree$mapped.edge),
- 2*ncol(tree$mapped.edge)+1)
- } else {
- if(any(res2$par<(LOWER+2*tol))||any(res2$par>(UPPER-2*tol)))
- res2$convergence<-77
- R<-list()
- res2$par[1:(2*p)]<-exp(res2$par[1:(2*p)])
- for(i in 1:p) R[[i]]<-matrix(c(res2$par[2*(i-1)+1],
- rep(res2$par[2*p+1]*sqrt(res2$par[2*(i-1)+1]*res2$par[2*(i-1)+2]),2),
- res2$par[2*(i-1)+2]),2,2)
- names(R)<-colnames(tree$mapped.edge)
- m2<-list(description="different rates, common correlation",
- R=R,
- logLik=-res2$value,
- convergence=res2$convergence,
- k=length(res2$par)+2,
- AIC=2*(length(res2$par)+2)+2*res2$value)
- }
- object$model2<-m2
- msg(paste("Best log(L) from model 2: ",round(m2$logLik,4),".\n",sep=""))
- }
- if("2b"%in%models){
- msg("Fitting model 2b: different rates (trait 1), common correlation...\n")
- res2b<-list()
- res2b$convergence<-99
- class(res2b)<-"try-error"
- iter<-0
- best<-if(is.null(m1)) -loglik_model1+tol else
- (-m1$logLik)
- LOWER<-c(rep(lower[1],p),lower[2],lower[3])
- UPPER<-c(rep(upper[1],p),upper[2],upper[3])
- while((inherits(res2b,"try-error")||res2b$convergence!=0)&&iter<try.iter){
- init<-c(rnorm(n=p+1)*log(c(rep(sv1,p),sv2)),runif(n=1,-1,1))
- res2b<-try(optim(init,lik2b,C=mC,
- D=D,y=y,E=E,method="L-BFGS-B",
- lower=LOWER+tol,upper=UPPER-tol))
- if(inherits(res2b,"try-error")){
- res2b<-list()
- res2b$convergence<-99
- class(res2b)<-"try-error"
- res2b$value<-best+tol
- }
- if(res2b$value>best){
- if(res2b$convergence==0) res2b$convergence<-99
- } else best<-res2b$value
- iter<-iter+1
- }
- if(inherits(res2b,"try-error")){
- m2b<-makeError("different rates (trait 1), common correlation",
- colnames(tree$mapped.edge),
- ncol(tree$mapped.edge),
- 2*ncol(tree$mapped.edge)+2)
- } else {
- if(any(res2b$par<(LOWER+2*tol))||any(res2b$par>(UPPER-2*tol)))
- res2b$convergence<-77
- R<-list()
- res2b$par[1:(p+1)]<-exp(res2b$par[1:(p+1)])
- for(i in 1:p) R[[i]]<-matrix(c(res2b$par[i],
- rep(res2b$par[p+2]*sqrt(res2b$par[i]*res2b$par[p+1]),2),
- res2b$par[p+1]),2,2)
- names(R)<-colnames(tree$mapped.edge)
- m2b<-list(description="different rates (trait 1), common correlation",
- R=R,
- logLik=-res2b$value,
- convergence=res2b$convergence,
- k=length(res2b$par)+2,
- AIC=2*(length(res2b$par)+2)+2*res2b$value)
- }
- object$model2b<-m2b
- msg(paste("Best log(L) from model 2b: ",round(m2b$logLik,4),".\n",sep=""))
- }
- if("2c"%in%models){
- msg("Fitting model 2c: different rates (trait 2), common correlation...\n")
- res2c<-list()
- res2c$convergence<-99
- class(res2c)<-"try-error"
- iter<-0
- best<-if(is.null(m1)) -loglik_model1+tol else
- (-m1$logLik)
- LOWER<-c(lower[1],rep(lower[2],p),lower[3])
- UPPER<-c(upper[1],rep(upper[2],p),upper[3])
- while((inherits(res2c,"try-error")||res2c$convergence!=0)&&iter<try.iter){
- init<-c(rnorm(n=p+1)*log(c(sv1,rep(sv2,p))),runif(n=1,-1,1))
- res2c<-try(optim(init,lik2c,C=mC,
- D=D,y=y,E=E,method="L-BFGS-B",
- lower=LOWER+tol,upper=UPPER-tol))
- if(inherits(res2c,"try-error")){
- res2c<-list()
- res2c$convergence<-99
- class(res2c)<-"try-error"
- res2c$value<-best+tol
- }
- if(res2c$value>best){
- if(res2c$convergence==0) res2c$convergence<-99
- } else best<-res2c$value
- iter<-iter+1
- }
- if(inherits(res2c,"try-error")){
- m2c<-makeError("different rates (trait 2), common correlation",
- colnames(tree$mapped.edge),
- ncol(tree$mapped.edge),
- 2*ncol(tree$mapped.edge)+2)
- } else {
- if(any(res2c$par<(LOWER+2*tol))||any(res2c$par>(UPPER-2*tol)))
- res2c$convergence<-77
- R<-list()
- res2c$par[1:(p+1)]<-exp(res2c$par[1:(p+1)])
- for(i in 1:p) R[[i]]<-matrix(c(res2c$par[1],
- rep(res2c$par[p+2]*sqrt(res2c$par[1]*res2c$par[i+1]),2),
- res2c$par[i+1]),2,2)
- names(R)<-colnames(tree$mapped.edge)
- m2c<-list(description="different rates (trait 2), common correlation",
- R=R,
- logLik=-res2c$value,
- convergence=res2c$convergence,
- k=length(res2c$par)+2,
- AIC=2*(length(res2c$par)+2)+2*res2c$value)
- }
- object$model2c<-m2c
- msg(paste("Best log(L) from model 2c: ",round(m2c$logLik,4),".\n",sep=""))
- }
- if("3"%in%models){
- msg("Fitting model 3: common rates, different correlation...\n")
- res3<-list()
- res3$convergence<-99
- class(res3)<-"try-error"
- iter<-0
- best<-if(is.null(m1)) -loglik_model1+tol else
- (-m1$logLik)
- LOWER<-c(lower[1],lower[2],rep(lower[3],p))
- UPPER<-c(upper[1],upper[2],rep(upper[3],p))
- while((inherits(res3,"try-error")||res3$convergence!=0)&&iter<try.iter){
- init<-c(rnorm(n=2)*log(c(sv1,sv2)),runif(n=p,-1,1))
- res3<-try(optim(init,lik3,C=mC,D=D,
- y=y,E=E,method="L-BFGS-B",lower=tol+LOWER,
- upper=UPPER-tol))
- if(inherits(res3,"try-error")){
- res3<-list()
- res3$convergence<-99
- class(res3)<-"try-error"
- res3$value<-best+tol
- }
- if(res3$value>best){
- if(res3$convergence==0) res3$convergence<-99
- } else best<-res3$value
- iter<-iter+1
- }
- if(inherits(res3,"try-error")){
- m3<-makeError("common rates, different correlation",
- colnames(tree$mapped.edge),
- ncol(tree$mapped.edge),
- ncol(tree$mapped.edge)+2)
- } else {
- if(any(res3$par<(LOWER+2*tol))||any(res3$par>(UPPER-2*tol)))
- res3$convergence<-77
- R<-list()
- res3$par[1:2]<-exp(res3$par[1:2])
- for(i in 1:p) R[[i]]<-matrix(c(res3$par[1],
- rep(res3$par[2+i]*sqrt(res3$par[1]*res3$par[2]),2),res3$par[2]),2,2)
- names(R)<-colnames(tree$mapped.edge)
- m3<-list(description="common rates, different correlation",
- R=R,
- logLik=-res3$value,
- convergence=res3$convergence,
- k=length(res3$par)+2,
- AIC=2*(length(res3$par)+2)+2*res3$value)
- }
- object$model3<-m3
- msg(paste("Best log(L) from model 3: ",round(m3$logLik,4),".\n",sep=""))
- }
- if("3b"%in%models){
- msg("Fitting model 3b: different rates (trait 1), different correlation...\n")
- res3b<-list()
- res3b$convergence<-99
- class(res3b)<-"try-error"
- iter<-0
- best<-if(is.null(m1)) -loglik_model1+tol else
- (-m1$logLik)
- LOWER<-c(rep(lower[1],p),lower[2],rep(lower[3],p))
- UPPER<-c(rep(upper[1],p),upper[2],rep(upper[3],p))
- while((inherits(res3b,"try-error")||res3b$convergence!=0)&&iter<try.iter){
- init<-c(rnorm(n=p+1)*log(c(rep(sv1,p),sv2)),runif(n=p,-1,1))
- res3b<-try(optim(init,lik3b,C=mC,
- D=D,y=y,E=E,method="L-BFGS-B",
- lower=LOWER+tol,upper=UPPER-tol))
- if(inherits(res3b,"try-error")){
- res3b<-list()
- res3b$convergence<-99
- class(res3b)<-"try-error"
- res3b$value<-best+tol
- }
- if(res3b$value>best){
- if(res3b$convergence==0) res3b$convergence<-99
- } else best<-res3b$value
- iter<-iter+1
- }
- if(inherits(res3b,"try-error")){
- m3b<-makeError("different rates (trait 1), different correlation",
- colnames(tree$mapped.edge),
- ncol(tree$mapped.edge),
- 2*ncol(tree$mapped.edge)+1)
- } else {
- if(any(res3b$par<(LOWER+2*tol))||any(res3b$par>(UPPER-2*tol)))
- res3b$convergence<-77
- R<-list()
- res3b$par[1:(p+1)]<-exp(res3b$par[1:(p+1)])
- for(i in 1:p) R[[i]]<-matrix(c(res3b$par[i],
- rep(res3b$par[p+1+i]*sqrt(res3b$par[i]*res3b$par[p+1]),2),
- res3b$par[p+1]),2,2)
- names(R)<-colnames(tree$mapped.edge)
- m3b<-list(description="different rates (trait 1), different correlation",
- R=R,
- logLik=-res3b$value,
- convergence=res3b$convergence,
- k=length(res3b$par)+2,
- AIC=2*(length(res3b$par)+2)+2*res3b$value)
- }
- object$model3b<-m3b
- msg(paste("Best log(L) from model 3b: ",round(m3b$logLik,4),".\n",sep=""))
- }
- if("3c"%in%models){
- msg("Fitting model 3c: different rates (trait 2), different correlation...\n")
- res3c<-list()
- res3c$convergence<-99
- class(res3c)<-"try-error"
- iter<-0
- best<-if(is.null(m1)) -loglik_model1+tol else
- (-m1$logLik)
- LOWER<-c(lower[1],rep(lower[2],p),rep(lower[3],p))
- UPPER<-c(upper[1],rep(upper[2],p),rep(upper[3],p))
- while((inherits(res3c,"try-error")||res3c$convergence!=0)&&iter<try.iter){
- init<-c(rnorm(n=p+1)*log(c(sv1,rep(sv2,p))),runif(n=p,-1,1))
- res3c<-try(optim(init,lik3c,C=mC,
- D=D,y=y,E=E,method="L-BFGS-B",
- lower=LOWER+tol,upper=UPPER-tol))
- if(inherits(res3c,"try-error")){
- res3c<-list()
- res3c$convergence<-99
- class(res3c)<-"try-error"
- res3c$value<-best+tol
- }
- if(res3c$value>best){
- if(res3c$convergence==0) res3c$convergence<-99
- } else best<-res3c$value
- iter<-iter+1
- }
- if(inherits(res3c,"try-error")){
- m3c<-makeError("different rates (trait 2), different correlation",
- colnames(tree$mapped.edge),
- ncol(tree$mapped.edge),
- 2*ncol(tree$mapped.edge)+1)
- } else {
- if(any(res3c$par<(LOWER+2*tol))||any(res3c$par>(UPPER-2*tol)))
- res3c$convergence<-77
- R<-list()
- res3c$par[1:(p+1)]<-exp(res3c$par[1:(p+1)])
- for(i in 1:p) R[[i]]<-matrix(c(res3c$par[1],
- rep(res3c$par[p+1+i]*sqrt(res3c$par[1]*res3c$par[1+i]),2),
- res3c$par[1+i]),2,2)
- names(R)<-colnames(tree$mapped.edge)
- m3c<-list(description="different rates (trait 2), different correlation",
- R=R,
- logLik=-res3c$value,
- convergence=res3c$convergence,
- k=length(res3c$par)+2,
- AIC=2*(length(res3c$par)+2)+2*res3c$value)
- }
- object$model3c<-m3c
- msg(paste("Best log(L) from model 3c: ",round(m3c$logLik,4),".\n",sep=""))
- }
- if("4"%in%models){
- msg("Fitting model 4: no common structure...\n")
- res4<-list()
- res4$convergence<-99
- class(res4)<-"try-error"
- iter<-0
- best<-if(is.null(m1)) -loglik_model1+tol else
- (-m1$logLik)
- LOWER<-c(rep(lower[1:2],p),rep(lower[3],p))
- UPPER<-c(rep(upper[1:2],p),rep(upper[3],p))
- while((inherits(res4,"try-error")||res4$convergence!=0)&&iter<try.iter){
- init<-c(rnorm(n=2*p)*log(rep(c(sv1,sv2),p)),runif(n=p,-1,1))
- res4<-try(optim(init,lik4,C=mC,
- D=D,y=y,E=E,method="L-BFGS-B",lower=LOWER+tol,
- upper=UPPER-tol))
- if(inherits(res4,"try-error")){
- res4<-list()
- res4$convergence<-99
- class(res4)<-"try-error"
- res4$value<-best+tol
- }
- if(res4$value>best){
- if(res4$convergence==0) res4$convergence<-99
- } else best<-res4$value
- iter<-iter+1
- }
- if(inherits(res4,"try-error")){
- m4<-makeError("no common structure",
- colnames(tree$mapped.edge),
- ncol(tree$mapped.edge),
- 3*ncol(tree$mapped.edge)+2)
- } else {
- if(any(res4$par<(LOWER+2*tol))||any(res4$par>(UPPER-2*tol)))
- res4$convergence<-77
- R<-list()
- res4$par[1:(2*p)]<-exp(res4$par[1:(2*p)])
- for(i in 1:p) R[[i]]<-matrix(c(res4$par[2*(i-1)+1],
- rep(res4$par[2*p+i]*sqrt(res4$par[2*(i-1)+1]*res4$par[2*(i-1)+2]),
- 2),res4$par[2*(i-1)+2]),2,2)
- names(R)<-colnames(tree$mapped.edge)
- m4<-list(description="no common structure",
- R=R,
- logLik=-res4$value,
- convergence=res4$convergence,
- k=length(res4$par)+2,
- AIC=2*(length(res4$par)+2)+2*res4$value)
- }
- object$model4<-m4
- msg(paste("Best log(L) from model 4: ",round(m4$logLik,4),".\n",sep=""))
- }
- object
-}
-
-## S3 print method for object of class "evolvcv.lite"
-## written by Liam J. Revell 2017, 2019, 2021
-print.evolvcv.lite<-function(x,...){
- if(hasArg(digits)) digits<-list(...)$digits
- else digits<-4
-
- if(!is.null(x$model1)){
- nn<-paste("R[",t(sapply(1:ncol(x$model1$R),paste,
- 1:ncol(x$model1$R),sep=","))[upper.tri(x$model1$R,
- diag=TRUE)],"]",sep="")
- ## MODEL 1
- m1<-lapply(x$model1,function(a,b) if(is.numeric(a)) round(a,b) else a,b=digits)
- cat(paste("Model 1:",x$model1$description,"\n"))
- cat(paste("\t",paste(nn,collapse="\t"),"\tk\tlog(L)\tAIC","\n",sep=""))
- cat(paste("fitted",paste(m1$R[upper.tri(m1$R,diag=TRUE)],collapse="\t"),m1$k,
- m1$logLik,m1$AIC,"\n",sep="\t"))
- if(m1$convergence==0) cat("\n(R thinks it has found the ML solution for model 1.)\n\n")
- else if(m1$convergence==77) cat("\n(Model 1 optimization may be at bounds.)\n\n")
- else cat("\n(Model 1 optimization may not have converged.)\n\n")
- ii<-which(names(x)=="model1")
- x<-x[-ii]
- }
-
- if(length(x)>0){
- nn<-paste("R[",t(sapply(1:ncol(x[[1]]$R[[1]]),paste,
- 1:ncol(x[[1]]$R[[1]]),sep=","))[upper.tri(x[[1]]$R[[1]],
- diag=TRUE)],"]",sep="")
- for(i in 1:length(x)){
- m<-lapply(x[[i]],function(a,b) if(is.numeric(a)) round(a,b) else a,b=digits)
- m$R<-lapply(m$R,function(a,b) if(is.numeric(a)) round(a,b) else a,b=digits)
- model<-strsplit(names(x)[i],"model")[[1]][2]
- cat(paste("Model ",model,": ",m$description,"\n",sep=""))
- cat(paste("\t",paste(nn,collapse="\t"),"\tk\tlog(L)\tAIC","\n",sep=""))
- for(j in 1:length(m$R)){
- if(j==1) cat(paste(names(m$R)[j],paste(m$R[[j]][upper.tri(m$R[[j]],diag=TRUE)],
- collapse="\t"),m$k,m$logLik,m$AIC,"\n",sep="\t"))
- else cat(paste(names(m$R)[j],paste(m$R[[j]][upper.tri(m$R[[j]],diag=TRUE)],
- collapse="\t"),"\n",sep="\t"))
- }
- if(m$convergence==0)
- cat(paste("\n(R thinks it has found the ML solution for model ",model,".)\n\n",sep=""))
- else if(m$convergence==77)
- cat(paste("\n(Model ",model," optimization may be at bounds.)\n\n",sep=""))
- else cat(paste("\n(Model ",model," optimization may not have converged.)\n\n",sep=""))
- }
- }
-}
+## function is simplified version of evol.vcv
+## written by Liam J. Revell 2011, 2012, 2013, 2017, 2019, 2020, 2021, 2022
+
+anova.evolvcv.lite<-function(object,...){
+ models<-paste("model",sapply(strsplit(names(object),"model"),
+ function(x) x[2]))
+ logL<-sapply(object,function(x) x$logLik)
+ df<-sapply(object,function(x) x$k)
+ AIC<-sapply(object,function(x) x$AIC)
+ value<-data.frame(logL=logL,df=df,AIC=AIC,weight=unclass(aic.w(AIC)))
+ rownames(value)<-models
+ colnames(value)<-c("log(L)","d.f.","AIC","weight")
+ print(value)
+ invisible(value)
+}
+
+evolvcv.lite<-function(tree,X,maxit=2000,tol=1e-10,...){
+ ## check 'phylo' object
+ if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".")
+ ## get some optional arguments
+ if(hasArg(models)) models<-list(...)$models
+ else models<-as.character(1:4)
+ if(models[1]=="all models") models<-c("1","2","2b","2c","3","3b","3c","4")
+ models<-as.character(models)
+ if(hasArg(try.iter)) try.iter<-list(...)$try.iter
+ else try.iter<-10
+ if(hasArg(lower)){
+ lower<-list(...)$lower
+ if(length(lower)==1) lower<-c(rep(lower,2),-1)
+ if(length(lower)>3) lower<-lower[1:3]
+ } else lower<-NULL
+ if(hasArg(upper)){
+ upper<-list(...)$upper
+ if(length(upper)==1) upper<-c(rep(upper,2),1)
+ if(length(upper)>3) upper<-upper[1:3]
+ } else upper<-NULL
+
+ if(!inherits(tree,"simmap")) models<-intersect("1",models)
+
+ if(length(models)==0) stop("for models!=\"1\" tree must be an object of class \"simmap\".")
+
+ # model 1: common variances & correlation
+ lik1<-function(theta,C,D,y,E){
+ v<-exp(theta[1:2])
+ r<-theta[3]
+ R<-matrix(c(v[1],r*sqrt(v[1]*v[2]),r*sqrt(v[1]*v[2]),
+ v[2]),2,2)
+ V<-kronecker(R,C)+E
+ a<-solve(t(D)%*%solve(V)%*%D)%*%(t(D)%*%solve(V)%*%y)
+ logL<--t(y-D%*%a)%*%solve(V)%*%(y-D%*%a)/2-
+ n*m*log(2*pi)/2-determinant(V)$modulus[1]/2
+ return(-logL)
+ }
+
+ # model 2: different variances, same correlation
+ lik2<-function(theta,C,D,y,E){
+ p<-(length(theta)-1)/2
+ v<-matrix(exp(theta[1:(2*p)]),p,2,byrow=T)
+ r<-theta[length(theta)]
+ R<-list()
+ for(i in 1:p) R[[i]]<-matrix(c(v[i,1],r*sqrt(v[i,1]*v[i,2]),
+ r*sqrt(v[i,1]*v[i,2]),v[i,2]),2,2)
+ V<-matrix(0,length(y),length(y))
+ for(i in 1:p) V<-V+kronecker(R[[i]],C[[i]])
+ V<-V+E
+ a<-solve(t(D)%*%solve(V)%*%D)%*%(t(D)%*%solve(V)%*%y)
+ logL<--t(y-D%*%a)%*%solve(V)%*%(y-D%*%a)/2-n*m*log(2*pi)/2-
+ determinant(V)$modulus[1]/2
+ return(-logL)
+ }
+
+ ## model 2b: different variances for only trait 1, same correlation
+ lik2b<-function(theta,C,D,y,E){
+ p<-length(theta)-2
+ v<-matrix(exp(c(theta[1:p],rep(theta[p+1],p))),p,2,byrow=FALSE)
+ r<-theta[length(theta)]
+ R<-list()
+ for(i in 1:p) R[[i]]<-matrix(c(v[i,1],r*sqrt(v[i,1]*v[i,2]),
+ r*sqrt(v[i,1]*v[i,2]),v[i,2]),2,2)
+ V<-matrix(0,length(y),length(y))
+ for(i in 1:p) V<-V+kronecker(R[[i]],C[[i]])
+ V<-V+E
+ a<-solve(t(D)%*%solve(V)%*%D)%*%(t(D)%*%solve(V)%*%y)
+ logL<--t(y-D%*%a)%*%solve(V)%*%(y-D%*%a)/2-n*m*log(2*pi)/2-
+ determinant(V)$modulus[1]/2
+ return(-logL)
+ }
+
+ ## model 2c: different variances for only trait 2, same correlation
+ lik2c<-function(theta,C,D,y,E){
+ p<-length(theta)-2
+ v<-matrix(exp(c(rep(theta[1],p),theta[1:p+1])),p,2,byrow=FALSE)
+ r<-theta[length(theta)]
+ R<-list()
+ for(i in 1:p) R[[i]]<-matrix(c(v[i,1],r*sqrt(v[i,1]*v[i,2]),
+ r*sqrt(v[i,1]*v[i,2]),v[i,2]),2,2)
+ V<-matrix(0,length(y),length(y))
+ for(i in 1:p) V<-V+kronecker(R[[i]],C[[i]])
+ V<-V+E
+ a<-solve(t(D)%*%solve(V)%*%D)%*%(t(D)%*%solve(V)%*%y)
+ logL<--t(y-D%*%a)%*%solve(V)%*%(y-D%*%a)/2-n*m*log(2*pi)/2-
+ determinant(V)$modulus[1]/2
+ return(-logL)
+ }
+
+ # model 3: same variances, different correlations
+ lik3<-function(theta,C,D,y,E){
+ p<-length(theta)-2
+ v<-exp(theta[1:2])
+ r<-theta[3:length(theta)]
+ R<-list()
+ for(i in 1:p) R[[i]]<-matrix(c(v[1],r[i]*sqrt(v[1]*v[2]),
+ r[i]*sqrt(v[1]*v[2]),v[2]),2,2)
+ V<-matrix(0,length(y),length(y))
+ for(i in 1:p) V<-V+kronecker(R[[i]],C[[i]])
+ V<-V+E
+ a<-solve(t(D)%*%solve(V)%*%D)%*%(t(D)%*%solve(V)%*%y)
+ logL<--t(y-D%*%a)%*%solve(V)%*%(y-D%*%a)/2-n*m*log(2*pi)/2-
+ determinant(V)$modulus[1]/2
+ return(-logL)
+ }
+
+ # model 3b: different variances for only trait 1, different correlation
+ lik3b<-function(theta,C,D,y,E){
+ p<-(length(theta)-1)/2
+ v<-matrix(exp(c(theta[1:p],rep(theta[p+1],p))),p,2,byrow=FALSE)
+ r<-theta[1:p+(p+1)]
+ R<-list()
+ for(i in 1:p) R[[i]]<-matrix(c(v[i,1],r[i]*sqrt(v[i,1]*v[i,2]),
+ r[i]*sqrt(v[i,1]*v[i,2]),v[i,2]),2,2)
+ V<-matrix(0,length(y),length(y))
+ for(i in 1:p) V<-V+kronecker(R[[i]],C[[i]])
+ V<-V+E
+ a<-solve(t(D)%*%solve(V)%*%D)%*%(t(D)%*%solve(V)%*%y)
+ logL<--t(y-D%*%a)%*%solve(V)%*%(y-D%*%a)/2-n*m*log(2*pi)/2-
+ determinant(V)$modulus[1]/2
+ return(-logL)
+ }
+
+ # model 3c: different variances for only trait 2, different correlations
+ lik3c<-function(theta,C,D,y,E){
+ p<-(length(theta)-1)/2
+ v<-matrix(exp(c(rep(theta[1],p),theta[1:p+1])),p,2,byrow=FALSE)
+ r<-theta[1:p+(p+1)]
+ R<-list()
+ for(i in 1:p) R[[i]]<-matrix(c(v[i,1],r[i]*sqrt(v[i,1]*v[i,2]),
+ r[i]*sqrt(v[i,1]*v[i,2]),v[i,2]),2,2)
+ V<-matrix(0,length(y),length(y))
+ for(i in 1:p) V<-V+kronecker(R[[i]],C[[i]])
+ V<-V+E
+ a<-solve(t(D)%*%solve(V)%*%D)%*%(t(D)%*%solve(V)%*%y)
+ logL<--t(y-D%*%a)%*%solve(V)%*%(y-D%*%a)/2-n*m*log(2*pi)/2-
+ determinant(V)$modulus[1]/2
+ return(-logL)
+ }
+
+ # model 4: everything different
+ lik4<-function(theta,C,D,y,E){
+ p<-length(theta)/3
+ v<-matrix(exp(theta[1:(2*p)]),p,2,byrow=TRUE)
+ r<-theta[(2*p+1):length(theta)]
+ R<-list()
+ for(i in 1:p) R[[i]]<-matrix(c(v[i,1],r[i]*sqrt(v[i,1]*v[i,2]),
+ r[i]*sqrt(v[i,1]*v[i,2]),v[i,2]),2,2)
+ V<-matrix(0,length(y),length(y))
+ for(i in 1:p) V<-V+kronecker(R[[i]],C[[i]])
+ V<-V+E
+ a<-solve(t(D)%*%solve(V)%*%D)%*%(t(D)%*%solve(V)%*%y)
+ logL<--t(y-D%*%a)%*%solve(V)%*%(y-D%*%a)/2-n*m*log(2*pi)/2-
+ determinant(V)$modulus[1]/2
+ return(-logL)
+ }
+
+ # done internal functions
+
+ # bookkeeping
+ X<-as.matrix(X)
+ X<-X[tree$tip.label,]
+ n<-nrow(X) # number of species
+ m<-ncol(X) # number of traits
+ if(m!=2) stop("number of traits must equal 2")
+
+ ## get error covariance matrices
+ if(hasArg(err_vcv)){
+ err_vcv<-list(...)$err_vcv
+ err_vcv<-err_vcv[tree$tip.label]
+ } else {
+ err_vcv<-replicate(n,matrix(0,m,m),simplify=FALSE)
+ names(err_vcv)<-tree$tip.label
+ }
+ E<-matrix(0,n*m,n*m)
+ for(i in 1:n){
+ ii<-0:(m-1)*n+i
+ E[ii,ii]<-err_vcv[[i]]
+ }
+ ## end get error covariances
+
+ ## more bookkeeping
+ p<-if(inherits(tree,"simmap")) ncol(tree$mapped.edge) else 1 # number of states
+ D<-matrix(0,n*m,m)
+ for(i in 1:(n*m)) for(j in 1:m)
+ if((j-1)*n<i&&i<=j*n) D[i,j]=1.0
+ y<-as.matrix(as.vector(X))
+ if(inherits(tree,"simmap")){
+ mC<-multiC(tree)
+ C<-Reduce("+",mC)
+ } else C<-vcv.phylo(tree)
+ sv1<-mean(pic(X[,1],multi2di(as.phylo(tree)))^2)
+ sv2<-mean(pic(X[,2],multi2di(as.phylo(tree)))^2)
+ sr<-mean(pic(X[,1],tree)*pic(X[,2],tree))/sqrt(sv1*sv2)
+ if(is.null(lower)) lower<-c(log(0.1*c(sv1,sv2)),-1)
+ if(is.null(upper)) upper<-c(log(10*c(sv1,sv2)),1)
+
+ object<-list()
+ class(object)<-"evolvcv.lite"
+
+ loglik_model1<-if(hasArg(err_vcv))
+ evol.vcv(as.phylo(tree),X,err_vcv=err_vcv)$logL1 else
+ evol.vcv(as.phylo(tree),X)$logL1
+
+ # now optimize models
+ msg<-function(text){
+ cat(text)
+ flush.console()
+ }
+ if("1"%in%models){
+ msg("Fitting model 1: common rates, common correlation...\n")
+ res1<-list()
+ res1$convergence<-99
+ class(res1)<-"try-error"
+ iter<-0
+ best<--loglik_model1+tol
+ LOWER<-lower
+ UPPER<-upper
+ while((inherits(res1,"try-error")||res1$convergence!=0)&&iter<try.iter){
+ init<-c(rnorm(n=2)*log(c(sv1,sv2)),runif(n=1,-1,1))
+ res1<-try(optim(init,lik1,C=C,D=D,y=y,E=E,
+ method="L-BFGS-B",lower=LOWER+tol,
+ upper=UPPER-tol))
+ if(inherits(res1,"try-error")){
+ res1<-list()
+ res1$convergence<-99
+ class(res1)<-"try-error"
+ res1$value<-best+tol
+ }
+ if(res1$value>best){
+ if(res1$convergence==0) res1$convergence<-99
+ } else best<-res1$value
+ iter<-iter+1
+ }
+ if(inherits(res1,"try-error")){
+ m1<-list(description="common rates, common correlation",
+ R=matrix(NA,p,p),logLik=NA,k=5,AIC=NA)
+ } else {
+ if(any(res1$par<(LOWER+2*tol))||any(res1$par>(UPPER-2*tol)))
+ res1$convergence<-77
+ res1$par[1:2]<-exp(res1$par[1:2])
+ m1<-list(description="common rates, common correlation",
+ R=matrix(c(res1$par[1],res1$par[3]*sqrt(res1$par[1]*res1$par[2]),
+ res1$par[3]*sqrt(res1$par[1]*res1$par[2]),res1$par[2]),2,2),
+ logLik=-res1$value,
+ convergence=res1$convergence,
+ k=length(res1$par)+2,
+ AIC=2*(length(res1$par)+2)+2*res1$value)
+ }
+ object$model1=m1
+ msg(paste("Best log(L) from model 1: ",round(m1$logLik,4),".\n",sep=""))
+ } else m1<-NULL
+ makeError<-function(description,names,p,k){
+ list(description=description,
+ R=setNames(replicate(p,matrix(NA,2,2),simplify=FALSE),names),
+ logLik=NA,
+ convergence=99,
+ k=k,
+ AIC=NA)
+ }
+ if("2"%in%models){
+ msg("Fitting model 2: different rates, common correlation...\n")
+ res2<-list()
+ res2$convergence<-99
+ class(res2)<-"try-error"
+ iter<-0
+ best<-if(is.null(m1)) -loglik_model1+tol else
+ -m1$logLik
+ LOWER<-c(rep(lower[1:2],p),lower[3])
+ UPPER<-c(rep(upper[1:2],p),upper[3])
+ while((inherits(res2,"try-error")||res2$convergence!=0)&&iter<try.iter){
+ init<-c(rnorm(n=2*p)*log(c(sv1,sv2)),runif(n=1,-1,1))
+ res2<-try(optim(init,lik2,C=mC,
+ D=D,y=y,E=E,method="L-BFGS-B",
+ lower=tol+LOWER,upper=UPPER-tol))
+ if(inherits(res2,"try-error")){
+ res2<-list()
+ res2$convergence<-99
+ class(res2)<-"try-error"
+ res2$value<-best+tol
+ }
+ if(res2$value>best){
+ if(res2$convergence==0) res2$convergence<-99
+ } else best<-res2$value
+ iter<-iter+1
+ }
+ if(inherits(res2,"try-error")){
+ m2<-makeError("different rates, common correlation",
+ colnames(tree$mapped.edge),
+ ncol(tree$mapped.edge),
+ 2*ncol(tree$mapped.edge)+1)
+ } else {
+ if(any(res2$par<(LOWER+2*tol))||any(res2$par>(UPPER-2*tol)))
+ res2$convergence<-77
+ R<-list()
+ res2$par[1:(2*p)]<-exp(res2$par[1:(2*p)])
+ for(i in 1:p) R[[i]]<-matrix(c(res2$par[2*(i-1)+1],
+ rep(res2$par[2*p+1]*sqrt(res2$par[2*(i-1)+1]*res2$par[2*(i-1)+2]),2),
+ res2$par[2*(i-1)+2]),2,2)
+ names(R)<-colnames(tree$mapped.edge)
+ m2<-list(description="different rates, common correlation",
+ R=R,
+ logLik=-res2$value,
+ convergence=res2$convergence,
+ k=length(res2$par)+2,
+ AIC=2*(length(res2$par)+2)+2*res2$value)
+ }
+ object$model2<-m2
+ msg(paste("Best log(L) from model 2: ",round(m2$logLik,4),".\n",sep=""))
+ }
+ if("2b"%in%models){
+ msg("Fitting model 2b: different rates (trait 1), common correlation...\n")
+ res2b<-list()
+ res2b$convergence<-99
+ class(res2b)<-"try-error"
+ iter<-0
+ best<-if(is.null(m1)) -loglik_model1+tol else
+ (-m1$logLik)
+ LOWER<-c(rep(lower[1],p),lower[2],lower[3])
+ UPPER<-c(rep(upper[1],p),upper[2],upper[3])
+ while((inherits(res2b,"try-error")||res2b$convergence!=0)&&iter<try.iter){
+ init<-c(rnorm(n=p+1)*log(c(rep(sv1,p),sv2)),runif(n=1,-1,1))
+ res2b<-try(optim(init,lik2b,C=mC,
+ D=D,y=y,E=E,method="L-BFGS-B",
+ lower=LOWER+tol,upper=UPPER-tol))
+ if(inherits(res2b,"try-error")){
+ res2b<-list()
+ res2b$convergence<-99
+ class(res2b)<-"try-error"
+ res2b$value<-best+tol
+ }
+ if(res2b$value>best){
+ if(res2b$convergence==0) res2b$convergence<-99
+ } else best<-res2b$value
+ iter<-iter+1
+ }
+ if(inherits(res2b,"try-error")){
+ m2b<-makeError("different rates (trait 1), common correlation",
+ colnames(tree$mapped.edge),
+ ncol(tree$mapped.edge),
+ 2*ncol(tree$mapped.edge)+2)
+ } else {
+ if(any(res2b$par<(LOWER+2*tol))||any(res2b$par>(UPPER-2*tol)))
+ res2b$convergence<-77
+ R<-list()
+ res2b$par[1:(p+1)]<-exp(res2b$par[1:(p+1)])
+ for(i in 1:p) R[[i]]<-matrix(c(res2b$par[i],
+ rep(res2b$par[p+2]*sqrt(res2b$par[i]*res2b$par[p+1]),2),
+ res2b$par[p+1]),2,2)
+ names(R)<-colnames(tree$mapped.edge)
+ m2b<-list(description="different rates (trait 1), common correlation",
+ R=R,
+ logLik=-res2b$value,
+ convergence=res2b$convergence,
+ k=length(res2b$par)+2,
+ AIC=2*(length(res2b$par)+2)+2*res2b$value)
+ }
+ object$model2b<-m2b
+ msg(paste("Best log(L) from model 2b: ",round(m2b$logLik,4),".\n",sep=""))
+ }
+ if("2c"%in%models){
+ msg("Fitting model 2c: different rates (trait 2), common correlation...\n")
+ res2c<-list()
+ res2c$convergence<-99
+ class(res2c)<-"try-error"
+ iter<-0
+ best<-if(is.null(m1)) -loglik_model1+tol else
+ (-m1$logLik)
+ LOWER<-c(lower[1],rep(lower[2],p),lower[3])
+ UPPER<-c(upper[1],rep(upper[2],p),upper[3])
+ while((inherits(res2c,"try-error")||res2c$convergence!=0)&&iter<try.iter){
+ init<-c(rnorm(n=p+1)*log(c(sv1,rep(sv2,p))),runif(n=1,-1,1))
+ res2c<-try(optim(init,lik2c,C=mC,
+ D=D,y=y,E=E,method="L-BFGS-B",
+ lower=LOWER+tol,upper=UPPER-tol))
+ if(inherits(res2c,"try-error")){
+ res2c<-list()
+ res2c$convergence<-99
+ class(res2c)<-"try-error"
+ res2c$value<-best+tol
+ }
+ if(res2c$value>best){
+ if(res2c$convergence==0) res2c$convergence<-99
+ } else best<-res2c$value
+ iter<-iter+1
+ }
+ if(inherits(res2c,"try-error")){
+ m2c<-makeError("different rates (trait 2), common correlation",
+ colnames(tree$mapped.edge),
+ ncol(tree$mapped.edge),
+ 2*ncol(tree$mapped.edge)+2)
+ } else {
+ if(any(res2c$par<(LOWER+2*tol))||any(res2c$par>(UPPER-2*tol)))
+ res2c$convergence<-77
+ R<-list()
+ res2c$par[1:(p+1)]<-exp(res2c$par[1:(p+1)])
+ for(i in 1:p) R[[i]]<-matrix(c(res2c$par[1],
+ rep(res2c$par[p+2]*sqrt(res2c$par[1]*res2c$par[i+1]),2),
+ res2c$par[i+1]),2,2)
+ names(R)<-colnames(tree$mapped.edge)
+ m2c<-list(description="different rates (trait 2), common correlation",
+ R=R,
+ logLik=-res2c$value,
+ convergence=res2c$convergence,
+ k=length(res2c$par)+2,
+ AIC=2*(length(res2c$par)+2)+2*res2c$value)
+ }
+ object$model2c<-m2c
+ msg(paste("Best log(L) from model 2c: ",round(m2c$logLik,4),".\n",sep=""))
+ }
+ if("3"%in%models){
+ msg("Fitting model 3: common rates, different correlation...\n")
+ res3<-list()
+ res3$convergence<-99
+ class(res3)<-"try-error"
+ iter<-0
+ best<-if(is.null(m1)) -loglik_model1+tol else
+ (-m1$logLik)
+ LOWER<-c(lower[1],lower[2],rep(lower[3],p))
+ UPPER<-c(upper[1],upper[2],rep(upper[3],p))
+ while((inherits(res3,"try-error")||res3$convergence!=0)&&iter<try.iter){
+ init<-c(rnorm(n=2)*log(c(sv1,sv2)),runif(n=p,-1,1))
+ res3<-try(optim(init,lik3,C=mC,D=D,
+ y=y,E=E,method="L-BFGS-B",lower=tol+LOWER,
+ upper=UPPER-tol))
+ if(inherits(res3,"try-error")){
+ res3<-list()
+ res3$convergence<-99
+ class(res3)<-"try-error"
+ res3$value<-best+tol
+ }
+ if(res3$value>best){
+ if(res3$convergence==0) res3$convergence<-99
+ } else best<-res3$value
+ iter<-iter+1
+ }
+ if(inherits(res3,"try-error")){
+ m3<-makeError("common rates, different correlation",
+ colnames(tree$mapped.edge),
+ ncol(tree$mapped.edge),
+ ncol(tree$mapped.edge)+2)
+ } else {
+ if(any(res3$par<(LOWER+2*tol))||any(res3$par>(UPPER-2*tol)))
+ res3$convergence<-77
+ R<-list()
+ res3$par[1:2]<-exp(res3$par[1:2])
+ for(i in 1:p) R[[i]]<-matrix(c(res3$par[1],
+ rep(res3$par[2+i]*sqrt(res3$par[1]*res3$par[2]),2),res3$par[2]),2,2)
+ names(R)<-colnames(tree$mapped.edge)
+ m3<-list(description="common rates, different correlation",
+ R=R,
+ logLik=-res3$value,
+ convergence=res3$convergence,
+ k=length(res3$par)+2,
+ AIC=2*(length(res3$par)+2)+2*res3$value)
+ }
+ object$model3<-m3
+ msg(paste("Best log(L) from model 3: ",round(m3$logLik,4),".\n",sep=""))
+ }
+ if("3b"%in%models){
+ msg("Fitting model 3b: different rates (trait 1), different correlation...\n")
+ res3b<-list()
+ res3b$convergence<-99
+ class(res3b)<-"try-error"
+ iter<-0
+ best<-if(is.null(m1)) -loglik_model1+tol else
+ (-m1$logLik)
+ LOWER<-c(rep(lower[1],p),lower[2],rep(lower[3],p))
+ UPPER<-c(rep(upper[1],p),upper[2],rep(upper[3],p))
+ while((inherits(res3b,"try-error")||res3b$convergence!=0)&&iter<try.iter){
+ init<-c(rnorm(n=p+1)*log(c(rep(sv1,p),sv2)),runif(n=p,-1,1))
+ res3b<-try(optim(init,lik3b,C=mC,
+ D=D,y=y,E=E,method="L-BFGS-B",
+ lower=LOWER+tol,upper=UPPER-tol))
+ if(inherits(res3b,"try-error")){
+ res3b<-list()
+ res3b$convergence<-99
+ class(res3b)<-"try-error"
+ res3b$value<-best+tol
+ }
+ if(res3b$value>best){
+ if(res3b$convergence==0) res3b$convergence<-99
+ } else best<-res3b$value
+ iter<-iter+1
+ }
+ if(inherits(res3b,"try-error")){
+ m3b<-makeError("different rates (trait 1), different correlation",
+ colnames(tree$mapped.edge),
+ ncol(tree$mapped.edge),
+ 2*ncol(tree$mapped.edge)+1)
+ } else {
+ if(any(res3b$par<(LOWER+2*tol))||any(res3b$par>(UPPER-2*tol)))
+ res3b$convergence<-77
+ R<-list()
+ res3b$par[1:(p+1)]<-exp(res3b$par[1:(p+1)])
+ for(i in 1:p) R[[i]]<-matrix(c(res3b$par[i],
+ rep(res3b$par[p+1+i]*sqrt(res3b$par[i]*res3b$par[p+1]),2),
+ res3b$par[p+1]),2,2)
+ names(R)<-colnames(tree$mapped.edge)
+ m3b<-list(description="different rates (trait 1), different correlation",
+ R=R,
+ logLik=-res3b$value,
+ convergence=res3b$convergence,
+ k=length(res3b$par)+2,
+ AIC=2*(length(res3b$par)+2)+2*res3b$value)
+ }
+ object$model3b<-m3b
+ msg(paste("Best log(L) from model 3b: ",round(m3b$logLik,4),".\n",sep=""))
+ }
+ if("3c"%in%models){
+ msg("Fitting model 3c: different rates (trait 2), different correlation...\n")
+ res3c<-list()
+ res3c$convergence<-99
+ class(res3c)<-"try-error"
+ iter<-0
+ best<-if(is.null(m1)) -loglik_model1+tol else
+ (-m1$logLik)
+ LOWER<-c(lower[1],rep(lower[2],p),rep(lower[3],p))
+ UPPER<-c(upper[1],rep(upper[2],p),rep(upper[3],p))
+ while((inherits(res3c,"try-error")||res3c$convergence!=0)&&iter<try.iter){
+ init<-c(rnorm(n=p+1)*log(c(sv1,rep(sv2,p))),runif(n=p,-1,1))
+ res3c<-try(optim(init,lik3c,C=mC,
+ D=D,y=y,E=E,method="L-BFGS-B",
+ lower=LOWER+tol,upper=UPPER-tol))
+ if(inherits(res3c,"try-error")){
+ res3c<-list()
+ res3c$convergence<-99
+ class(res3c)<-"try-error"
+ res3c$value<-best+tol
+ }
+ if(res3c$value>best){
+ if(res3c$convergence==0) res3c$convergence<-99
+ } else best<-res3c$value
+ iter<-iter+1
+ }
+ if(inherits(res3c,"try-error")){
+ m3c<-makeError("different rates (trait 2), different correlation",
+ colnames(tree$mapped.edge),
+ ncol(tree$mapped.edge),
+ 2*ncol(tree$mapped.edge)+1)
+ } else {
+ if(any(res3c$par<(LOWER+2*tol))||any(res3c$par>(UPPER-2*tol)))
+ res3c$convergence<-77
+ R<-list()
+ res3c$par[1:(p+1)]<-exp(res3c$par[1:(p+1)])
+ for(i in 1:p) R[[i]]<-matrix(c(res3c$par[1],
+ rep(res3c$par[p+1+i]*sqrt(res3c$par[1]*res3c$par[1+i]),2),
+ res3c$par[1+i]),2,2)
+ names(R)<-colnames(tree$mapped.edge)
+ m3c<-list(description="different rates (trait 2), different correlation",
+ R=R,
+ logLik=-res3c$value,
+ convergence=res3c$convergence,
+ k=length(res3c$par)+2,
+ AIC=2*(length(res3c$par)+2)+2*res3c$value)
+ }
+ object$model3c<-m3c
+ msg(paste("Best log(L) from model 3c: ",round(m3c$logLik,4),".\n",sep=""))
+ }
+ if("4"%in%models){
+ msg("Fitting model 4: no common structure...\n")
+ res4<-list()
+ res4$convergence<-99
+ class(res4)<-"try-error"
+ iter<-0
+ best<-if(is.null(m1)) -loglik_model1+tol else
+ (-m1$logLik)
+ LOWER<-c(rep(lower[1:2],p),rep(lower[3],p))
+ UPPER<-c(rep(upper[1:2],p),rep(upper[3],p))
+ while((inherits(res4,"try-error")||res4$convergence!=0)&&iter<try.iter){
+ init<-c(rnorm(n=2*p)*log(rep(c(sv1,sv2),p)),runif(n=p,-1,1))
+ res4<-try(optim(init,lik4,C=mC,
+ D=D,y=y,E=E,method="L-BFGS-B",lower=LOWER+tol,
+ upper=UPPER-tol))
+ if(inherits(res4,"try-error")){
+ res4<-list()
+ res4$convergence<-99
+ class(res4)<-"try-error"
+ res4$value<-best+tol
+ }
+ if(res4$value>best){
+ if(res4$convergence==0) res4$convergence<-99
+ } else best<-res4$value
+ iter<-iter+1
+ }
+ if(inherits(res4,"try-error")){
+ m4<-makeError("no common structure",
+ colnames(tree$mapped.edge),
+ ncol(tree$mapped.edge),
+ 3*ncol(tree$mapped.edge)+2)
+ } else {
+ if(any(res4$par<(LOWER+2*tol))||any(res4$par>(UPPER-2*tol)))
+ res4$convergence<-77
+ R<-list()
+ res4$par[1:(2*p)]<-exp(res4$par[1:(2*p)])
+ for(i in 1:p) R[[i]]<-matrix(c(res4$par[2*(i-1)+1],
+ rep(res4$par[2*p+i]*sqrt(res4$par[2*(i-1)+1]*res4$par[2*(i-1)+2]),
+ 2),res4$par[2*(i-1)+2]),2,2)
+ names(R)<-colnames(tree$mapped.edge)
+ m4<-list(description="no common structure",
+ R=R,
+ logLik=-res4$value,
+ convergence=res4$convergence,
+ k=length(res4$par)+2,
+ AIC=2*(length(res4$par)+2)+2*res4$value)
+ }
+ object$model4<-m4
+ msg(paste("Best log(L) from model 4: ",round(m4$logLik,4),".\n",sep=""))
+ }
+ object
+}
+
+## S3 print method for object of class "evolvcv.lite"
+## written by Liam J. Revell 2017, 2019, 2021
+print.evolvcv.lite<-function(x,...){
+ if(hasArg(digits)) digits<-list(...)$digits
+ else digits<-4
+
+ if(!is.null(x$model1)){
+ nn<-paste("R[",t(sapply(1:ncol(x$model1$R),paste,
+ 1:ncol(x$model1$R),sep=","))[upper.tri(x$model1$R,
+ diag=TRUE)],"]",sep="")
+ ## MODEL 1
+ m1<-lapply(x$model1,function(a,b) if(is.numeric(a)) round(a,b) else a,b=digits)
+ cat(paste("Model 1:",x$model1$description,"\n"))
+ cat(paste("\t",paste(nn,collapse="\t"),"\tk\tlog(L)\tAIC","\n",sep=""))
+ cat(paste("fitted",paste(m1$R[upper.tri(m1$R,diag=TRUE)],collapse="\t"),m1$k,
+ m1$logLik,m1$AIC,"\n",sep="\t"))
+ if(m1$convergence==0) cat("\n(R thinks it has found the ML solution for model 1.)\n\n")
+ else if(m1$convergence==77) cat("\n(Model 1 optimization may be at bounds.)\n\n")
+ else cat("\n(Model 1 optimization may not have converged.)\n\n")
+ ii<-which(names(x)=="model1")
+ x<-x[-ii]
+ }
+
+ if(length(x)>0){
+ nn<-paste("R[",t(sapply(1:ncol(x[[1]]$R[[1]]),paste,
+ 1:ncol(x[[1]]$R[[1]]),sep=","))[upper.tri(x[[1]]$R[[1]],
+ diag=TRUE)],"]",sep="")
+ for(i in 1:length(x)){
+ m<-lapply(x[[i]],function(a,b) if(is.numeric(a)) round(a,b) else a,b=digits)
+ m$R<-lapply(m$R,function(a,b) if(is.numeric(a)) round(a,b) else a,b=digits)
+ model<-strsplit(names(x)[i],"model")[[1]][2]
+ cat(paste("Model ",model,": ",m$description,"\n",sep=""))
+ cat(paste("\t",paste(nn,collapse="\t"),"\tk\tlog(L)\tAIC","\n",sep=""))
+ for(j in 1:length(m$R)){
+ if(j==1) cat(paste(names(m$R)[j],paste(m$R[[j]][upper.tri(m$R[[j]],diag=TRUE)],
+ collapse="\t"),m$k,m$logLik,m$AIC,"\n",sep="\t"))
+ else cat(paste(names(m$R)[j],paste(m$R[[j]][upper.tri(m$R[[j]],diag=TRUE)],
+ collapse="\t"),"\n",sep="\t"))
+ }
+ if(m$convergence==0)
+ cat(paste("\n(R thinks it has found the ML solution for model ",model,".)\n\n",sep=""))
+ else if(m$convergence==77)
+ cat(paste("\n(Model ",model," optimization may be at bounds.)\n\n",sep=""))
+ else cat(paste("\n(Model ",model," optimization may not have converged.)\n\n",sep=""))
+ }
+ }
+}
diff --git a/R/export.as.xml.R b/R/export.as.xml.R
index 1171a99..7dea416 100644
--- a/R/export.as.xml.R
+++ b/R/export.as.xml.R
@@ -1,32 +1,32 @@
-## makes xml data and tree file for SIMMAP
-## written by Liam J. Revell 2012, 2015, 2022
-
-export.as.xml<-function(file,trees,X){
- if(is.vector(X)) X<-data.frame(X)
- if(inherits(X,"DNAbin")) {
- X<-as.character(X)
- datatype="nucleotide"
- } else datatype="standard"
- if(inherits(trees,"phylo")){
- trees<-list(trees)
- class(trees)<-"multiPhylo"
- }
- ntaxa<-length(trees[[1]]$tip)
- nchars<-ncol(X)
- write("<?xml version=\"1.0\"?>",file)
- write("<simmap>",file,append=TRUE)
- write(paste("\t<data ntaxa=\"",ntaxa,"\" nchars=\"",nchars,"\" datatype=\"",datatype,"\">",sep=""),file,append=TRUE)
- for(i in 1:ntaxa) write(paste("\t\t<seq name=\"",rownames(X)[i],"\">",paste(X[i,],collapse=""),"</seq>",sep=""),file,append=TRUE)
- write("\t</data>",file,append=TRUE)
- write("\t<trees>",file,append=TRUE)
- trans<-trees[[1]]$tip.label
- for(i in 1:ntaxa) write(paste("\t\t<translate id=\"",i,"\">",trans[i],"</translate>",sep=""),file,append=TRUE)
- for(i in 1:length(trees)){
- trees[[i]]$tip.label<-match(trans,trees[[i]]$tip.label)
- temp<-unlist(strsplit(write.tree(trees[[i]]),NULL))
- temp<-paste(temp[1:(length(temp)-1)],collapse="")
- write(paste("\t\t<tree>",temp,"</tree>",sep=""),file,append=TRUE)
- }
- write("\t</trees>",file,append=TRUE)
- write("</simmap>",file,append=TRUE)
-}
+## makes xml data and tree file for SIMMAP
+## written by Liam J. Revell 2012, 2015, 2022
+
+export.as.xml<-function(file,trees,X){
+ if(is.vector(X)) X<-data.frame(X)
+ if(inherits(X,"DNAbin")) {
+ X<-as.character(X)
+ datatype="nucleotide"
+ } else datatype="standard"
+ if(inherits(trees,"phylo")){
+ trees<-list(trees)
+ class(trees)<-"multiPhylo"
+ }
+ ntaxa<-length(trees[[1]]$tip)
+ nchars<-ncol(X)
+ write("<?xml version=\"1.0\"?>",file)
+ write("<simmap>",file,append=TRUE)
+ write(paste("\t<data ntaxa=\"",ntaxa,"\" nchars=\"",nchars,"\" datatype=\"",datatype,"\">",sep=""),file,append=TRUE)
+ for(i in 1:ntaxa) write(paste("\t\t<seq name=\"",rownames(X)[i],"\">",paste(X[i,],collapse=""),"</seq>",sep=""),file,append=TRUE)
+ write("\t</data>",file,append=TRUE)
+ write("\t<trees>",file,append=TRUE)
+ trans<-trees[[1]]$tip.label
+ for(i in 1:ntaxa) write(paste("\t\t<translate id=\"",i,"\">",trans[i],"</translate>",sep=""),file,append=TRUE)
+ for(i in 1:length(trees)){
+ trees[[i]]$tip.label<-match(trans,trees[[i]]$tip.label)
+ temp<-unlist(strsplit(write.tree(trees[[i]]),NULL))
+ temp<-paste(temp[1:(length(temp)-1)],collapse="")
+ write(paste("\t\t<tree>",temp,"</tree>",sep=""),file,append=TRUE)
+ }
+ write("\t</trees>",file,append=TRUE)
+ write("</simmap>",file,append=TRUE)
+}
diff --git a/R/fancyTree.R b/R/fancyTree.R
index 0407871..520bcbc 100644
--- a/R/fancyTree.R
+++ b/R/fancyTree.R
@@ -1,316 +1,316 @@
-# function to plot special types of phylogeny visualizations
-# so far the implemented types are:
-# "extinction" in which all branches leading to extinct taxa (or prior to the MRCA of extant species) are plotted with red dashed lines;
-# "traitgram3d" which creates a 3D graph projecting the tree into two-dimensional morphospace (with time as the third axis)
-# "droptip" creates a two panel plot with the tips to be pruned marked (panel 1) and then removed, and returns the pruned tree
-# "xkcd" creates an xkcd-comic style phylogeny [no longer an option]
-# "densitymap" maps the posterior density of a binary stochastic character mapping
-# "contmap" maps reconstructed trait evolution for a continuous character on the tree
-# "phenogram95" plots a 95% CI phenogram
-# "scattergram" plots a phylogenetic scatterplot matrix
-# written by Liam J. Revell 2012, 2013, 2014, 2015, 2016, 2017
-
-fancyTree<-function(tree,type=c("extinction","traitgram3d","droptip",
- "densitymap","contmap","phenogram95","scattergram"),...,control=list()){
- type<-matchType(type,c("extinction","traitgram3d","droptip","densitymap",
- "contmap","phenogram95","scattergram"))
- if(!inherits(tree,"phylo")&&type%in%c("extinction","traitgram3d",
- "droptip")) stop("tree should be an object of class \"phylo\".")
- else if(!inherits(tree,"multiSimmap")&&type=="densitymap")
- stop("for type='densitymap' tree should be an object of class \"multiSimmap\".")
- if(type=="extinction") extinctionTree(tree,...)
- else if(type=="traitgram3d") invisible(traitgram3d(tree,...,control=control))
- else if(type=="droptip") return(droptipTree(tree,...))
- else if(type=="densitymap") plotDensityMap(tree,...)
- else if(type=="contmap") plotContMap(tree,...)
- else if(type=="phenogram95") phenogram95(tree,...)
- else if(type=="scattergram") invisible(phyloScattergram(tree,...))
- else stop(paste("do not recognize type = \"",type,"\"",sep=""))
-}
-
-## phyloScattergram internal function
-## written by Liam J. Revell 2013, 2014, 2017, 2019, 2021
-
-phyloScattergram<-function(tree,X=NULL,...){
- if(is.null(X)) stop("phenotypic data should be provided in the matrix X")
- if(is.data.frame(X)) X<-as.matrix(X)
- if(hasArg(plot)) plot<-list(...)$plot
- else plot<-TRUE
- if(hasArg(fixed.lims)) fixed.lims<-list(...)$fixed.lims
- else fixed.lims<-FALSE
- if(hasArg(quiet)) quiet<-list(...)$quiet
- else quiet<-FALSE
- if(!quiet){
- cat("Computing multidimensional phylogenetic scatterplot matrix...\n")
- flush.console()
- }
- m<-ncol(X)
- A<-apply(X,2,fastAnc,tree=tree)
- cmaps<-list()
- lims<-if(fixed.lims) range(X) else NULL
- for(i in 1:m) cmaps[[i]]<-contMap(tree,X[,i],
- legend=FALSE,lwd=2,outline=FALSE,plot=FALSE,
- lims=lims)
- if(is.null(colnames(X))) colnames(X)<-paste("V",1:m,sep="")
- obj<-list(tree=tree,contMaps=cmaps,X=X,A=A)
- class(obj)<-"phyloScattergram"
- if(plot) plot(obj,...)
- invisible(obj)
-}
-
-plot.phyloScattergram<-function(x,...){
- if(hasArg(fsize)) fsize<-list(...)$fsize
- else fsize<-0.7
- if(hasArg(ftype)) ftype<-list(...)$ftype
- else ftype<-"i"
- if(hasArg(colors)) colors<-list(...)$colors
- else if(!is.null(x$tree$maps))
- colors<-setNames(palette()[1:ncol(x$tree$mapped.edge)],
- sort(colnames(x$tree$mapped.edge)))
- if(hasArg(label)) label<-list(...)$label
- else label<-"radial"
- m<-ncol(x$X)
- dev.hold()
- par(mfrow=c(m,m))
- par(mar=c(0,0,0,0))
- par(oma=c(5,5,3,3))
- for(i in 1:m) for(j in 1:m){
- if(i==j) plot(x$contMaps[[i]],legend=FALSE,
- lwd=2,outline=FALSE,fsize=fsize,ftype=ftype)
- else {
- phylomorphospace(x$tree,x$X[,c(j,i)],A=x$A[,c(j,i)],lwd=1,
- node.by.map=TRUE,axes=FALSE,node.size=c(0,1),
- colors=colors,label=label,xlab="",ylab="",
- fsize=fsize/0.7,ftype=ftype)
- if(i==1) axis(side=3) # top row
- if(i==m) axis(side=1) # first column
- if(j==1) axis(side=2) # bottom row
- if(j==m) axis(side=4) # last column
- }
- }
- old.cex<-par()$cex
- par(cex=0.9)
- if(is.null(colnames(x$X))) colnames(x$X)<-paste("V",1:m,sep="")
- invisible(mapply(title,xlab=colnames(x$X),
- adj=seq(0,(m-1)/m,1/m)+1/(2*m),MoreArgs=list(outer=TRUE,cex=0.9)))
- invisible(mapply(title,ylab=colnames(x$X)[m:1],
- adj=seq(0,(m-1)/m,1/m)+1/(2*m),MoreArgs=list(outer=TRUE,cex=0.9)))
- dev.flush()
- par(cex=old.cex)
-}
-
-print.phyloScattergram<-function(x,...){
- cat(paste("\nObject of class \"phyloScattergram\" for",ncol(x$X),
- "continuous traits.\n"))
- cat("To replot enter \"plot(object_name)\" at the prompt.\n\n")
-}
-
-## phenogram95 internal function
-## written by Liam J. Revell 2013, 2014, 2019
-
-phenogram95<-function(tree,x=NULL,...){
- if(is.null(x)) stop("no phenotypic data provided")
- if(hasArg(spread.labels)) spread.labels<-list(...)$spread.labels
- else spread.labels<-TRUE
- if(hasArg(link)) link<-list(...)$link
- else link<-0.05*max(nodeHeights(tree))
- if(hasArg(offset)) offset<-list(...)$offset
- else offset<-0
- if(hasArg(hold)) hold<-list(...)$hold
- else hold<-TRUE
- if(hasArg(quiet)) quiet<-list(...)$quiet
- else quiet<-FALSE
- # get ancestral states
- A<-fastAnc(tree,x,CI=TRUE)
- # compute transparencies
- if(hasArg(tlim)) tlim<-list(...)$tlim
- else tlim<-c(0,25)
- trans<-as.character(floor(seq(tlim[1],tlim[2],length.out=51)))
- trans[as.numeric(trans)<10]<-paste("0", trans[as.numeric(trans)<10],sep="")
- # now get the arguments for phenogram
- args<-list(...)
- args$tree<-tree
- args$lwd<-1
- args$link<-0.05*max(nodeHeights(tree))
- args$offset<-0
- if(hold) null<-dev.hold()
- if(!quiet&&hold){
- cat("Computing density traitgram...\n")
- flush.console()
- }
- for(i in 0:50){
- p<-i/length(trans)
- args$add<-i>0
- args$spread.labels<-if(i==0) spread.labels else FALSE
- args$link<-if(i==0) link else 0
- args$offset<-if(i==0) offset else offset+link
- args$x<-c(x,(1-p)*A$CI95[,1]+p*A$ace)
- args$colors<-paste("#0000ff",trans[i+1],sep="")
- do.call(phenogram,args)
- args$x<-c(x,(1-p)*A$CI95[,2]+p*A$ace)
- args$add<-TRUE
- args$spread.labels<-FALSE
- args$link<-0
- args$offset<-offset+link
- do.call(phenogram,args)
- }
- args$x<-c(x,A$ace)
- args$add<-TRUE
- args$colors<-"white"
- args$lwd<-2
- args$offset<-offset+link
- do.call(phenogram,args)
- null<-dev.flush()
-}
-
-## extinctionTree internal function
-## written by Liam J. Revell 2012, 2019
-
-extinctionTree<-function(tree,...){
- if(hasArg(fsize)) fsize<-list(...)$fsize
- else fsize<-1
- if(hasArg(ftype)) ftype<-list(...)$ftype
- else ftype<-"i"
- if(hasArg(lwd)) lwd<-list(...)$lwd
- else lwd<-2
- if(hasArg(colors)) colors<-list(...)$colors
- else colors<-palette()[1:2]
- ftype<-which(c("off","reg","b","i","bi")==ftype)-1
- if(!ftype) fsize=0.1
- edges<-rep(0,nrow(tree$edge))
- names(edges)<-tree$edge[,2]
- extant<-getExtant(tree)
- ca<-findMRCA(tree,extant)
- root.node<-length(tree$tip)+1
- if(ca!=root.node){
- z<-setdiff(getDescendants(tree,root.node),
- getDescendants(tree,ca))
- edges[as.character(z)]<-1
- }
- z<-getDescendants(tree,ca)
- y<-lapply(z,getDescendants,tree=tree)
- for(i in 1:length(z))
- if(!any(tree$tip.label[y[[i]]]%in%extant))
- edges[as.character(z[i])]<-1
- ape::plot.phylo(tree,edge.color=colors[edges+1],edge.lty=edges+1,
- edge.width=lwd,no.margin=TRUE,cex=fsize,
- show.tip.label=if(ftype==0) FALSE else TRUE,
- font=ftype)
-}
-
-# traitgram3d internal function
-# written by Liam J. Revell 2012, 2013
-
-traitgram3d<-function(tree,...,control){
- if(hasArg(X)) X<-list(...)$X
- else stop("no phenotypic data provided")
- if(!hasArg(A)){
- if(is.null(control$maxit)) maxit<-2000
- else maxit<-control$maxit
- Y<-apply(X,2,function(x,tree) anc.ML(tree,x,maxit),tree=tree)
- convergence<-sapply(Y,function(x) x$convergence)
- if(any(convergence!=0)) warning("anc.ML may not have converged; consider increasing maxit.")
- A<-sapply(Y,function(x) x$ace)
- } else {
- A<-list(...)$A
- A<-A[as.character(1:tree$Nnode+length(tree$tip)),]
- }
- if(is.null(colnames(X))) colnames(X)<-c("x","y")
- X<-cbind(X,diag(vcv(tree))[rownames(X)])
- A<-cbind(A,nodeHeights(tree)[match(rownames(A)[1:nrow(A)],tree$edge)])
- colnames(X)[3]<-colnames(A)[3]<-"time"
- # other optional arguments
- if(hasArg(method)) method<-list(...)$method
- else method<-"dynamic"
- if(hasArg(angle)) angle<-list(...)$angle
- else angle<-30
- # done other optional arguments
- xx<-phylomorphospace3d(tree,X,A,control=control,method=method,
- angle=angle,zlim=range(nodeHeights(tree)))
- return(xx)
-}
-
-# droptipTree internal function
-# written by Liam J. Revell 2012, 2020 (just to fix a couple of dumb bugs)
-
-droptipTree<-function(tree,...){
- if(hasArg(tip)) tip<-list(...)$tip
- else stop("need to provide tip or tips to drop")
- if(hasArg(cex)) cex<-list(...)$cex
- else cex<-0.7
- edges<-rep(0,nrow(tree$edge))
- names(edges)<-tree$edge[,2]
- keep<-setdiff(tree$tip.label,tip)
- ca<-findMRCA(tree,keep)
- root.node<-length(tree$tip)+1
- if(ca!=root.node){
- z<-setdiff(getDescendants(tree,root.node),
- getDescendants(tree,ca))
- edges[as.character(z)]<-1
- }
- z<-getDescendants(tree,ca)
- foo<-function(x,tree){
- n<-length(tree$tip.label)
- y<-getDescendants(tree,x)
- y<-y[y<=n]
- return(y)
- }
- y<-lapply(z,foo,tree=tree)
- for(i in 1:length(z)) if(!any(tree$tip.label[y[[i]]]%in%keep))
- edges[as.character(z[i])]<-1
- par(mfrow=c(2,1))
- plot.phylo(tree,edge.color=edges+1,edge.lty=edges+1,
- edge.width=2,no.margin=TRUE,cex=cex)
- xlim<-get("last_plot.phylo",envir=.PlotPhyloEnv)$x.lim
- dtree<-drop.tip(tree,tip)
- dtree$root.edge<-max(nodeHeights(tree))-max(nodeHeights(dtree))
- plot.phylo(rootedge.to.singleton(dtree),edge.width=2,
- no.margin=TRUE,cex=cex,x.lim=xlim)
- return(dtree)
-}
-
-# plotDensityMap internal function
-# written by Liam J. Revell 2012
-
-plotDensityMap<-function(trees,...){
- if(hasArg(res)) res<-list(...)$res
- else res<-100
- if(hasArg(fsize)) fsize<-list(...)$fsize
- else fsize<-NULL
- if(hasArg(ftype)) ftype<-list(...)$ftype
- else ftype<-NULL
- if(hasArg(lwd)) lwd<-list(...)$lwd
- else lwd<-3
- if(hasArg(check)) check<-list(...)$check
- else check<-FALSE
- if(hasArg(legend)) legend<-list(...)$legend
- else legend<-NULL
- if(hasArg(outline)) outline<-list(...)$outline
- else outline<-FALSE
- densityMap(trees,res,fsize,check,legend,outline)
-}
-
-# plotContMap internal function
-# written by Liam J. Revell 2012
-
-plotContMap<-function(tree,...){
- if(hasArg(x)) x<-list(...)$x
- else stop("need to provide vector 'x' of phenotypic trait values")
- if(hasArg(res)) res<-list(...)$res
- else res<-100
- if(hasArg(fsize)) fsize<-list(...)$fsize
- else fsize<-NULL
- if(hasArg(ftype)) ftype<-list(...)$ftype
- else ftype<-NULL
- if(hasArg(lwd)) lwd<-list(...)$lwd
- else lwd<-4
- if(hasArg(legend)) legend<-list(...)$legend
- else legend<-NULL
- if(hasArg(lims)) lims<-list(...)$lims
- else lims<-NULL
- if(hasArg(outline)) outline<-list(...)$outline
- else outline<-TRUE
- if(hasArg(sig)) sig<-list(...)$sig
- else sig<-3
- contMap(tree,x,res,fsize,ftype,lwd,legend,lims,outline,sig)
-}
+# function to plot special types of phylogeny visualizations
+# so far the implemented types are:
+# "extinction" in which all branches leading to extinct taxa (or prior to the MRCA of extant species) are plotted with red dashed lines;
+# "traitgram3d" which creates a 3D graph projecting the tree into two-dimensional morphospace (with time as the third axis)
+# "droptip" creates a two panel plot with the tips to be pruned marked (panel 1) and then removed, and returns the pruned tree
+# "xkcd" creates an xkcd-comic style phylogeny [no longer an option]
+# "densitymap" maps the posterior density of a binary stochastic character mapping
+# "contmap" maps reconstructed trait evolution for a continuous character on the tree
+# "phenogram95" plots a 95% CI phenogram
+# "scattergram" plots a phylogenetic scatterplot matrix
+# written by Liam J. Revell 2012, 2013, 2014, 2015, 2016, 2017
+
+fancyTree<-function(tree,type=c("extinction","traitgram3d","droptip",
+ "densitymap","contmap","phenogram95","scattergram"),...,control=list()){
+ type<-matchType(type,c("extinction","traitgram3d","droptip","densitymap",
+ "contmap","phenogram95","scattergram"))
+ if(!inherits(tree,"phylo")&&type%in%c("extinction","traitgram3d",
+ "droptip")) stop("tree should be an object of class \"phylo\".")
+ else if(!inherits(tree,"multiSimmap")&&type=="densitymap")
+ stop("for type='densitymap' tree should be an object of class \"multiSimmap\".")
+ if(type=="extinction") extinctionTree(tree,...)
+ else if(type=="traitgram3d") invisible(traitgram3d(tree,...,control=control))
+ else if(type=="droptip") return(droptipTree(tree,...))
+ else if(type=="densitymap") plotDensityMap(tree,...)
+ else if(type=="contmap") plotContMap(tree,...)
+ else if(type=="phenogram95") phenogram95(tree,...)
+ else if(type=="scattergram") invisible(phyloScattergram(tree,...))
+ else stop(paste("do not recognize type = \"",type,"\"",sep=""))
+}
+
+## phyloScattergram internal function
+## written by Liam J. Revell 2013, 2014, 2017, 2019, 2021
+
+phyloScattergram<-function(tree,X=NULL,...){
+ if(is.null(X)) stop("phenotypic data should be provided in the matrix X")
+ if(is.data.frame(X)) X<-as.matrix(X)
+ if(hasArg(plot)) plot<-list(...)$plot
+ else plot<-TRUE
+ if(hasArg(fixed.lims)) fixed.lims<-list(...)$fixed.lims
+ else fixed.lims<-FALSE
+ if(hasArg(quiet)) quiet<-list(...)$quiet
+ else quiet<-FALSE
+ if(!quiet){
+ cat("Computing multidimensional phylogenetic scatterplot matrix...\n")
+ flush.console()
+ }
+ m<-ncol(X)
+ A<-apply(X,2,fastAnc,tree=tree)
+ cmaps<-list()
+ lims<-if(fixed.lims) range(X) else NULL
+ for(i in 1:m) cmaps[[i]]<-contMap(tree,X[,i],
+ legend=FALSE,lwd=2,outline=FALSE,plot=FALSE,
+ lims=lims)
+ if(is.null(colnames(X))) colnames(X)<-paste("V",1:m,sep="")
+ obj<-list(tree=tree,contMaps=cmaps,X=X,A=A)
+ class(obj)<-"phyloScattergram"
+ if(plot) plot(obj,...)
+ invisible(obj)
+}
+
+plot.phyloScattergram<-function(x,...){
+ if(hasArg(fsize)) fsize<-list(...)$fsize
+ else fsize<-0.7
+ if(hasArg(ftype)) ftype<-list(...)$ftype
+ else ftype<-"i"
+ if(hasArg(colors)) colors<-list(...)$colors
+ else if(!is.null(x$tree$maps))
+ colors<-setNames(palette()[1:ncol(x$tree$mapped.edge)],
+ sort(colnames(x$tree$mapped.edge)))
+ if(hasArg(label)) label<-list(...)$label
+ else label<-"radial"
+ m<-ncol(x$X)
+ dev.hold()
+ par(mfrow=c(m,m))
+ par(mar=c(0,0,0,0))
+ par(oma=c(5,5,3,3))
+ for(i in 1:m) for(j in 1:m){
+ if(i==j) plot(x$contMaps[[i]],legend=FALSE,
+ lwd=2,outline=FALSE,fsize=fsize,ftype=ftype)
+ else {
+ phylomorphospace(x$tree,x$X[,c(j,i)],A=x$A[,c(j,i)],lwd=1,
+ node.by.map=TRUE,axes=FALSE,node.size=c(0,1),
+ colors=colors,label=label,xlab="",ylab="",
+ fsize=fsize/0.7,ftype=ftype)
+ if(i==1) axis(side=3) # top row
+ if(i==m) axis(side=1) # first column
+ if(j==1) axis(side=2) # bottom row
+ if(j==m) axis(side=4) # last column
+ }
+ }
+ old.cex<-par()$cex
+ par(cex=0.9)
+ if(is.null(colnames(x$X))) colnames(x$X)<-paste("V",1:m,sep="")
+ invisible(mapply(title,xlab=colnames(x$X),
+ adj=seq(0,(m-1)/m,1/m)+1/(2*m),MoreArgs=list(outer=TRUE,cex=0.9)))
+ invisible(mapply(title,ylab=colnames(x$X)[m:1],
+ adj=seq(0,(m-1)/m,1/m)+1/(2*m),MoreArgs=list(outer=TRUE,cex=0.9)))
+ dev.flush()
+ par(cex=old.cex)
+}
+
+print.phyloScattergram<-function(x,...){
+ cat(paste("\nObject of class \"phyloScattergram\" for",ncol(x$X),
+ "continuous traits.\n"))
+ cat("To replot enter \"plot(object_name)\" at the prompt.\n\n")
+}
+
+## phenogram95 internal function
+## written by Liam J. Revell 2013, 2014, 2019
+
+phenogram95<-function(tree,x=NULL,...){
+ if(is.null(x)) stop("no phenotypic data provided")
+ if(hasArg(spread.labels)) spread.labels<-list(...)$spread.labels
+ else spread.labels<-TRUE
+ if(hasArg(link)) link<-list(...)$link
+ else link<-0.05*max(nodeHeights(tree))
+ if(hasArg(offset)) offset<-list(...)$offset
+ else offset<-0
+ if(hasArg(hold)) hold<-list(...)$hold
+ else hold<-TRUE
+ if(hasArg(quiet)) quiet<-list(...)$quiet
+ else quiet<-FALSE
+ # get ancestral states
+ A<-fastAnc(tree,x,CI=TRUE)
+ # compute transparencies
+ if(hasArg(tlim)) tlim<-list(...)$tlim
+ else tlim<-c(0,25)
+ trans<-as.character(floor(seq(tlim[1],tlim[2],length.out=51)))
+ trans[as.numeric(trans)<10]<-paste("0", trans[as.numeric(trans)<10],sep="")
+ # now get the arguments for phenogram
+ args<-list(...)
+ args$tree<-tree
+ args$lwd<-1
+ args$link<-0.05*max(nodeHeights(tree))
+ args$offset<-0
+ if(hold) null<-dev.hold()
+ if(!quiet&&hold){
+ cat("Computing density traitgram...\n")
+ flush.console()
+ }
+ for(i in 0:50){
+ p<-i/length(trans)
+ args$add<-i>0
+ args$spread.labels<-if(i==0) spread.labels else FALSE
+ args$link<-if(i==0) link else 0
+ args$offset<-if(i==0) offset else offset+link
+ args$x<-c(x,(1-p)*A$CI95[,1]+p*A$ace)
+ args$colors<-paste("#0000ff",trans[i+1],sep="")
+ do.call(phenogram,args)
+ args$x<-c(x,(1-p)*A$CI95[,2]+p*A$ace)
+ args$add<-TRUE
+ args$spread.labels<-FALSE
+ args$link<-0
+ args$offset<-offset+link
+ do.call(phenogram,args)
+ }
+ args$x<-c(x,A$ace)
+ args$add<-TRUE
+ args$colors<-"white"
+ args$lwd<-2
+ args$offset<-offset+link
+ do.call(phenogram,args)
+ null<-dev.flush()
+}
+
+## extinctionTree internal function
+## written by Liam J. Revell 2012, 2019
+
+extinctionTree<-function(tree,...){
+ if(hasArg(fsize)) fsize<-list(...)$fsize
+ else fsize<-1
+ if(hasArg(ftype)) ftype<-list(...)$ftype
+ else ftype<-"i"
+ if(hasArg(lwd)) lwd<-list(...)$lwd
+ else lwd<-2
+ if(hasArg(colors)) colors<-list(...)$colors
+ else colors<-palette()[1:2]
+ ftype<-which(c("off","reg","b","i","bi")==ftype)-1
+ if(!ftype) fsize=0.1
+ edges<-rep(0,nrow(tree$edge))
+ names(edges)<-tree$edge[,2]
+ extant<-getExtant(tree)
+ ca<-findMRCA(tree,extant)
+ root.node<-length(tree$tip)+1
+ if(ca!=root.node){
+ z<-setdiff(getDescendants(tree,root.node),
+ getDescendants(tree,ca))
+ edges[as.character(z)]<-1
+ }
+ z<-getDescendants(tree,ca)
+ y<-lapply(z,getDescendants,tree=tree)
+ for(i in 1:length(z))
+ if(!any(tree$tip.label[y[[i]]]%in%extant))
+ edges[as.character(z[i])]<-1
+ ape::plot.phylo(tree,edge.color=colors[edges+1],edge.lty=edges+1,
+ edge.width=lwd,no.margin=TRUE,cex=fsize,
+ show.tip.label=if(ftype==0) FALSE else TRUE,
+ font=ftype)
+}
+
+# traitgram3d internal function
+# written by Liam J. Revell 2012, 2013
+
+traitgram3d<-function(tree,...,control){
+ if(hasArg(X)) X<-list(...)$X
+ else stop("no phenotypic data provided")
+ if(!hasArg(A)){
+ if(is.null(control$maxit)) maxit<-2000
+ else maxit<-control$maxit
+ Y<-apply(X,2,function(x,tree) anc.ML(tree,x,maxit),tree=tree)
+ convergence<-sapply(Y,function(x) x$convergence)
+ if(any(convergence!=0)) warning("anc.ML may not have converged; consider increasing maxit.")
+ A<-sapply(Y,function(x) x$ace)
+ } else {
+ A<-list(...)$A
+ A<-A[as.character(1:tree$Nnode+length(tree$tip)),]
+ }
+ if(is.null(colnames(X))) colnames(X)<-c("x","y")
+ X<-cbind(X,diag(vcv(tree))[rownames(X)])
+ A<-cbind(A,nodeHeights(tree)[match(rownames(A)[1:nrow(A)],tree$edge)])
+ colnames(X)[3]<-colnames(A)[3]<-"time"
+ # other optional arguments
+ if(hasArg(method)) method<-list(...)$method
+ else method<-"dynamic"
+ if(hasArg(angle)) angle<-list(...)$angle
+ else angle<-30
+ # done other optional arguments
+ xx<-phylomorphospace3d(tree,X,A,control=control,method=method,
+ angle=angle,zlim=range(nodeHeights(tree)))
+ return(xx)
+}
+
+# droptipTree internal function
+# written by Liam J. Revell 2012, 2020 (just to fix a couple of dumb bugs)
+
+droptipTree<-function(tree,...){
+ if(hasArg(tip)) tip<-list(...)$tip
+ else stop("need to provide tip or tips to drop")
+ if(hasArg(cex)) cex<-list(...)$cex
+ else cex<-0.7
+ edges<-rep(0,nrow(tree$edge))
+ names(edges)<-tree$edge[,2]
+ keep<-setdiff(tree$tip.label,tip)
+ ca<-findMRCA(tree,keep)
+ root.node<-length(tree$tip)+1
+ if(ca!=root.node){
+ z<-setdiff(getDescendants(tree,root.node),
+ getDescendants(tree,ca))
+ edges[as.character(z)]<-1
+ }
+ z<-getDescendants(tree,ca)
+ foo<-function(x,tree){
+ n<-length(tree$tip.label)
+ y<-getDescendants(tree,x)
+ y<-y[y<=n]
+ return(y)
+ }
+ y<-lapply(z,foo,tree=tree)
+ for(i in 1:length(z)) if(!any(tree$tip.label[y[[i]]]%in%keep))
+ edges[as.character(z[i])]<-1
+ par(mfrow=c(2,1))
+ plot.phylo(tree,edge.color=edges+1,edge.lty=edges+1,
+ edge.width=2,no.margin=TRUE,cex=cex)
+ xlim<-get("last_plot.phylo",envir=.PlotPhyloEnv)$x.lim
+ dtree<-drop.tip(tree,tip)
+ dtree$root.edge<-max(nodeHeights(tree))-max(nodeHeights(dtree))
+ plot.phylo(rootedge.to.singleton(dtree),edge.width=2,
+ no.margin=TRUE,cex=cex,x.lim=xlim)
+ return(dtree)
+}
+
+# plotDensityMap internal function
+# written by Liam J. Revell 2012
+
+plotDensityMap<-function(trees,...){
+ if(hasArg(res)) res<-list(...)$res
+ else res<-100
+ if(hasArg(fsize)) fsize<-list(...)$fsize
+ else fsize<-NULL
+ if(hasArg(ftype)) ftype<-list(...)$ftype
+ else ftype<-NULL
+ if(hasArg(lwd)) lwd<-list(...)$lwd
+ else lwd<-3
+ if(hasArg(check)) check<-list(...)$check
+ else check<-FALSE
+ if(hasArg(legend)) legend<-list(...)$legend
+ else legend<-NULL
+ if(hasArg(outline)) outline<-list(...)$outline
+ else outline<-FALSE
+ densityMap(trees,res,fsize,check,legend,outline)
+}
+
+# plotContMap internal function
+# written by Liam J. Revell 2012
+
+plotContMap<-function(tree,...){
+ if(hasArg(x)) x<-list(...)$x
+ else stop("need to provide vector 'x' of phenotypic trait values")
+ if(hasArg(res)) res<-list(...)$res
+ else res<-100
+ if(hasArg(fsize)) fsize<-list(...)$fsize
+ else fsize<-NULL
+ if(hasArg(ftype)) ftype<-list(...)$ftype
+ else ftype<-NULL
+ if(hasArg(lwd)) lwd<-list(...)$lwd
+ else lwd<-4
+ if(hasArg(legend)) legend<-list(...)$legend
+ else legend<-NULL
+ if(hasArg(lims)) lims<-list(...)$lims
+ else lims<-NULL
+ if(hasArg(outline)) outline<-list(...)$outline
+ else outline<-TRUE
+ if(hasArg(sig)) sig<-list(...)$sig
+ else sig<-3
+ contMap(tree,x,res,fsize,ftype,lwd,legend,lims,outline,sig)
+}
diff --git a/R/fastAnc.R b/R/fastAnc.R
index ad2e110..547a301 100644
--- a/R/fastAnc.R
+++ b/R/fastAnc.R
@@ -1,95 +1,95 @@
-## function does fast estimation of ML ancestral states using ace
-## written by Liam J. Revell 2012, 2013, 2015, 2019, 2020, 2021
-
-fastAnc<-function(tree,x,vars=FALSE,CI=FALSE,...){
- if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".")
- if(length(class(tree)>1)) class(tree)<-"phylo"
- if(hasArg(anc.states)) anc.states<-list(...)$anc.states
- else anc.states<-NULL
- if(!is.null(anc.states)){
- nodes<-as.numeric(names(anc.states))
- tt<-tree
- for(i in 1:length(nodes)){
- M<-matchNodes(tt,tree,method="distances",quiet=TRUE)
- ii<-M[which(M[,2]==nodes[i]),1]
- tt<-bind.tip(tt,nodes[i],edge.length=0,where=ii)
- }
- x<-c(x,anc.states)
- } else tt<-tree
- if(!is.binary(tt)) btree<-multi2di(tt,random=FALSE)
- else btree<-tt
- M<-btree$Nnode
- N<-length(btree$tip.label)
- anc<-v<-vector()
- for(i in 1:M+N){
- a<-collapse.singles(multi2di(ape::root.phylo(btree,node=i),random=FALSE))
- anc[i-N]<-ace(x,a,method="pic")$ace[1]
- names(anc)[i-N]<-i
- if(vars||CI){
- picx<-pic(x,a,rescaled.tree=TRUE)
- b<-picx$rescaled.tree
- d<-which(b$edge[,1]==(length(b$tip.label)+1))
- v[i-N]<-(1/b$edge.length[d[1]]+1/b$edge.length[d[2]])^(-1)*mean(picx$contr^2)
- names(v)[i-N]<-names(anc)[i-N]
- }
- }
- if(!is.binary(tree)||!is.null(anc.states)){
- ancNames<-matchNodes(tree,btree,method="distances",quiet=TRUE)
- anc<-anc[as.character(ancNames[,2])]
- names(anc)<-ancNames[,1]
- if(vars||CI){
- v<-v[as.character(ancNames[,2])]
- names(v)<-ancNames[,1]
- }
- }
- obj<-list(ace=anc)
- if(vars) obj$var<-v
- if(CI){
- obj$CI95<-cbind(anc-1.96*sqrt(v),anc+1.96*sqrt(v))
- rownames(obj$CI95)<-names(anc)
- }
- if(length(obj)==1) obj<-obj$ace
- class(obj)<-"fastAnc"
- obj
-}
-
-## print method for "fastAnc"
-## written by Liam J. Revell 2015
-print.fastAnc<-function(x,digits=6,printlen=NULL,...){
- cat("Ancestral character estimates using fastAnc:\n")
- if(!is.list(x)){
- if(is.null(printlen)||printlen>=length(x)) print(round(unclass(x),digits))
- else printDotDot(unclass(x),digits,printlen)
- } else {
- Nnode<-length(x$ace)
- if(is.null(printlen)||printlen>=Nnode) print(round(x$ace,digits))
- else printDotDot(x$ace,digits,printlen)
- if(!is.null(x$var)){
- cat("\nVariances on ancestral states:\n")
- if(is.null(printlen)||printlen>=Nnode) print(round(x$var,digits))
- else printDotDot(x$var,digits,printlen)
- }
- if(!is.null(x$CI95)){
- cat("\nLower & upper 95% CIs:\n")
- colnames(x$CI95)<-c("lower","upper")
- if(is.null(printlen)||printlen>=Nnode) print(round(x$CI95,digits))
- else printDotDot(x$CI95,digits,printlen)
- }
- }
- cat("\n")
-}
-
-## internal function
-## written by Liam J. Revell 2015
-printDotDot<-function(x,digits,printlen){
- if(is.vector(x)){
- x<-as.data.frame(t(as.matrix(unclass(round(x[1:printlen],digits)))))
- x<-cbind(x,"....")
- rownames(x)<-""
- colnames(x)[printlen+1]<-""
- print(x)
- } else if(is.matrix(x)){
- x<-as.data.frame(rbind(round(x[1:printlen,],digits),c("....","....")))
- print(x)
- }
-}
+## function does fast estimation of ML ancestral states using ace
+## written by Liam J. Revell 2012, 2013, 2015, 2019, 2020, 2021
+
+fastAnc<-function(tree,x,vars=FALSE,CI=FALSE,...){
+ if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".")
+ if(length(class(tree)>1)) class(tree)<-"phylo"
+ if(hasArg(anc.states)) anc.states<-list(...)$anc.states
+ else anc.states<-NULL
+ if(!is.null(anc.states)){
+ nodes<-as.numeric(names(anc.states))
+ tt<-tree
+ for(i in 1:length(nodes)){
+ M<-matchNodes(tt,tree,method="distances",quiet=TRUE)
+ ii<-M[which(M[,2]==nodes[i]),1]
+ tt<-bind.tip(tt,nodes[i],edge.length=0,where=ii)
+ }
+ x<-c(x,anc.states)
+ } else tt<-tree
+ if(!is.binary(tt)) btree<-multi2di(tt,random=FALSE)
+ else btree<-tt
+ M<-btree$Nnode
+ N<-length(btree$tip.label)
+ anc<-v<-vector()
+ for(i in 1:M+N){
+ a<-collapse.singles(multi2di(ape::root.phylo(btree,node=i),random=FALSE))
+ anc[i-N]<-ace(x,a,method="pic")$ace[1]
+ names(anc)[i-N]<-i
+ if(vars||CI){
+ picx<-pic(x,a,rescaled.tree=TRUE)
+ b<-picx$rescaled.tree
+ d<-which(b$edge[,1]==(length(b$tip.label)+1))
+ v[i-N]<-(1/b$edge.length[d[1]]+1/b$edge.length[d[2]])^(-1)*mean(picx$contr^2)
+ names(v)[i-N]<-names(anc)[i-N]
+ }
+ }
+ if(!is.binary(tree)||!is.null(anc.states)){
+ ancNames<-matchNodes(tree,btree,method="distances",quiet=TRUE)
+ anc<-anc[as.character(ancNames[,2])]
+ names(anc)<-ancNames[,1]
+ if(vars||CI){
+ v<-v[as.character(ancNames[,2])]
+ names(v)<-ancNames[,1]
+ }
+ }
+ obj<-list(ace=anc)
+ if(vars) obj$var<-v
+ if(CI){
+ obj$CI95<-cbind(anc-1.96*sqrt(v),anc+1.96*sqrt(v))
+ rownames(obj$CI95)<-names(anc)
+ }
+ if(length(obj)==1) obj<-obj$ace
+ class(obj)<-"fastAnc"
+ obj
+}
+
+## print method for "fastAnc"
+## written by Liam J. Revell 2015
+print.fastAnc<-function(x,digits=6,printlen=NULL,...){
+ cat("Ancestral character estimates using fastAnc:\n")
+ if(!is.list(x)){
+ if(is.null(printlen)||printlen>=length(x)) print(round(unclass(x),digits))
+ else printDotDot(unclass(x),digits,printlen)
+ } else {
+ Nnode<-length(x$ace)
+ if(is.null(printlen)||printlen>=Nnode) print(round(x$ace,digits))
+ else printDotDot(x$ace,digits,printlen)
+ if(!is.null(x$var)){
+ cat("\nVariances on ancestral states:\n")
+ if(is.null(printlen)||printlen>=Nnode) print(round(x$var,digits))
+ else printDotDot(x$var,digits,printlen)
+ }
+ if(!is.null(x$CI95)){
+ cat("\nLower & upper 95% CIs:\n")
+ colnames(x$CI95)<-c("lower","upper")
+ if(is.null(printlen)||printlen>=Nnode) print(round(x$CI95,digits))
+ else printDotDot(x$CI95,digits,printlen)
+ }
+ }
+ cat("\n")
+}
+
+## internal function
+## written by Liam J. Revell 2015
+printDotDot<-function(x,digits,printlen){
+ if(is.vector(x)){
+ x<-as.data.frame(t(as.matrix(unclass(round(x[1:printlen],digits)))))
+ x<-cbind(x,"....")
+ rownames(x)<-""
+ colnames(x)[printlen+1]<-""
+ print(x)
+ } else if(is.matrix(x)){
+ x<-as.data.frame(rbind(round(x[1:printlen,],digits),c("....","....")))
+ print(x)
+ }
+}
diff --git a/R/fitBayes.R b/R/fitBayes.R
index 9153d95..a80dc77 100644
--- a/R/fitBayes.R
+++ b/R/fitBayes.R
@@ -1,108 +1,108 @@
-# this function calls various MCMC methods
-# written by Liam J. Revell 2011, 2015, 2017
-
-fitBayes<-function(tree,x,ngen=10000,model="BM",method="reduced",control=list()){
- if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".")
- if(model=="BM"){
- if(method=="reduced")
- X<-mcmcBM(tree,x,ngen,control)
- else if(method=="full")
- X<-mcmcBM.full(tree,x,ngen,control)
- else
- stop("This is not a recognized method for model='BM'.")
- } else if(model=="lambda"){
- if(method=="reduced")
- X<-mcmcLambda(tree,x,ngen,control)
- else if(method=="full")
- stop("This method is not yet implmented for model='lambda'.")
- else
- stop("This is not a recognized method for model='lambda'.")
- } else
- stop("This is not a recognized model.")
- obj<-list(mcmc=as.data.frame(X),model=model,method=method,tree=tree)
- class(obj)<-"fitBayes"
- obj
-}
-
-## S3 methods for the object class
-
-print.fitBayes<-function(x,digits=6,...){
- if(hasArg(burnin)) burnin<-list(...)$burnin
- else burnin<-0.2*max(x$mcmc$gen)
- ii<-which(((x$mcmc$gen-burnin)^2)==min((x$mcmc$gen-burnin)^2))+1
- cat("\nObject of class \"fitBayes\" which consists of a posterior sample")
- cat("\n(in component \'mcmc\') from a Bayesian MCMC of the model presented")
- cat("\nin Revell & Reynolds (2012; Evolution).\n\n")
- cat("Object summary:\n")
- cat(paste("\tgenerations of MCMC: ",max(x$mcmc$gen),".\n",sep=""))
- cat(paste("\tsample interval: ",x$mcmc$gen[3]-x$mcmc$gen[2],".\n",sep=""))
- cat(paste("\tmean sigma^2 from posterior sample: ",
- round(mean(x$mcmc$sig2[ii:nrow(x$mcmc)]),6),".\n",sep=""))
- if(x$model=="lambda") cat(paste("\tmean lambda from posterior sample: ",
- round(mean(x$mcmc$lambda[ii:nrow(x$mcmc)]),6),".\n",sep=""))
- cat(paste("\nCalculations based on burn-in of",burnin,"generations.\n"))
- cat("\n")
-}
-
-plot.fitBayes<-function(x,...){
- args<-list(...)
- if(is.null(args$what)) what<-"logLik"
- else {
- what<-args$what
- args$what<-NULL
- }
- if(is.null(args$burnin)) burnin<-0.2*max(x$mcmc$gen)
- else {
- burnin<-args$burnin
- args$burnin<-NULL
- }
- if(what=="logLik"){
- args$x<-x$mcmc$gen
- args$y<-x$mcmc$logLik
- if(is.null(args$xlab)) args$xlab<-"generation"
- if(is.null(args$ylab)) args$ylab<-"log(L)"
- if(is.null(args$type)) args$type<-"l"
- if(is.null(args$col)) args$col<-make.transparent("blue",0.5)
- do.call(plot,args)
- } else if(what=="sig2"){
- ii<-which(((x$mcmc$gen-burnin)^2)==min((x$mcmc$gen-burnin)^2))+1
- if(is.null(args$bw)) bw<-0.05*diff(range(x$mcmc$sig2[ii:nrow(x$mcmc)]))
- else {
- bw<-args$bw
- args$bw<-NULL
- }
- d<-density(x$mcmc$sig2[ii:nrow(x$mcmc)],bw=bw)
- args$x<-d$x
- args$y<-d$y
- if(is.null(args$xlab)) args$xlab<-expression(paste("posterior distribution of ",sigma^2))
- if(is.null(args$ylab)) args$ylab<-"density"
- if(is.null(args$main)) args$main<-""
- if(is.null(args$type)) args$type<-"l"
- if(is.null(args$col)) args$col<-"blue"
- do.call(plot,args)
- polygon(x=c(min(d$x),d$x,max(d$x)),y=c(0,d$y,0),
- col=make.transparent(args$col,0.2),border=NA)
- } else if(what=="lambda"){
- if(x$model!="lambda") stop("Model of \"fitBayes\" object is not \"lambda\".")
- else {
- ii<-which(((x$mcmc$gen-burnin)^2)==min((x$mcmc$gen-burnin)^2))+1
- if(is.null(args$bw)) bw<-0.05*diff(range(x$mcmc$lambda[ii:nrow(x$mcmc)]))
- else {
- bw<-args$bw
- args$bw<-NULL
- }
- d<-density(x$mcmc$lambda[ii:nrow(x$mcmc)],bw=bw)
- args$x<-d$x
- args$y<-d$y
- if(is.null(args$xlab)) args$xlab<-expression(paste("posterior distribution of ",lambda))
- if(is.null(args$ylab)) args$ylab<-"density"
- if(is.null(args$main)) args$main<-""
- if(is.null(args$type)) args$type<-"l"
- if(is.null(args$col)) args$col<-"blue"
- do.call(plot,args)
- polygon(x=c(min(d$x),d$x,max(d$x)),y=c(0,d$y,0),
- col=make.transparent(args$col,0.2),border=NA)
- }
- }
-}
-
+# this function calls various MCMC methods
+# written by Liam J. Revell 2011, 2015, 2017
+
+fitBayes<-function(tree,x,ngen=10000,model="BM",method="reduced",control=list()){
+ if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".")
+ if(model=="BM"){
+ if(method=="reduced")
+ X<-mcmcBM(tree,x,ngen,control)
+ else if(method=="full")
+ X<-mcmcBM.full(tree,x,ngen,control)
+ else
+ stop("This is not a recognized method for model='BM'.")
+ } else if(model=="lambda"){
+ if(method=="reduced")
+ X<-mcmcLambda(tree,x,ngen,control)
+ else if(method=="full")
+ stop("This method is not yet implmented for model='lambda'.")
+ else
+ stop("This is not a recognized method for model='lambda'.")
+ } else
+ stop("This is not a recognized model.")
+ obj<-list(mcmc=as.data.frame(X),model=model,method=method,tree=tree)
+ class(obj)<-"fitBayes"
+ obj
+}
+
+## S3 methods for the object class
+
+print.fitBayes<-function(x,digits=6,...){
+ if(hasArg(burnin)) burnin<-list(...)$burnin
+ else burnin<-0.2*max(x$mcmc$gen)
+ ii<-which(((x$mcmc$gen-burnin)^2)==min((x$mcmc$gen-burnin)^2))+1
+ cat("\nObject of class \"fitBayes\" which consists of a posterior sample")
+ cat("\n(in component \'mcmc\') from a Bayesian MCMC of the model presented")
+ cat("\nin Revell & Reynolds (2012; Evolution).\n\n")
+ cat("Object summary:\n")
+ cat(paste("\tgenerations of MCMC: ",max(x$mcmc$gen),".\n",sep=""))
+ cat(paste("\tsample interval: ",x$mcmc$gen[3]-x$mcmc$gen[2],".\n",sep=""))
+ cat(paste("\tmean sigma^2 from posterior sample: ",
+ round(mean(x$mcmc$sig2[ii:nrow(x$mcmc)]),6),".\n",sep=""))
+ if(x$model=="lambda") cat(paste("\tmean lambda from posterior sample: ",
+ round(mean(x$mcmc$lambda[ii:nrow(x$mcmc)]),6),".\n",sep=""))
+ cat(paste("\nCalculations based on burn-in of",burnin,"generations.\n"))
+ cat("\n")
+}
+
+plot.fitBayes<-function(x,...){
+ args<-list(...)
+ if(is.null(args$what)) what<-"logLik"
+ else {
+ what<-args$what
+ args$what<-NULL
+ }
+ if(is.null(args$burnin)) burnin<-0.2*max(x$mcmc$gen)
+ else {
+ burnin<-args$burnin
+ args$burnin<-NULL
+ }
+ if(what=="logLik"){
+ args$x<-x$mcmc$gen
+ args$y<-x$mcmc$logLik
+ if(is.null(args$xlab)) args$xlab<-"generation"
+ if(is.null(args$ylab)) args$ylab<-"log(L)"
+ if(is.null(args$type)) args$type<-"l"
+ if(is.null(args$col)) args$col<-make.transparent("blue",0.5)
+ do.call(plot,args)
+ } else if(what=="sig2"){
+ ii<-which(((x$mcmc$gen-burnin)^2)==min((x$mcmc$gen-burnin)^2))+1
+ if(is.null(args$bw)) bw<-0.05*diff(range(x$mcmc$sig2[ii:nrow(x$mcmc)]))
+ else {
+ bw<-args$bw
+ args$bw<-NULL
+ }
+ d<-density(x$mcmc$sig2[ii:nrow(x$mcmc)],bw=bw)
+ args$x<-d$x
+ args$y<-d$y
+ if(is.null(args$xlab)) args$xlab<-expression(paste("posterior distribution of ",sigma^2))
+ if(is.null(args$ylab)) args$ylab<-"density"
+ if(is.null(args$main)) args$main<-""
+ if(is.null(args$type)) args$type<-"l"
+ if(is.null(args$col)) args$col<-"blue"
+ do.call(plot,args)
+ polygon(x=c(min(d$x),d$x,max(d$x)),y=c(0,d$y,0),
+ col=make.transparent(args$col,0.2),border=NA)
+ } else if(what=="lambda"){
+ if(x$model!="lambda") stop("Model of \"fitBayes\" object is not \"lambda\".")
+ else {
+ ii<-which(((x$mcmc$gen-burnin)^2)==min((x$mcmc$gen-burnin)^2))+1
+ if(is.null(args$bw)) bw<-0.05*diff(range(x$mcmc$lambda[ii:nrow(x$mcmc)]))
+ else {
+ bw<-args$bw
+ args$bw<-NULL
+ }
+ d<-density(x$mcmc$lambda[ii:nrow(x$mcmc)],bw=bw)
+ args$x<-d$x
+ args$y<-d$y
+ if(is.null(args$xlab)) args$xlab<-expression(paste("posterior distribution of ",lambda))
+ if(is.null(args$ylab)) args$ylab<-"density"
+ if(is.null(args$main)) args$main<-""
+ if(is.null(args$type)) args$type<-"l"
+ if(is.null(args$col)) args$col<-"blue"
+ do.call(plot,args)
+ polygon(x=c(min(d$x),d$x,max(d$x)),y=c(0,d$y,0),
+ col=make.transparent(args$col,0.2),border=NA)
+ }
+ }
+}
+
diff --git a/R/fitDiversityModel.R b/R/fitDiversityModel.R
index a887d95..0c16326 100644
--- a/R/fitDiversityModel.R
+++ b/R/fitDiversityModel.R
@@ -1,150 +1,150 @@
-## this function fits a "diversity-dependent-evolutionary-diversification"
-## model (similar to Mahler et al. 2010)
-## written by Liam Revell, 2010/2011/2012, 2019
-
-fitDiversityModel<-function(tree,x,d=NULL,showTree=TRUE,tol=1e-6){
- # some minor error checking
- if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".")
- if(is.data.frame(x)) x<-as.matrix(x)
- if(is.matrix(x)) x<-x[,1]
- if(is.null(names(x))){
- if(length(x)==length(tree$tip)){
- message("x has no names; assuming x is in the same order as tree$tip.label")
- names(x)<-tree$tip.label
- } else
- stop("x has no names and is a different length than tree$tip.label")
- }
- if(any(is.na(match(tree$tip.label,names(x))))){
- message("some species in tree are missing from data, dropping missing taxa from the tree")
- tree<-drop.tip(tree,tree$tip.label[-match(names(x),tree$tip.label)])
- }
- if(any(is.na(match(names(x),tree$tip.label)))){
- message("some species in data are missing from tree, dropping missing taxa from the data")
- x<-x[tree$tip.label]
- }
- if(any(is.na(x))){
- message("some data given as 'NA', dropping corresponding species from tree")
- tree<-drop.tip(tree,names(which(is.na(x))))
- }
- if(!is.null(d)){
- if(is.data.frame(d)) d<-as.matrix(d)
- if(is.matrix(d)) d<-d[,1]
- if(is.null(names(d))){
- if(length(d)==tree$Nnode){
- message("d has no names; assuming d is in node number order of the resolved tree")
- names(d)<-c(length(tree$tip)+tol:tree$Nnode)
- } else
- stop("d has no names and is a different length than tree$Nnode for the resolved tree")
- }
- } else {
- message("no values for lineage density provided; computing assuming single biogeographic region")
- # compute lineage diversity at each node
- ages<-branching.times(tree)
- d<-vector()
- for(i in 1:length(ages)) d[i]<-sum(ages>ages[i])
- names(d)<-names(ages)
- }
- maxd<-max(d)
- d<-d/(maxd+tol)
- # likelihood function
- lik<-function(theta,y,phy,diversity){
- scaled.psi<-theta
- for(i in 1:nrow(phy$edge)){
- vi<-phy$edge.length[i]
- phy$edge.length[i]<-vi+vi*scaled.psi*
- diversity[as.character(phy$edge[i,1])]
- }
- D<-vcv(phy)
- D<-D[names(y),names(y)]
- Dinv<-solve(D)
- a<-as.numeric(colSums(Dinv)%*%y/sum(Dinv))
- sig0<-as.numeric(t(y-a)%*%Dinv%*%(y-a)/nrow(D))
- Dinv<-Dinv/sig0; D<-D*sig0
- logL<-as.numeric(-t(y-a)%*%Dinv%*%(y-a)/2-
- determinant(D)$modulus[1]/2-length(y)*log(2*pi)/2)
- if(showTree) plot(phy)
- return(logL)
- }
- # optimize
- res<-optimize(lik,c(-1,1),y=x,phy=tree,diversity=d,
- maximum=TRUE)
- # compute condition sig0
- compute_sig0<-function(scaled.psi,y,phy,diversity){
- for(i in 1:nrow(phy$edge)){
- vi<-phy$edge.length[i]
- phy$edge.length[i]<-vi+vi*scaled.psi*
- diversity[as.character(phy$edge[i,1])]
- }
- D<-vcv(phy)
- D<-D[names(y),names(y)]
- Dinv<-solve(D)
- a<-as.numeric(colSums(Dinv)%*%y/sum(Dinv))
- sig0<-as.numeric(t(y-a)%*%Dinv%*%(y-a)/nrow(D))
- return(sig0)
- }
- sig0=compute_sig0(res$maximum,x,tree,d)
- # compute the Hessian
- compute_Hessian<-function(scaled.psi,sig0,y,phy,d,maxd){
- psi<-scaled.psi*sig0/(maxd+tol)
- likHessian<-function(theta,y,phy,d,maxd){
- sig0<-theta[1]
- psi<-theta[2]
- for(i in 1:nrow(phy$edge)){
- vi<-phy$edge.length[i]
- phy$edge.length[i]<-vi*(sig0+psi*d[as.character(phy$edge[i,
- 1])]*(maxd+tol))
- }
- D<-vcv(phy)
- D<-D[names(y),names(y)]
- Dinv<-solve(D)
- a<-as.numeric(colSums(Dinv)%*%y/sum(Dinv))
- logL<-as.numeric(-t(y-a)%*%Dinv%*%(y-a)/2-determinant(D)$modulus[1]/2-
- length(y)*log(2*pi)/2)
- return(logL)
- }
- H<-hessian(likHessian,c(sig0,psi),y=y,phy=phy,d=d,maxd=maxd)
- return(H)
- }
- H<-compute_Hessian(res$maximum,sig0,x,tree,d,maxd)
- # return results to user
- if(var(d)>0){
- object<-list(logL=res$objective,sig0=sig0,psi=sig0*res$maximum/(maxd+tol),
- vcv=matrix(solve(-H),2,2,dimnames=list(c("sig0","psi"),c("sig0","psi"))))
- class(object)<-"fitDiversityModel"
- return(object)
- } else {
- message("psi not estimable because diversity is constant through time.")
- object<-list(logL=res$objective,sig0=sig0,vcv=matrix(-1/H[1,1],1,1,
- dimnames=list(c("sig0"),c("sig0"))))
- class(object)<-"fitDiversityModel"
- return(object)
- }
-}
-
-print.fitDiversityModel<-function(x,...){
- if(hasArg(digits)) digits<-list(...)$digits
- else digits<-5
- if(is.null(x$psi)){
- cat("Fitted diversity-independent evolution model:\n")
- cat("\tsig2(0)\tSE\tlog(L)\n")
- cat(paste("value\t",round(x$sig0,digits),"\t",
- round(sqrt(x$vcv[1,1]),digits),"\t",
- round(logLik(x),digits),"\n\n",sep=""))
- } else {
- cat("Fitted diversity-dependent evolution model:\n")
- cat("\tsig2(0)\tSE\tpsi\tSE\tlog(L)\n")
- cat(paste("value\t",round(x$sig0,digits),"\t",
- round(sqrt(x$vcv[1,1]),digits),"\t",
- round(x$psi,digits),"\t",
- round(sqrt(x$vcv[2,2]),digits),"\t",
- round(logLik(x),digits),"\n\n",sep=""))
- }
-}
-
-logLik.fitDiversityModel<-function(object,...){
- if(hasArg(df)) df<-list(...)$df
- else df<-if(is.null(object$psi)) 2 else 3
- lik<-object$logL
- attr(lik,"df")<-df
- lik
-}
+## this function fits a "diversity-dependent-evolutionary-diversification"
+## model (similar to Mahler et al. 2010)
+## written by Liam Revell, 2010/2011/2012, 2019
+
+fitDiversityModel<-function(tree,x,d=NULL,showTree=TRUE,tol=1e-6){
+ # some minor error checking
+ if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".")
+ if(is.data.frame(x)) x<-as.matrix(x)
+ if(is.matrix(x)) x<-x[,1]
+ if(is.null(names(x))){
+ if(length(x)==length(tree$tip)){
+ message("x has no names; assuming x is in the same order as tree$tip.label")
+ names(x)<-tree$tip.label
+ } else
+ stop("x has no names and is a different length than tree$tip.label")
+ }
+ if(any(is.na(match(tree$tip.label,names(x))))){
+ message("some species in tree are missing from data, dropping missing taxa from the tree")
+ tree<-drop.tip(tree,tree$tip.label[-match(names(x),tree$tip.label)])
+ }
+ if(any(is.na(match(names(x),tree$tip.label)))){
+ message("some species in data are missing from tree, dropping missing taxa from the data")
+ x<-x[tree$tip.label]
+ }
+ if(any(is.na(x))){
+ message("some data given as 'NA', dropping corresponding species from tree")
+ tree<-drop.tip(tree,names(which(is.na(x))))
+ }
+ if(!is.null(d)){
+ if(is.data.frame(d)) d<-as.matrix(d)
+ if(is.matrix(d)) d<-d[,1]
+ if(is.null(names(d))){
+ if(length(d)==tree$Nnode){
+ message("d has no names; assuming d is in node number order of the resolved tree")
+ names(d)<-c(length(tree$tip)+tol:tree$Nnode)
+ } else
+ stop("d has no names and is a different length than tree$Nnode for the resolved tree")
+ }
+ } else {
+ message("no values for lineage density provided; computing assuming single biogeographic region")
+ # compute lineage diversity at each node
+ ages<-branching.times(tree)
+ d<-vector()
+ for(i in 1:length(ages)) d[i]<-sum(ages>ages[i])
+ names(d)<-names(ages)
+ }
+ maxd<-max(d)
+ d<-d/(maxd+tol)
+ # likelihood function
+ lik<-function(theta,y,phy,diversity){
+ scaled.psi<-theta
+ for(i in 1:nrow(phy$edge)){
+ vi<-phy$edge.length[i]
+ phy$edge.length[i]<-vi+vi*scaled.psi*
+ diversity[as.character(phy$edge[i,1])]
+ }
+ D<-vcv(phy)
+ D<-D[names(y),names(y)]
+ Dinv<-solve(D)
+ a<-as.numeric(colSums(Dinv)%*%y/sum(Dinv))
+ sig0<-as.numeric(t(y-a)%*%Dinv%*%(y-a)/nrow(D))
+ Dinv<-Dinv/sig0; D<-D*sig0
+ logL<-as.numeric(-t(y-a)%*%Dinv%*%(y-a)/2-
+ determinant(D)$modulus[1]/2-length(y)*log(2*pi)/2)
+ if(showTree) plot(phy)
+ return(logL)
+ }
+ # optimize
+ res<-optimize(lik,c(-1,1),y=x,phy=tree,diversity=d,
+ maximum=TRUE)
+ # compute condition sig0
+ compute_sig0<-function(scaled.psi,y,phy,diversity){
+ for(i in 1:nrow(phy$edge)){
+ vi<-phy$edge.length[i]
+ phy$edge.length[i]<-vi+vi*scaled.psi*
+ diversity[as.character(phy$edge[i,1])]
+ }
+ D<-vcv(phy)
+ D<-D[names(y),names(y)]
+ Dinv<-solve(D)
+ a<-as.numeric(colSums(Dinv)%*%y/sum(Dinv))
+ sig0<-as.numeric(t(y-a)%*%Dinv%*%(y-a)/nrow(D))
+ return(sig0)
+ }
+ sig0=compute_sig0(res$maximum,x,tree,d)
+ # compute the Hessian
+ compute_Hessian<-function(scaled.psi,sig0,y,phy,d,maxd){
+ psi<-scaled.psi*sig0/(maxd+tol)
+ likHessian<-function(theta,y,phy,d,maxd){
+ sig0<-theta[1]
+ psi<-theta[2]
+ for(i in 1:nrow(phy$edge)){
+ vi<-phy$edge.length[i]
+ phy$edge.length[i]<-vi*(sig0+psi*d[as.character(phy$edge[i,
+ 1])]*(maxd+tol))
+ }
+ D<-vcv(phy)
+ D<-D[names(y),names(y)]
+ Dinv<-solve(D)
+ a<-as.numeric(colSums(Dinv)%*%y/sum(Dinv))
+ logL<-as.numeric(-t(y-a)%*%Dinv%*%(y-a)/2-determinant(D)$modulus[1]/2-
+ length(y)*log(2*pi)/2)
+ return(logL)
+ }
+ H<-hessian(likHessian,c(sig0,psi),y=y,phy=phy,d=d,maxd=maxd)
+ return(H)
+ }
+ H<-compute_Hessian(res$maximum,sig0,x,tree,d,maxd)
+ # return results to user
+ if(var(d)>0){
+ object<-list(logL=res$objective,sig0=sig0,psi=sig0*res$maximum/(maxd+tol),
+ vcv=matrix(solve(-H),2,2,dimnames=list(c("sig0","psi"),c("sig0","psi"))))
+ class(object)<-"fitDiversityModel"
+ return(object)
+ } else {
+ message("psi not estimable because diversity is constant through time.")
+ object<-list(logL=res$objective,sig0=sig0,vcv=matrix(-1/H[1,1],1,1,
+ dimnames=list(c("sig0"),c("sig0"))))
+ class(object)<-"fitDiversityModel"
+ return(object)
+ }
+}
+
+print.fitDiversityModel<-function(x,...){
+ if(hasArg(digits)) digits<-list(...)$digits
+ else digits<-5
+ if(is.null(x$psi)){
+ cat("Fitted diversity-independent evolution model:\n")
+ cat("\tsig2(0)\tSE\tlog(L)\n")
+ cat(paste("value\t",round(x$sig0,digits),"\t",
+ round(sqrt(x$vcv[1,1]),digits),"\t",
+ round(logLik(x),digits),"\n\n",sep=""))
+ } else {
+ cat("Fitted diversity-dependent evolution model:\n")
+ cat("\tsig2(0)\tSE\tpsi\tSE\tlog(L)\n")
+ cat(paste("value\t",round(x$sig0,digits),"\t",
+ round(sqrt(x$vcv[1,1]),digits),"\t",
+ round(x$psi,digits),"\t",
+ round(sqrt(x$vcv[2,2]),digits),"\t",
+ round(logLik(x),digits),"\n\n",sep=""))
+ }
+}
+
+logLik.fitDiversityModel<-function(object,...){
+ if(hasArg(df)) df<-list(...)$df
+ else df<-if(is.null(object$psi)) 2 else 3
+ lik<-object$logL
+ attr(lik,"df")<-df
+ lik
+}
diff --git a/R/fitHRM.R b/R/fitHRM.R
index 3e3809b..6f09e76 100644
--- a/R/fitHRM.R
+++ b/R/fitHRM.R
@@ -1,258 +1,258 @@
-## this function fits a hidden-rates model (Beaulieu et al. 2013)
-## written by Liam J. Revell 2020, 2021, 2023
-
-fitHRM<-function(tree,x,model="ARD",ncat=2,...){
- if(hasArg(trace)) trace<-list(...)$trace
- else trace<-0
- if(!is.factor(x)) x<-setNames(as.factor(x),names(x))
- k<-length(levels(x))
- if(hasArg(niter)) niter<-list(...)$niter
- else niter<-10
- if(length(ncat)==1) ncat<-rep(ncat,k)
- if(hasArg(quiet)) quiet<-list(...)$quiet
- else quiet<-FALSE
- if(hasArg(parallel)) parallel<-list(...)$parallel
- else parallel<-FALSE
- if(is.numeric(model)||(model%in%c("ARD","SYM","ER")==FALSE)){
- cat("Only models \"ER\", \"SYM\", and \"ARD\" are permitted.\n")
- cat("Setting model to \"ARD\".\n\n")
- model<-"ARD"
- }
- if(hasArg(umbral)) umbral<-list(...)$umbral
- else umbral<-FALSE
- if(hasArg(corHMM_model)) corHMM_model<-list(...)$corHMM_model
- else corHMM_model<-FALSE
- if(umbral&&corHMM_model){
- cat("The \"umbral\" and corHMM models are inconsistent. Setting \"corHMM_model=FALSE\".\n")
- corHMM_model<-FALSE
- }
- XX<-to.matrix(x,levels(x))
- X<-matrix(NA,nrow(XX),sum(ncat),dimnames=list(rownames(XX)))
- ii<-1
- cols<-nn<-vector()
- for(i in 1:ncol(XX)){
- for(j in 1:ncat[i]){
- X[,ii]<-XX[,i]
- nn[ii]<-paste(colnames(XX)[i],"_R",j,sep="")
- cols[ii]<-paste(colnames(XX)[i],paste(rep("*",j-1),
- collapse=""),sep="")
- ii<-ii+1
- }
- }
- colnames(X)<-nn
- MODEL<-model
- model<-matrix(0,ncol(X),ncol(X),dimnames=list(colnames(X),
- colnames(X)))
- if(!umbral){
- ii<-1
- for(i in 1:length(nn)){
- FROM<-strsplit(nn[i],"_")[[1]]
- TO<-strsplit(nn,"_")
- for(j in 1:length(nn)){
- if(i!=j){
- if(FROM[1]==TO[[j]][1]){
- r<-as.numeric(
- c(strsplit(FROM[2],"R")[[1]][2],
- strsplit(TO[[j]][2],"R")[[1]][2]))
- if(abs(diff(r))==1){
- model[i,j]<-ii
- ii<-ii+1
- }
- } else if(FROM[2]==TO[[j]][2]){
- model[i,j]<-ii
- ii<-ii+1
- }
- }
- }
- }
- } else {
- if(hasArg(ordered)) ordered<-list(...)$ordered
- else ordered<-TRUE
- order<-if(ordered) setNames(1:length(levels(x)),levels(x)) else
- setNames(rep(1,length(levels(x))),levels(x))
- ii<-1
- for(i in 1:length(nn)){
- FROM<-strsplit(nn[i],"_")[[1]]
- TO<-strsplit(nn,"_")
- for(j in 1:length(nn)){
- if(i!=j){
- if(FROM[1]==TO[[j]][1]){
- r<-as.numeric(
- c(strsplit(FROM[2],"R")[[1]][2],
- strsplit(TO[[j]][2],"R")[[1]][2]))
- if(abs(diff(r))==1){
- model[i,j]<-ii
- ii<-ii+1
- }
- } else {
- r<-order[c(FROM[1],TO[[j]][1])]
- if(abs(diff(r))<=1){
- if(as.numeric(strsplit(FROM[2],"R")[[1]][2])==1&&
- as.numeric(strsplit(TO[[j]][2],"R")[[1]][2])==1){
- model[i,j]<-ii
- ii<-ii+1
- }
-
- }
- }
- }
- }
- }
- }
- if(MODEL=="SYM"){
- for(i in 1:nrow(model)) for(j in i:ncol(model)) model[i,j]<-model[j,i]
- oo<-sort(unique(as.vector(model)))
- ii<-0:length(oo)
- for(i in 1:length(oo)) model[model==oo[i]]<-ii[i]
- } else if(MODEL=="ER"){
- for(i in 1:nrow(model)) for(j in 1:ncol(model)){
- if(model[i,j]!=0){
- nr<-rownames(model)[i]
- nc<-rownames(model)[j]
- if(strsplit(nr,"_")[[1]][2]==strsplit(nc,"_")[[1]][2]){
- model[i,j]<-as.numeric(strsplit(nr,"_R")[[1]][2])
- } else model[i,j]<-if(umbral) 2 else max(ncat)+1
- }
- }
- }
- if(corHMM_model){
- mm<-model
- ind<-which(model>0,arr.ind=TRUE)
- for(i in 1:max(ncat)){
- ii<-grep(paste("R",i,sep=""),rownames(model))
- for(j in 1:max(ncat)){
- if(i!=j){
- jj<-grep(paste("R",j,sep=""),rownames(model))
- if(any(mm[ii,jj]>0)){
- kk<-ind[which(ind[,1]%in%ii),,drop=FALSE]
- kk<-kk[which(kk[,2]%in%jj),,drop=FALSE]
- mm[kk]<-min(model[kk])
- }
- }
- }
- }
- old<-sort(unique(as.vector(mm)))
- new<-0:length(old)
- for(i in 1:length(old)) mm[which(mm==old[i],arr.ind=TRUE)]<-new[i]
- model<-mm
- }
- colnames(model)<-rownames(model)<-colnames(X)<-cols
- if(!quiet){
- cat("\nThis is the design matrix of the fitted model.\nDoes it make sense?\n\n")
- print(model)
- cat("\n")
- flush.console()
- }
- fits<-list()
- args<-list(...)
- args$model<-model
- args$tree<-tree
- args$x<-X
- if(hasArg(logscale)) logscale<-rep(list(...)$logscale,niter)
- else logscale<-sample(c(TRUE,FALSE),niter,replace=TRUE)
- if(hasArg(opt.method)) opt.method<-rep(list(...)$opt.method,niter)
- else opt.method<-sample(c("nlminb","optim"),niter,replace=TRUE)
- ## parallelize
- if(!parallel){
- for(i in 1:niter){
- args$logscale<-logscale[i]
- args$opt.method<-opt.method[i]
- args$q.init<-rexp(n=max(model),rate=sum(tree$edge.length)/(1e3*k))
- fits[[i]]<-do.call(fitMk,args)
- if(trace>0) print(fits[[i]])
- logL<-sapply(fits,logLik)
- if(!quiet){
- cat(paste("log-likelihood from current iteration:",
- round(logLik(fits[[i]]),4),"\n"))
- cat(paste(" --- Best log-likelihood so far:",round(max(logL),4),
- "---\n"))
- flush.console()
- }
- }
- } else if(parallel){
- if(hasArg(ncores)) ncores<-list(...)$ncores
- else ncores<-detectCores()-1
- mc<-makeCluster(ncores,type="PSOCK")
- registerDoParallel(cl=mc)
- if(!quiet){
- cat(paste("Opened cluster with",ncores,"cores.\n"))
- cat("Running optimization iterations in parallel.\n")
- cat("Please wait....\n")
- flush.console()
- }
- fits<-foreach(i=1:niter)%dopar%{
- args$logscale<-logscale[i]
- args$opt.method<-opt.method[i]
- args$q.init<-rexp(n=max(model),rate=sum(tree$edge.length)/(1e3*k))
- do.call(phytools::fitMk,args)
- }
- logL<-sapply(fits,logLik)
- stopCluster(cl=mc)
- }
- obj<-fits[[which(logL==max(logL))[1]]]
- obj$ncat<-ncat
- obj$model<-MODEL
- obj$umbral<-umbral
- obj$all.fits<-fits
- obj$data<-X
- class(obj)<-c("fitHRM","fitMk")
- obj
-}
-
-## print method for objects of class "fitHRM"
-print.fitHRM<-function(x,digits=6,...){
- cat("Object of class \"fitHRM\".\n\n")
- ss<-unique(sapply(x$states,function(x) strsplit(x,"*",fixed=TRUE)[[1]][1]))
- cat(paste("Observed states: [ ",paste(ss,collapse=", ")," ]\n",
- sep=""))
- cat(paste("Number of rate categories per state: [ ",
- paste(x$ncat,collapse=", ")," ]\n\n",sep=""))
- cat("Fitted (or set) value of Q:\n")
- Q<-matrix(NA,length(x$states),length(x$states))
- Q[]<-c(0,x$rates)[x$index.matrix+1]
- diag(Q)<-0
- diag(Q)<--rowSums(Q)
- colnames(Q)<-rownames(Q)<-x$states
- print(round(Q,digits))
- cat("\nFitted (or set) value of pi:\n")
- print(round(x$pi,digits))
- cat(paste("due to treating the root prior as (a) ",x$root.prior,".\n",
- sep=""))
- cat(paste("\nLog-likelihood:",round(x$logLik,digits),"\n"))
- cat(paste("\nOptimization method used was \"",x$method,"\"\n\n",
- sep=""))
-}
-
-isOdd<-function(x) (x%%2)==1
-
-## S3 plot method for objects of class "fitHRM"
-plot.fitHRM<-function(x,...){
- if(hasArg(tol)) tol<-list(...)$tol
- else tol<-1e-6
- umbral<-x$umbral
- ncat<-x$ncat
- Q<-as.Qmatrix(x)
- II<-x$index.matrix
- for(i in 1:nrow(II)) for(j in 1:ncol(II))
- if(Q[i,j]<tol&&II[i,j]!=0) Q[i,j]<-10*tol
- nn<-sort(rownames(Q))
- mm<-nn
- for(i in 1:length(x$ncat)){
- cs<-if(i>1) sum(x$ncat[1:(i-1)]) else 0
- mm[1:x$ncat[i]+cs]<-if(isOdd(i)) nn[1:x$ncat[i]+cs] else nn[x$ncat[i]:1+cs]
- }
- if(isOdd(length(x$ncat))) mm<-nn
- Q<-Q[mm,mm]
- class(Q)<-"Qmatrix"
- args.list<-list(...)
- args.list$show.zeros<-FALSE
- plot(Q,show.zeros=FALSE,umbral=umbral,ncat=ncat,...)
-}
-
-as.Qmatrix.corhmm<-function(x,...){
- Q<-x$solution
- Q[is.na(Q)]<-0
- diag(Q)<--rowSums(Q)
- class(Q)<-"Qmatrix"
- Q
-}
+## this function fits a hidden-rates model (Beaulieu et al. 2013)
+## written by Liam J. Revell 2020, 2021, 2023
+
+fitHRM<-function(tree,x,model="ARD",ncat=2,...){
+ if(hasArg(trace)) trace<-list(...)$trace
+ else trace<-0
+ if(!is.factor(x)) x<-setNames(as.factor(x),names(x))
+ k<-length(levels(x))
+ if(hasArg(niter)) niter<-list(...)$niter
+ else niter<-10
+ if(length(ncat)==1) ncat<-rep(ncat,k)
+ if(hasArg(quiet)) quiet<-list(...)$quiet
+ else quiet<-FALSE
+ if(hasArg(parallel)) parallel<-list(...)$parallel
+ else parallel<-FALSE
+ if(is.numeric(model)||(model%in%c("ARD","SYM","ER")==FALSE)){
+ cat("Only models \"ER\", \"SYM\", and \"ARD\" are permitted.\n")
+ cat("Setting model to \"ARD\".\n\n")
+ model<-"ARD"
+ }
+ if(hasArg(umbral)) umbral<-list(...)$umbral
+ else umbral<-FALSE
+ if(hasArg(corHMM_model)) corHMM_model<-list(...)$corHMM_model
+ else corHMM_model<-FALSE
+ if(umbral&&corHMM_model){
+ cat("The \"umbral\" and corHMM models are inconsistent. Setting \"corHMM_model=FALSE\".\n")
+ corHMM_model<-FALSE
+ }
+ XX<-to.matrix(x,levels(x))
+ X<-matrix(NA,nrow(XX),sum(ncat),dimnames=list(rownames(XX)))
+ ii<-1
+ cols<-nn<-vector()
+ for(i in 1:ncol(XX)){
+ for(j in 1:ncat[i]){
+ X[,ii]<-XX[,i]
+ nn[ii]<-paste(colnames(XX)[i],"_R",j,sep="")
+ cols[ii]<-paste(colnames(XX)[i],paste(rep("*",j-1),
+ collapse=""),sep="")
+ ii<-ii+1
+ }
+ }
+ colnames(X)<-nn
+ MODEL<-model
+ model<-matrix(0,ncol(X),ncol(X),dimnames=list(colnames(X),
+ colnames(X)))
+ if(!umbral){
+ ii<-1
+ for(i in 1:length(nn)){
+ FROM<-strsplit(nn[i],"_")[[1]]
+ TO<-strsplit(nn,"_")
+ for(j in 1:length(nn)){
+ if(i!=j){
+ if(FROM[1]==TO[[j]][1]){
+ r<-as.numeric(
+ c(strsplit(FROM[2],"R")[[1]][2],
+ strsplit(TO[[j]][2],"R")[[1]][2]))
+ if(abs(diff(r))==1){
+ model[i,j]<-ii
+ ii<-ii+1
+ }
+ } else if(FROM[2]==TO[[j]][2]){
+ model[i,j]<-ii
+ ii<-ii+1
+ }
+ }
+ }
+ }
+ } else {
+ if(hasArg(ordered)) ordered<-list(...)$ordered
+ else ordered<-TRUE
+ order<-if(ordered) setNames(1:length(levels(x)),levels(x)) else
+ setNames(rep(1,length(levels(x))),levels(x))
+ ii<-1
+ for(i in 1:length(nn)){
+ FROM<-strsplit(nn[i],"_")[[1]]
+ TO<-strsplit(nn,"_")
+ for(j in 1:length(nn)){
+ if(i!=j){
+ if(FROM[1]==TO[[j]][1]){
+ r<-as.numeric(
+ c(strsplit(FROM[2],"R")[[1]][2],
+ strsplit(TO[[j]][2],"R")[[1]][2]))
+ if(abs(diff(r))==1){
+ model[i,j]<-ii
+ ii<-ii+1
+ }
+ } else {
+ r<-order[c(FROM[1],TO[[j]][1])]
+ if(abs(diff(r))<=1){
+ if(as.numeric(strsplit(FROM[2],"R")[[1]][2])==1&&
+ as.numeric(strsplit(TO[[j]][2],"R")[[1]][2])==1){
+ model[i,j]<-ii
+ ii<-ii+1
+ }
+
+ }
+ }
+ }
+ }
+ }
+ }
+ if(MODEL=="SYM"){
+ for(i in 1:nrow(model)) for(j in i:ncol(model)) model[i,j]<-model[j,i]
+ oo<-sort(unique(as.vector(model)))
+ ii<-0:length(oo)
+ for(i in 1:length(oo)) model[model==oo[i]]<-ii[i]
+ } else if(MODEL=="ER"){
+ for(i in 1:nrow(model)) for(j in 1:ncol(model)){
+ if(model[i,j]!=0){
+ nr<-rownames(model)[i]
+ nc<-rownames(model)[j]
+ if(strsplit(nr,"_")[[1]][2]==strsplit(nc,"_")[[1]][2]){
+ model[i,j]<-as.numeric(strsplit(nr,"_R")[[1]][2])
+ } else model[i,j]<-if(umbral) 2 else max(ncat)+1
+ }
+ }
+ }
+ if(corHMM_model){
+ mm<-model
+ ind<-which(model>0,arr.ind=TRUE)
+ for(i in 1:max(ncat)){
+ ii<-grep(paste("R",i,sep=""),rownames(model))
+ for(j in 1:max(ncat)){
+ if(i!=j){
+ jj<-grep(paste("R",j,sep=""),rownames(model))
+ if(any(mm[ii,jj]>0)){
+ kk<-ind[which(ind[,1]%in%ii),,drop=FALSE]
+ kk<-kk[which(kk[,2]%in%jj),,drop=FALSE]
+ mm[kk]<-min(model[kk])
+ }
+ }
+ }
+ }
+ old<-sort(unique(as.vector(mm)))
+ new<-0:length(old)
+ for(i in 1:length(old)) mm[which(mm==old[i],arr.ind=TRUE)]<-new[i]
+ model<-mm
+ }
+ colnames(model)<-rownames(model)<-colnames(X)<-cols
+ if(!quiet){
+ cat("\nThis is the design matrix of the fitted model.\nDoes it make sense?\n\n")
+ print(model)
+ cat("\n")
+ flush.console()
+ }
+ fits<-list()
+ args<-list(...)
+ args$model<-model
+ args$tree<-tree
+ args$x<-X
+ if(hasArg(logscale)) logscale<-rep(list(...)$logscale,niter)
+ else logscale<-sample(c(TRUE,FALSE),niter,replace=TRUE)
+ if(hasArg(opt.method)) opt.method<-rep(list(...)$opt.method,niter)
+ else opt.method<-sample(c("nlminb","optim"),niter,replace=TRUE)
+ ## parallelize
+ if(!parallel){
+ for(i in 1:niter){
+ args$logscale<-logscale[i]
+ args$opt.method<-opt.method[i]
+ args$q.init<-rexp(n=max(model),rate=sum(tree$edge.length)/(1e3*k))
+ fits[[i]]<-do.call(fitMk,args)
+ if(trace>0) print(fits[[i]])
+ logL<-sapply(fits,logLik)
+ if(!quiet){
+ cat(paste("log-likelihood from current iteration:",
+ round(logLik(fits[[i]]),4),"\n"))
+ cat(paste(" --- Best log-likelihood so far:",round(max(logL),4),
+ "---\n"))
+ flush.console()
+ }
+ }
+ } else if(parallel){
+ if(hasArg(ncores)) ncores<-list(...)$ncores
+ else ncores<-detectCores()-1
+ mc<-makeCluster(ncores,type="PSOCK")
+ registerDoParallel(cl=mc)
+ if(!quiet){
+ cat(paste("Opened cluster with",ncores,"cores.\n"))
+ cat("Running optimization iterations in parallel.\n")
+ cat("Please wait....\n")
+ flush.console()
+ }
+ fits<-foreach(i=1:niter)%dopar%{
+ args$logscale<-logscale[i]
+ args$opt.method<-opt.method[i]
+ args$q.init<-rexp(n=max(model),rate=sum(tree$edge.length)/(1e3*k))
+ do.call(phytools::fitMk,args)
+ }
+ logL<-sapply(fits,logLik)
+ stopCluster(cl=mc)
+ }
+ obj<-fits[[which(logL==max(logL))[1]]]
+ obj$ncat<-ncat
+ obj$model<-MODEL
+ obj$umbral<-umbral
+ obj$all.fits<-fits
+ obj$data<-X
+ class(obj)<-c("fitHRM","fitMk")
+ obj
+}
+
+## print method for objects of class "fitHRM"
+print.fitHRM<-function(x,digits=6,...){
+ cat("Object of class \"fitHRM\".\n\n")
+ ss<-unique(sapply(x$states,function(x) strsplit(x,"*",fixed=TRUE)[[1]][1]))
+ cat(paste("Observed states: [ ",paste(ss,collapse=", ")," ]\n",
+ sep=""))
+ cat(paste("Number of rate categories per state: [ ",
+ paste(x$ncat,collapse=", ")," ]\n\n",sep=""))
+ cat("Fitted (or set) value of Q:\n")
+ Q<-matrix(NA,length(x$states),length(x$states))
+ Q[]<-c(0,x$rates)[x$index.matrix+1]
+ diag(Q)<-0
+ diag(Q)<--rowSums(Q)
+ colnames(Q)<-rownames(Q)<-x$states
+ print(round(Q,digits))
+ cat("\nFitted (or set) value of pi:\n")
+ print(round(x$pi,digits))
+ cat(paste("due to treating the root prior as (a) ",x$root.prior,".\n",
+ sep=""))
+ cat(paste("\nLog-likelihood:",round(x$logLik,digits),"\n"))
+ cat(paste("\nOptimization method used was \"",x$method,"\"\n\n",
+ sep=""))
+}
+
+isOdd<-function(x) (x%%2)==1
+
+## S3 plot method for objects of class "fitHRM"
+plot.fitHRM<-function(x,...){
+ if(hasArg(tol)) tol<-list(...)$tol
+ else tol<-1e-6
+ umbral<-x$umbral
+ ncat<-x$ncat
+ Q<-as.Qmatrix(x)
+ II<-x$index.matrix
+ for(i in 1:nrow(II)) for(j in 1:ncol(II))
+ if(Q[i,j]<tol&&II[i,j]!=0) Q[i,j]<-10*tol
+ nn<-sort(rownames(Q))
+ mm<-nn
+ for(i in 1:length(x$ncat)){
+ cs<-if(i>1) sum(x$ncat[1:(i-1)]) else 0
+ mm[1:x$ncat[i]+cs]<-if(isOdd(i)) nn[1:x$ncat[i]+cs] else nn[x$ncat[i]:1+cs]
+ }
+ if(isOdd(length(x$ncat))) mm<-nn
+ Q<-Q[mm,mm]
+ class(Q)<-"Qmatrix"
+ args.list<-list(...)
+ args.list$show.zeros<-FALSE
+ plot(Q,show.zeros=FALSE,umbral=umbral,ncat=ncat,...)
+}
+
+as.Qmatrix.corhmm<-function(x,...){
+ Q<-x$solution
+ Q[is.na(Q)]<-0
+ diag(Q)<--rowSums(Q)
+ class(Q)<-"Qmatrix"
+ Q
+}
diff --git a/R/fitMk.R b/R/fitMk.R
index 373032b..53f6ec2 100644
--- a/R/fitMk.R
+++ b/R/fitMk.R
@@ -1,620 +1,625 @@
-## optimizing, graphing, and analyzing extended Mk model for discrete
-## character evolution
-## written by Liam J. Revell (updates in 2015, 2016, 2019, 2020, 2021, 2022)
-## likelihood function (with pruning) adapted from ape::ace (Paradis et al. 2013)
-
-anova.fitMk<-function(object,...){
- fits<-list(...)
- nm<-c(
- deparse(substitute(object)),
- if(length(fits)>0) sapply(substitute(list(...))[-1],deparse)
- )
- logL<-c(logLik(object),
- if(length(fits)>0) sapply(fits,logLik))
- df<-c(attr(logLik(object),"df"),
- if(length(fits)>0) sapply(fits,function(x) attr(logLik(x),"df")))
- AICvals<-c(AIC(object),
- if(length(fits)>0) sapply(fits,AIC))
- ww<-aic.w(AICvals)
- result<-data.frame(logL,df,AICvals,unclass(ww))
- rownames(result)<-nm
- colnames(result)<-c("log(L)","d.f.","AIC","weight")
- print(result)
- invisible(result)
-}
-
-fitMk<-function(tree,x,model="SYM",fixedQ=NULL,...){
- if(hasArg(opt.method)) opt.method<-list(...)$opt.method
- else opt.method<-"nlminb"
- if(opt.method=="optimParallel"){
- if(hasArg(ncores)) ncores<-list(...)$ncores
- else ncores<-detectCores()
- if(is.na(ncores)) ncores<-1
- args<-list(...)
- args$tree<-tree
- args$x<-x
- args$model<-model
- args$ncores<-ncores
- obj<-do.call(fitMk.parallel,args)
- } else {
- if(hasArg(output.liks)) output.liks<-list(...)$output.liks
- else output.liks<-FALSE
- if(hasArg(q.init)) q.init<-list(...)$q.init
- else q.init<-length(unique(x))/sum(tree$edge.length)
- if(hasArg(min.q)) min.q<-list(...)$min.q
- else min.q<-1e-12
- if(hasArg(max.q)) max.q<-list(...)$max.q
- else max.q<-max(nodeHeights(tree))*100
- if(hasArg(logscale)) logscale<-list(...)$logscale
- else logscale<-FALSE
- N<-Ntip(tree)
- M<-tree$Nnode
- if(is.matrix(x)){
- x<-x[tree$tip.label,]
- m<-ncol(x)
- states<-colnames(x)
- } else {
- x<-to.matrix(x,sort(unique(x)))
- x<-x[tree$tip.label,]
- m<-ncol(x)
- states<-colnames(x)
- }
- if(hasArg(pi)) pi<-list(...)$pi
- else pi<-"equal"
- if(is.numeric(pi)) root.prior<-"given"
- if(pi[1]=="equal"){
- pi<-setNames(rep(1/m,m),states)
- root.prior<-"flat"
- } else if(pi[1]=="estimated"){
- pi<-if(!is.null(fixedQ)) statdist(fixedQ) else
- statdist(summary(fitMk(tree,x,model),quiet=TRUE)$Q)
- cat(paste("Using pi estimated from the stationary",
- "distribution of Q assuming a flat prior.\npi =\n"))
- print(round(pi,6))
- cat("\n")
- root.prior<-"stationary"
- } else if(pi[1]=="fitzjohn") root.prior<-"nuisance"
- if(is.numeric(pi)){
- pi<-pi/sum(pi)
- if(is.null(names(pi))) pi<-setNames(pi,states)
- pi<-pi[states]
- }
- if(is.null(fixedQ)){
- if(is.character(model)){
- rate<-matrix(NA,m,m)
- if(model=="ER"){
- k<-rate[]<-1
- diag(rate)<-NA
- } else if(model=="ARD"){
- k<-m*(m-1)
- rate[col(rate)!=row(rate)]<-1:k
- } else if(model=="SYM"){
- k<-m*(m-1)/2
- ii<-col(rate)<row(rate)
- rate[ii]<-1:k
- rate<-t(rate)
- rate[ii]<-1:k
- }
- } else {
- if(ncol(model)!=nrow(model))
- stop("model is not a square matrix")
- if(ncol(model)!=ncol(x))
- stop("model does not have the right number of columns")
- rate<-model
- k<-max(rate)
- }
- Q<-matrix(0,m,m)
- } else {
- rate<-matrix(NA,m,m)
- k<-m*(m-1)
- rate[col(rate)!=row(rate)]<-1:k
- Q<-fixedQ
- }
- index.matrix<-rate
- tmp<-cbind(1:m,1:m)
- rate[tmp]<-0
- rate[rate==0]<-k+1
- liks<-rbind(x,matrix(0,M,m,dimnames=list(1:M+N,states)))
- pw<-reorder(tree,"pruningwise")
- lik<-function(Q,output.liks=FALSE,pi,...){
- if(hasArg(output.pi)) output.pi<-list(...)$output.pi
- else output.pi<-FALSE
- if(is.Qmatrix(Q)) Q<-unclass(Q)
- if(any(is.nan(Q))||any(is.infinite(Q))) return(1e50)
- comp<-vector(length=N+M,mode="numeric")
- parents<-unique(pw$edge[,1])
- root<-min(parents)
- for(i in 1:length(parents)){
- anc<-parents[i]
- ii<-which(pw$edge[,1]==parents[i])
- desc<-pw$edge[ii,2]
- el<-pw$edge.length[ii]
- v<-vector(length=length(desc),mode="list")
- for(j in 1:length(v)){
- v[[j]]<-EXPM(Q*el[j])%*%liks[desc[j],]
- }
- if(anc==root){
- if(is.numeric(pi)) vv<-Reduce('*',v)[,1]*pi
- else if(pi[1]=="fitzjohn"){
- D<-Reduce('*',v)[,1]
- pi<-D/sum(D)
- vv<-D*D/sum(D)
- }
- } else vv<-Reduce('*',v)[,1]
- ## vv<-if(anc==root) Reduce('*',v)[,1]*pi else Reduce('*',v)[,1]
- comp[anc]<-sum(vv)
- liks[anc,]<-vv/comp[anc]
- }
- if(output.liks) return(liks[1:M+N,,drop=FALSE])
- else if(output.pi) return(pi)
- else {
- logL<--sum(log(comp[1:M+N]))
- if(is.na(logL)) logL<-Inf
- return(logL)
- }
- }
- if(is.null(fixedQ)){
- if(length(q.init)!=k) q.init<-rep(q.init[1],k)
- q.init<-if(logscale) log(q.init) else q.init
- if(opt.method=="optim"){
- fit<-if(logscale)
- optim(q.init,function(p) lik(makeQ(m,exp(p),index.matrix),pi=pi),
- method="L-BFGS-B",lower=rep(log(min.q),k),upper=rep(log(max.q),k)) else
- optim(q.init,function(p) lik(makeQ(m,p,index.matrix),pi=pi),
- method="L-BFGS-B",lower=rep(min.q,k),upper=rep(max.q,k))
- } else if(opt.method=="none"){
- fit<-list(objective=lik(makeQ(m,q.init,index.matrix),pi=pi),
- par=q.init)
- } else {
- fit<-if(logscale)
- nlminb(q.init,function(p) lik(makeQ(m,exp(p),index.matrix),pi=pi),
- lower=rep(log(min.q),k),upper=rep(log(max.q),k))
- else nlminb(q.init,function(p) lik(makeQ(m,p,index.matrix),
- pi=pi),lower=rep(0,k),upper=rep(max.q,k))
- }
- if(logscale) fit$par<-exp(fit$par)
- if(pi[1]=="fitzjohn") pi<-setNames(
- lik(makeQ(m,fit$par,index.matrix),FALSE,pi=pi,output.pi=TRUE),
- states)
- obj<-list(logLik=
- if(opt.method=="optim") -fit$value else -fit$objective,
- rates=fit$par,
- index.matrix=index.matrix,
- states=states,
- pi=pi,
- method=opt.method,
- root.prior=root.prior)
- if(output.liks) obj$lik.anc<-lik(makeQ(m,obj$rates,index.matrix),TRUE,
- pi=pi)
- } else {
- fit<-lik(Q,pi=pi)
- if(pi[1]=="fitzjohn") pi<-setNames(lik(Q,FALSE,pi=pi,output.pi=TRUE),states)
- obj<-list(logLik=-fit,
- rates=Q[sapply(1:k,function(x,y) which(x==y),index.matrix)],
- index.matrix=index.matrix,
- states=states,
- pi=pi,
- root.prior=root.prior)
- if(output.liks) obj$lik.anc<-lik(makeQ(m,obj$rates,index.matrix),TRUE,
- pi=pi)
- }
- lik.f<-function(q) -lik(q,output.liks=FALSE,
- pi=if(root.prior=="nuisance") "fitzjohn" else pi)
- obj$lik<-lik.f
- class(obj)<-"fitMk"
- }
- return(obj)
-}
-
-makeQ<-function(m,q,index.matrix){
- Q<-matrix(0,m,m)
- Q[]<-c(0,q)[index.matrix+1]
- diag(Q)<-0
- diag(Q)<--rowSums(Q)
- Q
-}
-
-## print method for objects of class "fitMk"
-print.fitMk<-function(x,digits=6,...){
- cat("Object of class \"fitMk\".\n\n")
- cat("Fitted (or set) value of Q:\n")
- Q<-matrix(NA,length(x$states),length(x$states))
- Q[]<-c(0,x$rates)[x$index.matrix+1]
- diag(Q)<-0
- diag(Q)<--rowSums(Q)
- colnames(Q)<-rownames(Q)<-x$states
- print(round(Q,digits))
- cat("\nFitted (or set) value of pi:\n")
- print(round(x$pi,digits))
- cat(paste("due to treating the root prior as (a) ",x$root.prior,".\n",
- sep=""))
- cat(paste("\nLog-likelihood:",round(x$logLik,digits),"\n"))
- cat(paste("\nOptimization method used was \"",x$method,"\"\n\n",
- sep=""))
-}
-
-## summary method for objects of class "fitMk"
-summary.fitMk<-function(object,...){
- if(hasArg(digits)) digits<-list(...)$digits
- else digits<-6
- if(hasArg(quiet)) quiet<-list(...)$quiet
- else quiet<-FALSE
- if(!quiet) cat("Fitted (or set) value of Q:\n")
- Q<-matrix(NA,length(object$states),length(object$states))
- Q[]<-c(0,object$rates)[object$index.matrix+1]
- diag(Q)<-0
- diag(Q)<--rowSums(Q)
- colnames(Q)<-rownames(Q)<-object$states
- if(!quiet) print(round(Q,digits))
- if(!quiet) cat(paste("\nLog-likelihood:",round(object$logLik,digits),"\n\n"))
- invisible(list(Q=Q,logLik=object$logLik))
-}
-
-## logLik method for objects of class "fitMk"
-logLik.fitMk<-function(object,...){
- lik<-object$logLik
- if(!is.null(object$index.matrix))
- attr(lik,"df")<-max(object$index.matrix,na.rm=TRUE)
- else
- attr(lik,"df")<-length(object$rates)
- lik
-}
-
-## S3 plot method for objects of class "fitMk"
-plot.fitMk<-function(x,...){
- Q<-as.Qmatrix(x)
- plot(Q,...)
-}
-
-## S3 plot method for "gfit" object from geiger::fitDiscrete
-plot.gfit<-function(x,...){
- if("mkn"%in%class(x$lik)==FALSE){
- stop("Sorry. No plot method presently available for objects of this type.")
- object<-NULL
- } else {
- chk<-.check.pkg("geiger")
- if(chk) object<-plot(as.Qmatrix(x),...)
- else {
- obj<-list()
- QQ<-.Qmatrix.from.gfit(x)
- obj$states<-colnames(QQ)
- m<-length(obj$states)
- obj$index.matrix<-matrix(NA,m,m)
- k<-m*(m-1)
- obj$index.matrix[col(obj$index.matrix)!=row(obj$index.matrix)]<-1:k
- obj$rates<-QQ[sapply(1:k,function(x,y) which(x==y),obj$index.matrix)]
- class(obj)<-"fitMk"
- object<-plot(obj,...)
- }
- }
- invisible(object)
-}
-
-MIN<-function(x,...) min(x[is.finite(x)],...)
-MAX<-function(x,...) max(x[is.finite(x)],...)
-RANGE<-function(x,...) range(x[is.finite(x)],...)
-
-## S3 method for "Qmatrix" object class
-plot.Qmatrix<-function(x,...){
- Q<-unclass(x)
- if(hasArg(signif)) signif<-list(...)$signif
- else signif<-3
- if(hasArg(main)) main<-list(...)$main
- else main<-NULL
- if(hasArg(cex.main)) cex.main<-list(...)$cex.main
- else cex.main<-1.2
- if(hasArg(cex.traits)) cex.traits<-list(...)$cex.traits
- else cex.traits<-1
- if(hasArg(cex.rates)) cex.rates<-list(...)$cex.rates
- else cex.rates<-0.6
- if(hasArg(show.zeros)) show.zeros<-list(...)$show.zeros
- else show.zeros<-TRUE
- if(hasArg(tol)) tol<-list(...)$tol
- else tol<-1e-6
- if(hasArg(mar)) mar<-list(...)$mar
- else mar<-c(1.1,1.1,3.1,1.1)
- if(hasArg(lwd)) lwd<-list(...)$lwd
- else lwd<-1
- if(hasArg(umbral)) umbral<-list(...)$umbral
- else umbral<-FALSE
- if(hasArg(ncat)) ncat<-list(...)$ncat
- else ncat<-NULL
- if(hasArg(spacer)) spacer<-list(...)$spacer
- else spacer<-0.1
- if(hasArg(color)) color<-list(...)$color
- else color<-FALSE
- if(hasArg(width)) width<-list(...)$width
- else width<-FALSE
- if(hasArg(text)) text<-list(...)$text
- else text<-TRUE
- if(hasArg(max.lwd)) max.lwd<-list(...)$max.lwd
- else max.lwd<-if(text) 5 else 8
- if(hasArg(rotate)) rotate<-list(...)$rotate
- else rotate<-NULL
- if(hasArg(add)) add<-list(...)$add
- else add<-FALSE
- if(hasArg(xlim)) xlim<-list(...)$xlim
- else xlim<-NULL
- if(hasArg(ylim)) ylim<-list(...)$ylim
- else ylim<-NULL
- if(hasArg(offset)) offset<-list(...)$offset
- else offset<-0.02
- if(hasArg(palette)) palette<-list(...)$palette
- else palette<-c("blue","purple","red")
- ## set all Q<tol to zero (may remove later)
- Q[Q<tol]<-0
- ## end may remove later
- if(!add) plot.new()
- par(mar=mar)
- if(is.null(xlim)) xlim<-ylim
- if(is.null(ylim)) ylim<-xlim
- if(is.null(xlim)&&is.null(ylim)){
- if(!color) xlim<-ylim<-c(-1.2,1.2)
- else {
- xlim<-c(-1.4,1)
- ylim<-c(-1.2,1.2)
- }
- }
- plot.window(xlim=xlim,ylim=ylim,asp=1)
- if(!is.null(main)) title(main=main,cex.main=cex.main)
- nstates<-nrow(Q)
- if(is.null(rotate)){
- if(nstates==2) rotate<--90
- else rotate<--90*(nstates-2)/(nstates)
- }
- if(color){
- col_pal<-function(qq) if(is.na(qq)) NA else
- if(is.infinite(qq)) make.transparent("grey",0.6) else
- rgb(colorRamp(palette)(qq),maxColorValue=255)
- qq<-Q
- diag(qq)<-NA
- qq<-log(qq)
- dq<-diff(RANGE(qq,na.rm=TRUE))
- if(dq<tol){
- cols<-matrix(palette[1],nstates,nstates)
- cols[Q<tol]<-make.transparent("grey",0.6)
- } else {
- qq<-(qq-MIN(qq,na.rm=TRUE))/dq
- cols<-apply(qq,c(1,2),col_pal)
- }
- } else cols<-matrix(par("fg"),nstates,nstates)
- if(width){
- lwd_maker<-function(qq,max.qq) if(is.na(qq)) NA else
- if(is.infinite(qq)) 0 else qq*(max.lwd-1)+1
- qq<-Q
- diag(qq)<-NA
- qq<-log(qq)
- dq<-max(qq[!is.infinite(qq)],na.rm=TRUE)-
- min(qq[!is.infinite(qq)],na.rm=TRUE)
- if(dq<tol){
- lwd<-matrix(lwd,nstates,nstates)
- lwd[Q<tol]<-0
- } else {
- qq<-(qq-(min(qq[!is.infinite(qq)],na.rm=TRUE)))/dq
- lwd<-apply(qq,c(1,2),lwd_maker,max.qq=max(qq,na.rm=TRUE))
- }
- } else lwd<-matrix(lwd,nstates,nstates)
- if(!umbral||is.null(ncat)){
- step<-360/nstates
- angles<-seq(rotate,360-step+rotate,by=step)/180*pi
- if(nstates==2) angles<-angles+pi/2
- v.x<-cos(angles)
- v.y<-sin(angles)
- } else {
- v.x<-v.y<-vector()
- for(i in 1:length(ncat)){
- Q<-Q[sort(rownames(Q)),sort(colnames(Q))]
- xp<--1+2*(i-1)/(length(ncat)-1)
- v.x<-c(v.x,rep(xp,ncat[i]))
- yp<-seq(1,-1,length.out=max(ncat))[1:ncat[i]]
- v.y<-c(v.y,yp)
- }
- }
- for(i in 1:nstates) for(j in 1:nstates)
- if(if(!isSymmetric(Q)) i!=j else i>j){
- dx<-v.x[j]-v.x[i]
- dy<-v.y[j]-v.y[i]
- slope<-abs(dy/dx)
- shift.x<-offset*sin(atan(dy/dx))*sign(j-i)*if(dy/dx>0) 1 else -1
- shift.y<-offset*cos(atan(dy/dx))*sign(j-i)*if(dy/dx>0) -1 else 1
- s<-c(v.x[i]+spacer*cos(atan(slope))*sign(dx)+
- if(isSymmetric(Q)) 0 else shift.x,
- v.y[i]+spacer*sin(atan(slope))*sign(dy)+
- if(isSymmetric(Q)) 0 else shift.y)
- e<-c(v.x[j]+spacer*cos(atan(slope))*sign(-dx)+
- if(isSymmetric(Q)) 0 else shift.x,
- v.y[j]+spacer*sin(atan(slope))*sign(-dy)+
- if(isSymmetric(Q)) 0 else shift.y)
- if(show.zeros||Q[i,j]>tol){
- if(text){
- if(abs(diff(c(i,j)))==1||abs(diff(c(i,j)))==(nstates-1))
- text(mean(c(s[1],e[1]))+1.5*shift.x,
- mean(c(s[2],e[2]))+1.5*shift.y,
- round(Q[i,j],signif),cex=cex.rates,
- srt=atan(dy/dx)*180/pi)
- else
- text(mean(c(s[1],e[1]))+0.3*diff(c(s[1],e[1]))+
- 1.5*shift.x,
- mean(c(s[2],e[2]))+0.3*diff(c(s[2],e[2]))+
- 1.5*shift.y,
- round(Q[i,j],signif),cex=cex.rates,
- srt=atan(dy/dx)*180/pi)
- }
- arrows(s[1],s[2],e[1],e[2],length=0.05,
- code=if(isSymmetric(Q)) 3 else 2,
- lwd=if(lwd[i,j]==0) 1 else lwd[i,j],
- lty=if(lwd[i,j]==0) "dotted" else "solid",
- col=cols[i,j])
- }
- }
- text(v.x,v.y,rownames(Q),cex=cex.traits,
- col=make.transparent(par("fg"),0.9))
- if(color){
- if(dq>tol){
- h<-1.5
- LWD<-diff(par()$usr[1:2])/dev.size("px")[1]
- lines(x=rep(-1.3+LWD*15/2,2),y=c(-h/2,h/2))
- nticks<-6
- Y<-cbind(seq(-h/2,h/2,length.out=nticks),
- seq(-h/2,h/2,length.out=nticks))
- X<-cbind(rep(-1.3+LWD*15/2,nticks),
- rep(-1.3+LWD*15/2+0.02*h,nticks))
- for(i in 1:nrow(Y)) lines(X[i,],Y[i,])
- add.color.bar(h,sapply(seq(0,1,length.out=100),col_pal),
- title="evolutionary rate (q)",
- lims=NULL,digits=3,
- direction="upwards",
- subtitle="",lwd=15,
- x=-1.3,y=-h/2,prompt=FALSE)
- QQ<-Q
- diag(QQ)<-0
- text(x=X[,2],y=Y[,2],signif(exp(seq(MIN(log(QQ),na.rm=TRUE),
- MAX(log(QQ),na.rm=TRUE),length.out=6)),signif),pos=4,cex=0.7)
- } else {
- BLUE<-function(...) palette[1]
- h<-1.5
- LWD<-diff(par()$usr[1:2])/dev.size("px")[1]
- lines(x=rep(-1.3+LWD*15/2,2),y=c(-h/2,h/2))
- nticks<-6
- Y<-cbind(seq(-h/2,h/2,length.out=nticks),
- seq(-h/2,h/2,length.out=nticks))[nticks,,drop=FALSE]
- X<-cbind(rep(-1.3+LWD*15/2,nticks),
- rep(-1.3+LWD*15/2+0.02*h,nticks))[nticks,,drop=FALSE]
- for(i in 1:nrow(Y)) lines(X[i,],Y[i,])
- add.color.bar(h,sapply(seq(0,1,length.out=100),BLUE),
- title="evolutionary rate (q)",
- lims=NULL,digits=3,
- direction="upwards",
- subtitle="",lwd=15,
- x=-1.3,y=-h/2,prompt=FALSE)
- QQ<-Q
- diag(QQ)<-0
- text(x=X[,2],y=Y[,2],signif(exp(seq(MIN(log(QQ),na.rm=TRUE),
- MAX(log(QQ),na.rm=TRUE),length.out=1)),signif),pos=4,cex=0.7)
- }
- }
- object<-data.frame(states=rownames(Q),x=v.x,y=v.y)
- invisible(object)
-}
-
-## wraps around expm
-## written by Liam Revell 2011, 2017
-EXPM<-function(x,...){
- e_x<-if(isSymmetric(x)) matexpo(x) else expm(x,...)
- dimnames(e_x)<-dimnames(x)
- e_x
-}
-
-## function to simulate multiple-rate Mk multiMk
-## written by Liam J. Revell 2018
-sim.multiMk<-function(tree,Q,anc=NULL,nsim=1,...){
- if(hasArg(as.list)) as.list<-list(...)$as.list
- else as.list<-FALSE
- ss<-rownames(Q[[1]])
- tt<-map.to.singleton(reorder(tree))
- P<-vector(mode="list",length=nrow(tt$edge))
- for(i in 1:nrow(tt$edge))
- P[[i]]<-expm(Q[[names(tt$edge.length)[i]]]*tt$edge.length[i])
- if(nsim>1) X<- if(as.list) vector(mode="list",length=nsim) else
- data.frame(row.names=tt$tip.label)
- for(i in 1:nsim){
- a<-if(is.null(anc)) sample(ss,1) else anc
- STATES<-matrix(NA,nrow(tt$edge),2)
- root<-Ntip(tt)+1
- STATES[which(tt$edge[,1]==root),1]<-a
- for(j in 1:nrow(tt$edge)){
- new<-ss[which(rmultinom(1,1,P[[j]][STATES[j,1],])[,1]==1)]
- STATES[j,2]<-new
- ii<-which(tt$edge[,1]==tt$edge[j,2])
- if(length(ii)>0) STATES[ii,1]<-new
- }
- x<-as.factor(
- setNames(sapply(1:Ntip(tt),function(n,S,E) S[which(E==n)],
- S=STATES[,2],E=tt$edge[,2]),tt$tip.label))
- if(nsim>1) X[,i]<-x else X<-x
- }
- X
-}
-
-## constant-rate Mk model simulator
-## written by Liam J. Revell 2018
-sim.Mk<-function(tree,Q,anc=NULL,nsim=1,...){
- if(hasArg(as.list)) as.list<-list(...)$as.list
- else as.list<-FALSE
- ss<-rownames(Q)
- tt<-reorder(tree)
- P<-vector(mode="list",length=nrow(tt$edge))
- for(i in 1:nrow(tt$edge))
- P[[i]]<-expm(Q*tt$edge.length[i])
- if(nsim>1) X<- if(as.list) vector(mode="list",length=nsim) else
- data.frame(row.names=tt$tip.label)
- for(i in 1:nsim){
- a<-if(is.null(anc)) sample(ss,1) else anc
- STATES<-matrix(NA,nrow(tt$edge),2)
- root<-Ntip(tt)+1
- STATES[which(tt$edge[,1]==root),1]<-a
- for(j in 1:nrow(tt$edge)){
- new<-ss[which(rmultinom(1,1,P[[j]][STATES[j,1],])[,1]==1)]
- STATES[j,2]<-new
- ii<-which(tt$edge[,1]==tt$edge[j,2])
- if(length(ii)>0) STATES[ii,1]<-new
- }
- x<-as.factor(
- setNames(sapply(1:Ntip(tt),function(n,S,E) S[which(E==n)],
- S=STATES[,2],E=tt$edge[,2]),tt$tip.label))
- if(nsim>1) X[[i]]<-x else X<-x
- }
- X
-}
-
-## as.Qmatrix method
-
-as.Qmatrix<-function(x,...){
- if(identical(class(x),"Qmatrix")) return(x)
- UseMethod("as.Qmatrix")
-}
-
-as.Qmatrix.default<-function(x, ...){
- warning(paste(
- "as.Qmatrix does not know how to handle objects of class ",
- class(x),"."))
-}
-
-as.Qmatrix.matrix<-function(x, ...){
- if(ncol(x)!=nrow(x)){
- warning("\"matrix\" object does not appear to contain a valid Q matrix.\n")
- } else {
- diag(x)<--rowSums(x)
- class(x)<-"Qmatrix"
- return(x)
- }
-}
-
-as.Qmatrix.fitMk<-function(x,...){
- Q<-matrix(NA,length(x$states),length(x$states))
- Q[]<-c(0,x$rates)[x$index.matrix+1]
- rownames(Q)<-colnames(Q)<-x$states
- diag(Q)<--rowSums(Q,na.rm=TRUE)
- class(Q)<-"Qmatrix"
- Q
-}
-
-as.Qmatrix.ace<-function(x, ...){
- if("index.matrix"%in%names(x)){
- k<-nrow(x$index.matrix)
- Q<-matrix(NA,k,k)
- Q[]<-c(0,x$rates)[x$index.matrix+1]
- rownames(Q)<-colnames(Q)<-colnames(x$lik.anc)
- diag(Q)<--rowSums(Q,na.rm=TRUE)
- class(Q)<-"Qmatrix"
- return(Q)
- } else cat("\"ace\" object does not appear to contain a Q matrix.\n")
-}
-
-print.Qmatrix<-function(x,...){
- cat("Estimated Q matrix:\n")
- print(unclass(x),...)
-}
-
-is.Qmatrix<-function(x) "Qmatrix" %in% class(x)
-
+## optimizing, graphing, and analyzing extended Mk model for discrete
+## character evolution
+## written by Liam J. Revell (updates in 2015, 2016, 2019, 2020, 2021, 2022, 2023)
+## likelihood function (with pruning) adapted from ape::ace (Paradis et al. 2013)
+
+anova.fitMk<-function(object,...){
+ fits<-list(...)
+ nm<-c(
+ deparse(substitute(object)),
+ if(length(fits)>0) sapply(substitute(list(...))[-1],deparse)
+ )
+ logL<-c(logLik(object),
+ if(length(fits)>0) sapply(fits,logLik))
+ df<-c(attr(logLik(object),"df"),
+ if(length(fits)>0) sapply(fits,function(x) attr(logLik(x),"df")))
+ AICvals<-c(AIC(object),
+ if(length(fits)>0) sapply(fits,AIC))
+ ww<-aic.w(AICvals)
+ result<-data.frame(logL,df,AICvals,unclass(ww))
+ rownames(result)<-nm
+ colnames(result)<-c("log(L)","d.f.","AIC","weight")
+ models<-c(list(object),fits)
+ attr(result,"models")<-models
+ class(result)<-c(class(result),"anova.fitMk")
+ print(result)
+ invisible(result)
+}
+
+fitMk<-function(tree,x,model="SYM",fixedQ=NULL,...){
+ if(hasArg(opt.method)) opt.method<-list(...)$opt.method
+ else opt.method<-"nlminb"
+ if(opt.method=="optimParallel"){
+ if(hasArg(ncores)) ncores<-list(...)$ncores
+ else ncores<-detectCores()
+ if(is.na(ncores)) ncores<-1
+ args<-list(...)
+ args$tree<-tree
+ args$x<-x
+ args$model<-model
+ args$ncores<-ncores
+ obj<-do.call(fitMk.parallel,args)
+ } else {
+ if(hasArg(output.liks)) output.liks<-list(...)$output.liks
+ else output.liks<-FALSE
+ if(hasArg(q.init)) q.init<-list(...)$q.init
+ else q.init<-length(unique(x))/sum(tree$edge.length)
+ if(hasArg(min.q)) min.q<-list(...)$min.q
+ else min.q<-1e-12
+ if(hasArg(max.q)) max.q<-list(...)$max.q
+ else max.q<-max(nodeHeights(tree))*100
+ if(hasArg(logscale)) logscale<-list(...)$logscale
+ else logscale<-FALSE
+ N<-Ntip(tree)
+ M<-tree$Nnode
+ if(is.matrix(x)){
+ x<-x[tree$tip.label,]
+ m<-ncol(x)
+ states<-colnames(x)
+ } else {
+ x<-to.matrix(x,sort(unique(x)))
+ x<-x[tree$tip.label,]
+ m<-ncol(x)
+ states<-colnames(x)
+ }
+ if(hasArg(pi)) pi<-list(...)$pi
+ else pi<-"equal"
+ if(is.numeric(pi)) root.prior<-"given"
+ if(pi[1]=="equal"){
+ pi<-setNames(rep(1/m,m),states)
+ root.prior<-"flat"
+ } else if(pi[1]=="estimated"){
+ pi<-if(!is.null(fixedQ)) statdist(fixedQ) else
+ statdist(summary(fitMk(tree,x,model),quiet=TRUE)$Q)
+ cat(paste("Using pi estimated from the stationary",
+ "distribution of Q assuming a flat prior.\npi =\n"))
+ print(round(pi,6))
+ cat("\n")
+ root.prior<-"stationary"
+ } else if(pi[1]=="fitzjohn") root.prior<-"nuisance"
+ if(is.numeric(pi)){
+ pi<-pi/sum(pi)
+ if(is.null(names(pi))) pi<-setNames(pi,states)
+ pi<-pi[states]
+ }
+ if(is.null(fixedQ)){
+ if(is.character(model)){
+ rate<-matrix(NA,m,m)
+ if(model=="ER"){
+ k<-rate[]<-1
+ diag(rate)<-NA
+ } else if(model=="ARD"){
+ k<-m*(m-1)
+ rate[col(rate)!=row(rate)]<-1:k
+ } else if(model=="SYM"){
+ k<-m*(m-1)/2
+ ii<-col(rate)<row(rate)
+ rate[ii]<-1:k
+ rate<-t(rate)
+ rate[ii]<-1:k
+ }
+ } else {
+ if(ncol(model)!=nrow(model))
+ stop("model is not a square matrix")
+ if(ncol(model)!=ncol(x))
+ stop("model does not have the right number of columns")
+ rate<-model
+ k<-max(rate)
+ }
+ Q<-matrix(0,m,m)
+ } else {
+ rate<-matrix(NA,m,m)
+ k<-m*(m-1)
+ rate[col(rate)!=row(rate)]<-1:k
+ Q<-fixedQ
+ }
+ index.matrix<-rate
+ tmp<-cbind(1:m,1:m)
+ rate[tmp]<-0
+ rate[rate==0]<-k+1
+ liks<-rbind(x,matrix(0,M,m,dimnames=list(1:M+N,states)))
+ pw<-reorder(tree,"pruningwise")
+ lik<-function(Q,output.liks=FALSE,pi,...){
+ if(hasArg(output.pi)) output.pi<-list(...)$output.pi
+ else output.pi<-FALSE
+ if(is.Qmatrix(Q)) Q<-unclass(Q)
+ if(any(is.nan(Q))||any(is.infinite(Q))) return(1e50)
+ comp<-vector(length=N+M,mode="numeric")
+ parents<-unique(pw$edge[,1])
+ root<-min(parents)
+ for(i in 1:length(parents)){
+ anc<-parents[i]
+ ii<-which(pw$edge[,1]==parents[i])
+ desc<-pw$edge[ii,2]
+ el<-pw$edge.length[ii]
+ v<-vector(length=length(desc),mode="list")
+ for(j in 1:length(v)){
+ v[[j]]<-EXPM(Q*el[j])%*%liks[desc[j],]
+ }
+ if(anc==root){
+ if(is.numeric(pi)) vv<-Reduce('*',v)[,1]*pi
+ else if(pi[1]=="fitzjohn"){
+ D<-Reduce('*',v)[,1]
+ pi<-D/sum(D)
+ vv<-D*D/sum(D)
+ }
+ } else vv<-Reduce('*',v)[,1]
+ ## vv<-if(anc==root) Reduce('*',v)[,1]*pi else Reduce('*',v)[,1]
+ comp[anc]<-sum(vv)
+ liks[anc,]<-vv/comp[anc]
+ }
+ if(output.liks) return(liks[1:M+N,,drop=FALSE])
+ else if(output.pi) return(pi)
+ else {
+ logL<--sum(log(comp[1:M+N]))
+ if(is.na(logL)) logL<-Inf
+ return(logL)
+ }
+ }
+ if(is.null(fixedQ)){
+ if(length(q.init)!=k) q.init<-rep(q.init[1],k)
+ q.init<-if(logscale) log(q.init) else q.init
+ if(opt.method=="optim"){
+ fit<-if(logscale)
+ optim(q.init,function(p) lik(makeQ(m,exp(p),index.matrix),pi=pi),
+ method="L-BFGS-B",lower=rep(log(min.q),k),upper=rep(log(max.q),k)) else
+ optim(q.init,function(p) lik(makeQ(m,p,index.matrix),pi=pi),
+ method="L-BFGS-B",lower=rep(min.q,k),upper=rep(max.q,k))
+ } else if(opt.method=="none"){
+ fit<-list(objective=lik(makeQ(m,q.init,index.matrix),pi=pi),
+ par=q.init)
+ } else {
+ fit<-if(logscale)
+ nlminb(q.init,function(p) lik(makeQ(m,exp(p),index.matrix),pi=pi),
+ lower=rep(log(min.q),k),upper=rep(log(max.q),k))
+ else nlminb(q.init,function(p) lik(makeQ(m,p,index.matrix),
+ pi=pi),lower=rep(0,k),upper=rep(max.q,k))
+ }
+ if(logscale) fit$par<-exp(fit$par)
+ if(pi[1]=="fitzjohn") pi<-setNames(
+ lik(makeQ(m,fit$par,index.matrix),FALSE,pi=pi,output.pi=TRUE),
+ states)
+ obj<-list(logLik=
+ if(opt.method=="optim") -fit$value else -fit$objective,
+ rates=fit$par,
+ index.matrix=index.matrix,
+ states=states,
+ pi=pi,
+ method=opt.method,
+ root.prior=root.prior)
+ if(output.liks) obj$lik.anc<-lik(makeQ(m,obj$rates,index.matrix),TRUE,
+ pi=pi)
+ } else {
+ fit<-lik(Q,pi=pi)
+ if(pi[1]=="fitzjohn") pi<-setNames(lik(Q,FALSE,pi=pi,output.pi=TRUE),states)
+ obj<-list(logLik=-fit,
+ rates=Q[sapply(1:k,function(x,y) which(x==y),index.matrix)],
+ index.matrix=index.matrix,
+ states=states,
+ pi=pi,
+ root.prior=root.prior)
+ if(output.liks) obj$lik.anc<-lik(makeQ(m,obj$rates,index.matrix),TRUE,
+ pi=pi)
+ }
+ lik.f<-function(q) -lik(q,output.liks=FALSE,
+ pi=if(root.prior=="nuisance") "fitzjohn" else pi)
+ obj$data<-x
+ obj$tree<-tree
+ obj$lik<-lik.f
+ class(obj)<-"fitMk"
+ }
+ return(obj)
+}
+
+makeQ<-function(m,q,index.matrix){
+ Q<-matrix(0,m,m)
+ Q[]<-c(0,q)[index.matrix+1]
+ diag(Q)<-0
+ diag(Q)<--rowSums(Q)
+ Q
+}
+
+## print method for objects of class "fitMk"
+print.fitMk<-function(x,digits=6,...){
+ cat("Object of class \"fitMk\".\n\n")
+ cat("Fitted (or set) value of Q:\n")
+ Q<-matrix(NA,length(x$states),length(x$states))
+ Q[]<-c(0,x$rates)[x$index.matrix+1]
+ diag(Q)<-0
+ diag(Q)<--rowSums(Q)
+ colnames(Q)<-rownames(Q)<-x$states
+ print(round(Q,digits))
+ cat("\nFitted (or set) value of pi:\n")
+ print(round(x$pi,digits))
+ cat(paste("due to treating the root prior as (a) ",x$root.prior,".\n",
+ sep=""))
+ cat(paste("\nLog-likelihood:",round(x$logLik,digits),"\n"))
+ cat(paste("\nOptimization method used was \"",x$method,"\"\n\n",
+ sep=""))
+}
+
+## summary method for objects of class "fitMk"
+summary.fitMk<-function(object,...){
+ if(hasArg(digits)) digits<-list(...)$digits
+ else digits<-6
+ if(hasArg(quiet)) quiet<-list(...)$quiet
+ else quiet<-FALSE
+ if(!quiet) cat("Fitted (or set) value of Q:\n")
+ Q<-matrix(NA,length(object$states),length(object$states))
+ Q[]<-c(0,object$rates)[object$index.matrix+1]
+ diag(Q)<-0
+ diag(Q)<--rowSums(Q)
+ colnames(Q)<-rownames(Q)<-object$states
+ if(!quiet) print(round(Q,digits))
+ if(!quiet) cat(paste("\nLog-likelihood:",round(object$logLik,digits),"\n\n"))
+ invisible(list(Q=Q,logLik=object$logLik))
+}
+
+## logLik method for objects of class "fitMk"
+logLik.fitMk<-function(object,...){
+ lik<-object$logLik
+ if(!is.null(object$index.matrix))
+ attr(lik,"df")<-max(object$index.matrix,na.rm=TRUE)
+ else
+ attr(lik,"df")<-length(object$rates)
+ lik
+}
+
+## S3 plot method for objects of class "fitMk"
+plot.fitMk<-function(x,...){
+ Q<-as.Qmatrix(x)
+ plot(Q,...)
+}
+
+## S3 plot method for "gfit" object from geiger::fitDiscrete
+plot.gfit<-function(x,...){
+ if("mkn"%in%class(x$lik)==FALSE){
+ stop("Sorry. No plot method presently available for objects of this type.")
+ object<-NULL
+ } else {
+ chk<-.check.pkg("geiger")
+ if(chk) object<-plot(as.Qmatrix(x),...)
+ else {
+ obj<-list()
+ QQ<-.Qmatrix.from.gfit(x)
+ obj$states<-colnames(QQ)
+ m<-length(obj$states)
+ obj$index.matrix<-matrix(NA,m,m)
+ k<-m*(m-1)
+ obj$index.matrix[col(obj$index.matrix)!=row(obj$index.matrix)]<-1:k
+ obj$rates<-QQ[sapply(1:k,function(x,y) which(x==y),obj$index.matrix)]
+ class(obj)<-"fitMk"
+ object<-plot(obj,...)
+ }
+ }
+ invisible(object)
+}
+
+MIN<-function(x,...) min(x[is.finite(x)],...)
+MAX<-function(x,...) max(x[is.finite(x)],...)
+RANGE<-function(x,...) range(x[is.finite(x)],...)
+
+## S3 method for "Qmatrix" object class
+plot.Qmatrix<-function(x,...){
+ Q<-unclass(x)
+ if(hasArg(signif)) signif<-list(...)$signif
+ else signif<-3
+ if(hasArg(main)) main<-list(...)$main
+ else main<-NULL
+ if(hasArg(cex.main)) cex.main<-list(...)$cex.main
+ else cex.main<-1.2
+ if(hasArg(cex.traits)) cex.traits<-list(...)$cex.traits
+ else cex.traits<-1
+ if(hasArg(cex.rates)) cex.rates<-list(...)$cex.rates
+ else cex.rates<-0.6
+ if(hasArg(show.zeros)) show.zeros<-list(...)$show.zeros
+ else show.zeros<-TRUE
+ if(hasArg(tol)) tol<-list(...)$tol
+ else tol<-1e-6
+ if(hasArg(mar)) mar<-list(...)$mar
+ else mar<-c(1.1,1.1,3.1,1.1)
+ if(hasArg(lwd)) lwd<-list(...)$lwd
+ else lwd<-1
+ if(hasArg(umbral)) umbral<-list(...)$umbral
+ else umbral<-FALSE
+ if(hasArg(ncat)) ncat<-list(...)$ncat
+ else ncat<-NULL
+ if(hasArg(spacer)) spacer<-list(...)$spacer
+ else spacer<-0.1
+ if(hasArg(color)) color<-list(...)$color
+ else color<-FALSE
+ if(hasArg(width)) width<-list(...)$width
+ else width<-FALSE
+ if(hasArg(text)) text<-list(...)$text
+ else text<-TRUE
+ if(hasArg(max.lwd)) max.lwd<-list(...)$max.lwd
+ else max.lwd<-if(text) 5 else 8
+ if(hasArg(rotate)) rotate<-list(...)$rotate
+ else rotate<-NULL
+ if(hasArg(add)) add<-list(...)$add
+ else add<-FALSE
+ if(hasArg(xlim)) xlim<-list(...)$xlim
+ else xlim<-NULL
+ if(hasArg(ylim)) ylim<-list(...)$ylim
+ else ylim<-NULL
+ if(hasArg(offset)) offset<-list(...)$offset
+ else offset<-0.02
+ if(hasArg(palette)) palette<-list(...)$palette
+ else palette<-c("blue","purple","red")
+ ## set all Q<tol to zero (may remove later)
+ Q[Q<tol]<-0
+ ## end may remove later
+ if(!add) plot.new()
+ par(mar=mar)
+ if(is.null(xlim)) xlim<-ylim
+ if(is.null(ylim)) ylim<-xlim
+ if(is.null(xlim)&&is.null(ylim)){
+ if(!color) xlim<-ylim<-c(-1.2,1.2)
+ else {
+ xlim<-c(-1.4,1)
+ ylim<-c(-1.2,1.2)
+ }
+ }
+ plot.window(xlim=xlim,ylim=ylim,asp=1)
+ if(!is.null(main)) title(main=main,cex.main=cex.main)
+ nstates<-nrow(Q)
+ if(is.null(rotate)){
+ if(nstates==2) rotate<--90
+ else rotate<--90*(nstates-2)/(nstates)
+ }
+ if(color){
+ col_pal<-function(qq) if(is.na(qq)) NA else
+ if(is.infinite(qq)) make.transparent("grey",0.6) else
+ rgb(colorRamp(palette)(qq),maxColorValue=255)
+ qq<-Q
+ diag(qq)<-NA
+ qq<-log(qq)
+ dq<-diff(RANGE(qq,na.rm=TRUE))
+ if(dq<tol){
+ cols<-matrix(palette[1],nstates,nstates)
+ cols[Q<tol]<-make.transparent("grey",0.6)
+ } else {
+ qq<-(qq-MIN(qq,na.rm=TRUE))/dq
+ cols<-apply(qq,c(1,2),col_pal)
+ }
+ } else cols<-matrix(par("fg"),nstates,nstates)
+ if(width){
+ lwd_maker<-function(qq,max.qq) if(is.na(qq)) NA else
+ if(is.infinite(qq)) 0 else qq*(max.lwd-1)+1
+ qq<-Q
+ diag(qq)<-NA
+ qq<-log(qq)
+ dq<-max(qq[!is.infinite(qq)],na.rm=TRUE)-
+ min(qq[!is.infinite(qq)],na.rm=TRUE)
+ if(dq<tol){
+ lwd<-matrix(lwd,nstates,nstates)
+ lwd[Q<tol]<-0
+ } else {
+ qq<-(qq-(min(qq[!is.infinite(qq)],na.rm=TRUE)))/dq
+ lwd<-apply(qq,c(1,2),lwd_maker,max.qq=max(qq,na.rm=TRUE))
+ }
+ } else lwd<-matrix(lwd,nstates,nstates)
+ if(!umbral||is.null(ncat)){
+ step<-360/nstates
+ angles<-seq(rotate,360-step+rotate,by=step)/180*pi
+ if(nstates==2) angles<-angles+pi/2
+ v.x<-cos(angles)
+ v.y<-sin(angles)
+ } else {
+ v.x<-v.y<-vector()
+ for(i in 1:length(ncat)){
+ Q<-Q[sort(rownames(Q)),sort(colnames(Q))]
+ xp<--1+2*(i-1)/(length(ncat)-1)
+ v.x<-c(v.x,rep(xp,ncat[i]))
+ yp<-seq(1,-1,length.out=max(ncat))[1:ncat[i]]
+ v.y<-c(v.y,yp)
+ }
+ }
+ for(i in 1:nstates) for(j in 1:nstates)
+ if(if(!isSymmetric(Q)) i!=j else i>j){
+ dx<-v.x[j]-v.x[i]
+ dy<-v.y[j]-v.y[i]
+ slope<-abs(dy/dx)
+ shift.x<-offset*sin(atan(dy/dx))*sign(j-i)*if(dy/dx>0) 1 else -1
+ shift.y<-offset*cos(atan(dy/dx))*sign(j-i)*if(dy/dx>0) -1 else 1
+ s<-c(v.x[i]+spacer*cos(atan(slope))*sign(dx)+
+ if(isSymmetric(Q)) 0 else shift.x,
+ v.y[i]+spacer*sin(atan(slope))*sign(dy)+
+ if(isSymmetric(Q)) 0 else shift.y)
+ e<-c(v.x[j]+spacer*cos(atan(slope))*sign(-dx)+
+ if(isSymmetric(Q)) 0 else shift.x,
+ v.y[j]+spacer*sin(atan(slope))*sign(-dy)+
+ if(isSymmetric(Q)) 0 else shift.y)
+ if(show.zeros||Q[i,j]>tol){
+ if(text){
+ if(abs(diff(c(i,j)))==1||abs(diff(c(i,j)))==(nstates-1))
+ text(mean(c(s[1],e[1]))+1.5*shift.x,
+ mean(c(s[2],e[2]))+1.5*shift.y,
+ round(Q[i,j],signif),cex=cex.rates,
+ srt=atan(dy/dx)*180/pi)
+ else
+ text(mean(c(s[1],e[1]))+0.3*diff(c(s[1],e[1]))+
+ 1.5*shift.x,
+ mean(c(s[2],e[2]))+0.3*diff(c(s[2],e[2]))+
+ 1.5*shift.y,
+ round(Q[i,j],signif),cex=cex.rates,
+ srt=atan(dy/dx)*180/pi)
+ }
+ arrows(s[1],s[2],e[1],e[2],length=0.05,
+ code=if(isSymmetric(Q)) 3 else 2,
+ lwd=if(lwd[i,j]==0) 1 else lwd[i,j],
+ lty=if(lwd[i,j]==0) "dotted" else "solid",
+ col=cols[i,j])
+ }
+ }
+ text(v.x,v.y,rownames(Q),cex=cex.traits,
+ col=make.transparent(par("fg"),0.9))
+ if(color){
+ if(dq>tol){
+ h<-1.5
+ LWD<-diff(par()$usr[1:2])/dev.size("px")[1]
+ lines(x=rep(-1.3+LWD*15/2,2),y=c(-h/2,h/2))
+ nticks<-6
+ Y<-cbind(seq(-h/2,h/2,length.out=nticks),
+ seq(-h/2,h/2,length.out=nticks))
+ X<-cbind(rep(-1.3+LWD*15/2,nticks),
+ rep(-1.3+LWD*15/2+0.02*h,nticks))
+ for(i in 1:nrow(Y)) lines(X[i,],Y[i,])
+ add.color.bar(h,sapply(seq(0,1,length.out=100),col_pal),
+ title="evolutionary rate (q)",
+ lims=NULL,digits=3,
+ direction="upwards",
+ subtitle="",lwd=15,
+ x=-1.3,y=-h/2,prompt=FALSE)
+ QQ<-Q
+ diag(QQ)<-0
+ text(x=X[,2],y=Y[,2],signif(exp(seq(MIN(log(QQ),na.rm=TRUE),
+ MAX(log(QQ),na.rm=TRUE),length.out=6)),signif),pos=4,cex=0.7)
+ } else {
+ BLUE<-function(...) palette[1]
+ h<-1.5
+ LWD<-diff(par()$usr[1:2])/dev.size("px")[1]
+ lines(x=rep(-1.3+LWD*15/2,2),y=c(-h/2,h/2))
+ nticks<-6
+ Y<-cbind(seq(-h/2,h/2,length.out=nticks),
+ seq(-h/2,h/2,length.out=nticks))[nticks,,drop=FALSE]
+ X<-cbind(rep(-1.3+LWD*15/2,nticks),
+ rep(-1.3+LWD*15/2+0.02*h,nticks))[nticks,,drop=FALSE]
+ for(i in 1:nrow(Y)) lines(X[i,],Y[i,])
+ add.color.bar(h,sapply(seq(0,1,length.out=100),BLUE),
+ title="evolutionary rate (q)",
+ lims=NULL,digits=3,
+ direction="upwards",
+ subtitle="",lwd=15,
+ x=-1.3,y=-h/2,prompt=FALSE)
+ QQ<-Q
+ diag(QQ)<-0
+ text(x=X[,2],y=Y[,2],signif(exp(seq(MIN(log(QQ),na.rm=TRUE),
+ MAX(log(QQ),na.rm=TRUE),length.out=1)),signif),pos=4,cex=0.7)
+ }
+ }
+ object<-data.frame(states=rownames(Q),x=v.x,y=v.y)
+ invisible(object)
+}
+
+## wraps around expm
+## written by Liam Revell 2011, 2017
+EXPM<-function(x,...){
+ e_x<-if(isSymmetric(x)) matexpo(x) else expm(x,...)
+ dimnames(e_x)<-dimnames(x)
+ e_x
+}
+
+## function to simulate multiple-rate Mk multiMk
+## written by Liam J. Revell 2018
+sim.multiMk<-function(tree,Q,anc=NULL,nsim=1,...){
+ if(hasArg(as.list)) as.list<-list(...)$as.list
+ else as.list<-FALSE
+ ss<-rownames(Q[[1]])
+ tt<-map.to.singleton(reorder(tree))
+ P<-vector(mode="list",length=nrow(tt$edge))
+ for(i in 1:nrow(tt$edge))
+ P[[i]]<-expm(Q[[names(tt$edge.length)[i]]]*tt$edge.length[i])
+ if(nsim>1) X<- if(as.list) vector(mode="list",length=nsim) else
+ data.frame(row.names=tt$tip.label)
+ for(i in 1:nsim){
+ a<-if(is.null(anc)) sample(ss,1) else anc
+ STATES<-matrix(NA,nrow(tt$edge),2)
+ root<-Ntip(tt)+1
+ STATES[which(tt$edge[,1]==root),1]<-a
+ for(j in 1:nrow(tt$edge)){
+ new<-ss[which(rmultinom(1,1,P[[j]][STATES[j,1],])[,1]==1)]
+ STATES[j,2]<-new
+ ii<-which(tt$edge[,1]==tt$edge[j,2])
+ if(length(ii)>0) STATES[ii,1]<-new
+ }
+ x<-as.factor(
+ setNames(sapply(1:Ntip(tt),function(n,S,E) S[which(E==n)],
+ S=STATES[,2],E=tt$edge[,2]),tt$tip.label))
+ if(nsim>1) X[,i]<-x else X<-x
+ }
+ X
+}
+
+## constant-rate Mk model simulator
+## written by Liam J. Revell 2018
+sim.Mk<-function(tree,Q,anc=NULL,nsim=1,...){
+ if(hasArg(as.list)) as.list<-list(...)$as.list
+ else as.list<-FALSE
+ ss<-rownames(Q)
+ tt<-reorder(tree)
+ P<-vector(mode="list",length=nrow(tt$edge))
+ for(i in 1:nrow(tt$edge))
+ P[[i]]<-expm(Q*tt$edge.length[i])
+ if(nsim>1) X<- if(as.list) vector(mode="list",length=nsim) else
+ data.frame(row.names=tt$tip.label)
+ for(i in 1:nsim){
+ a<-if(is.null(anc)) sample(ss,1) else anc
+ STATES<-matrix(NA,nrow(tt$edge),2)
+ root<-Ntip(tt)+1
+ STATES[which(tt$edge[,1]==root),1]<-a
+ for(j in 1:nrow(tt$edge)){
+ new<-ss[which(rmultinom(1,1,P[[j]][STATES[j,1],])[,1]==1)]
+ STATES[j,2]<-new
+ ii<-which(tt$edge[,1]==tt$edge[j,2])
+ if(length(ii)>0) STATES[ii,1]<-new
+ }
+ x<-as.factor(
+ setNames(sapply(1:Ntip(tt),function(n,S,E) S[which(E==n)],
+ S=STATES[,2],E=tt$edge[,2]),tt$tip.label))
+ if(nsim>1) X[[i]]<-x else X<-x
+ }
+ X
+}
+
+## as.Qmatrix method
+
+as.Qmatrix<-function(x,...){
+ if(identical(class(x),"Qmatrix")) return(x)
+ UseMethod("as.Qmatrix")
+}
+
+as.Qmatrix.default<-function(x, ...){
+ warning(paste(
+ "as.Qmatrix does not know how to handle objects of class ",
+ class(x),"."))
+}
+
+as.Qmatrix.matrix<-function(x, ...){
+ if(ncol(x)!=nrow(x)){
+ warning("\"matrix\" object does not appear to contain a valid Q matrix.\n")
+ } else {
+ diag(x)<--rowSums(x)
+ class(x)<-"Qmatrix"
+ return(x)
+ }
+}
+
+as.Qmatrix.fitMk<-function(x,...){
+ Q<-matrix(NA,length(x$states),length(x$states))
+ Q[]<-c(0,x$rates)[x$index.matrix+1]
+ rownames(Q)<-colnames(Q)<-x$states
+ diag(Q)<--rowSums(Q,na.rm=TRUE)
+ class(Q)<-"Qmatrix"
+ Q
+}
+
+as.Qmatrix.ace<-function(x, ...){
+ if("index.matrix"%in%names(x)){
+ k<-nrow(x$index.matrix)
+ Q<-matrix(NA,k,k)
+ Q[]<-c(0,x$rates)[x$index.matrix+1]
+ rownames(Q)<-colnames(Q)<-colnames(x$lik.anc)
+ diag(Q)<--rowSums(Q,na.rm=TRUE)
+ class(Q)<-"Qmatrix"
+ return(Q)
+ } else cat("\"ace\" object does not appear to contain a Q matrix.\n")
+}
+
+print.Qmatrix<-function(x,...){
+ cat("Estimated Q matrix:\n")
+ print(unclass(x),...)
+}
+
+is.Qmatrix<-function(x) "Qmatrix" %in% class(x)
+
diff --git a/R/fitMk.parallel.R b/R/fitMk.parallel.R
index cd89ed9..204d090 100644
--- a/R/fitMk.parallel.R
+++ b/R/fitMk.parallel.R
@@ -1,71 +1,71 @@
-## parallelized version of fitMk using optimParallel
-
-fitMk.parallel<-function(tree,x,model="SYM",ncores=1,...){
- ## compute states
- if(is.matrix(x)){
- x<-x[tree$tip.label,]
- m<-ncol(x)
- ss<-colnames(x)
- } else {
- x<-to.matrix(x,sort(unique(x)))
- x<-x[tree$tip.label,]
- m<-ncol(x)
- ss<-colnames(x)
- }
- ## set pi
- if(hasArg(pi)) pi<-list(...)$pi
- else pi<-"equal"
- if(is.numeric(pi)) root.prior<-"given"
- if(pi[1]=="equal"){
- pi<-setNames(rep(1/m,m),ss)
- root.prior<-"flat"
- } else if(pi[1]=="fitzjohn") root.prior<-"nuisance"
- if(is.numeric(pi)){
- pi<-pi/sum(pi)
- if(is.null(names(pi))) pi<-setNames(pi,ss)
- pi<-pi[ss]
- }
- ## create object of class "fitMk"
- unfitted<-fitMk(tree,x,model=model,pi=pi,opt.method="none")
- ## get initial values for optimization
- if(hasArg(q.init)) q.init<-list(...)$q.init
- else q.init<-rep(m/sum(tree$edge.length),
- max(unfitted$index.matrix,na.rm=TRUE))
- ## create likelihood function
- loglik<-function(par,lik,index.matrix){
- Q<-makeQ(nrow(index.matrix),exp(par),index.matrix)
- -lik(Q)
- }
- ## create cluster
- cl<-makeCluster(ncores)
- ## optimize model
- fit.parallel<-optimParallel(
- log(q.init),
- loglik,lik=unfitted$lik,
- index.matrix=unfitted$index.matrix,
- lower=log(1e-12),
- upper=log(max(nodeHeights(tree))*100),
- parallel=list(cl=cl,forward=FALSE,
- loginfo=TRUE)
- )
- ## stop cluster
- ## setDefaultCluster(cl=NULL)
- stopCluster(cl)
- ## create object
- estQ<-makeQ(nrow(unfitted$index.matrix),
- exp(fit.parallel$par),
- unfitted$index.matrix)
- colnames(estQ)<-rownames(estQ)<-ss
- temp<-fitMk(tree,x,fixedQ=estQ,pi=pi)
- object<-list()
- object$logLik<-(-fit.parallel$value[1])
- object$rates<-exp(fit.parallel$par)
- object$index.matrix<-unfitted$index.matrix
- object$states<-unfitted$states
- object$pi<-temp$pi
- object$method<-"optimParallel"
- object$root.prior<-temp$root.prior
- object$lik<-temp$lik
- class(object)<-"fitMk"
- object
-}
+## parallelized version of fitMk using optimParallel
+
+fitMk.parallel<-function(tree,x,model="SYM",ncores=1,...){
+ ## compute states
+ if(is.matrix(x)){
+ x<-x[tree$tip.label,]
+ m<-ncol(x)
+ ss<-colnames(x)
+ } else {
+ x<-to.matrix(x,sort(unique(x)))
+ x<-x[tree$tip.label,]
+ m<-ncol(x)
+ ss<-colnames(x)
+ }
+ ## set pi
+ if(hasArg(pi)) pi<-list(...)$pi
+ else pi<-"equal"
+ if(is.numeric(pi)) root.prior<-"given"
+ if(pi[1]=="equal"){
+ pi<-setNames(rep(1/m,m),ss)
+ root.prior<-"flat"
+ } else if(pi[1]=="fitzjohn") root.prior<-"nuisance"
+ if(is.numeric(pi)){
+ pi<-pi/sum(pi)
+ if(is.null(names(pi))) pi<-setNames(pi,ss)
+ pi<-pi[ss]
+ }
+ ## create object of class "fitMk"
+ unfitted<-fitMk(tree,x,model=model,pi=pi,opt.method="none")
+ ## get initial values for optimization
+ if(hasArg(q.init)) q.init<-list(...)$q.init
+ else q.init<-rep(m/sum(tree$edge.length),
+ max(unfitted$index.matrix,na.rm=TRUE))
+ ## create likelihood function
+ loglik<-function(par,lik,index.matrix){
+ Q<-makeQ(nrow(index.matrix),exp(par),index.matrix)
+ -lik(Q)
+ }
+ ## create cluster
+ cl<-makeCluster(ncores)
+ ## optimize model
+ fit.parallel<-optimParallel(
+ log(q.init),
+ loglik,lik=unfitted$lik,
+ index.matrix=unfitted$index.matrix,
+ lower=log(1e-12),
+ upper=log(max(nodeHeights(tree))*100),
+ parallel=list(cl=cl,forward=FALSE,
+ loginfo=TRUE)
+ )
+ ## stop cluster
+ ## setDefaultCluster(cl=NULL)
+ stopCluster(cl)
+ ## create object
+ estQ<-makeQ(nrow(unfitted$index.matrix),
+ exp(fit.parallel$par),
+ unfitted$index.matrix)
+ colnames(estQ)<-rownames(estQ)<-ss
+ temp<-fitMk(tree,x,fixedQ=estQ,pi=pi)
+ object<-list()
+ object$logLik<-(-fit.parallel$value[1])
+ object$rates<-exp(fit.parallel$par)
+ object$index.matrix<-unfitted$index.matrix
+ object$states<-unfitted$states
+ object$pi<-temp$pi
+ object$method<-"optimParallel"
+ object$root.prior<-temp$root.prior
+ object$lik<-temp$lik
+ class(object)<-"fitMk"
+ object
+}
diff --git a/R/fitPagel.R b/R/fitPagel.R
index 364af28..6f35cd3 100644
--- a/R/fitPagel.R
+++ b/R/fitPagel.R
@@ -1,362 +1,362 @@
-## function fits Pagel '94 model of correlated evolution of two binary characters
-## uses fitMk, ape::ace, or geiger::fitDiscrete internally
-## written by Liam J. Revell 2014, 2015, 2016, 2020, 2022
-
-anova.fitPagel<-function(object,...){
- fits<-list(...)
- nm<-c(
- "independent",
- deparse(substitute(object)),
- if(length(fits)>0)
- sapply(substitute(list(...))[-1],deparse)
- )
- logL<-c(object$independent.logL,
- object$dependent.logL,
- if(length(fits)>0)
- sapply(fits,function(x) x$dependent.logL))
- df<-c(attr(object$independent.logL,"df"),
- attr(object$dependent.logL,"df"),
- if(length(fits)>0)
- sapply(fits,function(x) attr(x$dependent.logL,"df")))
- AICvals<-c(object$independent.AIC,
- object$dependent.AIC,
- if(length(fits)>0)
- sapply(fits,function(x) x$dependent.AIC))
- ww<-aic.w(AICvals)
- result<-data.frame(logL,df,AICvals,unclass(ww))
- rownames(result)<-nm
- colnames(result)<-c("log(L)","d.f.","AIC","weight")
- print(result)
- invisible(result)
-}
-
-fitPagel<-function(tree,x,y,method="fitMk",model="ARD",dep.var="xy",...){
- if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".")
- if(dep.var%in%c("x","y","xy")==FALSE){
- cat(" Invalid option for argument \"dep.var\".\n")
- cat(" Setting dep.var=\"xy\" (x depends on y & vice versa)\n\n")
- dep.var<-"xy"
- }
- if(model%in%c("ER","SYM","ARD")==FALSE){
- cat(" Invalid model. Setting model=\"ARD\"\n\n")
- model<-"ARD"
- }
- if(method=="fitDiscrete"){
- chk<-.check.pkg("geiger")
- if(!chk){
- cat(" method = \"fitDiscrete\" requires the package \"geiger\"\n")
- cat(" Defaulting to method = \"fitMk\"\n\n")
- method<-"fitMk"
- fitDiscrete<-function(...) NULL
- }
- }
- if(method%in%c("fitDiscrete","ace","fitMk")==FALSE){
- cat(paste(" method = \"",method,"\" not found.\n",sep=""))
- cat(" Defaulting to method = \"fitMk\"\n\n")
- method<-"fitMk"
- }
- if(is.matrix(x)||is.matrix(y)){
- if(!is.matrix(x)) x<-to.matrix(as.factor(x),levels(as.factor(x)))
- x<-t(apply(x,1,function(xx) xx/sum(xx)))
- if(!is.matrix(y)) y<-to.matrix(as.factor(y),levels(as.factor(y)))
- y<-t(apply(y,1,function(xx) xx/sum(xx)))
- if(method!="fitMk"){
- cat(paste(" method = \"",method,
- "\" does not permit input data as matrices\n",sep=""))
- cat(" Switching to method = \"fitMk\"\n\n")
- method<-"fitMk"
- }
- levels.x<-colnames(x)
- levels.y<-colnames(y)
- levels.xy<-as.vector(sapply(levels.x,paste,levels.y,sep="|"))
- xy<-matrix(NA,nrow(x),4,dimnames=list(rownames(x),levels.xy))
- for(i in 1:nrow(xy))
- xy[i,]<-as.vector(y[i,]%*%x[i,,drop=FALSE])
- } else {
- if(!is.factor(x)) x<-as.factor(x)
- levels.x<-levels(x)
- if(!is.factor(y)) y<-as.factor(y)
- levels.y<-levels(y)
- y<-y[names(x)]
- if(length(levels.x)!=2||length(levels.y)!=2)
- stop("Only binary characters for x & y currently permitted.")
- xy<-setNames(factor(paste(x,y,sep="|"),
- levels=sapply(levels.x,paste,levels.y,sep="|")),
- names(x))
- levels.xy<-levels(xy)
- }
- ## fit independent dep.var
- iQ<-matrix(c(0,1,2,0,3,0,0,2,4,0,0,1,0,4,3,0),4,4,byrow=TRUE)
- if(model%in%c("ER","SYM")) iQ<-make.sym(iQ)
- k.iQ<-length(unique(as.vector(iQ)))-1
- rownames(iQ)<-colnames(iQ)<-levels.xy
- fit.iQ<-if(method=="fitDiscrete") fitDiscrete(tree,xy,model=iQ,...)
- else if(method=="ace") ace(xy,tree,type="discrete",model=iQ,...)
- else fitMk(tree,if(!is.matrix(xy)) to.matrix(xy,levels(xy)) else xy,
- model=iQ,...)
- ## fit dependendent model
- if(dep.var=="xy")
- dQ<-matrix(c(0,1,2,0,3,0,0,4,5,0,0,6,0,7,8,0),4,4,byrow=TRUE)
- else if(dep.var=="x")
- dQ<-matrix(c(0,1,2,0,3,0,0,4,5,0,0,1,0,6,3,0),4,4,byrow=TRUE)
- else if(dep.var=="y")
- dQ<-matrix(c(0,1,2,0,3,0,0,2,4,0,0,5,0,4,6,0),4,4,byrow=TRUE)
- if(model%in%c("ER","SYM")) dQ<-make.sym(dQ)
- k.dQ<-length(unique(as.vector(dQ)))-1
- rownames(dQ)<-colnames(dQ)<-levels.xy
- fit.dQ<-if(method=="fitDiscrete") fitDiscrete(tree,xy,model=dQ,...)
- else if(method=="ace") ace(xy,tree,type="discrete",model=dQ,...)
- else fitMk(tree,if(!is.matrix(xy)) to.matrix(xy,levels(xy)) else xy,
- model=dQ,...)
- ## back translate independent model
- if(method=="fitDiscrete") iQ<-.Qmatrix.from.gfit(fit.iQ)
- else {
- I<-fit.iQ$index.matrix
- I[I==0]<-NA
- iQ<-apply(I,2,function(i,x) x[i],x=fit.iQ$rates)
- iQ[is.na(iQ)]<-0
- diag(iQ)<--rowSums(iQ)
- rownames(iQ)<-colnames(iQ)
- }
- ## dependent model
- if(method=="fitDiscrete") dQ<-.Qmatrix.from.gfit(fit.dQ)
- else {
- I<-fit.dQ$index.matrix
- I[I==0]<-NA
- dQ<-apply(I,2,function(i,x) x[i],x=fit.dQ$rates)
- dQ[is.na(dQ)]<-0
- diag(dQ)<--rowSums(dQ)
- rownames(dQ)<-colnames(dQ)
- }
- ## assemble object to return
- obj<-list(independent.Q=iQ,
- dependent.Q=dQ,
- independent.logL=logLik(fit.iQ),
- dependent.logL=logLik(fit.dQ),
- independent.AIC=2*k.iQ-2*logLik(fit.iQ),
- dependent.AIC=2*k.dQ-2*logLik(fit.dQ),
- lik.ratio=2*(logLik(fit.dQ)-logLik(fit.iQ)),
- P=pchisq(2*(logLik(fit.dQ)-logLik(fit.iQ)),
- df=k.dQ-k.iQ,
- lower.tail=FALSE),
- method=method,
- dep.var=dep.var,
- model=model)
- class(obj)<-"fitPagel"
- obj
-}
-
-## print method for objects of class "fitPagel"
-## written by Liam J. Revell 2014, 2016
-print.fitPagel<-function(x,...){
- if(hasArg(digits)) digits<-list(...)$digits
- else digits<-6
- cat("\nPagel's binary character correlation test:\n")
- cat(paste("\nAssumes \"",x$model,
- "\" substitution model for both characters\n",sep=""))
- cat("\nIndependent model rate matrix:\n")
- print(round(x$independent.Q,digits))
- tmp<-if(x$dep.var=="xy") "x & y"
- else if(x$dep.var=="x") "x only"
- else if(x$dep.var=="y") "y only"
- cat(paste("\nDependent (",tmp,") model rate matrix:\n",sep=""))
- print(round(x$dependent.Q,digits))
- cat("\nModel fit:\n")
- obj<-matrix(c(x$independent.logL,x$dependent.logL,
- x$independent.AIC,x$dependent.AIC),2,2)
- rownames(obj)<-c("independent","dependent")
- colnames(obj)<-c("log-likelihood","AIC")
- print(round(obj,digits))
- cat("\nHypothesis test result:\n")
- cat(paste(" likelihood-ratio: ",signif(x$lik.ratio,digits),"\n"))
- cat(paste(" p-value: ",signif(x$P,digits),"\n"))
- cat(paste("\nModel fitting method used was",x$method,"\n\n"))
-}
-
-## function borrowed from geiger to pull the Q-matrix from a fit returned by
-## fitDiscrete
-.Qmatrix.from.gfit<-function(x){
- if(!.check.pkg("geiger")) argn<-function(...) NULL
- lik=x$lik
- numberize=function(x){
- y=gsub("q","",x)
- sp=(nn<-nchar(y))/2
- as.numeric(c(substring(y,1,sp),substring(y,sp+1,
- nn)))
- }
- att=attributes(lik)
- att$k=length(att$levels)
- Qmat=matrix(0,att$k,att$k)
- nms=att$argn[att$trns]
- other=att$argn[!att$trns]
- if("constrained"%in%class(lik)){
- cpars=x$opt[argn(lik)]
- apars=names(lik(unlist(cpars),pars.only=TRUE))
- nms=apars[!apars%in%other]
- }
- trns=x$opt[nms]
- for(i in 1:length(trns)){
- nm=names(trns)[i]
- idx=numberize(nm)
- Qmat[idx[1],idx[2]]=trns[[i]]
- }
- diag(Qmat)=-rowSums(Qmat)
- rownames(Qmat)<-colnames(Qmat)<-levels(lik)
- Qmat
-}
-
-## make the model matrix symmetric
-make.sym<-function(X){
- for(i in 1:nrow(X)) for(j in i:nrow(X)) X[j,i]<-X[i,j]
- X
-}
-
-## S3 plot method for objects of class "fitPagel
-## written by Liam J. Revell 2016
-plot.fitPagel<-function(x,...){
- if(hasArg(signif)) signif<-list(...)$signif
- else signif<-3
- if(hasArg(main)) main<-list(...)$main
- else main<-NULL
- if(!is.null(main)&&length(main)==1) main<-rep(main,2)
- if(hasArg(cex.main)) cex.main<-list(...)$cex.main
- else cex.main<-1.2
- if(hasArg(cex.sub)) cex.sub<-list(...)$cex.sub
- else cex.sub<-1
- if(hasArg(cex.traits)) cex.traits<-list(...)$cex.traits
- else cex.traits<-0.9
- if(hasArg(cex.rates)) cex.rates<-list(...)$cex.rates
- else cex.rates<-0.8
- if(hasArg(lwd)) lwd<-list(...)$lwd
- else lwd<-2 ## only used if lwd.by.rate=FALSE
- if(hasArg(lwd.by.rate)) lwd.by.rate<-list(...)$lwd.by.rate
- else lwd.by.rate<-FALSE
- if(lwd.by.rate){
- rates<-c(x$independent.Q[x$independent.Q>0],x$dependent.Q[x$dependent.Q>0])
- LWD.ind<-round(x$independent.Q/min(rates))
- LWD.dep<-round(x$dependent.Q/min(rates))
- if(hasArg(max.lwd)) max.lwd<-list(...)$max.lwd
- else max.lwd<-10
- LWD.ind[LWD.ind>max.lwd]<-max.lwd
- LWD.dep[LWD.dep>max.lwd]<-max.lwd
- } else LWD.ind<-LWD.dep<-matrix(lwd,nrow(x$dependent.Q),
- ncol(x$dependent.Q))
- par(mfrow=c(2,1))
- ## INDEPENDENT MODEL
- plot.new()
- par(mar=c(1.1,2.1,3.1,2.1))
- plot.window(xlim=c(0,2),ylim=c(0,1),asp=1)
- mtext(if(!is.null(main)) main[1] else "a) Independent model",
- side=3,adj=0,line=1.2,cex=cex.main)
- ## trait 1
- text(x=0.15,y=1,"Trait 1:",cex=cex.sub)
- arrows(x0=0.5,y0=0.15,x1=0.5,y1=0.85,
- lwd=max(LWD.ind[3,1],1),
- lty=if(LWD.ind[3,1]==0) "dashed" else "solid",
- length=0.15,lend=3,angle=20)
- arrows(x0=0.55,y0=0.85,x1=0.55,y1=0.15,
- lwd=max(LWD.ind[1,3],1),
- lty=if(LWD.ind[1,3]==0) "dashed" else "solid",
- length=0.15,lend=3,angle=20)
- text(x=0.525,y=0.95,namesplit(rownames(x$dependent.Q)[1])[1],
- cex=cex.traits)
- text(x=0.525,y=0.05,namesplit(rownames(x$dependent.Q)[3])[1],
- cex=cex.traits)
- text(x=0.60,y=0.5,round(x$independent.Q[1,3],signif),cex=cex.rates,srt=90)
- text(x=0.45,y=0.5,round(x$independent.Q[3,1],signif),cex=cex.rates,srt=90)
- ## trait 2
- text(x=1.3,y=1,"Trait 2:",cex=cex.sub)
- arrows(x0=1.65,y0=0.15,x1=1.65,y1=0.85,
- lwd=max(LWD.ind[2,1],1),
- lty=if(LWD.ind[2,1]==0) "dashed" else "solid",
- length=0.15,lend=3,angle=20)
- arrows(x0=1.70,y0=0.85,x1=1.70,y1=0.15,
- lwd=max(LWD.ind[1,2],1),
- lty=if(LWD.ind[1,2]==0) "dashed" else "solid",
- length=0.15,lend=3,angle=20)
- text(x=1.675,y=0.95,namesplit(rownames(x$dependent.Q)[1])[2],
- cex=cex.traits)
- text(x=1.675,y=0.05,namesplit(rownames(x$dependent.Q)[2])[2],
- cex=cex.traits)
- text(x=1.75,y=0.5,round(x$independent.Q[1,2],signif),cex=cex.rates,srt=90)
- text(x=1.60,y=0.5,round(x$independent.Q[2,1],signif),cex=cex.rates,srt=90)
- ## DEPENDENT MODEL
- collapse<-
- if(any(sapply(strsplit(rownames(x$dependent.Q),""),length)>6))
- ",\n" else ", "
- plot.new()
- par(mar=c(1.1,2.1,3.1,2.1))
- plot.window(xlim=c(0,2),ylim=c(0,1),asp=1)
- mtext(if(!is.null(main)) main[2] else "b) Dependent model",
- side=3,adj=0,line=1.2,cex=cex.main)
- text(x=0.15,y=0.95,"Trait 1,\nTrait 2:",cex=cex.sub)
- arrows(x0=0.5,y0=0.15,x1=0.5,y1=0.85,
- lwd=max(LWD.dep[3,1],1),
- lty=if(LWD.dep[3,1]==0) "dashed" else "solid",
- length=0.15,lend=3,angle=20)
- arrows(x0=0.55,y0=0.85,x1=0.55,y1=0.15,
- lwd=max(LWD.dep[1,3],1),
- lty=if(LWD.dep[1,3]==0) "dashed" else "solid",
- length=0.15,lend=3,angle=20)
- arrows(x0=1.45,y0=0.05,x1=0.75,y1=0.05,
- lwd=max(LWD.dep[4,3],1),
- lty=if(LWD.dep[4,3]==0) "dashed" else "solid",
- length=0.15,lend=3,angle=20)
- arrows(x0=0.75,y0=0.1,x1=1.45,y1=0.1,
- lwd=max(LWD.dep[3,4],1),
- lty=if(LWD.dep[3,4]==0) "dashed" else "solid",
- length=0.15,lend=3,angle=20)
- arrows(x0=1.65,y0=0.15,x1=1.65,y1=0.85,
- lwd=max(LWD.dep[4,2],1),
- lty=if(LWD.dep[4,2]==0) "dashed" else "solid",
- length=0.15,lend=3,angle=20)
- arrows(x0=1.7,y0=0.85,x1=1.7,y1=0.15,
- lwd=max(LWD.dep[2,4],1),
- lty=if(LWD.dep[2,4]==0) "dashed" else "solid",
- length=0.15,lend=3,angle=20)
- arrows(x0=1.45,y0=0.9,x1=0.75,y1=0.9,
- lwd=max(LWD.dep[2,1],1),
- lty=if(LWD.dep[2,1]==0) "dashed" else "solid",
- length=0.15,lend=3,angle=20)
- arrows(x0=0.75,y0=0.95,x1=1.45,y1=0.95,
- lwd=max(LWD.dep[1,2],1),
- lty=if(LWD.dep[1,2]==0) "dashed" else "solid",
- length=0.15,lend=3,angle=20)
- ## add states
- text(x=0.525,y=0.95,
- paste(namesplit(rownames(x$dependent.Q)[1]),
- collapse=collapse),cex=cex.traits)
- text(x=1.675,y=0.95,
- paste(namesplit(rownames(x$dependent.Q)[2]),
- collapse=collapse),cex=cex.traits)
- text(x=1.675,y=0.05,
- paste(namesplit(rownames(x$dependent.Q)[4]),
- collapse=collapse),cex=cex.traits)
- text(x=0.525,y=0.05,
- paste(namesplit(rownames(x$dependent.Q)[3]),
- collapse=collapse),cex=cex.traits)
- ## add rates
- text(x=1.1,y=1,round(x$dependent.Q[1,2],signif),
- cex=cex.rates)
- text(x=1.1,y=0.85,round(x$dependent.Q[2,1],signif),
- cex=cex.rates)
- text(x=1.6,y=0.5,round(x$dependent.Q[4,2],signif),
- cex=cex.rates,srt=90)
- text(x=1.75,y=0.5,round(x$dependent.Q[2,4],signif),
- cex=cex.rates,srt=90)
- text(x=1.1,y=0,round(x$dependent.Q[4,3],signif),
- cex=cex.rates)
- text(x=1.1,y=0.15,round(x$dependent.Q[3,4],signif),
- cex=cex.rates)
- text(x=0.45,y=0.5,round(x$dependent.Q[3,1],signif),
- cex=cex.rates,srt=90)
- text(x=0.6,y=0.5,round(x$dependent.Q[1,3],signif),
- cex=cex.rates,srt=90)
-}
-
-namesplit<-function(x){
- tmp<-strsplit(x,"")[[1]]
- ii<-which(tmp=="|")
- c(paste(tmp[1:(ii-1)],collapse=""),
- paste(tmp[(ii+1):length(tmp)],collapse=""))
+## function fits Pagel '94 model of correlated evolution of two binary characters
+## uses fitMk, ape::ace, or geiger::fitDiscrete internally
+## written by Liam J. Revell 2014, 2015, 2016, 2020, 2022
+
+anova.fitPagel<-function(object,...){
+ fits<-list(...)
+ nm<-c(
+ "independent",
+ deparse(substitute(object)),
+ if(length(fits)>0)
+ sapply(substitute(list(...))[-1],deparse)
+ )
+ logL<-c(object$independent.logL,
+ object$dependent.logL,
+ if(length(fits)>0)
+ sapply(fits,function(x) x$dependent.logL))
+ df<-c(attr(object$independent.logL,"df"),
+ attr(object$dependent.logL,"df"),
+ if(length(fits)>0)
+ sapply(fits,function(x) attr(x$dependent.logL,"df")))
+ AICvals<-c(object$independent.AIC,
+ object$dependent.AIC,
+ if(length(fits)>0)
+ sapply(fits,function(x) x$dependent.AIC))
+ ww<-aic.w(AICvals)
+ result<-data.frame(logL,df,AICvals,unclass(ww))
+ rownames(result)<-nm
+ colnames(result)<-c("log(L)","d.f.","AIC","weight")
+ print(result)
+ invisible(result)
+}
+
+fitPagel<-function(tree,x,y,method="fitMk",model="ARD",dep.var="xy",...){
+ if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".")
+ if(dep.var%in%c("x","y","xy")==FALSE){
+ cat(" Invalid option for argument \"dep.var\".\n")
+ cat(" Setting dep.var=\"xy\" (x depends on y & vice versa)\n\n")
+ dep.var<-"xy"
+ }
+ if(model%in%c("ER","SYM","ARD")==FALSE){
+ cat(" Invalid model. Setting model=\"ARD\"\n\n")
+ model<-"ARD"
+ }
+ if(method=="fitDiscrete"){
+ chk<-.check.pkg("geiger")
+ if(!chk){
+ cat(" method = \"fitDiscrete\" requires the package \"geiger\"\n")
+ cat(" Defaulting to method = \"fitMk\"\n\n")
+ method<-"fitMk"
+ fitDiscrete<-function(...) NULL
+ }
+ }
+ if(method%in%c("fitDiscrete","ace","fitMk")==FALSE){
+ cat(paste(" method = \"",method,"\" not found.\n",sep=""))
+ cat(" Defaulting to method = \"fitMk\"\n\n")
+ method<-"fitMk"
+ }
+ if(is.matrix(x)||is.matrix(y)){
+ if(!is.matrix(x)) x<-to.matrix(as.factor(x),levels(as.factor(x)))
+ x<-t(apply(x,1,function(xx) xx/sum(xx)))
+ if(!is.matrix(y)) y<-to.matrix(as.factor(y),levels(as.factor(y)))
+ y<-t(apply(y,1,function(xx) xx/sum(xx)))
+ if(method!="fitMk"){
+ cat(paste(" method = \"",method,
+ "\" does not permit input data as matrices\n",sep=""))
+ cat(" Switching to method = \"fitMk\"\n\n")
+ method<-"fitMk"
+ }
+ levels.x<-colnames(x)
+ levels.y<-colnames(y)
+ levels.xy<-as.vector(sapply(levels.x,paste,levels.y,sep="|"))
+ xy<-matrix(NA,nrow(x),4,dimnames=list(rownames(x),levels.xy))
+ for(i in 1:nrow(xy))
+ xy[i,]<-as.vector(y[i,]%*%x[i,,drop=FALSE])
+ } else {
+ if(!is.factor(x)) x<-as.factor(x)
+ levels.x<-levels(x)
+ if(!is.factor(y)) y<-as.factor(y)
+ levels.y<-levels(y)
+ y<-y[names(x)]
+ if(length(levels.x)!=2||length(levels.y)!=2)
+ stop("Only binary characters for x & y currently permitted.")
+ xy<-setNames(factor(paste(x,y,sep="|"),
+ levels=sapply(levels.x,paste,levels.y,sep="|")),
+ names(x))
+ levels.xy<-levels(xy)
+ }
+ ## fit independent dep.var
+ iQ<-matrix(c(0,1,2,0,3,0,0,2,4,0,0,1,0,4,3,0),4,4,byrow=TRUE)
+ if(model%in%c("ER","SYM")) iQ<-make.sym(iQ)
+ k.iQ<-length(unique(as.vector(iQ)))-1
+ rownames(iQ)<-colnames(iQ)<-levels.xy
+ fit.iQ<-if(method=="fitDiscrete") fitDiscrete(tree,xy,model=iQ,...)
+ else if(method=="ace") ace(xy,tree,type="discrete",model=iQ,...)
+ else fitMk(tree,if(!is.matrix(xy)) to.matrix(xy,levels(xy)) else xy,
+ model=iQ,...)
+ ## fit dependendent model
+ if(dep.var=="xy")
+ dQ<-matrix(c(0,1,2,0,3,0,0,4,5,0,0,6,0,7,8,0),4,4,byrow=TRUE)
+ else if(dep.var=="x")
+ dQ<-matrix(c(0,1,2,0,3,0,0,4,5,0,0,1,0,6,3,0),4,4,byrow=TRUE)
+ else if(dep.var=="y")
+ dQ<-matrix(c(0,1,2,0,3,0,0,2,4,0,0,5,0,4,6,0),4,4,byrow=TRUE)
+ if(model%in%c("ER","SYM")) dQ<-make.sym(dQ)
+ k.dQ<-length(unique(as.vector(dQ)))-1
+ rownames(dQ)<-colnames(dQ)<-levels.xy
+ fit.dQ<-if(method=="fitDiscrete") fitDiscrete(tree,xy,model=dQ,...)
+ else if(method=="ace") ace(xy,tree,type="discrete",model=dQ,...)
+ else fitMk(tree,if(!is.matrix(xy)) to.matrix(xy,levels(xy)) else xy,
+ model=dQ,...)
+ ## back translate independent model
+ if(method=="fitDiscrete") iQ<-.Qmatrix.from.gfit(fit.iQ)
+ else {
+ I<-fit.iQ$index.matrix
+ I[I==0]<-NA
+ iQ<-apply(I,2,function(i,x) x[i],x=fit.iQ$rates)
+ iQ[is.na(iQ)]<-0
+ diag(iQ)<--rowSums(iQ)
+ rownames(iQ)<-colnames(iQ)
+ }
+ ## dependent model
+ if(method=="fitDiscrete") dQ<-.Qmatrix.from.gfit(fit.dQ)
+ else {
+ I<-fit.dQ$index.matrix
+ I[I==0]<-NA
+ dQ<-apply(I,2,function(i,x) x[i],x=fit.dQ$rates)
+ dQ[is.na(dQ)]<-0
+ diag(dQ)<--rowSums(dQ)
+ rownames(dQ)<-colnames(dQ)
+ }
+ ## assemble object to return
+ obj<-list(independent.Q=iQ,
+ dependent.Q=dQ,
+ independent.logL=logLik(fit.iQ),
+ dependent.logL=logLik(fit.dQ),
+ independent.AIC=2*k.iQ-2*logLik(fit.iQ),
+ dependent.AIC=2*k.dQ-2*logLik(fit.dQ),
+ lik.ratio=2*(logLik(fit.dQ)-logLik(fit.iQ)),
+ P=pchisq(2*(logLik(fit.dQ)-logLik(fit.iQ)),
+ df=k.dQ-k.iQ,
+ lower.tail=FALSE),
+ method=method,
+ dep.var=dep.var,
+ model=model)
+ class(obj)<-"fitPagel"
+ obj
+}
+
+## print method for objects of class "fitPagel"
+## written by Liam J. Revell 2014, 2016
+print.fitPagel<-function(x,...){
+ if(hasArg(digits)) digits<-list(...)$digits
+ else digits<-6
+ cat("\nPagel's binary character correlation test:\n")
+ cat(paste("\nAssumes \"",x$model,
+ "\" substitution model for both characters\n",sep=""))
+ cat("\nIndependent model rate matrix:\n")
+ print(round(x$independent.Q,digits))
+ tmp<-if(x$dep.var=="xy") "x & y"
+ else if(x$dep.var=="x") "x only"
+ else if(x$dep.var=="y") "y only"
+ cat(paste("\nDependent (",tmp,") model rate matrix:\n",sep=""))
+ print(round(x$dependent.Q,digits))
+ cat("\nModel fit:\n")
+ obj<-matrix(c(x$independent.logL,x$dependent.logL,
+ x$independent.AIC,x$dependent.AIC),2,2)
+ rownames(obj)<-c("independent","dependent")
+ colnames(obj)<-c("log-likelihood","AIC")
+ print(round(obj,digits))
+ cat("\nHypothesis test result:\n")
+ cat(paste(" likelihood-ratio: ",signif(x$lik.ratio,digits),"\n"))
+ cat(paste(" p-value: ",signif(x$P,digits),"\n"))
+ cat(paste("\nModel fitting method used was",x$method,"\n\n"))
+}
+
+## function borrowed from geiger to pull the Q-matrix from a fit returned by
+## fitDiscrete
+.Qmatrix.from.gfit<-function(x){
+ if(!.check.pkg("geiger")) argn<-function(...) NULL
+ lik=x$lik
+ numberize=function(x){
+ y=gsub("q","",x)
+ sp=(nn<-nchar(y))/2
+ as.numeric(c(substring(y,1,sp),substring(y,sp+1,
+ nn)))
+ }
+ att=attributes(lik)
+ att$k=length(att$levels)
+ Qmat=matrix(0,att$k,att$k)
+ nms=att$argn[att$trns]
+ other=att$argn[!att$trns]
+ if("constrained"%in%class(lik)){
+ cpars=x$opt[argn(lik)]
+ apars=names(lik(unlist(cpars),pars.only=TRUE))
+ nms=apars[!apars%in%other]
+ }
+ trns=x$opt[nms]
+ for(i in 1:length(trns)){
+ nm=names(trns)[i]
+ idx=numberize(nm)
+ Qmat[idx[1],idx[2]]=trns[[i]]
+ }
+ diag(Qmat)=-rowSums(Qmat)
+ rownames(Qmat)<-colnames(Qmat)<-levels(lik)
+ Qmat
+}
+
+## make the model matrix symmetric
+make.sym<-function(X){
+ for(i in 1:nrow(X)) for(j in i:nrow(X)) X[j,i]<-X[i,j]
+ X
+}
+
+## S3 plot method for objects of class "fitPagel
+## written by Liam J. Revell 2016
+plot.fitPagel<-function(x,...){
+ if(hasArg(signif)) signif<-list(...)$signif
+ else signif<-3
+ if(hasArg(main)) main<-list(...)$main
+ else main<-NULL
+ if(!is.null(main)&&length(main)==1) main<-rep(main,2)
+ if(hasArg(cex.main)) cex.main<-list(...)$cex.main
+ else cex.main<-1.2
+ if(hasArg(cex.sub)) cex.sub<-list(...)$cex.sub
+ else cex.sub<-1
+ if(hasArg(cex.traits)) cex.traits<-list(...)$cex.traits
+ else cex.traits<-0.9
+ if(hasArg(cex.rates)) cex.rates<-list(...)$cex.rates
+ else cex.rates<-0.8
+ if(hasArg(lwd)) lwd<-list(...)$lwd
+ else lwd<-2 ## only used if lwd.by.rate=FALSE
+ if(hasArg(lwd.by.rate)) lwd.by.rate<-list(...)$lwd.by.rate
+ else lwd.by.rate<-FALSE
+ if(lwd.by.rate){
+ rates<-c(x$independent.Q[x$independent.Q>0],x$dependent.Q[x$dependent.Q>0])
+ LWD.ind<-round(x$independent.Q/min(rates))
+ LWD.dep<-round(x$dependent.Q/min(rates))
+ if(hasArg(max.lwd)) max.lwd<-list(...)$max.lwd
+ else max.lwd<-10
+ LWD.ind[LWD.ind>max.lwd]<-max.lwd
+ LWD.dep[LWD.dep>max.lwd]<-max.lwd
+ } else LWD.ind<-LWD.dep<-matrix(lwd,nrow(x$dependent.Q),
+ ncol(x$dependent.Q))
+ par(mfrow=c(2,1))
+ ## INDEPENDENT MODEL
+ plot.new()
+ par(mar=c(1.1,2.1,3.1,2.1))
+ plot.window(xlim=c(0,2),ylim=c(0,1),asp=1)
+ mtext(if(!is.null(main)) main[1] else "a) Independent model",
+ side=3,adj=0,line=1.2,cex=cex.main)
+ ## trait 1
+ text(x=0.15,y=1,"Trait 1:",cex=cex.sub)
+ arrows(x0=0.5,y0=0.15,x1=0.5,y1=0.85,
+ lwd=max(LWD.ind[3,1],1),
+ lty=if(LWD.ind[3,1]==0) "dashed" else "solid",
+ length=0.15,lend=3,angle=20)
+ arrows(x0=0.55,y0=0.85,x1=0.55,y1=0.15,
+ lwd=max(LWD.ind[1,3],1),
+ lty=if(LWD.ind[1,3]==0) "dashed" else "solid",
+ length=0.15,lend=3,angle=20)
+ text(x=0.525,y=0.95,namesplit(rownames(x$dependent.Q)[1])[1],
+ cex=cex.traits)
+ text(x=0.525,y=0.05,namesplit(rownames(x$dependent.Q)[3])[1],
+ cex=cex.traits)
+ text(x=0.60,y=0.5,round(x$independent.Q[1,3],signif),cex=cex.rates,srt=90)
+ text(x=0.45,y=0.5,round(x$independent.Q[3,1],signif),cex=cex.rates,srt=90)
+ ## trait 2
+ text(x=1.3,y=1,"Trait 2:",cex=cex.sub)
+ arrows(x0=1.65,y0=0.15,x1=1.65,y1=0.85,
+ lwd=max(LWD.ind[2,1],1),
+ lty=if(LWD.ind[2,1]==0) "dashed" else "solid",
+ length=0.15,lend=3,angle=20)
+ arrows(x0=1.70,y0=0.85,x1=1.70,y1=0.15,
+ lwd=max(LWD.ind[1,2],1),
+ lty=if(LWD.ind[1,2]==0) "dashed" else "solid",
+ length=0.15,lend=3,angle=20)
+ text(x=1.675,y=0.95,namesplit(rownames(x$dependent.Q)[1])[2],
+ cex=cex.traits)
+ text(x=1.675,y=0.05,namesplit(rownames(x$dependent.Q)[2])[2],
+ cex=cex.traits)
+ text(x=1.75,y=0.5,round(x$independent.Q[1,2],signif),cex=cex.rates,srt=90)
+ text(x=1.60,y=0.5,round(x$independent.Q[2,1],signif),cex=cex.rates,srt=90)
+ ## DEPENDENT MODEL
+ collapse<-
+ if(any(sapply(strsplit(rownames(x$dependent.Q),""),length)>6))
+ ",\n" else ", "
+ plot.new()
+ par(mar=c(1.1,2.1,3.1,2.1))
+ plot.window(xlim=c(0,2),ylim=c(0,1),asp=1)
+ mtext(if(!is.null(main)) main[2] else "b) Dependent model",
+ side=3,adj=0,line=1.2,cex=cex.main)
+ text(x=0.15,y=0.95,"Trait 1,\nTrait 2:",cex=cex.sub)
+ arrows(x0=0.5,y0=0.15,x1=0.5,y1=0.85,
+ lwd=max(LWD.dep[3,1],1),
+ lty=if(LWD.dep[3,1]==0) "dashed" else "solid",
+ length=0.15,lend=3,angle=20)
+ arrows(x0=0.55,y0=0.85,x1=0.55,y1=0.15,
+ lwd=max(LWD.dep[1,3],1),
+ lty=if(LWD.dep[1,3]==0) "dashed" else "solid",
+ length=0.15,lend=3,angle=20)
+ arrows(x0=1.45,y0=0.05,x1=0.75,y1=0.05,
+ lwd=max(LWD.dep[4,3],1),
+ lty=if(LWD.dep[4,3]==0) "dashed" else "solid",
+ length=0.15,lend=3,angle=20)
+ arrows(x0=0.75,y0=0.1,x1=1.45,y1=0.1,
+ lwd=max(LWD.dep[3,4],1),
+ lty=if(LWD.dep[3,4]==0) "dashed" else "solid",
+ length=0.15,lend=3,angle=20)
+ arrows(x0=1.65,y0=0.15,x1=1.65,y1=0.85,
+ lwd=max(LWD.dep[4,2],1),
+ lty=if(LWD.dep[4,2]==0) "dashed" else "solid",
+ length=0.15,lend=3,angle=20)
+ arrows(x0=1.7,y0=0.85,x1=1.7,y1=0.15,
+ lwd=max(LWD.dep[2,4],1),
+ lty=if(LWD.dep[2,4]==0) "dashed" else "solid",
+ length=0.15,lend=3,angle=20)
+ arrows(x0=1.45,y0=0.9,x1=0.75,y1=0.9,
+ lwd=max(LWD.dep[2,1],1),
+ lty=if(LWD.dep[2,1]==0) "dashed" else "solid",
+ length=0.15,lend=3,angle=20)
+ arrows(x0=0.75,y0=0.95,x1=1.45,y1=0.95,
+ lwd=max(LWD.dep[1,2],1),
+ lty=if(LWD.dep[1,2]==0) "dashed" else "solid",
+ length=0.15,lend=3,angle=20)
+ ## add states
+ text(x=0.525,y=0.95,
+ paste(namesplit(rownames(x$dependent.Q)[1]),
+ collapse=collapse),cex=cex.traits)
+ text(x=1.675,y=0.95,
+ paste(namesplit(rownames(x$dependent.Q)[2]),
+ collapse=collapse),cex=cex.traits)
+ text(x=1.675,y=0.05,
+ paste(namesplit(rownames(x$dependent.Q)[4]),
+ collapse=collapse),cex=cex.traits)
+ text(x=0.525,y=0.05,
+ paste(namesplit(rownames(x$dependent.Q)[3]),
+ collapse=collapse),cex=cex.traits)
+ ## add rates
+ text(x=1.1,y=1,round(x$dependent.Q[1,2],signif),
+ cex=cex.rates)
+ text(x=1.1,y=0.85,round(x$dependent.Q[2,1],signif),
+ cex=cex.rates)
+ text(x=1.6,y=0.5,round(x$dependent.Q[4,2],signif),
+ cex=cex.rates,srt=90)
+ text(x=1.75,y=0.5,round(x$dependent.Q[2,4],signif),
+ cex=cex.rates,srt=90)
+ text(x=1.1,y=0,round(x$dependent.Q[4,3],signif),
+ cex=cex.rates)
+ text(x=1.1,y=0.15,round(x$dependent.Q[3,4],signif),
+ cex=cex.rates)
+ text(x=0.45,y=0.5,round(x$dependent.Q[3,1],signif),
+ cex=cex.rates,srt=90)
+ text(x=0.6,y=0.5,round(x$dependent.Q[1,3],signif),
+ cex=cex.rates,srt=90)
+}
+
+namesplit<-function(x){
+ tmp<-strsplit(x,"")[[1]]
+ ii<-which(tmp=="|")
+ c(paste(tmp[1:(ii-1)],collapse=""),
+ paste(tmp[(ii+1):length(tmp)],collapse=""))
}
\ No newline at end of file
diff --git a/R/fitmultiMk.R b/R/fitmultiMk.R
index 9cd979c..6a99892 100644
--- a/R/fitmultiMk.R
+++ b/R/fitmultiMk.R
@@ -1,160 +1,160 @@
-## new function to fit multi-regime Mk model
-## written by Liam J. Revell 2017, 2020
-## adapted from ape::ace by E. Paradis et al. 2013
-
-fitmultiMk<-function(tree,x,model="ER",...){
- if(!inherits(tree,"simmap")){
- stop("tree should be an object of class \"simmap\". Use fitMk.\n")
- } else {
- regimes<-mapped.states(tree)
- nregimes<-length(regimes)
- }
- if(hasArg(q.init)) q.init<-list(...)$q.init
- else q.init<-length(unique(x))/sum(tree$edge.length)
- if(hasArg(opt.method)) opt.method<-list(...)$opt.method
- else opt.method<-"nlminb"
- if(hasArg(min.q)) min.q<-list(...)$min.q
- else min.q<-1e-12
- if(is.matrix(x)){
- x<-x[tree$tip.label,]
- m<-ncol(x)
- states<-colnames(x)
- } else {
- x<-to.matrix(x,sort(unique(x)))
- x<-x[tree$tip.label,]
- m<-ncol(x)
- states<-colnames(x)
- }
- if(hasArg(pi)) pi<-list(...)$pi
- else pi<-"equal"
- if(pi[1]=="equal") pi<-setNames(rep(1/m,m),states)
- else pi<-pi/sum(pi)
- if(is.character(model)){
- rate<-matrix(NA,m,m)
- if(model=="ER"){
- k<-rate[]<-1
- diag(rate)<-NA
- } else if(model=="ARD"){
- k<-m*(m-1)
- rate[col(rate)!=row(rate)]<-1:k
- } else if(model=="SYM"){
- k<-m*(m-1)/2
- ii<-col(rate)<row(rate)
- rate[ii]<-1:k
- rate<-t(rate)
- rate[ii]<-1:k
- }
- } else {
- if(ncol(model)!=nrow(model))
- stop("model is not a square matrix")
- if(ncol(model)!=ncol(x))
- stop("model does not have the right number of columns")
- rate<-model
- k<-max(rate)
- }
- Q<-replicate(nregimes,matrix(0,m,m),simplify=FALSE)
- names(Q)<-regimes
- index.matrix<-rate
- tmp<-cbind(1:m,1:m)
- rate[tmp]<-0
- rate[rate==0]<-k+1
- pw<-reorder(map.to.singleton(tree),"pruningwise")
- N<-Ntip(pw)
- M<-pw$Nnode
- liks<-rbind(x,matrix(0,M,m,dimnames=list(1:M+N,states)))
- lik<-function(pp,output.liks=FALSE,pi){
- if(any(is.nan(pp))||any(is.infinite(pp))) return(1e50)
- comp<-vector(length=N+M,mode="numeric")
- for(i in 1:nregimes){
- Q[[i]][]<-c(pp[1:k+(i-1)*k],0)[rate]
- diag(Q[[i]])<--rowSums(Q[[i]])
- }
- parents<-unique(pw$edge[,1])
- root<-min(parents)
- for(i in 1:length(parents)){
- anc<-parents[i]
- ii<-which(pw$edge[,1]==parents[i])
- desc<-pw$edge[ii,2]
- el<-pw$edge.length[ii]
- v<-vector(length=length(desc),mode="list")
- reg<-names(pw$edge.length)[ii]
- for(j in 1:length(v))
- v[[j]]<-EXPM(Q[[reg[j]]]*el[j])%*%liks[desc[j],]
- vv<-if(anc==root) Reduce('*',v)[,1]*pi else
- Reduce('*',v)[,1]
- comp[anc]<-sum(vv)
- liks[anc,]<-vv/comp[anc]
- }
- logL<--sum(log(comp[1:M+N]))
- return(if(is.na(logL)) Inf else logL)
- }
- if(length(q.init)!=(k*nregimes)) q.init<-rep(q.init[1],k*nregimes)
- if(opt.method=="optim")
- fit<-optim(q.init,function(p) lik(p,pi=pi),method="L-BFGS-B",
- lower=rep(min.q,k))
- else
- fit<-nlminb(q.init,function(p) lik(p,pi=pi),
- lower=rep(0,k*nregimes),upper=rep(1e50,k*nregimes))
- obj<-list(logLik=
- if(opt.method=="optim") -fit$value else -fit$objective,
- rates=fit$par,
- index.matrix=index.matrix,
- states=states,
- regimes=regimes,
- pi=pi,
- method=opt.method)
- lik.f<-function(q) -lik(q,output.liks=FALSE,pi=pi)
- obj$lik<-lik.f
- class(obj)<-"fitmultiMk"
- return(obj)
-}
-
-## print method for objects of class "fitMk"
-print.fitmultiMk<-function(x,digits=6,...){
- k<-max(x$index.matrix,na.rm=TRUE)
- cat("Object of class \"fitmultiMk\".\n\n")
- for(i in 1:length(x$regimes)){
- cat(paste("Fitted value of Q[",x$regimes[i],"]:\n",sep=""))
- Q<-matrix(NA,length(x$states),length(x$states))
- Q[]<-c(0,x$rates[1:k+(i-1)*k])[x$index.matrix+1]
- diag(Q)<-0
- diag(Q)<--rowSums(Q)
- colnames(Q)<-rownames(Q)<-x$states
- print(round(Q,digits))
- cat("\n")
- }
- cat("Fitted (or set) value of pi:\n")
- print(x$pi)
- cat(paste("\nLog-likelihood:",round(x$logLik,digits),"\n"))
- cat(paste("\nOptimization method used was \"",x$method,"\"\n\n",sep=""))
-}
-
-## summary method for objects of class "fitmultiMk"
-summary.fitmultiMk<-function(object,...){
- if(hasArg(digits)) digits<-list(...)$digits
- else digits<-6
- if(hasArg(quiet)) quiet<-list(...)$quiet
- else quiet<-FALSE
- Q<-list()
- for(i in 1:length(object$regimes)){
- if(!quiet) cat(paste("Fitted value of Q[",object$regimes[i],
- "]:\n",sep=""))
- Q[[i]]<-matrix(NA,length(object$states),length(object$states))
- Q[[i]][]<-c(0,object$rates)[object$index.matrix+1]
- diag(Q[[i]])<-0
- diag(Q[[i]])<--rowSums(Q[[i]])
- colnames(Q[[i]])<-rownames(Q[[i]])<-object$states
- if(!quiet) print(round(Q[[i]],digits))
- cat("\n")
- }
- names(Q)<-object$regimes
- if(!quiet) cat(paste("Log-likelihood:",round(object$logLik,digits),"\n\n"))
- invisible(list(Q=Q,logLik=object$logLik))
-}
-
-## logLik method for objects of class "fitmultiMk"
-logLik.fitmultiMk<-function(object,...){
- lik<-object$logLik
- attr(lik,"df")<-length(object$rates)
- lik
-}
+## new function to fit multi-regime Mk model
+## written by Liam J. Revell 2017, 2020
+## adapted from ape::ace by E. Paradis et al. 2013
+
+fitmultiMk<-function(tree,x,model="ER",...){
+ if(!inherits(tree,"simmap")){
+ stop("tree should be an object of class \"simmap\". Use fitMk.\n")
+ } else {
+ regimes<-mapped.states(tree)
+ nregimes<-length(regimes)
+ }
+ if(hasArg(q.init)) q.init<-list(...)$q.init
+ else q.init<-length(unique(x))/sum(tree$edge.length)
+ if(hasArg(opt.method)) opt.method<-list(...)$opt.method
+ else opt.method<-"nlminb"
+ if(hasArg(min.q)) min.q<-list(...)$min.q
+ else min.q<-1e-12
+ if(is.matrix(x)){
+ x<-x[tree$tip.label,]
+ m<-ncol(x)
+ states<-colnames(x)
+ } else {
+ x<-to.matrix(x,sort(unique(x)))
+ x<-x[tree$tip.label,]
+ m<-ncol(x)
+ states<-colnames(x)
+ }
+ if(hasArg(pi)) pi<-list(...)$pi
+ else pi<-"equal"
+ if(pi[1]=="equal") pi<-setNames(rep(1/m,m),states)
+ else pi<-pi/sum(pi)
+ if(is.character(model)){
+ rate<-matrix(NA,m,m)
+ if(model=="ER"){
+ k<-rate[]<-1
+ diag(rate)<-NA
+ } else if(model=="ARD"){
+ k<-m*(m-1)
+ rate[col(rate)!=row(rate)]<-1:k
+ } else if(model=="SYM"){
+ k<-m*(m-1)/2
+ ii<-col(rate)<row(rate)
+ rate[ii]<-1:k
+ rate<-t(rate)
+ rate[ii]<-1:k
+ }
+ } else {
+ if(ncol(model)!=nrow(model))
+ stop("model is not a square matrix")
+ if(ncol(model)!=ncol(x))
+ stop("model does not have the right number of columns")
+ rate<-model
+ k<-max(rate)
+ }
+ Q<-replicate(nregimes,matrix(0,m,m),simplify=FALSE)
+ names(Q)<-regimes
+ index.matrix<-rate
+ tmp<-cbind(1:m,1:m)
+ rate[tmp]<-0
+ rate[rate==0]<-k+1
+ pw<-reorder(map.to.singleton(tree),"pruningwise")
+ N<-Ntip(pw)
+ M<-pw$Nnode
+ liks<-rbind(x,matrix(0,M,m,dimnames=list(1:M+N,states)))
+ lik<-function(pp,output.liks=FALSE,pi){
+ if(any(is.nan(pp))||any(is.infinite(pp))) return(1e50)
+ comp<-vector(length=N+M,mode="numeric")
+ for(i in 1:nregimes){
+ Q[[i]][]<-c(pp[1:k+(i-1)*k],0)[rate]
+ diag(Q[[i]])<--rowSums(Q[[i]])
+ }
+ parents<-unique(pw$edge[,1])
+ root<-min(parents)
+ for(i in 1:length(parents)){
+ anc<-parents[i]
+ ii<-which(pw$edge[,1]==parents[i])
+ desc<-pw$edge[ii,2]
+ el<-pw$edge.length[ii]
+ v<-vector(length=length(desc),mode="list")
+ reg<-names(pw$edge.length)[ii]
+ for(j in 1:length(v))
+ v[[j]]<-EXPM(Q[[reg[j]]]*el[j])%*%liks[desc[j],]
+ vv<-if(anc==root) Reduce('*',v)[,1]*pi else
+ Reduce('*',v)[,1]
+ comp[anc]<-sum(vv)
+ liks[anc,]<-vv/comp[anc]
+ }
+ logL<--sum(log(comp[1:M+N]))
+ return(if(is.na(logL)) Inf else logL)
+ }
+ if(length(q.init)!=(k*nregimes)) q.init<-rep(q.init[1],k*nregimes)
+ if(opt.method=="optim")
+ fit<-optim(q.init,function(p) lik(p,pi=pi),method="L-BFGS-B",
+ lower=rep(min.q,k))
+ else
+ fit<-nlminb(q.init,function(p) lik(p,pi=pi),
+ lower=rep(0,k*nregimes),upper=rep(1e50,k*nregimes))
+ obj<-list(logLik=
+ if(opt.method=="optim") -fit$value else -fit$objective,
+ rates=fit$par,
+ index.matrix=index.matrix,
+ states=states,
+ regimes=regimes,
+ pi=pi,
+ method=opt.method)
+ lik.f<-function(q) -lik(q,output.liks=FALSE,pi=pi)
+ obj$lik<-lik.f
+ class(obj)<-"fitmultiMk"
+ return(obj)
+}
+
+## print method for objects of class "fitMk"
+print.fitmultiMk<-function(x,digits=6,...){
+ k<-max(x$index.matrix,na.rm=TRUE)
+ cat("Object of class \"fitmultiMk\".\n\n")
+ for(i in 1:length(x$regimes)){
+ cat(paste("Fitted value of Q[",x$regimes[i],"]:\n",sep=""))
+ Q<-matrix(NA,length(x$states),length(x$states))
+ Q[]<-c(0,x$rates[1:k+(i-1)*k])[x$index.matrix+1]
+ diag(Q)<-0
+ diag(Q)<--rowSums(Q)
+ colnames(Q)<-rownames(Q)<-x$states
+ print(round(Q,digits))
+ cat("\n")
+ }
+ cat("Fitted (or set) value of pi:\n")
+ print(x$pi)
+ cat(paste("\nLog-likelihood:",round(x$logLik,digits),"\n"))
+ cat(paste("\nOptimization method used was \"",x$method,"\"\n\n",sep=""))
+}
+
+## summary method for objects of class "fitmultiMk"
+summary.fitmultiMk<-function(object,...){
+ if(hasArg(digits)) digits<-list(...)$digits
+ else digits<-6
+ if(hasArg(quiet)) quiet<-list(...)$quiet
+ else quiet<-FALSE
+ Q<-list()
+ for(i in 1:length(object$regimes)){
+ if(!quiet) cat(paste("Fitted value of Q[",object$regimes[i],
+ "]:\n",sep=""))
+ Q[[i]]<-matrix(NA,length(object$states),length(object$states))
+ Q[[i]][]<-c(0,object$rates)[object$index.matrix+1]
+ diag(Q[[i]])<-0
+ diag(Q[[i]])<--rowSums(Q[[i]])
+ colnames(Q[[i]])<-rownames(Q[[i]])<-object$states
+ if(!quiet) print(round(Q[[i]],digits))
+ cat("\n")
+ }
+ names(Q)<-object$regimes
+ if(!quiet) cat(paste("Log-likelihood:",round(object$logLik,digits),"\n\n"))
+ invisible(list(Q=Q,logLik=object$logLik))
+}
+
+## logLik method for objects of class "fitmultiMk"
+logLik.fitmultiMk<-function(object,...){
+ lik<-object$logLik
+ attr(lik,"df")<-length(object$rates)
+ lik
+}
diff --git a/R/fitpolyMk.R b/R/fitpolyMk.R
index 7265d58..98fac35 100644
--- a/R/fitpolyMk.R
+++ b/R/fitpolyMk.R
@@ -1,511 +1,510 @@
-## fitpolyMk
-## fits several polymorphic discrete character evolution models
-## written by Liam J. Revell 2019, 2020, 2022, 2023
-
-anova.fitpolyMk<-anova.fitMk
-
-as.Qmatrix.fitpolyMk<-function(x,...){
- class(x)<-"fitMk"
- as.Qmatrix(x,...)
-}
-
-Combinations<-function(n,r,v=1:n){
- if(n!=length(v)) stop("n and v should have the same length")
- else return(t(combn(v,r)))
-}
-
-fitpolyMk<-function(tree,x,model="SYM",ordered=FALSE,...){
- if(hasArg(quiet)) quiet<-list(...)$quiet
- else quiet<-FALSE
- if(is.factor(x)) x<-setNames(as.character(x),names(x))
- if(is.matrix(x)) X<-strsplit(colnames(x),"+",fixed=TRUE)
- else X<-strsplit(x,"+",fixed=TRUE)
- ns<-sapply(X,length)
- ## get the states
- states<-sort(unique(unlist(X)))
- ## check if ordered
- if(ordered){
- if(hasArg(max.poly)) max.poly<-list(...)$max.poly
- else if(hasArg(max.states)){
- max.states<-list(...)$max.states
- max.poly<-max.states
- } else max.poly<-max(ns)
- ## get any user-supplied ordering
- if(hasArg(order)) order<-list(...)$order
- else order<-NULL
- if(!is.null(order)){
- if(setequal(order,states)) states<-order
- else cat("order & states do not match. using alphabetical order.\n")
- }
- }
- if(all(ns==1)){
- cat("No polymorphic species found. Use fitMk.\n\n")
- object<-NULL
- } else {
- ## fix the order of the input data
- if(is.matrix(x)){
- Levs<-sapply(X,function(x) paste(sort(x),collapse="+"))
- colnames(x)<-Levs
- } else x<-sapply(X,function(x) paste(sort(x),collapse="+"))
- if(ordered){
- ss<-vector()
- for(i in 1:(length(states)-1)){
- ss<-c(ss,states[i])
- for(j in (i+1):length(states))
- if((j-i)<max.poly) ss<-c(ss,paste(sort(states[i:j]),collapse="+"))
- }
- ss<-c(ss,states[i+1])
- tmodel<-matrix(0,length(ss),length(ss),dimnames=list(ss,ss))
- } else {
- ss<-vector()
- for(i in 1:length(states))
- ss<-c(ss,apply(Combinations(length(states),i,states),
- 1,paste,collapse="+"))
- tmodel<-matrix(0,length(ss),length(ss),dimnames=list(ss,ss))
- }
- poly<-strsplit(ss,"+",fixed=TRUE)
- index<-0
- for(i in 1:nrow(tmodel)){
- for(j in i:ncol(tmodel)){
- INT<-intersect(poly[[i]],poly[[j]])
- SDij<-setdiff(poly[[i]],poly[[j]])
- SDji<-setdiff(poly[[j]],poly[[i]])
- if(length(INT)>0
- &&(0%in%c(length(SDij),length(SDji)))
- &&(1%in%c(length(SDij),length(SDji)))){
- if(model=="ER"){
- tmodel[i,j]<-tmodel[j,i]<-1
- } else if(model%in%c("ARD","SYM")){
- index<-index+1
- tmodel[i,j]<-index
- if(model=="SYM") tmodel[j,i]<-index
- else {
- tmodel[j,i]<-index+1
- index<-index+1
- }
- } else if(model=="transient") {
- if(length(poly[[i]])>length(poly[[j]])){
- tmodel[i,j]<-1
- tmodel[j,i]<-2
- } else {
- tmodel[i,j]<-2
- tmodel[j,i]<-1
- }
- }
- }
- }
- }
- if(!quiet){
- cat("\nThis is the design matrix of the fitted model. Does it make sense?\n\n")
- print(tmodel)
- cat("\n")
- flush.console()
- }
- if(is.matrix(x)){
- X<-matrix(0,nrow(x),length(ss),dimnames=list(rownames(x),ss))
- X[rownames(x),colnames(x)]<-x
- } else X<-to.matrix(x,ss)
- object<-fitMk(tree,X,model=tmodel,...)
- }
- object$model<-model
- object$ordered<-ordered
- if(ordered) attr(object$ordered,"max.poly")<-max.poly
- object$data<-X
- class(object)<-"fitpolyMk"
- object
-}
-
-## print method for objects of class "fitpolyMk"
-print.fitpolyMk<-function(x,digits=6,...){
- cat("Object of class \"fitpolyMk\".\n\n")
- if(x$ordered){
- cat("Evolution was modeled as \'ordered\' (i.e., transitions are assumed\n")
- cat(paste("to occur ",x$states[1]," <-> ",x$states[2]," <-> ",x$states[3],
- " and so on) ",sep=""))
- cat(paste("using the \"",x$model,"\" model.\n\n",sep=""))
- } else {
- cat("Evolution was modeled as \'unordered\' ")
- cat(paste("using the \"",x$model,"\" model.\n\n",sep=""))
- }
- cat("Fitted (or set) value of Q:\n")
- Q<-matrix(NA,length(x$states),length(x$states))
- Q[]<-c(0,x$rates)[x$index.matrix+1]
- diag(Q)<-0
- diag(Q)<--rowSums(Q)
- colnames(Q)<-rownames(Q)<-x$states
- print(round(Q,digits))
- cat("\nFitted (or set) value of pi:\n")
- print(round(x$pi,digits))
- cat(paste("\nLog-likelihood:",round(x$logLik,digits),"\n"))
- cat(paste("\nOptimization method used was \"",x$method,"\"\n\n",sep=""))
-}
-
-## logLik method for objects of class "fitpolyMk"
-logLik.fitpolyMk<-function(object,...){
- lik<-object$logLik
- attr(lik,"df")<-length(object$rates)
- lik
-}
-
-## S3 plot method for objects of class "fitpolyMk"
-plot.fitpolyMk<-function(x,...){
- if(hasArg(signif)) signif<-list(...)$signif
- else signif<-3
- if(hasArg(main)) main<-list(...)$main
- else main<-NULL
- if(hasArg(cex.main)) cex.main<-list(...)$cex.main
- else cex.main<-1.2
- if(hasArg(cex.traits)) cex.traits<-list(...)$cex.traits
- else cex.traits<-1
- if(hasArg(cex.rates)) cex.rates<-list(...)$cex.rates
- else cex.rates<-0.6
- if(hasArg(mar)) mar<-list(...)$mar
- else mar<-c(1.1,1.1,3.1,1.1)
- if(hasArg(lwd)) lwd<-list(...)$lwd
- else lwd<-1
- if(hasArg(asp)) asp<-list(...)$asp
- else asp<-1
- Q<-matrix(NA,length(x$states),length(x$states))
- Q[]<-c(0,x$rates)[x$index.matrix+1]
- diag(Q)<-0
- spacer<-0.1
- plot.new()
- par(mar=mar)
- xylim<-c(-1.2,1.2)
- plot.window(xlim=xylim,ylim=xylim,asp=asp)
- if(!is.null(main)) title(main=main,cex.main=cex.main)
- nstates<-length(x$states)
- if(x$ordered){
- if(attr(x$ordered,"max.poly")==2){
- step<-360/nstates
- angles<-seq(-floor(nstates/2)*step,360-ceiling(nstates/2)*step,by=step)/180*pi
- if(nstates==2) angles<-angles+pi/2
- v.x<-sin(angles)
- v.y<-cos(angles)
- for(i in 1:nstates) for(j in 1:nstates){
- if(if(!isSymmetric(Q)) i!=j else i>j){
- dx<-v.x[j]-v.x[i]
- dy<-v.y[j]-v.y[i]
- slope<-abs(dy/dx)
- shift.x<-0.02*sin(atan(dy/dx))*sign(j-i)*if(dy/dx>0) 1 else -1
- shift.y<-0.02*cos(atan(dy/dx))*sign(j-i)*if(dy/dx>0) -1 else 1
- s<-c(v.x[i]+spacer*cos(atan(slope))*sign(dx)+
- if(isSymmetric(Q)) 0 else shift.x,
- v.y[i]+spacer*sin(atan(slope))*sign(dy)+
- if(isSymmetric(Q)) 0 else shift.y)
- e<-c(v.x[j]+spacer*cos(atan(slope))*sign(-dx)+
- if(isSymmetric(Q)) 0 else shift.x,
- v.y[j]+spacer*sin(atan(slope))*sign(-dy)+
- if(isSymmetric(Q)) 0 else shift.y)
- if(x$index.matrix[i,j]!=0){
- if(abs(diff(c(i,j)))==1||abs(diff(c(i,j)))==(nstates-1))
- text(mean(c(s[1],e[1]))+1.5*shift.x,
- mean(c(s[2],e[2]))+1.5*shift.y,
- round(Q[i,j],signif),cex=cex.rates,
- srt=atan(dy/dx)*180/pi)
- else
- text(mean(c(s[1],e[1]))+0.3*diff(c(s[1],e[1]))+
- 1.5*shift.x,
- mean(c(s[2],e[2]))+0.3*diff(c(s[2],e[2]))+
- 1.5*shift.y,
- round(Q[i,j],signif),cex=cex.rates,
- srt=atan(dy/dx)*180/pi)
- arrows(s[1],s[2],e[1],e[2],length=0.05,
- code=if(isSymmetric(Q)) 3 else 2,lwd=lwd)
- }
- }
- }
- text(v.x,v.y,x$states,cex=cex.traits,
- col=make.transparent(par()$fg,0.7))
- } else {
- nlevs<-attr(x$ordered,"max.poly")
- Ns<-inv.ncombn2(nstates,nlevs)
- v.x<-v.y<-vector()
- xx<-seq(-1,1,length.out=Ns)
- for(i in 1:Ns){
- for(j in 1:min(nlevs,Ns-i+1)){
- v.x<-c(v.x,mean(xx[i:(i+j-1)]))
- v.y<-c(v.y,1-2*(j-1)/(nlevs-1))
- }
- }
- for(i in 1:nstates) for(j in 1:nstates){
- if(if(!isSymmetric(Q)) i!=j else i>j){
- dx<-v.x[j]-v.x[i]
- dy<-v.y[j]-v.y[i]
- slope<-abs(dy/dx)
- shift.x<-0.02*sin(atan(dy/dx))*sign(j-i)*if(dy/dx>0) 1 else -1
- shift.y<-0.02*cos(atan(dy/dx))*sign(j-i)*if(dy/dx>0) -1 else 1
- s<-c(v.x[i]+spacer*cos(atan(slope))*sign(dx)+
- if(isSymmetric(Q)) 0 else shift.x,
- v.y[i]+spacer*sin(atan(slope))*sign(dy)+
- if(isSymmetric(Q)) 0 else shift.y)
- e<-c(v.x[j]+spacer*cos(atan(slope))*sign(-dx)+
- if(isSymmetric(Q)) 0 else shift.x,
- v.y[j]+spacer*sin(atan(slope))*sign(-dy)+
- if(isSymmetric(Q)) 0 else shift.y)
- if(x$index.matrix[i,j]!=0){
- text(mean(c(s[1],e[1]))+1.5*shift.x,
- mean(c(s[2],e[2]))+1.5*shift.y,
- round(Q[i,j],signif),cex=cex.rates,
- srt=atan(dy/dx)*180/pi)
- arrows(s[1],s[2],e[1],e[2],length=0.05,
- code=if(isSymmetric(Q)) 3 else 2,lwd=lwd)
- }
- }
- }
- text(v.x,v.y,x$states,cex=cex.traits,
- col=make.transparent(par()$fg,0.7))
- }
- } else {
- Ns<-inv.ncombn(nstates)
- step.y<-2/(Ns-1)
- v.x<-v.y<-vector()
- for(i in 1:Ns){
- nc<-ncombn(Ns,i)
- v.x<-c(v.x,if(nc>1) seq(-1,1,by=2/(nc-1)) else 0)
- v.y<-c(v.y,rep(1-rep((i-1)*step.y,nc)))
- }
- for(i in 1:nstates) for(j in 1:nstates)
- if(if(!isSymmetric(Q)) i!=j else i>j){
- dx<-v.x[j]-v.x[i]
- dy<-v.y[j]-v.y[i]
- slope<-abs(dy/dx)
- shift.x<-0.02*sin(atan(dy/dx))*sign(j-i)*if(dy/dx>0) 1 else -1
- shift.y<-0.02*cos(atan(dy/dx))*sign(j-i)*if(dy/dx>0) -1 else 1
- s<-c(v.x[i]+spacer*cos(atan(slope))*sign(dx)+
- if(isSymmetric(Q)) 0 else shift.x,
- v.y[i]+spacer*sin(atan(slope))*sign(dy)+
- if(isSymmetric(Q)) 0 else shift.y)
- e<-c(v.x[j]+spacer*cos(atan(slope))*sign(-dx)+
- if(isSymmetric(Q)) 0 else shift.x,
- v.y[j]+spacer*sin(atan(slope))*sign(-dy)+
- if(isSymmetric(Q)) 0 else shift.y)
- if(x$index.matrix[i,j]!=0){
- if(abs(diff(c(i,j)))==1||abs(diff(c(i,j)))==(nstates-1))
- text(mean(c(s[1],e[1]))+1.5*shift.x,
- mean(c(s[2],e[2]))+1.5*shift.y,
- round(Q[i,j],signif),cex=cex.rates,
- srt=atan(dy/dx)*180/pi)
- else
- text(mean(c(s[1],e[1]))+0.3*diff(c(s[1],e[1]))+
- 1.5*shift.x,
- mean(c(s[2],e[2]))+0.3*diff(c(s[2],e[2]))+
- 1.5*shift.y,
- round(Q[i,j],signif),cex=cex.rates,
- srt=atan(dy/dx)*180/pi)
- arrows(s[1],s[2],e[1],e[2],length=0.05,
- code=if(isSymmetric(Q)) 3 else 2,lwd=lwd)
- }
- }
- text(v.x,v.y,x$states,cex=cex.traits,
- col=make.transparent(par()$fg,0.7))
-
- }
-}
-
-## internally used functions to either calculate the number of combinations
-## of r elements of n or calculate the number of elements n from the sum of
-## all combinations from 1:r of n elements
-ncombn<-function(n,r) factorial(n)/(factorial(n-r)*factorial(r))
-inv.ncombn<-function(N){
- n<-Nc<-1
- while(Nc!=N){
- Nc<-0
- for(r in 1:n) Nc<-Nc+factorial(n)/(factorial(n-r)*factorial(r))
- n<-n+1
- }
- return(n-1)
-}
-inv.ncombn2<-function(N,m){
- n<-2
- Nc<-0
- while(Nc!=N){
- Nc<-sum((n:1)[1:min(m,n)])
- n<-n+1
- }
- return(n-1)
-}
-
-## maybe this should be plot.mkModel or something?
-## then you create a model class & plot it?
-
-graph.polyMk<-function(k=2,model="SYM",ordered=FALSE,...){
- if(hasArg(states)) states<-list(...)$states
- else states<-0:(k-1)
- if(hasArg(max.poly)) max.poly<-list(...)$max.poly
- else max.poly<-k
- if(hasArg(main)) main<-list(...)$main
- else main<-NULL
- if(hasArg(cex.main)) cex.main<-list(...)$cex.main
- else cex.main<-1.2
- if(hasArg(cex.traits)) cex.traits<-list(...)$cex.traits
- else cex.traits<-1
- if(hasArg(mar)) mar<-list(...)$mar
- else mar<-c(1.1,1.1,3.1,1.1)
- if(hasArg(lwd)) lwd<-list(...)$lwd
- else lwd<-1
- if(hasArg(quiet)) quiet<-list(...)$quiet
- else quiet<-FALSE
- if(hasArg(xlim)) xlim<-list(...)$xlim
- else xlim<-c(-1.2,1.2)
- if(hasArg(ylim)) ylim<-list(...)$ylim
- else ylim<-c(-1.2,1.2)
- if(hasArg(plot)) plot<-list(...)$plot
- else plot<-TRUE
- if(hasArg(asp)) asp<-list(...)$asp
- else asp<-1
- if(ordered){
- ss<-vector()
- for(i in 1:(length(states)-1)){
- ss<-c(ss,states[i])
- for(j in (i+1):length(states))
- if((j-i)<max.poly) ss<-c(ss,paste(states[i:j],collapse="+"))
- }
- ss<-c(ss,states[i+1])
- tmodel<-matrix(0,length(ss),length(ss),dimnames=list(ss,ss))
- } else {
- ss<-vector()
- for(i in 1:length(states))
- ss<-c(ss,apply(Combinations(length(states),i,states),
- 1,paste,collapse="+"))
- tmodel<-matrix(0,length(ss),length(ss),dimnames=list(ss,ss))
- }
- nstates<-length(ss)
- poly<-strsplit(ss,"+",fixed=TRUE)
- index<-0
- for(i in 1:nrow(tmodel)){
- for(j in i:ncol(tmodel)){
- INT<-intersect(poly[[i]],poly[[j]])
- SDij<-setdiff(poly[[i]],poly[[j]])
- SDji<-setdiff(poly[[j]],poly[[i]])
- if(length(INT)>0
- &&(0%in%c(length(SDij),length(SDji)))
- &&(1%in%c(length(SDij),length(SDji)))){
- if(model=="ER"){
- tmodel[i,j]<-tmodel[j,i]<-1
- } else if(model%in%c("ARD","SYM")){
- index<-index+1
- tmodel[i,j]<-index
- if(model=="SYM") tmodel[j,i]<-index
- else {
- tmodel[j,i]<-index+1
- index<-index+1
- }
- } else if(model=="transient"){
- if(length(poly[[i]])>length(poly[[j]])){
- tmodel[i,j]<-1
- tmodel[j,i]<-2
- } else {
- tmodel[i,j]<-2
- tmodel[j,i]<-1
- }
- }
- }
- }
- }
- if(plot){
- spacer<-0.1
- plot.new()
- par(mar=mar)
- plot.window(xlim=xlim,ylim=ylim,asp=asp)
- if(!is.null(main)) title(main=main,cex.main=cex.main)
- if(ordered){
- if(max.poly==2){
- step<-360/nstates
- angles<-seq(-floor(nstates/2)*step,360-ceiling(nstates/2)*step,by=step)/180*pi
- if(k==2) angles<-angles+pi/2
- v.x<-sin(angles)
- v.y<-cos(angles)
- for(i in 1:nstates) for(j in 1:nstates){
- if(if(!isSymmetric(tmodel)) i!=j else i>j){
- dx<-v.x[j]-v.x[i]
- dy<-v.y[j]-v.y[i]
- slope<-abs(dy/dx)
- shift.x<-0.02*sin(atan(dy/dx))*sign(j-i)*if(dy/dx>0) 1 else -1
- shift.y<-0.02*cos(atan(dy/dx))*sign(j-i)*if(dy/dx>0) -1 else 1
- s<-c(v.x[i]+spacer*cos(atan(slope))*sign(dx)+
- if(isSymmetric(tmodel)) 0 else shift.x,
- v.y[i]+spacer*sin(atan(slope))*sign(dy)+
- if(isSymmetric(tmodel)) 0 else shift.y)
- e<-c(v.x[j]+spacer*cos(atan(slope))*sign(-dx)+
- if(isSymmetric(tmodel)) 0 else shift.x,
- v.y[j]+spacer*sin(atan(slope))*sign(-dy)+
- if(isSymmetric(tmodel)) 0 else shift.y)
- if(tmodel[i,j]!=0){
- arrows(s[1],s[2],e[1],e[2],length=0.05,
- code=if(isSymmetric(tmodel)) 3 else 2,lwd=lwd)
- }
- }
- }
- text(v.x,v.y,colnames(tmodel),cex=cex.traits,
- col=make.transparent(par()$fg,0.7))
- } else {
- nlevs<-max.poly
- Ns<-inv.ncombn2(nstates,nlevs)
- v.x<-v.y<-vector()
- xx<-seq(-1,1,length.out=Ns)
- for(i in 1:k){
- for(j in 1:min(nlevs,Ns-i+1)){
- v.x<-c(v.x,mean(xx[i:(i+j-1)]))
- v.y<-c(v.y,1-2*(j-1)/(nlevs-1))
- }
- }
- for(i in 1:nstates) for(j in 1:nstates){
- if(if(!isSymmetric(tmodel)) i!=j else i>j){
- dx<-v.x[j]-v.x[i]
- dy<-v.y[j]-v.y[i]
- slope<-abs(dy/dx)
- shift.x<-0.02*sin(atan(dy/dx))*sign(j-i)*if(dy/dx>0) 1 else -1
- shift.y<-0.02*cos(atan(dy/dx))*sign(j-i)*if(dy/dx>0) -1 else 1
- s<-c(v.x[i]+spacer*cos(atan(slope))*sign(dx)+
- if(isSymmetric(tmodel)) 0 else shift.x,
- v.y[i]+spacer*sin(atan(slope))*sign(dy)+
- if(isSymmetric(tmodel)) 0 else shift.y)
- e<-c(v.x[j]+spacer*cos(atan(slope))*sign(-dx)+
- if(isSymmetric(tmodel)) 0 else shift.x,
- v.y[j]+spacer*sin(atan(slope))*sign(-dy)+
- if(isSymmetric(tmodel)) 0 else shift.y)
- if(tmodel[i,j]!=0){
- arrows(s[1],s[2],e[1],e[2],length=0.05,
- code=if(isSymmetric(tmodel)) 3 else 2,lwd=lwd)
- }
- }
- }
- text(v.x,v.y,rownames(tmodel),cex=cex.traits,
- col=make.transparent(par()$fg,0.7))
- }
- } else {
- step.y<-2/(k-1)
- v.x<-v.y<-vector()
- for(i in 1:k){
- nc<-ncombn(k,i)
- v.x<-c(v.x,if(nc>1) seq(-1,1,by=2/(nc-1)) else 0)
- v.y<-c(v.y,rep(1-rep((i-1)*step.y,nc)))
- }
- for(i in 1:ncol(tmodel)) for(j in 1:ncol(tmodel)){
- if(if(!isSymmetric(tmodel)) i!=j else i>j){
- dx<-v.x[j]-v.x[i]
- dy<-v.y[j]-v.y[i]
- slope<-abs(dy/dx)
- shift.x<-0.02*sin(atan(dy/dx))*sign(j-i)*if(dy/dx>0) 1 else -1
- shift.y<-0.02*cos(atan(dy/dx))*sign(j-i)*if(dy/dx>0) -1 else 1
- s<-c(v.x[i]+spacer*cos(atan(slope))*sign(dx)+
- if(isSymmetric(tmodel)) 0 else shift.x,
- v.y[i]+spacer*sin(atan(slope))*sign(dy)+
- if(isSymmetric(tmodel)) 0 else shift.y)
- e<-c(v.x[j]+spacer*cos(atan(slope))*sign(-dx)+
- if(isSymmetric(tmodel)) 0 else shift.x,
- v.y[j]+spacer*sin(atan(slope))*sign(-dy)+
- if(isSymmetric(tmodel)) 0 else shift.y)
- if(tmodel[i,j]!=0){
- arrows(s[1],s[2],e[1],e[2],length=0.05,
- code=if(isSymmetric(tmodel)) 3 else 2,lwd=lwd)
- }
- }
- }
- text(v.x,v.y,rownames(tmodel),cex=cex.traits,
- col=make.transparent(par()$fg,0.7))
- }
- }
- invisible(tmodel)
+## fitpolyMk
+## fits several polymorphic discrete character evolution models
+## written by Liam J. Revell 2019, 2020, 2022, 2023
+
+anova.fitpolyMk<-anova.fitMk
+
+as.Qmatrix.fitpolyMk<-function(x,...){
+ class(x)<-"fitMk"
+ as.Qmatrix(x,...)
+}
+
+Combinations<-function(n,r,v=1:n){
+ if(n!=length(v)) stop("n and v should have the same length")
+ else return(t(combn(v,r)))
+}
+
+fitpolyMk<-function(tree,x,model="SYM",ordered=FALSE,...){
+ if(hasArg(quiet)) quiet<-list(...)$quiet
+ else quiet<-FALSE
+ if(is.factor(x)) x<-setNames(as.character(x),names(x))
+ if(is.matrix(x)) X<-strsplit(colnames(x),"+",fixed=TRUE)
+ else X<-strsplit(x,"+",fixed=TRUE)
+ ns<-sapply(X,length)
+ ## get the states
+ states<-sort(unique(unlist(X)))
+ ## check if ordered
+ if(ordered){
+ if(hasArg(max.poly)) max.poly<-list(...)$max.poly
+ else if(hasArg(max.states)){
+ max.states<-list(...)$max.states
+ max.poly<-max.states
+ } else max.poly<-max(ns)
+ ## get any user-supplied ordering
+ if(hasArg(order)) order<-list(...)$order
+ else order<-NULL
+ if(!is.null(order)){
+ if(setequal(order,states)) states<-order
+ else cat("order & states do not match. using alphabetical order.\n")
+ }
+ }
+ if(all(ns==1)){
+ cat("No polymorphic species found. Use fitMk.\n\n")
+ object<-NULL
+ } else {
+ ## fix the order of the input data
+ if(is.matrix(x)){
+ Levs<-sapply(X,function(x) paste(sort(x),collapse="+"))
+ colnames(x)<-Levs
+ } else x<-sapply(X,function(x) paste(sort(x),collapse="+"))
+ if(ordered){
+ ss<-vector()
+ for(i in 1:(length(states)-1)){
+ ss<-c(ss,states[i])
+ for(j in (i+1):length(states))
+ if((j-i)<max.poly) ss<-c(ss,paste(sort(states[i:j]),collapse="+"))
+ }
+ ss<-c(ss,states[i+1])
+ tmodel<-matrix(0,length(ss),length(ss),dimnames=list(ss,ss))
+ } else {
+ ss<-vector()
+ for(i in 1:length(states))
+ ss<-c(ss,apply(Combinations(length(states),i,states),
+ 1,paste,collapse="+"))
+ tmodel<-matrix(0,length(ss),length(ss),dimnames=list(ss,ss))
+ }
+ poly<-strsplit(ss,"+",fixed=TRUE)
+ index<-0
+ for(i in 1:nrow(tmodel)){
+ for(j in i:ncol(tmodel)){
+ INT<-intersect(poly[[i]],poly[[j]])
+ SDij<-setdiff(poly[[i]],poly[[j]])
+ SDji<-setdiff(poly[[j]],poly[[i]])
+ if(length(INT)>0
+ &&(0%in%c(length(SDij),length(SDji)))
+ &&(1%in%c(length(SDij),length(SDji)))){
+ if(model=="ER"){
+ tmodel[i,j]<-tmodel[j,i]<-1
+ } else if(model%in%c("ARD","SYM")){
+ index<-index+1
+ tmodel[i,j]<-index
+ if(model=="SYM") tmodel[j,i]<-index
+ else {
+ tmodel[j,i]<-index+1
+ index<-index+1
+ }
+ } else if(model=="transient") {
+ if(length(poly[[i]])>length(poly[[j]])){
+ tmodel[i,j]<-1
+ tmodel[j,i]<-2
+ } else {
+ tmodel[i,j]<-2
+ tmodel[j,i]<-1
+ }
+ }
+ }
+ }
+ }
+ if(!quiet){
+ cat("\nThis is the design matrix of the fitted model. Does it make sense?\n\n")
+ print(tmodel)
+ cat("\n")
+ flush.console()
+ }
+ if(is.matrix(x)){
+ X<-matrix(0,nrow(x),length(ss),dimnames=list(rownames(x),ss))
+ X[rownames(x),colnames(x)]<-x
+ } else X<-to.matrix(x,ss)
+ object<-fitMk(tree,X,model=tmodel,...)
+ }
+ object$model<-model
+ object$ordered<-ordered
+ if(ordered) attr(object$ordered,"max.poly")<-max.poly
+ class(object)<-"fitpolyMk"
+ object
+}
+
+## print method for objects of class "fitpolyMk"
+print.fitpolyMk<-function(x,digits=6,...){
+ cat("Object of class \"fitpolyMk\".\n\n")
+ if(x$ordered){
+ cat("Evolution was modeled as \'ordered\' (i.e., transitions are assumed\n")
+ cat(paste("to occur ",x$states[1]," <-> ",x$states[2]," <-> ",x$states[3],
+ " and so on) ",sep=""))
+ cat(paste("using the \"",x$model,"\" model.\n\n",sep=""))
+ } else {
+ cat("Evolution was modeled as \'unordered\' ")
+ cat(paste("using the \"",x$model,"\" model.\n\n",sep=""))
+ }
+ cat("Fitted (or set) value of Q:\n")
+ Q<-matrix(NA,length(x$states),length(x$states))
+ Q[]<-c(0,x$rates)[x$index.matrix+1]
+ diag(Q)<-0
+ diag(Q)<--rowSums(Q)
+ colnames(Q)<-rownames(Q)<-x$states
+ print(round(Q,digits))
+ cat("\nFitted (or set) value of pi:\n")
+ print(round(x$pi,digits))
+ cat(paste("\nLog-likelihood:",round(x$logLik,digits),"\n"))
+ cat(paste("\nOptimization method used was \"",x$method,"\"\n\n",sep=""))
+}
+
+## logLik method for objects of class "fitpolyMk"
+logLik.fitpolyMk<-function(object,...){
+ lik<-object$logLik
+ attr(lik,"df")<-length(object$rates)
+ lik
+}
+
+## S3 plot method for objects of class "fitpolyMk"
+plot.fitpolyMk<-function(x,...){
+ if(hasArg(signif)) signif<-list(...)$signif
+ else signif<-3
+ if(hasArg(main)) main<-list(...)$main
+ else main<-NULL
+ if(hasArg(cex.main)) cex.main<-list(...)$cex.main
+ else cex.main<-1.2
+ if(hasArg(cex.traits)) cex.traits<-list(...)$cex.traits
+ else cex.traits<-1
+ if(hasArg(cex.rates)) cex.rates<-list(...)$cex.rates
+ else cex.rates<-0.6
+ if(hasArg(mar)) mar<-list(...)$mar
+ else mar<-c(1.1,1.1,3.1,1.1)
+ if(hasArg(lwd)) lwd<-list(...)$lwd
+ else lwd<-1
+ if(hasArg(asp)) asp<-list(...)$asp
+ else asp<-1
+ Q<-matrix(NA,length(x$states),length(x$states))
+ Q[]<-c(0,x$rates)[x$index.matrix+1]
+ diag(Q)<-0
+ spacer<-0.1
+ plot.new()
+ par(mar=mar)
+ xylim<-c(-1.2,1.2)
+ plot.window(xlim=xylim,ylim=xylim,asp=asp)
+ if(!is.null(main)) title(main=main,cex.main=cex.main)
+ nstates<-length(x$states)
+ if(x$ordered){
+ if(attr(x$ordered,"max.poly")==2){
+ step<-360/nstates
+ angles<-seq(-floor(nstates/2)*step,360-ceiling(nstates/2)*step,by=step)/180*pi
+ if(nstates==2) angles<-angles+pi/2
+ v.x<-sin(angles)
+ v.y<-cos(angles)
+ for(i in 1:nstates) for(j in 1:nstates){
+ if(if(!isSymmetric(Q)) i!=j else i>j){
+ dx<-v.x[j]-v.x[i]
+ dy<-v.y[j]-v.y[i]
+ slope<-abs(dy/dx)
+ shift.x<-0.02*sin(atan(dy/dx))*sign(j-i)*if(dy/dx>0) 1 else -1
+ shift.y<-0.02*cos(atan(dy/dx))*sign(j-i)*if(dy/dx>0) -1 else 1
+ s<-c(v.x[i]+spacer*cos(atan(slope))*sign(dx)+
+ if(isSymmetric(Q)) 0 else shift.x,
+ v.y[i]+spacer*sin(atan(slope))*sign(dy)+
+ if(isSymmetric(Q)) 0 else shift.y)
+ e<-c(v.x[j]+spacer*cos(atan(slope))*sign(-dx)+
+ if(isSymmetric(Q)) 0 else shift.x,
+ v.y[j]+spacer*sin(atan(slope))*sign(-dy)+
+ if(isSymmetric(Q)) 0 else shift.y)
+ if(x$index.matrix[i,j]!=0){
+ if(abs(diff(c(i,j)))==1||abs(diff(c(i,j)))==(nstates-1))
+ text(mean(c(s[1],e[1]))+1.5*shift.x,
+ mean(c(s[2],e[2]))+1.5*shift.y,
+ round(Q[i,j],signif),cex=cex.rates,
+ srt=atan(asp*dy/dx)*180/pi)
+ else
+ text(mean(c(s[1],e[1]))+0.3*diff(c(s[1],e[1]))+
+ 1.5*shift.x,
+ mean(c(s[2],e[2]))+0.3*diff(c(s[2],e[2]))+
+ 1.5*shift.y,
+ round(Q[i,j],signif),cex=cex.rates,
+ srt=atan(asp*dy/dx)*180/pi)
+ arrows(s[1],s[2],e[1],e[2],length=0.05,
+ code=if(isSymmetric(Q)) 3 else 2,lwd=lwd)
+ }
+ }
+ }
+ text(v.x,v.y,x$states,cex=cex.traits,
+ col=make.transparent(par()$fg,0.7))
+ } else {
+ nlevs<-attr(x$ordered,"max.poly")
+ Ns<-inv.ncombn2(nstates,nlevs)
+ v.x<-v.y<-vector()
+ xx<-seq(-1,1,length.out=Ns)
+ for(i in 1:Ns){
+ for(j in 1:min(nlevs,Ns-i+1)){
+ v.x<-c(v.x,mean(xx[i:(i+j-1)]))
+ v.y<-c(v.y,1-2*(j-1)/(nlevs-1))
+ }
+ }
+ for(i in 1:nstates) for(j in 1:nstates){
+ if(if(!isSymmetric(Q)) i!=j else i>j){
+ dx<-v.x[j]-v.x[i]
+ dy<-v.y[j]-v.y[i]
+ slope<-abs(dy/dx)
+ shift.x<-0.02*sin(atan(dy/dx))*sign(j-i)*if(dy/dx>0) 1 else -1
+ shift.y<-0.02*cos(atan(dy/dx))*sign(j-i)*if(dy/dx>0) -1 else 1
+ s<-c(v.x[i]+spacer*cos(atan(slope))*sign(dx)+
+ if(isSymmetric(Q)) 0 else shift.x,
+ v.y[i]+spacer*sin(atan(slope))*sign(dy)+
+ if(isSymmetric(Q)) 0 else shift.y)
+ e<-c(v.x[j]+spacer*cos(atan(slope))*sign(-dx)+
+ if(isSymmetric(Q)) 0 else shift.x,
+ v.y[j]+spacer*sin(atan(slope))*sign(-dy)+
+ if(isSymmetric(Q)) 0 else shift.y)
+ if(x$index.matrix[i,j]!=0){
+ text(mean(c(s[1],e[1]))+1.5*shift.x,
+ mean(c(s[2],e[2]))+1.5*shift.y,
+ round(Q[i,j],signif),cex=cex.rates,
+ srt=atan(asp*dy/dx)*180/pi)
+ arrows(s[1],s[2],e[1],e[2],length=0.05,
+ code=if(isSymmetric(Q)) 3 else 2,lwd=lwd)
+ }
+ }
+ }
+ text(v.x,v.y,x$states,cex=cex.traits,
+ col=make.transparent(par()$fg,0.7))
+ }
+ } else {
+ Ns<-inv.ncombn(nstates)
+ step.y<-2/(Ns-1)
+ v.x<-v.y<-vector()
+ for(i in 1:Ns){
+ nc<-ncombn(Ns,i)
+ v.x<-c(v.x,if(nc>1) seq(-1,1,by=2/(nc-1)) else 0)
+ v.y<-c(v.y,rep(1-rep((i-1)*step.y,nc)))
+ }
+ for(i in 1:nstates) for(j in 1:nstates)
+ if(if(!isSymmetric(Q)) i!=j else i>j){
+ dx<-v.x[j]-v.x[i]
+ dy<-v.y[j]-v.y[i]
+ slope<-abs(dy/dx)
+ shift.x<-0.02*sin(atan(dy/dx))*sign(j-i)*if(dy/dx>0) 1 else -1
+ shift.y<-0.02*cos(atan(dy/dx))*sign(j-i)*if(dy/dx>0) -1 else 1
+ s<-c(v.x[i]+spacer*cos(atan(slope))*sign(dx)+
+ if(isSymmetric(Q)) 0 else shift.x,
+ v.y[i]+spacer*sin(atan(slope))*sign(dy)+
+ if(isSymmetric(Q)) 0 else shift.y)
+ e<-c(v.x[j]+spacer*cos(atan(slope))*sign(-dx)+
+ if(isSymmetric(Q)) 0 else shift.x,
+ v.y[j]+spacer*sin(atan(slope))*sign(-dy)+
+ if(isSymmetric(Q)) 0 else shift.y)
+ if(x$index.matrix[i,j]!=0){
+ if(abs(diff(c(i,j)))==1||abs(diff(c(i,j)))==(nstates-1))
+ text(mean(c(s[1],e[1]))+1.5*shift.x,
+ mean(c(s[2],e[2]))+1.5*shift.y,
+ round(Q[i,j],signif),cex=cex.rates,
+ srt=atan(asp*dy/dx)*180/pi)
+ else
+ text(mean(c(s[1],e[1]))+0.3*diff(c(s[1],e[1]))+
+ 1.5*shift.x,
+ mean(c(s[2],e[2]))+0.3*diff(c(s[2],e[2]))+
+ 1.5*shift.y,
+ round(Q[i,j],signif),cex=cex.rates,
+ srt=atan(asp*dy/dx)*180/pi)
+ arrows(s[1],s[2],e[1],e[2],length=0.05,
+ code=if(isSymmetric(Q)) 3 else 2,lwd=lwd)
+ }
+ }
+ text(v.x,v.y,x$states,cex=cex.traits,
+ col=make.transparent(par()$fg,0.7))
+
+ }
+}
+
+## internally used functions to either calculate the number of combinations
+## of r elements of n or calculate the number of elements n from the sum of
+## all combinations from 1:r of n elements
+ncombn<-function(n,r) factorial(n)/(factorial(n-r)*factorial(r))
+inv.ncombn<-function(N){
+ n<-Nc<-1
+ while(Nc!=N){
+ Nc<-0
+ for(r in 1:n) Nc<-Nc+factorial(n)/(factorial(n-r)*factorial(r))
+ n<-n+1
+ }
+ return(n-1)
+}
+inv.ncombn2<-function(N,m){
+ n<-2
+ Nc<-0
+ while(Nc!=N){
+ Nc<-sum((n:1)[1:min(m,n)])
+ n<-n+1
+ }
+ return(n-1)
+}
+
+## maybe this should be plot.mkModel or something?
+## then you create a model class & plot it?
+
+graph.polyMk<-function(k=2,model="SYM",ordered=FALSE,...){
+ if(hasArg(states)) states<-list(...)$states
+ else states<-0:(k-1)
+ if(hasArg(max.poly)) max.poly<-list(...)$max.poly
+ else max.poly<-k
+ if(hasArg(main)) main<-list(...)$main
+ else main<-NULL
+ if(hasArg(cex.main)) cex.main<-list(...)$cex.main
+ else cex.main<-1.2
+ if(hasArg(cex.traits)) cex.traits<-list(...)$cex.traits
+ else cex.traits<-1
+ if(hasArg(mar)) mar<-list(...)$mar
+ else mar<-c(1.1,1.1,3.1,1.1)
+ if(hasArg(lwd)) lwd<-list(...)$lwd
+ else lwd<-1
+ if(hasArg(quiet)) quiet<-list(...)$quiet
+ else quiet<-FALSE
+ if(hasArg(xlim)) xlim<-list(...)$xlim
+ else xlim<-c(-1.2,1.2)
+ if(hasArg(ylim)) ylim<-list(...)$ylim
+ else ylim<-c(-1.2,1.2)
+ if(hasArg(plot)) plot<-list(...)$plot
+ else plot<-TRUE
+ if(hasArg(asp)) asp<-list(...)$asp
+ else asp<-1
+ if(ordered){
+ ss<-vector()
+ for(i in 1:(length(states)-1)){
+ ss<-c(ss,states[i])
+ for(j in (i+1):length(states))
+ if((j-i)<max.poly) ss<-c(ss,paste(states[i:j],collapse="+"))
+ }
+ ss<-c(ss,states[i+1])
+ tmodel<-matrix(0,length(ss),length(ss),dimnames=list(ss,ss))
+ } else {
+ ss<-vector()
+ for(i in 1:length(states))
+ ss<-c(ss,apply(Combinations(length(states),i,states),
+ 1,paste,collapse="+"))
+ tmodel<-matrix(0,length(ss),length(ss),dimnames=list(ss,ss))
+ }
+ nstates<-length(ss)
+ poly<-strsplit(ss,"+",fixed=TRUE)
+ index<-0
+ for(i in 1:nrow(tmodel)){
+ for(j in i:ncol(tmodel)){
+ INT<-intersect(poly[[i]],poly[[j]])
+ SDij<-setdiff(poly[[i]],poly[[j]])
+ SDji<-setdiff(poly[[j]],poly[[i]])
+ if(length(INT)>0
+ &&(0%in%c(length(SDij),length(SDji)))
+ &&(1%in%c(length(SDij),length(SDji)))){
+ if(model=="ER"){
+ tmodel[i,j]<-tmodel[j,i]<-1
+ } else if(model%in%c("ARD","SYM")){
+ index<-index+1
+ tmodel[i,j]<-index
+ if(model=="SYM") tmodel[j,i]<-index
+ else {
+ tmodel[j,i]<-index+1
+ index<-index+1
+ }
+ } else if(model=="transient"){
+ if(length(poly[[i]])>length(poly[[j]])){
+ tmodel[i,j]<-1
+ tmodel[j,i]<-2
+ } else {
+ tmodel[i,j]<-2
+ tmodel[j,i]<-1
+ }
+ }
+ }
+ }
+ }
+ if(plot){
+ spacer<-if(hasArg(spacer)) list(...)$spacer else 0.1
+ plot.new()
+ par(mar=mar)
+ plot.window(xlim=xlim,ylim=ylim,asp=asp)
+ if(!is.null(main)) title(main=main,cex.main=cex.main)
+ if(ordered){
+ if(max.poly==2){
+ step<-360/nstates
+ angles<-seq(-floor(nstates/2)*step,360-ceiling(nstates/2)*step,by=step)/180*pi
+ if(k==2) angles<-angles+pi/2
+ v.x<-sin(angles)
+ v.y<-cos(angles)
+ for(i in 1:nstates) for(j in 1:nstates){
+ if(if(!isSymmetric(tmodel)) i!=j else i>j){
+ dx<-v.x[j]-v.x[i]
+ dy<-v.y[j]-v.y[i]
+ slope<-abs(dy/dx)
+ shift.x<-0.02*sin(atan(dy/dx))*sign(j-i)*if(dy/dx>0) 1 else -1
+ shift.y<-0.02*cos(atan(dy/dx))*sign(j-i)*if(dy/dx>0) -1 else 1
+ s<-c(v.x[i]+spacer*cos(atan(slope))*sign(dx)+
+ if(isSymmetric(tmodel)) 0 else shift.x,
+ v.y[i]+spacer*sin(atan(slope))*sign(dy)+
+ if(isSymmetric(tmodel)) 0 else shift.y)
+ e<-c(v.x[j]+spacer*cos(atan(slope))*sign(-dx)+
+ if(isSymmetric(tmodel)) 0 else shift.x,
+ v.y[j]+spacer*sin(atan(slope))*sign(-dy)+
+ if(isSymmetric(tmodel)) 0 else shift.y)
+ if(tmodel[i,j]!=0){
+ arrows(s[1],s[2],e[1],e[2],length=0.05,
+ code=if(isSymmetric(tmodel)) 3 else 2,lwd=lwd)
+ }
+ }
+ }
+ text(v.x,v.y,colnames(tmodel),cex=cex.traits,
+ col=make.transparent(par()$fg,0.7))
+ } else {
+ nlevs<-max.poly
+ Ns<-inv.ncombn2(nstates,nlevs)
+ v.x<-v.y<-vector()
+ xx<-seq(-1,1,length.out=Ns)
+ for(i in 1:k){
+ for(j in 1:min(nlevs,Ns-i+1)){
+ v.x<-c(v.x,mean(xx[i:(i+j-1)]))
+ v.y<-c(v.y,1-2*(j-1)/(nlevs-1))
+ }
+ }
+ for(i in 1:nstates) for(j in 1:nstates){
+ if(if(!isSymmetric(tmodel)) i!=j else i>j){
+ dx<-v.x[j]-v.x[i]
+ dy<-v.y[j]-v.y[i]
+ slope<-abs(dy/dx)
+ shift.x<-0.02*sin(atan(dy/dx))*sign(j-i)*if(dy/dx>0) 1 else -1
+ shift.y<-0.02*cos(atan(dy/dx))*sign(j-i)*if(dy/dx>0) -1 else 1
+ s<-c(v.x[i]+spacer*cos(atan(slope))*sign(dx)+
+ if(isSymmetric(tmodel)) 0 else shift.x,
+ v.y[i]+spacer*sin(atan(slope))*sign(dy)+
+ if(isSymmetric(tmodel)) 0 else shift.y)
+ e<-c(v.x[j]+spacer*cos(atan(slope))*sign(-dx)+
+ if(isSymmetric(tmodel)) 0 else shift.x,
+ v.y[j]+spacer*sin(atan(slope))*sign(-dy)+
+ if(isSymmetric(tmodel)) 0 else shift.y)
+ if(tmodel[i,j]!=0){
+ arrows(s[1],s[2],e[1],e[2],length=0.05,
+ code=if(isSymmetric(tmodel)) 3 else 2,lwd=lwd)
+ }
+ }
+ }
+ text(v.x,v.y,rownames(tmodel),cex=cex.traits,
+ col=make.transparent(par()$fg,0.7))
+ }
+ } else {
+ step.y<-2/(k-1)
+ v.x<-v.y<-vector()
+ for(i in 1:k){
+ nc<-ncombn(k,i)
+ v.x<-c(v.x,if(nc>1) seq(-1,1,by=2/(nc-1)) else 0)
+ v.y<-c(v.y,rep(1-rep((i-1)*step.y,nc)))
+ }
+ for(i in 1:ncol(tmodel)) for(j in 1:ncol(tmodel)){
+ if(if(!isSymmetric(tmodel)) i!=j else i>j){
+ dx<-v.x[j]-v.x[i]
+ dy<-v.y[j]-v.y[i]
+ slope<-abs(dy/dx)
+ shift.x<-0.02*sin(atan(dy/dx))*sign(j-i)*if(dy/dx>0) 1 else -1
+ shift.y<-0.02*cos(atan(dy/dx))*sign(j-i)*if(dy/dx>0) -1 else 1
+ s<-c(v.x[i]+spacer*cos(atan(slope))*sign(dx)+
+ if(isSymmetric(tmodel)) 0 else shift.x,
+ v.y[i]+spacer*sin(atan(slope))*sign(dy)+
+ if(isSymmetric(tmodel)) 0 else shift.y)
+ e<-c(v.x[j]+spacer*cos(atan(slope))*sign(-dx)+
+ if(isSymmetric(tmodel)) 0 else shift.x,
+ v.y[j]+spacer*sin(atan(slope))*sign(-dy)+
+ if(isSymmetric(tmodel)) 0 else shift.y)
+ if(tmodel[i,j]!=0){
+ arrows(s[1],s[2],e[1],e[2],length=0.05,
+ code=if(isSymmetric(tmodel)) 3 else 2,lwd=lwd)
+ }
+ }
+ }
+ text(v.x,v.y,rownames(tmodel),cex=cex.traits,
+ col=make.transparent(par()$fg,0.7))
+ }
+ }
+ invisible(tmodel)
}
\ No newline at end of file
diff --git a/R/locate.fossil.R b/R/locate.fossil.R
index e770f17..5ec3e8c 100644
--- a/R/locate.fossil.R
+++ b/R/locate.fossil.R
@@ -1,117 +1,117 @@
-## code to place a fossil taxon into a tree using ML and continuous data
-## written by Liam J. Revell 2014, 2015, 2017, 2022, 2023
-
-locate.fossil<-function(tree,X,...){
- if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".")
- if(hasArg(plot)) plot<-list(...)$plot
- else plot<-TRUE
- if(hasArg(quiet)) quiet<-list(...)$quiet
- else quiet<-FALSE
- if(hasArg(rotate)) rotate<-list(...)$rotate
- else rotate<-TRUE
- if(hasArg(edge.constraint))edge.constraint<-list(...)$edge.constraint
- else edge.constraint<-tree$edge[,2]
- if(hasArg(time.constraint)) time.constraint<-list(...)$time.constraint
- else time.constraint<-c(0,max(nodeHeights(tree)))
- if(hasArg(tol)) tol<-list(...)$tol
- else tol<-1e-6
- if(any(time.constraint<0)) time.constraint<-max(nodeHeights(tree))+time.constraint
- if(length(time.constraint)==1) time.constraint<-rep(time.constraint,2)
- if(!is.matrix(X)) X<-as.matrix(X)
- tip<-setdiff(rownames(X),tree$tip.label)
- fossilML(tree,X,quiet,tip,edge.constraint,time.constraint,plot,search,rotate,tol)
-}
-
-fossilML<-function(tree,X,quiet,tip,edge.constraint,time.constraint,plot,search,rotate,tol){
- if(!quiet) cat(paste("Optimizing the phylogenetic position of ",tip,
- " using ML. Please wait....\n",sep=""))
- if(ncol(X)>1&&rotate){
- pca<-phyl.pca(tree,X[tree$tip.label,])
- obj<-phyl.vcv(X[tree$tip.label,],vcv(tree),1)
- X<-(X-matrix(rep(obj$a[,1],nrow(X)),nrow(X),ncol(X),byrow=TRUE))%*%pca$Evec
- }
- lik.tree<-function(par,tip,tree,edge,height,XX,rotate,time.constraint){
- tip.depth<-par[1]
- tip.height<-par[2]
- if(tip.height>(tip.depth+1e-6)){
- ii<-which(tree$edge[,2]==edge)
- tree<-bind.tip(tree,tip,where=edge,position=min(height[2]-tip.depth,
- tree$edge.length[ii]),
- edge.length=tip.height-tip.depth)
- if(!rotate) XX<-phyl.pca(tree,XX[tree$tip.label,])$S
- obj<-phyl.vcv(as.matrix(XX[tree$tip.label,]),vcv(tree),1)
- ll<-vector()
- for(i in 1:ncol(XX))
- ll[i]<-sum(dmnorm(XX[tree$tip.label,i],mean=rep(obj$a[i,1],nrow(XX)),
- obj$C*obj$R[i,i],log=TRUE))
- if(plot){
- plotTree(tree,mar=c(2.1,0.1,3.1,0.1),ftype="i",fsize=0.8)
- obj<-lapply(time.constraint,function(x,tree) lines(rep(x,2),
- c(0,Ntip(tree)+1),col="red",lty="dashed"),tree=tree)
- title(paste("log(L) = ",signif(sum(ll),6),sep=""))
- axis(1)
- }
- logL<-sum(ll)
- } else logL<--.Machine$double.xmax/1e100
- logL
- }
- ee<-intersect(tree$edge[,2],edge.constraint)
- H<-nodeHeights(tree)
- hh<-unique(c(tree$edge[H[,1]<=time.constraint[2],2],
- tree$edge[H[,2]<=time.constraint[2],2]))
- ee<-intersect(ee,hh)
- fit<-vector(mode="list",length=length(ee))
- for(i in 1:length(ee)){
- ii<-which(tree$edge[,2]==ee[i])
- lower<-c(H[ii,1],time.constraint[1])+
- tol*diff(c(H[ii,1],time.constraint[1]))
- upper<-c(H[ii,2],time.constraint[2])+
- tol*diff(c(H[ii,2],time.constraint[2]))
- par<-c(mean(lower),mean(upper))
- fit[[i]]<-optim(par,lik.tree,tip=tip,tree=tree,edge=ee[i],
- height=H[ii,],XX=X,rotate=rotate,
- time.constraint=time.constraint,
- method="L-BFGS-B",lower=lower,upper=upper,
- control=list(fnscale=-1))
- }
- logL<-sapply(fit,function(x) x$value)
- ii<-which(logL==max(logL))
- if(length(ii)==1){
- fit<-fit[[ii]]
- edge<-ee[ii]
- mltree<-bind.tip(tree,tip,where=edge,
- position=H[which(tree$edge[,2]==edge),2]-fit$par[1],
- edge.length=fit$par[2]-fit$par[1])
- mltree$logL<-fit$value
- } else {
- fit<-fit[ii]
- mltree<-vector(mode="list",length=length(ii))
- for(i in 1:length(ii)){
- edge<-ee[ii[i]]
- mltree[[i]]<-bind.tip(tree,tip,where=edge,
- position=H[which(tree$edge[,2]==edge),2]-fit[[i]]$par[1],
- edge.length=fit[[i]]$par[2]-fit[[i]]$par[1])
- mltree[[i]]$logL<-fit[[i]]$value
- }
- class(mltree)<-"multiPhylo"
- }
- if(!quiet) cat("Done.\n")
- if(plot){
- if(inherits(mltree,"phylo")){
- plotTree(mltree,mar=c(2.1,0.1,3.1,0.1),ftype="i",fsize=0.8)
- obj<-lapply(time.constraint,function(x,tree) lines(rep(x,2),
- c(0,Ntip(tree)+1),col="red",lty="dashed"),tree=tree)
- title(paste("Optimized position of taxon \"",tip,"\"",sep=""))
- axis(1)
- } else {
- par(mfrow=c(1,length(mltree)))
- for(i in 1:length(mltree)){
- plotTree(mltree[[i]],mar=c(2.1,0.1,0.1,0.1),ftype="i",fsize=0.8)
- obj<-lapply(time.constraint,function(x,tree) lines(rep(x,2),
- c(0,Ntip(tree)+1),col="red",lty="dashed"),tree=tree)
- axis(1)
- }
- }
- }
- mltree
-}
+## code to place a fossil taxon into a tree using ML and continuous data
+## written by Liam J. Revell 2014, 2015, 2017, 2022, 2023
+
+locate.fossil<-function(tree,X,...){
+ if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".")
+ if(hasArg(plot)) plot<-list(...)$plot
+ else plot<-TRUE
+ if(hasArg(quiet)) quiet<-list(...)$quiet
+ else quiet<-FALSE
+ if(hasArg(rotate)) rotate<-list(...)$rotate
+ else rotate<-TRUE
+ if(hasArg(edge.constraint))edge.constraint<-list(...)$edge.constraint
+ else edge.constraint<-tree$edge[,2]
+ if(hasArg(time.constraint)) time.constraint<-list(...)$time.constraint
+ else time.constraint<-c(0,max(nodeHeights(tree)))
+ if(hasArg(tol)) tol<-list(...)$tol
+ else tol<-1e-6
+ if(any(time.constraint<0)) time.constraint<-max(nodeHeights(tree))+time.constraint
+ if(length(time.constraint)==1) time.constraint<-rep(time.constraint,2)
+ if(!is.matrix(X)) X<-as.matrix(X)
+ tip<-setdiff(rownames(X),tree$tip.label)
+ fossilML(tree,X,quiet,tip,edge.constraint,time.constraint,plot,search,rotate,tol)
+}
+
+fossilML<-function(tree,X,quiet,tip,edge.constraint,time.constraint,plot,search,rotate,tol){
+ if(!quiet) cat(paste("Optimizing the phylogenetic position of ",tip,
+ " using ML. Please wait....\n",sep=""))
+ if(ncol(X)>1&&rotate){
+ pca<-phyl.pca(tree,X[tree$tip.label,])
+ obj<-phyl.vcv(X[tree$tip.label,],vcv(tree),1)
+ X<-(X-matrix(rep(obj$a[,1],nrow(X)),nrow(X),ncol(X),byrow=TRUE))%*%pca$Evec
+ }
+ lik.tree<-function(par,tip,tree,edge,height,XX,rotate,time.constraint){
+ tip.depth<-par[1]
+ tip.height<-par[2]
+ if(tip.height>(tip.depth+1e-6)){
+ ii<-which(tree$edge[,2]==edge)
+ tree<-bind.tip(tree,tip,where=edge,position=min(height[2]-tip.depth,
+ tree$edge.length[ii]),
+ edge.length=tip.height-tip.depth)
+ if(!rotate) XX<-phyl.pca(tree,XX[tree$tip.label,])$S
+ obj<-phyl.vcv(as.matrix(XX[tree$tip.label,]),vcv(tree),1)
+ ll<-vector()
+ for(i in 1:ncol(XX))
+ ll[i]<-sum(dmnorm(XX[tree$tip.label,i],mean=rep(obj$a[i,1],nrow(XX)),
+ obj$C*obj$R[i,i],log=TRUE))
+ if(plot){
+ plotTree(tree,mar=c(2.1,0.1,3.1,0.1),ftype="i",fsize=0.8)
+ obj<-lapply(time.constraint,function(x,tree) lines(rep(x,2),
+ c(0,Ntip(tree)+1),col="red",lty="dashed"),tree=tree)
+ title(paste("log(L) = ",signif(sum(ll),6),sep=""))
+ axis(1)
+ }
+ logL<-sum(ll)
+ } else logL<--.Machine$double.xmax/1e100
+ logL
+ }
+ ee<-intersect(tree$edge[,2],edge.constraint)
+ H<-nodeHeights(tree)
+ hh<-unique(c(tree$edge[H[,1]<=time.constraint[2],2],
+ tree$edge[H[,2]<=time.constraint[2],2]))
+ ee<-intersect(ee,hh)
+ fit<-vector(mode="list",length=length(ee))
+ for(i in 1:length(ee)){
+ ii<-which(tree$edge[,2]==ee[i])
+ lower<-c(H[ii,1],time.constraint[1])+
+ tol*diff(c(H[ii,1],time.constraint[1]))
+ upper<-c(H[ii,2],time.constraint[2])+
+ tol*diff(c(H[ii,2],time.constraint[2]))
+ par<-c(mean(lower),mean(upper))
+ fit[[i]]<-optim(par,lik.tree,tip=tip,tree=tree,edge=ee[i],
+ height=H[ii,],XX=X,rotate=rotate,
+ time.constraint=time.constraint,
+ method="L-BFGS-B",lower=lower,upper=upper,
+ control=list(fnscale=-1))
+ }
+ logL<-sapply(fit,function(x) x$value)
+ ii<-which(logL==max(logL))
+ if(length(ii)==1){
+ fit<-fit[[ii]]
+ edge<-ee[ii]
+ mltree<-bind.tip(tree,tip,where=edge,
+ position=H[which(tree$edge[,2]==edge),2]-fit$par[1],
+ edge.length=fit$par[2]-fit$par[1])
+ mltree$logL<-fit$value
+ } else {
+ fit<-fit[ii]
+ mltree<-vector(mode="list",length=length(ii))
+ for(i in 1:length(ii)){
+ edge<-ee[ii[i]]
+ mltree[[i]]<-bind.tip(tree,tip,where=edge,
+ position=H[which(tree$edge[,2]==edge),2]-fit[[i]]$par[1],
+ edge.length=fit[[i]]$par[2]-fit[[i]]$par[1])
+ mltree[[i]]$logL<-fit[[i]]$value
+ }
+ class(mltree)<-"multiPhylo"
+ }
+ if(!quiet) cat("Done.\n")
+ if(plot){
+ if(inherits(mltree,"phylo")){
+ plotTree(mltree,mar=c(2.1,0.1,3.1,0.1),ftype="i",fsize=0.8)
+ obj<-lapply(time.constraint,function(x,tree) lines(rep(x,2),
+ c(0,Ntip(tree)+1),col="red",lty="dashed"),tree=tree)
+ title(paste("Optimized position of taxon \"",tip,"\"",sep=""))
+ axis(1)
+ } else {
+ par(mfrow=c(1,length(mltree)))
+ for(i in 1:length(mltree)){
+ plotTree(mltree[[i]],mar=c(2.1,0.1,0.1,0.1),ftype="i",fsize=0.8)
+ obj<-lapply(time.constraint,function(x,tree) lines(rep(x,2),
+ c(0,Ntip(tree)+1),col="red",lty="dashed"),tree=tree)
+ axis(1)
+ }
+ }
+ }
+ mltree
+}
diff --git a/R/locate.yeti.R b/R/locate.yeti.R
index 804b8a1..ac36051 100644
--- a/R/locate.yeti.R
+++ b/R/locate.yeti.R
@@ -1,183 +1,183 @@
-## code to place a missing extant taxon into a tree using ML or REML on continuous data
-## written by Liam J. Revell 2014, 2018, 2021
-
-locate.yeti<-function(tree,X,...){
- if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".")
- if(hasArg(method)) method<-list(...)$method
- else method<-"ML"
- if(hasArg(search)) search<-list(...)$search
- else search<-"heuristic"
- if(hasArg(plot)) plot<-list(...)$plot
- else plot<-FALSE
- if(hasArg(quiet)) quiet<-list(...)$quiet
- else quiet<-FALSE
- if(hasArg(rotate)) rotate<-list(...)$rotate
- else rotate<-if(method=="ML") TRUE else FALSE
- root.node<-Ntip(tree)+1
- if(hasArg(constraint)){
- if(search=="exhaustive") constraint<-list(...)$constraint
- else {
- cat("constraint only works with search==\"exhaustive\"\n")
- constraint<-c(root.node,tree$edge[,2])
- }
- } else constraint<-c(root.node,tree$edge[,2])
- if(!is.matrix(X)) X<-as.matrix(X)
- tip<-setdiff(rownames(X),tree$tip.label)
- if(method=="ML") mltree<-yetiML(tree,X,quiet,tip,root.node,constraint,plot,search,rotate)
- else if(method=="REML") mltree<-yetiREML(tree,X,quiet,tip,root.node,constraint,plot,search)
- else {
- cat(paste("Do not recognize method ",method,".\n",sep=""))
- stop()
- }
- mltree
-}
-
-yetiML<-function(tree,X,quiet,tip,root.node,constraint,plot,search,rotate){
- if(!quiet) cat(paste("Optimizing the phylogenetic position of ",tip," using ML. Please wait....\n",sep=""))
- if(ncol(X)>1&&rotate){
- pca<-phyl.pca(tree,X[tree$tip.label,])
- obj<-phyl.vcv(X[tree$tip.label,],vcv(tree),1)
- X<-(X-matrix(rep(obj$a[,1],nrow(X)),nrow(X),ncol(X),byrow=TRUE))%*%pca$Evec
- }
- if(search=="heuristic"){
- trees<-list()
- ee<-c(root.node,tree$edge[,2])
- for(i in 1:length(ee)) trees[[i]]<-bind.tip(tree,tip,where=ee[i],position=if(ee[i]==root.node) 0 else 0.5*tree$edge.length[i-1])
- class(trees)<-"multiPhylo"
- lik.edge<-function(tree,XX,rotate){
- if(!rotate) XX<-phyl.pca(tree,XX[tree$tip.label,])$S
- obj<-phyl.vcv(as.matrix(XX[tree$tip.label,]),vcv(tree),1)
- ll<-vector()
- for(i in 1:ncol(XX)) ll[i]<-sum(dmnorm(XX[tree$tip.label,i],mean=rep(obj$a[i,1],nrow(XX)),obj$C*obj$R[i,i],log=TRUE))
- sum(ll)
- }
- logL<-sapply(trees,lik.edge,XX=X,rotate=rotate)
- if(plot){
- ll<-logL[2:length(logL)]
- ll[ll<=sort(ll,decreasing=TRUE)[ceiling(nrow(tree$edge)/2)]]<-sort(ll,decreasing=TRUE)[ceiling(nrow(tree$edge)/2)]
- layout(matrix(c(1,2),2,1),heights=c(0.95,0.05))
- plotBranchbyTrait(tree,ll,mode="edges",title="log(L)",show.tip.label=FALSE)
- edgelabels(round(logL[2:length(logL)],1),cex=0.5)
- plot.new()
- text(paste("Note: logL <=",round(min(ll),2),"set to",round(min(ll),2),"for visualization only"),x=0.5,y=0.5)
- }
- edge<-ee[which(logL==max(logL))]
- }
- lik.tree<-function(position,tip,tree,edge,XX,rt,rotate){
- if(edge==rt) tree<-bind.tip(tree,tip,edge.length=position,where=edge)
- else tree<-bind.tip(tree,tip,where=edge,position=position)
- if(!rotate) XX<-phyl.pca(tree,XX[tree$tip.label,])$S
- obj<-phyl.vcv(as.matrix(XX[tree$tip.label,]),vcv(tree),1)
- ll<-vector()
- for(i in 1:ncol(XX)) ll[i]<-sum(dmnorm(XX[tree$tip.label,i],mean=rep(obj$a[i,1],nrow(XX)),obj$C*obj$R[i,i],log=TRUE))
- sum(ll)
- }
- if(search=="heuristic"){
- ee<-edge
- if(edge!=root.node) ee<-c(ee,getAncestors(tree,node=edge,type="parent"))
- if(edge>Ntip(tree)) ee<-c(ee,tree$edge[which(tree$edge[,1]==edge),2])
- } else if(search=="exhaustive") ee<-c(root.node,tree$edge[,2])
- ee<-intersect(ee,constraint)
- fit<-vector(mode="list",length=length(ee))
- for(i in 1:length(ee)){
- if(ee[i]==root.node) fit[[i]]<-optimize(lik.tree,interval=c(max(nodeHeights(tree)),10*max(nodeHeights(tree))),tip=tip,tree=tree,
- edge=ee[i],XX=X,rt=root.node,rotate=rotate,maximum=TRUE)
- else fit[[i]]<-optimize(lik.tree,interval=c(0,tree$edge.length[which(tree$edge[,2]==ee[i])]),tip=tip,tree=tree,edge=ee[i],
- XX=X,rt=root.node,rotate=rotate,maximum=TRUE)
- }
- logL<-sapply(fit,function(x) x$objective)
- if(search=="exhaustive"&&plot){
- ll<-sapply(fit,function(x) x$objective)
- ll<-ll[2:length(ll)]
- ll[ll<=sort(ll,decreasing=TRUE)[ceiling(nrow(tree$edge)/2)]]<-sort(ll,decreasing=TRUE)[ceiling(nrow(tree$edge)/2)]
- layout(matrix(c(1,2),2,1),heights=c(0.95,0.05))
- plotBranchbyTrait(tree,ll,mode="edges",title="log(L)",show.tip.label=FALSE)
- edgelabels(round(ll,1),cex=0.5)
- plot.new()
- text(paste("Note: logL <=",round(min(ll),2),"set to",round(min(ll),2),"for visualization only"),x=0.5,y=0.5)
- }
- fit<-fit[[which(logL==max(logL))]]
- edge<-ee[which(logL==max(logL))]
- mltree<-if(edge==root.node) midpoint.root(bind.tip(tree,tip,where=edge,edge.length=fit$maximum)) else bind.tip(tree,tip,where=edge,position=fit$maximum)
- mltree$logL<-fit$objective
- if(!quiet) cat("Done.\n")
- mltree
-}
-
-yetiREML<-function(tree,X,quiet,tip,root.node,constraint,plot,search){
- if(!quiet){
- cat("---------------------------------------------------------------\n")
- cat("| **Warning: method=\"REML\" has not been thoroughly tested. |\n")
- cat("| Use with caution.** |\n")
- cat("---------------------------------------------------------------\n\n")
- }
- if(!quiet) cat(paste("Optimizing the phylogenetic position of ",tip," using REML. Please wait....\n",sep=""))
- if(search=="heuristic"){
- trees<-list()
- ee<-c(root.node,tree$edge[,2])
- for(i in 1:length(ee)) trees[[i]]<-bind.tip(tree,tip,where=ee[i],position=if(ee[i]==root.node) 0 else 0.5*tree$edge.length[i-1])
- class(trees)<-"multiPhylo"
- lik.edge<-function(tree,XX){
- tree<-multi2di(tree,random=FALSE)
- YY<-apply(XX[tree$tip.label,],2,pic,phy=tree)
- vcv<-t(YY)%*%YY/nrow(YY)
- E<-eigen(vcv)$vectors
- ##a<-apply(XX,2,function(x,tree) ace(x,tree,type="continuous",method="pic")$ace[1],tree=tree)
- ##S<-(X-matrix(rep(a,nrow(X)),nrow(X),ncol(X),byrow=TRUE))%*%E
- ##ZZ<-apply(S,2,pic,phy=tree)
- ZZ<-YY%*%E
- vars<-diag(t(ZZ)%*%ZZ/nrow(ZZ))
- ll<-vector()
- for(i in 1:ncol(ZZ)) ll[i]<-sum(dnorm(ZZ[,i],mean=0,sd=sqrt(vars[i]),log=TRUE))
- sum(ll)
- }
- logL<-sapply(trees,lik.edge,XX=X)
- if(plot){
- ll<-logL[2:length(logL)]
- ll[ll<=sort(ll,decreasing=TRUE)[ceiling(nrow(tree$edge)/2)]]<-sort(ll,decreasing=TRUE)[ceiling(nrow(tree$edge)/2)]
- layout(matrix(c(1,2),2,1),heights=c(0.95,0.05))
- plotBranchbyTrait(tree,ll,mode="edges",title="log(L)",show.tip.label=FALSE)
- edgelabels(round(logL[2:length(logL)],1),cex=0.5)
- plot.new()
- text(paste("Note: logL <=",round(min(ll),2),"set to",round(min(ll),2),"for visualization only"),x=0.5,y=0.5)
- }
- edge<-ee[which(logL==max(logL))]
- }
- lik.tree<-function(position,tip,tree,edge,XX,rt){
- if(edge==rt) tree<-bind.tip(tree,tip,edge.length=position,where=edge)
- else tree<-bind.tip(tree,tip,where=edge,position=position)
- tree<-multi2di(tree,random=FALSE)
- YY<-apply(XX,2,pic,phy=tree,scaled=FALSE)
- vcv<-t(YY)%*%YY/nrow(YY)
- sum(dmnorm(YY,mean=rep(0,ncol(YY)),varcov=vcv,log=TRUE))
- }
- if(search=="heuristic"){
- ee<-edge
- if(edge!=root.node) ee<-c(ee,getAncestors(tree,node=edge,type="parent"))
- if(edge>Ntip(tree)) ee<-c(ee,tree$edge[which(tree$edge[,1]==edge),2])
- } else if(search=="exhaustive") ee<-c(root.node,tree$edge[,2])
- ee<-intersect(ee,constraint)
- fit<-vector(mode="list",length=length(ee))
- for(i in 1:length(ee)){
- if(ee[i]==root.node) fit[[i]]<-optimize(lik.tree,interval=c(max(nodeHeights(tree)),10*max(nodeHeights(tree))),tip=tip,tree=tree,edge=ee[i],XX=X,rt=root.node,maximum=TRUE)
- else fit[[i]]<-optimize(lik.tree,interval=c(0,tree$edge.length[which(tree$edge[,2]==ee[i])]),tip=tip,tree=tree,edge=ee[i],XX=X,rt=root.node,maximum=TRUE)
- }
- logL<-sapply(fit,function(x) x$objective)
- if(search=="exhaustive"&&plot){
- ll<-sapply(fit,function(x) x$objective)
- ll<-ll[2:length(ll)]
- ll[ll<=sort(ll,decreasing=TRUE)[ceiling(nrow(tree$edge)/2)]]<-sort(ll,decreasing=TRUE)[ceiling(nrow(tree$edge)/2)]
- layout(matrix(c(1,2),2,1),heights=c(0.95,0.05))
- plotBranchbyTrait(tree,ll,mode="edges",title="log(L)",show.tip.label=FALSE)
- edgelabels(round(ll,1),cex=0.5)
- plot.new()
- text(paste("Note: logL <=",round(min(ll),2),"set to",round(min(ll),2),"for visualization only"),x=0.5,y=0.5)
- }
- fit<-fit[[which(logL==max(logL))]]
- edge<-ee[which(logL==max(logL))]
- mltree<-if(edge==root.node) midpoint.root(bind.tip(tree,tip,where=edge,edge.length=fit$maximum)) else bind.tip(tree,tip,where=edge,position=fit$maximum)
- mltree$logL<-fit$objective
- if(!quiet) cat("Done.\n")
- mltree
-}
-
+## code to place a missing extant taxon into a tree using ML or REML on continuous data
+## written by Liam J. Revell 2014, 2018, 2021
+
+locate.yeti<-function(tree,X,...){
+ if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".")
+ if(hasArg(method)) method<-list(...)$method
+ else method<-"ML"
+ if(hasArg(search)) search<-list(...)$search
+ else search<-"heuristic"
+ if(hasArg(plot)) plot<-list(...)$plot
+ else plot<-FALSE
+ if(hasArg(quiet)) quiet<-list(...)$quiet
+ else quiet<-FALSE
+ if(hasArg(rotate)) rotate<-list(...)$rotate
+ else rotate<-if(method=="ML") TRUE else FALSE
+ root.node<-Ntip(tree)+1
+ if(hasArg(constraint)){
+ if(search=="exhaustive") constraint<-list(...)$constraint
+ else {
+ cat("constraint only works with search==\"exhaustive\"\n")
+ constraint<-c(root.node,tree$edge[,2])
+ }
+ } else constraint<-c(root.node,tree$edge[,2])
+ if(!is.matrix(X)) X<-as.matrix(X)
+ tip<-setdiff(rownames(X),tree$tip.label)
+ if(method=="ML") mltree<-yetiML(tree,X,quiet,tip,root.node,constraint,plot,search,rotate)
+ else if(method=="REML") mltree<-yetiREML(tree,X,quiet,tip,root.node,constraint,plot,search)
+ else {
+ cat(paste("Do not recognize method ",method,".\n",sep=""))
+ stop()
+ }
+ mltree
+}
+
+yetiML<-function(tree,X,quiet,tip,root.node,constraint,plot,search,rotate){
+ if(!quiet) cat(paste("Optimizing the phylogenetic position of ",tip," using ML. Please wait....\n",sep=""))
+ if(ncol(X)>1&&rotate){
+ pca<-phyl.pca(tree,X[tree$tip.label,])
+ obj<-phyl.vcv(X[tree$tip.label,],vcv(tree),1)
+ X<-(X-matrix(rep(obj$a[,1],nrow(X)),nrow(X),ncol(X),byrow=TRUE))%*%pca$Evec
+ }
+ if(search=="heuristic"){
+ trees<-list()
+ ee<-c(root.node,tree$edge[,2])
+ for(i in 1:length(ee)) trees[[i]]<-bind.tip(tree,tip,where=ee[i],position=if(ee[i]==root.node) 0 else 0.5*tree$edge.length[i-1])
+ class(trees)<-"multiPhylo"
+ lik.edge<-function(tree,XX,rotate){
+ if(!rotate) XX<-phyl.pca(tree,XX[tree$tip.label,])$S
+ obj<-phyl.vcv(as.matrix(XX[tree$tip.label,]),vcv(tree),1)
+ ll<-vector()
+ for(i in 1:ncol(XX)) ll[i]<-sum(dmnorm(XX[tree$tip.label,i],mean=rep(obj$a[i,1],nrow(XX)),obj$C*obj$R[i,i],log=TRUE))
+ sum(ll)
+ }
+ logL<-sapply(trees,lik.edge,XX=X,rotate=rotate)
+ if(plot){
+ ll<-logL[2:length(logL)]
+ ll[ll<=sort(ll,decreasing=TRUE)[ceiling(nrow(tree$edge)/2)]]<-sort(ll,decreasing=TRUE)[ceiling(nrow(tree$edge)/2)]
+ layout(matrix(c(1,2),2,1),heights=c(0.95,0.05))
+ plotBranchbyTrait(tree,ll,mode="edges",title="log(L)",show.tip.label=FALSE)
+ edgelabels(round(logL[2:length(logL)],1),cex=0.5)
+ plot.new()
+ text(paste("Note: logL <=",round(min(ll),2),"set to",round(min(ll),2),"for visualization only"),x=0.5,y=0.5)
+ }
+ edge<-ee[which(logL==max(logL))]
+ }
+ lik.tree<-function(position,tip,tree,edge,XX,rt,rotate){
+ if(edge==rt) tree<-bind.tip(tree,tip,edge.length=position,where=edge)
+ else tree<-bind.tip(tree,tip,where=edge,position=position)
+ if(!rotate) XX<-phyl.pca(tree,XX[tree$tip.label,])$S
+ obj<-phyl.vcv(as.matrix(XX[tree$tip.label,]),vcv(tree),1)
+ ll<-vector()
+ for(i in 1:ncol(XX)) ll[i]<-sum(dmnorm(XX[tree$tip.label,i],mean=rep(obj$a[i,1],nrow(XX)),obj$C*obj$R[i,i],log=TRUE))
+ sum(ll)
+ }
+ if(search=="heuristic"){
+ ee<-edge
+ if(edge!=root.node) ee<-c(ee,getAncestors(tree,node=edge,type="parent"))
+ if(edge>Ntip(tree)) ee<-c(ee,tree$edge[which(tree$edge[,1]==edge),2])
+ } else if(search=="exhaustive") ee<-c(root.node,tree$edge[,2])
+ ee<-intersect(ee,constraint)
+ fit<-vector(mode="list",length=length(ee))
+ for(i in 1:length(ee)){
+ if(ee[i]==root.node) fit[[i]]<-optimize(lik.tree,interval=c(max(nodeHeights(tree)),10*max(nodeHeights(tree))),tip=tip,tree=tree,
+ edge=ee[i],XX=X,rt=root.node,rotate=rotate,maximum=TRUE)
+ else fit[[i]]<-optimize(lik.tree,interval=c(0,tree$edge.length[which(tree$edge[,2]==ee[i])]),tip=tip,tree=tree,edge=ee[i],
+ XX=X,rt=root.node,rotate=rotate,maximum=TRUE)
+ }
+ logL<-sapply(fit,function(x) x$objective)
+ if(search=="exhaustive"&&plot){
+ ll<-sapply(fit,function(x) x$objective)
+ ll<-ll[2:length(ll)]
+ ll[ll<=sort(ll,decreasing=TRUE)[ceiling(nrow(tree$edge)/2)]]<-sort(ll,decreasing=TRUE)[ceiling(nrow(tree$edge)/2)]
+ layout(matrix(c(1,2),2,1),heights=c(0.95,0.05))
+ plotBranchbyTrait(tree,ll,mode="edges",title="log(L)",show.tip.label=FALSE)
+ edgelabels(round(ll,1),cex=0.5)
+ plot.new()
+ text(paste("Note: logL <=",round(min(ll),2),"set to",round(min(ll),2),"for visualization only"),x=0.5,y=0.5)
+ }
+ fit<-fit[[which(logL==max(logL))]]
+ edge<-ee[which(logL==max(logL))]
+ mltree<-if(edge==root.node) midpoint.root(bind.tip(tree,tip,where=edge,edge.length=fit$maximum)) else bind.tip(tree,tip,where=edge,position=fit$maximum)
+ mltree$logL<-fit$objective
+ if(!quiet) cat("Done.\n")
+ mltree
+}
+
+yetiREML<-function(tree,X,quiet,tip,root.node,constraint,plot,search){
+ if(!quiet){
+ cat("---------------------------------------------------------------\n")
+ cat("| **Warning: method=\"REML\" has not been thoroughly tested. |\n")
+ cat("| Use with caution.** |\n")
+ cat("---------------------------------------------------------------\n\n")
+ }
+ if(!quiet) cat(paste("Optimizing the phylogenetic position of ",tip," using REML. Please wait....\n",sep=""))
+ if(search=="heuristic"){
+ trees<-list()
+ ee<-c(root.node,tree$edge[,2])
+ for(i in 1:length(ee)) trees[[i]]<-bind.tip(tree,tip,where=ee[i],position=if(ee[i]==root.node) 0 else 0.5*tree$edge.length[i-1])
+ class(trees)<-"multiPhylo"
+ lik.edge<-function(tree,XX){
+ tree<-multi2di(tree,random=FALSE)
+ YY<-apply(XX[tree$tip.label,],2,pic,phy=tree)
+ vcv<-t(YY)%*%YY/nrow(YY)
+ E<-eigen(vcv)$vectors
+ ##a<-apply(XX,2,function(x,tree) ace(x,tree,type="continuous",method="pic")$ace[1],tree=tree)
+ ##S<-(X-matrix(rep(a,nrow(X)),nrow(X),ncol(X),byrow=TRUE))%*%E
+ ##ZZ<-apply(S,2,pic,phy=tree)
+ ZZ<-YY%*%E
+ vars<-diag(t(ZZ)%*%ZZ/nrow(ZZ))
+ ll<-vector()
+ for(i in 1:ncol(ZZ)) ll[i]<-sum(dnorm(ZZ[,i],mean=0,sd=sqrt(vars[i]),log=TRUE))
+ sum(ll)
+ }
+ logL<-sapply(trees,lik.edge,XX=X)
+ if(plot){
+ ll<-logL[2:length(logL)]
+ ll[ll<=sort(ll,decreasing=TRUE)[ceiling(nrow(tree$edge)/2)]]<-sort(ll,decreasing=TRUE)[ceiling(nrow(tree$edge)/2)]
+ layout(matrix(c(1,2),2,1),heights=c(0.95,0.05))
+ plotBranchbyTrait(tree,ll,mode="edges",title="log(L)",show.tip.label=FALSE)
+ edgelabels(round(logL[2:length(logL)],1),cex=0.5)
+ plot.new()
+ text(paste("Note: logL <=",round(min(ll),2),"set to",round(min(ll),2),"for visualization only"),x=0.5,y=0.5)
+ }
+ edge<-ee[which(logL==max(logL))]
+ }
+ lik.tree<-function(position,tip,tree,edge,XX,rt){
+ if(edge==rt) tree<-bind.tip(tree,tip,edge.length=position,where=edge)
+ else tree<-bind.tip(tree,tip,where=edge,position=position)
+ tree<-multi2di(tree,random=FALSE)
+ YY<-apply(XX,2,pic,phy=tree,scaled=FALSE)
+ vcv<-t(YY)%*%YY/nrow(YY)
+ sum(dmnorm(YY,mean=rep(0,ncol(YY)),varcov=vcv,log=TRUE))
+ }
+ if(search=="heuristic"){
+ ee<-edge
+ if(edge!=root.node) ee<-c(ee,getAncestors(tree,node=edge,type="parent"))
+ if(edge>Ntip(tree)) ee<-c(ee,tree$edge[which(tree$edge[,1]==edge),2])
+ } else if(search=="exhaustive") ee<-c(root.node,tree$edge[,2])
+ ee<-intersect(ee,constraint)
+ fit<-vector(mode="list",length=length(ee))
+ for(i in 1:length(ee)){
+ if(ee[i]==root.node) fit[[i]]<-optimize(lik.tree,interval=c(max(nodeHeights(tree)),10*max(nodeHeights(tree))),tip=tip,tree=tree,edge=ee[i],XX=X,rt=root.node,maximum=TRUE)
+ else fit[[i]]<-optimize(lik.tree,interval=c(0,tree$edge.length[which(tree$edge[,2]==ee[i])]),tip=tip,tree=tree,edge=ee[i],XX=X,rt=root.node,maximum=TRUE)
+ }
+ logL<-sapply(fit,function(x) x$objective)
+ if(search=="exhaustive"&&plot){
+ ll<-sapply(fit,function(x) x$objective)
+ ll<-ll[2:length(ll)]
+ ll[ll<=sort(ll,decreasing=TRUE)[ceiling(nrow(tree$edge)/2)]]<-sort(ll,decreasing=TRUE)[ceiling(nrow(tree$edge)/2)]
+ layout(matrix(c(1,2),2,1),heights=c(0.95,0.05))
+ plotBranchbyTrait(tree,ll,mode="edges",title="log(L)",show.tip.label=FALSE)
+ edgelabels(round(ll,1),cex=0.5)
+ plot.new()
+ text(paste("Note: logL <=",round(min(ll),2),"set to",round(min(ll),2),"for visualization only"),x=0.5,y=0.5)
+ }
+ fit<-fit[[which(logL==max(logL))]]
+ edge<-ee[which(logL==max(logL))]
+ mltree<-if(edge==root.node) midpoint.root(bind.tip(tree,tip,where=edge,edge.length=fit$maximum)) else bind.tip(tree,tip,where=edge,position=fit$maximum)
+ mltree$logL<-fit$objective
+ if(!quiet) cat("Done.\n")
+ mltree
+}
+
diff --git a/R/ls.consensus.R b/R/ls.consensus.R
index 4667aec..9c70bcf 100644
--- a/R/ls.consensus.R
+++ b/R/ls.consensus.R
@@ -1,154 +1,154 @@
-## some average tree methods
-## written by Liam J. Revell
-
-ls.consensus<-function(trees,start=NULL,tol=1e-12,quiet=FALSE,...){
- D<-Reduce("+",lapply(trees,function(x,t) cophenetic(x)[t,t],
- t=trees[[1]]$tip.label))/length(trees)
- tip.dates<-NULL
- if(is.null(start)) start<-NJ(D)
- if(hasArg(ultrametric)) ultrametric<-list(...)$ultrametric
- else ultrametric<-all(sapply(trees,is.ultrametric))
- if(ultrametric){
- method<-"ultrametric"
- } else {
- if(hasArg(tipdated)) tipdated<-list(...)$tipdated
- else tipdated<-FALSE
- if(tipdated){
- tip.dates<-diag(D)
- method<-"tip.dated"
- } else method<-"unrooted"
- }
- if(ultrametric&&!is.rooted(start)) start<-midpoint(start)
- curr<-nnls.tree(D,tree=start,method=method,trace=0,tip.dates=tip.dates)
- if(hasArg(optNNI)) optNNI<-list(...)$optNNI
- else optNNI<-TRUE
- if(optNNI){
- Q<-Inf
- Qp<-attr(curr,"RSS")
- if(is.null(Qp)) Qp<-rss(D,curr)
- ct<-0
- while((Q-Qp)>tol){
- Q<-Qp
- NNIs<-.uncompressTipLabel(nni(curr))
- curr<-list(curr)
- class(curr)<-"multiPhylo"
- NNIs<-c(NNIs,curr)
- NNIs<-lapply(NNIs,nnls.tree,dm=D,method=method,trace=0,
- tip.dates=tip.dates)
- qs<-sapply(NNIs,rss,D=D)
- ii<-which(qs==min(qs))[1]
- if(!quiet) message(paste("Best Q =",qs[ii]))
- Qp<-qs[ii]
- curr<-NNIs[[ii]]
- ct<-ct+1
- }
- if(!quiet)
- message(paste("Solution found after",ct,
- "set of nearest neighbor interchanges."))
- } else if(!quiet)
- message(paste("No optimization of topology performed.",
- "Returning start tree with LS edge lengths."))
- curr
-}
-
-rss<-function(D,tree){
- Dp<-cophenetic(tree)[rownames(D),colnames(D)]
- sum((D-Dp)^2)/2
-}
-
-minTreeDist<-function(tree,trees,method="quadratic.path.difference",...){
- if(is.null(tree$edge.length))
- tree$edge.length<-runif(n=nrow(tree$edge))
- e<-tree$edge.length
- fn<-function(e,tree,trees,m){
- tree$edge.length<-e
- if(method=="quadratic.path.difference")
- d<-qpd(tree,trees)
- else
- d<-sapply(trees,function(x,y) treedist(x,y)[m],
- y=tree)
- sum(d^2)
- }
- fit<-optim(e,fn,tree=tree,trees=trees,m=method,lower=0,
- method="L-BFGS-B",...)
- tree$edge.length<-fit$par
- attr(tree,"SQD")<-fit$value
- tree
-}
-
-averageTree<-function(trees,start=NULL,method="quadratic.path.difference",
- tol=1e-12,quiet=FALSE,...){
- if(!quiet)
- message(paste(
- "\n Function is attempting to find the phylogeny with ",
- "\n minimum distance to all trees in set under the ",
- "\n \"",
- paste(strsplit(method,"[.]")[[1]],collapse=" "),
- "\" criterion...\n",sep=""))
- if(is.null(start)){
- if(method%in%c("symmetric.difference","path.difference"))
- start<-multi2di(consensus(trees,p=0.5),random=FALSE)
- else start<-ls.consensus(trees,quiet=TRUE)
- }
- if(method%in%c("branch.score.difference","quadratic.path.difference")){
- D<-Reduce("+",lapply(trees,function(x,t) cophenetic(x)[t,t],
- t=trees[[1]]$tip.label))/length(trees)
- rt<-all(sapply(trees,is.ultrametric))
- nnls.method<-if(rt) "ultrametric" else "unrooted"
- } else if(method%in%c("symmetric.difference","path.difference")){
- rt<-all(sapply(trees,is.rooted))
- if(!rt) start<-unroot(start)
- }
- curr<-start
- SS<-Inf
- SSp<-sum(sapply(trees,function(x,y,m) treedist(x,y)[m],
- y=curr,m=method)^2)
- ct<-0
- while((SS-SSp)>tol){
- SS<-SSp
- NNIs<-.uncompressTipLabel(nni(curr))
- curr<-list(curr)
- class(curr)<-"multiPhylo"
- NNIs<-c(NNIs,curr)
- if(method=="symmetric.difference")
- SSp<-colSums(sapply(NNIs,RF.dist,tree2=trees)^2)
- else if(method=="path.difference")
- SSp<-colSums(sapply(NNIs,function(x,y,m) sapply(y,
- function(y,x,m) setNames(treedist(y,x)[m],NULL),
- y=x,m=m),y=trees,m=method)^2)
- else {
- if(nnls.method=="unrooted") NNIs<-lapply(NNIs,unroot)
- NNIs<-lapply(NNIs,nnls.tree,dm=D,method=nnls.method,trace=0)
- NNIs<-lapply(NNIs,minTreeDist,trees=trees,method=method,
- ...)
- SSp<-sapply(NNIs,function(x) attr(x,"SQD"))
- }
- ii<-which(SSp==min(SSp))[1]
- if(!quiet) message(paste(" Best SS so far =",SSp[ii]))
- SSp<-SSp[ii]
- curr<-NNIs[[ii]]
- plotTree(curr)
- ct<-ct+1
- }
- if(!quiet) message(paste("\n Solution found after",ct,
- "set of nearest neighbor interchanges.\n"))
- curr
-}
-
-qpd<-function(t1,t2){
- if(inherits(t1,"phylo")) t1<-list(t1)
- if(inherits(t2,"phylo")) t2<-list(t2)
- tips<-t1[[1]]$tip.label
- P1<-lapply(t1,function(x) cophenetic(x)[tips,tips])
- P2<-lapply(t2,function(x) cophenetic(x)[tips,tips])
- foo<-function(x,y) sqrt(sum((x-y)^2/2))
- sapply(P2,function(x,y) sapply(y,foo,y=x),y=P1)
-}
-
-TREEDIST<-function(t1,t2,method){
- obj<-if(method=="symmetric.difference") RF.dist(t1,t2)
- else if(method=="path.difference") path.dist(t1,t2)
- else if(method=="weighted.path.difference") path.dist(t1,t2,use.weight=TRUE)
- else if(method=="branch.score.difference") KF.dist(t1,t2)
- obj
+## some average tree methods
+## written by Liam J. Revell
+
+ls.consensus<-function(trees,start=NULL,tol=1e-12,quiet=FALSE,...){
+ D<-Reduce("+",lapply(trees,function(x,t) cophenetic(x)[t,t],
+ t=trees[[1]]$tip.label))/length(trees)
+ tip.dates<-NULL
+ if(is.null(start)) start<-NJ(D)
+ if(hasArg(ultrametric)) ultrametric<-list(...)$ultrametric
+ else ultrametric<-all(sapply(trees,is.ultrametric))
+ if(ultrametric){
+ method<-"ultrametric"
+ } else {
+ if(hasArg(tipdated)) tipdated<-list(...)$tipdated
+ else tipdated<-FALSE
+ if(tipdated){
+ tip.dates<-diag(D)
+ method<-"tip.dated"
+ } else method<-"unrooted"
+ }
+ if(ultrametric&&!is.rooted(start)) start<-midpoint(start)
+ curr<-nnls.tree(D,tree=start,method=method,trace=0,tip.dates=tip.dates)
+ if(hasArg(optNNI)) optNNI<-list(...)$optNNI
+ else optNNI<-TRUE
+ if(optNNI){
+ Q<-Inf
+ Qp<-attr(curr,"RSS")
+ if(is.null(Qp)) Qp<-rss(D,curr)
+ ct<-0
+ while((Q-Qp)>tol){
+ Q<-Qp
+ NNIs<-.uncompressTipLabel(nni(curr))
+ curr<-list(curr)
+ class(curr)<-"multiPhylo"
+ NNIs<-c(NNIs,curr)
+ NNIs<-lapply(NNIs,nnls.tree,dm=D,method=method,trace=0,
+ tip.dates=tip.dates)
+ qs<-sapply(NNIs,rss,D=D)
+ ii<-which(qs==min(qs))[1]
+ if(!quiet) message(paste("Best Q =",qs[ii]))
+ Qp<-qs[ii]
+ curr<-NNIs[[ii]]
+ ct<-ct+1
+ }
+ if(!quiet)
+ message(paste("Solution found after",ct,
+ "set of nearest neighbor interchanges."))
+ } else if(!quiet)
+ message(paste("No optimization of topology performed.",
+ "Returning start tree with LS edge lengths."))
+ curr
+}
+
+rss<-function(D,tree){
+ Dp<-cophenetic(tree)[rownames(D),colnames(D)]
+ sum((D-Dp)^2)/2
+}
+
+minTreeDist<-function(tree,trees,method="quadratic.path.difference",...){
+ if(is.null(tree$edge.length))
+ tree$edge.length<-runif(n=nrow(tree$edge))
+ e<-tree$edge.length
+ fn<-function(e,tree,trees,m){
+ tree$edge.length<-e
+ if(method=="quadratic.path.difference")
+ d<-qpd(tree,trees)
+ else
+ d<-sapply(trees,function(x,y) treedist(x,y)[m],
+ y=tree)
+ sum(d^2)
+ }
+ fit<-optim(e,fn,tree=tree,trees=trees,m=method,lower=0,
+ method="L-BFGS-B",...)
+ tree$edge.length<-fit$par
+ attr(tree,"SQD")<-fit$value
+ tree
+}
+
+averageTree<-function(trees,start=NULL,method="quadratic.path.difference",
+ tol=1e-12,quiet=FALSE,...){
+ if(!quiet)
+ message(paste(
+ "\n Function is attempting to find the phylogeny with ",
+ "\n minimum distance to all trees in set under the ",
+ "\n \"",
+ paste(strsplit(method,"[.]")[[1]],collapse=" "),
+ "\" criterion...\n",sep=""))
+ if(is.null(start)){
+ if(method%in%c("symmetric.difference","path.difference"))
+ start<-multi2di(consensus(trees,p=0.5),random=FALSE)
+ else start<-ls.consensus(trees,quiet=TRUE)
+ }
+ if(method%in%c("branch.score.difference","quadratic.path.difference")){
+ D<-Reduce("+",lapply(trees,function(x,t) cophenetic(x)[t,t],
+ t=trees[[1]]$tip.label))/length(trees)
+ rt<-all(sapply(trees,is.ultrametric))
+ nnls.method<-if(rt) "ultrametric" else "unrooted"
+ } else if(method%in%c("symmetric.difference","path.difference")){
+ rt<-all(sapply(trees,is.rooted))
+ if(!rt) start<-unroot(start)
+ }
+ curr<-start
+ SS<-Inf
+ SSp<-sum(sapply(trees,function(x,y,m) treedist(x,y)[m],
+ y=curr,m=method)^2)
+ ct<-0
+ while((SS-SSp)>tol){
+ SS<-SSp
+ NNIs<-.uncompressTipLabel(nni(curr))
+ curr<-list(curr)
+ class(curr)<-"multiPhylo"
+ NNIs<-c(NNIs,curr)
+ if(method=="symmetric.difference")
+ SSp<-colSums(sapply(NNIs,RF.dist,tree2=trees)^2)
+ else if(method=="path.difference")
+ SSp<-colSums(sapply(NNIs,function(x,y,m) sapply(y,
+ function(y,x,m) setNames(treedist(y,x)[m],NULL),
+ y=x,m=m),y=trees,m=method)^2)
+ else {
+ if(nnls.method=="unrooted") NNIs<-lapply(NNIs,unroot)
+ NNIs<-lapply(NNIs,nnls.tree,dm=D,method=nnls.method,trace=0)
+ NNIs<-lapply(NNIs,minTreeDist,trees=trees,method=method,
+ ...)
+ SSp<-sapply(NNIs,function(x) attr(x,"SQD"))
+ }
+ ii<-which(SSp==min(SSp))[1]
+ if(!quiet) message(paste(" Best SS so far =",SSp[ii]))
+ SSp<-SSp[ii]
+ curr<-NNIs[[ii]]
+ plotTree(curr)
+ ct<-ct+1
+ }
+ if(!quiet) message(paste("\n Solution found after",ct,
+ "set of nearest neighbor interchanges.\n"))
+ curr
+}
+
+qpd<-function(t1,t2){
+ if(inherits(t1,"phylo")) t1<-list(t1)
+ if(inherits(t2,"phylo")) t2<-list(t2)
+ tips<-t1[[1]]$tip.label
+ P1<-lapply(t1,function(x) cophenetic(x)[tips,tips])
+ P2<-lapply(t2,function(x) cophenetic(x)[tips,tips])
+ foo<-function(x,y) sqrt(sum((x-y)^2/2))
+ sapply(P2,function(x,y) sapply(y,foo,y=x),y=P1)
+}
+
+TREEDIST<-function(t1,t2,method){
+ obj<-if(method=="symmetric.difference") RF.dist(t1,t2)
+ else if(method=="path.difference") path.dist(t1,t2)
+ else if(method=="weighted.path.difference") path.dist(t1,t2,use.weight=TRUE)
+ else if(method=="branch.score.difference") KF.dist(t1,t2)
+ obj
}
\ No newline at end of file
diff --git a/R/ltt.R b/R/ltt.R
index 449e9ef..9e7b9db 100644
--- a/R/ltt.R
+++ b/R/ltt.R
@@ -1,558 +1,576 @@
-## This function computes the data for a lineage-through-time plot and
-## (optionally) creates this plot the function does not require a tree
-## that is ultrametric. Optionally, the function can remove extinct
-## species from the phylogeny. If the input tree is an object of class
-## "multiPhylo" then the function will simultaneously plot all ltts.
-## written by Liam J. Revell 2010-2015, 2022
-
-## ltt method (added 2022)
-
-ltt<-function(tree,...) UseMethod("ltt")
-
-ltt.default<-function(tree,...){
- warning(paste(
- "ltt does not know how to handle objects of class ",
- class(tree),"."))
-}
-
-print.ltt.multiSimmap<-function(x,...){
- cat(paste(length(x),"objects of class \"ltt.simmap\" in a list\n"))
-}
-
-ltt.multiSimmap<-function(tree,gamma=TRUE,...){
- if(!inherits(tree,"multiSimmap")){
- stop("tree must be object of class \"multiSimmap\".")
- } else {
- obj<-lapply(tree,ltt,plot=FALSE,log.lineages=FALSE,gamma=gamma)
- class(obj)<-"ltt.multiSimmap"
- return(obj)
- }
-}
-
-ltt.simmap<-function(tree,plot=TRUE,log.lineages=FALSE,gamma=TRUE,...){
- if(!inherits(tree,"simmap")){
- stop("tree must be an object of class \"simmap\".")
- } else {
- levs<-sort(unique(c(getStates(tree,"tips"),
- getStates(tree,"nodes"))))
- tt<-map.to.singleton(tree)
- H<-nodeHeights(tt)
- h<-c(0,max(H)-branching.times(tt),min(sapply(1:Ntip(tt),
- nodeheight,tree=tt)))
- ss<-setNames(as.factor(names(tt$edge.length)),
- tt$edge[,2])
- lineages<-matrix(0,length(h),length(levs),
- dimnames=list(names(h),levs))
- lineages[1,getStates(tree,"nodes")[1]]<-1
- for(i in 2:length(h)){
- ii<-intersect(which(h[i]>H[,1]),which(h[i]<=H[,2]))
- lineages[i,]<-summary(ss[ii])
- }
- ii<-order(h)
- times<-h[ii]
- lineages<-lineages[ii,]
- lineages<-cbind(lineages,total=rowSums(lineages))
- obj<-list(times=times,ltt=lineages)
- if(gamma==FALSE){
- obj<-list(ltt=lineages,times=times,tree=tree)
- class(obj)<-"ltt.simmap"
- } else {
- gam<-gammatest(ltt(as.phylo(tree),plot=FALSE))
- obj<-list(ltt=lineages,times=times,gamma=gam$gamma,
- p=gam$p,tree=tree)
- class(obj)<-"ltt.simmap"
- }
- }
- if(plot) plot(obj,log.lineages=log.lineages,...)
- obj
-}
-
-plot.ltt.multiSimmap<-function(x,...){
- if(hasArg(add)) add<-list(...)$add
- else add<-FALSE
- hh<-max(sapply(x,function(x) max(nodeHeights(x$tree))))
- if(hasArg(alpha)) alpha<-list(...)$alpha else alpha<-0.05
- if(hasArg(res)) res<-list(...)$res else res<-1000
- if(hasArg(log.lineages)) log.lineages<-list(...)$log.lineages
- else log.lineages<-FALSE
- levs<-sort(unique(unlist(lapply(x,function(x)
- c(getStates(x$tree,"tips"),getStates(x$tree,"nodes"))))))
- if(hasArg(colors)) colors<-list(...)$colors
- else colors<-setNames(c(palette()[1:length(levs)+1],par()$fg),
- c(levs,"total"))
- if(hasArg(legend)) legend<-list(...)$legend else
- legend<-"topleft"
- plot.leg<-TRUE
- if(is.logical(legend)) if(legend) plot.leg<-TRUE else
- plot.leg<-FALSE
- if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-5
- if(hasArg(show.total)) show.total<-list(...)$show.total else
- show.total<-TRUE
- nn<-max(sapply(x,function(x,tot) if(!tot)
- max(x$ltt[,-which(colnames(x$ltt)=="total")]) else
- Ntip(x$tree),tot=show.total))
- xlim<-if(hasArg(xlim)) list(...)$xlim else c(0,hh)
- ylim<-if(hasArg(ylim)) list(...)$ylim else
- if(log.lineages) log(c(1,1.05*nn)) else
- c(0,1.05*nn)
- xlab<-if(hasArg(xlab)) list(...)$xlab else "time"
- ylab<-if(hasArg(ylab)) list(...)$ylab else if(log.lineages)
- "log(lineages)" else "lineages"
- TIMES<-seq(0,hh,length.out=res)
- LINEAGES<-matrix(0,length(TIMES),length(levs)+1)
- colnames(LINEAGES)<-c(levs,"total")
- for(i in 1:length(TIMES)){
- for(j in 1:length(x)){
- ii<-which(x[[j]]$times<=TIMES[i])
- ADD<-if(length(ii)==0) rep(0,length(levs)) else
- x[[j]]$ltt[max(ii),]/length(x)
- LINEAGES[i,]<-LINEAGES[i,]+ADD
- }
- }
- args<-list(...)
- args$res<-NULL
- args$alpha<-NULL
- args$log.lineages<-NULL
- args$colors<-NULL
- args$legend<-NULL
- args$show.total<-NULL
- args$add<-NULL
- args$xlim<-xlim
- args$ylim<-ylim
- args$xlab<-xlab
- args$ylab<-ylab
- args$x<-NA
- if(!add) do.call(plot,args)
- if(!show.total) dd<-1 else dd<-0
- for(i in 1:length(x)){
- for(j in 1:(ncol(LINEAGES)-dd)){
- nm<-colnames(x[[i]]$ltt)[j]
- ltt<-if(log.lineages) log(x[[i]]$ltt[,j]) else x[[i]]$ltt[,j]
- lines(x[[i]]$times,ltt,type="s",lwd=1,
- col=make.transparent(colors[nm],
- alpha))
- }
- }
- for(i in 1:(ncol(LINEAGES)-dd)){
- nm<-colnames(LINEAGES)[i]
- ltt<-if(log.lineages) log(LINEAGES[,i]) else LINEAGES[,i]
- lines(TIMES,ltt,lwd=lwd,col=colors[nm])
- }
- if(plot.leg){
- nm<-c(levs,"total")
- if(!show.total) nm<-setdiff(nm,"total")
- legend(legend,legend=nm,pch=22,pt.bg=colors[nm],pt.cex=1.2,
- cex=0.8,bty="n")
- }
- invisible(list(times=TIMES,ltt=LINEAGES))
-}
-
-plot.ltt.simmap<-function(x,...){
- if(hasArg(add)) add<-list(...)$add else add<-FALSE
- if(hasArg(log.lineages)) log.lineages<-list(...)$log.lineages
- else log.lineages<-FALSE
- if(hasArg(colors)) colors<-list(...)$colors
- else colors<-setNames(c(palette()[2:ncol(x$ltt)],par()$fg),
- colnames(x$ltt))
- if(hasArg(legend)) legend<-list(...)$legend else
- legend<-"topleft"
- plot.leg<-TRUE
- if(is.logical(legend)) if(legend) plot.leg<-TRUE else
- plot.leg<-FALSE
- if(hasArg(show.tree)) show.tree<-list(...)$show.tree else
- show.tree<-FALSE
- if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-3
- if(hasArg(outline)) outline<-list(...)$outline else
- outline<-show.tree
- if(hasArg(show.total)) show.total<-list(...)$show.total else
- show.total<-TRUE
- xlim<-if(hasArg(xlim)) list(...)$xlim else range(x$times)
- ylim<-if(hasArg(ylim)) list(...)$ylim else
- if(log.lineages) log(c(1,1.05*max(x$ltt))) else
- c(0,1.1*max(x$ltt))
- xlab<-if(hasArg(xlab)) list(...)$xlab else "time"
- ylab<-if(hasArg(ylab)) list(...)$ylab else if(log.lineages)
- "log(lineages)" else "lineages"
- args<-list(...)
- args$log.lineages<-NULL
- args$colors<-NULL
- args$legend<-NULL
- args$show.tree<-NULL
- args$show.total<-NULL
- args$add<-NULL
- args$xlim<-xlim
- args$ylim<-ylim
- args$xlab<-xlab
- args$ylab<-ylab
- args$x<-NA
- if(!add) do.call(plot,args)
- tips<-if(log.lineages) seq(0,log(Ntip(x$tree)),
- length.out=Ntip(x$tree)) else 1:Ntip(x$tree)
- if(show.tree){
- mar<-par()$mar
- plot(x$tree,
- make.transparent(colors[1:(ncol(x$ltt)-1)],0.5),
- tips=tips,xlim=xlim,ylim=ylim,
- ftype="off",add=TRUE,lwd=1,mar=mar)
- plot.window(xlim=xlim,ylim=ylim)
- }
- if(!show.total) dd<-1 else dd<-0
- for(i in 1:(ncol(x$ltt)-dd)){
- LTT<-if(log.lineages) log(x$ltt) else x$ltt
- if(outline) lines(x$times,LTT[,i],type="s",lwd=lwd+2,
- col=if(par()$bg=="transparent") "white" else
- par()$bg)
- lines(x$times,LTT[,i],type="s",lwd=lwd,col=colors[i])
- }
- if(plot.leg){
- nn<-colnames(x$ltt)
- if(!show.total) nn<-setdiff(nn,"total")
- legend(legend,nn,pch=22,pt.bg=colors[nn],pt.cex=1.2,
- cex=0.8,bty="n")
- }
-}
-
-print.ltt.simmap<-function(x,digits=4,...){
- ss<-sort(unique(c(getStates(x$tree,"tips"),
- getStates(x$tree,"nodes"))))
- cat("Object of class \"ltt.simmap\" containing:\n\n")
- cat(paste("(1) A phylogenetic tree with ",Ntip(x$tree),
- " tips, ",x$tree$Nnode," internal\n",sep= ""))
- cat(paste(" nodes, and a mapped state with ",length(ss),
- " states.\n\n",sep=""))
- cat(paste("(2) A matrix containing the number of lineages in each\n",
- " state (ltt) and event timings (times) on the tree.\n\n",sep=""))
- if(!is.null(x$gamma))
- cat(paste("(3) A value for Pybus & Harvey's \"gamma\"",
- " statistic of\n gamma = ",round(x$gamma,digits),
- ", p-value = ",
- round(x$p,digits),".\n\n",sep=""))
-}
-
-ltt.multiPhylo<-function(tree,drop.extinct=FALSE,gamma=TRUE,...){
- if(!inherits(tree,"multiPhylo")){
- stop("tree must be object of class \"multiPhylo\".")
- } else {
- obj<-lapply(tree,ltt,plot=FALSE,drop.extinct=drop.extinct,
- log.lineages=FALSE,gamma=gamma)
- class(obj)<-"multiLtt"
- return(obj)
- }
-}
-
-ltt.phylo<-function(tree,plot=TRUE,drop.extinct=FALSE,log.lineages=TRUE,
- gamma=TRUE,...){
- # set tolerance
- tol<-1e-6
- # check "phylo" object
- if(!inherits(tree,"phylo")){
- stop("tree must be object of class \"phylo\".")
- } else {
- # reorder the tree
- tree<-reorder.phylo(tree,order="cladewise")
- if(!is.null(tree$node.label)){
- node.names<-setNames(tree$node.label,1:tree$Nnode+Ntip(tree))
- tree$node.label<-NULL
- } else node.names<-NULL
- ## check if tree is ultrametric & if yes, then make *precisely* ultrametric
- if(is.ultrametric(tree)){
- h<-max(nodeHeights(tree))
- time<-c(0,h-sort(branching.times(tree),decreasing=TRUE),h)
- nodes<-as.numeric(names(time)[2:(length(time)-1)])
- ltt<-c(cumsum(c(1,sapply(nodes,function(x,y) sum(y==x)-1,y=tree$edge[,1]))),
- length(tree$tip.label))
- names(ltt)<-names(time)
- } else {
- # internal functions
- # drop extinct tips
- drop.extinct.tips<-function(phy){
- temp<-diag(vcv(phy))
- if(length(temp[temp<(max(temp)-tol)])>0)
- pruned.phy<-drop.tip(phy,names(temp[temp<(max(temp)-tol)]))
- else
- pruned.phy<-phy
- return(pruned.phy)
- }
- # first, if drop.extinct==TRUE
- if(drop.extinct==TRUE)
- tree<-drop.extinct.tips(tree)
- # compute node heights
- root<-length(tree$tip)+1
- node.height<-matrix(NA,nrow(tree$edge),2)
- for(i in 1:nrow(tree$edge)){
- if(tree$edge[i,1]==root){
- node.height[i,1]<-0.0
- node.height[i,2]<-tree$edge.length[i]
- } else {
- node.height[i,1]<-node.height[match(tree$edge[i,1],tree$edge[,2]),2]
- node.height[i,2]<-node.height[i,1]+tree$edge.length[i]
- }
- }
- ltt<-vector()
- tree.length<-max(node.height) # tree length
- n.extinct<-sum(node.height[tree$edge[,2]<=length(tree$tip),2]<(tree.length-tol))
- # fudge things a little bit
- node.height[tree$edge[,2]<=length(tree$tip),2]<-
- node.height[tree$edge[,2]<=length(tree$tip),2]+1.1*tol
- time<-c(0,node.height[,2]); names(time)<-as.character(c(root,tree$edge[,2]))
- temp<-vector()
- time<-time[order(time)]
- time<-time[1:(tree$Nnode+n.extinct+1)] # times
- # get numbers of lineages
- for(i in 1:(length(time)-1)){
- ltt[i]<-0
- for(j in 1:nrow(node.height))
- ltt[i]<-ltt[i]+(time[i]>=(node.height[j,1]-
- tol)&&time[i]<=(node.height[j,2]-tol))
- }
- ltt[i+1]<-0
- for(j in 1:nrow(node.height))
- ltt[i+1]<-ltt[i+1]+(time[i+1]<=(node.height[j,2]+tol))
- # set names (these are the node indices)
- names(ltt)<-names(time)
- # append 0,1 for time 0
- ltt<-c(1,ltt)
- time<-c(0,time)
- # subtract fudge factor
- time[length(time)]<-time[length(time)]-1.1*tol
- }
- if(!is.null(node.names)){ nn<-sapply(names(time),function(x,y)
- if(any(names(y)==x)) y[which(names(y)==x)] else "",y=node.names)
- names(ltt)<-names(time)<-nn
- }
- if(gamma==FALSE){
- obj<-list(ltt=ltt,times=time,tree=tree)
- class(obj)<-"ltt"
- } else {
- gam<-gammatest(list(ltt=ltt,times=time))
- obj<-list(ltt=ltt,times=time,gamma=gam$gamma,p=gam$p,tree=tree)
- class(obj)<-"ltt"
- }
- }
- if(plot) plot(obj,log.lineages=log.lineages,...)
- obj
-}
-
-## function computes the gamma-statistic & a two-tailed P-value
-## written by Liam J. Revell 2011, 2019
-
-gammatest<-function(x){
- n<-max(x$ltt)
- g<-vector()
- for(i in 2:(length(x$times))) g[i-1]<-x$times[i]-x$times[i-1]
- T<-sum((2:n)*g[2:n])
- doublesum<-0
- for(i in 1:(n-1)) for(k in 1:i) doublesum<-doublesum+k*g[k]
- gamma<-(1/(n-2)*doublesum-T/2)/(T*sqrt(1/(12*(n-2))))
- p<-2*pnorm(abs(gamma),lower.tail=F)
- object<-list(gamma=gamma,p=p)
- class(object)<-"gammatest"
- object
-}
-
-## print method for object class "gammatest"
-## written by Liam J. Revell 2019
-
-print.gammatest<-function(x,...){
- if(hasArg(digits)) digits<-list(...)$digits
- else digits<-4
- cat("\nAn object of class \"gammatest\" with:\n")
- cat(paste("(1) Pybus & Harvey's gamma = ",
- round(x$gamma,digits),sep=""))
- cat(paste("\n(2) p-value = ",round(x$p,digits),
- "\n\n",sep=""))
-}
-
-## S3 print method for object of class "ltt"
-## written by Liam J. Revell 2015
-
-print.ltt<-function(x,digits=4,...){
- cat("Object of class \"ltt\" containing:\n\n")
- cat(paste("(1) A phylogenetic tree with ",Ntip(x$tree),
- " tips and ",x$tree$Nnode," internal\n",sep= ""))
- cat(" nodes.\n\n")
- cat(paste("(2) Vectors containing the number of lineages (ltt) and\n",
- " branching times (times) on the tree.\n\n",sep=""))
- if(!is.null(x$gamma))
- cat(paste("(3) A value for Pybus & Harvey's \"gamma\"",
- " statistic of\n gamma = ",round(x$gamma,digits),
- ", p-value = ",
- round(x$p,digits),".\n\n",sep=""))
-}
-
-## S3 print method for object of class "multiLtt"
-## written by Liam J. Revell 2015
-
-print.multiLtt<-function(x,...){
- cat(paste(length(x),"objects of class \"ltt\" in a list\n"))
-}
-
-## S3 plot method for object of class "ltt"
-## written by Liam J. Revell 2015
-
-plot.ltt<-function(x,...){
- args<-list(...)
- args$x<-x$time
- if(!is.null(args$log.lineages)){
- logl<-args$log.lineages
- args$log.lineages<-NULL
- } else logl<-TRUE
- if(!is.null(args$show.tree)){
- show.tree<-args$show.tree
- args$show.tree<-NULL
- } else show.tree<-FALSE
- if(!is.null(args$transparency)){
- transparency<-args$transparency
- args$transparency<-NULL
- } else transparency<-0.3
- args$y<-if(logl) log(x$ltt) else x$ltt
- if(is.null(args$xlab)) args$xlab<-"time"
- if(is.null(args$ylab))
- args$ylab<-if(logl) "log(lineages)" else "lineages"
- if(is.null(args$type)) args$type<-"s"
- if(hasArg(add)){
- add<-list(...)$add
- args$add<-NULL
- } else add<-FALSE
- if(!add) do.call(plot,args)
- else do.call(lines,args)
- if(show.tree){
- tips<-if(par()$ylog) setNames(exp(1:Ntip(x$tree)),x$tree$tip.label)
- else setNames(1:Ntip(x$tree),x$tree$tip.label)
- plotTree(x$tree,color=rgb(0,0,1,transparency),
- ftype="off",add=TRUE,mar=par()$mar,tips=tips)
- }
-}
-
-## S3 plot method for object of class "multiLtt"
-## written by Liam J. Revell 2015, 2020
-
-plot.multiLtt<-function(x,...){
- max.lineages<-max(sapply(x,function(x) max(x$ltt)))
- max.time<-max(sapply(x,function(x) max(x$time)))
- args<-list(...)
- if(!is.null(args$log.lineages)) logl<-list(...)$log.lineages
- else logl<-TRUE
- if(is.null(args$xlim)) args$xlim<-c(0,max.time)
- if(is.null(args$ylim))
- args$ylim<-if(logl) c(0,log(max.lineages)) else c(1,max.lineages)
- args$x<-x[[1]]
- do.call(plot,args)
- args$add<-TRUE
- if(!is.null(args$log)) args$log<-NULL
- if(length(x)>2){
- for(i in 2:length(x)){
- args$x<-x[[i]]
- do.call(plot,args)
- }
- } else {
- args$x<-x[[2]]
- do.call(plot,args)
- }
-}
-
-## compute the gamma statistic through time by slicing the tree n times
-## written by Liam J. Revell 2017
-
-gtt<-function(tree,n=100,...){
- if(!inherits(tree,"phylo"))
- stop("tree must be object of class \"phylo\".")
- if(inherits(tree,"simmap")) tree<-as.phylo(tree)
- if(hasArg(plot)) plot<-list(...)$plot
- else plot<-FALSE
- obj<-ltt(tree,plot=FALSE)
- t<-obj$times[which(obj$ltt==3)[1]]
- h<-max(nodeHeights(tree))
- x<-seq(t,h,by=(h-t)/(n-1))
- trees<-lapply(x,treeSlice,tree=tree,orientation="rootwards")
- gamma<-sapply(trees,function(x,plot){
- obj<-unlist(gammatest(ltt<-ltt(x,plot=FALSE)));
- if(plot) plot(ltt,xlim=c(0,h),ylim=c(1,Ntip(tree)),
- log.lineages=FALSE,log="y");
- Sys.sleep(0.01);
- obj},plot=plot)
- object<-list(t=x,gamma=gamma[1,],p=gamma[2,],tree=tree)
- class(object)<-"gtt"
- object
-}
-
-## plot method for "gtt" object class
-plot.gtt<-function(x,...){
- args<-list(...)
- args$x<-x$t
- args$y<-x$gamma
- if(!is.null(args$show.tree)){
- show.tree<-args$show.tree
- args$show.tree<-NULL
- } else show.tree<-TRUE
- if(is.null(args$xlim)) args$xlim<-c(0,max(x$t))
- if(is.null(args$xlab)) args$xlab<-"time"
- if(is.null(args$ylab)) args$ylab<-expression(gamma)
- if(is.null(args$lwd)) args$lwd<-3
- if(is.null(args$type)) args$type<-"s"
- if(is.null(args$bty)) args$bty<-"l"
- if(is.null(args$main)) args$main<-expression(paste(gamma," through time plot"))
- do.call(plot,args)
- if(show.tree) plotTree(x$tree,add=TRUE,ftype="off",mar=par()$mar,
- xlim=args$xlim,color=make.transparent("blue",0.1))
-}
-
-## print method for "gtt" object class
-print.gtt<-function(x,...)
- cat("Object of class \"gtt\".\n\n")
-
-## perform the MCCR test of Pybus & Harvey (2000)
-## written by Liam J. Revell 2018
-
-mccr<-function(obj,rho=1,nsim=100,...){
- N<-round(Ntip(obj$tree)/rho)
- tt<-pbtree(n=N,nsim=nsim)
- foo<-function(x,m) drop.tip(x,sample(x$tip.label,m))
- tt<-lapply(tt,foo,m=N-Ntip(obj$tree))
- g<-sapply(tt,function(x) ltt(x,plot=FALSE)$gamma)
- P<-if(obj$gamma>median(g)) 2*mean(g>=obj$gamma) else 2*mean(g<=obj$gamma)
- result<-list(gamma=obj$gamma,"P(two-tailed)"=P,null.gamma=g)
- class(result)<-"mccr"
- result
-}
-
-## print method for "mccr" object class
-
-print.mccr<-function(x,digits=4,...){
- cat("Object of class \"mccr\" consisting of:\n\n")
- cat(paste("(1) A value for Pybus & Harvey's \"gamma\"",
- " statistic of \n gamma = ",round(x$gamma,digits),
- ".\n\n",sep=""))
- cat(paste("(2) A two-tailed p-value from the MCCR test of ",
- round(x$'P(two-tailed)',digits),".\n\n", sep = ""))
- cat(paste("(3) A simulated null-distribution of gamma from ",
- length(x$null.gamma),"\n simulations.\n\n",sep=""))
-}
-
-## plot method for "mccr" object class
-
-plot.mccr<-function(x,...){
- if(hasArg(main)) main<-list(...)$main
- else main=expression(paste("null distribution of ",
- gamma))
- if(hasArg(las)) las<-list(...)$las
- else las<-par()$las
- if(hasArg(cex.axis)) cex.axis<-list(...)$cex.axis
- else cex.axis<-par()$cex.axis
- if(hasArg(cex.lab)) cex.lab<-list(...)$cex.lab
- else cex.lab<-par()$cex.lab
- hh<-hist(x$null.gamma,breaks=min(c(max(12,
- round(length(x$null.gamma)/10)),20)),
- plot=FALSE)
- if(hasArg(ylim)) ylim<-list(...)$ylim
- else ylim<-c(0,1.15*max(hh$counts))
- plot(hh,xlim=range(c(x$gamma,x$null.gamma)),
- main=main,xlab=expression(gamma),col="lightgrey",
- ylim=ylim,las=las,cex.axis=cex.axis,cex.lab=cex.lab)
- arrows(x0=x$gamma,y0=par()$usr[4],y1=0,length=0.12,
- col=make.transparent("blue",0.5),lwd=2)
- text(x$gamma,0.96*par()$usr[4],
- expression(paste("observed value of ",gamma)),
- pos=if(x$gamma>mean(x$null.gamma)) 2 else 4,
- cex=0.9)
+## This function computes the data for a lineage-through-time plot and
+## (optionally) creates this plot the function does not require a tree
+## that is ultrametric. Optionally, the function can remove extinct
+## species from the phylogeny. If the input tree is an object of class
+## "multiPhylo" then the function will simultaneously plot all ltts.
+## written by Liam J. Revell 2010-2015, 2022, 2023
+
+## ltt method (added 2022)
+
+ltt<-function(tree,...) UseMethod("ltt")
+
+ltt.default<-function(tree,...){
+ warning(paste(
+ "ltt does not know how to handle objects of class ",
+ class(tree),"."))
+}
+
+print.ltt.multiSimmap<-function(x,...){
+ cat(paste(length(x),"objects of class \"ltt.simmap\" in a list\n"))
+}
+
+ltt.multiSimmap<-function(tree,gamma=TRUE,...){
+ if(!inherits(tree,"multiSimmap")){
+ stop("tree must be object of class \"multiSimmap\".")
+ } else {
+ obj<-lapply(tree,ltt,plot=FALSE,log.lineages=FALSE,gamma=gamma)
+ class(obj)<-"ltt.multiSimmap"
+ return(obj)
+ }
+}
+
+ltt.simmap<-function(tree,plot=TRUE,log.lineages=FALSE,gamma=TRUE,...){
+ if(!inherits(tree,"simmap")){
+ stop("tree must be an object of class \"simmap\".")
+ } else {
+ levs<-sort(unique(c(getStates(tree,"tips"),
+ getStates(tree,"nodes"))))
+ tt<-map.to.singleton(tree)
+ H<-nodeHeights(tt)
+ h<-c(0,max(H)-branching.times(tt),min(sapply(1:Ntip(tt),
+ nodeheight,tree=tt)))
+ ss<-setNames(as.factor(names(tt$edge.length)),
+ tt$edge[,2])
+ lineages<-matrix(0,length(h),length(levs),
+ dimnames=list(names(h),levs))
+ lineages[1,getStates(tree,"nodes")[1]]<-1
+ for(i in 2:length(h)){
+ ii<-intersect(which(h[i]>H[,1]),which(h[i]<=H[,2]))
+ lineages[i,]<-summary(ss[ii])
+ }
+ ii<-order(h)
+ times<-h[ii]
+ lineages<-lineages[ii,]
+ lineages<-cbind(lineages,total=rowSums(lineages))
+ obj<-list(times=times,ltt=lineages)
+ if(gamma==FALSE){
+ obj<-list(ltt=lineages,times=times,tree=tree)
+ class(obj)<-"ltt.simmap"
+ } else {
+ gam<-gammatest(ltt(as.phylo(tree),plot=FALSE))
+ obj<-list(ltt=lineages,times=times,gamma=gam$gamma,
+ p=gam$p,tree=tree)
+ class(obj)<-"ltt.simmap"
+ }
+ }
+ if(plot) plot(obj,log.lineages=log.lineages,...)
+ obj
+}
+
+plot.ltt.multiSimmap<-function(x,...){
+ if(hasArg(add)) add<-list(...)$add
+ else add<-FALSE
+ hh<-max(sapply(x,function(x) max(nodeHeights(x$tree))))
+ if(hasArg(alpha)) alpha<-list(...)$alpha else alpha<-0.05
+ if(hasArg(res)) res<-list(...)$res else res<-1000
+ if(hasArg(log.lineages)) log.lineages<-list(...)$log.lineages
+ else log.lineages<-FALSE
+ levs<-sort(unique(unlist(lapply(x,function(x)
+ c(getStates(x$tree,"tips"),getStates(x$tree,"nodes"))))))
+ if(hasArg(colors)) colors<-list(...)$colors
+ else colors<-setNames(c(palette()[1:length(levs)+1],par()$fg),
+ c(levs,"total"))
+ if(hasArg(legend)) legend<-list(...)$legend else
+ legend<-"topleft"
+ plot.leg<-TRUE
+ if(is.logical(legend)) if(legend) plot.leg<-TRUE else
+ plot.leg<-FALSE
+ if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-5
+ if(hasArg(show.total)) show.total<-list(...)$show.total else
+ show.total<-TRUE
+ nn<-max(sapply(x,function(x,tot) if(!tot)
+ max(x$ltt[,-which(colnames(x$ltt)=="total")]) else
+ Ntip(x$tree),tot=show.total))
+ xlim<-if(hasArg(xlim)) list(...)$xlim else c(0,hh)
+ ylim<-if(hasArg(ylim)) list(...)$ylim else
+ if(log.lineages) log(c(1,1.05*nn)) else
+ c(0,1.05*nn)
+ xlab<-if(hasArg(xlab)) list(...)$xlab else "time"
+ ylab<-if(hasArg(ylab)) list(...)$ylab else if(log.lineages)
+ "log(lineages)" else "lineages"
+ TIMES<-seq(0,hh,length.out=res)
+ LINEAGES<-matrix(0,length(TIMES),length(levs)+1)
+ colnames(LINEAGES)<-c(levs,"total")
+ for(i in 1:length(TIMES)){
+ for(j in 1:length(x)){
+ ii<-which(x[[j]]$times<=TIMES[i])
+ ADD<-if(length(ii)==0) rep(0,length(levs)) else
+ x[[j]]$ltt[max(ii),]/length(x)
+ LINEAGES[i,]<-LINEAGES[i,]+ADD
+ }
+ }
+ args<-list(...)
+ args$res<-NULL
+ args$alpha<-NULL
+ args$log.lineages<-NULL
+ args$colors<-NULL
+ args$legend<-NULL
+ args$show.total<-NULL
+ args$add<-NULL
+ args$xlim<-xlim
+ args$ylim<-ylim
+ args$xlab<-xlab
+ args$ylab<-ylab
+ args$x<-NA
+ if(!add) do.call(plot,args)
+ if(!show.total) dd<-1 else dd<-0
+ for(i in 1:length(x)){
+ for(j in 1:(ncol(LINEAGES)-dd)){
+ nm<-colnames(x[[i]]$ltt)[j]
+ ltt<-if(log.lineages) log(x[[i]]$ltt[,j]) else x[[i]]$ltt[,j]
+ lines(x[[i]]$times,ltt,type="s",lwd=1,
+ col=make.transparent(colors[nm],
+ alpha))
+ }
+ }
+ for(i in 1:(ncol(LINEAGES)-dd)){
+ nm<-colnames(LINEAGES)[i]
+ ltt<-if(log.lineages) log(LINEAGES[,i]) else LINEAGES[,i]
+ lines(TIMES,ltt,lwd=lwd,col=colors[nm])
+ }
+ if(plot.leg){
+ nm<-c(levs,"total")
+ if(!show.total) nm<-setdiff(nm,"total")
+ legend(legend,legend=nm,pch=22,pt.bg=colors[nm],pt.cex=1.2,
+ cex=0.8,bty="n")
+ }
+ invisible(list(times=TIMES,ltt=LINEAGES))
+}
+
+plot.ltt.simmap<-function(x,...){
+ if(hasArg(add)) add<-list(...)$add else add<-FALSE
+ if(hasArg(log.lineages)) log.lineages<-list(...)$log.lineages
+ else log.lineages<-FALSE
+ if(hasArg(colors)) colors<-list(...)$colors
+ else colors<-setNames(c(palette()[2:ncol(x$ltt)],par()$fg),
+ colnames(x$ltt))
+ if(hasArg(legend)) legend<-list(...)$legend else
+ legend<-"topleft"
+ plot.leg<-TRUE
+ if(is.logical(legend)) if(legend) plot.leg<-TRUE else
+ plot.leg<-FALSE
+ if(hasArg(show.tree)) show.tree<-list(...)$show.tree else
+ show.tree<-FALSE
+ if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-3
+ if(hasArg(outline)) outline<-list(...)$outline else
+ outline<-show.tree
+ if(hasArg(show.total)) show.total<-list(...)$show.total else
+ show.total<-TRUE
+ xlim<-if(hasArg(xlim)) list(...)$xlim else range(x$times)
+ ylim<-if(hasArg(ylim)) list(...)$ylim else
+ if(log.lineages) log(c(1,1.05*max(x$ltt))) else
+ c(0,1.1*max(x$ltt))
+ xlab<-if(hasArg(xlab)) list(...)$xlab else "time"
+ ylab<-if(hasArg(ylab)) list(...)$ylab else if(log.lineages)
+ "log(lineages)" else "lineages"
+ args<-list(...)
+ args$log.lineages<-NULL
+ args$colors<-NULL
+ args$legend<-NULL
+ args$show.tree<-NULL
+ args$show.total<-NULL
+ args$add<-NULL
+ args$xlim<-xlim
+ args$ylim<-ylim
+ args$xlab<-xlab
+ args$ylab<-ylab
+ args$x<-NA
+ if(!add) do.call(plot,args)
+ tips<-if(log.lineages) seq(0,log(Ntip(x$tree)),
+ length.out=Ntip(x$tree)) else 1:Ntip(x$tree)
+ if(show.tree){
+ mar<-par()$mar
+ plot(x$tree,
+ make.transparent(colors[1:(ncol(x$ltt)-1)],0.5),
+ tips=tips,xlim=xlim,ylim=ylim,
+ ftype="off",add=TRUE,lwd=1,mar=mar)
+ plot.window(xlim=xlim,ylim=ylim)
+ }
+ if(!show.total) dd<-1 else dd<-0
+ for(i in 1:(ncol(x$ltt)-dd)){
+ LTT<-if(log.lineages) log(x$ltt) else x$ltt
+ if(outline) lines(x$times,LTT[,i],type="s",lwd=lwd+2,
+ col=if(par()$bg=="transparent") "white" else
+ par()$bg)
+ lines(x$times,LTT[,i],type="s",lwd=lwd,col=colors[i])
+ }
+ if(plot.leg){
+ nn<-colnames(x$ltt)
+ if(!show.total) nn<-setdiff(nn,"total")
+ legend(legend,nn,pch=22,pt.bg=colors[nn],pt.cex=1.2,
+ cex=0.8,bty="n")
+ }
+}
+
+print.ltt.simmap<-function(x,digits=4,...){
+ ss<-sort(unique(c(getStates(x$tree,"tips"),
+ getStates(x$tree,"nodes"))))
+ cat("Object of class \"ltt.simmap\" containing:\n\n")
+ cat(paste("(1) A phylogenetic tree with ",Ntip(x$tree),
+ " tips, ",x$tree$Nnode," internal\n",sep= ""))
+ cat(paste(" nodes, and a mapped state with ",length(ss),
+ " states.\n\n",sep=""))
+ cat(paste("(2) A matrix containing the number of lineages in each\n",
+ " state (ltt) and event timings (times) on the tree.\n\n",sep=""))
+ if(!is.null(x$gamma))
+ cat(paste("(3) A value for Pybus & Harvey's \"gamma\"",
+ " statistic of\n gamma = ",round(x$gamma,digits),
+ ", p-value = ",
+ round(x$p,digits),".\n\n",sep=""))
+}
+
+ltt.multiPhylo<-function(tree,drop.extinct=FALSE,gamma=TRUE,...){
+ if(!inherits(tree,"multiPhylo")){
+ stop("tree must be object of class \"multiPhylo\".")
+ } else {
+ obj<-lapply(tree,ltt,plot=FALSE,drop.extinct=drop.extinct,
+ log.lineages=FALSE,gamma=gamma)
+ class(obj)<-"multiLtt"
+ return(obj)
+ }
+}
+
+ltt.phylo<-function(tree,plot=TRUE,drop.extinct=FALSE,log.lineages=TRUE,
+ gamma=TRUE,...){
+ # set tolerance
+ tol<-1e-6
+ # check "phylo" object
+ if(!inherits(tree,"phylo")){
+ stop("tree must be object of class \"phylo\".")
+ } else {
+ # reorder the tree
+ tree<-reorder.phylo(tree,order="cladewise")
+ if(!is.null(tree$node.label)){
+ node.names<-setNames(tree$node.label,1:tree$Nnode+Ntip(tree))
+ tree$node.label<-NULL
+ } else node.names<-NULL
+ ## check if tree is ultrametric & if yes, then make *precisely* ultrametric
+ if(is.ultrametric(tree)){
+ h<-max(nodeHeights(tree))
+ time<-c(0,h-sort(branching.times(tree),decreasing=TRUE),h)
+ nodes<-as.numeric(names(time)[2:(length(time)-1)])
+ ltt<-c(cumsum(c(1,sapply(nodes,function(x,y) sum(y==x)-1,y=tree$edge[,1]))),
+ length(tree$tip.label))
+ names(ltt)<-names(time)
+ } else {
+ # internal functions
+ # drop extinct tips
+ drop.extinct.tips<-function(phy){
+ temp<-diag(vcv(phy))
+ if(length(temp[temp<(max(temp)-tol)])>0)
+ pruned.phy<-drop.tip(phy,names(temp[temp<(max(temp)-tol)]))
+ else
+ pruned.phy<-phy
+ return(pruned.phy)
+ }
+ # first, if drop.extinct==TRUE
+ if(drop.extinct==TRUE)
+ tree<-drop.extinct.tips(tree)
+ # compute node heights
+ root<-length(tree$tip)+1
+ node.height<-matrix(NA,nrow(tree$edge),2)
+ for(i in 1:nrow(tree$edge)){
+ if(tree$edge[i,1]==root){
+ node.height[i,1]<-0.0
+ node.height[i,2]<-tree$edge.length[i]
+ } else {
+ node.height[i,1]<-node.height[match(tree$edge[i,1],tree$edge[,2]),2]
+ node.height[i,2]<-node.height[i,1]+tree$edge.length[i]
+ }
+ }
+ ltt<-vector()
+ tree.length<-max(node.height) # tree length
+ n.extinct<-sum(node.height[tree$edge[,2]<=length(tree$tip),2]<(tree.length-tol))
+ # fudge things a little bit
+ node.height[tree$edge[,2]<=length(tree$tip),2]<-
+ node.height[tree$edge[,2]<=length(tree$tip),2]+1.1*tol
+ time<-c(0,node.height[,2]); names(time)<-as.character(c(root,tree$edge[,2]))
+ temp<-vector()
+ time<-time[order(time)]
+ time<-time[1:(tree$Nnode+n.extinct+1)] # times
+ # get numbers of lineages
+ for(i in 1:(length(time)-1)){
+ ltt[i]<-0
+ for(j in 1:nrow(node.height))
+ ltt[i]<-ltt[i]+(time[i]>=(node.height[j,1]-
+ tol)&&time[i]<=(node.height[j,2]-tol))
+ }
+ ltt[i+1]<-0
+ for(j in 1:nrow(node.height))
+ ltt[i+1]<-ltt[i+1]+(time[i+1]<=(node.height[j,2]+tol))
+ # set names (these are the node indices)
+ names(ltt)<-names(time)
+ # append 0,1 for time 0
+ ltt<-c(1,ltt)
+ time<-c(0,time)
+ # subtract fudge factor
+ time[length(time)]<-time[length(time)]-1.1*tol
+ }
+ if(!is.null(node.names)){ nn<-sapply(names(time),function(x,y)
+ if(any(names(y)==x)) y[which(names(y)==x)] else "",y=node.names)
+ names(ltt)<-names(time)<-nn
+ }
+ if(gamma==FALSE){
+ obj<-list(ltt=ltt,times=time,tree=tree)
+ class(obj)<-"ltt"
+ } else {
+ gam<-gammatest(list(ltt=ltt,times=time))
+ obj<-list(ltt=ltt,times=time,gamma=gam$gamma,p=gam$p,tree=tree)
+ class(obj)<-"ltt"
+ }
+ }
+ if(plot) plot(obj,log.lineages=log.lineages,...)
+ obj
+}
+
+## function computes the gamma-statistic & a two-tailed P-value
+## written by Liam J. Revell 2011, 2019
+
+gammatest<-function(x){
+ n<-max(x$ltt)
+ g<-vector()
+ for(i in 2:(length(x$times))) g[i-1]<-x$times[i]-x$times[i-1]
+ T<-sum((2:n)*g[2:n])
+ doublesum<-0
+ for(i in 1:(n-1)) for(k in 1:i) doublesum<-doublesum+k*g[k]
+ gamma<-(1/(n-2)*doublesum-T/2)/(T*sqrt(1/(12*(n-2))))
+ p<-2*pnorm(abs(gamma),lower.tail=F)
+ object<-list(gamma=gamma,p=p)
+ class(object)<-"gammatest"
+ object
+}
+
+## print method for object class "gammatest"
+## written by Liam J. Revell 2019
+
+print.gammatest<-function(x,...){
+ if(hasArg(digits)) digits<-list(...)$digits
+ else digits<-4
+ cat("\nAn object of class \"gammatest\" with:\n")
+ cat(paste("(1) Pybus & Harvey's gamma = ",
+ round(x$gamma,digits),sep=""))
+ cat(paste("\n(2) p-value = ",round(x$p,digits),
+ "\n\n",sep=""))
+}
+
+## S3 print method for object of class "ltt"
+## written by Liam J. Revell 2015
+
+print.ltt<-function(x,digits=4,...){
+ cat("Object of class \"ltt\" containing:\n\n")
+ cat(paste("(1) A phylogenetic tree with ",Ntip(x$tree),
+ " tips and ",x$tree$Nnode," internal\n",sep= ""))
+ cat(" nodes.\n\n")
+ cat(paste("(2) Vectors containing the number of lineages (ltt) and\n",
+ " branching times (times) on the tree.\n\n",sep=""))
+ if(!is.null(x$gamma))
+ cat(paste("(3) A value for Pybus & Harvey's \"gamma\"",
+ " statistic of\n gamma = ",round(x$gamma,digits),
+ ", p-value = ",
+ round(x$p,digits),".\n\n",sep=""))
+}
+
+## S3 print method for object of class "multiLtt"
+## written by Liam J. Revell 2015
+
+print.multiLtt<-function(x,...){
+ cat(paste(length(x),"objects of class \"ltt\" in a list\n"))
+}
+
+## S3 plot method for object of class "ltt"
+## written by Liam J. Revell 2015, 2023
+
+plot.ltt<-function(x,...){
+ args<-list(...)
+ if(hasArg(show.tree_mode)) show.tree_mode<-list(...)$show.tree_mode
+ else show.tree_mode<-"classic"
+ args$show.tree_mode<-NULL
+ args$x<-x$time
+ if(!is.null(args$log.lineages)){
+ logl<-args$log.lineages
+ args$log.lineages<-NULL
+ } else logl<-TRUE
+ if(!is.null(args$show.tree)){
+ show.tree<-args$show.tree
+ args$show.tree<-NULL
+ } else show.tree<-FALSE
+ if(!is.null(args$transparency)){
+ transparency<-args$transparency
+ args$transparency<-NULL
+ } else transparency<-0.3
+ args$y<-if(logl) log(x$ltt) else x$ltt
+ if(is.null(args$xlab)) args$xlab<-"time"
+ if(is.null(args$ylab))
+ args$ylab<-if(logl) "log(lineages)" else "lineages"
+ if(is.null(args$type)) args$type<-"s"
+ if(hasArg(add)){
+ add<-list(...)$add
+ args$add<-NULL
+ } else add<-FALSE
+ if(!add) do.call(plot,args)
+ else do.call(lines,args)
+ if(show.tree){
+ tips<-if(par()$ylog) exp(setNames(seq(log(min(args$y)),log(max(args$y)),
+ length.out=Ntip(x$tree)),x$tree$tip.label)) else setNames(1:Ntip(x$tree),
+ x$tree$tip.label)
+ if(show.tree_mode=="classic"){
+ plotTree(x$tree,color=rgb(0,0,1,transparency),
+ ftype="off",add=TRUE,mar=par()$mar,tips=tips)
+ } else if(show.tree_mode=="next generation"){
+ ## this doesn't really work yet
+ plotTree(x$tree,color=rgb(0,0,1,transparency),
+ ftype="off",add=TRUE,mar=par()$mar,tips=tips,
+ plot=FALSE)
+ pp<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ max_yy<-max(pp$yy)
+ max_y<-max(args$y)
+ hh<-c(tips,(pp$yy[1:x$tree$Nnode+Ntip(x$tree)]/max_yy)*
+ args$y[as.character(1:x$tree$Nnode+Ntip(x$tree))]+1)
+ for(i in 1:nrow(x$tree$edge)) lines(pp$xx[x$tree$edge[i,]],
+ hh[x$tree$edge[i,]],col=rgb(0,0,1,transparency),lwd=2)
+ }
+ }
+}
+
+## S3 plot method for object of class "multiLtt"
+## written by Liam J. Revell 2015, 2020
+
+plot.multiLtt<-function(x,...){
+ max.lineages<-max(sapply(x,function(x) max(x$ltt)))
+ max.time<-max(sapply(x,function(x) max(x$time)))
+ args<-list(...)
+ if(!is.null(args$log.lineages)) logl<-list(...)$log.lineages
+ else logl<-TRUE
+ if(is.null(args$xlim)) args$xlim<-c(0,max.time)
+ if(is.null(args$ylim))
+ args$ylim<-if(logl) c(0,log(max.lineages)) else c(1,max.lineages)
+ args$x<-x[[1]]
+ do.call(plot,args)
+ args$add<-TRUE
+ if(!is.null(args$log)) args$log<-NULL
+ if(length(x)>2){
+ for(i in 2:length(x)){
+ args$x<-x[[i]]
+ do.call(plot,args)
+ }
+ } else {
+ args$x<-x[[2]]
+ do.call(plot,args)
+ }
+}
+
+## compute the gamma statistic through time by slicing the tree n times
+## written by Liam J. Revell 2017
+
+gtt<-function(tree,n=100,...){
+ if(!inherits(tree,"phylo"))
+ stop("tree must be object of class \"phylo\".")
+ if(inherits(tree,"simmap")) tree<-as.phylo(tree)
+ if(hasArg(plot)) plot<-list(...)$plot
+ else plot<-FALSE
+ obj<-ltt(tree,plot=FALSE)
+ t<-obj$times[which(obj$ltt==3)[1]]
+ h<-max(nodeHeights(tree))
+ x<-seq(t,h,by=(h-t)/(n-1))
+ trees<-lapply(x,treeSlice,tree=tree,orientation="rootwards")
+ gamma<-sapply(trees,function(x,plot){
+ obj<-unlist(gammatest(ltt<-ltt(x,plot=FALSE)));
+ if(plot) plot(ltt,xlim=c(0,h),ylim=c(1,Ntip(tree)),
+ log.lineages=FALSE,log="y");
+ Sys.sleep(0.01);
+ obj},plot=plot)
+ object<-list(t=x,gamma=gamma[1,],p=gamma[2,],tree=tree)
+ class(object)<-"gtt"
+ object
+}
+
+## plot method for "gtt" object class
+plot.gtt<-function(x,...){
+ args<-list(...)
+ args$x<-x$t
+ args$y<-x$gamma
+ if(!is.null(args$show.tree)){
+ show.tree<-args$show.tree
+ args$show.tree<-NULL
+ } else show.tree<-TRUE
+ if(is.null(args$xlim)) args$xlim<-c(0,max(x$t))
+ if(is.null(args$xlab)) args$xlab<-"time"
+ if(is.null(args$ylab)) args$ylab<-expression(gamma)
+ if(is.null(args$lwd)) args$lwd<-3
+ if(is.null(args$type)) args$type<-"s"
+ if(is.null(args$bty)) args$bty<-"l"
+ if(is.null(args$main)) args$main<-expression(paste(gamma," through time plot"))
+ do.call(plot,args)
+ if(show.tree) plotTree(x$tree,add=TRUE,ftype="off",mar=par()$mar,
+ xlim=args$xlim,color=make.transparent("blue",0.1))
+}
+
+## print method for "gtt" object class
+print.gtt<-function(x,...)
+ cat("Object of class \"gtt\".\n\n")
+
+## perform the MCCR test of Pybus & Harvey (2000)
+## written by Liam J. Revell 2018
+
+mccr<-function(obj,rho=1,nsim=100,...){
+ N<-round(Ntip(obj$tree)/rho)
+ tt<-pbtree(n=N,nsim=nsim)
+ foo<-function(x,m) drop.tip(x,sample(x$tip.label,m))
+ tt<-lapply(tt,foo,m=N-Ntip(obj$tree))
+ g<-sapply(tt,function(x) ltt(x,plot=FALSE)$gamma)
+ P<-if(obj$gamma>median(g)) 2*mean(g>=obj$gamma) else 2*mean(g<=obj$gamma)
+ result<-list(gamma=obj$gamma,"P(two-tailed)"=P,null.gamma=g)
+ class(result)<-"mccr"
+ result
+}
+
+## print method for "mccr" object class
+
+print.mccr<-function(x,digits=4,...){
+ cat("Object of class \"mccr\" consisting of:\n\n")
+ cat(paste("(1) A value for Pybus & Harvey's \"gamma\"",
+ " statistic of \n gamma = ",round(x$gamma,digits),
+ ".\n\n",sep=""))
+ cat(paste("(2) A two-tailed p-value from the MCCR test of ",
+ round(x$'P(two-tailed)',digits),".\n\n", sep = ""))
+ cat(paste("(3) A simulated null-distribution of gamma from ",
+ length(x$null.gamma),"\n simulations.\n\n",sep=""))
+}
+
+## plot method for "mccr" object class
+
+plot.mccr<-function(x,...){
+ if(hasArg(main)) main<-list(...)$main
+ else main=expression(paste("null distribution of ",
+ gamma))
+ if(hasArg(las)) las<-list(...)$las
+ else las<-par()$las
+ if(hasArg(cex.axis)) cex.axis<-list(...)$cex.axis
+ else cex.axis<-par()$cex.axis
+ if(hasArg(cex.lab)) cex.lab<-list(...)$cex.lab
+ else cex.lab<-par()$cex.lab
+ hh<-hist(x$null.gamma,breaks=min(c(max(12,
+ round(length(x$null.gamma)/10)),20)),
+ plot=FALSE)
+ if(hasArg(ylim)) ylim<-list(...)$ylim
+ else ylim<-c(0,1.15*max(hh$counts))
+ plot(hh,xlim=range(c(x$gamma,x$null.gamma)),
+ main=main,xlab=expression(gamma),col="lightgrey",
+ ylim=ylim,las=las,cex.axis=cex.axis,cex.lab=cex.lab)
+ arrows(x0=x$gamma,y0=par()$usr[4],y1=0,length=0.12,
+ col=make.transparent("blue",0.5),lwd=2)
+ text(x$gamma,0.96*par()$usr[4],
+ expression(paste("observed value of ",gamma)),
+ pos=if(x$gamma>mean(x$null.gamma)) 2 else 4,
+ cex=0.9)
}
\ No newline at end of file
diff --git a/R/ltt95.R b/R/ltt95.R
index d2a3a39..8d54cdc 100644
--- a/R/ltt95.R
+++ b/R/ltt95.R
@@ -1,141 +1,141 @@
-# 95% CI on ltts
-# written by Liam J. Revell 2013, 2014, 2015, 2019
-
-ltt95<-function(trees,alpha=0.05,log=FALSE,method=c("lineages","times"),mode=c("median","mean"),...){
- if(!inherits(trees,"multiPhylo")) stop("trees should be an object of class \"multiPhylo\".")
- method<-method[1]
- mode<-mode[1]
- if(hasArg(res)) res<-list(...)$res
- else res<-100
- if(hasArg(plot)) plot<-list(...)$plot
- else plot<-TRUE
- X<-ltt(trees,plot=FALSE,gamma=FALSE)
- if(method=="times"){
- N<-length(X)
- tt<-sapply(X,function(x) max(x$times))
- zz<-max(tt)-tt
- for(i in 1:N) X[[i]]$times<-X[[i]]$times+zz[i]
- n<-sapply(X,function(x) max(x$ltt))
- if(all(n==max(n))) n<-max(n)
- else stop("for method=\"times\" all trees must contain the same number of lineages")
- LL<-sapply(X,function(x) x$times[1:length(x$times)])
- ii<-max(floor(alpha/2*N)+1,1)
- jj<-min(ceiling((1-alpha/2)*N),N)
- low<-apply(LL,1,function(x) sort(x)[ii])
- high<-apply(LL,1,function(x) sort(x)[jj])
- ll<-if(mode=="median") apply(LL,1,function(x) median(x)[1]) else rowMeans(LL)
- obj<-cbind(c(1:n,n),low,ll,high)
- colnames(obj)<-c("lineages","low(time)","time","high(time)")
- rownames(obj)<-NULL
- } else if(method=="lineages"){
- N<-length(X)
- tt<-sapply(X,function(x) max(x$times))
- zz<-max(tt)-tt
- for(i in 1:N) X[[i]]$times<-X[[i]]$times+zz[i]
- tt<-0:res*max(tt)/res
- ll<-low<-high<-vector()
- for(i in 1:length(tt)){
- ss<-vector()
- for(j in 1:N){
- ii<-2
- while(tt[i]>X[[j]]$times[ii]&&ii<length(X[[j]]$times)) ii<-ii+1
- ss[j]<-X[[j]]$ltt[ii-1]
- }
- ll[i]<-if(mode=="median") median(ss) else mean(ss)
- low[i]<-sort(ss)[max(floor(alpha/2*N)+1,1)]
- high[i]<-sort(ss)[min(ceiling((1-alpha/2)*N),N)]
- }
- obj<-cbind(tt,low,ll,high)
- colnames(obj)<-c("time","low(lineages)","lineages","high(lineages)")
- rownames(obj)<-NULL
- }
- attr(obj,"class")<-"ltt95"
- attr(obj,"alpha")<-alpha
- attr(obj,"method")<-method
- attr(obj,"mode")<-mode
- attr(obj,"log")<-log
- if(plot) plot(obj,...)
- invisible(obj)
-}
-
-## S3 plotting method for objects of class 'ltt95'
-## written by Liam J. Revell 2014, 2019
-plot.ltt95<-function(x,...){
- if(hasArg(lend)) lend<-list(...)$lend
- else lend<-3
- old.lend<-par()$lend
- par(lend=lend)
- if(hasArg(log)) log<-list(...)$log
- else log<-attr(x,"log")
- if(hasArg(xaxis)) xaxis<-list(...)$xaxis
- else xaxis<-"standard"
- if(hasArg(shaded)) shaded<-list(...)$shaded
- else shaded<-FALSE
- if(shaded) bg<-if(hasArg(bg)) list(...)$bg else rgb(0,0,1,0.25)
- if(attr(x,"method")=="times"){
- n<-max(x[,1])
- if(xaxis=="negative"){
- x[,2:4]<-x[,2:4]-max(x[,2:4])
- }
- if(xaxis=="flipped"){
- x[,2:4]<-max(x[,2:4])-x[,2:4]
- x.lim<-c(max(x[,2:4]),min(x[,2:4]))
- } else x.lim<-range(x[,2:4])
- plot(x[,3],x[,1],lwd=2,xlim=x.lim,
- type=if(attr(x,"mode")=="median") "s" else "l",main=NULL,
- xlab=if(xaxis=="standard") "time from the oldest root" else
- if(xaxis=="negative") "time from the present" else
- if(xaxis=="flipped") "time before the present day",
- ylab="lineages",log=if(log) "y" else "")
- if(!shaded){
- lines(x[,2],x[,1],lty="dashed",type="s")
- lines(x[,4],x[,1],lty="dashed",type="s")
- } else {
- xx<-c(x[1,2],rbind(x[2:nrow(x),2],x[2:nrow(x),2]),
- rbind(x[nrow(x):2,4],x[nrow(x):2,4]),x[1,4])
- yy<-c(rbind(x[1:(nrow(x)-1),1],x[1:(nrow(x)-1),1]),x[nrow(x),1],
- x[nrow(x),1],rbind(x[(nrow(x)-1):1,1],x[(nrow(x)-1):1,1]))
- polygon(xx,yy,border=NA,col=bg)
- lines(x[,3],x[,1],lwd=2,
- type=if(attr(x,"mode")=="median") "s" else "l")
- }
- } else if(attr(x,"method")=="lineages"){
- if(xaxis=="negative") x[,1]<-x[,1]-max(x[,1])
- if(xaxis=="flipped"){
- x[,1]<-max(x[,1])-x[,1]
- x.lim<-c(max(x[,1]),min(x[,1]))
- } else x.lim<-range(x[,1])
- plot(x[,1],x[,3],xlim=x.lim,ylim=c(min(x[,2]),max(x[,4])),lwd=2,
- type=if(attr(x,"mode")=="median") "s" else "l",main=NULL,
- xlab=if(xaxis=="standard") "time from the oldest root" else
- if(xaxis=="negative") "time from the present" else
- if(xaxis=="flipped") "time before the present day",
- ylab="lineages",log=if(log) "y" else "")
- if(!shaded){
- lines(x[,1],x[,2],lty="dashed",type="s")
- lines(x[,1],x[,4],lty="dashed",type="s")
- } else {
- xx<-c(x[1,1],rbind(x[2:nrow(x),1],x[2:nrow(x),1]),
- rbind(x[nrow(x):2,1],x[nrow(x):2,1]),x[1,1])
- yy<-c(rbind(x[1:(nrow(x)-1),2],x[1:(nrow(x)-1),2]),x[nrow(x),2],
- x[nrow(x),4],rbind(x[(nrow(x)-1):1,4],x[(nrow(x)-1):1,4]))
- polygon(xx,yy,border=NA,col=bg)
- lines(x[,1],x[,3],lwd=2,
- type=if(attr(x,"mode")=="median") "s" else "l")
- }
- }
- par(lend=old.lend)
-}
-
-## S3 print method for object of class 'ltt95'
-## written by Liam J. Revell 2014
-print.ltt95<-function(x,...){
- cat("Object of class \"ltt95\".\n")
- cat(paste(" alpha:\t",round(attr(x,"alpha"),3),"\n",sep=""))
- cat(paste(" method:\t",attr(x,"method"),"\n",sep=""))
- cat(paste(" mode: \t",attr(x,"mode"),"\n",sep=""))
- n<-if(attr(x,"method")=="times") max(x[,1]) else range(apply(x[,2:4],2,max))
- if(length(n)==2&&n[1]==n[2]) n<-n[1]
- if(length(n)==1) cat(paste(" N(lineages):\t",n,"\n\n",sep=""))
- else cat(paste(" N(lineages):\t[",n[1],",",n[2],"]\n\n",sep=""))
-}
+# 95% CI on ltts
+# written by Liam J. Revell 2013, 2014, 2015, 2019
+
+ltt95<-function(trees,alpha=0.05,log=FALSE,method=c("lineages","times"),mode=c("median","mean"),...){
+ if(!inherits(trees,"multiPhylo")) stop("trees should be an object of class \"multiPhylo\".")
+ method<-method[1]
+ mode<-mode[1]
+ if(hasArg(res)) res<-list(...)$res
+ else res<-100
+ if(hasArg(plot)) plot<-list(...)$plot
+ else plot<-TRUE
+ X<-ltt(trees,plot=FALSE,gamma=FALSE)
+ if(method=="times"){
+ N<-length(X)
+ tt<-sapply(X,function(x) max(x$times))
+ zz<-max(tt)-tt
+ for(i in 1:N) X[[i]]$times<-X[[i]]$times+zz[i]
+ n<-sapply(X,function(x) max(x$ltt))
+ if(all(n==max(n))) n<-max(n)
+ else stop("for method=\"times\" all trees must contain the same number of lineages")
+ LL<-sapply(X,function(x) x$times[1:length(x$times)])
+ ii<-max(floor(alpha/2*N)+1,1)
+ jj<-min(ceiling((1-alpha/2)*N),N)
+ low<-apply(LL,1,function(x) sort(x)[ii])
+ high<-apply(LL,1,function(x) sort(x)[jj])
+ ll<-if(mode=="median") apply(LL,1,function(x) median(x)[1]) else rowMeans(LL)
+ obj<-cbind(c(1:n,n),low,ll,high)
+ colnames(obj)<-c("lineages","low(time)","time","high(time)")
+ rownames(obj)<-NULL
+ } else if(method=="lineages"){
+ N<-length(X)
+ tt<-sapply(X,function(x) max(x$times))
+ zz<-max(tt)-tt
+ for(i in 1:N) X[[i]]$times<-X[[i]]$times+zz[i]
+ tt<-0:res*max(tt)/res
+ ll<-low<-high<-vector()
+ for(i in 1:length(tt)){
+ ss<-vector()
+ for(j in 1:N){
+ ii<-2
+ while(tt[i]>X[[j]]$times[ii]&&ii<length(X[[j]]$times)) ii<-ii+1
+ ss[j]<-X[[j]]$ltt[ii-1]
+ }
+ ll[i]<-if(mode=="median") median(ss) else mean(ss)
+ low[i]<-sort(ss)[max(floor(alpha/2*N)+1,1)]
+ high[i]<-sort(ss)[min(ceiling((1-alpha/2)*N),N)]
+ }
+ obj<-cbind(tt,low,ll,high)
+ colnames(obj)<-c("time","low(lineages)","lineages","high(lineages)")
+ rownames(obj)<-NULL
+ }
+ attr(obj,"class")<-"ltt95"
+ attr(obj,"alpha")<-alpha
+ attr(obj,"method")<-method
+ attr(obj,"mode")<-mode
+ attr(obj,"log")<-log
+ if(plot) plot(obj,...)
+ invisible(obj)
+}
+
+## S3 plotting method for objects of class 'ltt95'
+## written by Liam J. Revell 2014, 2019
+plot.ltt95<-function(x,...){
+ if(hasArg(lend)) lend<-list(...)$lend
+ else lend<-3
+ old.lend<-par()$lend
+ par(lend=lend)
+ if(hasArg(log)) log<-list(...)$log
+ else log<-attr(x,"log")
+ if(hasArg(xaxis)) xaxis<-list(...)$xaxis
+ else xaxis<-"standard"
+ if(hasArg(shaded)) shaded<-list(...)$shaded
+ else shaded<-FALSE
+ if(shaded) bg<-if(hasArg(bg)) list(...)$bg else rgb(0,0,1,0.25)
+ if(attr(x,"method")=="times"){
+ n<-max(x[,1])
+ if(xaxis=="negative"){
+ x[,2:4]<-x[,2:4]-max(x[,2:4])
+ }
+ if(xaxis=="flipped"){
+ x[,2:4]<-max(x[,2:4])-x[,2:4]
+ x.lim<-c(max(x[,2:4]),min(x[,2:4]))
+ } else x.lim<-range(x[,2:4])
+ plot(x[,3],x[,1],lwd=2,xlim=x.lim,
+ type=if(attr(x,"mode")=="median") "s" else "l",main=NULL,
+ xlab=if(xaxis=="standard") "time from the oldest root" else
+ if(xaxis=="negative") "time from the present" else
+ if(xaxis=="flipped") "time before the present day",
+ ylab="lineages",log=if(log) "y" else "")
+ if(!shaded){
+ lines(x[,2],x[,1],lty="dashed",type="s")
+ lines(x[,4],x[,1],lty="dashed",type="s")
+ } else {
+ xx<-c(x[1,2],rbind(x[2:nrow(x),2],x[2:nrow(x),2]),
+ rbind(x[nrow(x):2,4],x[nrow(x):2,4]),x[1,4])
+ yy<-c(rbind(x[1:(nrow(x)-1),1],x[1:(nrow(x)-1),1]),x[nrow(x),1],
+ x[nrow(x),1],rbind(x[(nrow(x)-1):1,1],x[(nrow(x)-1):1,1]))
+ polygon(xx,yy,border=NA,col=bg)
+ lines(x[,3],x[,1],lwd=2,
+ type=if(attr(x,"mode")=="median") "s" else "l")
+ }
+ } else if(attr(x,"method")=="lineages"){
+ if(xaxis=="negative") x[,1]<-x[,1]-max(x[,1])
+ if(xaxis=="flipped"){
+ x[,1]<-max(x[,1])-x[,1]
+ x.lim<-c(max(x[,1]),min(x[,1]))
+ } else x.lim<-range(x[,1])
+ plot(x[,1],x[,3],xlim=x.lim,ylim=c(min(x[,2]),max(x[,4])),lwd=2,
+ type=if(attr(x,"mode")=="median") "s" else "l",main=NULL,
+ xlab=if(xaxis=="standard") "time from the oldest root" else
+ if(xaxis=="negative") "time from the present" else
+ if(xaxis=="flipped") "time before the present day",
+ ylab="lineages",log=if(log) "y" else "")
+ if(!shaded){
+ lines(x[,1],x[,2],lty="dashed",type="s")
+ lines(x[,1],x[,4],lty="dashed",type="s")
+ } else {
+ xx<-c(x[1,1],rbind(x[2:nrow(x),1],x[2:nrow(x),1]),
+ rbind(x[nrow(x):2,1],x[nrow(x):2,1]),x[1,1])
+ yy<-c(rbind(x[1:(nrow(x)-1),2],x[1:(nrow(x)-1),2]),x[nrow(x),2],
+ x[nrow(x),4],rbind(x[(nrow(x)-1):1,4],x[(nrow(x)-1):1,4]))
+ polygon(xx,yy,border=NA,col=bg)
+ lines(x[,1],x[,3],lwd=2,
+ type=if(attr(x,"mode")=="median") "s" else "l")
+ }
+ }
+ par(lend=old.lend)
+}
+
+## S3 print method for object of class 'ltt95'
+## written by Liam J. Revell 2014
+print.ltt95<-function(x,...){
+ cat("Object of class \"ltt95\".\n")
+ cat(paste(" alpha:\t",round(attr(x,"alpha"),3),"\n",sep=""))
+ cat(paste(" method:\t",attr(x,"method"),"\n",sep=""))
+ cat(paste(" mode: \t",attr(x,"mode"),"\n",sep=""))
+ n<-if(attr(x,"method")=="times") max(x[,1]) else range(apply(x[,2:4],2,max))
+ if(length(n)==2&&n[1]==n[2]) n<-n[1]
+ if(length(n)==1) cat(paste(" N(lineages):\t",n,"\n\n",sep=""))
+ else cat(paste(" N(lineages):\t[",n[1],",",n[2],"]\n\n",sep=""))
+}
diff --git a/R/make.era.map.R b/R/make.era.map.R
index a506d6d..9c99066 100644
--- a/R/make.era.map.R
+++ b/R/make.era.map.R
@@ -1,53 +1,53 @@
-# function creates a mapped tree in which the mappings are based on eras defined by "limits"
-# written by Liam J. Revell 2011, 2013, 2015
-
-make.era.map<-function(tree,limits,...){
- ## set tolerance
- if(hasArg(tol)) tol<-list(...)$tol
- else tol<-1e-5
- # check
- if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".")
- H<-nodeHeights(tree) # compute node heights
- if(limits[1]>tol){
- warning("first value in limits should be zero.")
- limits[1]<-0
- }
- while(limits[length(limits)]>max(H)){
- warning("last value in limits should be less than the total tree height.")
- limits<-limits[1:(length(limits)-1)]
- }
- if(is.null(names(limits))) names(limits)<-1:length(limits)
- limits[length(limits)+1]<-max(H)
- maps<-list()
- # ok, now go through the edges of the tree
- for(i in 1:nrow(tree$edge)){
- s<-1
- while((H[i,1]>=(limits[s]-tol)&&H[i,1]<limits[s+1])==FALSE) s<-s+1
- e<-1
- while((H[i,2]>limits[e]&&H[i,2]<=(limits[e+1]+tol))==FALSE) e<-e+1
- maps[[i]]<-vector()
- if(s==e){
- maps[[i]][1]<-tree$edge.length[i]
- names(maps[[i]])[1]<-names(limits)[s]
- } else {
- maps[[i]][1]<-limits[s+1]-H[i,1]
- for(j in (s+1):e)
- maps[[i]][j-s+1]<-limits[j+1]-limits[j]
- maps[[i]][e-s+1]<-H[i,2]-limits[e]
- names(maps[[i]])<-names(limits)[s:e]
- }
- }
- tree$maps<-maps
- # now construct the matrix "mapped.edge" (for backward compatibility)
- allstates<-vector()
- for(i in 1:nrow(tree$edge)) allstates<-c(allstates,names(tree$maps[[i]]))
- allstates<-unique(allstates)
- tree$mapped.edge<-matrix(data=0,length(tree$edge.length),length(allstates),
- dimnames=list(apply(tree$edge,1,function(x) paste(x,collapse=",")),
- state=allstates))
- for(i in 1:length(tree$maps)) for(j in 1:length(tree$maps[[i]]))
- tree$mapped.edge[i,names(tree$maps[[i]])[j]]<-tree$mapped.edge[i,
- names(tree$maps[[i]])[j]]+tree$maps[[i]][j]
- class(tree)<-c("simmap",setdiff(class(tree),"simmap"))
- tree
-}
+# function creates a mapped tree in which the mappings are based on eras defined by "limits"
+# written by Liam J. Revell 2011, 2013, 2015
+
+make.era.map<-function(tree,limits,...){
+ ## set tolerance
+ if(hasArg(tol)) tol<-list(...)$tol
+ else tol<-1e-5
+ # check
+ if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".")
+ H<-nodeHeights(tree) # compute node heights
+ if(limits[1]>tol){
+ warning("first value in limits should be zero.")
+ limits[1]<-0
+ }
+ while(limits[length(limits)]>max(H)){
+ warning("last value in limits should be less than the total tree height.")
+ limits<-limits[1:(length(limits)-1)]
+ }
+ if(is.null(names(limits))) names(limits)<-1:length(limits)
+ limits[length(limits)+1]<-max(H)
+ maps<-list()
+ # ok, now go through the edges of the tree
+ for(i in 1:nrow(tree$edge)){
+ s<-1
+ while((H[i,1]>=(limits[s]-tol)&&H[i,1]<limits[s+1])==FALSE) s<-s+1
+ e<-1
+ while((H[i,2]>limits[e]&&H[i,2]<=(limits[e+1]+tol))==FALSE) e<-e+1
+ maps[[i]]<-vector()
+ if(s==e){
+ maps[[i]][1]<-tree$edge.length[i]
+ names(maps[[i]])[1]<-names(limits)[s]
+ } else {
+ maps[[i]][1]<-limits[s+1]-H[i,1]
+ for(j in (s+1):e)
+ maps[[i]][j-s+1]<-limits[j+1]-limits[j]
+ maps[[i]][e-s+1]<-H[i,2]-limits[e]
+ names(maps[[i]])<-names(limits)[s:e]
+ }
+ }
+ tree$maps<-maps
+ # now construct the matrix "mapped.edge" (for backward compatibility)
+ allstates<-vector()
+ for(i in 1:nrow(tree$edge)) allstates<-c(allstates,names(tree$maps[[i]]))
+ allstates<-unique(allstates)
+ tree$mapped.edge<-matrix(data=0,length(tree$edge.length),length(allstates),
+ dimnames=list(apply(tree$edge,1,function(x) paste(x,collapse=",")),
+ state=allstates))
+ for(i in 1:length(tree$maps)) for(j in 1:length(tree$maps[[i]]))
+ tree$mapped.edge[i,names(tree$maps[[i]])[j]]<-tree$mapped.edge[i,
+ names(tree$maps[[i]])[j]]+tree$maps[[i]][j]
+ class(tree)<-c("simmap",setdiff(class(tree),"simmap"))
+ tree
+}
diff --git a/R/make.simmap.R b/R/make.simmap.R
index ad72dde..14b7d59 100644
--- a/R/make.simmap.R
+++ b/R/make.simmap.R
@@ -1,550 +1,612 @@
-## function creates a stochastic character mapped tree as a modified "phylo" object
-## written by Liam Revell 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021, 2022
-
-make.simmap<-function(tree,x,model="SYM",nsim=1,...){
- if(inherits(tree,"multiPhylo")){
- ff<-function(yy,x,model,nsim,...){
- zz<-make.simmap(yy,x,model,nsim,...)
- if(nsim>1) class(zz)<-NULL
- return(zz)
- }
- if(nsim>1) mtrees<-unlist(sapply(tree,ff,x,model,nsim,...,simplify=FALSE),recursive=FALSE)
- else mtrees<-sapply(tree,ff,x,model,nsim,...,simplify=FALSE)
- class(mtrees)<-c("multiSimmap","multiPhylo")
- } else {
- ## get optional arguments
- if(hasArg(pi)) pi<-list(...)$pi
- else pi<-"equal"
- if(hasArg(message)) pm<-list(...)$message
- else pm<-TRUE
- if(hasArg(tol)) tol<-list(...)$tol
- else tol<-0
- if(hasArg(Q)) Q<-list(...)$Q
- else Q<-"empirical"
- if(hasArg(burnin)) burnin<-list(...)$burnin
- else burnin<-1000
- if(hasArg(samplefreq)) samplefreq<-list(...)$samplefreq
- else samplefreq<-100
- if(hasArg(vQ)) vQ<-list(...)$vQ
- else vQ<-0.1
- prior<-list(alpha=1,beta=1,use.empirical=FALSE)
- if(hasArg(prior)){
- pr<-list(...)$prior
- prior[names(pr)]<-pr
- }
- ## done optional arguments
- # check
- if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".")
- # if vector convert to binary matrix
- if(!is.matrix(x)) xx<-to.matrix(x,sort(unique(x)))
- else xx<-x
- xx<-xx[tree$tip.label,]
- xx<-xx/rowSums(xx)
- # reorder to cladewise
- tree<-bt<-reorder.phylo(tree,"cladewise")
- if(!is.binary(bt)) bt<-multi2di(bt,random=FALSE)
- # some preliminaries
- N<-Ntip(tree)
- m<-ncol(xx)
- root<-N+1
- # get conditional likelihoods & model
- if(is.character(Q)&&Q=="empirical"){
- XX<-getPars(bt,xx,model,Q=NULL,tree,tol,m,pi=pi,args=list(...))
- L<-XX$L
- Q<-XX$Q
- logL<-XX$loglik
- pi<-XX$pi
- if(pi[1]=="equal") pi<-setNames(rep(1/m,m),colnames(L)) # set equal
- else if(pi[1]=="estimated") pi<-statdist(Q) # set from stationary distribution
- else if(pi[1]=="fitzjohn") pi<-"fitzjohn"
- else pi<-pi/sum(pi) # obtain from input
- if(pm) printmessage(Q,pi,method="empirical")
- mtrees<-replicate(nsim,smap(tree,x,N,m,root,L,Q,pi,logL),simplify=FALSE)
- } else if(is.character(Q)&&Q=="mcmc"){
- if(prior$use.empirical){
- qq<-fitMk(bt,xx,model)$rates
- prior$alpha<-qq*prior$beta
- }
- get.stationary<-if(pi[1]=="estimated") TRUE else FALSE
- if(pi[1]%in%c("equal","estimated"))
- pi<-setNames(rep(1/m,m),colnames(xx)) # set equal
- else if(pi[1]=="fitzjohn") pi<-"fitzjohn"
- else pi<-pi/sum(pi) # obtain from input
- XX<-mcmcQ(bt,xx,model,tree,tol,m,burnin,samplefreq,nsim,vQ,prior,pi=pi)
- L<-lapply(XX,function(x) x$L)
- Q<-lapply(XX,function(x) x$Q)
- logL<-lapply(XX,function(x) x$loglik)
- pi<-if(get.stationary) lapply(Q,statdist) else
- if(pi[1]=="fitzjohn") lapply(XX,function(x) x$pi) else
- lapply(1:nsim,function(x,y) y,y=pi)
- if(pm) printmessage(Reduce('+',Q)/length(Q),Reduce('+',pi)/length(pi),
- method="mcmc")
- mtrees<-if(nsim>1) mapply(smap,L=L,Q=Q,pi=pi,logL=logL,MoreArgs=
- list(tree=tree,x=x,N=N,m=m,root=root),SIMPLIFY=FALSE) else
- list(smap(tree=tree,x=x,N=N,m=m,root=root,L=L[[1]],Q=Q[[1]],pi=pi[[1]],
- logL=logL[[1]]))
- } else if(is(Q,"Qmatrix")||is.matrix(Q)){
- if(is(Q,"Qmatrix")) Q<-unclass(Q)
- XX<-getPars(bt,xx,model,Q=Q,tree,tol,m,pi=pi,args=list(...))
- L<-XX$L
- logL<-XX$loglik
- pi<-XX$pi
- if(pi[1]=="equal") pi<-setNames(rep(1/m,m),colnames(L)) # set equal
- else if(pi[1]=="estimated") pi<-statdist(Q) # set from stationary distribution
- else if(pi[1]=="fitzjohn") pi<-"fitzjohn"
- else pi<-pi/sum(pi) # obtain from input
- if(pm) printmessage(Q,pi,method="fixed")
- mtrees<-replicate(nsim,smap(tree,x,N,m,root,L,Q,pi,logL),simplify=FALSE)
- }
- if(length(mtrees)==1) mtrees<-mtrees[[1]]
- else class(mtrees)<-c("multiSimmap","multiPhylo")
- }
- (if(hasArg(message)) list(...)$message else TRUE)
- if((if(hasArg(message)) list(...)$message else TRUE)&&inherits(tree,"phylo")) message("Done.")
- return(mtrees)
-}
-
-# print message
-# written by Liam J. Revell 2013
-printmessage<-function(Q,pi,method){
- if(method=="empirical"||method=="fixed")
- cat("make.simmap is sampling character histories conditioned on\nthe transition matrix\n\nQ =\n")
- else if(method=="mcmc"){
- cat("make.simmap is simulating with a sample of Q from\nthe posterior distribution\n")
- cat("\nMean Q from the posterior is\nQ =\n")
- }
- print(Q)
- if(method=="empirical") cat("(estimated using likelihood);\n")
- else if(method=="fixed") cat("(specified by the user);\n")
- cat("and (mean) root node prior probabilities\npi =\n")
- if(is.list(pi)) pi<-Reduce("+",pi)/length(pi)
- print(pi)
- flush.console()
-}
-
-# mcmc for Q used in Q="mcmc"
-# written by Liam J. Revell 2013
-mcmcQ<-function(bt,xx,model,tree,tol,m,burnin,samplefreq,nsim,vQ,prior,pi,args=list()){
- update<-function(x){
- x<-abs(x+rnorm(n=np,mean=0,sd=sqrt(vQ)))
- return(x)
- }
- # get model matrix
- if(is.character(model)){
- rate<-matrix(NA,m,m)
- if(model=="ER"){
- np<-rate[]<-1
- diag(rate)<-NA
- }
- if(model=="ARD"){
- np<-m*(m-1)
- rate[col(rate)!=row(rate)]<-1:np
- }
- if(model=="SYM") {
- np<-m*(m-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)!=m)
- stop("the matrix 'model' must have as many rows as the number of categories in 'x'")
- rate<-model
- np<-max(rate)
- }
- # burn-in
- p<-rgamma(np,prior$alpha,prior$beta)
- Q<-matrix(c(0,p)[rate+1],m,m)
- diag(Q)<--rowSums(Q,na.rm=TRUE)
- yy<-getPars(bt,xx,model,Q,tree,tol,m,pi=pi,args=args)
- cat("Running MCMC burn-in. Please wait....\n")
- flush.console()
- for(i in 1:burnin){
- pp<-update(p)
- Qp<-matrix(c(0,pp)[rate+1],m,m)
- diag(Qp)<--rowSums(Qp,na.rm=TRUE)
- zz<-getPars(bt,xx,model,Qp,tree,tol,m,FALSE,pi=pi,args)
- p.odds<-exp(zz$loglik+sum(dgamma(pp,prior$alpha,prior$beta,log=TRUE))-
- yy$loglik-sum(dgamma(p,prior$alpha,prior$beta,log=TRUE)))
- if(p.odds>=runif(n=1)){
- yy<-zz
- p<-pp
- }
- }
- # now run MCMC generation, sampling at samplefreq
- cat(paste("Running",samplefreq*nsim,"generations of MCMC, sampling every",samplefreq,"generations.\nPlease wait....\n\n"))
- flush.console()
- XX<-vector("list",nsim)
- for(i in 1:(samplefreq*nsim)){
- pp<-update(p)
- Qp<-matrix(c(0,pp)[rate+1],m,m)
- diag(Qp)<--rowSums(Qp,na.rm=TRUE)
- zz<-getPars(bt,xx,model,Qp,tree,tol,m,FALSE,pi=pi,args)
- p.odds<-exp(zz$loglik+sum(dgamma(pp,prior$alpha,prior$beta,log=TRUE))-
- yy$loglik-sum(dgamma(p,prior$alpha,prior$beta,log=TRUE)))
- if(p.odds>=runif(n=1)){
- yy<-zz
- p<-pp
- }
- if(i%%samplefreq==0){
- Qi<-matrix(c(0,p)[rate+1],m,m)
- diag(Qi)<--rowSums(Qi,na.rm=TRUE)
- XX[[i/samplefreq]]<-getPars(bt,xx,model,Qi,tree,tol,m,TRUE,pi=pi,args)
- }
- }
- return(XX)
-}
-
-# get pars
-# written by Liam J. Revell 2013, 2017, 2021
-getPars<-function(bt,xx,model,Q,tree,tol,m,liks=TRUE,pi,args=list()){
- if(!is.null(args$pi)) args$pi<-NULL
- args<-c(list(tree=bt,x=xx,model=model,fixedQ=Q,output.liks=liks,pi=pi),args)
- obj<-do.call(fitMk,args)
- N<-length(bt$tip.label)
- pi<-obj$pi
- II<-obj$index.matrix+1
- lvls<-obj$states
- if(liks){
- L<-obj$lik.anc
- rownames(L)<-N+1:nrow(L)
- if(!is.binary(tree)){
- ancNames<-matchNodes(tree,bt)
- L<-L[as.character(ancNames[,2]),]
- rownames(L)<-ancNames[,1]
- }
- L<-rbind(xx,L)
- rownames(L)[1:N]<-1:N
- } else L<-NULL
- Q<-matrix(c(0,obj$rates)[II],m,m,dimnames=list(lvls,lvls))
- if(any(rowSums(Q,na.rm=TRUE)<tol)){
- message(paste("\nWarning: some rows of Q not numerically distinct from 0; setting to",tol,"\n"))
- ii<-which(rowSums(Q,na.rm=TRUE)<tol)
- for(i in 1:length(ii)) Q[ii[i],setdiff(1:ncol(Q),ii[i])]<-tol/(ncol(Q)-1)
- }
- diag(Q)<--rowSums(Q,na.rm=TRUE)
- return(list(Q=Q,L=L,loglik=logLik(obj),pi=pi))
-}
-
-# convert vector of x to binary matrix
-# written by Liam J. Revell 2012
-to.matrix<-function(x,seq){
- X<-matrix(0,length(x),length(seq),dimnames=list(names(x),seq))
- for(i in 1:length(seq)) X[x==seq[i],i]<-1
- return(X)
-}
-
-## function does the stochastic mapping, conditioned on our model & given the conditional likelihoods
-## written by Liam J. Revell 2013, 2017
-smap<-function(tree,x,N,m,root,L,Q,pi,logL){
- # create the map tree object
- mtree<-tree
- mtree$maps<-list()
- mtree$mapped.edge<-matrix(0,nrow(tree$edge),m,dimnames=list(paste(tree$edge[,1],",",
- tree$edge[,2],sep=""),colnames(L)))
- # now we want to simulate the node states & histories by pre-order traversal
- NN<-matrix(NA,nrow(tree$edge),2) # our node values
- NN[which(tree$edge[,1]==root),1]<-rstate(L[as.character(root),]/
- sum(L[as.character(root),])) # assign root
- for(j in 1:nrow(tree$edge)){
- # conditioned on the start value, assign end value of node (if internal)
- p<-EXPM(Q*tree$edge.length[j])[NN[j,1],]*L[as.character(tree$edge[j,2]),]
- NN[j,2]<-rstate(p/sum(p))
- NN[which(tree$edge[,1]==tree$edge[j,2]),1]<-NN[j,2]
- # now simulate on the branches
- accept<-FALSE
- while(!accept){
- map<-sch(NN[j,1],tree$edge.length[j],Q)
- if(names(map)[length(map)]==NN[j,2]) accept=TRUE
- }
- mtree$maps[[j]]<-map
- for(k in 1:length(mtree$maps[[j]]))
- mtree$mapped.edge[j,names(mtree$maps[[j]])[k]]<-mtree$mapped.edge[j,
- names(mtree$maps[[j]])[k]]+mtree$maps[[j]][k]
- }
- mtree$Q<-Q
- mtree$logL<-logL
- if(!inherits(mtree,"simmap")) class(mtree)<-c("simmap",setdiff(class(mtree),
- "simmap"))
- attr(mtree,"map.order")<-"right-to-left"
- return(mtree)
-}
-
-# function generates a history along a branch
-# written by Liam J. Revell 2013
-sch<-function(start,t,Q){
- tol<-t*1e-12
- dt<-setNames(0,start)
- while(sum(dt)<(t-tol)){
- s<-names(dt)[length(dt)]
- dt[length(dt)]<-if(-Q[s,s]>0) rexp(n=1,rate=-Q[s,s]) else t-sum(dt)
- if(sum(dt)<(t-tol)){
- dt<-c(dt,0)
- if(sum(Q[s,][-match(s,colnames(Q))])>0)
- names(dt)[length(dt)]<-rstate(Q[s,][-match(s,colnames(Q))]/sum(Q[s,][-match(s,colnames(Q))]))
- else names(dt)[length(dt)]<-s
- } else dt[length(dt)]<-dt[length(dt)]-sum(dt)+t
- }
- return(dt)
-}
-
-# function uses numerical optimization to solve for the stationary distribution
-# written by Liam J. Revell 2013
-statdist<-function(Q){
- foo<-function(theta,Q){
- Pi<-c(theta[1:(nrow(Q)-1)],1-sum(theta[1:(nrow(Q)-1)]))
- sum((Pi%*%Q)^2)
- }
- k<-nrow(Q)
- if(nrow(Q)>2){
- fit<-optim(rep(1/k,k-1),foo,Q=Q,control=list(reltol=1e-16))
- return(setNames(c(fit$par[1:(k-1)],1-sum(fit$par[1:(k-1)])),rownames(Q)))
- } else {
- fit<-optimize(foo,interval=c(0,1),Q=Q)
- return(setNames(c(fit$minimum,1-fit$minimum),rownames(Q)))
- }
-}
-
-## S3 print method for objects of class "simmap" & multiSimmap
-## based on print.phylo in ape
-print.simmap<-function(x,printlen=6,...){
- N<-Ntip(x)
- M<-x$Nnode
- cat(paste("\nPhylogenetic tree with",N,"tips and",M,"internal nodes.\n\n"))
- cat("Tip labels:\n")
- if(N>printlen) cat(paste("\t",paste(x$tip.label[1:printlen],collapse=", "),", ...\n",sep=""))
- else print(x$tip.label)
- ss<-sort(unique(c(getStates(x,"tips"),getStates(x,"nodes"))))
- cat(paste("\nThe tree includes a mapped, ",length(ss),"-state discrete character\nwith states:\n",
- sep=""))
- if(length(ss)>printlen) cat(paste("\t",paste(ss[1:printlen],collapse=", "),", ...\n",sep=""))
- else cat(paste("\t",paste(ss,collapse=", "),"\n",sep=""))
- rlab<-if(is.rooted(x)) "Rooted" else "Unrooted"
- cat("\n",rlab,"; includes branch lengths.\n",sep="")
-}
-print.multiSimmap<-function(x,details=FALSE,...){
- N<-length(x)
- cat(N,"phylogenetic trees with mapped discrete characters\n")
- if(details){
- n<-sapply(x,Ntip)
- s<-sapply(x,function(x) length(unique(c(getStates(x,"tips"),getStates(x,"nodes")))))
- for(i in 1:N) cat("tree",i,":",n[i],"tips,",s[i],"mapped states\n")
- }
-}
-
-## S3 summary method for objects of class "simmap" & "multiSimmap"
-summary.simmap<-function(object,...) describe.simmap(object,...)
-summary.multiSimmap<-function(object,...) describe.simmap(object,...)
-
-## for backward compatibility with any function using apeAce internally
-apeAce<-function(tree,x,model,fixedQ=NULL,...){
- if(hasArg(output.liks)){
- output.liks<-list(...)$output.liks
- return(fitMk(tree,x,model,fixedQ,...))
- } else {
- output.liks<-TRUE
- return(fitMk(tree,x,model,fixedQ,output.liks=TRUE,...))
- }
-}
-
-## S3 logLik methods for "simmap" & "multiSimmap"
-logLik.simmap<-function(object,...) object$logL
-logLik.multiSimmap<-function(object,...)
- sapply(object,function(x) x$logL)
-
-## S3 density method for "multiSimmap"
-density.multiSimmap<-function(x,...){
- if(hasArg(method)) method<-list(...)$method
- else method<-"changes"
- if(!method%in%c("densityMap","changes")){
- cat("method not recognized. Setting to default method.\n\n")
- method<-"changes"
- }
- if(method=="densityMap") obj<-densityMap(x,plot=FALSE,...)
- else if(method=="changes"){
- if(hasArg(bw)) bw<-list(...)$bw
- else bw<-1
- tmp<-summary(x)
- ab<-lapply(2:ncol(tmp$count),function(i,x) x[,i],x=tmp$count)
- names(ab)<-sapply(strsplit(colnames(tmp$count)[2:ncol(tmp$count)],
- ","),function(x) paste(x,collapse="->"))
- ab<-lapply(ab,function(x){
- class(x)<-"mcmc"
- x })
- if(.check.pkg("coda")){
- hpd.ab<-lapply(ab,HPDinterval)
- } else {
- cat(" HPDinterval requires package coda.\n")
- cat(" Computing 95% interval from samples only.\n\n")
- hpd95<-function(x){
- obj<-setNames(c(sort(x)[round(0.025*length(x))],
- sort(x)[round(0.975*length(x))]),
- c("lower","upper"))
- attr(obj,"Probability")<-0.95
- obj
- }
- hpd.ab<-lapply(ab,hpd95)
- }
- minmax<-range(unlist(ab))
- pcalc<-function(x,mm)
- hist(x,breaks=seq(mm[1]-1.5,mm[2]+1.5,bw),plot=FALSE)
- p.ab<-lapply(ab,pcalc,mm=minmax)
- states<-colnames(tmp$ace)
- trans<-names(ab)
- obj<-list(hpd=hpd.ab,
- p=p.ab,
- states=states,trans=trans,
- bw=bw,
- mins=sapply(ab,min),
- meds=sapply(ab,median),
- means=sapply(ab,mean),
- maxs=sapply(ab,max))
- class(obj)<-"changesMap"
- }
- else if(method=="timings"){
- cat("This method doesn't work yet.\n")
- obj<-NULL
- }
- obj
-}
-
-## S3 plot method for "changesMap" object from density.multiSimmap
-plot.changesMap<-function(x,...){
- if(hasArg(bty)) bty<-list(...)$bty
- else bty<-"l"
- if(hasArg(alpha)) alpha<-list(...)$alpha
- else alpha<-0.3
- if(hasArg(colors)){
- colors<-list(...)$colors
- nn<-names(colors)
- colors<-setNames(make.transparent(colors,alpha),nn)
- } else {
- colors<-if(length(x$trans)==2)
- setNames(make.transparent(c("blue","red"),alpha),x$trans)
- else
- setNames(rep(make.transparent("blue",alpha),length(x$trans)),
- x$trans)
- }
- if(length(colors)<length(x$trans))
- colors<-rep(colors,ceiling(length(x$trans)/length(colors)))[1:length(x$trans)]
- if(is.null(names(colors))) colors<-setNames(colors,x$trans)
- if(hasArg(transition)){
- transition<-list(...)$transition
- if(length(transition)>1){
- cat("transition should be of length 1; truncating to first element.\n")
- transition<-transition[1]
- }
- } else transition<-NULL
- p<-x$p
- hpd<-x$hpd
- bw<-x$bw
- if(length(x$trans)==2&&is.null(transition)){
- plot(p[[1]]$mids,p[[1]]$density,xlim=c(min(x$mins)-1,
- max(x$maxs)+1),ylim=c(0,1.2*max(c(p[[1]]$density,
- p[[2]]$density))),
- type="n",xlab="number of changes",
- ylab="relative frequency across stochastic maps",
- bty=bty)
- y2<-rep(p[[1]]$density,each=2)
- y2<-y2[-length(y2)]
- x2<-rep(p[[1]]$mids-bw/2,each=2)[-1]
- x3<-c(min(x2),x2,max(x2))
- y3<-c(0,y2,0)
- polygon(x3,y3,col=colors[x$trans[1]],border=FALSE)
- lines(p[[1]]$mids-bw/2,p[[1]]$density,type="s")
- y2<-rep(p[[2]]$density,each=2)
- y2<-y2[-length(y2)]
- x2<-rep(p[[2]]$mids-bw/2,each=2)[-1]
- x3<-c(min(x2),x2,max(x2))
- y3<-c(0,y2,0)
- polygon(x3,y3,col=colors[x$trans[2]],border=FALSE)
- lines(p[[2]]$mids-bw/2,p[[2]]$density,type="s")
- dd<-0.01*diff(par()$usr[3:4])
- lines(hpd[[1]],rep(max(p[[1]]$density)+dd,2))
- lines(rep(hpd[[1]][1],2),c(max(p[[1]]$density)+dd,
- max(p[[1]]$density)+dd-0.005))
- lines(rep(hpd[[1]][2],2),c(max(p[[1]]$density)+dd,
- max(p[[1]]$density)+dd-0.005))
- CHARS<-strsplit(x$trans[1],"->")[[1]]
- CHARS[1]<-paste("HPD(",CHARS[1],collapse="")
- CHARS[2]<-paste(CHARS[2],")",collapse="")
- T1<-bquote(.(CHARS[1])%->%.(CHARS[2]))
- text(mean(hpd[[1]]),max(p[[1]]$density)+dd,
- T1,pos=3)
- lines(hpd[[2]],rep(max(p[[2]]$density)+dd,2))
- lines(rep(hpd[[2]][1],2),c(max(p[[2]]$density)+dd,
- max(p[[2]]$density)+dd-0.005))
- lines(rep(hpd[[2]][2],2),c(max(p[[2]]$density)+dd,
- max(p[[2]]$density)+dd-0.005))
- CHARS<-strsplit(x$trans[2],"->")[[1]]
- CHARS[1]<-paste("HPD(",CHARS[1],collapse="")
- CHARS[2]<-paste(CHARS[2],")",collapse="")
- T2<-bquote(.(CHARS[1])%->%.(CHARS[2]))
- text(mean(hpd[[2]]),max(p[[2]]$density)+dd,
- T2,pos=3)
- CHARS<-strsplit(x$trans[1],"->")[[1]]
- T1<-bquote(.(CHARS[1])%->%.(CHARS[2]))
- CHARS<-strsplit(x$trans[2],"->")[[1]]
- T2<-bquote(.(CHARS[1])%->%.(CHARS[2]))
- legend("topleft",legend=c(T1,T2),pch=22,pt.cex=2.2,bty="n",
- pt.bg=colors[x$trans])
- } else {
- k<-if(is.null(transition)) length(x$states) else 1
- if(k>1) par(mfrow=c(k,k))
- ii<-if(is.null(transition)) 1 else which(x$trans==transition)
- max.d<-max(unlist(lapply(p,function(x) x$density)))
- for(i in 1:k){
- for(j in 1:k){
- if(i==j&&is.null(transition)) plot.new()
- else {
- CHARS<-strsplit(x$trans[ii],"->")[[1]]
- MAIN<-bquote(.(CHARS[1])%->%.(CHARS[2]))
- plot(p[[ii]]$mids,p[[ii]]$density,xlim=c(min(x$mins)-1,
- max(x$maxs)+1),ylim=c(0,1.2*max.d),
- type="n",xlab="number of changes",
- ylab="relative frequency",main=MAIN,font.main=1,
- bty=bty)
- y2<-rep(p[[ii]]$density,each=2)
- y2<-y2[-length(y2)]
- x2<-rep(p[[ii]]$mids-bw/2,each=2)[-1]
- x3<-c(min(x2),x2,max(x2))
- y3<-c(0,y2,0)
- polygon(x3,y3,col=colors[x$trans[ii]],border=FALSE)
- lines(p[[ii]]$mids-bw/2,p[[ii]]$density,type="s")
- dd<-0.03*diff(par()$usr[3:4])
- lines(hpd[[ii]],rep(max(p[[ii]]$density)+dd,2))
- text(mean(hpd[[ii]]),max(p[[ii]]$density)+dd,"HPD",pos=3)
- ii<-ii+1
- }
- }
- }
- }
-}
-
-print.changesMap<-function(x, ...){
- if(hasArg(signif)) signif<-list(...)$signif
- else signif<-2
- cat("\nDistribution of changes from stochastic mapping:\n")
- NROW<-ceiling(length(x$trans)/2)
- if(NROW>1) cat("\n")
- for(i in 1:NROW){
- ii<-2*i-1
- jj<-ii+1
- cat(paste("\t",x$trans[ii],"\t\t",x$trans[jj],"\n",sep=""))
- cat(paste("\tMin. :",round(x$mins[ii],signif),
- "\tMin. :",round(x$mins[jj],signif),"\n",sep=""))
- cat(paste("\tMedian :",round(x$meds[ii],signif),
- "\tMedian :",round(x$meds[jj],signif),"\n",sep=""))
- cat(paste("\tMean :",round(x$means[ii],signif),
- "\tMean :",round(x$means[jj],signif),"\n",sep=""))
- cat(paste("\tMax. :",round(x$maxs[ii],signif),
- "\tMax. :",round(x$maxs[jj],signif),"\n\n",sep=""))
- }
- for(i in 1:length(x$trans))
- cat("95% HPD interval(",x$trans[i],"): [",x$hpd[[i]][1],", ",
- x$hpd[[i]][2],"]\n",sep="")
- cat("\n")
-}
-
+## function creates a stochastic character mapped tree as a modified "phylo" object
+## written by Liam Revell 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021, 2022, 2023
+
+## S3 method for Mk models of various classes
+
+simmap<-function(object,...) UseMethod("simmap")
+
+simmap.default<-function(object,...){
+ warning(paste(
+ "simmap does not know how to handle objects of class ",
+ class(object),".\n"))
+}
+
+simmap.fitpolyMk<-function(object,...) simmap.fitMk(object,...)
+
+simmap.fitMk<-function(object,...){
+ args<-list(...)
+ args$tree<-object$tree
+ args$x<-object$data
+ args$Q<-as.Qmatrix(object)
+ args$pi<-if(object$root.prior=="fitzjohn")
+ "fitzjohn" else object$pi
+ if(is.null(args$nsim)) args$nsim<-100
+ if(hasArg(trace)) trace<-list(...)$trace
+ else trace<-0
+ if(trace>0) args$message<-TRUE
+ else args$message<-FALSE
+ do.call(make.simmap,args)
+}
+
+simmap.anova.fitMk<-function(object,...){
+ if(hasArg(weighted)) weighted<-list(...)$weighted
+ else weighted<-TRUE
+ if(hasArg(nsim)) nsim<-list(...)$nsim
+ else nsim<-100
+ if(weighted){
+ w<-object$weight
+ mods<-sample(1:length(w),size=nsim,replace=TRUE,prob=w)
+ } else {
+ best<-which(object$AIC==min(object$AIC))
+ mods<-sample(best,size=nsim,replace=TRUE)
+ }
+ fits<-attr(object,"models")[mods]
+ foo<-function(obj,args){
+ args$object<-obj
+ do.call(simmap,args)
+ }
+ args<-list(...)
+ args$nsim<-1
+ tt<-lapply(fits,foo,args=args)
+ class(tt)<-c("multiSimmap","multiPhylo")
+ return(tt)
+}
+
+make.simmap<-function(tree,x,model="SYM",nsim=1,...){
+ if(inherits(tree,"multiPhylo")){
+ ff<-function(yy,x,model,nsim,...){
+ zz<-make.simmap(yy,x,model,nsim,...)
+ if(nsim>1) class(zz)<-NULL
+ return(zz)
+ }
+ if(nsim>1){
+ mtrees<-unlist(sapply(tree,ff,x,model,nsim,...,simplify=FALSE),
+ recursive=FALSE)
+ } else mtrees<-sapply(tree,ff,x,model,nsim,...,simplify=FALSE)
+ class(mtrees)<-c("multiSimmap","multiPhylo")
+ } else {
+ ## get optional arguments
+ if(hasArg(pi)) pi<-list(...)$pi
+ else pi<-"equal"
+ if(hasArg(message)) pm<-list(...)$message
+ else pm<-TRUE
+ if(hasArg(tol)) tol<-list(...)$tol
+ else tol<-0
+ if(hasArg(Q)) Q<-list(...)$Q
+ else Q<-"empirical"
+ if(hasArg(burnin)) burnin<-list(...)$burnin
+ else burnin<-1000
+ if(hasArg(samplefreq)) samplefreq<-list(...)$samplefreq
+ else samplefreq<-100
+ if(hasArg(vQ)) vQ<-list(...)$vQ
+ else vQ<-0.1
+ prior<-list(alpha=1,beta=1,use.empirical=FALSE)
+ if(hasArg(prior)){
+ pr<-list(...)$prior
+ prior[names(pr)]<-pr
+ }
+ ## done optional arguments
+ # check
+ if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".")
+ # if vector convert to binary matrix
+ if(!is.matrix(x)) xx<-to.matrix(x,sort(unique(x)))
+ else xx<-x
+ xx<-xx[tree$tip.label,]
+ xx<-xx/rowSums(xx)
+ # reorder to cladewise
+ tree<-bt<-reorder.phylo(tree,"cladewise")
+ if(!is.binary(bt)) bt<-multi2di(bt,random=FALSE)
+ # some preliminaries
+ N<-Ntip(tree)
+ m<-ncol(xx)
+ root<-N+1
+ # get conditional likelihoods & model
+ if(is.character(Q)&&Q=="empirical"){
+ XX<-getPars(bt,xx,model,Q=NULL,tree,tol,m,pi=pi,args=list(...))
+ L<-XX$L
+ Q<-XX$Q
+ logL<-XX$loglik
+ pi<-XX$pi
+ if(pi[1]=="equal") pi<-setNames(rep(1/m,m),colnames(L)) # set equal
+ else if(pi[1]=="estimated") pi<-statdist(Q) # set from stationary distribution
+ else if(pi[1]=="fitzjohn") pi<-"fitzjohn"
+ else pi<-pi/sum(pi) # obtain from input
+ if(pm) printmessage(Q,pi,method="empirical")
+ mtrees<-replicate(nsim,smap(tree,x,N,m,root,L,Q,pi,logL),simplify=FALSE)
+ } else if(is.character(Q)&&Q=="mcmc"){
+ if(prior$use.empirical){
+ qq<-fitMk(bt,xx,model)$rates
+ prior$alpha<-qq*prior$beta
+ }
+ get.stationary<-if(pi[1]=="estimated") TRUE else FALSE
+ if(pi[1]%in%c("equal","estimated"))
+ pi<-setNames(rep(1/m,m),colnames(xx)) # set equal
+ else if(pi[1]=="fitzjohn") pi<-"fitzjohn"
+ else pi<-pi/sum(pi) # obtain from input
+ XX<-mcmcQ(bt,xx,model,tree,tol,m,burnin,samplefreq,nsim,vQ,prior,pi=pi)
+ L<-lapply(XX,function(x) x$L)
+ Q<-lapply(XX,function(x) x$Q)
+ logL<-lapply(XX,function(x) x$loglik)
+ pi<-if(get.stationary) lapply(Q,statdist) else
+ if(pi[1]=="fitzjohn") lapply(XX,function(x) x$pi) else
+ lapply(1:nsim,function(x,y) y,y=pi)
+ if(pm) printmessage(Reduce('+',Q)/length(Q),Reduce('+',pi)/length(pi),
+ method="mcmc")
+ mtrees<-if(nsim>1) mapply(smap,L=L,Q=Q,pi=pi,logL=logL,MoreArgs=
+ list(tree=tree,x=x,N=N,m=m,root=root),SIMPLIFY=FALSE) else
+ list(smap(tree=tree,x=x,N=N,m=m,root=root,L=L[[1]],Q=Q[[1]],pi=pi[[1]],
+ logL=logL[[1]]))
+ } else if(is(Q,"Qmatrix")||is.matrix(Q)){
+ if(is(Q,"Qmatrix")) Q<-unclass(Q)
+ XX<-getPars(bt,xx,model,Q=Q,tree,tol,m,pi=pi,args=list(...))
+ L<-XX$L
+ logL<-XX$loglik
+ pi<-XX$pi
+ if(pi[1]=="equal") pi<-setNames(rep(1/m,m),colnames(L)) # set equal
+ else if(pi[1]=="estimated") pi<-statdist(Q) # set from stationary distribution
+ else if(pi[1]=="fitzjohn") pi<-"fitzjohn"
+ else pi<-pi/sum(pi) # obtain from input
+ if(pm) printmessage(Q,pi,method="fixed")
+ mtrees<-replicate(nsim,smap(tree,x,N,m,root,L,Q,pi,logL),simplify=FALSE)
+ }
+ if(length(mtrees)==1) mtrees<-mtrees[[1]]
+ else class(mtrees)<-c("multiSimmap","multiPhylo")
+ }
+ (if(hasArg(message)) list(...)$message else TRUE)
+ if((if(hasArg(message)) list(...)$message else TRUE)&&inherits(tree,"phylo")) message("Done.")
+ return(mtrees)
+}
+
+# print message
+# written by Liam J. Revell 2013
+printmessage<-function(Q,pi,method){
+ if(method=="empirical"||method=="fixed")
+ cat("make.simmap is sampling character histories conditioned on\nthe transition matrix\n\nQ =\n")
+ else if(method=="mcmc"){
+ cat("make.simmap is simulating with a sample of Q from\nthe posterior distribution\n")
+ cat("\nMean Q from the posterior is\nQ =\n")
+ }
+ print(Q)
+ if(method=="empirical") cat("(estimated using likelihood);\n")
+ else if(method=="fixed") cat("(specified by the user);\n")
+ cat("and (mean) root node prior probabilities\npi =\n")
+ if(is.list(pi)) pi<-Reduce("+",pi)/length(pi)
+ print(pi)
+ flush.console()
+}
+
+# mcmc for Q used in Q="mcmc"
+# written by Liam J. Revell 2013
+mcmcQ<-function(bt,xx,model,tree,tol,m,burnin,samplefreq,nsim,vQ,prior,pi,args=list()){
+ update<-function(x){
+ x<-abs(x+rnorm(n=np,mean=0,sd=sqrt(vQ)))
+ return(x)
+ }
+ # get model matrix
+ if(is.character(model)){
+ rate<-matrix(NA,m,m)
+ if(model=="ER"){
+ np<-rate[]<-1
+ diag(rate)<-NA
+ }
+ if(model=="ARD"){
+ np<-m*(m-1)
+ rate[col(rate)!=row(rate)]<-1:np
+ }
+ if(model=="SYM") {
+ np<-m*(m-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)!=m)
+ stop("the matrix 'model' must have as many rows as the number of categories in 'x'")
+ rate<-model
+ np<-max(rate)
+ }
+ # burn-in
+ p<-rgamma(np,prior$alpha,prior$beta)
+ Q<-matrix(c(0,p)[rate+1],m,m)
+ diag(Q)<--rowSums(Q,na.rm=TRUE)
+ yy<-getPars(bt,xx,model,Q,tree,tol,m,pi=pi,args=args)
+ cat("Running MCMC burn-in. Please wait....\n")
+ flush.console()
+ for(i in 1:burnin){
+ pp<-update(p)
+ Qp<-matrix(c(0,pp)[rate+1],m,m)
+ diag(Qp)<--rowSums(Qp,na.rm=TRUE)
+ zz<-getPars(bt,xx,model,Qp,tree,tol,m,FALSE,pi=pi,args)
+ p.odds<-exp(zz$loglik+sum(dgamma(pp,prior$alpha,prior$beta,log=TRUE))-
+ yy$loglik-sum(dgamma(p,prior$alpha,prior$beta,log=TRUE)))
+ if(p.odds>=runif(n=1)){
+ yy<-zz
+ p<-pp
+ }
+ }
+ # now run MCMC generation, sampling at samplefreq
+ cat(paste("Running",samplefreq*nsim,"generations of MCMC, sampling every",samplefreq,"generations.\nPlease wait....\n\n"))
+ flush.console()
+ XX<-vector("list",nsim)
+ for(i in 1:(samplefreq*nsim)){
+ pp<-update(p)
+ Qp<-matrix(c(0,pp)[rate+1],m,m)
+ diag(Qp)<--rowSums(Qp,na.rm=TRUE)
+ zz<-getPars(bt,xx,model,Qp,tree,tol,m,FALSE,pi=pi,args)
+ p.odds<-exp(zz$loglik+sum(dgamma(pp,prior$alpha,prior$beta,log=TRUE))-
+ yy$loglik-sum(dgamma(p,prior$alpha,prior$beta,log=TRUE)))
+ if(p.odds>=runif(n=1)){
+ yy<-zz
+ p<-pp
+ }
+ if(i%%samplefreq==0){
+ Qi<-matrix(c(0,p)[rate+1],m,m)
+ diag(Qi)<--rowSums(Qi,na.rm=TRUE)
+ XX[[i/samplefreq]]<-getPars(bt,xx,model,Qi,tree,tol,m,TRUE,pi=pi,args)
+ }
+ }
+ return(XX)
+}
+
+# get pars
+# written by Liam J. Revell 2013, 2017, 2021
+getPars<-function(bt,xx,model,Q,tree,tol,m,liks=TRUE,pi,args=list()){
+ if(!is.null(args$pi)) args$pi<-NULL
+ args<-c(list(tree=bt,x=xx,model=model,fixedQ=Q,output.liks=liks,pi=pi),args)
+ obj<-do.call(fitMk,args)
+ N<-length(bt$tip.label)
+ pi<-obj$pi
+ II<-obj$index.matrix+1
+ lvls<-obj$states
+ if(liks){
+ L<-obj$lik.anc
+ rownames(L)<-N+1:nrow(L)
+ if(!is.binary(tree)){
+ ancNames<-matchNodes(tree,bt)
+ L<-L[as.character(ancNames[,2]),]
+ rownames(L)<-ancNames[,1]
+ }
+ L<-rbind(xx,L)
+ rownames(L)[1:N]<-1:N
+ } else L<-NULL
+ Q<-matrix(c(0,obj$rates)[II],m,m,dimnames=list(lvls,lvls))
+ if(any(rowSums(Q,na.rm=TRUE)<tol)){
+ message(paste("\nWarning: some rows of Q not numerically distinct from 0; setting to",tol,"\n"))
+ ii<-which(rowSums(Q,na.rm=TRUE)<tol)
+ for(i in 1:length(ii)) Q[ii[i],setdiff(1:ncol(Q),ii[i])]<-tol/(ncol(Q)-1)
+ }
+ diag(Q)<--rowSums(Q,na.rm=TRUE)
+ return(list(Q=Q,L=L,loglik=logLik(obj),pi=pi))
+}
+
+# convert vector of x to binary matrix
+# written by Liam J. Revell 2012
+to.matrix<-function(x,seq){
+ X<-matrix(0,length(x),length(seq),dimnames=list(names(x),seq))
+ for(i in 1:length(seq)) X[x==seq[i],i]<-1
+ return(X)
+}
+
+## function does the stochastic mapping, conditioned on our model & given the conditional likelihoods
+## written by Liam J. Revell 2013, 2017
+smap<-function(tree,x,N,m,root,L,Q,pi,logL){
+ # create the map tree object
+ mtree<-tree
+ mtree$maps<-list()
+ mtree$mapped.edge<-matrix(0,nrow(tree$edge),m,dimnames=list(paste(tree$edge[,1],",",
+ tree$edge[,2],sep=""),colnames(L)))
+ # now we want to simulate the node states & histories by pre-order traversal
+ NN<-matrix(NA,nrow(tree$edge),2) # our node values
+ NN[which(tree$edge[,1]==root),1]<-rstate(L[as.character(root),]/
+ sum(L[as.character(root),])) # assign root
+ for(j in 1:nrow(tree$edge)){
+ # conditioned on the start value, assign end value of node (if internal)
+ p<-EXPM(Q*tree$edge.length[j])[NN[j,1],]*L[as.character(tree$edge[j,2]),]
+ NN[j,2]<-rstate(p/sum(p))
+ NN[which(tree$edge[,1]==tree$edge[j,2]),1]<-NN[j,2]
+ # now simulate on the branches
+ accept<-FALSE
+ while(!accept){
+ map<-sch(NN[j,1],tree$edge.length[j],Q)
+ if(names(map)[length(map)]==NN[j,2]) accept=TRUE
+ }
+ mtree$maps[[j]]<-map
+ for(k in 1:length(mtree$maps[[j]]))
+ mtree$mapped.edge[j,names(mtree$maps[[j]])[k]]<-mtree$mapped.edge[j,
+ names(mtree$maps[[j]])[k]]+mtree$maps[[j]][k]
+ }
+ mtree$Q<-Q
+ mtree$logL<-logL
+ if(!inherits(mtree,"simmap")) class(mtree)<-c("simmap",setdiff(class(mtree),
+ "simmap"))
+ attr(mtree,"map.order")<-"right-to-left"
+ return(mtree)
+}
+
+# function generates a history along a branch
+# written by Liam J. Revell 2013
+sch<-function(start,t,Q){
+ tol<-t*1e-12
+ dt<-setNames(0,start)
+ while(sum(dt)<(t-tol)){
+ s<-names(dt)[length(dt)]
+ dt[length(dt)]<-if(-Q[s,s]>0) rexp(n=1,rate=-Q[s,s]) else t-sum(dt)
+ if(sum(dt)<(t-tol)){
+ dt<-c(dt,0)
+ if(sum(Q[s,][-match(s,colnames(Q))])>0)
+ names(dt)[length(dt)]<-rstate(Q[s,][-match(s,colnames(Q))]/sum(Q[s,][-match(s,colnames(Q))]))
+ else names(dt)[length(dt)]<-s
+ } else dt[length(dt)]<-dt[length(dt)]-sum(dt)+t
+ }
+ return(dt)
+}
+
+# function uses numerical optimization to solve for the stationary distribution
+# written by Liam J. Revell 2013
+statdist<-function(Q){
+ foo<-function(theta,Q){
+ Pi<-c(theta[1:(nrow(Q)-1)],1-sum(theta[1:(nrow(Q)-1)]))
+ sum((Pi%*%Q)^2)
+ }
+ k<-nrow(Q)
+ if(nrow(Q)>2){
+ fit<-optim(rep(1/k,k-1),foo,Q=Q,control=list(reltol=1e-16))
+ return(setNames(c(fit$par[1:(k-1)],1-sum(fit$par[1:(k-1)])),rownames(Q)))
+ } else {
+ fit<-optimize(foo,interval=c(0,1),Q=Q)
+ return(setNames(c(fit$minimum,1-fit$minimum),rownames(Q)))
+ }
+}
+
+## S3 print method for objects of class "simmap" & multiSimmap
+## based on print.phylo in ape
+print.simmap<-function(x,printlen=6,...){
+ N<-Ntip(x)
+ M<-x$Nnode
+ cat(paste("\nPhylogenetic tree with",N,"tips and",M,"internal nodes.\n\n"))
+ cat("Tip labels:\n")
+ if(N>printlen) cat(paste("\t",paste(x$tip.label[1:printlen],collapse=", "),", ...\n",sep=""))
+ else print(x$tip.label)
+ ss<-sort(unique(c(getStates(x,"tips"),getStates(x,"nodes"))))
+ cat(paste("\nThe tree includes a mapped, ",length(ss),"-state discrete character\nwith states:\n",
+ sep=""))
+ if(length(ss)>printlen) cat(paste("\t",paste(ss[1:printlen],collapse=", "),", ...\n",sep=""))
+ else cat(paste("\t",paste(ss,collapse=", "),"\n",sep=""))
+ rlab<-if(is.rooted(x)) "Rooted" else "Unrooted"
+ cat("\n",rlab,"; includes branch lengths.\n",sep="")
+}
+print.multiSimmap<-function(x,details=FALSE,...){
+ N<-length(x)
+ cat(N,"phylogenetic trees with mapped discrete characters\n")
+ if(details){
+ n<-sapply(x,Ntip)
+ s<-sapply(x,function(x) length(unique(c(getStates(x,"tips"),getStates(x,"nodes")))))
+ for(i in 1:N) cat("tree",i,":",n[i],"tips,",s[i],"mapped states\n")
+ }
+}
+
+## S3 summary method for objects of class "simmap" & "multiSimmap"
+summary.simmap<-function(object,...) describe.simmap(object,...)
+summary.multiSimmap<-function(object,...) describe.simmap(object,...)
+
+## for backward compatibility with any function using apeAce internally
+apeAce<-function(tree,x,model,fixedQ=NULL,...){
+ if(hasArg(output.liks)){
+ output.liks<-list(...)$output.liks
+ return(fitMk(tree,x,model,fixedQ,...))
+ } else {
+ output.liks<-TRUE
+ return(fitMk(tree,x,model,fixedQ,output.liks=TRUE,...))
+ }
+}
+
+## S3 logLik methods for "simmap" & "multiSimmap"
+logLik.simmap<-function(object,...) object$logL
+logLik.multiSimmap<-function(object,...)
+ sapply(object,function(x) x$logL)
+
+## S3 density method for "multiSimmap"
+density.multiSimmap<-function(x,...){
+ if(hasArg(method)) method<-list(...)$method
+ else method<-"changes"
+ if(!method%in%c("densityMap","changes")){
+ cat("method not recognized. Setting to default method.\n\n")
+ method<-"changes"
+ }
+ if(method=="densityMap") obj<-densityMap(x,plot=FALSE,...)
+ else if(method=="changes"){
+ if(hasArg(bw)) bw<-list(...)$bw
+ else bw<-1
+ tmp<-summary(x)
+ ab<-lapply(2:ncol(tmp$count),function(i,x) x[,i],x=tmp$count)
+ names(ab)<-sapply(strsplit(colnames(tmp$count)[2:ncol(tmp$count)],
+ ","),function(x) paste(x,collapse="->"))
+ ab<-lapply(ab,function(x){
+ class(x)<-"mcmc"
+ x })
+ if(.check.pkg("coda")){
+ hpd.ab<-lapply(ab,HPDinterval)
+ } else {
+ cat(" HPDinterval requires package coda.\n")
+ cat(" Computing 95% interval from samples only.\n\n")
+ hpd95<-function(x){
+ obj<-setNames(c(sort(x)[round(0.025*length(x))],
+ sort(x)[round(0.975*length(x))]),
+ c("lower","upper"))
+ attr(obj,"Probability")<-0.95
+ obj
+ }
+ hpd.ab<-lapply(ab,hpd95)
+ }
+ minmax<-range(unlist(ab))
+ pcalc<-function(x,mm)
+ hist(x,breaks=seq(mm[1]-1.5,mm[2]+1.5,bw),plot=FALSE)
+ p.ab<-lapply(ab,pcalc,mm=minmax)
+ states<-colnames(tmp$ace)
+ trans<-names(ab)
+ obj<-list(hpd=hpd.ab,
+ p=p.ab,
+ states=states,trans=trans,
+ bw=bw,
+ mins=sapply(ab,min),
+ meds=sapply(ab,median),
+ means=sapply(ab,mean),
+ maxs=sapply(ab,max))
+ class(obj)<-"changesMap"
+ }
+ else if(method=="timings"){
+ cat("This method doesn't work yet.\n")
+ obj<-NULL
+ }
+ obj
+}
+
+## S3 plot method for "changesMap" object from density.multiSimmap
+plot.changesMap<-function(x,...){
+ if(hasArg(bty)) bty<-list(...)$bty
+ else bty<-"l"
+ if(hasArg(alpha)) alpha<-list(...)$alpha
+ else alpha<-0.3
+ if(hasArg(xlim)) xlim<-list(...)$xlim
+ else xlim<-NULL
+ if(hasArg(ylim)) ylim<-list(...)$ylim
+ else ylim<-NULL
+ if(hasArg(main)) main<-list(...)$main
+ else main<-NULL
+ if(hasArg(colors)){
+ colors<-list(...)$colors
+ nn<-names(colors)
+ colors<-setNames(make.transparent(colors,alpha),nn)
+ } else {
+ colors<-if(length(x$trans)==2)
+ setNames(make.transparent(c("blue","red"),alpha),x$trans)
+ else
+ setNames(rep(make.transparent("blue",alpha),length(x$trans)),
+ x$trans)
+ }
+ if(length(colors)<length(x$trans))
+ colors<-rep(colors,ceiling(length(x$trans)/length(colors)))[1:length(x$trans)]
+ if(is.null(names(colors))) colors<-setNames(colors,x$trans)
+ if(hasArg(transition)){
+ transition<-list(...)$transition
+ if(length(transition)>1){
+ cat("transition should be of length 1; truncating to first element.\n")
+ transition<-transition[1]
+ }
+ } else transition<-NULL
+ p<-x$p
+ hpd<-x$hpd
+ bw<-x$bw
+ if(length(x$trans)==2&&is.null(transition)){
+ plot(p[[1]]$mids,p[[1]]$density,xlim=if(is.null(xlim))
+ c(min(x$mins)-1,max(x$maxs)+1) else xlim,
+ ylim=if(is.null(ylim)) c(0,1.2*max(c(p[[1]]$density,
+ p[[2]]$density))) else ylim,
+ type="n",xlab="number of changes",
+ ylab="relative frequency across stochastic maps",
+ bty=bty)
+ y2<-rep(p[[1]]$density,each=2)
+ y2<-y2[-length(y2)]
+ x2<-rep(p[[1]]$mids-bw/2,each=2)[-1]
+ x3<-c(min(x2),x2,max(x2))
+ y3<-c(0,y2,0)
+ polygon(x3,y3,col=colors[x$trans[1]],border=FALSE)
+ lines(p[[1]]$mids-bw/2,p[[1]]$density,type="s")
+ y2<-rep(p[[2]]$density,each=2)
+ y2<-y2[-length(y2)]
+ x2<-rep(p[[2]]$mids-bw/2,each=2)[-1]
+ x3<-c(min(x2),x2,max(x2))
+ y3<-c(0,y2,0)
+ polygon(x3,y3,col=colors[x$trans[2]],border=FALSE)
+ lines(p[[2]]$mids-bw/2,p[[2]]$density,type="s")
+ dd<-0.01*diff(par()$usr[3:4])
+ lines(hpd[[1]],rep(max(p[[1]]$density)+dd,2))
+ lines(rep(hpd[[1]][1],2),c(max(p[[1]]$density)+dd,
+ max(p[[1]]$density)+dd-0.005))
+ lines(rep(hpd[[1]][2],2),c(max(p[[1]]$density)+dd,
+ max(p[[1]]$density)+dd-0.005))
+ CHARS<-strsplit(x$trans[1],"->")[[1]]
+ CHARS[1]<-paste("HPD(",CHARS[1],collapse="")
+ CHARS[2]<-paste(CHARS[2],")",collapse="")
+ T1<-bquote(.(CHARS[1])%->%.(CHARS[2]))
+ text(mean(hpd[[1]]),max(p[[1]]$density)+dd,
+ T1,pos=3)
+ lines(hpd[[2]],rep(max(p[[2]]$density)+dd,2))
+ lines(rep(hpd[[2]][1],2),c(max(p[[2]]$density)+dd,
+ max(p[[2]]$density)+dd-0.005))
+ lines(rep(hpd[[2]][2],2),c(max(p[[2]]$density)+dd,
+ max(p[[2]]$density)+dd-0.005))
+ CHARS<-strsplit(x$trans[2],"->")[[1]]
+ CHARS[1]<-paste("HPD(",CHARS[1],collapse="")
+ CHARS[2]<-paste(CHARS[2],")",collapse="")
+ T2<-bquote(.(CHARS[1])%->%.(CHARS[2]))
+ text(mean(hpd[[2]]),max(p[[2]]$density)+dd,
+ T2,pos=3)
+ CHARS<-strsplit(x$trans[1],"->")[[1]]
+ T1<-bquote(.(CHARS[1])%->%.(CHARS[2]))
+ CHARS<-strsplit(x$trans[2],"->")[[1]]
+ T2<-bquote(.(CHARS[1])%->%.(CHARS[2]))
+ legend("topleft",legend=c(T1,T2),pch=22,pt.cex=2.2,bty="n",
+ pt.bg=colors[x$trans])
+ } else {
+ k<-if(is.null(transition)) length(x$states) else 1
+ if(k>1) par(mfrow=c(k,k))
+ ii<-if(is.null(transition)) 1 else which(x$trans==transition)
+ max.d<-max(unlist(lapply(p,function(x) x$density)))
+ for(i in 1:k){
+ for(j in 1:k){
+ if(i==j&&is.null(transition)) plot.new()
+ else {
+ CHARS<-strsplit(x$trans[ii],"->")[[1]]
+ MAIN<-if(is.null(main)) bquote(.(CHARS[1])%->%.(CHARS[2])) else
+ main
+ plot(p[[ii]]$mids,p[[ii]]$density,xlim=if(is.null(xlim))
+ c(min(x$mins)-1,max(x$maxs)+1) else xlim,
+ ylim=if(is.null(ylim)) c(0,1.2*max.d) else ylim,
+ type="n",xlab="number of changes",
+ ylab="relative frequency",main=MAIN,font.main=1,
+ bty=bty)
+ y2<-rep(p[[ii]]$density,each=2)
+ y2<-y2[-length(y2)]
+ x2<-rep(p[[ii]]$mids-bw/2,each=2)[-1]
+ x3<-c(min(x2),x2,max(x2))
+ y3<-c(0,y2,0)
+ polygon(x3,y3,col=colors[x$trans[ii]],border=FALSE)
+ lines(p[[ii]]$mids-bw/2,p[[ii]]$density,type="s")
+ dd<-0.03*diff(par()$usr[3:4])
+ lines(hpd[[ii]],rep(max(p[[ii]]$density)+dd,2))
+ text(mean(hpd[[ii]]),max(p[[ii]]$density)+dd,"HPD",pos=3)
+ ii<-ii+1
+ }
+ }
+ }
+ }
+}
+
+print.changesMap<-function(x, ...){
+ if(hasArg(signif)) signif<-list(...)$signif
+ else signif<-2
+ cat("\nDistribution of changes from stochastic mapping:\n")
+ NROW<-ceiling(length(x$trans)/2)
+ if(NROW>1) cat("\n")
+ for(i in 1:NROW){
+ ii<-2*i-1
+ jj<-ii+1
+ cat(paste("\t",x$trans[ii],"\t\t",x$trans[jj],"\n",sep=""))
+ cat(paste("\tMin. :",round(x$mins[ii],signif),
+ "\tMin. :",round(x$mins[jj],signif),"\n",sep=""))
+ cat(paste("\tMedian :",round(x$meds[ii],signif),
+ "\tMedian :",round(x$meds[jj],signif),"\n",sep=""))
+ cat(paste("\tMean :",round(x$means[ii],signif),
+ "\tMean :",round(x$means[jj],signif),"\n",sep=""))
+ cat(paste("\tMax. :",round(x$maxs[ii],signif),
+ "\tMax. :",round(x$maxs[jj],signif),"\n\n",sep=""))
+ }
+ for(i in 1:length(x$trans))
+ cat("95% HPD interval(",x$trans[i],"): [",x$hpd[[i]][1],", ",
+ x$hpd[[i]][2],"]\n",sep="")
+ cat("\n")
+}
+
diff --git a/R/map.overlap.R b/R/map.overlap.R
index 59b2a93..0128789 100644
--- a/R/map.overlap.R
+++ b/R/map.overlap.R
@@ -1,92 +1,92 @@
-## function computes the fractional (i.e., 0->1) overlap between the
-## stochastic maps of two trees
-## written by Liam Revell 2011, 2015, 2016
-
-Map.Overlap<-function(tree1,tree2,tol=1e-06,standardize=TRUE,...){
- if(hasArg(check.equal)) check.equal<-list(...)$check.equal
- else check.equal<-TRUE
- if(!inherits(tree1,"phylo")||!inherits(tree2,"phylo"))
- stop("Both input trees should be objects of class \"phylo\".")
- if(check.equal&&!all.equal.phylo(tree1,tree2,tolerance=tol))
- stop("Mapped trees must have the same underlying structure.")
- if(!inherits(tree1,"simmap")||!inherits(tree2,"simmap"))
- stop("Both input trees should be objects of class \"simmap\".")
- s1<-mapped.states(tree1)
- s2<-mapped.states(tree2)
- R<-matrix(0,length(s1),length(s2),dimnames=list(s1,s2))
- for(i in 1:nrow(tree1$edge)){
- XX<-matrix(0,length(tree1$maps[[i]]),2,
- dimnames=list(names(tree1$maps[[i]]),c("start","end")))
- XX[1,2]<-tree1$maps[[i]][1]
- if(length(tree1$maps[[i]])>1){
- for(j in 2:length(tree1$maps[[i]])){
- XX[j,1]<-XX[j-1,2]
- XX[j,2]<-XX[j,1]+tree1$maps[[i]][j]
- }
- }
- YY<-matrix(0,length(tree2$maps[[i]]),2,
- dimnames=list(names(tree2$maps[[i]]),c("start","end")))
- YY[1,2]<-tree2$maps[[i]][1]
- if(length(tree2$maps[[i]])>1){
- for(j in 2:length(tree2$maps[[i]])){
- YY[j,1]<-YY[j-1,2]
- YY[j,2]<-YY[j,1]+tree2$maps[[i]][j]
- }
- }
- for(j in 1:nrow(XX)){
- lower<-max(which(YY[,1]<=XX[j,1]))
- upper<-which(YY[,2]>=(XX[j,2]-tol))[1]
- for(k in lower:upper){
- R[rownames(XX)[j],rownames(YY)[k]]<-
- R[rownames(XX)[j],rownames(YY)[k]]+
- min(YY[k,2],XX[j,2])-max(YY[k,1],XX[j,1])
- }
- }
- }
- if(standardize) R/sum(R) else R
-}
-
-map.overlap<-function(tree1,tree2,tol=1e-6,...){
- if(hasArg(check.equal)) check.equal<-list(...)$check.equal
- else check.equal<-TRUE
- if(!inherits(tree1,"phylo")||!inherits(tree2,"phylo"))
- stop("Both input trees should be objects of class \"phylo\".")
- if(check.equal&&!all.equal.phylo(tree1,tree2,tolerance=tol))
- stop("Mapped trees must have the same underlying structure.")
- if(!inherits(tree1,"simmap")||!inherits(tree2,"simmap"))
- stop("Both input trees should be objects of class \"simmap\".")
- overlap<-0
- for(i in 1:nrow(tree1$edge)){
- XX<-matrix(0,length(tree1$maps[[i]]),2,
- dimnames=list(names(tree1$maps[[i]]),c("start","end")))
- XX[1,2]<-tree1$maps[[i]][1]
- if(length(tree1$maps[[i]])>1){
- for(j in 2:length(tree1$maps[[i]])){
- XX[j,1]<-XX[j-1,2]
- XX[j,2]<-XX[j,1]+tree1$maps[[i]][j]
- }
- }
- YY<-matrix(0,length(tree2$maps[[i]]),2,
- dimnames=list(names(tree2$maps[[i]]),c("start","end")))
- YY[1,2]<-tree2$maps[[i]][1]
- if(length(tree2$maps[[i]])>1){
- for(j in 2:length(tree2$maps[[i]])){
- YY[j,1]<-YY[j-1,2]
- YY[j,2]<-YY[j,1]+tree2$maps[[i]][j]
- }
- }
- for(j in 1:nrow(XX)){
- lower<-which(YY[,1]<=XX[j,1])
- lower<-lower[length(lower)]
- upper<-which(YY[,2]>=(XX[j,2]-tol))[1]
- for(k in lower:upper){
- if(rownames(XX)[j]==rownames(YY)[k])
- overlap<-overlap+min(YY[k,2],XX[j,2])-
- max(YY[k,1],XX[j,1])
- }
- }
- }
- overlap/sum(tree1$edge.length)
-}
-
+## function computes the fractional (i.e., 0->1) overlap between the
+## stochastic maps of two trees
+## written by Liam Revell 2011, 2015, 2016
+
+Map.Overlap<-function(tree1,tree2,tol=1e-06,standardize=TRUE,...){
+ if(hasArg(check.equal)) check.equal<-list(...)$check.equal
+ else check.equal<-TRUE
+ if(!inherits(tree1,"phylo")||!inherits(tree2,"phylo"))
+ stop("Both input trees should be objects of class \"phylo\".")
+ if(check.equal&&!all.equal.phylo(tree1,tree2,tolerance=tol))
+ stop("Mapped trees must have the same underlying structure.")
+ if(!inherits(tree1,"simmap")||!inherits(tree2,"simmap"))
+ stop("Both input trees should be objects of class \"simmap\".")
+ s1<-mapped.states(tree1)
+ s2<-mapped.states(tree2)
+ R<-matrix(0,length(s1),length(s2),dimnames=list(s1,s2))
+ for(i in 1:nrow(tree1$edge)){
+ XX<-matrix(0,length(tree1$maps[[i]]),2,
+ dimnames=list(names(tree1$maps[[i]]),c("start","end")))
+ XX[1,2]<-tree1$maps[[i]][1]
+ if(length(tree1$maps[[i]])>1){
+ for(j in 2:length(tree1$maps[[i]])){
+ XX[j,1]<-XX[j-1,2]
+ XX[j,2]<-XX[j,1]+tree1$maps[[i]][j]
+ }
+ }
+ YY<-matrix(0,length(tree2$maps[[i]]),2,
+ dimnames=list(names(tree2$maps[[i]]),c("start","end")))
+ YY[1,2]<-tree2$maps[[i]][1]
+ if(length(tree2$maps[[i]])>1){
+ for(j in 2:length(tree2$maps[[i]])){
+ YY[j,1]<-YY[j-1,2]
+ YY[j,2]<-YY[j,1]+tree2$maps[[i]][j]
+ }
+ }
+ for(j in 1:nrow(XX)){
+ lower<-max(which(YY[,1]<=XX[j,1]))
+ upper<-which(YY[,2]>=(XX[j,2]-tol))[1]
+ for(k in lower:upper){
+ R[rownames(XX)[j],rownames(YY)[k]]<-
+ R[rownames(XX)[j],rownames(YY)[k]]+
+ min(YY[k,2],XX[j,2])-max(YY[k,1],XX[j,1])
+ }
+ }
+ }
+ if(standardize) R/sum(R) else R
+}
+
+map.overlap<-function(tree1,tree2,tol=1e-6,...){
+ if(hasArg(check.equal)) check.equal<-list(...)$check.equal
+ else check.equal<-TRUE
+ if(!inherits(tree1,"phylo")||!inherits(tree2,"phylo"))
+ stop("Both input trees should be objects of class \"phylo\".")
+ if(check.equal&&!all.equal.phylo(tree1,tree2,tolerance=tol))
+ stop("Mapped trees must have the same underlying structure.")
+ if(!inherits(tree1,"simmap")||!inherits(tree2,"simmap"))
+ stop("Both input trees should be objects of class \"simmap\".")
+ overlap<-0
+ for(i in 1:nrow(tree1$edge)){
+ XX<-matrix(0,length(tree1$maps[[i]]),2,
+ dimnames=list(names(tree1$maps[[i]]),c("start","end")))
+ XX[1,2]<-tree1$maps[[i]][1]
+ if(length(tree1$maps[[i]])>1){
+ for(j in 2:length(tree1$maps[[i]])){
+ XX[j,1]<-XX[j-1,2]
+ XX[j,2]<-XX[j,1]+tree1$maps[[i]][j]
+ }
+ }
+ YY<-matrix(0,length(tree2$maps[[i]]),2,
+ dimnames=list(names(tree2$maps[[i]]),c("start","end")))
+ YY[1,2]<-tree2$maps[[i]][1]
+ if(length(tree2$maps[[i]])>1){
+ for(j in 2:length(tree2$maps[[i]])){
+ YY[j,1]<-YY[j-1,2]
+ YY[j,2]<-YY[j,1]+tree2$maps[[i]][j]
+ }
+ }
+ for(j in 1:nrow(XX)){
+ lower<-which(YY[,1]<=XX[j,1])
+ lower<-lower[length(lower)]
+ upper<-which(YY[,2]>=(XX[j,2]-tol))[1]
+ for(k in lower:upper){
+ if(rownames(XX)[j]==rownames(YY)[k])
+ overlap<-overlap+min(YY[k,2],XX[j,2])-
+ max(YY[k,1],XX[j,1])
+ }
+ }
+ }
+ overlap/sum(tree1$edge.length)
+}
+
\ No newline at end of file
diff --git a/R/map.to.singleton.R b/R/map.to.singleton.R
index d19165e..35b92f7 100644
--- a/R/map.to.singleton.R
+++ b/R/map.to.singleton.R
@@ -1,139 +1,139 @@
-## convert stochastic map style tree to a tree with singleton nodes
-## written by Liam J. Revell 2013, 2015
-
-map.to.singleton<-function(tree){
- if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".")
- tree<-reorderSimmap(tree)
- Nedge<-nrow(tree$edge)+sum(sapply(tree$maps,length)-1)
- Ntips<-length(tree$tip.label)
- edge<-tree$edge
- edge[edge>Ntips]<--edge[edge>Ntips]+Ntips
- xx<-vector(); edge.length<-vector(); ii<-1
- for(i in 1:nrow(tree$edge)){
- if(length(tree$maps[[i]])==1){
- xx[ii]<-names(tree$maps[[i]])
- edge.length[ii]<-tree$maps[[i]]
- ii<-ii+1
- } else {
- nn<-length(tree$maps[[i]])
- new<-matrix(NA,nn,2)
- new[1,1]<-edge[ii,1]
- nextnode<--1+if(i>1) min(c(edge[1:(ii-1),],edge[ii,1])) else edge[ii,1]
- new[,2]<-nextnode-0:(nn-1)
- for(j in 2:nn) new[j,1]<-new[j-1,2]
- if(edge[ii,2]>0) new[nrow(new),2]<-edge[ii,2]
- if(i==nrow(tree$edge)) edge<-rbind(edge[1:(ii-1),],new)
- else {
- ee<-edge[(ii+1):nrow(edge),]
- ee[ee<edge[ii,1]]<-ee[ee<edge[ii,1]]-nrow(new)+1
- if(ii==1) edge<-rbind(new,ee)
- else edge<-rbind(edge[1:(ii-1),],new,ee)
- }
- xx[1:length(tree$maps[[i]])+ii-1]<-names(tree$maps[[i]])
- edge.length[1:length(tree$maps[[i]])+ii-1]<-tree$maps[[i]]
- ii<-ii+length(tree$maps[[i]])
- }
- }
- tip.label<-tree$tip.label
- Nnode<--min(edge)
- edge[edge<0]<-length(tip.label)-edge[edge<0]
- tree<-list(edge=edge,Nnode=Nnode,tip.label=tip.label,edge.length=setNames(edge.length,xx))
- class(tree)<-c("singleton","phylo")
- attr(tree,"order")<-"cladewise"
- return(tree)
-}
-
-## function plots tree with singleton nodes
-## written by Liam J. Revell 2013, 2015, 2017
-plotTree.singletons<-function(tree){
- ## preliminaries
- n<-length(tree$tip.label)
- if(is.null(names(tree$edge.length))) names(tree$edge.length)<-rep(1,length(tree$edge.length))
- colors<-setNames(palette()[1:length(unique(names(tree$edge.length)))],sort(unique(names(tree$edge.length))))
- colors<-colors[names(tree$edge.length)]
- # assume order is cladewise (otherwise we're in trouble!)
- if(attr(tree,"order")=="cladewise") cw<-tree
- else stop("tree must be in \"cladewise\" order.")
- y<-vector(length=n+cw$Nnode)
- y[cw$edge[cw$edge[,2]<=n,2]]<-1:n
- # reorder pruningwise for post-order traversal
- pw<-reorderPhylo(cw,"pruningwise")
- nn<-unique(pw$edge[,1])
- # compute vertical position of each edge
- for(i in 1:length(nn)){
- yy<-y[pw$edge[which(pw$edge[,1]==nn[i]),2]]
- y[nn[i]]<-mean(range(yy))
- }
- # compute start & end points of each edge
- X<-nodeHeights(cw)
- # open & size a new plot
- plot.new(); par(mar=c(1.1,1.1,0.1,0.1))
- pp<-par("pin")[1]
- sw<-par("cex")*(max(strwidth(cw$tip.label,units="inches")))+1.37*par("cex")*strwidth("W",units="inches")
- alp<-optimize(function(a,H,sw,pp) (a*1.04*max(H)+sw-pp)^2,H=X,sw=sw,pp=pp,interval=c(0,1e6))$minimum
- xlim<-c(min(X),max(X)+sw/alp)
- plot.window(xlim=xlim,ylim=c(1,max(y)))
- axis(1,at=c(0,max(X)),labels=FALSE); axis(2,at=1:max(y),labels=FALSE)
- # plot horizontal edges
- for(i in 1:nrow(X)) lines(X[i,],rep(y[cw$edge[i,2]],2),lwd=2,lend=2,col=colors[i])
- # plot vertical relationships
- for(i in 1:tree$Nnode+n){
- xx<-X[which(cw$edge[,1]==i),1]
- yy<-y[cw$edge[which(cw$edge[,1]==i),2]]
- if(length(xx)>1) lines(xx,yy,lwd=2,lend=2,col=colors[which(cw$edge[,1]==i)])
- }
- # plot points
- for(i in 1:nrow(X)) points(X[i,],rep(y[cw$edge[i,2]],2),pch=21,bg="gray")
- # plot tip labels
- for(i in 1:n) text(X[which(cw$edge[,2]==i),2],y[i],tree$tip.label[i],pos=4,offset=0.3)
- PP<-list(type="phylogram",use.edge.length=TRUE,node.pos=1,
- show.tip.label=TRUE,show.node.label=FALSE,
- font=par()$font,cex=par()$cex,adj=0,srt=0,no.margin=FALSE,label.offset=0.3,
- x.lim=xlim,y.lim=c(1,max(y)),
- direction="rightward",tip.color="black",Ntip=Ntip(cw),Nnode=cw$Nnode,
- edge=cw$edge,xx=sapply(1:(Ntip(cw)+cw$Nnode),
- function(x,y,z) y[match(x,z)],y=X,z=cw$edge),yy=y)
- assign("last_plot.phylo",PP,envir=.PlotPhyloEnv)
-}
-
-## function to reorder the edges of the tree for postorder traversal should *only* be used
-## internally to plotTree.singletons (i.e., is not designed for general use).
-## written by Liam J. Revell 2013
-reorderPhylo<-function(x,order="pruningwise",index.only=FALSE,...){
- if(index.only) stop("index.only=TRUE not permitted")
- if(order!="pruningwise") stop("function only returns trees in modified pruningwise format for plotTree.singletons")
- if(attr(x,"order")!="cladewise") stop("input tree should be in cladewise order.")
- aa<-lapply(x$edge[,1],getDescendants,tree=x)
- ll<-sapply(aa,length)
- ii<-order(ll)
- x$edge<-x$edge[ii,]
- x$edge.length<-x$edge.length[ii]
- attr(x,"order")<-"pruningwise"
- return(x)
-}
-
-## function converts a tree with a root edge to a tree with a singleton node instead
-## written by Liam J. Revell 2016, re-written 2019
-rootedge.to.singleton<-function(tree){
- if(!inherits(tree,"phylo"))
- stop("tree should be object of class \"phylo\".")
- if(!is.null(tree$root.edge)){
- tree$edge[tree$edge>Ntip(tree)]<-
- tree$edge[tree$edge>Ntip(tree)]+1
- if(attr(tree,"order")%in%c("postorder","pruningwise")){
- tree$edge<-rbind(tree$edge,c(1,2)+Ntip(tree))
- tree$edge.length<-c(tree$edge.length,tree$root.edge)
- } else {
- tree$edge<-rbind(c(1,2)+Ntip(tree),tree$edge)
- tree$edge.length<-c(tree$root.edge,tree$edge.length)
- }
- tree$root.edge<-NULL
- tree$Nnode<-tree$Nnode+1
- if(!is.null(tree$node.label))
- tree$node.label<-c("",tree$node.label)
- }
- tree
-}
-
-
-
+## convert stochastic map style tree to a tree with singleton nodes
+## written by Liam J. Revell 2013, 2015
+
+map.to.singleton<-function(tree){
+ if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".")
+ tree<-reorderSimmap(tree)
+ Nedge<-nrow(tree$edge)+sum(sapply(tree$maps,length)-1)
+ Ntips<-length(tree$tip.label)
+ edge<-tree$edge
+ edge[edge>Ntips]<--edge[edge>Ntips]+Ntips
+ xx<-vector(); edge.length<-vector(); ii<-1
+ for(i in 1:nrow(tree$edge)){
+ if(length(tree$maps[[i]])==1){
+ xx[ii]<-names(tree$maps[[i]])
+ edge.length[ii]<-tree$maps[[i]]
+ ii<-ii+1
+ } else {
+ nn<-length(tree$maps[[i]])
+ new<-matrix(NA,nn,2)
+ new[1,1]<-edge[ii,1]
+ nextnode<--1+if(i>1) min(c(edge[1:(ii-1),],edge[ii,1])) else edge[ii,1]
+ new[,2]<-nextnode-0:(nn-1)
+ for(j in 2:nn) new[j,1]<-new[j-1,2]
+ if(edge[ii,2]>0) new[nrow(new),2]<-edge[ii,2]
+ if(i==nrow(tree$edge)) edge<-rbind(edge[1:(ii-1),],new)
+ else {
+ ee<-edge[(ii+1):nrow(edge),]
+ ee[ee<edge[ii,1]]<-ee[ee<edge[ii,1]]-nrow(new)+1
+ if(ii==1) edge<-rbind(new,ee)
+ else edge<-rbind(edge[1:(ii-1),],new,ee)
+ }
+ xx[1:length(tree$maps[[i]])+ii-1]<-names(tree$maps[[i]])
+ edge.length[1:length(tree$maps[[i]])+ii-1]<-tree$maps[[i]]
+ ii<-ii+length(tree$maps[[i]])
+ }
+ }
+ tip.label<-tree$tip.label
+ Nnode<--min(edge)
+ edge[edge<0]<-length(tip.label)-edge[edge<0]
+ tree<-list(edge=edge,Nnode=Nnode,tip.label=tip.label,edge.length=setNames(edge.length,xx))
+ class(tree)<-c("singleton","phylo")
+ attr(tree,"order")<-"cladewise"
+ return(tree)
+}
+
+## function plots tree with singleton nodes
+## written by Liam J. Revell 2013, 2015, 2017
+plotTree.singletons<-function(tree){
+ ## preliminaries
+ n<-length(tree$tip.label)
+ if(is.null(names(tree$edge.length))) names(tree$edge.length)<-rep(1,length(tree$edge.length))
+ colors<-setNames(palette()[1:length(unique(names(tree$edge.length)))],sort(unique(names(tree$edge.length))))
+ colors<-colors[names(tree$edge.length)]
+ # assume order is cladewise (otherwise we're in trouble!)
+ if(attr(tree,"order")=="cladewise") cw<-tree
+ else stop("tree must be in \"cladewise\" order.")
+ y<-vector(length=n+cw$Nnode)
+ y[cw$edge[cw$edge[,2]<=n,2]]<-1:n
+ # reorder pruningwise for post-order traversal
+ pw<-reorderPhylo(cw,"pruningwise")
+ nn<-unique(pw$edge[,1])
+ # compute vertical position of each edge
+ for(i in 1:length(nn)){
+ yy<-y[pw$edge[which(pw$edge[,1]==nn[i]),2]]
+ y[nn[i]]<-mean(range(yy))
+ }
+ # compute start & end points of each edge
+ X<-nodeHeights(cw)
+ # open & size a new plot
+ plot.new(); par(mar=c(1.1,1.1,0.1,0.1))
+ pp<-par("pin")[1]
+ sw<-par("cex")*(max(strwidth(cw$tip.label,units="inches")))+1.37*par("cex")*strwidth("W",units="inches")
+ alp<-optimize(function(a,H,sw,pp) (a*1.04*max(H)+sw-pp)^2,H=X,sw=sw,pp=pp,interval=c(0,1e6))$minimum
+ xlim<-c(min(X),max(X)+sw/alp)
+ plot.window(xlim=xlim,ylim=c(1,max(y)))
+ axis(1,at=c(0,max(X)),labels=FALSE); axis(2,at=1:max(y),labels=FALSE)
+ # plot horizontal edges
+ for(i in 1:nrow(X)) lines(X[i,],rep(y[cw$edge[i,2]],2),lwd=2,lend=2,col=colors[i])
+ # plot vertical relationships
+ for(i in 1:tree$Nnode+n){
+ xx<-X[which(cw$edge[,1]==i),1]
+ yy<-y[cw$edge[which(cw$edge[,1]==i),2]]
+ if(length(xx)>1) lines(xx,yy,lwd=2,lend=2,col=colors[which(cw$edge[,1]==i)])
+ }
+ # plot points
+ for(i in 1:nrow(X)) points(X[i,],rep(y[cw$edge[i,2]],2),pch=21,bg="gray")
+ # plot tip labels
+ for(i in 1:n) text(X[which(cw$edge[,2]==i),2],y[i],tree$tip.label[i],pos=4,offset=0.3)
+ PP<-list(type="phylogram",use.edge.length=TRUE,node.pos=1,
+ show.tip.label=TRUE,show.node.label=FALSE,
+ font=par()$font,cex=par()$cex,adj=0,srt=0,no.margin=FALSE,label.offset=0.3,
+ x.lim=xlim,y.lim=c(1,max(y)),
+ direction="rightward",tip.color="black",Ntip=Ntip(cw),Nnode=cw$Nnode,
+ edge=cw$edge,xx=sapply(1:(Ntip(cw)+cw$Nnode),
+ function(x,y,z) y[match(x,z)],y=X,z=cw$edge),yy=y)
+ assign("last_plot.phylo",PP,envir=.PlotPhyloEnv)
+}
+
+## function to reorder the edges of the tree for postorder traversal should *only* be used
+## internally to plotTree.singletons (i.e., is not designed for general use).
+## written by Liam J. Revell 2013
+reorderPhylo<-function(x,order="pruningwise",index.only=FALSE,...){
+ if(index.only) stop("index.only=TRUE not permitted")
+ if(order!="pruningwise") stop("function only returns trees in modified pruningwise format for plotTree.singletons")
+ if(attr(x,"order")!="cladewise") stop("input tree should be in cladewise order.")
+ aa<-lapply(x$edge[,1],getDescendants,tree=x)
+ ll<-sapply(aa,length)
+ ii<-order(ll)
+ x$edge<-x$edge[ii,]
+ x$edge.length<-x$edge.length[ii]
+ attr(x,"order")<-"pruningwise"
+ return(x)
+}
+
+## function converts a tree with a root edge to a tree with a singleton node instead
+## written by Liam J. Revell 2016, re-written 2019
+rootedge.to.singleton<-function(tree){
+ if(!inherits(tree,"phylo"))
+ stop("tree should be object of class \"phylo\".")
+ if(!is.null(tree$root.edge)){
+ tree$edge[tree$edge>Ntip(tree)]<-
+ tree$edge[tree$edge>Ntip(tree)]+1
+ if(attr(tree,"order")%in%c("postorder","pruningwise")){
+ tree$edge<-rbind(tree$edge,c(1,2)+Ntip(tree))
+ tree$edge.length<-c(tree$edge.length,tree$root.edge)
+ } else {
+ tree$edge<-rbind(c(1,2)+Ntip(tree),tree$edge)
+ tree$edge.length<-c(tree$root.edge,tree$edge.length)
+ }
+ tree$root.edge<-NULL
+ tree$Nnode<-tree$Nnode+1
+ if(!is.null(tree$node.label))
+ tree$node.label<-c("",tree$node.label)
+ }
+ tree
+}
+
+
+
diff --git a/R/mcmcBM.R b/R/mcmcBM.R
index dec205d..98db931 100644
--- a/R/mcmcBM.R
+++ b/R/mcmcBM.R
@@ -1,113 +1,113 @@
-# function
-# written by Liam J. Revell 2011
-
-mcmcBM<-function(tree,x,ngen=10000,control=list()){
-
- # starting values (for now)
- n<-length(tree$tip)
- temp<-aggregate(x,list(species=as.factor(names(x))),mean)
- xbar<-temp[,2]; names(xbar)<-temp[,1]; xbar<-xbar[tree$tip.label]
- sig2<-mean(pic(xbar,tree)^2)
- a<-mean(xbar)
- intV<-mean(aggregate(x,list(species=as.factor(names(x))),var)[,2],na.rm=T)
- prop<-c(0.01*sig2,0.01*sig2,rep(0.01*sig2*max(vcv(tree)),n),0.01*intV)
- pr.mean<-c(1000,rep(0,n+1),1000)
- pr.var<-c(pr.mean[1]^2,rep(1000,n+1),pr.mean[length(pr.mean)]^2)
-
- # populate control list
- con=list(sig2=sig2,a=a,xbar=xbar,intV=intV,pr.mean=pr.mean,pr.var=pr.var,prop=prop,sample=100)
- con[(namc<-names(control))]<-control
- con<-con[!sapply(con,is.null)]
- # print control parameters to screen
- message("Control parameters (set by user or default):"); str(con)
-
- # function returns the log-likelihood
- likelihood<-function(C,invC,detC,x,sig2,a,xbar,intV){
- z<-xbar-a
- logLik<--z%*%invC%*%z/(2*sig2)-nrow(C)*log(2*pi)/2-nrow(C)*log(sig2)/2-detC/2+sum(dnorm(x,xbar[names(x)],sd=sqrt(intV),log=T))
- return(logLik)
- }
-
- # function returns the log prior probability
- log.prior<-function(sig2,a,xbar,intV){
- pp<-dexp(sig2,rate=1/con$pr.mean[1],log=T)+sum(dnorm(c(a,xbar),mean=con$pr.mean[1+1:(n+1)],sd=sqrt(con$pr.var[1+1:(n+1)]),log=T))+dexp(intV,rate=1/con$pr.mean[length(con$pr.mean)],log=T)
- return(pp)
- }
-
- # compute C
- C<-vcv.phylo(tree)
- invC<-solve(C)
- detC<-determinant(C,logarithm=TRUE)$modulus[1]
-
- # now set starting values for MCMC
- sig2<-con$sig2; a<-con$a; xbar<-con$xbar; intV<-con$intV
- L<-likelihood(C,invC,detC,x,sig2,a,xbar,intV)
- Pr<-log.prior(sig2,a,xbar,intV)
-
- # store
- X<-matrix(NA,ngen/con$sample+1,n+5,dimnames=list(NULL,c("gen","sig2","a",tree$tip.label,"var","logLik")))
- X[1,]<-c(0,sig2,a,xbar,intV,L)
-
- message("Starting MCMC...")
-
- # start MCMC
- for(i in 1:ngen){
- j<-(i-1)%%(n+3)
- if(j==0){
- # update sig2
- sig2.prime<-sig2+rnorm(n=1,sd=sqrt(con$prop[j+1]))
- if(sig2.prime<0) sig2.prime<--sig2.prime
- L.prime<-likelihood(C,invC,detC,x,sig2.prime,a,xbar,intV)
- Pr.prime<-log.prior(sig2.prime,a,xbar,intV)
- post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T)
- if(post.odds>runif(n=1)){
- if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2.prime,a,xbar,intV,L.prime)
- sig2<-sig2.prime
- L<-L.prime
- Pr<-Pr.prime
- } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,intV,L)
- } else if(j==1){
- # update a
- a.prime<-a+rnorm(n=1,sd=sqrt(con$prop[j+1]))
- L.prime<-likelihood(C,invC,detC,x,sig2,a.prime,xbar,intV)
- Pr.prime<-log.prior(sig2,a.prime,xbar,intV)
- post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T)
- if(post.odds>runif(n=1)){
- if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a.prime,xbar,intV,L.prime)
- a<-a.prime
- L<-L.prime
- Pr<-Pr.prime
- } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,intV,L)
- } else if(j>1&&j<=(n+1)) {
- k<-j-1 # update tip mean k
- xbar.prime<-xbar
- xbar.prime[k]<-xbar[k]+rnorm(n=1,sd=sqrt(con$prop[j+1]))
- L.prime<-likelihood(C,invC,detC,x,sig2,a,xbar.prime,intV)
- Pr.prime<-log.prior(sig2,a,xbar.prime,intV)
- post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T)
- if(post.odds>runif(n=1)){
- if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar.prime,intV,L.prime)
- xbar<-xbar.prime
- L<-L.prime
- Pr<-Pr.prime
- } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,intV,L)
- } else if(j>(n+1)){
- # update var
- intV.prime<-intV+rnorm(n=1,sd=sqrt(con$prop[j+1]))
- if(intV.prime<0) intV.prime<--intV.prime
- L.prime<-likelihood(C,invC,detC,x,sig2,a,xbar,intV.prime)
- Pr.prime<-log.prior(sig2,a,xbar,intV.prime)
- post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T)
- if(post.odds>runif(n=1)){
- if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,intV.prime,L.prime)
- intV<-intV.prime
- L<-L.prime
- Pr<-Pr.prime
- } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,intV,L)
- }
- }
-
- # done MCMC
- message("Done MCMC.")
- return(X)
-}
+# function
+# written by Liam J. Revell 2011
+
+mcmcBM<-function(tree,x,ngen=10000,control=list()){
+
+ # starting values (for now)
+ n<-length(tree$tip)
+ temp<-aggregate(x,list(species=as.factor(names(x))),mean)
+ xbar<-temp[,2]; names(xbar)<-temp[,1]; xbar<-xbar[tree$tip.label]
+ sig2<-mean(pic(xbar,tree)^2)
+ a<-mean(xbar)
+ intV<-mean(aggregate(x,list(species=as.factor(names(x))),var)[,2],na.rm=T)
+ prop<-c(0.01*sig2,0.01*sig2,rep(0.01*sig2*max(vcv(tree)),n),0.01*intV)
+ pr.mean<-c(1000,rep(0,n+1),1000)
+ pr.var<-c(pr.mean[1]^2,rep(1000,n+1),pr.mean[length(pr.mean)]^2)
+
+ # populate control list
+ con=list(sig2=sig2,a=a,xbar=xbar,intV=intV,pr.mean=pr.mean,pr.var=pr.var,prop=prop,sample=100)
+ con[(namc<-names(control))]<-control
+ con<-con[!sapply(con,is.null)]
+ # print control parameters to screen
+ message("Control parameters (set by user or default):"); str(con)
+
+ # function returns the log-likelihood
+ likelihood<-function(C,invC,detC,x,sig2,a,xbar,intV){
+ z<-xbar-a
+ logLik<--z%*%invC%*%z/(2*sig2)-nrow(C)*log(2*pi)/2-nrow(C)*log(sig2)/2-detC/2+sum(dnorm(x,xbar[names(x)],sd=sqrt(intV),log=T))
+ return(logLik)
+ }
+
+ # function returns the log prior probability
+ log.prior<-function(sig2,a,xbar,intV){
+ pp<-dexp(sig2,rate=1/con$pr.mean[1],log=T)+sum(dnorm(c(a,xbar),mean=con$pr.mean[1+1:(n+1)],sd=sqrt(con$pr.var[1+1:(n+1)]),log=T))+dexp(intV,rate=1/con$pr.mean[length(con$pr.mean)],log=T)
+ return(pp)
+ }
+
+ # compute C
+ C<-vcv.phylo(tree)
+ invC<-solve(C)
+ detC<-determinant(C,logarithm=TRUE)$modulus[1]
+
+ # now set starting values for MCMC
+ sig2<-con$sig2; a<-con$a; xbar<-con$xbar; intV<-con$intV
+ L<-likelihood(C,invC,detC,x,sig2,a,xbar,intV)
+ Pr<-log.prior(sig2,a,xbar,intV)
+
+ # store
+ X<-matrix(NA,ngen/con$sample+1,n+5,dimnames=list(NULL,c("gen","sig2","a",tree$tip.label,"var","logLik")))
+ X[1,]<-c(0,sig2,a,xbar,intV,L)
+
+ message("Starting MCMC...")
+
+ # start MCMC
+ for(i in 1:ngen){
+ j<-(i-1)%%(n+3)
+ if(j==0){
+ # update sig2
+ sig2.prime<-sig2+rnorm(n=1,sd=sqrt(con$prop[j+1]))
+ if(sig2.prime<0) sig2.prime<--sig2.prime
+ L.prime<-likelihood(C,invC,detC,x,sig2.prime,a,xbar,intV)
+ Pr.prime<-log.prior(sig2.prime,a,xbar,intV)
+ post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T)
+ if(post.odds>runif(n=1)){
+ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2.prime,a,xbar,intV,L.prime)
+ sig2<-sig2.prime
+ L<-L.prime
+ Pr<-Pr.prime
+ } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,intV,L)
+ } else if(j==1){
+ # update a
+ a.prime<-a+rnorm(n=1,sd=sqrt(con$prop[j+1]))
+ L.prime<-likelihood(C,invC,detC,x,sig2,a.prime,xbar,intV)
+ Pr.prime<-log.prior(sig2,a.prime,xbar,intV)
+ post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T)
+ if(post.odds>runif(n=1)){
+ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a.prime,xbar,intV,L.prime)
+ a<-a.prime
+ L<-L.prime
+ Pr<-Pr.prime
+ } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,intV,L)
+ } else if(j>1&&j<=(n+1)) {
+ k<-j-1 # update tip mean k
+ xbar.prime<-xbar
+ xbar.prime[k]<-xbar[k]+rnorm(n=1,sd=sqrt(con$prop[j+1]))
+ L.prime<-likelihood(C,invC,detC,x,sig2,a,xbar.prime,intV)
+ Pr.prime<-log.prior(sig2,a,xbar.prime,intV)
+ post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T)
+ if(post.odds>runif(n=1)){
+ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar.prime,intV,L.prime)
+ xbar<-xbar.prime
+ L<-L.prime
+ Pr<-Pr.prime
+ } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,intV,L)
+ } else if(j>(n+1)){
+ # update var
+ intV.prime<-intV+rnorm(n=1,sd=sqrt(con$prop[j+1]))
+ if(intV.prime<0) intV.prime<--intV.prime
+ L.prime<-likelihood(C,invC,detC,x,sig2,a,xbar,intV.prime)
+ Pr.prime<-log.prior(sig2,a,xbar,intV.prime)
+ post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T)
+ if(post.odds>runif(n=1)){
+ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,intV.prime,L.prime)
+ intV<-intV.prime
+ L<-L.prime
+ Pr<-Pr.prime
+ } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,intV,L)
+ }
+ }
+
+ # done MCMC
+ message("Done MCMC.")
+ return(X)
+}
diff --git a/R/mcmcBM.full.R b/R/mcmcBM.full.R
index 6b3299c..5daa88a 100644
--- a/R/mcmcBM.full.R
+++ b/R/mcmcBM.full.R
@@ -1,116 +1,116 @@
-# function
-# written by Liam J. Revell 2011
-
-mcmcBM.full<-function(tree,x,ngen=10000,control=list()){
-
- # starting values (for now)
- n<-length(tree$tip)
- temp<-aggregate(x,list(species=as.factor(names(x))),mean)
- xbar<-temp[,2]; names(xbar)<-temp[,1]; xbar<-xbar[tree$tip.label]
- sig2<-mean(pic(xbar,tree)^2)
- a<-mean(xbar)
- v<-rep(mean(aggregate(x,list(species=as.factor(names(x))),var)[,2],na.rm=T),n)
- names(v)<-names(xbar)
- prop<-c(0.01*sig2,0.01*sig2,rep(0.01*sig2*max(vcv(tree)),n),0.01*v)
- pr.mean<-c(1000,rep(0,n+1),rep(1000,n))
- pr.var<-c(pr.mean[1]^2,rep(1000,n+1),pr.mean[n+2+1:n]^2)
-
- # populate control list
- con=list(sig2=sig2,a=a,xbar=xbar,v=v,pr.mean=pr.mean,pr.var=pr.var,prop=prop,sample=100)
- names(con$v)<-gsub("\\)","",gsub("var\\(","",names(con$v)))
- con[(namc<-names(control))]<-control
- con<-con[!sapply(con,is.null)]
- # print control parameters to screen
- message("Control parameters (set by user or default):"); str(con)
-
- # function returns the log-likelihood
- likelihood<-function(C,invC,detC,x,sig2,a,xbar,v){
- z<-xbar-a
- logLik<--z%*%invC%*%z/(2*sig2)-nrow(C)*log(2*pi)/2-nrow(C)*log(sig2)/2-detC/2+sum(dnorm(x,xbar[names(x)],sd=sqrt(v[names(x)]),log=T))
- return(logLik)
- }
-
- # function returns the log prior probability
- log.prior<-function(sig2,a,xbar,v){
- pp<-dexp(sig2,rate=1/con$pr.mean[1],log=T)+sum(dnorm(c(a,xbar),mean=con$pr.mean[1+1:(n+1)],sd=sqrt(con$pr.var[1+1:(n+1)]),log=T))+sum(dexp(v,rate=1/con$pr.mean[n+2+1:n],log=T))
- return(pp)
- }
-
- # compute C
- C<-vcv.phylo(tree)
- invC<-solve(C)
- detC<-determinant(C,logarithm=TRUE)$modulus[1]
-
- # now set starting values for MCMC
- sig2<-con$sig2; a<-con$a; xbar<-con$xbar; v<-con$v
- L<-likelihood(C,invC,detC,x,sig2,a,xbar,v)
- Pr<-log.prior(sig2,a,xbar,v)
-
- # store
- X<-matrix(NA,ngen/con$sample+1,2*n+4,dimnames=list(NULL,c("gen","sig2","a",tree$tip.label,paste("var(",tree$tip.label,")",sep=""),"logLik")))
- X[1,]<-c(0,sig2,a,xbar,v,L)
-
- message("Starting MCMC...")
-
- # start MCMC
- for(i in 1:ngen){
- j<-(i-1)%%(2*n+2)
- if(j==0){
- # update sig2
- sig2.prime<-sig2+rnorm(n=1,sd=sqrt(con$prop[j+1]))
- if(sig2.prime<0) sig2.prime<--sig2.prime
- L.prime<-likelihood(C,invC,detC,x,sig2.prime,a,xbar,v)
- Pr.prime<-log.prior(sig2.prime,a,xbar,v)
- post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T)
- if(post.odds>runif(n=1)){
- if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2.prime,a,xbar,v,L.prime)
- sig2<-sig2.prime
- L<-L.prime
- Pr<-Pr.prime
- } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,v,L)
- } else if(j==1){
- # update a
- a.prime<-a+rnorm(n=1,sd=sqrt(con$prop[j+1]))
- L.prime<-likelihood(C,invC,detC,x,sig2,a.prime,xbar,v)
- Pr.prime<-log.prior(sig2,a.prime,xbar,v)
- post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T)
- if(post.odds>runif(n=1)){
- if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a.prime,xbar,v,L.prime)
- a<-a.prime
- L<-L.prime
- Pr<-Pr.prime
- } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,v,L)
- } else if(j>1&&j<=(n+1)) {
- k<-j-1 # update tip mean k
- xbar.prime<-xbar
- xbar.prime[k]<-xbar[k]+rnorm(n=1,sd=sqrt(con$prop[j+1]))
- L.prime<-likelihood(C,invC,detC,x,sig2,a,xbar.prime,v)
- Pr.prime<-log.prior(sig2,a,xbar.prime,v)
- post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T)
- if(post.odds>runif(n=1)){
- if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar.prime,v,L.prime)
- xbar<-xbar.prime
- L<-L.prime
- Pr<-Pr.prime
- } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,v,L)
- } else if(j>(n+1)){
- k<-j-n-1 # update var
- v.prime<-v
- v.prime[k]<-v[k]+rnorm(n=1,sd=sqrt(con$prop[j+1]))
- if(v.prime[k]<0) v.prime[k]<--v.prime[k]
- L.prime<-likelihood(C,invC,detC,x,sig2,a,xbar,v.prime)
- Pr.prime<-log.prior(sig2,a,xbar,v.prime)
- post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T)
- if(post.odds>runif(n=1)){
- if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,v.prime,L.prime)
- v<-v.prime
- L<-L.prime
- Pr<-Pr.prime
- } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,v,L)
- }
- }
-
- # done MCMC
- message("Done MCMC.")
- return(X)
-}
+# function
+# written by Liam J. Revell 2011
+
+mcmcBM.full<-function(tree,x,ngen=10000,control=list()){
+
+ # starting values (for now)
+ n<-length(tree$tip)
+ temp<-aggregate(x,list(species=as.factor(names(x))),mean)
+ xbar<-temp[,2]; names(xbar)<-temp[,1]; xbar<-xbar[tree$tip.label]
+ sig2<-mean(pic(xbar,tree)^2)
+ a<-mean(xbar)
+ v<-rep(mean(aggregate(x,list(species=as.factor(names(x))),var)[,2],na.rm=T),n)
+ names(v)<-names(xbar)
+ prop<-c(0.01*sig2,0.01*sig2,rep(0.01*sig2*max(vcv(tree)),n),0.01*v)
+ pr.mean<-c(1000,rep(0,n+1),rep(1000,n))
+ pr.var<-c(pr.mean[1]^2,rep(1000,n+1),pr.mean[n+2+1:n]^2)
+
+ # populate control list
+ con=list(sig2=sig2,a=a,xbar=xbar,v=v,pr.mean=pr.mean,pr.var=pr.var,prop=prop,sample=100)
+ names(con$v)<-gsub("\\)","",gsub("var\\(","",names(con$v)))
+ con[(namc<-names(control))]<-control
+ con<-con[!sapply(con,is.null)]
+ # print control parameters to screen
+ message("Control parameters (set by user or default):"); str(con)
+
+ # function returns the log-likelihood
+ likelihood<-function(C,invC,detC,x,sig2,a,xbar,v){
+ z<-xbar-a
+ logLik<--z%*%invC%*%z/(2*sig2)-nrow(C)*log(2*pi)/2-nrow(C)*log(sig2)/2-detC/2+sum(dnorm(x,xbar[names(x)],sd=sqrt(v[names(x)]),log=T))
+ return(logLik)
+ }
+
+ # function returns the log prior probability
+ log.prior<-function(sig2,a,xbar,v){
+ pp<-dexp(sig2,rate=1/con$pr.mean[1],log=T)+sum(dnorm(c(a,xbar),mean=con$pr.mean[1+1:(n+1)],sd=sqrt(con$pr.var[1+1:(n+1)]),log=T))+sum(dexp(v,rate=1/con$pr.mean[n+2+1:n],log=T))
+ return(pp)
+ }
+
+ # compute C
+ C<-vcv.phylo(tree)
+ invC<-solve(C)
+ detC<-determinant(C,logarithm=TRUE)$modulus[1]
+
+ # now set starting values for MCMC
+ sig2<-con$sig2; a<-con$a; xbar<-con$xbar; v<-con$v
+ L<-likelihood(C,invC,detC,x,sig2,a,xbar,v)
+ Pr<-log.prior(sig2,a,xbar,v)
+
+ # store
+ X<-matrix(NA,ngen/con$sample+1,2*n+4,dimnames=list(NULL,c("gen","sig2","a",tree$tip.label,paste("var(",tree$tip.label,")",sep=""),"logLik")))
+ X[1,]<-c(0,sig2,a,xbar,v,L)
+
+ message("Starting MCMC...")
+
+ # start MCMC
+ for(i in 1:ngen){
+ j<-(i-1)%%(2*n+2)
+ if(j==0){
+ # update sig2
+ sig2.prime<-sig2+rnorm(n=1,sd=sqrt(con$prop[j+1]))
+ if(sig2.prime<0) sig2.prime<--sig2.prime
+ L.prime<-likelihood(C,invC,detC,x,sig2.prime,a,xbar,v)
+ Pr.prime<-log.prior(sig2.prime,a,xbar,v)
+ post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T)
+ if(post.odds>runif(n=1)){
+ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2.prime,a,xbar,v,L.prime)
+ sig2<-sig2.prime
+ L<-L.prime
+ Pr<-Pr.prime
+ } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,v,L)
+ } else if(j==1){
+ # update a
+ a.prime<-a+rnorm(n=1,sd=sqrt(con$prop[j+1]))
+ L.prime<-likelihood(C,invC,detC,x,sig2,a.prime,xbar,v)
+ Pr.prime<-log.prior(sig2,a.prime,xbar,v)
+ post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T)
+ if(post.odds>runif(n=1)){
+ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a.prime,xbar,v,L.prime)
+ a<-a.prime
+ L<-L.prime
+ Pr<-Pr.prime
+ } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,v,L)
+ } else if(j>1&&j<=(n+1)) {
+ k<-j-1 # update tip mean k
+ xbar.prime<-xbar
+ xbar.prime[k]<-xbar[k]+rnorm(n=1,sd=sqrt(con$prop[j+1]))
+ L.prime<-likelihood(C,invC,detC,x,sig2,a,xbar.prime,v)
+ Pr.prime<-log.prior(sig2,a,xbar.prime,v)
+ post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T)
+ if(post.odds>runif(n=1)){
+ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar.prime,v,L.prime)
+ xbar<-xbar.prime
+ L<-L.prime
+ Pr<-Pr.prime
+ } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,v,L)
+ } else if(j>(n+1)){
+ k<-j-n-1 # update var
+ v.prime<-v
+ v.prime[k]<-v[k]+rnorm(n=1,sd=sqrt(con$prop[j+1]))
+ if(v.prime[k]<0) v.prime[k]<--v.prime[k]
+ L.prime<-likelihood(C,invC,detC,x,sig2,a,xbar,v.prime)
+ Pr.prime<-log.prior(sig2,a,xbar,v.prime)
+ post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T)
+ if(post.odds>runif(n=1)){
+ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,v.prime,L.prime)
+ v<-v.prime
+ L<-L.prime
+ Pr<-Pr.prime
+ } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,v,L)
+ }
+ }
+
+ # done MCMC
+ message("Done MCMC.")
+ return(X)
+}
diff --git a/R/mcmcLambda.R b/R/mcmcLambda.R
index 2bac7a9..2f47075 100644
--- a/R/mcmcLambda.R
+++ b/R/mcmcLambda.R
@@ -1,137 +1,137 @@
-# function
-# written by Liam J. Revell 2011, 2012, 2013
-
-mcmcLambda<-function(tree,x,ngen=10000,control=list()){
-
- # starting values (for now)
- n<-length(tree$tip)
- temp<-aggregate(x,list(species=as.factor(names(x))),mean)
- xbar<-temp[,2]; names(xbar)<-temp[,1]; xbar<-xbar[tree$tip.label]
- sig2<-mean(pic(xbar,tree)^2)
- lambda<-1.0; max.lambda<-maxLambda(tree)
- a<-mean(xbar)
- intV<-mean(aggregate(x,list(species=as.factor(names(x))),var)[,2],na.rm=T)
- prop<-c(0.01*sig2,0.02,0.01*sig2,rep(0.01*sig2*max(vcv(tree)),n),0.01*intV)
- pr.mean<-c(1000,max.lambda/2,rep(0,n+1),1000)
- pr.var<-c(pr.mean[1]^2,max.lambda,rep(1000,n+1),pr.mean[length(pr.mean)]^2)
-
- # populate control list
- con=list(sig2=sig2,lambda=lambda,a=a,xbar=xbar,intV=intV,pr.mean=pr.mean,pr.var=pr.var,prop=prop,sample=100)
- con[(namc<-names(control))]<-control
- con<-con[!sapply(con,is.null)]
- # print control parameters to screen
- message("Control parameters (set by user or default):"); str(con)
-
- # function returns the log-likelihood
- likelihood<-function(C,invC,detC,x,sig2,a,xbar,intV){
- z<-xbar-a
- logLik<--z%*%invC%*%z/(2*sig2)-nrow(C)*log(2*pi)/2-nrow(C)*log(sig2)/2-detC/2+sum(dnorm(x,xbar[names(x)],sd=sqrt(intV),log=T))
- return(logLik)
- }
-
- # function returns the log prior probability
- log.prior<-function(sig2,lambda,a,xbar,intV){
- pp<-dexp(sig2,rate=1/con$pr.mean[1],log=T)+dunif(lambda,min=con$pr.mean[2]-con$pr.var[2]/2,max=con$pr.mean[2]+con$pr.var[2]/2,log=T)+sum(dnorm(c(a,xbar),mean=con$pr.mean[1+1:(n+1)],sd=sqrt(con$pr.var[1+1:(n+1)]),log=T))+dexp(intV,rate=1/con$pr.mean[length(con$pr.mean)],log=T)
- return(pp)
- }
-
- # compute (starting values for) C
- C1<-vcv.phylo(tree) # used for updates of lambda
- C<-lambda.transform(con$lambda,C1)
- invC<-solve(C)
- detC<-determinant(C,logarithm=TRUE)$modulus[1]
-
- # now set starting values for MCMC
- sig2<-con$sig2; lambda<-con$lambda; a<-con$a; xbar<-con$xbar; intV<-con$intV
- L<-likelihood(C,invC,detC,x,sig2,a,xbar,intV)
- Pr<-log.prior(sig2,lambda,a,xbar,intV)
-
- # store
- X<-matrix(NA,ngen/con$sample+1,n+6,dimnames=list(NULL,c("gen","sig2","lambda","a",tree$tip.label,"var","logLik")))
- X[1,]<-c(0,sig2,lambda,a,xbar,intV,L)
-
- message("Starting MCMC...")
-
- # start MCMC
- for(i in 1:ngen){
- j<-(i-1)%%(n+4)
- if(j==0){
- # update sig2
- sig2.prime<-sig2+rnorm(n=1,sd=sqrt(con$prop[j+1]))
- if(sig2.prime<0) sig2.prime<--sig2.prime
- L.prime<-likelihood(C,invC,detC,x,sig2.prime,a,xbar,intV)
- Pr.prime<-log.prior(sig2.prime,lambda,a,xbar,intV)
- post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T)
- if(post.odds>runif(n=1)){
- if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2.prime,lambda,a,xbar,intV,L.prime)
- sig2<-sig2.prime
- L<-L.prime
- Pr<-Pr.prime
- } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,lambda,a,xbar,intV,L)
- } else if(j==1){
- # update lambda
- lambda.prime<-lambda+rnorm(n=1,sd=sqrt(con$prop[j+1]))
- while(lambda.prime<0||lambda.prime>max.lambda){
- if(lambda.prime<0) lambda.prime<--lambda.prime
- if(lambda.prime>max.lambda) lambda.prime<-2*max.lambda-lambda.prime
- }
- # update C with new lambda
- C.prime<-lambda.transform(lambda.prime,C1)
- invC.prime<-solve(C.prime)
- detC.prime<-determinant(C.prime,logarithm=TRUE)$modulus[1]
- L.prime<-likelihood(C.prime,invC.prime,detC.prime,x,sig2,a,xbar,intV)
- Pr.prime<-log.prior(sig2,lambda.prime,a,xbar,intV)
- post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T)
- if(post.odds>runif(n=1)){
- if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,lambda.prime,a,xbar,intV,L.prime)
- lambda<-lambda.prime
- C<-C.prime; invC<-invC.prime; detC<-detC.prime
- L<-L.prime
- Pr<-Pr.prime
- } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,lambda,a,xbar,intV,L)
- } else if(j==2){
- # update a
- a.prime<-a+rnorm(n=1,sd=sqrt(con$prop[j+1]))
- L.prime<-likelihood(C,invC,detC,x,sig2,a.prime,xbar,intV)
- Pr.prime<-log.prior(sig2,lambda,a.prime,xbar,intV)
- post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T)
- if(post.odds>runif(n=1)){
- if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,lambda,a.prime,xbar,intV,L.prime)
- a<-a.prime
- L<-L.prime
- Pr<-Pr.prime
- } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,lambda,a,xbar,intV,L)
- } else if(j>2&&j<=(n+2)) {
- k<-j-2 # update tip mean k
- xbar.prime<-xbar
- xbar.prime[k]<-xbar[k]+rnorm(n=1,sd=sqrt(con$prop[j+1]))
- L.prime<-likelihood(C,invC,detC,x,sig2,a,xbar.prime,intV)
- Pr.prime<-log.prior(sig2,lambda,a,xbar.prime,intV)
- post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T)
- if(post.odds>runif(n=1)){
- if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,lambda,a,xbar.prime,intV,L.prime)
- xbar<-xbar.prime
- L<-L.prime
- Pr<-Pr.prime
- } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,lambda,a,xbar,intV,L)
- } else if(j>(n+2)){
- # update var
- intV.prime<-intV+rnorm(n=1,sd=sqrt(con$prop[j+1]))
- if(intV.prime<0) intV.prime<--intV.prime
- L.prime<-likelihood(C,invC,detC,x,sig2,a,xbar,intV.prime)
- Pr.prime<-log.prior(sig2,lambda,a,xbar,intV.prime)
- post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T)
- if(post.odds>runif(n=1)){
- if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,lambda,a,xbar,intV.prime,L.prime)
- intV<-intV.prime
- L<-L.prime
- Pr<-Pr.prime
- } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,lambda,a,xbar,intV,L)
- }
- }
-
- # done MCMC
- message("Done MCMC.")
- return(X)
-}
-
+# function
+# written by Liam J. Revell 2011, 2012, 2013
+
+mcmcLambda<-function(tree,x,ngen=10000,control=list()){
+
+ # starting values (for now)
+ n<-length(tree$tip)
+ temp<-aggregate(x,list(species=as.factor(names(x))),mean)
+ xbar<-temp[,2]; names(xbar)<-temp[,1]; xbar<-xbar[tree$tip.label]
+ sig2<-mean(pic(xbar,tree)^2)
+ lambda<-1.0; max.lambda<-maxLambda(tree)
+ a<-mean(xbar)
+ intV<-mean(aggregate(x,list(species=as.factor(names(x))),var)[,2],na.rm=T)
+ prop<-c(0.01*sig2,0.02,0.01*sig2,rep(0.01*sig2*max(vcv(tree)),n),0.01*intV)
+ pr.mean<-c(1000,max.lambda/2,rep(0,n+1),1000)
+ pr.var<-c(pr.mean[1]^2,max.lambda,rep(1000,n+1),pr.mean[length(pr.mean)]^2)
+
+ # populate control list
+ con=list(sig2=sig2,lambda=lambda,a=a,xbar=xbar,intV=intV,pr.mean=pr.mean,pr.var=pr.var,prop=prop,sample=100)
+ con[(namc<-names(control))]<-control
+ con<-con[!sapply(con,is.null)]
+ # print control parameters to screen
+ message("Control parameters (set by user or default):"); str(con)
+
+ # function returns the log-likelihood
+ likelihood<-function(C,invC,detC,x,sig2,a,xbar,intV){
+ z<-xbar-a
+ logLik<--z%*%invC%*%z/(2*sig2)-nrow(C)*log(2*pi)/2-nrow(C)*log(sig2)/2-detC/2+sum(dnorm(x,xbar[names(x)],sd=sqrt(intV),log=T))
+ return(logLik)
+ }
+
+ # function returns the log prior probability
+ log.prior<-function(sig2,lambda,a,xbar,intV){
+ pp<-dexp(sig2,rate=1/con$pr.mean[1],log=T)+dunif(lambda,min=con$pr.mean[2]-con$pr.var[2]/2,max=con$pr.mean[2]+con$pr.var[2]/2,log=T)+sum(dnorm(c(a,xbar),mean=con$pr.mean[1+1:(n+1)],sd=sqrt(con$pr.var[1+1:(n+1)]),log=T))+dexp(intV,rate=1/con$pr.mean[length(con$pr.mean)],log=T)
+ return(pp)
+ }
+
+ # compute (starting values for) C
+ C1<-vcv.phylo(tree) # used for updates of lambda
+ C<-lambda.transform(con$lambda,C1)
+ invC<-solve(C)
+ detC<-determinant(C,logarithm=TRUE)$modulus[1]
+
+ # now set starting values for MCMC
+ sig2<-con$sig2; lambda<-con$lambda; a<-con$a; xbar<-con$xbar; intV<-con$intV
+ L<-likelihood(C,invC,detC,x,sig2,a,xbar,intV)
+ Pr<-log.prior(sig2,lambda,a,xbar,intV)
+
+ # store
+ X<-matrix(NA,ngen/con$sample+1,n+6,dimnames=list(NULL,c("gen","sig2","lambda","a",tree$tip.label,"var","logLik")))
+ X[1,]<-c(0,sig2,lambda,a,xbar,intV,L)
+
+ message("Starting MCMC...")
+
+ # start MCMC
+ for(i in 1:ngen){
+ j<-(i-1)%%(n+4)
+ if(j==0){
+ # update sig2
+ sig2.prime<-sig2+rnorm(n=1,sd=sqrt(con$prop[j+1]))
+ if(sig2.prime<0) sig2.prime<--sig2.prime
+ L.prime<-likelihood(C,invC,detC,x,sig2.prime,a,xbar,intV)
+ Pr.prime<-log.prior(sig2.prime,lambda,a,xbar,intV)
+ post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T)
+ if(post.odds>runif(n=1)){
+ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2.prime,lambda,a,xbar,intV,L.prime)
+ sig2<-sig2.prime
+ L<-L.prime
+ Pr<-Pr.prime
+ } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,lambda,a,xbar,intV,L)
+ } else if(j==1){
+ # update lambda
+ lambda.prime<-lambda+rnorm(n=1,sd=sqrt(con$prop[j+1]))
+ while(lambda.prime<0||lambda.prime>max.lambda){
+ if(lambda.prime<0) lambda.prime<--lambda.prime
+ if(lambda.prime>max.lambda) lambda.prime<-2*max.lambda-lambda.prime
+ }
+ # update C with new lambda
+ C.prime<-lambda.transform(lambda.prime,C1)
+ invC.prime<-solve(C.prime)
+ detC.prime<-determinant(C.prime,logarithm=TRUE)$modulus[1]
+ L.prime<-likelihood(C.prime,invC.prime,detC.prime,x,sig2,a,xbar,intV)
+ Pr.prime<-log.prior(sig2,lambda.prime,a,xbar,intV)
+ post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T)
+ if(post.odds>runif(n=1)){
+ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,lambda.prime,a,xbar,intV,L.prime)
+ lambda<-lambda.prime
+ C<-C.prime; invC<-invC.prime; detC<-detC.prime
+ L<-L.prime
+ Pr<-Pr.prime
+ } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,lambda,a,xbar,intV,L)
+ } else if(j==2){
+ # update a
+ a.prime<-a+rnorm(n=1,sd=sqrt(con$prop[j+1]))
+ L.prime<-likelihood(C,invC,detC,x,sig2,a.prime,xbar,intV)
+ Pr.prime<-log.prior(sig2,lambda,a.prime,xbar,intV)
+ post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T)
+ if(post.odds>runif(n=1)){
+ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,lambda,a.prime,xbar,intV,L.prime)
+ a<-a.prime
+ L<-L.prime
+ Pr<-Pr.prime
+ } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,lambda,a,xbar,intV,L)
+ } else if(j>2&&j<=(n+2)) {
+ k<-j-2 # update tip mean k
+ xbar.prime<-xbar
+ xbar.prime[k]<-xbar[k]+rnorm(n=1,sd=sqrt(con$prop[j+1]))
+ L.prime<-likelihood(C,invC,detC,x,sig2,a,xbar.prime,intV)
+ Pr.prime<-log.prior(sig2,lambda,a,xbar.prime,intV)
+ post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T)
+ if(post.odds>runif(n=1)){
+ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,lambda,a,xbar.prime,intV,L.prime)
+ xbar<-xbar.prime
+ L<-L.prime
+ Pr<-Pr.prime
+ } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,lambda,a,xbar,intV,L)
+ } else if(j>(n+2)){
+ # update var
+ intV.prime<-intV+rnorm(n=1,sd=sqrt(con$prop[j+1]))
+ if(intV.prime<0) intV.prime<--intV.prime
+ L.prime<-likelihood(C,invC,detC,x,sig2,a,xbar,intV.prime)
+ Pr.prime<-log.prior(sig2,lambda,a,xbar,intV.prime)
+ post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T)
+ if(post.odds>runif(n=1)){
+ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,lambda,a,xbar,intV.prime,L.prime)
+ intV<-intV.prime
+ L<-L.prime
+ Pr<-Pr.prime
+ } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,lambda,a,xbar,intV,L)
+ }
+ }
+
+ # done MCMC
+ message("Done MCMC.")
+ return(X)
+}
+
diff --git a/R/mcmcMk.R b/R/mcmcMk.R
index 97bbe1d..6b3b10c 100644
--- a/R/mcmcMk.R
+++ b/R/mcmcMk.R
@@ -1,389 +1,389 @@
-## written by Liam J. Revell
-
-mtom<-function(model){
- model<-t(model)
- im<-matrix(NA,nrow(model),ncol(model))
- indices<-setNames(1:length(unique(as.vector(model)))-1,
- unique(as.vector(model)))
- for(i in 1:length(as.vector(model)))
- im[i]<-indices[as.character(model[i])]
- t(im)
-}
-
-minChanges<-function(tree,x){
- if(is.matrix(x))
- x<-as.factor(apply(x,1,function(x) names(which(x==max(x)))[1]))
- parsimony(tree,as.phyDat(x))
-}
-
-makeq<-function(Q,index.matrix){
- q<-vector(length=max(index.matrix,na.rm=TRUE),mode="numeric")
- for(i in 1:length(q)) q[i]<-Q[match(i,index.matrix)]
- q
-}
-
-mcmcMk<-function(tree,x,model="ER",ngen=10000,...){
- if(hasArg(plot)) plot<-list(...)$plot
- else plot<-TRUE
- log.prior<-function(x,prior) sum(dgamma(x,shape=prior$alpha,rate=prior$beta,log=TRUE))
- proposal<-function(q,pv) abs(q+rnorm(n=length(q),sd=sqrt(pv)))
- if(hasArg(q)) q<-list(...)$q
- else q<-minChanges(tree,x)/sum(tree$edge.length)
- if(hasArg(prop.var)) prop.var<-list(...)$prop.var
- else prop.var<-1/max(nodeHeights(tree))
- if(hasArg(auto.tune)) auto.tune<-list(...)$auto.tune
- else auto.tune<-TRUE
- if(is.numeric(auto.tune)){
- target.accept<-auto.tune
- auto.tune<-TRUE
- } else target.accept<-0.5
- if(hasArg(prior)) prior<-list(...)$prior
- else prior<-NULL
- if(hasArg(print)) print<-list(...)$print
- else print<-100
- if(hasArg(likelihood)) likelihood<-list(...)$likelihood
- else {
- if(.check.pkg("geiger")) likelihood<-"fitDiscrete"
- else likelihood<-"fitMk"
- }
- if(likelihood=="fitDiscrete"){
- if(.check.pkg("geiger")==FALSE){
- cat("geiger is not installed. Setting likelihood method to \"fitMk\".\n\n")
- likelihood<-"fitMk"
- fitDiscrete<-function(...) NULL
- } else if(is.matrix(x)){
- cat("likelihood=\"fitDiscrete\" doesn't work for data input as matrix.\n")
- cat("Setting likelihood method to \"fitMk\".\n\n")
- fitDiscrete<-function(...) NULL
- }
- }
- if(is.matrix(x)){
- x<-x[tree$tip.label,]
- m<-ncol(x)
- states<-colnames(x)
- } else {
- y<-x
- x<-to.matrix(x,sort(unique(x)))
- x<-x[tree$tip.label,]
- m<-ncol(x)
- states<-colnames(x)
- }
- if(hasArg(pi)) pi<-list(...)$pi
- else pi<-"equal"
- if(pi[1]=="equal") pi<-setNames(rep(1/m,m),states)
- else pi<-pi/sum(pi)
- if(is.character(model)){
- rate<-matrix(NA,m,m)
- if(model=="ER"){
- k<-rate[]<-1
- diag(rate)<-NA
- } else if(model=="ARD"){
- k<-m*(m-1)
- rate[col(rate)!=row(rate)]<-1:k
- } else if(model=="SYM"){
- k<-m*(m-1)/2
- ii<-col(rate)<row(rate)
- rate[ii]<-1:k
- rate<-t(rate)
- rate[ii]<-1:k
- }
- rate<-t(rate)
- } else {
- if(ncol(model)!=nrow(model))
- stop("model is not a square matrix")
- if(ncol(model)!=ncol(x))
- stop("model does not have the right number of columns")
- model<-mtom(model)
- rate<-model
- k<-max(rate)
- }
- index.matrix<-rate
- if(length(q)!=k) q<-rep(q[1],k)
- if(length(prop.var)!=k) prop.var<-rep(prop.var[1],k)
- default.alpha<-0.1
- if(is.null(prior)){
- prior<-list(
- alpha=rep(default.alpha,k),
- beta=rep(default.alpha*sum(tree$edge.length)/minChanges(tree,x),k)
- )
- } else if(is.list(prior)){
- if(is.null(prior$alpha)) prior$alpha<-rep(default.alpha,k)
- else if(is.null(prior$beta))
- prior$beta<-rep(prior$alpha*sum(tree$edge.length)/minChanges(tree,x),k)
- } else if(is.numeric(prior)){
- if(length(prior)==1)
- prior<-list(alpha=rep(prior,k),
- beta=rep(prior*sum(tree$edge.length)/minChanges(tree,x),k))
- else if(length(prior)==2)
- prior<-list(alpha=rep(prior[1],k),beta=rep(prior[2],k))
- }
- if(likelihood=="fitDiscrete"){
- LIK<-fitDiscrete(tree,y,model=model,niter=1)$lik
- lik.func<-function(Q) LIK(makeq(Q,index.matrix),root="given",root.p=pi)
- } else lik.func<-fitMk(tree,x,fixedQ=makeQ(m,q,index.matrix),pi=pi)$lik
- likQ<-lik.func(makeQ(m,q,index.matrix))
- nn<-vector(length=k,mode="character")
- for(i in 1:k) nn[i]<-paste("[",paste(states[which(rate==i,arr.ind=TRUE)[1,]],
- collapse=","),"]",sep="")
- PS<-matrix(NA,ngen,k+2,dimnames=list(1:ngen,c("gen",nn,"logLik")))
- PS[1,]<-c(1,q,likQ)
- cat("Running MCMC....\n")
- accept<-0
- if(print){
- cat(paste(paste(colnames(PS),collapse=" \t"),"\taccept\n",sep=""))
- i<-1
- cat(paste(round(PS[i,1]),paste(round(PS[i,1:k+1],4),collapse="\t"),
- round(PS[i,ncol(PS)],4),sep="\t"))
- cat("\n")
- }
- flush.console()
- qp<-q
- for(i in 2:ngen){
- qp[i%%k+1]<-proposal(q[i%%k+1],prop.var[i%%k+1])
- likQp<-lik.func(makeQ(m,qp,index.matrix))
- por<-exp(likQp-likQ+log.prior(qp,prior)-log.prior(q,prior))
- if(por>runif(n=1)){
- q<-qp
- likQ<-likQp
- accept<-accept+1/100
- }
- PS[i,]<-c(i,q,likQ)
- if(print) if(i%%print==1){
- cat(paste(round(PS[i,1]),paste(round(PS[i,1:k+1],4),collapse="\t"),
- round(PS[i,ncol(PS)],4),round(accept,3),sep="\t"))
- cat("\n")
- flush.console()
- }
- if(i%%100==1){
- if(auto.tune)
- prop.var<-if(accept>target.accept) 1.1*prop.var else prop.var/1.1
- accept<-0
- }
- if(plot){
- dev.hold()
- par(mfrow=c(2,1),mar=c(5.1,4.1,2.1,1.1))
- plot(1:i,PS[1:i,"logLik"],col="darkgrey",xlab="",
- ylab="log(L)",xlim=c(0,ngen),type="l",bty="l")
- mtext("a) log-likelihood profile plot",side=3,line=1,cex=1,
- at=0,outer=FALSE,adj=0)
- plot(1:i,PS[1:i,2],col=Palette(1),
- xlab="generation",xlim=c(0,ngen),
- ylim=c(0,max(PS[1:i,2:(ncol(PS)-1)])),
- ylab="q",type="l",bty="l")
- abline(h=mean(PS[1:i,2]),lty="dotted",col=Palette(1))
- text(x=ngen,y=mean(PS[1:i,2]),colnames(PS)[2],cex=0.5,
- col=Palette(1),pos=3)
- if(length(q)>1){
- for(j in 2:length(q)){
- lines(1:i,PS[1:i,j+1],col=Palette(j))
- abline(h=mean(PS[1:i,j+1]),lty="dotted",col=Palette(j))
- text(x=ngen,y=mean(PS[1:i,j+1]),colnames(PS)[j+1],
- cex=0.5,col=Palette(j),pos=3)
- }
- }
- mtext("b) rates",side=3,line=1,cex=1,at=0,outer=FALSE,adj=0)
- dev.flush()
- }
- }
- cat("Done.\n")
- class(PS)<-"mcmcMk"
- attr(PS,"model")<-model
- attr(PS,"index.matrix")<-index.matrix
- attr(PS,"states")<-states
- PS
-}
-
-Palette<-function(i){
- if(!.check.pkg("RColorBrewer")){
- brewer.pal<-function(...) NULL
- COLOR<-rep(palette(),ceiling(i/8))[i]
- COLOR<-if(COLOR=="black") "darkgrey"
- } else COLOR<-rep(brewer.pal(8,"Accent"),ceiling(i/8))[i]
- COLOR
-}
-
-print.mcmcMk<-function(x,...){
- cat("\nPosterior sample from mcmcMk consisting of a posterior sample obtained using\n")
- cat("Bayesian MCMC in the form of a matrix.\n\n")
- cat("1. plot(\'object_name\') will create a likelihood profile plot.\n")
- cat("2. summary(\'object_name\') will compute a summary of the MCMC.\n")
- cat("3. density(\'object_name\') will calculate a posterior density from the sample.\n")
- cat("4. Finally, plot(density(\'object_name\')) will plot the posterior density and\n")
- cat(" and high probability density intervals.\n\n")
- cat("To work best, we recommend users install the package \'coda\'.\n\n")
-}
-
-plot.mcmcMk<-function(x,...){
- par(mfrow=c(2,1),mar=c(5.1,4.1,2.1,1.1))
- plot(x[,"gen"],x[,"logLik"],col="darkgrey",xlab="",
- ylab="log(L)",type="l",bty="l")
- mtext("a) log-likelihood profile plot",side=3,line=1,cex=1,
- at=0,outer=FALSE,adj=0)
- plot(x[,"gen"],x[,2],col=Palette(1),xlab="generation",
- ylim=c(0,max(x[,2:(ncol(x)-1)])),ylab="q",type="l",
- bty="l")
- abline(h=mean(x[,2]),lty="dotted",col=Palette(1))
- text(x=max(x[,"gen"]),y=mean(x[,2]),colnames(x)[2],cex=0.5,
- col=Palette(1),pos=3)
- if(ncol(x)>3){
- for(j in 2:(ncol(x)-2)){
- lines(x[,"gen"],x[,j+1],col=Palette(j))
- abline(h=mean(x[,j+1]),lty="dotted",col=Palette(j))
- text(x=max(x[,"gen"]),y=mean(x[,j+1]),colnames(x)[j+1],
- cex=0.5,col=Palette(j),pos=3)
- }
- }
- mtext("b) rates",side=3,line=1,cex=1,at=0,outer=FALSE,adj=0)
-}
-
-summary.mcmcMk<-function(object,...){
- if(hasArg(burnin)) burnin<-list(...)$burnin
- else {
- burnin<-floor(0.2*nrow(object))
- cat("Assuming 20% burn-in as no burn-in was specified....\n\n")
- }
- ii<-which((object[,"gen"]-burnin)^2==min((object[,"gen"]-burnin)^2))
- PD<-object[(ii+1):nrow(object),]
- ## compute the average value of Q
- Q<-makeQ(length(attr(object,"states")),
- colMeans(PD[,2:(ncol(object)-1),drop=FALSE]),
- attr(object,"index.matrix"))
- colnames(Q)<-rownames(Q)<-attr(object,"states")
- ## print Q
- cat("Mean value of Q from the post burn-in posterior sample:\n")
- print(Q)
- ## compute the median value of Q
- median.Q<-makeQ(length(attr(object,"states")),
- apply(PD[,2:(ncol(object)-1),drop=FALSE],2,median),
- attr(object,"index.matrix"))
- colnames(median.Q)<-rownames(median.Q)<-attr(object,"states")
- ## print Q
- cat("\nMedian value of Q from the post burn-in posterior sample:\n")
- print(median.Q)
- if(.check.pkg("coda")){
- hpd95<-function(x) HPDinterval(as.mcmc(x))
- } else {
- cat(" HPDinterval requires package coda.\n")
- cat(" Computing 95% interval from samples only.\n\n")
- hpd95<-function(x){
- obj<-setNames(c(sort(x)[round(0.025*length(x))],
- sort(x)[round(0.975*length(x))]),
- c("lower","upper"))
- attr(obj,"Probability")<-0.95
- obj
- }
- }
- HPD<-t(apply(PD[,2:(ncol(object)-1),drop=FALSE],2,hpd95))
- colnames(HPD)<-c("lower","upper")
- cat("\n95% HPD interval computed either from the post burn-in\nsamples or using \'coda\':\n")
- print(HPD)
- cat("\n")
- object<-list(mean.Q=Q,median.Q=median.Q,HPD95=HPD)
- class(object)<-"summary.mcmcMk"
- invisible(object)
-}
-
-density.mcmcMk<-function(x,...){
- if(hasArg(burnin)) burnin<-list(...)$burnin
- else {
- burnin<-floor(0.2*nrow(x))
- cat("Assuming 20% burn-in as no burn-in was specified....\n")
- }
- ii<-which((x[,"gen"]-burnin)^2==min((x[,"gen"]-burnin)^2))
- PD<-x[(ii+1):nrow(x),]
- if(hasArg(bw)) bw<-list(...)$bw
- else bw<-rep("nrd0",ncol(x)-2)
- if(length(bw)==1) bw<-rep(bw,ncol(x)-2)
- d<-list()
- for(i in 2:(ncol(PD)-1))
- d[[i-1]]<-density(PD[,i],bw=bw[i-1])
- class(d)<-"density.mcmcMk"
- names(d)<-paste("Density",colnames(x)[2:(ncol(x)-1)])
- attr(d,"model")<-attr(x,"model")
- attr(d,"index.matrix")<-attr(x,"index.matrix")
- attr(d,"states")<-attr(x,"states")
- nulo<-capture.output(attr(d,"summary")<-summary(x,...))
- d
-}
-
-print.density.mcmcMk<-function(x, digits=NULL, ...){
- for(i in 1:length(x)){
- cat(paste("\n",names(x)[1],"\n\n"))
- print(summary(as.data.frame(x[[1]][c("x", "y")])),
- digits = digits, ...)
- }
- cat("\n")
- cat("To plot enter plot(\'object_name\') at the command line interface.\n\n")
- invisible(x)
-}
-
-plot.density.mcmcMk<-function(x,...){
- if(hasArg(show.matrix)) show.matrix<-list(...)$show.matrix
- else show.matrix<-FALSE
- if(hasArg(xlim)) xlim<-list(...)$xlim
- else xlim<-range(sapply(x,function(x) x$x))
- if(hasArg(ylim)) ylim<-list(...)$ylim
- else ylim<-c(0,1.1*max(sapply(x,function(x) x$y)))
- if(length(x)==1){
- if(hasArg(main)) main<-list(...)$main
- else main<-"estimated posterior density for q"
- plot(x[[1]],main=main,
- bty="l",font.main=1,xlim=xlim,ylim=ylim,
- xlab="q",bty="l")
- polygon(x[[1]],col=make.transparent("blue",0.5))
- lines(x=attr(x,"summary")$HPD95[1,],y=rep(1.01*max(x[[1]]$y),2))
- text(x=mean(attr(x,"summary")$HPD95[1,]),
- y=1.01*max(x[[1]]$y),"95% HPD",pos=3)
- } else if(length(x)==2&&show.matrix==FALSE){
- if(hasArg(main)) main<-list(...)$main
- else main<-expression(paste("estimated posterior density for ",
- Q[ij]))
- plot(x[[1]],xlim=xlim,ylim=ylim,
- main=main,xlab="q",bty="l")
- polygon(x[[1]],col=make.transparent("blue",0.25))
- lines(x=attr(x,"summary")$HPD95[1,],
- y=rep(max(x[[1]]$y),2)+0.01*diff(ylim))
- text(x=mean(attr(x,"summary")$HPD95[1,]),
- y=max(x[[1]]$y)+0.01*diff(ylim),paste("95% HPD",
- rownames(attr(x,"summary")$HPD95)[1]),pos=3)
- lines(x[[2]])
- polygon(x[[2]],col=make.transparent("red",0.25))
- lines(x=attr(x,"summary")$HPD95[2,],
- y=rep(max(x[[2]]$y),2)+0.01*diff(ylim))
- text(x=mean(attr(x,"summary")$HPD95[2,]),
- y=max(x[[2]]$y)+0.01*diff(ylim),paste("95% HPD",
- rownames(attr(x,"summary")$HPD95)[2]),pos=3)
- nam.legend<-sapply(strsplit(names(x),"Density "),function(x) x[2])
- legend(x="topright",legend=nam.legend,bty="n",pt.cex=2,pch=22,
- pt.bg=c(make.transparent("blue",0.25),make.transparent("red",
- 0.25)))
- } else {
- k<-length(attr(x,"states"))
- par(mfrow=c(k,k))
- NAMES<-sapply(strsplit(names(x),"Density "),function(x) x[2])
- NAMES<-sapply(strsplit(NAMES,""),function(x) paste(x[2:(length(x)-1)],
- collapse=""))
- s.i<-sapply(strsplit(NAMES,","),function(x) x[1])
- s.j<-sapply(strsplit(NAMES,","),function(x) x[2])
- for(i in 1:k){
- for(j in 1:k){
- ii<-intersect(which(s.i==attr(x,"states")[i]),
- which(s.j==attr(x,"states")[j]))
- if(length(ii)==0) {
- plot(c(0,1),c(1,0),type="l",lty="dotted",xaxt="n",yaxt="n",
- xlab="",ylab="")
- } else {
- plot(x[[ii]],xlim=xlim,ylim=ylim,
- main=paste("estimated posterior density for Q[",
- s.i[ii],",",s.j[ii],"]",sep=""),xlab="q",bty="l",
- font.main=1,cex.main=1,mar=c(4.1,4.1,3.1,1.1))
- polygon(x[[ii]],col=make.transparent("blue",0.25))
- lines(x=attr(x,"summary")$HPD95[ii,],
- y=rep(max(x[[ii]]$y),2)+0.01*diff(ylim))
- text(x=mean(attr(x,"summary")$HPD95[ii,]),
- y=max(x[[ii]]$y)+0.01*diff(ylim),"95% HPD",pos=3)
- }
- }
- }
- }
+## written by Liam J. Revell
+
+mtom<-function(model){
+ model<-t(model)
+ im<-matrix(NA,nrow(model),ncol(model))
+ indices<-setNames(1:length(unique(as.vector(model)))-1,
+ unique(as.vector(model)))
+ for(i in 1:length(as.vector(model)))
+ im[i]<-indices[as.character(model[i])]
+ t(im)
+}
+
+minChanges<-function(tree,x){
+ if(is.matrix(x))
+ x<-as.factor(apply(x,1,function(x) names(which(x==max(x)))[1]))
+ parsimony(tree,as.phyDat(x))
+}
+
+makeq<-function(Q,index.matrix){
+ q<-vector(length=max(index.matrix,na.rm=TRUE),mode="numeric")
+ for(i in 1:length(q)) q[i]<-Q[match(i,index.matrix)]
+ q
+}
+
+mcmcMk<-function(tree,x,model="ER",ngen=10000,...){
+ if(hasArg(plot)) plot<-list(...)$plot
+ else plot<-TRUE
+ log.prior<-function(x,prior) sum(dgamma(x,shape=prior$alpha,rate=prior$beta,log=TRUE))
+ proposal<-function(q,pv) abs(q+rnorm(n=length(q),sd=sqrt(pv)))
+ if(hasArg(q)) q<-list(...)$q
+ else q<-minChanges(tree,x)/sum(tree$edge.length)
+ if(hasArg(prop.var)) prop.var<-list(...)$prop.var
+ else prop.var<-1/max(nodeHeights(tree))
+ if(hasArg(auto.tune)) auto.tune<-list(...)$auto.tune
+ else auto.tune<-TRUE
+ if(is.numeric(auto.tune)){
+ target.accept<-auto.tune
+ auto.tune<-TRUE
+ } else target.accept<-0.5
+ if(hasArg(prior)) prior<-list(...)$prior
+ else prior<-NULL
+ if(hasArg(print)) print<-list(...)$print
+ else print<-100
+ if(hasArg(likelihood)) likelihood<-list(...)$likelihood
+ else {
+ if(.check.pkg("geiger")) likelihood<-"fitDiscrete"
+ else likelihood<-"fitMk"
+ }
+ if(likelihood=="fitDiscrete"){
+ if(.check.pkg("geiger")==FALSE){
+ cat("geiger is not installed. Setting likelihood method to \"fitMk\".\n\n")
+ likelihood<-"fitMk"
+ fitDiscrete<-function(...) NULL
+ } else if(is.matrix(x)){
+ cat("likelihood=\"fitDiscrete\" doesn't work for data input as matrix.\n")
+ cat("Setting likelihood method to \"fitMk\".\n\n")
+ fitDiscrete<-function(...) NULL
+ }
+ }
+ if(is.matrix(x)){
+ x<-x[tree$tip.label,]
+ m<-ncol(x)
+ states<-colnames(x)
+ } else {
+ y<-x
+ x<-to.matrix(x,sort(unique(x)))
+ x<-x[tree$tip.label,]
+ m<-ncol(x)
+ states<-colnames(x)
+ }
+ if(hasArg(pi)) pi<-list(...)$pi
+ else pi<-"equal"
+ if(pi[1]=="equal") pi<-setNames(rep(1/m,m),states)
+ else pi<-pi/sum(pi)
+ if(is.character(model)){
+ rate<-matrix(NA,m,m)
+ if(model=="ER"){
+ k<-rate[]<-1
+ diag(rate)<-NA
+ } else if(model=="ARD"){
+ k<-m*(m-1)
+ rate[col(rate)!=row(rate)]<-1:k
+ } else if(model=="SYM"){
+ k<-m*(m-1)/2
+ ii<-col(rate)<row(rate)
+ rate[ii]<-1:k
+ rate<-t(rate)
+ rate[ii]<-1:k
+ }
+ rate<-t(rate)
+ } else {
+ if(ncol(model)!=nrow(model))
+ stop("model is not a square matrix")
+ if(ncol(model)!=ncol(x))
+ stop("model does not have the right number of columns")
+ model<-mtom(model)
+ rate<-model
+ k<-max(rate)
+ }
+ index.matrix<-rate
+ if(length(q)!=k) q<-rep(q[1],k)
+ if(length(prop.var)!=k) prop.var<-rep(prop.var[1],k)
+ default.alpha<-0.1
+ if(is.null(prior)){
+ prior<-list(
+ alpha=rep(default.alpha,k),
+ beta=rep(default.alpha*sum(tree$edge.length)/minChanges(tree,x),k)
+ )
+ } else if(is.list(prior)){
+ if(is.null(prior$alpha)) prior$alpha<-rep(default.alpha,k)
+ else if(is.null(prior$beta))
+ prior$beta<-rep(prior$alpha*sum(tree$edge.length)/minChanges(tree,x),k)
+ } else if(is.numeric(prior)){
+ if(length(prior)==1)
+ prior<-list(alpha=rep(prior,k),
+ beta=rep(prior*sum(tree$edge.length)/minChanges(tree,x),k))
+ else if(length(prior)==2)
+ prior<-list(alpha=rep(prior[1],k),beta=rep(prior[2],k))
+ }
+ if(likelihood=="fitDiscrete"){
+ LIK<-fitDiscrete(tree,y,model=model,niter=1)$lik
+ lik.func<-function(Q) LIK(makeq(Q,index.matrix),root="given",root.p=pi)
+ } else lik.func<-fitMk(tree,x,fixedQ=makeQ(m,q,index.matrix),pi=pi)$lik
+ likQ<-lik.func(makeQ(m,q,index.matrix))
+ nn<-vector(length=k,mode="character")
+ for(i in 1:k) nn[i]<-paste("[",paste(states[which(rate==i,arr.ind=TRUE)[1,]],
+ collapse=","),"]",sep="")
+ PS<-matrix(NA,ngen,k+2,dimnames=list(1:ngen,c("gen",nn,"logLik")))
+ PS[1,]<-c(1,q,likQ)
+ cat("Running MCMC....\n")
+ accept<-0
+ if(print){
+ cat(paste(paste(colnames(PS),collapse=" \t"),"\taccept\n",sep=""))
+ i<-1
+ cat(paste(round(PS[i,1]),paste(round(PS[i,1:k+1],4),collapse="\t"),
+ round(PS[i,ncol(PS)],4),sep="\t"))
+ cat("\n")
+ }
+ flush.console()
+ qp<-q
+ for(i in 2:ngen){
+ qp[i%%k+1]<-proposal(q[i%%k+1],prop.var[i%%k+1])
+ likQp<-lik.func(makeQ(m,qp,index.matrix))
+ por<-exp(likQp-likQ+log.prior(qp,prior)-log.prior(q,prior))
+ if(por>runif(n=1)){
+ q<-qp
+ likQ<-likQp
+ accept<-accept+1/100
+ }
+ PS[i,]<-c(i,q,likQ)
+ if(print) if(i%%print==1){
+ cat(paste(round(PS[i,1]),paste(round(PS[i,1:k+1],4),collapse="\t"),
+ round(PS[i,ncol(PS)],4),round(accept,3),sep="\t"))
+ cat("\n")
+ flush.console()
+ }
+ if(i%%100==1){
+ if(auto.tune)
+ prop.var<-if(accept>target.accept) 1.1*prop.var else prop.var/1.1
+ accept<-0
+ }
+ if(plot){
+ dev.hold()
+ par(mfrow=c(2,1),mar=c(5.1,4.1,2.1,1.1))
+ plot(1:i,PS[1:i,"logLik"],col="darkgrey",xlab="",
+ ylab="log(L)",xlim=c(0,ngen),type="l",bty="l")
+ mtext("a) log-likelihood profile plot",side=3,line=1,cex=1,
+ at=0,outer=FALSE,adj=0)
+ plot(1:i,PS[1:i,2],col=Palette(1),
+ xlab="generation",xlim=c(0,ngen),
+ ylim=c(0,max(PS[1:i,2:(ncol(PS)-1)])),
+ ylab="q",type="l",bty="l")
+ abline(h=mean(PS[1:i,2]),lty="dotted",col=Palette(1))
+ text(x=ngen,y=mean(PS[1:i,2]),colnames(PS)[2],cex=0.5,
+ col=Palette(1),pos=3)
+ if(length(q)>1){
+ for(j in 2:length(q)){
+ lines(1:i,PS[1:i,j+1],col=Palette(j))
+ abline(h=mean(PS[1:i,j+1]),lty="dotted",col=Palette(j))
+ text(x=ngen,y=mean(PS[1:i,j+1]),colnames(PS)[j+1],
+ cex=0.5,col=Palette(j),pos=3)
+ }
+ }
+ mtext("b) rates",side=3,line=1,cex=1,at=0,outer=FALSE,adj=0)
+ dev.flush()
+ }
+ }
+ cat("Done.\n")
+ class(PS)<-"mcmcMk"
+ attr(PS,"model")<-model
+ attr(PS,"index.matrix")<-index.matrix
+ attr(PS,"states")<-states
+ PS
+}
+
+Palette<-function(i){
+ if(!.check.pkg("RColorBrewer")){
+ brewer.pal<-function(...) NULL
+ COLOR<-rep(palette(),ceiling(i/8))[i]
+ COLOR<-if(COLOR=="black") "darkgrey"
+ } else COLOR<-rep(brewer.pal(8,"Accent"),ceiling(i/8))[i]
+ COLOR
+}
+
+print.mcmcMk<-function(x,...){
+ cat("\nPosterior sample from mcmcMk consisting of a posterior sample obtained using\n")
+ cat("Bayesian MCMC in the form of a matrix.\n\n")
+ cat("1. plot(\'object_name\') will create a likelihood profile plot.\n")
+ cat("2. summary(\'object_name\') will compute a summary of the MCMC.\n")
+ cat("3. density(\'object_name\') will calculate a posterior density from the sample.\n")
+ cat("4. Finally, plot(density(\'object_name\')) will plot the posterior density and\n")
+ cat(" and high probability density intervals.\n\n")
+ cat("To work best, we recommend users install the package \'coda\'.\n\n")
+}
+
+plot.mcmcMk<-function(x,...){
+ par(mfrow=c(2,1),mar=c(5.1,4.1,2.1,1.1))
+ plot(x[,"gen"],x[,"logLik"],col="darkgrey",xlab="",
+ ylab="log(L)",type="l",bty="l")
+ mtext("a) log-likelihood profile plot",side=3,line=1,cex=1,
+ at=0,outer=FALSE,adj=0)
+ plot(x[,"gen"],x[,2],col=Palette(1),xlab="generation",
+ ylim=c(0,max(x[,2:(ncol(x)-1)])),ylab="q",type="l",
+ bty="l")
+ abline(h=mean(x[,2]),lty="dotted",col=Palette(1))
+ text(x=max(x[,"gen"]),y=mean(x[,2]),colnames(x)[2],cex=0.5,
+ col=Palette(1),pos=3)
+ if(ncol(x)>3){
+ for(j in 2:(ncol(x)-2)){
+ lines(x[,"gen"],x[,j+1],col=Palette(j))
+ abline(h=mean(x[,j+1]),lty="dotted",col=Palette(j))
+ text(x=max(x[,"gen"]),y=mean(x[,j+1]),colnames(x)[j+1],
+ cex=0.5,col=Palette(j),pos=3)
+ }
+ }
+ mtext("b) rates",side=3,line=1,cex=1,at=0,outer=FALSE,adj=0)
+}
+
+summary.mcmcMk<-function(object,...){
+ if(hasArg(burnin)) burnin<-list(...)$burnin
+ else {
+ burnin<-floor(0.2*nrow(object))
+ cat("Assuming 20% burn-in as no burn-in was specified....\n\n")
+ }
+ ii<-which((object[,"gen"]-burnin)^2==min((object[,"gen"]-burnin)^2))
+ PD<-object[(ii+1):nrow(object),]
+ ## compute the average value of Q
+ Q<-makeQ(length(attr(object,"states")),
+ colMeans(PD[,2:(ncol(object)-1),drop=FALSE]),
+ attr(object,"index.matrix"))
+ colnames(Q)<-rownames(Q)<-attr(object,"states")
+ ## print Q
+ cat("Mean value of Q from the post burn-in posterior sample:\n")
+ print(Q)
+ ## compute the median value of Q
+ median.Q<-makeQ(length(attr(object,"states")),
+ apply(PD[,2:(ncol(object)-1),drop=FALSE],2,median),
+ attr(object,"index.matrix"))
+ colnames(median.Q)<-rownames(median.Q)<-attr(object,"states")
+ ## print Q
+ cat("\nMedian value of Q from the post burn-in posterior sample:\n")
+ print(median.Q)
+ if(.check.pkg("coda")){
+ hpd95<-function(x) HPDinterval(as.mcmc(x))
+ } else {
+ cat(" HPDinterval requires package coda.\n")
+ cat(" Computing 95% interval from samples only.\n\n")
+ hpd95<-function(x){
+ obj<-setNames(c(sort(x)[round(0.025*length(x))],
+ sort(x)[round(0.975*length(x))]),
+ c("lower","upper"))
+ attr(obj,"Probability")<-0.95
+ obj
+ }
+ }
+ HPD<-t(apply(PD[,2:(ncol(object)-1),drop=FALSE],2,hpd95))
+ colnames(HPD)<-c("lower","upper")
+ cat("\n95% HPD interval computed either from the post burn-in\nsamples or using \'coda\':\n")
+ print(HPD)
+ cat("\n")
+ object<-list(mean.Q=Q,median.Q=median.Q,HPD95=HPD)
+ class(object)<-"summary.mcmcMk"
+ invisible(object)
+}
+
+density.mcmcMk<-function(x,...){
+ if(hasArg(burnin)) burnin<-list(...)$burnin
+ else {
+ burnin<-floor(0.2*nrow(x))
+ cat("Assuming 20% burn-in as no burn-in was specified....\n")
+ }
+ ii<-which((x[,"gen"]-burnin)^2==min((x[,"gen"]-burnin)^2))
+ PD<-x[(ii+1):nrow(x),]
+ if(hasArg(bw)) bw<-list(...)$bw
+ else bw<-rep("nrd0",ncol(x)-2)
+ if(length(bw)==1) bw<-rep(bw,ncol(x)-2)
+ d<-list()
+ for(i in 2:(ncol(PD)-1))
+ d[[i-1]]<-density(PD[,i],bw=bw[i-1])
+ class(d)<-"density.mcmcMk"
+ names(d)<-paste("Density",colnames(x)[2:(ncol(x)-1)])
+ attr(d,"model")<-attr(x,"model")
+ attr(d,"index.matrix")<-attr(x,"index.matrix")
+ attr(d,"states")<-attr(x,"states")
+ nulo<-capture.output(attr(d,"summary")<-summary(x,...))
+ d
+}
+
+print.density.mcmcMk<-function(x, digits=NULL, ...){
+ for(i in 1:length(x)){
+ cat(paste("\n",names(x)[1],"\n\n"))
+ print(summary(as.data.frame(x[[1]][c("x", "y")])),
+ digits = digits, ...)
+ }
+ cat("\n")
+ cat("To plot enter plot(\'object_name\') at the command line interface.\n\n")
+ invisible(x)
+}
+
+plot.density.mcmcMk<-function(x,...){
+ if(hasArg(show.matrix)) show.matrix<-list(...)$show.matrix
+ else show.matrix<-FALSE
+ if(hasArg(xlim)) xlim<-list(...)$xlim
+ else xlim<-range(sapply(x,function(x) x$x))
+ if(hasArg(ylim)) ylim<-list(...)$ylim
+ else ylim<-c(0,1.1*max(sapply(x,function(x) x$y)))
+ if(length(x)==1){
+ if(hasArg(main)) main<-list(...)$main
+ else main<-"estimated posterior density for q"
+ plot(x[[1]],main=main,
+ bty="l",font.main=1,xlim=xlim,ylim=ylim,
+ xlab="q",bty="l")
+ polygon(x[[1]],col=make.transparent("blue",0.5))
+ lines(x=attr(x,"summary")$HPD95[1,],y=rep(1.01*max(x[[1]]$y),2))
+ text(x=mean(attr(x,"summary")$HPD95[1,]),
+ y=1.01*max(x[[1]]$y),"95% HPD",pos=3)
+ } else if(length(x)==2&&show.matrix==FALSE){
+ if(hasArg(main)) main<-list(...)$main
+ else main<-expression(paste("estimated posterior density for ",
+ Q[ij]))
+ plot(x[[1]],xlim=xlim,ylim=ylim,
+ main=main,xlab="q",bty="l")
+ polygon(x[[1]],col=make.transparent("blue",0.25))
+ lines(x=attr(x,"summary")$HPD95[1,],
+ y=rep(max(x[[1]]$y),2)+0.01*diff(ylim))
+ text(x=mean(attr(x,"summary")$HPD95[1,]),
+ y=max(x[[1]]$y)+0.01*diff(ylim),paste("95% HPD",
+ rownames(attr(x,"summary")$HPD95)[1]),pos=3)
+ lines(x[[2]])
+ polygon(x[[2]],col=make.transparent("red",0.25))
+ lines(x=attr(x,"summary")$HPD95[2,],
+ y=rep(max(x[[2]]$y),2)+0.01*diff(ylim))
+ text(x=mean(attr(x,"summary")$HPD95[2,]),
+ y=max(x[[2]]$y)+0.01*diff(ylim),paste("95% HPD",
+ rownames(attr(x,"summary")$HPD95)[2]),pos=3)
+ nam.legend<-sapply(strsplit(names(x),"Density "),function(x) x[2])
+ legend(x="topright",legend=nam.legend,bty="n",pt.cex=2,pch=22,
+ pt.bg=c(make.transparent("blue",0.25),make.transparent("red",
+ 0.25)))
+ } else {
+ k<-length(attr(x,"states"))
+ par(mfrow=c(k,k))
+ NAMES<-sapply(strsplit(names(x),"Density "),function(x) x[2])
+ NAMES<-sapply(strsplit(NAMES,""),function(x) paste(x[2:(length(x)-1)],
+ collapse=""))
+ s.i<-sapply(strsplit(NAMES,","),function(x) x[1])
+ s.j<-sapply(strsplit(NAMES,","),function(x) x[2])
+ for(i in 1:k){
+ for(j in 1:k){
+ ii<-intersect(which(s.i==attr(x,"states")[i]),
+ which(s.j==attr(x,"states")[j]))
+ if(length(ii)==0) {
+ plot(c(0,1),c(1,0),type="l",lty="dotted",xaxt="n",yaxt="n",
+ xlab="",ylab="")
+ } else {
+ plot(x[[ii]],xlim=xlim,ylim=ylim,
+ main=paste("estimated posterior density for Q[",
+ s.i[ii],",",s.j[ii],"]",sep=""),xlab="q",bty="l",
+ font.main=1,cex.main=1,mar=c(4.1,4.1,3.1,1.1))
+ polygon(x[[ii]],col=make.transparent("blue",0.25))
+ lines(x=attr(x,"summary")$HPD95[ii,],
+ y=rep(max(x[[ii]]$y),2)+0.01*diff(ylim))
+ text(x=mean(attr(x,"summary")$HPD95[ii,]),
+ y=max(x[[ii]]$y)+0.01*diff(ylim),"95% HPD",pos=3)
+ }
+ }
+ }
+ }
}
\ No newline at end of file
diff --git a/R/mrp.supertree.R b/R/mrp.supertree.R
index 319392c..e3b660b 100644
--- a/R/mrp.supertree.R
+++ b/R/mrp.supertree.R
@@ -1,100 +1,100 @@
-## function for Matrix Representation Parsimony supertree estimation in R
-## uses pratchet() or optim.parsimony() from the "phangorn" package
-## written by Liam J. Revell 2011, 2013, 2015, 2022
-
-compute.mr<-function(trees,type=c("phyDat","matrix")){
- type<-type[1]
- if(inherits(trees,"phylo")){
- trees<-list(trees)
- class(trees)<-"multiPhylo"
- }
- if(!inherits(trees,"multiPhylo")) stop("trees should be an object of class \"phylo\" or \"multiPhylo\".")
- # compute matrix representation phylogenies
- X<-list() # list of bipartitions
- characters<-0 # number of characters
- for(i in 1:length(trees)){
- temp<-prop.part(trees[[i]]) # find all bipartitions
- # create matrix representation of trees[[i]] in X[[i]]
- X[[i]]<-matrix(0,nrow=length(trees[[i]]$tip),ncol=length(temp)-1)
- for(j in 1:ncol(X[[i]])) X[[i]][c(temp[[j+1]]),j]<-1
- rownames(X[[i]])<-attr(temp,"labels") # label rows
- if(i==1) species<-trees[[i]]$tip.label
- else species<-union(species,trees[[i]]$tip.label) # accumulate labels
- characters<-characters+ncol(X[[i]]) # count characters
- }
- XX<-matrix(data="?",nrow=length(species),ncol=characters,dimnames=list(species))
- j<-1
- for(i in 1:length(X)){
- # copy each of X into supermatrix XX
- XX[rownames(X[[i]]),c(j:((j-1)+ncol(X[[i]])))]<-X[[i]][1:nrow(X[[i]]),1:ncol(X[[i]])]
- j<-j+ncol(X[[i]])
- }
- if(type=="phyDat"){
- # compute contrast matrix for phangorn
- contrast<-matrix(data=c(1,0,0,1,1,1),3,2,dimnames=list(c("0","1","?"),c("0","1")),byrow=TRUE)
- # convert XX to phyDat object
- XX<-phyDat(XX,type="USER",contrast=contrast)
- }
- XX
-}
-
-mrp.supertree<-function(trees,method=c("pratchet","optim.parsimony"),...){
- # set method
- method<-method[1]
- # some minor error checking
- if(!inherits(trees,"multiPhylo")) stop("trees should be an object of class \"multiPhylo\".")
- XX<-compute.mr(trees,type="phyDat")
- # estimate supertree
- if(method=="pratchet"){
- if(hasArg(start)){
- start<-list(...)$start
- if(inherits(start,"phylo")){
- supertree<-pratchet(XX,all=TRUE,...)
- } else {
- if(start=="NJ") start<-NJ(dist.hamming(XX))
- else if(start=="random") start<-rtree(n=length(XX),tip.label=names(XX))
- else {
- warning("do not recognize that option for start; using random starting tree")
- tree<-rtree(n=length(XX),tip.label=names(XX))
- }
- args<-list(...)
- args$start<-start
- args$data<-XX
- args$all<-TRUE
- supertree<-do.call(pratchet,args)
- }
- } else supertree<-pratchet(XX,all=TRUE,...)
- if(inherits(supertree,"phylo"))
- message(paste("The MRP supertree, optimized via pratchet(),\nhas a parsimony score of ",
- attr(supertree,"pscore")," (minimum ",attr(XX,"nr"),")",sep=""))
- else if(inherits(supertree,"multiPhylo"))
- message(paste("pratchet() found ",length(supertree)," supertrees\nwith a parsimony score of ",
- attr(supertree[[1]],"pscore")," (minimum ",attr(XX,"nr"),")",sep=""))
- } else if(method=="optim.parsimony"){
- if(hasArg(start)){
- start<-list(...)$start
- if(inherits(start,"phylo")){
- supertree<-optim.parsimony(tree=start,data=XX,...)
- } else {
- if(start=="NJ") start<-NJ(dist.hamming(XX))
- else if(start=="random") start<-rtree(n=length(XX),tip.label=names(XX))
- else {
- warning("do not recognize that option for tree; using random starting tree")
- start<-rtree(n=length(XX),tip.label=names(XX))
- }
- supertree<-optim.parsimony(tree=start,data=XX,...)
- }
- } else {
- message("no input starting tree or option for optim.parsimony; using random starting tree")
- start<-rtree(n=length(XX),tip.label=names(XX))
- supertree<-optim.parsimony(tree=start,data=XX,...)
- }
- if(inherits(supertree,"phylo"))
- message(paste("The MRP supertree, optimized via optim.parsimony(),\nhas a parsimony score of ",
- attr(supertree,"pscore")," (minimum ",attr(XX,"nr"),")",sep=""))
- else if(inherits(supertree,"multiPhylo"))
- message(paste("optim.parsimony() found ",length(supertree)," supertrees\nwith a parsimony score of ",
- attr(supertree[[1]],"pscore")," (minimum ",attr(XX,"nr"),")",sep=""))
- }
- return(supertree)
-}
+## function for Matrix Representation Parsimony supertree estimation in R
+## uses pratchet() or optim.parsimony() from the "phangorn" package
+## written by Liam J. Revell 2011, 2013, 2015, 2022
+
+compute.mr<-function(trees,type=c("phyDat","matrix")){
+ type<-type[1]
+ if(inherits(trees,"phylo")){
+ trees<-list(trees)
+ class(trees)<-"multiPhylo"
+ }
+ if(!inherits(trees,"multiPhylo")) stop("trees should be an object of class \"phylo\" or \"multiPhylo\".")
+ # compute matrix representation phylogenies
+ X<-list() # list of bipartitions
+ characters<-0 # number of characters
+ for(i in 1:length(trees)){
+ temp<-prop.part(trees[[i]]) # find all bipartitions
+ # create matrix representation of trees[[i]] in X[[i]]
+ X[[i]]<-matrix(0,nrow=length(trees[[i]]$tip),ncol=length(temp)-1)
+ for(j in 1:ncol(X[[i]])) X[[i]][c(temp[[j+1]]),j]<-1
+ rownames(X[[i]])<-attr(temp,"labels") # label rows
+ if(i==1) species<-trees[[i]]$tip.label
+ else species<-union(species,trees[[i]]$tip.label) # accumulate labels
+ characters<-characters+ncol(X[[i]]) # count characters
+ }
+ XX<-matrix(data="?",nrow=length(species),ncol=characters,dimnames=list(species))
+ j<-1
+ for(i in 1:length(X)){
+ # copy each of X into supermatrix XX
+ XX[rownames(X[[i]]),c(j:((j-1)+ncol(X[[i]])))]<-X[[i]][1:nrow(X[[i]]),1:ncol(X[[i]])]
+ j<-j+ncol(X[[i]])
+ }
+ if(type=="phyDat"){
+ # compute contrast matrix for phangorn
+ contrast<-matrix(data=c(1,0,0,1,1,1),3,2,dimnames=list(c("0","1","?"),c("0","1")),byrow=TRUE)
+ # convert XX to phyDat object
+ XX<-phyDat(XX,type="USER",contrast=contrast)
+ }
+ XX
+}
+
+mrp.supertree<-function(trees,method=c("pratchet","optim.parsimony"),...){
+ # set method
+ method<-method[1]
+ # some minor error checking
+ if(!inherits(trees,"multiPhylo")) stop("trees should be an object of class \"multiPhylo\".")
+ XX<-compute.mr(trees,type="phyDat")
+ # estimate supertree
+ if(method=="pratchet"){
+ if(hasArg(start)){
+ start<-list(...)$start
+ if(inherits(start,"phylo")){
+ supertree<-pratchet(XX,all=TRUE,...)
+ } else {
+ if(start=="NJ") start<-NJ(dist.hamming(XX))
+ else if(start=="random") start<-rtree(n=length(XX),tip.label=names(XX))
+ else {
+ warning("do not recognize that option for start; using random starting tree")
+ tree<-rtree(n=length(XX),tip.label=names(XX))
+ }
+ args<-list(...)
+ args$start<-start
+ args$data<-XX
+ args$all<-TRUE
+ supertree<-do.call(pratchet,args)
+ }
+ } else supertree<-pratchet(XX,all=TRUE,...)
+ if(inherits(supertree,"phylo"))
+ message(paste("The MRP supertree, optimized via pratchet(),\nhas a parsimony score of ",
+ attr(supertree,"pscore")," (minimum ",attr(XX,"nr"),")",sep=""))
+ else if(inherits(supertree,"multiPhylo"))
+ message(paste("pratchet() found ",length(supertree)," supertrees\nwith a parsimony score of ",
+ attr(supertree[[1]],"pscore")," (minimum ",attr(XX,"nr"),")",sep=""))
+ } else if(method=="optim.parsimony"){
+ if(hasArg(start)){
+ start<-list(...)$start
+ if(inherits(start,"phylo")){
+ supertree<-optim.parsimony(tree=start,data=XX,...)
+ } else {
+ if(start=="NJ") start<-NJ(dist.hamming(XX))
+ else if(start=="random") start<-rtree(n=length(XX),tip.label=names(XX))
+ else {
+ warning("do not recognize that option for tree; using random starting tree")
+ start<-rtree(n=length(XX),tip.label=names(XX))
+ }
+ supertree<-optim.parsimony(tree=start,data=XX,...)
+ }
+ } else {
+ message("no input starting tree or option for optim.parsimony; using random starting tree")
+ start<-rtree(n=length(XX),tip.label=names(XX))
+ supertree<-optim.parsimony(tree=start,data=XX,...)
+ }
+ if(inherits(supertree,"phylo"))
+ message(paste("The MRP supertree, optimized via optim.parsimony(),\nhas a parsimony score of ",
+ attr(supertree,"pscore")," (minimum ",attr(XX,"nr"),")",sep=""))
+ else if(inherits(supertree,"multiPhylo"))
+ message(paste("optim.parsimony() found ",length(supertree)," supertrees\nwith a parsimony score of ",
+ attr(supertree[[1]],"pscore")," (minimum ",attr(XX,"nr"),")",sep=""))
+ }
+ return(supertree)
+}
diff --git a/R/multi.mantel.R b/R/multi.mantel.R
index b1b6c93..0fd9275 100644
--- a/R/multi.mantel.R
+++ b/R/multi.mantel.R
@@ -1,101 +1,101 @@
-## function for multiple matrix regression with P-values computed by Mantel permutation of the dependent matrix
-## written by Liam J. Revell 2012, 2017, 2022
-
-multi.mantel<-function(Y,X,nperm=1000){
- y<-unfoldLower(Y)
- if(!is.list(X)) X<-list(X)
- Xv<-sapply(X,unfoldLower)
- colnames(Xv)<-paste("X",1:ncol(Xv),sep="")
- fit<-lm(y~Xv)
- coefficients<-fit$coefficients
- smmry<-summary(fit)
- r.squared<-smmry$r.squared
- fstatistic<-smmry$fstatistic[1]
- pF<-0
- tstatistic<-smmry$coefficients[,"t value"]
- pT<-rep(0,length(tstatistic))
- # begin Mantel permutations
- Y<-Yp<-as.matrix(Y)
- for(i in 1:nperm){
- y<-unfoldLower(Yp)
- fitp<-lm(y~Xv)
- smmryp<-summary(fitp)
- pF<-pF+as.numeric(smmryp$fstatistic[1]>=fstatistic)/nperm
- pT<-pT+as.numeric(abs(smmryp$coefficients[,"t value"])>=abs(tstatistic))/nperm
- rndm<-sample(1:nrow(Yp))
- Yp<-Y[rndm,rndm]
- }
- names(coefficients)<-names(tstatistic)<-names(pT)<-c("(intercept)",paste("X",1:ncol(Xv),sep=""))
- names(fstatistic)<-NULL
- residuals<-foldtoLower(fit$residuals); attr(residuals,"Labels")<-rownames(Y)
- fitted.values<-foldtoLower(fit$fitted.values); attr(fitted.values,"Labels")<-rownames(Y)
- object<-list(r.squared=r.squared,
- coefficients=coefficients,
- tstatistic=tstatistic,
- fstatistic=fstatistic,
- probt=pT,
- probF=pF,
- residuals=residuals,
- fitted.values=fitted.values,
- nperm=nperm)
- class(object)<-"multi.mantel"
- object
-}
-
-## function unfolds the sub-diagonal of a "dist" object or symmetric matrix into a vector
-## written by Liam J. Revell 2012, 2022
-
-unfoldLower<-function(X){
- if(inherits(X,"dist")) X<-as.matrix(X)
- x<-vector()
- for(i in 2:ncol(X)-1) x<-c(x,X[(i+1):nrow(X),i])
- names(x)<-NULL
- return(x)
-}
-
-# function folds vector into lower matrix "dist" object
-
-foldtoLower<-function(x){
- n<-(1+sqrt(1+8*length(x)))/2
- X<-matrix(0,n,n)
- j<-0
- for(i in 2:n-1){
- X[(i+1):n,i]<-x[i:(n-1)+j]
- j<-j+(n-i-1)
- }
- return(as.dist(X))
-}
-
-## S3 methods (added 2017)
-
-print.multi.mantel<-function(x,...){
- if(hasArg(digits)) digits<-list(...)$digits
- else digits<-6
- star<-function(p){
- obj<-if(p>0.1) "" else if(p<=0.1&&p>0.05) "." else
- if(p<=0.05&&p>0.01) "*" else if(p<=0.01&&p>0.001) "**" else
- if(p<=0.001) "***"
- obj
- }
- cat("\nResults from a (multiple) Mantel regression using \"multi.mantel\":\n\n")
- cat("Coefficients:\n")
- object<-data.frame(x$coefficients,
- x$tstatistic,x$probt,
- sapply(x$probt,star))
- rownames(object)<-names(x$coefficients)
- colnames(object)<-c("Estimate","t value","Pr(>|t|)","")
- print(object)
- cat("---\n")
- cat(paste("Signif. codes: 0 \u2018***\u2019 0.001 \u2018**\u2019 0.01",
- "\u2018*\u2019 0.05 \u2018.\u2019 0.1 \u2018 \u2019 1\n"))
- cat(paste("Pr(>|t|) based on",x$nperm,
- "(Mantel) permutations of rows & columns together in Y.\n\n"))
- cat(paste("Multiple R-squared:",round(x$r.squared,digits),"\n"))
- cat(paste("F-statistic: ",round(x$fstatistic,digits),
- ", p-value (based on ",x$nperm," permutations): ",
- round(x$probF,ceiling(log10(x$nperm))),"\n\n",sep=""))
-}
-
-residuals.multi.mantel<-function(object,...) object$residuals
-
-fitted.multi.mantel<-function(object,...) object$fitted.values
+## function for multiple matrix regression with P-values computed by Mantel permutation of the dependent matrix
+## written by Liam J. Revell 2012, 2017, 2022
+
+multi.mantel<-function(Y,X,nperm=1000){
+ y<-unfoldLower(Y)
+ if(!is.list(X)) X<-list(X)
+ Xv<-sapply(X,unfoldLower)
+ colnames(Xv)<-paste("X",1:ncol(Xv),sep="")
+ fit<-lm(y~Xv)
+ coefficients<-fit$coefficients
+ smmry<-summary(fit)
+ r.squared<-smmry$r.squared
+ fstatistic<-smmry$fstatistic[1]
+ pF<-0
+ tstatistic<-smmry$coefficients[,"t value"]
+ pT<-rep(0,length(tstatistic))
+ # begin Mantel permutations
+ Y<-Yp<-as.matrix(Y)
+ for(i in 1:nperm){
+ y<-unfoldLower(Yp)
+ fitp<-lm(y~Xv)
+ smmryp<-summary(fitp)
+ pF<-pF+as.numeric(smmryp$fstatistic[1]>=fstatistic)/nperm
+ pT<-pT+as.numeric(abs(smmryp$coefficients[,"t value"])>=abs(tstatistic))/nperm
+ rndm<-sample(1:nrow(Yp))
+ Yp<-Y[rndm,rndm]
+ }
+ names(coefficients)<-names(tstatistic)<-names(pT)<-c("(intercept)",paste("X",1:ncol(Xv),sep=""))
+ names(fstatistic)<-NULL
+ residuals<-foldtoLower(fit$residuals); attr(residuals,"Labels")<-rownames(Y)
+ fitted.values<-foldtoLower(fit$fitted.values); attr(fitted.values,"Labels")<-rownames(Y)
+ object<-list(r.squared=r.squared,
+ coefficients=coefficients,
+ tstatistic=tstatistic,
+ fstatistic=fstatistic,
+ probt=pT,
+ probF=pF,
+ residuals=residuals,
+ fitted.values=fitted.values,
+ nperm=nperm)
+ class(object)<-"multi.mantel"
+ object
+}
+
+## function unfolds the sub-diagonal of a "dist" object or symmetric matrix into a vector
+## written by Liam J. Revell 2012, 2022
+
+unfoldLower<-function(X){
+ if(inherits(X,"dist")) X<-as.matrix(X)
+ x<-vector()
+ for(i in 2:ncol(X)-1) x<-c(x,X[(i+1):nrow(X),i])
+ names(x)<-NULL
+ return(x)
+}
+
+# function folds vector into lower matrix "dist" object
+
+foldtoLower<-function(x){
+ n<-(1+sqrt(1+8*length(x)))/2
+ X<-matrix(0,n,n)
+ j<-0
+ for(i in 2:n-1){
+ X[(i+1):n,i]<-x[i:(n-1)+j]
+ j<-j+(n-i-1)
+ }
+ return(as.dist(X))
+}
+
+## S3 methods (added 2017)
+
+print.multi.mantel<-function(x,...){
+ if(hasArg(digits)) digits<-list(...)$digits
+ else digits<-6
+ star<-function(p){
+ obj<-if(p>0.1) "" else if(p<=0.1&&p>0.05) "." else
+ if(p<=0.05&&p>0.01) "*" else if(p<=0.01&&p>0.001) "**" else
+ if(p<=0.001) "***"
+ obj
+ }
+ cat("\nResults from a (multiple) Mantel regression using \"multi.mantel\":\n\n")
+ cat("Coefficients:\n")
+ object<-data.frame(x$coefficients,
+ x$tstatistic,x$probt,
+ sapply(x$probt,star))
+ rownames(object)<-names(x$coefficients)
+ colnames(object)<-c("Estimate","t value","Pr(>|t|)","")
+ print(object)
+ cat("---\n")
+ cat(paste("Signif. codes: 0 \u2018***\u2019 0.001 \u2018**\u2019 0.01",
+ "\u2018*\u2019 0.05 \u2018.\u2019 0.1 \u2018 \u2019 1\n"))
+ cat(paste("Pr(>|t|) based on",x$nperm,
+ "(Mantel) permutations of rows & columns together in Y.\n\n"))
+ cat(paste("Multiple R-squared:",round(x$r.squared,digits),"\n"))
+ cat(paste("F-statistic: ",round(x$fstatistic,digits),
+ ", p-value (based on ",x$nperm," permutations): ",
+ round(x$probF,ceiling(log10(x$nperm))),"\n\n",sep=""))
+}
+
+residuals.multi.mantel<-function(object,...) object$residuals
+
+fitted.multi.mantel<-function(object,...) object$fitted.values
diff --git a/R/multiRF.R b/R/multiRF.R
index c22e24b..76fd782 100644
--- a/R/multiRF.R
+++ b/R/multiRF.R
@@ -1,24 +1,24 @@
-## functions computes Robinson-Foulds distance between all trees in a list of class "multiPhylo"
-## works only for unrooted trees (if trees are rooted, them will be unrooted)
-## written by Liam J. Revell 2013, 2015, 2017, 2019
-
-multiRF<-function(trees,quiet=FALSE,multi2di=FALSE){
- if(!inherits(trees,"multiPhylo")) stop("trees should be an object of class \"multiPhylo\".")
- N<-length(trees)
- RF<-matrix(0,N,N)
- if(any(sapply(unclass(trees),is.rooted))){
- if(!quiet) cat("Some trees are rooted. Unrooting all trees.\n")
- trees<-lapply(unclass(trees),unroot)
- }
- if(any(sapply(unclass(trees),function(x) !is.binary(x)))){
- if(multi2di){
- if(!quiet) cat("some trees are not binary. Using multi2di to render bifurcating.\n")
- trees<-lapply(trees,multi2di)
- class(trees)<-"multiPhylo"
- } else stop("Some trees are not binary. This implementation only works for binary trees.")
- }
- foo<-function(pp) lapply(pp,function(x,pp) sort(attr(pp,"labels")[x]),pp=pp)
- xx<-lapply(unclass(trees),function(x) foo(prop.part(x))[2:x$Nnode])
- for(i in 1:(N-1)) for(j in (i+1):N) RF[i,j]<-RF[j,i]<-2*sum(!xx[[i]]%in%xx[[j]])
- RF
-}
+## functions computes Robinson-Foulds distance between all trees in a list of class "multiPhylo"
+## works only for unrooted trees (if trees are rooted, them will be unrooted)
+## written by Liam J. Revell 2013, 2015, 2017, 2019
+
+multiRF<-function(trees,quiet=FALSE,multi2di=FALSE){
+ if(!inherits(trees,"multiPhylo")) stop("trees should be an object of class \"multiPhylo\".")
+ N<-length(trees)
+ RF<-matrix(0,N,N)
+ if(any(sapply(unclass(trees),is.rooted))){
+ if(!quiet) cat("Some trees are rooted. Unrooting all trees.\n")
+ trees<-lapply(unclass(trees),unroot)
+ }
+ if(any(sapply(unclass(trees),function(x) !is.binary(x)))){
+ if(multi2di){
+ if(!quiet) cat("some trees are not binary. Using multi2di to render bifurcating.\n")
+ trees<-lapply(trees,multi2di)
+ class(trees)<-"multiPhylo"
+ } else stop("Some trees are not binary. This implementation only works for binary trees.")
+ }
+ foo<-function(pp) lapply(pp,function(x,pp) sort(attr(pp,"labels")[x]),pp=pp)
+ xx<-lapply(unclass(trees),function(x) foo(prop.part(x))[2:x$Nnode])
+ for(i in 1:(N-1)) for(j in (i+1):N) RF[i,j]<-RF[j,i]<-2*sum(!xx[[i]]%in%xx[[j]])
+ RF
+}
diff --git a/R/multirateBM.R b/R/multirateBM.R
index e6294a9..3b9a539 100644
--- a/R/multirateBM.R
+++ b/R/multirateBM.R
@@ -1,279 +1,281 @@
-## function
-## by Liam J. Revell 2021, 2022
-
-VCV<-function(tree){
- H<-nodeHeights(tree)
- h<-c(H[1,1],H[,2])[order(c(tree$edge[1,1],tree$edge[,2]))]
- M<-mrca(tree,full=TRUE)
- M[lower.tri(M)]<-t(M)[lower.tri(M)]
- ROOT<-Ntip(tree)+1
- M<-M[-ROOT,-ROOT]
- matrix(h[M],nrow(M),ncol(M),
- dimnames=list(c(tree$tip.label,2:tree$Nnode+Ntip(tree)),
- c(tree$tip.label,2:tree$Nnode+Ntip(tree))))
-}
-
-p.func<-function(x,a,C) dmnorm(x,rep(a,nrow(C)),C,log=TRUE)
-
-
-ln.mean<-function(x){
- if(x[1]==x[2]) return(x[1])
- else {
- a<-x[2]
- b<-log(x[1])-log(x[2])
- return(a/b*exp(b)-a/b)
- }
-}
-
-log_lik<-function(lnsig2,tree,x,lambda=1,trace=0){
- sig2<-exp(lnsig2)
- tt<-tree
- tt$edge.length<-tree$edge.length*apply(tree$edge,
- 1,function(e,x) ln.mean(x[e]),x=sig2)
- Tips<-phyl.vcv(as.matrix(x),vcv(tt),1)
- root<-Ntip(tree)+1
- n<-nrow(Tips$C)
- m<-tree$Nnode
- ln.p1<-p.func(x,Tips$alpha[1,1],Tips$C)
- ln.p2<--p.func(log(sig2)[-root],log(sig2)[root],
- VCV(tree))
- logL<-ln.p1-lambda*ln.p2
- if(trace>0){
- cat(paste("log(L) =",round(logL,4),"\n"))
- flush.console()
- }
- -logL
-}
-
-log_relik<-function(lnsig2,tree,x,trace=0){
- sig2<-exp(lnsig2[1:(length(lnsig2)-1)])
- SCALE<-exp(lnsig2[length(lnsig2)])
- tt<-tree
- tt$edge.length<-SCALE*tree$edge.length*apply(tree$edge,
- 1,function(e,x) mean(x[e]),x=sig2)
- px<-pic(x,tt)
- dLNSIG<-apply(tree$edge,1,function(edge,lnsig2) diff(lnsig2[edge]),
- lnsig2=lnsig2)/sqrt(tree$edge.length)
- logL<-sum(dnorm(px,log=TRUE))+sum(dnorm(dLNSIG,log=TRUE))
- if(trace>0){
- cat(paste("log(reL) =",round(logL,4),"\n"))
- flush.console()
- }
- -logL
-}
-
-multirateBM<-function(tree,x,method=c("ML","REML"),
- optim=c("L-BFGS-B","Nelder-Mead","BFGS","CG"),
- maxit=NULL,n.iter=1,lambda=1,...){
- if(hasArg(parallel)) parallel<-list(...)$parallel
- else parallel<-FALSE
- if(parallel){
- if(hasArg(ncores)) ncores<-list(...)$ncores
- else ncores<-detectCores()
- if(is.na(ncores)) ncores<-1
- }
- method<-method[1]
- optim.method<-if(!parallel) optim else "L-BFGS-B"
- if(!is.null(maxit)) control<-list(maxit=maxit)
- else control<-list()
- if(method=="REML"){
- cat("Sorry! method=\"REML\" doesn't work. Switching to \"ML\".\n")
- method<-"ML"
- }
- if("L-BFGS-B"%in%optim.method){
- vv<-log(var(x)/max(nodeHeights(tree)))
- if(hasArg(lower)){
- lower<-list(...)$lower
- lower<-log(lower)
- } else lower<-rep(-10+vv,Ntip(tree)+tree$Nnode)
- if(length(lower)!=(Ntip(tree)+tree$Nnode))
- lower<-rep(lower[1],Ntip(tree)+tree$Nnode)
- if(hasArg(upper)){
- upper<-list(...)$upper
- lower<-log(lower)
- } else upper<-rep(10+vv,Ntip(tree)+tree$Nnode)
- if(length(upper)!=(Ntip(tree)+tree$Nnode))
- upper<-rep(upper[1],Ntip(tree)+tree$Nnode)
- }
- lik<-if(method=="ML") log_lik else log_relik
- if(hasArg(trace)) trace<-list(...)$trace
- else trace<-0
- x<-x[tree$tip.label]
- fit<-list()
- fit$convergence<-99
- init<-log(mean(pic(x,multi2di(collapse.singles(tree),
- random=FALSE))^2)*(Ntip(tree)-1)/Ntip(tree))
- fit$par<-rep(init,Ntip(tree)+tree$Nnode)
- class(fit)<-"try-error"
- ii<-1
- cat("Beginning optimization....\n")
- if(parallel) {
- ## create cluster
- cl<-makeCluster(ncores)
- tmp<-capture.output(print(cl))
- cat(paste("Using ",tmp,".\n",sep=""))
- }
- while(inherits(fit,"try-error")||fit$convergence!=0||ii<=n.iter){
- if(length(optim.method)==1) OPTIM<-optim.method[1]
- else OPTIM<-optim.method[if(ii!=length(optim.method))
- ii%%length(optim.method) else length(optim.method)]
- cat(paste("Optimization iteration ",ii,". Using \"",
- OPTIM,"\"",if(parallel) " (parallel) " else " ",
- "optimization method.\n",sep=""))
- if(OPTIM=="L-BFGS-B"){
- fit$par[which(fit$par<lower)]<-lower
- fit$par[which(fit$par>upper)]<-upper
- }
- flush.console()
- cur.vals<-fit$par
- if(parallel){
- fit<-try(optimParallel(fit$par,
- lik,tree=tree,x=x,lambda=lambda,trace=trace,
- control=control,
- lower=lower,upper=upper,
- parallel=list(cl=cl,forward=FALSE,
- loginfo=TRUE)))
- } else {
- fit<-try(optim(fit$par,
- lik,tree=tree,x=x,lambda=lambda,trace=trace,
- control=control,
- method=OPTIM,
- lower=if(OPTIM=="L-BFGS-B") lower else -Inf,
- upper=if(OPTIM=="L-BFGS-B") upper else Inf))
- }
- if(inherits(fit,"try-error")){
- fit<-list()
- fit$convergence<-99
- fit$par<-cur.vals
- class(fit)<-"try-error"
- cat("Caught error without failing. Trying again....\n")
- } else {
- cat(paste("Best (penalized) log-likelihood so far:",
- signif(-fit$value,6),"\n"))
- }
- ii<-ii+1
- }
- if(parallel){
- ## stop cluster
- ## setDefaultCluster(cl=NULL)
- stopCluster(cl)
- }
- cat("Done optimization.\n")
- LIK<-function(sig2) -lik(log(sig2),tree=tree,x=x,
- lambda=0)
- object<-list(
- sig2=setNames(exp(fit$par),
- c(tree$tip.label,1:tree$Nnode+Ntip(tree))),
- lambda=lambda,
- logLik=LIK(exp(fit$par)),
- k=length(fit$par)+1,
- tree=tree,
- x=x,
- convergence=fit$convergence,
- method=method,
- lik=LIK)
- class(object)<-"multirateBM"
- object
-}
-
-print.multirateBM<-function(x,digits=6,printlen=NULL,...){
- if(is.null(printlen)) printlen<-8
- cat("Multi-rate Brownian model using multirateBM.\n\n")
- cat("Fitted rates:\n")
- if(printlen>=length(x$sig2)) print(round(x$sig2,digits))
- else printDotDot(x$sig2,digits,printlen)
- cat(paste("\nlambda penalty term:",
- round(x$lambda,digits)))
- cat(paste("\nlog-likelihood: ",round(x$logLik,digits),"\n"))
- cat(paste("AIC: ",round(AIC(x),digits),"\n\n"))
- if(x$convergence==0) cat("R thinks it has found a solution.\n\n")
- else cat("R may not have found a solution.\n\n")
-}
-
-logLik.multirateBM<-function(object,...){
- lik<-object$logLik
- attr(lik,"df")<-object$k
- lik
-}
-
-plot.multirateBM<-function(x,digits=2,...){
- if(hasArg(plot)) plot<-list(...)$plot
- else plot<-TRUE
- cols<-setNames(rainbow(1000,start=0.7,end=0),
- 1:1000)
- est.sig2<-apply(x$tree$edge,1,function(e,x)
- ln.mean(x[e]),x=x$sig2)
- ln.sig2<-log(est.sig2)
- min.sig2<-min(ln.sig2)
- max.sig2<-max(ln.sig2)
- edge.states<-vector()
- for(i in 1:length(est.sig2)){
- edge.states[i]<-round((ln.sig2[i]-min.sig2)/
- (max.sig2-min.sig2)*999)+1
- }
- tree<-paintBranches(x$tree,edge=x$tree$edge[1,2],
- state=edge.states[1])
- for(i in 2:length(edge.states))
- tree<-paintBranches(tree,edge=tree$edge[i,2],
- state=edge.states[i])
- nticks<-10
- ticks<-exp(seq(min(log(x$sig2)),max(log(x$sig2)),
- length.out=nticks))
- object<-list(tree=tree,cols=cols,ticks=ticks,
- sig2=est.sig2)
- class(object)<-"multirateBM_plot"
- if(plot) plot(object,digits=digits,...)
- invisible(object)
-}
-
-plot.multirateBM_plot<-function(x,digits=2,...){
- args<-list(...)
- if(!is.null(args$type)) if(args$type=="fan") args$type<-"phylogram"
- if(is.null(args$lwd)) args$lwd<-3
- args$split.vertical<-TRUE
- args$tree<-x$tree
- args$plot<-FALSE
- do.call(plotTree,args)
- lastPP<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- args$plot<-TRUE
- args$colors<-x$cols
- args$xlim<-c(-0.3,1.05)*diff(lastPP$x.lim)
- args$add<-TRUE
- do.call(plotSimmap,args)
- lastPP<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- h<-max(nodeHeights(x$tree))
- LWD<-diff(par()$usr[1:2])/dev.size("px")[1]
- lines(x=rep(-0.25*h+LWD*15/2,2),y=c(2,Ntip(x$tree)-1))
- nticks<-length(x$ticks)
- Y<-cbind(seq(2,Ntip(x$tree)-1,length.out=nticks),
- seq(2,Ntip(x$tree)-1,length.out=nticks))
- X<-cbind(rep(-0.25*h+LWD*15/2,nticks),
- rep(-0.25*h+LWD*15/2+0.02*h,nticks))
- for(i in 1:nrow(Y)) lines(X[i,],Y[i,])
- add.color.bar(Ntip(x$tree)-3,
- x$cols,
- title=expression(paste("evolutionary rate ( ",sigma^2,")")),
- lims=NULL,digits=3,
- direction="upwards",
- subtitle="",lwd=15,
- x=-0.25*h,
- y=2,prompt=FALSE)
- text(x=X[,2],y=Y[,2],signif(x$ticks,digits),pos=4,cex=0.7)
-}
-
-print.multirateBM_plot<-function(x,...){
- cat("Object of class \"multirateBM_plot\" containing:\n\n")
- cat(paste("(1) A phylogenetic tree with ",
- length(x$tree$tip.label)," tips and ",x$tree$Nnode,
- " internal nodes.\n\n",sep=""))
- cat("(2) A mapped set of Brownian evolution rates.\n\n")
-}
-
-setMap.multirateBM_plot<-function(x,...){
- if(hasArg(invert)) invert<-list(...)$invert
- else invert<-FALSE
- n<-length(x$cols)
- if(invert) x$cols<-setNames(rev(x$cols),names(x$cols))
- else x$cols[1:n]<-colorRampPalette(...)(n)
- x
-}
+## function
+## by Liam J. Revell 2021, 2022, 2023
+
+VCV<-function(tree){
+ H<-nodeHeights(tree)
+ h<-c(H[1,1],H[,2])[order(c(tree$edge[1,1],tree$edge[,2]))]
+ M<-mrca(tree,full=TRUE)
+ M[lower.tri(M)]<-t(M)[lower.tri(M)]
+ ROOT<-Ntip(tree)+1
+ M<-M[-ROOT,-ROOT]
+ matrix(h[M],nrow(M),ncol(M),
+ dimnames=list(c(tree$tip.label,2:tree$Nnode+Ntip(tree)),
+ c(tree$tip.label,2:tree$Nnode+Ntip(tree))))
+}
+
+p.func<-function(x,a,C) dmnorm(x,rep(a,nrow(C)),C,log=TRUE)
+
+
+ln.mean<-function(x){
+ if(x[1]==x[2]) return(x[1])
+ else {
+ a<-x[2]
+ b<-log(x[1])-log(x[2])
+ return(a/b*exp(b)-a/b)
+ }
+}
+
+log_lik<-function(lnsig2,tree,x,lambda=1,trace=0){
+ sig2<-exp(lnsig2)
+ tt<-tree
+ tt$edge.length<-tree$edge.length*apply(tree$edge,
+ 1,function(e,x) ln.mean(x[e]),x=sig2)
+ Tips<-phyl.vcv(as.matrix(x),vcv(tt),1)
+ root<-Ntip(tree)+1
+ n<-nrow(Tips$C)
+ m<-tree$Nnode
+ ln.p1<-p.func(x,Tips$alpha[1,1],Tips$C)
+ ln.p2<--p.func(log(sig2)[-root],log(sig2)[root],
+ VCV(tree))
+ logL<-ln.p1-lambda*ln.p2
+ if(trace>0){
+ cat(paste("log(L) =",round(logL,4),"\n"))
+ flush.console()
+ }
+ -logL
+}
+
+log_relik<-function(lnsig2,tree,x,trace=0){
+ sig2<-exp(lnsig2[1:(length(lnsig2)-1)])
+ SCALE<-exp(lnsig2[length(lnsig2)])
+ tt<-tree
+ tt$edge.length<-SCALE*tree$edge.length*apply(tree$edge,
+ 1,function(e,x) mean(x[e]),x=sig2)
+ px<-pic(x,tt)
+ dLNSIG<-apply(tree$edge,1,function(edge,lnsig2) diff(lnsig2[edge]),
+ lnsig2=lnsig2)/sqrt(tree$edge.length)
+ logL<-sum(dnorm(px,log=TRUE))+sum(dnorm(dLNSIG,log=TRUE))
+ if(trace>0){
+ cat(paste("log(reL) =",round(logL,4),"\n"))
+ flush.console()
+ }
+ -logL
+}
+
+multirateBM<-function(tree,x,method=c("ML","REML"),
+ optim=c("L-BFGS-B","Nelder-Mead","BFGS","CG"),
+ maxit=NULL,n.iter=1,lambda=1,...){
+ if(hasArg(quiet)) quiet<-list(...)$quiet
+ else quiet<-FALSE
+ if(hasArg(parallel)) parallel<-list(...)$parallel
+ else parallel<-FALSE
+ if(parallel){
+ if(hasArg(ncores)) ncores<-list(...)$ncores
+ else ncores<-detectCores()
+ if(is.na(ncores)) ncores<-1
+ }
+ method<-method[1]
+ optim.method<-if(!parallel) optim else "L-BFGS-B"
+ if(!is.null(maxit)) control<-list(maxit=maxit)
+ else control<-list()
+ if(method=="REML"){
+ cat("Sorry! method=\"REML\" doesn't work. Switching to \"ML\".\n")
+ method<-"ML"
+ }
+ if("L-BFGS-B"%in%optim.method){
+ vv<-log(var(x)/max(nodeHeights(tree)))
+ if(hasArg(lower)){
+ lower<-list(...)$lower
+ lower<-log(lower)
+ } else lower<-rep(-10+vv,Ntip(tree)+tree$Nnode)
+ if(length(lower)!=(Ntip(tree)+tree$Nnode))
+ lower<-rep(lower[1],Ntip(tree)+tree$Nnode)
+ if(hasArg(upper)){
+ upper<-list(...)$upper
+ lower<-log(lower)
+ } else upper<-rep(10+vv,Ntip(tree)+tree$Nnode)
+ if(length(upper)!=(Ntip(tree)+tree$Nnode))
+ upper<-rep(upper[1],Ntip(tree)+tree$Nnode)
+ }
+ lik<-if(method=="ML") log_lik else log_relik
+ if(hasArg(trace)) trace<-list(...)$trace
+ else trace<-0
+ x<-x[tree$tip.label]
+ fit<-list()
+ fit$convergence<-99
+ init<-log(mean(pic(x,multi2di(collapse.singles(tree),
+ random=FALSE))^2)*(Ntip(tree)-1)/Ntip(tree))
+ fit$par<-rep(init,Ntip(tree)+tree$Nnode)
+ class(fit)<-"try-error"
+ ii<-1
+ if(!quiet) cat("Beginning optimization....\n")
+ if(parallel){
+ ## create cluster
+ cl<-makeCluster(ncores)
+ tmp<-capture.output(print(cl))
+ if(!quiet) cat(paste("Using ",tmp,".\n",sep=""))
+ }
+ while(inherits(fit,"try-error")||fit$convergence!=0||ii<=n.iter){
+ if(length(optim.method)==1) OPTIM<-optim.method[1]
+ else OPTIM<-optim.method[if(ii!=length(optim.method))
+ ii%%length(optim.method) else length(optim.method)]
+ if(!quiet) cat(paste("Optimization iteration ",ii,". Using \"",
+ OPTIM,"\"",if(parallel) " (parallel) " else " ",
+ "optimization method.\n",sep=""))
+ if(OPTIM=="L-BFGS-B"){
+ fit$par[which(fit$par<lower)]<-lower
+ fit$par[which(fit$par>upper)]<-upper
+ }
+ flush.console()
+ cur.vals<-fit$par
+ if(parallel){
+ fit<-try(optimParallel(fit$par,
+ lik,tree=tree,x=x,lambda=lambda,trace=trace,
+ control=control,
+ lower=lower,upper=upper,
+ parallel=list(cl=cl,forward=FALSE,
+ loginfo=TRUE)))
+ } else {
+ fit<-try(optim(fit$par,
+ lik,tree=tree,x=x,lambda=lambda,trace=trace,
+ control=control,
+ method=OPTIM,
+ lower=if(OPTIM=="L-BFGS-B") lower else -Inf,
+ upper=if(OPTIM=="L-BFGS-B") upper else Inf))
+ }
+ if(inherits(fit,"try-error")){
+ fit<-list()
+ fit$convergence<-99
+ fit$par<-cur.vals
+ class(fit)<-"try-error"
+ if(!quiet) cat("Caught error without failing. Trying again....\n")
+ } else {
+ if(!quiet) cat(paste("Best (penalized) log-likelihood so far:",
+ signif(-fit$value,6),"\n"))
+ }
+ ii<-ii+1
+ }
+ if(parallel){
+ ## stop cluster
+ ## setDefaultCluster(cl=NULL)
+ stopCluster(cl)
+ }
+ if(!quiet) cat("Done optimization.\n")
+ LIK<-function(sig2) -lik(log(sig2),tree=tree,x=x,
+ lambda=0)
+ object<-list(
+ sig2=setNames(exp(fit$par),
+ c(tree$tip.label,1:tree$Nnode+Ntip(tree))),
+ lambda=lambda,
+ logLik=LIK(exp(fit$par)),
+ k=length(fit$par)+1,
+ tree=tree,
+ x=x,
+ convergence=fit$convergence,
+ method=method,
+ lik=LIK)
+ class(object)<-"multirateBM"
+ object
+}
+
+print.multirateBM<-function(x,digits=6,printlen=NULL,...){
+ if(is.null(printlen)) printlen<-8
+ cat("Multi-rate Brownian model using multirateBM.\n\n")
+ cat("Fitted rates:\n")
+ if(printlen>=length(x$sig2)) print(round(x$sig2,digits))
+ else printDotDot(x$sig2,digits,printlen)
+ cat(paste("\nlambda penalty term:",
+ round(x$lambda,digits)))
+ cat(paste("\nlog-likelihood: ",round(x$logLik,digits),"\n"))
+ cat(paste("AIC: ",round(AIC(x),digits),"\n\n"))
+ if(x$convergence==0) cat("R thinks it has found a solution.\n\n")
+ else cat("R may not have found a solution.\n\n")
+}
+
+logLik.multirateBM<-function(object,...){
+ lik<-object$logLik
+ attr(lik,"df")<-object$k
+ lik
+}
+
+plot.multirateBM<-function(x,digits=2,...){
+ if(hasArg(plot)) plot<-list(...)$plot
+ else plot<-TRUE
+ cols<-setNames(rainbow(1000,start=0.7,end=0),
+ 1:1000)
+ est.sig2<-apply(x$tree$edge,1,function(e,x)
+ ln.mean(x[e]),x=x$sig2)
+ ln.sig2<-log(est.sig2)
+ min.sig2<-min(ln.sig2)
+ max.sig2<-max(ln.sig2)
+ edge.states<-vector()
+ for(i in 1:length(est.sig2)){
+ edge.states[i]<-round((ln.sig2[i]-min.sig2)/
+ (max.sig2-min.sig2)*999)+1
+ }
+ tree<-paintBranches(x$tree,edge=x$tree$edge[1,2],
+ state=edge.states[1])
+ for(i in 2:length(edge.states))
+ tree<-paintBranches(tree,edge=tree$edge[i,2],
+ state=edge.states[i])
+ nticks<-10
+ ticks<-exp(seq(min(log(x$sig2)),max(log(x$sig2)),
+ length.out=nticks))
+ object<-list(tree=tree,cols=cols,ticks=ticks,
+ sig2=est.sig2)
+ class(object)<-"multirateBM_plot"
+ if(plot) plot(object,digits=digits,...)
+ invisible(object)
+}
+
+plot.multirateBM_plot<-function(x,digits=2,...){
+ args<-list(...)
+ if(!is.null(args$type)) if(args$type=="fan") args$type<-"phylogram"
+ if(is.null(args$lwd)) args$lwd<-3
+ args$split.vertical<-TRUE
+ args$tree<-x$tree
+ args$plot<-FALSE
+ do.call(plotTree,args)
+ lastPP<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ args$plot<-TRUE
+ args$colors<-x$cols
+ args$xlim<-c(-0.3,1.05)*diff(lastPP$x.lim)
+ args$add<-TRUE
+ do.call(plotSimmap,args)
+ lastPP<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ h<-max(nodeHeights(x$tree))
+ LWD<-diff(par()$usr[1:2])/dev.size("px")[1]
+ lines(x=rep(-0.25*h+LWD*15/2,2),y=c(2,Ntip(x$tree)-1))
+ nticks<-length(x$ticks)
+ Y<-cbind(seq(2,Ntip(x$tree)-1,length.out=nticks),
+ seq(2,Ntip(x$tree)-1,length.out=nticks))
+ X<-cbind(rep(-0.25*h+LWD*15/2,nticks),
+ rep(-0.25*h+LWD*15/2+0.02*h,nticks))
+ for(i in 1:nrow(Y)) lines(X[i,],Y[i,])
+ add.color.bar(Ntip(x$tree)-3,
+ x$cols,
+ title=expression(paste("evolutionary rate ( ",sigma^2,")")),
+ lims=NULL,digits=3,
+ direction="upwards",
+ subtitle="",lwd=15,
+ x=-0.25*h,
+ y=2,prompt=FALSE)
+ text(x=X[,2],y=Y[,2],signif(x$ticks,digits),pos=4,cex=0.7)
+}
+
+print.multirateBM_plot<-function(x,...){
+ cat("Object of class \"multirateBM_plot\" containing:\n\n")
+ cat(paste("(1) A phylogenetic tree with ",
+ length(x$tree$tip.label)," tips and ",x$tree$Nnode,
+ " internal nodes.\n\n",sep=""))
+ cat("(2) A mapped set of Brownian evolution rates.\n\n")
+}
+
+setMap.multirateBM_plot<-function(x,...){
+ if(hasArg(invert)) invert<-list(...)$invert
+ else invert<-FALSE
+ n<-length(x$cols)
+ if(invert) x$cols<-setNames(rev(x$cols),names(x$cols))
+ else x$cols[1:n]<-colorRampPalette(...)(n)
+ x
+}
diff --git a/R/optim.phylo.ls.R b/R/optim.phylo.ls.R
index 36bdd90..417ed4b 100644
--- a/R/optim.phylo.ls.R
+++ b/R/optim.phylo.ls.R
@@ -1,99 +1,99 @@
-## function performs least-squares phylogeny inference by nni
-## written by Liam J. Revell 2011, 2013, 2015, 2019, 2022
-
-optim.phylo.ls<-function(D,stree=NULL,set.neg.to.zero=TRUE,fixed=FALSE,tol=1e-10,collapse=TRUE){
- # change D to a matrix (if actually an object of class "dist")
- if(inherits(D,"dist")) D<-as.matrix(D)
- # compute the number of species
- n<-nrow(D)
- if(is.null(stree))
- stree<-rtree(n=n,tip.label=rownames(D),br=NULL,rooted=F) # random starting tree
- else if(!inherits(stree,"phylo")){
- cat("starting tree must be an object of class \"phylo.\" using random starting tree.\n")
- stree<-rtree(n=n,tip.label=rownames(D),br=NULL,rooted=F) # random starting tree
- }
- if(!is.binary(stree)) stree<-multi2di(stree)
- if(is.rooted(stree)) stree<-unroot(stree)
- # get ls branch lengths for stree
- best.tree<-ls.tree(stree,D)
- Q<-attr(best.tree,"Q-score")
- bestQ<-0 # to start the loop
- # for search
- Nnni<-0
- # loop while Q is not improved by nni
- while(bestQ-Q<tol&&fixed==FALSE){
- nni.trees<-lapply(nni(best.tree),ls.tree,D=D)
- nniQ<-sapply(nni.trees,function(x) attr(x,"Q-score"))
- ii<-which(nniQ==min(nniQ))
- bestQ<-nniQ[ii]
- if(bestQ<Q){
- best.tree<-nni.trees[[ii]]
- Nnni<-Nnni+1
- Q<-attr(best.tree,"Q-score")
- cat(paste(Nnni,"set(s) of nearest neighbor interchanges. best Q so far =",round(Q,10),"\n",collapse=""))
- flush.console()
- } else bestQ<-Inf
- }
- cat(paste("best Q score of",round(Q,10),"found after",Nnni,"nearest neighbor interchange(s).\n",collapse=""))
- if(set.neg.to.zero) best.tree$edge.length[best.tree$edge.length<0]<-0
- attr(best.tree,"Q-score")<-Q
- if(collapse) best.tree<-di2multi(best.tree)
- best.tree
-}
-
-# function computes the ls branch lengths and Q score for a tree
-# written by Liam J. Revell 2011
-ls.tree<-function(tree,D){
- # compute design matrix for tree i
- X<-phyloDesign(tree)
- # sort and columnarize D
- D<-D[tree$tip.label,tree$tip.label]
- colD<-D[lower.tri(D)]
- # compute the least squares branches conditioned on tree i
- v<-solve(t(X)%*%X)%*%t(X)%*%colD
- # give the tree its estimated branch lengths
- tree$edge.length<-v
- # compute the distances for this tree
- d<-X%*%v
- # compute Q
- Q<-sum((colD-d)^2)
- # assign attribute to tree
- attr(tree,"Q-score")<-Q
- tree
-}
-
-# function computes design matrix for least squares given a topology
-# written by Liam J. Revell 2011, totally re-written 2015
-phyloDesign<-function(tree){
- N<-Ntip(tree)
- A<-lapply(1:N,function(n,t) c(getAncestors(t,n),n),t=tree)
- X<-matrix(0,N*(N-1)/2,nrow(tree$edge))
- colnames(X)<-apply(tree$edge,1,paste,collapse=",")
- rn<-sapply(1:N,function(x,y) sapply(y,paste,x=x,sep=","),y=1:N)
- rownames(X)<-rn[upper.tri(rn)]
- ii<-1
- for(i in 1:(N-1)) for(j in (i+1):N){
- e<-c(setdiff(A[[i]],A[[j]]),setdiff(A[[j]],A[[i]]))
- e<-sapply(e,function(x,y) which(y==x),y=tree$edge[,2])
- X[ii,e]<-1
- ii<-ii+1
- }
- X
-}
-
-# function computes the ancestor node numbers for each tip number
-# written by Liam J. Revell 2011
-compute.ancestor.nodes<-function(tree){
- n<-length(tree$tip)
- m<-tree$Nnode
- X<-matrix(0,n,n+m,dimnames=list(1:n,1:(n+m)))
- for(i in 1:n){
- currnode<-i
- while(currnode!=(n+1)){
- X[i,currnode]<-1
- currnode<-tree$edge[match(currnode,tree$edge[,2]),1]
- }
- X[i,currnode]<-1
- }
- X
-}
+## function performs least-squares phylogeny inference by nni
+## written by Liam J. Revell 2011, 2013, 2015, 2019, 2022
+
+optim.phylo.ls<-function(D,stree=NULL,set.neg.to.zero=TRUE,fixed=FALSE,tol=1e-10,collapse=TRUE){
+ # change D to a matrix (if actually an object of class "dist")
+ if(inherits(D,"dist")) D<-as.matrix(D)
+ # compute the number of species
+ n<-nrow(D)
+ if(is.null(stree))
+ stree<-rtree(n=n,tip.label=rownames(D),br=NULL,rooted=F) # random starting tree
+ else if(!inherits(stree,"phylo")){
+ cat("starting tree must be an object of class \"phylo.\" using random starting tree.\n")
+ stree<-rtree(n=n,tip.label=rownames(D),br=NULL,rooted=F) # random starting tree
+ }
+ if(!is.binary(stree)) stree<-multi2di(stree)
+ if(is.rooted(stree)) stree<-unroot(stree)
+ # get ls branch lengths for stree
+ best.tree<-ls.tree(stree,D)
+ Q<-attr(best.tree,"Q-score")
+ bestQ<-0 # to start the loop
+ # for search
+ Nnni<-0
+ # loop while Q is not improved by nni
+ while(bestQ-Q<tol&&fixed==FALSE){
+ nni.trees<-lapply(nni(best.tree),ls.tree,D=D)
+ nniQ<-sapply(nni.trees,function(x) attr(x,"Q-score"))
+ ii<-which(nniQ==min(nniQ))
+ bestQ<-nniQ[ii]
+ if(bestQ<Q){
+ best.tree<-nni.trees[[ii]]
+ Nnni<-Nnni+1
+ Q<-attr(best.tree,"Q-score")
+ cat(paste(Nnni,"set(s) of nearest neighbor interchanges. best Q so far =",round(Q,10),"\n",collapse=""))
+ flush.console()
+ } else bestQ<-Inf
+ }
+ cat(paste("best Q score of",round(Q,10),"found after",Nnni,"nearest neighbor interchange(s).\n",collapse=""))
+ if(set.neg.to.zero) best.tree$edge.length[best.tree$edge.length<0]<-0
+ attr(best.tree,"Q-score")<-Q
+ if(collapse) best.tree<-di2multi(best.tree)
+ best.tree
+}
+
+# function computes the ls branch lengths and Q score for a tree
+# written by Liam J. Revell 2011
+ls.tree<-function(tree,D){
+ # compute design matrix for tree i
+ X<-phyloDesign(tree)
+ # sort and columnarize D
+ D<-D[tree$tip.label,tree$tip.label]
+ colD<-D[lower.tri(D)]
+ # compute the least squares branches conditioned on tree i
+ v<-solve(t(X)%*%X)%*%t(X)%*%colD
+ # give the tree its estimated branch lengths
+ tree$edge.length<-v
+ # compute the distances for this tree
+ d<-X%*%v
+ # compute Q
+ Q<-sum((colD-d)^2)
+ # assign attribute to tree
+ attr(tree,"Q-score")<-Q
+ tree
+}
+
+# function computes design matrix for least squares given a topology
+# written by Liam J. Revell 2011, totally re-written 2015
+phyloDesign<-function(tree){
+ N<-Ntip(tree)
+ A<-lapply(1:N,function(n,t) c(getAncestors(t,n),n),t=tree)
+ X<-matrix(0,N*(N-1)/2,nrow(tree$edge))
+ colnames(X)<-apply(tree$edge,1,paste,collapse=",")
+ rn<-sapply(1:N,function(x,y) sapply(y,paste,x=x,sep=","),y=1:N)
+ rownames(X)<-rn[upper.tri(rn)]
+ ii<-1
+ for(i in 1:(N-1)) for(j in (i+1):N){
+ e<-c(setdiff(A[[i]],A[[j]]),setdiff(A[[j]],A[[i]]))
+ e<-sapply(e,function(x,y) which(y==x),y=tree$edge[,2])
+ X[ii,e]<-1
+ ii<-ii+1
+ }
+ X
+}
+
+# function computes the ancestor node numbers for each tip number
+# written by Liam J. Revell 2011
+compute.ancestor.nodes<-function(tree){
+ n<-length(tree$tip)
+ m<-tree$Nnode
+ X<-matrix(0,n,n+m,dimnames=list(1:n,1:(n+m)))
+ for(i in 1:n){
+ currnode<-i
+ while(currnode!=(n+1)){
+ X[i,currnode]<-1
+ currnode<-tree$edge[match(currnode,tree$edge[,2]),1]
+ }
+ X[i,currnode]<-1
+ }
+ X
+}
diff --git a/R/paintSubTree.R b/R/paintSubTree.R
index b5feb4d..240c715 100644
--- a/R/paintSubTree.R
+++ b/R/paintSubTree.R
@@ -1,94 +1,94 @@
-## paint branch(es)
-## written by Liam J. Revell 2014, 2015
-
-paintBranches<-function(tree,edge,state,anc.state="1"){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- if(is.null(tree$maps)) maps<-lapply(tree$edge.length,function(x) setNames(x,anc.state))
- else maps<-tree$maps
- ii<-sapply(edge,function(x,y) which(y==x),y=tree$edge[,2])
- for(i in 1:length(ii)) maps[[ii[i]]]<-setNames(tree$edge.length[[ii[i]]],state)
- ## build mapped.edge matrix
- s<-vector()
- for(i in 1:nrow(tree$edge)) s<-c(s,names(maps[[i]]))
- s<-unique(s)
- mapped.edge<-matrix(0,length(tree$edge.length),length(s),dimnames=list(edge=apply(tree$edge,1,function(x) paste(x,collapse=",")),state=s))
- for(i in 1:length(maps)) for(j in 1:length(maps[[i]])) mapped.edge[i,names(maps[[i]])[j]]<-mapped.edge[i,names(maps[[i]])[j]]+maps[[i]][j]
- ## add attributes to the tree
- tree$mapped.edge<-mapped.edge
- tree$maps<-maps
- class(tree)<-c("simmap",setdiff(class(tree),"simmap"))
- tree
-}
-
-# function paints a subtree
-# written by Liam Revell 2012, 2013, 2015
-
-paintSubTree<-function(tree,node,state,anc.state="1",stem=FALSE){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- if(stem==0&&node<=length(tree$tip)) stop("stem must be TRUE for node<=N")
- if(is.null(tree$edge.length)) tree<-compute.brlen(tree)
- if(is.null(tree$maps)){
- maps<-as.list(tree$edge.length)
- for(i in 1:length(maps)) names(maps[[i]])<-anc.state
-
- } else maps<-tree$maps
- if(node>length(tree$tip)){
- desc<-getDescendants(tree,node)
- z<-which(tree$edge[,2]%in%desc)
- for(i in 1:length(z)){
- maps[[z[i]]]<-sum(maps[[z[i]]])
- names(maps[[z[i]]])<-state
- }
- if(stem){
- a<-which(tree$edge[,2]==node)
- b<-bySegments(maps[[a]])/max(bySegments(maps[[a]]))
- c<-match(1,((1-stem)>=b[,1])*((1-stem)<=b[,2]))
- d<-names(maps[[a]])[1:c]
- e<-maps[[a]]
- if(c>1){
- maps[[a]]<-c(e[1:(c-1)],(1-stem)*sum(e)-sum(e[1:(c-1)]),stem*sum(e))
- names(maps[[a]])<-c(d,state)
- } else {
- maps[[a]]<-c((1-stem)*sum(e),stem*sum(e))
- names(maps[[a]])<-c(d,state)
- }
- }
- } else {
- a<-which(tree$edge[,2]==node)
- b<-bySegments(maps[[a]])/max(bySegments(maps[[a]]))
- c<-match(1,((1-stem)>=b[,1])*((1-stem)<=b[,2]))
- d<-names(maps[[a]])[1:c]
- e<-maps[[a]]
- if(c>1){
- maps[[a]]<-c(e[1:(c-1)],(1-stem)*sum(e)-sum(e[1:(c-1)]),stem*sum(e))
- names(maps[[a]])<-c(d,state)
- } else {
- maps[[a]]<-c((1-stem)*sum(e),stem*sum(e))
- names(maps[[a]])<-c(d,state)
- }
- }
- s<-vector()
- for(i in 1:nrow(tree$edge)) s<-c(s,names(maps[[i]]))
- s<-unique(s)
- mapped.edge<-matrix(0,length(tree$edge.length),length(s),dimnames=list(edge=apply(tree$edge,1,function(x) paste(x,collapse=",")),state=s))
- for(i in 1:length(maps)) for(j in 1:length(maps[[i]])) mapped.edge[i,names(maps[[i]])[j]]<-mapped.edge[i,names(maps[[i]])[j]]+maps[[i]][j]
- tree$mapped.edge<-mapped.edge
- tree$maps<-maps
- class(tree)<-c("simmap",setdiff(class(tree),"simmap"))
- return(tree)
-}
-
-# function
-# written by Liam Revell 2012
-
-bySegments<-function(z){
- XX<-matrix(0,length(z),2,dimnames=list(names(z),c("start","end")))
- XX[1,2]<-z[1]
- if(length(z)>1){
- for(j in 2:length(z)){
- XX[j,1]<-XX[j-1,2]
- XX[j,2]<-XX[j,1]+z[j]
- }
- }
- return(XX)
-}
+## paint branch(es)
+## written by Liam J. Revell 2014, 2015
+
+paintBranches<-function(tree,edge,state,anc.state="1"){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ if(is.null(tree$maps)) maps<-lapply(tree$edge.length,function(x) setNames(x,anc.state))
+ else maps<-tree$maps
+ ii<-sapply(edge,function(x,y) which(y==x),y=tree$edge[,2])
+ for(i in 1:length(ii)) maps[[ii[i]]]<-setNames(tree$edge.length[[ii[i]]],state)
+ ## build mapped.edge matrix
+ s<-vector()
+ for(i in 1:nrow(tree$edge)) s<-c(s,names(maps[[i]]))
+ s<-unique(s)
+ mapped.edge<-matrix(0,length(tree$edge.length),length(s),dimnames=list(edge=apply(tree$edge,1,function(x) paste(x,collapse=",")),state=s))
+ for(i in 1:length(maps)) for(j in 1:length(maps[[i]])) mapped.edge[i,names(maps[[i]])[j]]<-mapped.edge[i,names(maps[[i]])[j]]+maps[[i]][j]
+ ## add attributes to the tree
+ tree$mapped.edge<-mapped.edge
+ tree$maps<-maps
+ class(tree)<-c("simmap",setdiff(class(tree),"simmap"))
+ tree
+}
+
+# function paints a subtree
+# written by Liam Revell 2012, 2013, 2015
+
+paintSubTree<-function(tree,node,state,anc.state="1",stem=FALSE){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ if(stem==0&&node<=length(tree$tip)) stop("stem must be TRUE for node<=N")
+ if(is.null(tree$edge.length)) tree<-compute.brlen(tree)
+ if(is.null(tree$maps)){
+ maps<-as.list(tree$edge.length)
+ for(i in 1:length(maps)) names(maps[[i]])<-anc.state
+
+ } else maps<-tree$maps
+ if(node>length(tree$tip)){
+ desc<-getDescendants(tree,node)
+ z<-which(tree$edge[,2]%in%desc)
+ for(i in 1:length(z)){
+ maps[[z[i]]]<-sum(maps[[z[i]]])
+ names(maps[[z[i]]])<-state
+ }
+ if(stem){
+ a<-which(tree$edge[,2]==node)
+ b<-bySegments(maps[[a]])/max(bySegments(maps[[a]]))
+ c<-match(1,((1-stem)>=b[,1])*((1-stem)<=b[,2]))
+ d<-names(maps[[a]])[1:c]
+ e<-maps[[a]]
+ if(c>1){
+ maps[[a]]<-c(e[1:(c-1)],(1-stem)*sum(e)-sum(e[1:(c-1)]),stem*sum(e))
+ names(maps[[a]])<-c(d,state)
+ } else {
+ maps[[a]]<-c((1-stem)*sum(e),stem*sum(e))
+ names(maps[[a]])<-c(d,state)
+ }
+ }
+ } else {
+ a<-which(tree$edge[,2]==node)
+ b<-bySegments(maps[[a]])/max(bySegments(maps[[a]]))
+ c<-match(1,((1-stem)>=b[,1])*((1-stem)<=b[,2]))
+ d<-names(maps[[a]])[1:c]
+ e<-maps[[a]]
+ if(c>1){
+ maps[[a]]<-c(e[1:(c-1)],(1-stem)*sum(e)-sum(e[1:(c-1)]),stem*sum(e))
+ names(maps[[a]])<-c(d,state)
+ } else {
+ maps[[a]]<-c((1-stem)*sum(e),stem*sum(e))
+ names(maps[[a]])<-c(d,state)
+ }
+ }
+ s<-vector()
+ for(i in 1:nrow(tree$edge)) s<-c(s,names(maps[[i]]))
+ s<-unique(s)
+ mapped.edge<-matrix(0,length(tree$edge.length),length(s),dimnames=list(edge=apply(tree$edge,1,function(x) paste(x,collapse=",")),state=s))
+ for(i in 1:length(maps)) for(j in 1:length(maps[[i]])) mapped.edge[i,names(maps[[i]])[j]]<-mapped.edge[i,names(maps[[i]])[j]]+maps[[i]][j]
+ tree$mapped.edge<-mapped.edge
+ tree$maps<-maps
+ class(tree)<-c("simmap",setdiff(class(tree),"simmap"))
+ return(tree)
+}
+
+# function
+# written by Liam Revell 2012
+
+bySegments<-function(z){
+ XX<-matrix(0,length(z),2,dimnames=list(names(z),c("start","end")))
+ XX[1,2]<-z[1]
+ if(length(z)>1){
+ for(j in 2:length(z)){
+ XX[j,1]<-XX[j-1,2]
+ XX[j,2]<-XX[j,1]+z[j]
+ }
+ }
+ return(XX)
+}
diff --git a/R/pbtree.R b/R/pbtree.R
index d9dd7b7..9f8891f 100644
--- a/R/pbtree.R
+++ b/R/pbtree.R
@@ -1,260 +1,260 @@
-## function to simulate a pure-birth phylogenetic tree or trees
-## written by Liam J. Revell 2011-2015, 2018
-
-pbtree<-function(b=1,d=0,n=NULL,t=NULL,scale=NULL,nsim=1,
- type=c("continuous","discrete"),...){
- # get arguments
- if(hasArg(ape)) ape<-list(...)$ape
- else ape<-TRUE
- if(hasArg(quiet)) quiet<-list(...)$quiet
- else quiet<-FALSE
- if(hasArg(extant.only)) extant.only<-list(...)$extant.only
- else extant.only<-FALSE
- if(hasArg(max.count)) max.count<-list(...)$max.count
- else max.count<-1e5
- if(hasArg(method)) method<-list(...)$method
- else method<-"rejection"
- if(hasArg(tip.label)){
- tip.label<-list(...)$tip.label
- if(!is.null(tip.label)){
- if(is.null(n)){
- tip.label<-NULL
- cat("Warning: tip.label not allowed for n=NULL.\n")
- cat(" using default labels\n")
- } else if(length(tip.label)==n){
- if(d>0){
- cat("Warning: only using labels in tip.label for extant tips.\n")
- cat(" extinct tips will be labeled X1, X2, etc.\n")
- }
- } else if(length(tip.label)!=n) {
- cat("Warning: length(tip.label) and n do not match.\n")
- cat(" using default labels\n")
- tip.label<-NULL
- }
- }
- } else tip.label<-NULL
- type<-matchType(type[1],c("continuous","discrete"))
- if(type=="discrete"){
- if((b+d)>1){
- cat("Warning:\n b + d cannot exceed 1.0 in discrete-time simulations\n")
- cat(paste(" setting b & d to",b/(b+d),"and",d/(b+d),"respectively\n"))
- b<-b/(b+d)
- d<-d/(b+d)
- }
- }
- tol<-1e-12
- # done get arguments
- # if nsim > 1 replicate nsim times
- if(nsim>1){
- trees<-replicate(nsim,pbtree(b,d,n,t,scale,type=type,ape=ape,quiet=quiet,extant.only=extant.only,method=method,tip.label=tip.label),simplify=FALSE)
- class(trees)<-"multiPhylo"
- return(trees)
- } else {
- if(!is.null(n)) NN<-n else NN<-NULL
- if(!is.null(n)&&!is.null(t)){
- if(method=="rejection"){
- # simulate taxa & time stop using rejection sampling to max.count
- if(!quiet){
- cat("simulating with both taxa-stop (n) and time-stop (t) is\n")
- cat("performed via rejection sampling & may be slow\n\n")
- }
- N<-0; T<-0; count<--1
- while((N!=n||T<t)&&count<max.count){
- tree<-pbtree(b,d,t=t,type=type,ape=FALSE,extant.only=extant.only,quiet=TRUE)
- if(is.null(tree)) N<-T<-0
- else {
- N<-if(d>0&&extant.only==FALSE) length(getExtant(tree)) else length(tree$tip.label)
- T<-max(nodeHeights(tree))
- }
- count<-count+1
- }
- if(N==n&&T>=(t-tol)){
- if(!quiet) cat(paste(" ",count," trees rejected before finding a tree\n\n",sep=""))
- } else {
- if(!quiet) cat(paste(" max count of ",count," reached without finding a tree\n\n",sep=""))
- tree<-NULL
- }
- # done simulate taxa & time stop
- } else if(method=="direct"){
- # simulate using direct sampling (experimental)
- if(!quiet){
- cat("simulating with both taxa-stop (n) & time-stop (t) using\n")
- cat("'direct' sampling. this is experimental\n")
- }
- m<-2
- while(m[length(m)]!=n){
- ll<-bd<-vector(); m<-2; i<-1
- while(sum(ll)<t){
- ll[i]<-rexp(n=1,rate=m[i]*(b+d))
- if(sum(ll)<t) bd[i]<-2*rbinom(n=1,size=1,prob=b/(b+d))-1 else bd[i]<-0
- m[i+1]<-m[i]+bd[i]; i<-i+1
- if(m[i]==0) break
- }
- }
- ll[length(ll)]<-ll[length(ll)]+t-sum(ll)
- bd<-bd
- node<-1; dead<-1
- edge<-matrix(c(node,NA,node,NA),2,2,byrow=T)
- edge.length<-c(0,0)
- node<-node+1
- for(i in 1:length(bd)){
- o<-is.na(edge[,2])
- p<-which(o)
- l<-ll[i]
- birth<-if(bd[i]==1) TRUE else FALSE
- q<-if(length(p)>1) sample(p,size=1) else p
- if(birth){
- # new edge
- edge[q,2]<-node
- edge<-rbind(edge,matrix(c(node,NA,node,NA),2,2,byrow=T))
- node<-node+1
- } else {
- edge[q,2]<--dead
- dead<-dead+1
- }
- edge.length[p]<-edge.length[p]+l
- if(birth) edge.length<-c(edge.length,rep(0,2))
- }
- edge[edge[,2]<0,2]<-NA
- o<-is.na(edge[,2])
- n<-sum(o)
- edge<-edge+n
- p<-which(o)
- edge[o,2]<-1:sum(is.na(edge[,2]))
- # build 'phylo' object
- tree<-list(edge=edge,edge.length=edge.length,tip.label=paste("t",1:n,sep=""),Nnode=n-1)
- class(tree)<-"phylo"
- # done simulate using direct sampling (experimental)
- }
- } else {
- if(!is.null(t)){
- # simulation time stop
- node<-1; dead<-1
- edge<-matrix(c(node,NA,node,NA),2,2,byrow=T)
- edge.length<-c(0,0)
- node<-node+1; tt<-0
- while(tt<t){
- o<-is.na(edge[,2])
- if(!any(o)) break
- p<-which(o)
- if(type=="discrete"){
- l<-rgeom(n=sum(o),prob=b+d)+1
- l<-l[which(l==min(l))]
- } else l<-rexp(n=1,sum(o)*(b+d))
- tt<-tt+l[1]
- if(tt>=t) l<-l-tt+t
- else {
- birth<-sapply(runif(n=length(l)),function(x) if(x<b/(b+d)) TRUE else FALSE)
- q<-if(length(p)>1) sample(p)[1:min(length(p),length(l))] else p
- for(i in 1:length(l)){
- if(birth[i]){
- # new edge
- edge[q[i],2]<-node
- edge<-rbind(edge,matrix(c(node,NA,node,NA),2,2,byrow=T))
- node<-node+1
- } else {
- edge[q[i],2]<--dead
- dead<-dead+1
- }
- }
-
- }
- edge.length[p]<-edge.length[p]+l[1]
- edge.length<-c(edge.length,rep(0,2*length(l)))
- }
- edge[edge[,2]<0,2]<-NA
- o<-is.na(edge[,2])
- n<-sum(o)
- edge<-edge+n
- p<-which(o)
- edge[o,2]<-1:sum(is.na(edge[,2]))
- # done unique part of time stop
- } else if(!is.null(n)) {
- # simulate taxa stop
- node<-1
- edge<-matrix(c(node,NA,node,NA),2,2,byrow=T)
- edge.length<-c(0,0)
- node<-node+1; dead<-1; nn<-2
- while(nn<n){
- o<-is.na(edge[,2])
- if(!any(o)) break
- p<-which(o)
- if(type=="discrete"){
- l<-rgeom(n=sum(o),prob=b+d)+1
- l<-l[which(l==min(l))]
- } else l<-rexp(n=1,sum(o)*(b+d))
- birth<-birth<-sapply(runif(n=length(l)),function(x) if(x<b/(b+d)) TRUE else FALSE)
- q<-if(length(p)>1) sample(p)[1:min(length(p),length(l))] else p
- for(i in 1:length(l)){
- if(birth[i]){
- # new edge
- edge[q[i],2]<-node
- edge<-rbind(edge,matrix(c(node,NA,node,NA),2,2,byrow=T))
- node<-node+1
- } else {
- edge[q[i],2]<--dead
- dead<-dead+1
- }
- }
- edge.length[p]<-edge.length[p]+l[1]
- edge.length<-c(edge.length,rep(0,2*length(l)))
- nn<-sum(is.na(edge[,2]))
- }
- edge[edge[,2]<0,2]<-NA
- o<-is.na(edge[,2])
- nn<-sum(o)
- edge<-edge+nn
- p<-which(o)
- l<-if(type=="discrete") min(rgeom(n=sum(o),prob=(b+d))+1) else rexp(n=1,sum(o)*(b+d))
- edge.length[p]<-edge.length[p]+l
- edge[is.na(edge[,2]),2]<-1:sum(is.na(edge[,2]))
- if((nn-dead+1)>n&&!quiet){
- # this might happen in discrete time only
- cat("Warning:\n due to multiple speciation events in the final time interval\n")
- cat(" realized n may not equal input n\n\n")
- if(!is.null(tip.label)){
- cat("Warning: length(tip.label) and n do not match.\n")
- cat(" using default labels\n")
- tip.label<-NULL
- }
- }
- n<-nn
- # done unique part of taxa stop
- }
- # build 'phylo' object with temporary labels
- tree<-list(edge=edge,edge.length=edge.length,tip.label=1:n,Nnode=n-1)
- class(tree)<-"phylo"
- if(!is.null(scale)){
- # rescale if scale!=NULL
- h<-max(nodeHeights(tree))
- tree$edge.length<-scale*tree$edge.length/h
- }
- if(d>0&&extant.only){
- # prune extinct tips if extant.only==TRUE
- if(length(getExtinct(tree))==(length(tree$tip.label)-1)){
- if(!quiet) cat("Warning:\n no extant tips, tree returned as NULL\n")
- tree<-NULL
- } else tree<-drop.tip(tree,getExtinct(tree))
- }
- # if tree!=NULL assign final tip labels
- if(!is.null(tree)) tree$tip.label<-paste("t",1:length(tree$tip.label),sep="")
-
- }
- # if ape==TRUE make sure 'phylo' is consistent with ape
- if(ape&&is.null(tree)==FALSE) tree<-read.tree(text=write.tree(tree))
- if(!is.null(tip.label)){
- th<-max(nodeHeights(tree))
- if(length(getExtant(tree,tol=1e-08*th))!=NN){
- # simulation must have gone extint before reaching NN
- tree$tip.label<-paste("X",1:length(tree$tip.label),sep="")
- } else {
- ll<-getExtant(tree,tol=1e-08*th)
- ii<-sapply(ll,function(x,y) which(x==y),y=tree$tip.label)
- tree$tip.label[ii]<-tip.label
- tree$tip.label[-ii]<-paste("X",1:(length(tree$tip.label)-length(ii)),sep="")
- }
- }
- # done
- return(tree)
- }
-}
+## function to simulate a pure-birth phylogenetic tree or trees
+## written by Liam J. Revell 2011-2015, 2018
+
+pbtree<-function(b=1,d=0,n=NULL,t=NULL,scale=NULL,nsim=1,
+ type=c("continuous","discrete"),...){
+ # get arguments
+ if(hasArg(ape)) ape<-list(...)$ape
+ else ape<-TRUE
+ if(hasArg(quiet)) quiet<-list(...)$quiet
+ else quiet<-FALSE
+ if(hasArg(extant.only)) extant.only<-list(...)$extant.only
+ else extant.only<-FALSE
+ if(hasArg(max.count)) max.count<-list(...)$max.count
+ else max.count<-1e5
+ if(hasArg(method)) method<-list(...)$method
+ else method<-"rejection"
+ if(hasArg(tip.label)){
+ tip.label<-list(...)$tip.label
+ if(!is.null(tip.label)){
+ if(is.null(n)){
+ tip.label<-NULL
+ cat("Warning: tip.label not allowed for n=NULL.\n")
+ cat(" using default labels\n")
+ } else if(length(tip.label)==n){
+ if(d>0){
+ cat("Warning: only using labels in tip.label for extant tips.\n")
+ cat(" extinct tips will be labeled X1, X2, etc.\n")
+ }
+ } else if(length(tip.label)!=n) {
+ cat("Warning: length(tip.label) and n do not match.\n")
+ cat(" using default labels\n")
+ tip.label<-NULL
+ }
+ }
+ } else tip.label<-NULL
+ type<-matchType(type[1],c("continuous","discrete"))
+ if(type=="discrete"){
+ if((b+d)>1){
+ cat("Warning:\n b + d cannot exceed 1.0 in discrete-time simulations\n")
+ cat(paste(" setting b & d to",b/(b+d),"and",d/(b+d),"respectively\n"))
+ b<-b/(b+d)
+ d<-d/(b+d)
+ }
+ }
+ tol<-1e-12
+ # done get arguments
+ # if nsim > 1 replicate nsim times
+ if(nsim>1){
+ trees<-replicate(nsim,pbtree(b,d,n,t,scale,type=type,ape=ape,quiet=quiet,extant.only=extant.only,method=method,tip.label=tip.label),simplify=FALSE)
+ class(trees)<-"multiPhylo"
+ return(trees)
+ } else {
+ if(!is.null(n)) NN<-n else NN<-NULL
+ if(!is.null(n)&&!is.null(t)){
+ if(method=="rejection"){
+ # simulate taxa & time stop using rejection sampling to max.count
+ if(!quiet){
+ cat("simulating with both taxa-stop (n) and time-stop (t) is\n")
+ cat("performed via rejection sampling & may be slow\n\n")
+ }
+ N<-0; T<-0; count<--1
+ while((N!=n||T<t)&&count<max.count){
+ tree<-pbtree(b,d,t=t,type=type,ape=FALSE,extant.only=extant.only,quiet=TRUE)
+ if(is.null(tree)) N<-T<-0
+ else {
+ N<-if(d>0&&extant.only==FALSE) length(getExtant(tree)) else length(tree$tip.label)
+ T<-max(nodeHeights(tree))
+ }
+ count<-count+1
+ }
+ if(N==n&&T>=(t-tol)){
+ if(!quiet) cat(paste(" ",count," trees rejected before finding a tree\n\n",sep=""))
+ } else {
+ if(!quiet) cat(paste(" max count of ",count," reached without finding a tree\n\n",sep=""))
+ tree<-NULL
+ }
+ # done simulate taxa & time stop
+ } else if(method=="direct"){
+ # simulate using direct sampling (experimental)
+ if(!quiet){
+ cat("simulating with both taxa-stop (n) & time-stop (t) using\n")
+ cat("'direct' sampling. this is experimental\n")
+ }
+ m<-2
+ while(m[length(m)]!=n){
+ ll<-bd<-vector(); m<-2; i<-1
+ while(sum(ll)<t){
+ ll[i]<-rexp(n=1,rate=m[i]*(b+d))
+ if(sum(ll)<t) bd[i]<-2*rbinom(n=1,size=1,prob=b/(b+d))-1 else bd[i]<-0
+ m[i+1]<-m[i]+bd[i]; i<-i+1
+ if(m[i]==0) break
+ }
+ }
+ ll[length(ll)]<-ll[length(ll)]+t-sum(ll)
+ bd<-bd
+ node<-1; dead<-1
+ edge<-matrix(c(node,NA,node,NA),2,2,byrow=T)
+ edge.length<-c(0,0)
+ node<-node+1
+ for(i in 1:length(bd)){
+ o<-is.na(edge[,2])
+ p<-which(o)
+ l<-ll[i]
+ birth<-if(bd[i]==1) TRUE else FALSE
+ q<-if(length(p)>1) sample(p,size=1) else p
+ if(birth){
+ # new edge
+ edge[q,2]<-node
+ edge<-rbind(edge,matrix(c(node,NA,node,NA),2,2,byrow=T))
+ node<-node+1
+ } else {
+ edge[q,2]<--dead
+ dead<-dead+1
+ }
+ edge.length[p]<-edge.length[p]+l
+ if(birth) edge.length<-c(edge.length,rep(0,2))
+ }
+ edge[edge[,2]<0,2]<-NA
+ o<-is.na(edge[,2])
+ n<-sum(o)
+ edge<-edge+n
+ p<-which(o)
+ edge[o,2]<-1:sum(is.na(edge[,2]))
+ # build 'phylo' object
+ tree<-list(edge=edge,edge.length=edge.length,tip.label=paste("t",1:n,sep=""),Nnode=n-1)
+ class(tree)<-"phylo"
+ # done simulate using direct sampling (experimental)
+ }
+ } else {
+ if(!is.null(t)){
+ # simulation time stop
+ node<-1; dead<-1
+ edge<-matrix(c(node,NA,node,NA),2,2,byrow=T)
+ edge.length<-c(0,0)
+ node<-node+1; tt<-0
+ while(tt<t){
+ o<-is.na(edge[,2])
+ if(!any(o)) break
+ p<-which(o)
+ if(type=="discrete"){
+ l<-rgeom(n=sum(o),prob=b+d)+1
+ l<-l[which(l==min(l))]
+ } else l<-rexp(n=1,sum(o)*(b+d))
+ tt<-tt+l[1]
+ if(tt>=t) l<-l-tt+t
+ else {
+ birth<-sapply(runif(n=length(l)),function(x) if(x<b/(b+d)) TRUE else FALSE)
+ q<-if(length(p)>1) sample(p)[1:min(length(p),length(l))] else p
+ for(i in 1:length(l)){
+ if(birth[i]){
+ # new edge
+ edge[q[i],2]<-node
+ edge<-rbind(edge,matrix(c(node,NA,node,NA),2,2,byrow=T))
+ node<-node+1
+ } else {
+ edge[q[i],2]<--dead
+ dead<-dead+1
+ }
+ }
+
+ }
+ edge.length[p]<-edge.length[p]+l[1]
+ edge.length<-c(edge.length,rep(0,2*length(l)))
+ }
+ edge[edge[,2]<0,2]<-NA
+ o<-is.na(edge[,2])
+ n<-sum(o)
+ edge<-edge+n
+ p<-which(o)
+ edge[o,2]<-1:sum(is.na(edge[,2]))
+ # done unique part of time stop
+ } else if(!is.null(n)) {
+ # simulate taxa stop
+ node<-1
+ edge<-matrix(c(node,NA,node,NA),2,2,byrow=T)
+ edge.length<-c(0,0)
+ node<-node+1; dead<-1; nn<-2
+ while(nn<n){
+ o<-is.na(edge[,2])
+ if(!any(o)) break
+ p<-which(o)
+ if(type=="discrete"){
+ l<-rgeom(n=sum(o),prob=b+d)+1
+ l<-l[which(l==min(l))]
+ } else l<-rexp(n=1,sum(o)*(b+d))
+ birth<-birth<-sapply(runif(n=length(l)),function(x) if(x<b/(b+d)) TRUE else FALSE)
+ q<-if(length(p)>1) sample(p)[1:min(length(p),length(l))] else p
+ for(i in 1:length(l)){
+ if(birth[i]){
+ # new edge
+ edge[q[i],2]<-node
+ edge<-rbind(edge,matrix(c(node,NA,node,NA),2,2,byrow=T))
+ node<-node+1
+ } else {
+ edge[q[i],2]<--dead
+ dead<-dead+1
+ }
+ }
+ edge.length[p]<-edge.length[p]+l[1]
+ edge.length<-c(edge.length,rep(0,2*length(l)))
+ nn<-sum(is.na(edge[,2]))
+ }
+ edge[edge[,2]<0,2]<-NA
+ o<-is.na(edge[,2])
+ nn<-sum(o)
+ edge<-edge+nn
+ p<-which(o)
+ l<-if(type=="discrete") min(rgeom(n=sum(o),prob=(b+d))+1) else rexp(n=1,sum(o)*(b+d))
+ edge.length[p]<-edge.length[p]+l
+ edge[is.na(edge[,2]),2]<-1:sum(is.na(edge[,2]))
+ if((nn-dead+1)>n&&!quiet){
+ # this might happen in discrete time only
+ cat("Warning:\n due to multiple speciation events in the final time interval\n")
+ cat(" realized n may not equal input n\n\n")
+ if(!is.null(tip.label)){
+ cat("Warning: length(tip.label) and n do not match.\n")
+ cat(" using default labels\n")
+ tip.label<-NULL
+ }
+ }
+ n<-nn
+ # done unique part of taxa stop
+ }
+ # build 'phylo' object with temporary labels
+ tree<-list(edge=edge,edge.length=edge.length,tip.label=1:n,Nnode=n-1)
+ class(tree)<-"phylo"
+ if(!is.null(scale)){
+ # rescale if scale!=NULL
+ h<-max(nodeHeights(tree))
+ tree$edge.length<-scale*tree$edge.length/h
+ }
+ if(d>0&&extant.only){
+ # prune extinct tips if extant.only==TRUE
+ if(length(getExtinct(tree))==(length(tree$tip.label)-1)){
+ if(!quiet) cat("Warning:\n no extant tips, tree returned as NULL\n")
+ tree<-NULL
+ } else tree<-drop.tip(tree,getExtinct(tree))
+ }
+ # if tree!=NULL assign final tip labels
+ if(!is.null(tree)) tree$tip.label<-paste("t",1:length(tree$tip.label),sep="")
+
+ }
+ # if ape==TRUE make sure 'phylo' is consistent with ape
+ if(ape&&is.null(tree)==FALSE) tree<-read.tree(text=write.tree(tree))
+ if(!is.null(tip.label)){
+ th<-max(nodeHeights(tree))
+ if(length(getExtant(tree,tol=1e-08*th))!=NN){
+ # simulation must have gone extint before reaching NN
+ tree$tip.label<-paste("X",1:length(tree$tip.label),sep="")
+ } else {
+ ll<-getExtant(tree,tol=1e-08*th)
+ ii<-sapply(ll,function(x,y) which(x==y),y=tree$tip.label)
+ tree$tip.label[ii]<-tip.label
+ tree$tip.label[-ii]<-paste("X",1:(length(tree$tip.label)-length(ii)),sep="")
+ }
+ }
+ # done
+ return(tree)
+ }
+}
diff --git a/R/pgls.Ives.R b/R/pgls.Ives.R
index ce43a67..90301ee 100644
--- a/R/pgls.Ives.R
+++ b/R/pgls.Ives.R
@@ -1,180 +1,180 @@
-## implements method of Ives et al. 2007 for PGLS regression with sampling error
-## written by Liam J. Revell 2012, 2013, 2015 2017
-
-pgls.Ives<-function(tree,X,y,Vx=NULL,Vy=NULL,Cxy=NULL,lower=c(1e-8,1e-8),
- fixed.b1=NULL){
-
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
-
- cat("\n")
- cat("---------------------------------------------------------------\n")
- cat("| **Warning: |\n")
- cat("| User reports suggest that this method may frequently |\n")
- cat("| fail to find the ML solution. Please use with caution. |\n")
- cat("---------------------------------------------------------------\n\n")
-
-
- # likelihood function
- lik<-function(theta,C,x,y,Mx,My,Mxy,fixed.b1=NULL){
- sig2x<-theta[1]
- sig2y<-theta[2]
- b1<-if(is.null(fixed.b1)) theta[3] else fixed.b1
- a<-theta[4:5]
- n<-nrow(C)
- Psi<-matrix(0,2*n,2*n)
- Psi[1:n,1:n]<-sig2x*C+diag(Mx)
- Psi[n+1:n,1:n]<-Psi[1:n,n+1:n]<-b1*sig2x*C+diag(Mxy)
- Psi[n+1:n,n+1:n]<-b1^2*sig2x*C+sig2y*C+diag(My)
- z<-c(X,y)
- D<-kronecker(diag(rep(1,2)),matrix(rep(1,n)))
- L<-dmnorm(z,(D%*%a)[,1],Psi,log=TRUE)
- return(-L)
- }
-
- # check data input format
- Xbar<-ybar<-NULL
- if((length(X)>length(unique(names(X))))&&is.null(Vx)){
- a<-aggregate(X,by=list(names(X)),FUN=mean)
- Xbar<-setNames(a[,2],a[,1])
- a<-aggregate(X,by=list(names(X)),FUN=var)
- Vx<-setNames(a[,2],a[,1])
- nx<-summary(as.factor(names(X)))[names(Vx)]
- Vx<-Vx/nx
- if(any(is.na(Vx))){
- warning("Some species contain only one sample. Substituting mean variance.",
- call.=FALSE)
- Vx[which(is.na(Vx))]<-mean(Vx*nx,na.rm=TRUE)
- }
- rm(a,nx)
- }
- if((length(y)>length(unique(names(y))))&&is.null(Vy)){
- a<-aggregate(y,by=list(names(y)),FUN=mean)
- ybar<-setNames(a[,2],a[,1])
- a<-aggregate(y,by=list(names(y)),FUN=var)
- Vy<-setNames(a[,2],a[,1])
- ny<-summary(as.factor(names(y)))[names(Vy)]
- Vy<-Vy/ny
- if(any(is.na(Vy))){
- warning("Some species contain only one sample. Substituting mean variance.",
- call.=FALSE)
- Vy[which(is.na(Vy))]<-mean(Vy*ny,na.rm=TRUE)
- }
- rm(a,ny)
- }
- if(is.null(Cxy)){
- a<-aggregate(X,by=list(names(X)),FUN=mean); a<-setNames(a[,2],a[,1])
- b<-aggregate(y,by=list(names(y)),FUN=mean); b<-setNames(b[,2],b[,1])
- c<-(X-a[names(X)])*(y-b[names(y)])
- d<-aggregate(c,by=list(names(c)),FUN=sum); d<-setNames(d[,2],d[,1])
- nxy<-summary(as.factor(names(y)))[names(d)]
- Cxy<-d/(nxy-1)/nxy
- if(any(is.na(Cxy))){
- warning("Some species contain only one sample. Substituting mean variance.",
- call.=FALSE)
- Cxy[which(is.na(Cxy))]<-mean(Cxy*nxy,na.rm=TRUE)
- }
- rm(a,b,c,nxy)
- }
- if(!is.null(Xbar)) X<-Xbar
- if(!is.null(ybar)) y<-ybar
-
- # perform calculation & organization
- C<-vcv.phylo(tree)
- X<-X[tree$tip.label]
- y<-y[tree$tip.label]
- Vx<-Vx[tree$tip.label]
- Vy<-Vy[tree$tip.label]
- Cxy<-Cxy[tree$tip.label]
-
- # get some reasonable starting values for optimization
- b<-if(is.null(fixed.b1)) runif(n=1,min=0,max=2)*lm(pic(y,
- tree)~pic(X,tree))$coefficients[2] else fixed.b1
- names(b)<-NULL
- sig2x<-runif(n=1,min=0,max=2)*mean(pic(X,tree)^2)
- sig2y<-runif(n=1,min=0,max=2)*mean(pic(y,tree)^2)
- a<-runif(n=2,min=-1,max=1)*c(mean(X),mean(y))
-
- # optimize regression model
- r<-optim(c(sig2x,sig2y,b,a),lik,C=C,x=X,y=y,Mx=Vx,My=Vy,Mxy=Cxy,
- fixed.b1=fixed.b1,method="L-BFGS-B",
- lower=c(lower,-Inf,-Inf,-Inf),control=list(factr=1e10))
-
- k<-if(is.null(fixed.b1)) 5 else 4
- if(all(Vx==0)) k<-k-1
- if(all(Vy==0)) k<-k-1
-
- # return r
- obj<-list(beta=c(r$par[5]-r$par[3]*r$par[4],
- if(is.null(fixed.b1)) r$par[3] else fixed.b1),sig2x=r$par[1],
- sig2y=r$par[2],a=r$par[4:5],logL=-r$value,convergence=r$convergence,
- message=r$message,df=c(k,Ntip(tree)-k))
- class(obj)<-"pgls.Ives"
- obj
-}
-
-logLik.pgls.Ives<-function(object,...){
- lik<-object$logL
- attr(lik,"df")<-object$df[1]
- lik
-}
-
-print.pgls.Ives<-function(x,digits=6,...){
- cat("\nResult PGLS with sampling error in x & y")
- cat("\n (based on Ives et al. 2007):\n\n")
- cat("Response: y\n")
- object<-data.frame(x$beta[1],x$beta[2])
- colnames(object)<-c("Intercept","beta[1]")
- rownames(object)<-"y"
- print(object)
- cat("\nSummary of ML estimated parameters:\n")
- object<-data.frame(round(c(x$sig2y,x$sig2x),digits),
- round(c(x$a[2:1]),digits),c(round(x$logL,digits),""))
- colnames(object)<-c("sigma^2","a","log(L)")
- rownames(object)<-c("y","x")
- print(object)
- cat("---------\n")
- if(x$convergence==0) cat("\nR thinks it has converged.\n\n")
- else ("\nR may not have converged.\n\n")
-}
-
-## simpler function to take sampling error into account for y only
-## written by Liam J. Revell 2017, 2021
-
-pgls.SEy<-function(model,data,corClass=corBrownian,tree,
- se=NULL,method=c("REML","ML"),interval=c(0,1000),...){
- Call<-match.call()
- corfunc<-corClass
- ## preliminaries
- spp<-rownames(data)
- data<-cbind(data,spp)
- if(is.null(se)) se<-setNames(rep(0,Ntip(tree)),
- tree$tip.label)[spp] else se<-se[spp]
- ## likelihood function
- lk<-function(sig2e,data,tree,model,ve,corfunc,spp){
- tree$edge.length<-tree$edge.length*sig2e
- ii<-sapply(1:Ntip(tree),function(x,e) which(e==x),
- e=tree$edge[,2])
- tree$edge.length[ii]<-tree$edge.length[ii]+ve[tree$tip.label]
- vf<-diag(vcv(tree))[spp]
- w<-varFixed(~vf)
- COR<-corfunc(1,tree,form=~spp,...)
- fit<-gls(model,data=cbind(data,vf),correlation=COR,method=method,
- weights=w)
- -logLik(fit)
- }
- ## estimate sig2[e]
- fit<-optimize(lk,interval=interval,data=data,tree=tree,model=model,
- ve=se^2,corfunc=corfunc,spp=spp)
- tree$edge.length<-tree$edge.length*fit$minimum
- ii<-sapply(1:Ntip(tree),function(x,e) which(e==x),
- e=tree$edge[,2])
- tree$edge.length[ii]<-tree$edge.length[ii]+
- se[tree$tip.label]^2
- vf<-diag(vcv(tree))[spp]
- w<-varFixed(~vf)
- ## fit & return model
- obj<-gls(model,data=cbind(data,vf),correlation=corfunc(1,tree,
- form=~spp,...),weights=w,method=method)
- obj$call<-Call
- obj
-}
+## implements method of Ives et al. 2007 for PGLS regression with sampling error
+## written by Liam J. Revell 2012, 2013, 2015 2017
+
+pgls.Ives<-function(tree,X,y,Vx=NULL,Vy=NULL,Cxy=NULL,lower=c(1e-8,1e-8),
+ fixed.b1=NULL){
+
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+
+ cat("\n")
+ cat("---------------------------------------------------------------\n")
+ cat("| **Warning: |\n")
+ cat("| User reports suggest that this method may frequently |\n")
+ cat("| fail to find the ML solution. Please use with caution. |\n")
+ cat("---------------------------------------------------------------\n\n")
+
+
+ # likelihood function
+ lik<-function(theta,C,x,y,Mx,My,Mxy,fixed.b1=NULL){
+ sig2x<-theta[1]
+ sig2y<-theta[2]
+ b1<-if(is.null(fixed.b1)) theta[3] else fixed.b1
+ a<-theta[4:5]
+ n<-nrow(C)
+ Psi<-matrix(0,2*n,2*n)
+ Psi[1:n,1:n]<-sig2x*C+diag(Mx)
+ Psi[n+1:n,1:n]<-Psi[1:n,n+1:n]<-b1*sig2x*C+diag(Mxy)
+ Psi[n+1:n,n+1:n]<-b1^2*sig2x*C+sig2y*C+diag(My)
+ z<-c(X,y)
+ D<-kronecker(diag(rep(1,2)),matrix(rep(1,n)))
+ L<-dmnorm(z,(D%*%a)[,1],Psi,log=TRUE)
+ return(-L)
+ }
+
+ # check data input format
+ Xbar<-ybar<-NULL
+ if((length(X)>length(unique(names(X))))&&is.null(Vx)){
+ a<-aggregate(X,by=list(names(X)),FUN=mean)
+ Xbar<-setNames(a[,2],a[,1])
+ a<-aggregate(X,by=list(names(X)),FUN=var)
+ Vx<-setNames(a[,2],a[,1])
+ nx<-summary(as.factor(names(X)))[names(Vx)]
+ Vx<-Vx/nx
+ if(any(is.na(Vx))){
+ warning("Some species contain only one sample. Substituting mean variance.",
+ call.=FALSE)
+ Vx[which(is.na(Vx))]<-mean(Vx*nx,na.rm=TRUE)
+ }
+ rm(a,nx)
+ }
+ if((length(y)>length(unique(names(y))))&&is.null(Vy)){
+ a<-aggregate(y,by=list(names(y)),FUN=mean)
+ ybar<-setNames(a[,2],a[,1])
+ a<-aggregate(y,by=list(names(y)),FUN=var)
+ Vy<-setNames(a[,2],a[,1])
+ ny<-summary(as.factor(names(y)))[names(Vy)]
+ Vy<-Vy/ny
+ if(any(is.na(Vy))){
+ warning("Some species contain only one sample. Substituting mean variance.",
+ call.=FALSE)
+ Vy[which(is.na(Vy))]<-mean(Vy*ny,na.rm=TRUE)
+ }
+ rm(a,ny)
+ }
+ if(is.null(Cxy)){
+ a<-aggregate(X,by=list(names(X)),FUN=mean); a<-setNames(a[,2],a[,1])
+ b<-aggregate(y,by=list(names(y)),FUN=mean); b<-setNames(b[,2],b[,1])
+ c<-(X-a[names(X)])*(y-b[names(y)])
+ d<-aggregate(c,by=list(names(c)),FUN=sum); d<-setNames(d[,2],d[,1])
+ nxy<-summary(as.factor(names(y)))[names(d)]
+ Cxy<-d/(nxy-1)/nxy
+ if(any(is.na(Cxy))){
+ warning("Some species contain only one sample. Substituting mean variance.",
+ call.=FALSE)
+ Cxy[which(is.na(Cxy))]<-mean(Cxy*nxy,na.rm=TRUE)
+ }
+ rm(a,b,c,nxy)
+ }
+ if(!is.null(Xbar)) X<-Xbar
+ if(!is.null(ybar)) y<-ybar
+
+ # perform calculation & organization
+ C<-vcv.phylo(tree)
+ X<-X[tree$tip.label]
+ y<-y[tree$tip.label]
+ Vx<-Vx[tree$tip.label]
+ Vy<-Vy[tree$tip.label]
+ Cxy<-Cxy[tree$tip.label]
+
+ # get some reasonable starting values for optimization
+ b<-if(is.null(fixed.b1)) runif(n=1,min=0,max=2)*lm(pic(y,
+ tree)~pic(X,tree))$coefficients[2] else fixed.b1
+ names(b)<-NULL
+ sig2x<-runif(n=1,min=0,max=2)*mean(pic(X,tree)^2)
+ sig2y<-runif(n=1,min=0,max=2)*mean(pic(y,tree)^2)
+ a<-runif(n=2,min=-1,max=1)*c(mean(X),mean(y))
+
+ # optimize regression model
+ r<-optim(c(sig2x,sig2y,b,a),lik,C=C,x=X,y=y,Mx=Vx,My=Vy,Mxy=Cxy,
+ fixed.b1=fixed.b1,method="L-BFGS-B",
+ lower=c(lower,-Inf,-Inf,-Inf),control=list(factr=1e10))
+
+ k<-if(is.null(fixed.b1)) 5 else 4
+ if(all(Vx==0)) k<-k-1
+ if(all(Vy==0)) k<-k-1
+
+ # return r
+ obj<-list(beta=c(r$par[5]-r$par[3]*r$par[4],
+ if(is.null(fixed.b1)) r$par[3] else fixed.b1),sig2x=r$par[1],
+ sig2y=r$par[2],a=r$par[4:5],logL=-r$value,convergence=r$convergence,
+ message=r$message,df=c(k,Ntip(tree)-k))
+ class(obj)<-"pgls.Ives"
+ obj
+}
+
+logLik.pgls.Ives<-function(object,...){
+ lik<-object$logL
+ attr(lik,"df")<-object$df[1]
+ lik
+}
+
+print.pgls.Ives<-function(x,digits=6,...){
+ cat("\nResult PGLS with sampling error in x & y")
+ cat("\n (based on Ives et al. 2007):\n\n")
+ cat("Response: y\n")
+ object<-data.frame(x$beta[1],x$beta[2])
+ colnames(object)<-c("Intercept","beta[1]")
+ rownames(object)<-"y"
+ print(object)
+ cat("\nSummary of ML estimated parameters:\n")
+ object<-data.frame(round(c(x$sig2y,x$sig2x),digits),
+ round(c(x$a[2:1]),digits),c(round(x$logL,digits),""))
+ colnames(object)<-c("sigma^2","a","log(L)")
+ rownames(object)<-c("y","x")
+ print(object)
+ cat("---------\n")
+ if(x$convergence==0) cat("\nR thinks it has converged.\n\n")
+ else ("\nR may not have converged.\n\n")
+}
+
+## simpler function to take sampling error into account for y only
+## written by Liam J. Revell 2017, 2021
+
+pgls.SEy<-function(model,data,corClass=corBrownian,tree,
+ se=NULL,method=c("REML","ML"),interval=c(0,1000),...){
+ Call<-match.call()
+ corfunc<-corClass
+ ## preliminaries
+ spp<-rownames(data)
+ data<-cbind(data,spp)
+ if(is.null(se)) se<-setNames(rep(0,Ntip(tree)),
+ tree$tip.label)[spp] else se<-se[spp]
+ ## likelihood function
+ lk<-function(sig2e,data,tree,model,ve,corfunc,spp){
+ tree$edge.length<-tree$edge.length*sig2e
+ ii<-sapply(1:Ntip(tree),function(x,e) which(e==x),
+ e=tree$edge[,2])
+ tree$edge.length[ii]<-tree$edge.length[ii]+ve[tree$tip.label]
+ vf<-diag(vcv(tree))[spp]
+ w<-varFixed(~vf)
+ COR<-corfunc(1,tree,form=~spp,...)
+ fit<-gls(model,data=cbind(data,vf),correlation=COR,method=method,
+ weights=w)
+ -logLik(fit)
+ }
+ ## estimate sig2[e]
+ fit<-optimize(lk,interval=interval,data=data,tree=tree,model=model,
+ ve=se^2,corfunc=corfunc,spp=spp)
+ tree$edge.length<-tree$edge.length*fit$minimum
+ ii<-sapply(1:Ntip(tree),function(x,e) which(e==x),
+ e=tree$edge[,2])
+ tree$edge.length[ii]<-tree$edge.length[ii]+
+ se[tree$tip.label]^2
+ vf<-diag(vcv(tree))[spp]
+ w<-varFixed(~vf)
+ ## fit & return model
+ obj<-gls(model,data=cbind(data,vf),correlation=corfunc(1,tree,
+ form=~spp,...),weights=w,method=method)
+ obj$call<-Call
+ obj
+}
diff --git a/R/phenogram.R b/R/phenogram.R
index 155c57f..d5bb832 100644
--- a/R/phenogram.R
+++ b/R/phenogram.R
@@ -1,212 +1,212 @@
-## function creates a phenogram (i.e., 'traitgram')
-## written by Liam J. Revell 2011, 2012, 2013, 2014, 2015, 2016, 2020, 2021
-
-phenogram<-function(tree,x,fsize=1.0,ftype="reg",colors=NULL,axes=list(),add=FALSE,...){
- ## get optional arguments
- if(hasArg(xlim)) xlim<-list(...)$xlim
- else xlim<-NULL
- if(hasArg(ylim)) ylim<-list(...)$ylim
- else ylim<-NULL
- if(hasArg(log)) log<-list(...)$log
- else log<-""
- if(hasArg(main)) main<-list(...)$main
- else main<-NULL
- if(hasArg(sub)) sub<-list(...)$sub
- else sub<-NULL
- if(hasArg(xlab)) xlab<-list(...)$xlab
- else xlab<-"time"
- if(hasArg(ylab)) ylab<-list(...)$ylab
- else ylab<-"phenotype"
- if(hasArg(asp)) asp<-list(...)$asp
- else asp<-NA
- if(hasArg(type)) type<-list(...)$type
- else type<-"l"
- if(hasArg(lty)) lty<-list(...)$lty
- else lty<-1
- if(hasArg(lwd)) lwd<-list(...)$lwd
- else lwd<-2
- if(hasArg(offset)) offset<-list(...)$offset
- else offset<-0.2
- if(hasArg(offsetFudge)) offsetFudge<-list(...)$offsetFudge
- else offsetFudge<-1.37
- if(hasArg(digits)) digits<-list(...)$digits
- else digits<-2
- if(hasArg(nticks)) nticks<-list(...)$nticks
- else nticks<-5
- if(hasArg(spread.labels)) spread.labels<-list(...)$spread.labels
- else spread.labels<-TRUE
- if(ftype=="off") spread.labels<-FALSE
- if(hasArg(spread.cost)) spread.cost<-list(...)$spread.cost
- else spread.cost<-c(1,0.4)
- if(hasArg(spread.range)) spread.range<-list(...)$spread.range
- else spread.range<-range(x)
- if(hasArg(link)) link<-list(...)$link
- else link<-if(spread.labels) 0.1*max(nodeHeights(tree)) else 0
- if(hasArg(hold)) hold<-list(...)$hold
- else hold<-TRUE
- if(hasArg(quiet)) quiet<-list(...)$quiet
- else quiet<-FALSE
- if(hasArg(label.pos)) label.pos<-list(...)$label.pos
- else label.pos<-NULL
- if(hasArg(cex.axis)) cex.axis<-list(...)$cex.axis
- else cex.axis<-par()$cex.axis
- if(hasArg(cex.lab)) cex.lab<-list(...)$cex.lab
- else cex.lab<-par()$cex.lab
- if(hasArg(las)) las<-list(...)$las
- else las<-par()$las
- ## end optional arguments
- # check tree
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- # check font
- ftype<-which(c("off","reg","b","i","bi")==ftype)-1
- if(!ftype&&!add) fsize=0
- H<-nodeHeights(tree)
- if(length(x)<(length(tree$tip)+tree$Nnode))
- x<-c(x,fastAnc(tree,x))
- else
- x<-c(x[tree$tip.label],x[as.character(length(tree$tip)+1:tree$Nnode)])
- x[1:length(tree$tip)]<-x[tree$tip.label]
- names(x)[1:length(tree$tip)]<-1:length(tree$tip)
- X<-matrix(x[as.character(tree$edge)],nrow(tree$edge),ncol(tree$edge))
- # legacy 'axes' argument trumps ylim & xlim from optional (...)
- if(is.null(axes$trait)&&is.null(ylim)) ylim<-c(min(x),max(x))
- else if(!is.null(axes$trait)) ylim<-axes$trait
- if(!is.null(axes$time)) xlim<-axes$time
- if(!add&&is.null(xlim)){
- pp<-par("pin")[1]
- sw<-fsize*(max(strwidth(tree$tip.label,units="inches")))+
- offsetFudge*offset*fsize*strwidth("W",units="inches")
- alp<-optimize(function(a,H,link,sw,pp) (a*1.04*(max(H)+link)+sw-pp)^2,H=H,
- link=link,sw=sw,pp=pp,interval=c(0,1e6))$minimum
- xlim<-c(min(H),max(H)+link+sw/alp)
- }
- if(!quiet&&Ntip(tree)>=40&&spread.labels){
- cat("Optimizing the positions of the tip labels...\n")
- flush.console()
- }
- ## matrix for tip coordinates
- tip.coords<-matrix(NA,Ntip(tree),2,dimnames=list(tree$tip.label,c("x","y")))
- if(hold) null<-dev.hold()
- if(is.null(tree$maps)){
- if(is.null(colors)) colors<-"black"
- if(!add){
- plot(H[1,],X[1,],type=type,lwd=lwd,lty=lty,col=colors,xlim=xlim,ylim=ylim,
- log=log,asp=asp,xlab="",ylab="",frame=FALSE,axes=FALSE)
- if(spread.labels) tt<-spreadlabels(tree,x,fsize=fsize,cost=spread.cost,
- range=spread.range,label.pos=label.pos,log=log) else tt<-x[1:length(tree$tip)]
- if(tree$edge[1,2]<=length(tree$tip)){
- if(fsize&&!add){
- text(gsub("_"," ",tree$tip.label[tree$edge[1,2]]),x=H[1,2]+link,
- y=tt[tree$edge[1,2]],cex=fsize,font=ftype,pos=4,offset=offset)
- tip.coords[tree$tip.label[tree$edge[1,2]],]<-c(H[1,2]+link,
- tt[tree$edge[1,2]])
- if(link>0) lines(x=c(H[1,2],H[1,2]+link),y=c(X[1,2],
- tt[tree$edge[1,2]]),lty=3)
- }
- }
- s<-2
- } else s<-1
- for(i in s:nrow(H)){
- lines(H[i,],X[i,],type=type,lwd=lwd,lty=lty,col=colors)
- if(tree$edge[i,2]<=length(tree$tip)){
- if(fsize&&!add){
- text(gsub("_"," ",tree$tip.label[tree$edge[i,2]]),x=H[i,2]+link,
- y=tt[tree$edge[i,2]],cex=fsize,font=ftype,pos=4,offset=offset)
- tip.coords[tree$tip.label[tree$edge[i,2]],]<-c(H[i,2]+link,
- tt[tree$edge[i,2]])
- if(link>0) lines(x=c(H[i,2],H[i,2]+link),y=c(X[i,2],tt[tree$edge[i,2]]),
- lty=3)
- }
- }
- }
- } else {
- if(is.null(colors)){
- nn<-sort(unique(c(getStates(tree,"tips"),getStates(tree,"nodes"))))
- colors<-setNames(palette()[1:length(nn)],nn)
- }
- for(i in 1:nrow(H)){
- y<-H[i,1]
- m<-diff(X[i,])/diff(H[i,])
- for(j in 1:length(tree$maps[[i]])){
- a<-c(y,y+tree$maps[[i]][j])
- b<-m*(a-H[i,1])+X[i,1]
- if(i==1&&j==1&&!add) {
- plot(a,b,col=colors[names(tree$maps[[i]])[j]],type=type,lwd=lwd,
- lty=lty,xlim=xlim,ylim=ylim,log=log,asp=asp,axes=FALSE,xlab="",
- ylab="")
- if(spread.labels) tt<-spreadlabels(tree,x[1:length(tree$tip)],
- fsize=fsize,cost=spread.cost,range=spread.range,log=log) else
- tt<-x[1:length(tree$tip)]
- } else lines(a,b,col=colors[names(tree$maps[[i]])[j]],lwd=lwd,lty=lty,
- type=type)
- y<-a[2]
- }
- if(tree$edge[i,2]<=length(tree$tip)){
- if(fsize&&!add){
- text(gsub("_"," ",tree$tip.label[tree$edge[i,2]]),x=H[i,2]+link,
- y=tt[tree$edge[i,2]],cex=fsize,font=ftype,pos=4,offset=offset)
- tip.coords[tree$tip.label[tree$edge[i,2]],]<-c(H[i,2]+link,
- tt[tree$edge[i,2]])
- if(link>0) lines(x=c(H[i,2],H[i,2]+link),y=c(X[i,2],
- tt[tree$edge[i,2]]),lty=3)
- }
- }
- }
- }
- if(!add){
- at<-round(0:(nticks-1)*max(H)/(nticks-1),digits)
- axis(1,at=at,cex.axis=cex.axis,cex.lab=cex.lab,las=las)
- axis(2,cex.axis=cex.axis,cex.lab=cex.lab,las=las)
- title(xlab=xlab,ylab=ylab,main=main,sub=sub)
- }
- if(hold) null<-dev.flush()
- xx<-setNames(c(H[1,1],H[,2]),c(tree$edge[1,1],tree$edge[,2]))
- xx<-xx[order(as.numeric(names(xx)))]
- yy<-setNames(c(X[1,1],X[,2]),c(tree$edge[1,1],tree$edge[,2]))
- yy<-yy[order(as.numeric(names(yy)))]
- PP<-list(type="phenogram",use.edge.length=TRUE,node.pos=1,
- show.tip.label=if(ftype!="off") TRUE else FALSE,show.node.label=FALSE,
- font=ftype,cex=fsize,adj=0,srt=NULL,no.margin=FALSE,label.offset=offset,
- x.lim=par()$usr[1:2],y.lim=par()$usr[3:4],
- direction=NULL,tip.color="black",Ntip=Ntip(tree),Nnode=tree$Nnode,
- edge=tree$edge,xx=xx,yy=yy)
- assign("last_plot.phylo",PP,envir=.PlotPhyloEnv)
- invisible(tip.coords)
-}
-
-## function to spread labels
-## written by Liam J. Revell 2013, 2014, 2016, 2021
-spreadlabels<-function(tree,x,fsize=1,cost=c(1,1),range=NULL,label.pos=NULL,log=""){
- if(!is.null(label.pos)) return(label.pos[tree$tip.label])
- else {
- if(log=="y") x<-log(x)
- if(is.null(range)) range<-range(x)
- else {
- if(log=="y") range<-log(range)
- }
- yy<-x[1:Ntip(tree)]
- zz<-setNames((rank(yy,ties.method="random")-1)/(length(yy)-1)*diff(range(yy))+
- range(yy)[1],names(yy))
- mm<-max(fsize*strheight(tree$tip.label))
- ff<-function(zz,yy,cost,mo=1,ms=1){
- ZZ<-cbind(zz-mm/2,zz+mm/2)
- ZZ<-ZZ[order(zz),]
- oo<-0
- for(i in 2:nrow(ZZ))
- oo<-if(ZZ[i-1,2]>ZZ[i,1]) oo<-oo+ZZ[i-1,2]-ZZ[i,1] else oo<-oo
- pp<-sum((zz-yy)^2)
- oo<-if(oo<(1e-6*diff(par()$usr[3:4]))) 0 else oo
- pp<-if(pp<(1e-6*diff(par()$usr[3:4]))) 0 else pp
- oo/mo*cost[1]+pp/ms*cost[2]
- }
- mo<-ff(yy,zz,cost=c(1,0))
- ms<-ff(yy,zz,cost=c(0,1))
- if(mo==0&&ms==0) return(yy)
- else {
- rr<-optim(zz,ff,yy=yy,mo=mo,ms=ms,cost=cost,method="L-BFGS-B",
- lower=rep(range[1],length(yy)),upper=rep(range[2],length(yy)))
- if(log=="y") return(exp(rr$par)) else return(rr$par)
- }
- }
-}
-
+## function creates a phenogram (i.e., 'traitgram')
+## written by Liam J. Revell 2011, 2012, 2013, 2014, 2015, 2016, 2020, 2021
+
+phenogram<-function(tree,x,fsize=1.0,ftype="reg",colors=NULL,axes=list(),add=FALSE,...){
+ ## get optional arguments
+ if(hasArg(xlim)) xlim<-list(...)$xlim
+ else xlim<-NULL
+ if(hasArg(ylim)) ylim<-list(...)$ylim
+ else ylim<-NULL
+ if(hasArg(log)) log<-list(...)$log
+ else log<-""
+ if(hasArg(main)) main<-list(...)$main
+ else main<-NULL
+ if(hasArg(sub)) sub<-list(...)$sub
+ else sub<-NULL
+ if(hasArg(xlab)) xlab<-list(...)$xlab
+ else xlab<-"time"
+ if(hasArg(ylab)) ylab<-list(...)$ylab
+ else ylab<-"phenotype"
+ if(hasArg(asp)) asp<-list(...)$asp
+ else asp<-NA
+ if(hasArg(type)) type<-list(...)$type
+ else type<-"l"
+ if(hasArg(lty)) lty<-list(...)$lty
+ else lty<-1
+ if(hasArg(lwd)) lwd<-list(...)$lwd
+ else lwd<-2
+ if(hasArg(offset)) offset<-list(...)$offset
+ else offset<-0.2
+ if(hasArg(offsetFudge)) offsetFudge<-list(...)$offsetFudge
+ else offsetFudge<-1.37
+ if(hasArg(digits)) digits<-list(...)$digits
+ else digits<-2
+ if(hasArg(nticks)) nticks<-list(...)$nticks
+ else nticks<-5
+ if(hasArg(spread.labels)) spread.labels<-list(...)$spread.labels
+ else spread.labels<-TRUE
+ if(ftype=="off") spread.labels<-FALSE
+ if(hasArg(spread.cost)) spread.cost<-list(...)$spread.cost
+ else spread.cost<-c(1,0.4)
+ if(hasArg(spread.range)) spread.range<-list(...)$spread.range
+ else spread.range<-range(x)
+ if(hasArg(link)) link<-list(...)$link
+ else link<-if(spread.labels) 0.1*max(nodeHeights(tree)) else 0
+ if(hasArg(hold)) hold<-list(...)$hold
+ else hold<-TRUE
+ if(hasArg(quiet)) quiet<-list(...)$quiet
+ else quiet<-FALSE
+ if(hasArg(label.pos)) label.pos<-list(...)$label.pos
+ else label.pos<-NULL
+ if(hasArg(cex.axis)) cex.axis<-list(...)$cex.axis
+ else cex.axis<-par()$cex.axis
+ if(hasArg(cex.lab)) cex.lab<-list(...)$cex.lab
+ else cex.lab<-par()$cex.lab
+ if(hasArg(las)) las<-list(...)$las
+ else las<-par()$las
+ ## end optional arguments
+ # check tree
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ # check font
+ ftype<-which(c("off","reg","b","i","bi")==ftype)-1
+ if(!ftype&&!add) fsize=0
+ H<-nodeHeights(tree)
+ if(length(x)<(length(tree$tip)+tree$Nnode))
+ x<-c(x,fastAnc(tree,x))
+ else
+ x<-c(x[tree$tip.label],x[as.character(length(tree$tip)+1:tree$Nnode)])
+ x[1:length(tree$tip)]<-x[tree$tip.label]
+ names(x)[1:length(tree$tip)]<-1:length(tree$tip)
+ X<-matrix(x[as.character(tree$edge)],nrow(tree$edge),ncol(tree$edge))
+ # legacy 'axes' argument trumps ylim & xlim from optional (...)
+ if(is.null(axes$trait)&&is.null(ylim)) ylim<-c(min(x),max(x))
+ else if(!is.null(axes$trait)) ylim<-axes$trait
+ if(!is.null(axes$time)) xlim<-axes$time
+ if(!add&&is.null(xlim)){
+ pp<-par("pin")[1]
+ sw<-fsize*(max(strwidth(tree$tip.label,units="inches")))+
+ offsetFudge*offset*fsize*strwidth("W",units="inches")
+ alp<-optimize(function(a,H,link,sw,pp) (a*1.04*(max(H)+link)+sw-pp)^2,H=H,
+ link=link,sw=sw,pp=pp,interval=c(0,1e6))$minimum
+ xlim<-c(min(H),max(H)+link+sw/alp)
+ }
+ if(!quiet&&Ntip(tree)>=40&&spread.labels){
+ cat("Optimizing the positions of the tip labels...\n")
+ flush.console()
+ }
+ ## matrix for tip coordinates
+ tip.coords<-matrix(NA,Ntip(tree),2,dimnames=list(tree$tip.label,c("x","y")))
+ if(hold) null<-dev.hold()
+ if(is.null(tree$maps)){
+ if(is.null(colors)) colors<-"black"
+ if(!add){
+ plot(H[1,],X[1,],type=type,lwd=lwd,lty=lty,col=colors,xlim=xlim,ylim=ylim,
+ log=log,asp=asp,xlab="",ylab="",frame=FALSE,axes=FALSE)
+ if(spread.labels) tt<-spreadlabels(tree,x,fsize=fsize,cost=spread.cost,
+ range=spread.range,label.pos=label.pos,log=log) else tt<-x[1:length(tree$tip)]
+ if(tree$edge[1,2]<=length(tree$tip)){
+ if(fsize&&!add){
+ text(gsub("_"," ",tree$tip.label[tree$edge[1,2]]),x=H[1,2]+link,
+ y=tt[tree$edge[1,2]],cex=fsize,font=ftype,pos=4,offset=offset)
+ tip.coords[tree$tip.label[tree$edge[1,2]],]<-c(H[1,2]+link,
+ tt[tree$edge[1,2]])
+ if(link>0) lines(x=c(H[1,2],H[1,2]+link),y=c(X[1,2],
+ tt[tree$edge[1,2]]),lty=3)
+ }
+ }
+ s<-2
+ } else s<-1
+ for(i in s:nrow(H)){
+ lines(H[i,],X[i,],type=type,lwd=lwd,lty=lty,col=colors)
+ if(tree$edge[i,2]<=length(tree$tip)){
+ if(fsize&&!add){
+ text(gsub("_"," ",tree$tip.label[tree$edge[i,2]]),x=H[i,2]+link,
+ y=tt[tree$edge[i,2]],cex=fsize,font=ftype,pos=4,offset=offset)
+ tip.coords[tree$tip.label[tree$edge[i,2]],]<-c(H[i,2]+link,
+ tt[tree$edge[i,2]])
+ if(link>0) lines(x=c(H[i,2],H[i,2]+link),y=c(X[i,2],tt[tree$edge[i,2]]),
+ lty=3)
+ }
+ }
+ }
+ } else {
+ if(is.null(colors)){
+ nn<-sort(unique(c(getStates(tree,"tips"),getStates(tree,"nodes"))))
+ colors<-setNames(palette()[1:length(nn)],nn)
+ }
+ for(i in 1:nrow(H)){
+ y<-H[i,1]
+ m<-diff(X[i,])/diff(H[i,])
+ for(j in 1:length(tree$maps[[i]])){
+ a<-c(y,y+tree$maps[[i]][j])
+ b<-m*(a-H[i,1])+X[i,1]
+ if(i==1&&j==1&&!add) {
+ plot(a,b,col=colors[names(tree$maps[[i]])[j]],type=type,lwd=lwd,
+ lty=lty,xlim=xlim,ylim=ylim,log=log,asp=asp,axes=FALSE,xlab="",
+ ylab="")
+ if(spread.labels) tt<-spreadlabels(tree,x[1:length(tree$tip)],
+ fsize=fsize,cost=spread.cost,range=spread.range,log=log) else
+ tt<-x[1:length(tree$tip)]
+ } else lines(a,b,col=colors[names(tree$maps[[i]])[j]],lwd=lwd,lty=lty,
+ type=type)
+ y<-a[2]
+ }
+ if(tree$edge[i,2]<=length(tree$tip)){
+ if(fsize&&!add){
+ text(gsub("_"," ",tree$tip.label[tree$edge[i,2]]),x=H[i,2]+link,
+ y=tt[tree$edge[i,2]],cex=fsize,font=ftype,pos=4,offset=offset)
+ tip.coords[tree$tip.label[tree$edge[i,2]],]<-c(H[i,2]+link,
+ tt[tree$edge[i,2]])
+ if(link>0) lines(x=c(H[i,2],H[i,2]+link),y=c(X[i,2],
+ tt[tree$edge[i,2]]),lty=3)
+ }
+ }
+ }
+ }
+ if(!add){
+ at<-round(0:(nticks-1)*max(H)/(nticks-1),digits)
+ axis(1,at=at,cex.axis=cex.axis,cex.lab=cex.lab,las=las)
+ axis(2,cex.axis=cex.axis,cex.lab=cex.lab,las=las)
+ title(xlab=xlab,ylab=ylab,main=main,sub=sub)
+ }
+ if(hold) null<-dev.flush()
+ xx<-setNames(c(H[1,1],H[,2]),c(tree$edge[1,1],tree$edge[,2]))
+ xx<-xx[order(as.numeric(names(xx)))]
+ yy<-setNames(c(X[1,1],X[,2]),c(tree$edge[1,1],tree$edge[,2]))
+ yy<-yy[order(as.numeric(names(yy)))]
+ PP<-list(type="phenogram",use.edge.length=TRUE,node.pos=1,
+ show.tip.label=if(ftype!="off") TRUE else FALSE,show.node.label=FALSE,
+ font=ftype,cex=fsize,adj=0,srt=NULL,no.margin=FALSE,label.offset=offset,
+ x.lim=par()$usr[1:2],y.lim=par()$usr[3:4],
+ direction=NULL,tip.color="black",Ntip=Ntip(tree),Nnode=tree$Nnode,
+ edge=tree$edge,xx=xx,yy=yy)
+ assign("last_plot.phylo",PP,envir=.PlotPhyloEnv)
+ invisible(tip.coords)
+}
+
+## function to spread labels
+## written by Liam J. Revell 2013, 2014, 2016, 2021
+spreadlabels<-function(tree,x,fsize=1,cost=c(1,1),range=NULL,label.pos=NULL,log=""){
+ if(!is.null(label.pos)) return(label.pos[tree$tip.label])
+ else {
+ if(log=="y") x<-log(x)
+ if(is.null(range)) range<-range(x)
+ else {
+ if(log=="y") range<-log(range)
+ }
+ yy<-x[1:Ntip(tree)]
+ zz<-setNames((rank(yy,ties.method="random")-1)/(length(yy)-1)*diff(range(yy))+
+ range(yy)[1],names(yy))
+ mm<-max(fsize*strheight(tree$tip.label))
+ ff<-function(zz,yy,cost,mo=1,ms=1){
+ ZZ<-cbind(zz-mm/2,zz+mm/2)
+ ZZ<-ZZ[order(zz),]
+ oo<-0
+ for(i in 2:nrow(ZZ))
+ oo<-if(ZZ[i-1,2]>ZZ[i,1]) oo<-oo+ZZ[i-1,2]-ZZ[i,1] else oo<-oo
+ pp<-sum((zz-yy)^2)
+ oo<-if(oo<(1e-6*diff(par()$usr[3:4]))) 0 else oo
+ pp<-if(pp<(1e-6*diff(par()$usr[3:4]))) 0 else pp
+ oo/mo*cost[1]+pp/ms*cost[2]
+ }
+ mo<-ff(yy,zz,cost=c(1,0))
+ ms<-ff(yy,zz,cost=c(0,1))
+ if(mo==0&&ms==0) return(yy)
+ else {
+ rr<-optim(zz,ff,yy=yy,mo=mo,ms=ms,cost=cost,method="L-BFGS-B",
+ lower=rep(range[1],length(yy)),upper=rep(range[2],length(yy)))
+ if(log=="y") return(exp(rr$par)) else return(rr$par)
+ }
+ }
+}
+
diff --git a/R/phyl.RMA.R b/R/phyl.RMA.R
index 7b584e8..1b82d66 100644
--- a/R/phyl.RMA.R
+++ b/R/phyl.RMA.R
@@ -1,87 +1,87 @@
-## this function computes a phylogenetic reduced major axis (RMA) regression
-## written by Liam Revell 2010, 2011, 2012, 2015, 2016, 2017
-
-phyl.RMA<-function(x,y,tree,method="BM",lambda=NULL,fixed=FALSE,h0=1.0){
- if(!inherits(tree,"phylo"))
- stop("tree should be an object of class \"phylo\".")
- x<-x[tree$tip.label]; y<-y[tree$tip.label]
- # bind the x & y into columns
- X<-cbind(x,y)
- if(method=="lambda")
- if(fixed==FALSE)
- result<-optimize(f=likMlambda,interval=c(0,1),X=X,C=vcv(tree),
- maximum=TRUE)
- else
- result<-list(objective=likMlambda(lambda,X,vcv(tree)),maximum=lambda)
- else if(method=="BM")
- result<-list(objective=likMlambda(1.0,X,vcv(tree)),maximum=1.0)
- else
- stop("do not recognize method")
- est.lambda<-result$maximum # estimated lambda
- C<-vcv(tree)
- C<-lambda.transform(est.lambda,C)
- temp<-phyl.vcv(X,vcv(tree),lambda=est.lambda)
- beta1<-sign(temp$R[1,2])*sqrt(temp$R[2,2]/temp$R[1,1])
- beta0<-temp$a[2]-beta1*temp$a[1]
- r<-y-(beta0+beta1*x)
- r2<-temp$R[1,2]^2/(temp$R[1,1]*temp$R[2,2])
- if(sign(beta1)!=sign(h0)){
- warning("b & h0 have different signs; hypothesis test invalid")
- T<-0
- } else
- T<-abs(log(abs(beta1))-log(abs(h0)))/sqrt((1-r2)/(Ntip(tree)-2))
- df<-2+(Ntip(tree)-2)/(1+0.5*r2)
- P<-2*pt(T,df=df,lower.tail=FALSE)
- test<-c(r2,T,df,P); names(test)<-c("r2","T","df","P")
- object<-list(RMA.beta=c(beta0,beta1),V=temp$R,lambda=est.lambda,
- logL=as.numeric(result$objective),test=test,h0=h0,model=method,
- resid=as.matrix(r),data=cbind(x,y),tree=tree)
- class(object)<-"phyl.RMA"
- object
-}
-
-## S3 methods for "phyl.RMA" object class
-
-print.phyl.RMA<-function(x,...){
- cat("\nCoefficients:\n")
- print(coef(x))
- cat("\nVCV matrix:\n")
- print(x$V)
- cat("\n")
- if(x$model=="BM")
- cat("Model for the covariance structure of the error is \"BM\"\n")
- else
- cat("Model for the covariance structure of the error is \"lambda\"\n")
- cat("\nEstimates (or set values):\n")
- print(setNames(c(x$lambda,x$logL),c("lambda","log(L)")))
- cat("\n")
- cat("Hypothesis test based on Clarke (1980; Biometrika):\n")
- print(round(x$test,6))
- cat(paste("\nNote that the null hypothesis test is h0 =",x$h0,
- "\n\n"))
-}
-
-coef.phyl.RMA<-function(object,...){
- val<-setNames(object$RMA.beta,c("(Intercept)","x"))
- val
-}
-
-residuals.phyl.RMA<-function(object,...) object$resid[,1]
-
-plot.phyl.RMA<-function(x,...){
- phylomorphospace(x$tree,x$data,node.size=c(0,0),ftype="off")
- points(x$data,cex=1.2,pch=21,bg="grey")
- x0<-ace(x$data[,1],x$tree,method="pic")$ace[1]
- y0<-ace(x$data[,2],x$tree,method="pic")$ace[1]
- a0<-y0-x$h0*x0
- abline(a=a0,b=x$h0,lwd=2,col="grey",lty="dashed")
- abline(a=coef(x)[1],b=coef(x)[2],lwd=2,col="red")
- tmp<-legend(x=0,y=0,legend=c(expression(beta[RMA]),expression(h[0])),
- lty=c("solid","dashed"),lwd=c(2,2),plot=FALSE)
- legend(x=if(x$h0>0) par()$usr[1] else par()$usr[2]-tmp$rect$w,
- y=par()$usr[4],col=c("red","grey"),
- legend=c(expression(beta[RMA]),expression(h[0])),
- lty=c("solid","dashed"),lwd=c(2,2),
- bg=make.transparent("white",0.75))
-
-}
+## this function computes a phylogenetic reduced major axis (RMA) regression
+## written by Liam Revell 2010, 2011, 2012, 2015, 2016, 2017
+
+phyl.RMA<-function(x,y,tree,method="BM",lambda=NULL,fixed=FALSE,h0=1.0){
+ if(!inherits(tree,"phylo"))
+ stop("tree should be an object of class \"phylo\".")
+ x<-x[tree$tip.label]; y<-y[tree$tip.label]
+ # bind the x & y into columns
+ X<-cbind(x,y)
+ if(method=="lambda")
+ if(fixed==FALSE)
+ result<-optimize(f=likMlambda,interval=c(0,1),X=X,C=vcv(tree),
+ maximum=TRUE)
+ else
+ result<-list(objective=likMlambda(lambda,X,vcv(tree)),maximum=lambda)
+ else if(method=="BM")
+ result<-list(objective=likMlambda(1.0,X,vcv(tree)),maximum=1.0)
+ else
+ stop("do not recognize method")
+ est.lambda<-result$maximum # estimated lambda
+ C<-vcv(tree)
+ C<-lambda.transform(est.lambda,C)
+ temp<-phyl.vcv(X,vcv(tree),lambda=est.lambda)
+ beta1<-sign(temp$R[1,2])*sqrt(temp$R[2,2]/temp$R[1,1])
+ beta0<-temp$a[2]-beta1*temp$a[1]
+ r<-y-(beta0+beta1*x)
+ r2<-temp$R[1,2]^2/(temp$R[1,1]*temp$R[2,2])
+ if(sign(beta1)!=sign(h0)){
+ warning("b & h0 have different signs; hypothesis test invalid")
+ T<-0
+ } else
+ T<-abs(log(abs(beta1))-log(abs(h0)))/sqrt((1-r2)/(Ntip(tree)-2))
+ df<-2+(Ntip(tree)-2)/(1+0.5*r2)
+ P<-2*pt(T,df=df,lower.tail=FALSE)
+ test<-c(r2,T,df,P); names(test)<-c("r2","T","df","P")
+ object<-list(RMA.beta=c(beta0,beta1),V=temp$R,lambda=est.lambda,
+ logL=as.numeric(result$objective),test=test,h0=h0,model=method,
+ resid=as.matrix(r),data=cbind(x,y),tree=tree)
+ class(object)<-"phyl.RMA"
+ object
+}
+
+## S3 methods for "phyl.RMA" object class
+
+print.phyl.RMA<-function(x,...){
+ cat("\nCoefficients:\n")
+ print(coef(x))
+ cat("\nVCV matrix:\n")
+ print(x$V)
+ cat("\n")
+ if(x$model=="BM")
+ cat("Model for the covariance structure of the error is \"BM\"\n")
+ else
+ cat("Model for the covariance structure of the error is \"lambda\"\n")
+ cat("\nEstimates (or set values):\n")
+ print(setNames(c(x$lambda,x$logL),c("lambda","log(L)")))
+ cat("\n")
+ cat("Hypothesis test based on Clarke (1980; Biometrika):\n")
+ print(round(x$test,6))
+ cat(paste("\nNote that the null hypothesis test is h0 =",x$h0,
+ "\n\n"))
+}
+
+coef.phyl.RMA<-function(object,...){
+ val<-setNames(object$RMA.beta,c("(Intercept)","x"))
+ val
+}
+
+residuals.phyl.RMA<-function(object,...) object$resid[,1]
+
+plot.phyl.RMA<-function(x,...){
+ phylomorphospace(x$tree,x$data,node.size=c(0,0),ftype="off")
+ points(x$data,cex=1.2,pch=21,bg="grey")
+ x0<-ace(x$data[,1],x$tree,method="pic")$ace[1]
+ y0<-ace(x$data[,2],x$tree,method="pic")$ace[1]
+ a0<-y0-x$h0*x0
+ abline(a=a0,b=x$h0,lwd=2,col="grey",lty="dashed")
+ abline(a=coef(x)[1],b=coef(x)[2],lwd=2,col="red")
+ tmp<-legend(x=0,y=0,legend=c(expression(beta[RMA]),expression(h[0])),
+ lty=c("solid","dashed"),lwd=c(2,2),plot=FALSE)
+ legend(x=if(x$h0>0) par()$usr[1] else par()$usr[2]-tmp$rect$w,
+ y=par()$usr[4],col=c("red","grey"),
+ legend=c(expression(beta[RMA]),expression(h[0])),
+ lty=c("solid","dashed"),lwd=c(2,2),
+ bg=make.transparent("white",0.75))
+
+}
diff --git a/R/phyl.cca.R b/R/phyl.cca.R
index 3e593a7..5cb06aa 100644
--- a/R/phyl.cca.R
+++ b/R/phyl.cca.R
@@ -1,122 +1,122 @@
-# function does phylogenetic canonical correlation analysis (Revell & Harrison 2008)
-# written by Liam Revell 2011, 2012, 2013, 2015
-
-phyl.cca<-function(tree,X,Y,lambda=1.0,fixed=TRUE){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- # misc
- n<-length(tree$tip)
- mX<-ncol(X)
- mY<-ncol(Y)
- # compute C
- C<-vcv.phylo(tree)
- # if X & Y are data frames, convert to matrix
- if(is.data.frame(X)) X<-as.matrix(X)
- if(is.data.frame(Y)) Y<-as.matrix(Y)
- # check to see if X & Y have rownames
- if(is.null(rownames(X))){
- message("X is missing rownames; assuming same order as tree$tip.label")
- if(nrow(X)!=length(tree$tip)) warning("X does not have the correct number of rows")
- else rownames(X)<-tree$tip.label
- }
- if(is.null(rownames(Y))){
- message("Y is missing rownames; assuming same order as tree$tip.label")
- if(nrow(Y)!=length(tree$tip)) warning("Y does not have the correct number of rows")
- else rownames(Y)<-tree$tip.label
- }
- # reorder Y & C by tree$tip.label
- C<-C[tree$tip.label,tree$tip.label] # I think this is superfluous
- X<-as.matrix(X[tree$tip.label,])
- Y<-as.matrix(Y[tree$tip.label,])
- # set or optimize lambda
- if(fixed) logL<-likMlambda(lambda,cbind(X,Y),C)
- else {
- temp<-optimize(f=likMlambda,interval=c(0,maxLambda(tree)),X=cbind(X,Y),C=C,maximum=TRUE)
- logL<-temp$objective
- lambda<-temp$maximum
- }
- C<-lambda.transform(lambda,C)
- # invert C
- invC<-solve(C)
- # compute means
- aX<-colSums(invC%*%X)/sum(invC)
- aY<-colSums(invC%*%Y)/sum(invC)
- # compute cov & cross-cov matrices
- one<-as.matrix(rep(1,n))
- SigXX<-t(X-one%*%aX)%*%invC%*%(X-one%*%aX)/(n-1)
- SigXY<-t(X-one%*%aX)%*%invC%*%(Y-one%*%aY)/(n-1)
- SigYX<-t(SigXY)
- SigYY<-t(Y-one%*%aY)%*%invC%*%(Y-one%*%aY)/(n-1)
- # compute canonical coefficients
- A<-eigen(solve(SigXX)%*%SigXY%*%solve(SigYY)%*%SigYX)
- B<-eigen(solve(SigYY)%*%SigYX%*%solve(SigXX)%*%SigXY)
- # compute canonical variables, rescale
- U<-X%*%A$vectors[,1:min(mX,mY)]
- aU<-colSums(invC%*%U)/sum(invC)
- vcvU<-t(U-one%*%aU)%*%invC%*%(U-one%*%aU)/(n-1)
- U<-(U-one%*%aU)%*%Diag(sqrt(Diag(1/vcvU)))
- V<-Y%*%B$vectors[,1:min(mX,mY)]
- aV<-colSums(invC%*%V)/sum(invC)
- vcvV<-t(V-one%*%aV)%*%invC%*%(V-one%*%aV)/(n-1)
- V<-(V-one%*%aV)%*%Diag(sqrt(Diag(1/vcvV)))
- # compute canonical correlations
- aU<-colSums(invC%*%U)/sum(invC)
- aV<-colSums(invC%*%V)/sum(invC)
- Ccv<-round(t(cbind(U,V))%*%invC%*%cbind(U,V)/(n-1),10)
- ccs<-Diag(Ccv[1:min(mX,mY),(1+min(mX,mY)):(2*min(mX,mY))])
- if(all(Im(ccs)==0)) ccs<-Re(ccs)
- pos<-2*(as.numeric(ccs>0)-0.5)
- ccs<-ccs*pos
- # reorient variables, reorient & rescale coefficents
- U<-U*one%*%pos
- xcoef<-A$vectors[,1:min(mX,mY)]*matrix(1,mX,1)%*%pos%*%Diag(sqrt(Diag(1/vcvU)))
- ycoef<-B$vectors[,1:min(mX,mY)]%*%Diag(sqrt(Diag(1/vcvV)))
- # conduct hypothesis tests
- W_lh<-rep(1,min(mX,mY))
- chiSq<-vector()
- df<-vector()
- for(i in 1:min(mX,mY)){
- for(j in i:min(mX,mY)) W_lh[i]<-W_lh[i]*(1-ccs[j]^2)
- chiSq[i]<--((n-1)-(mX+mY+1)/2)*log(W_lh[i])
- df[i]<-(mX+1-i)*(mY+1-i)
- }
- pvalues<-pchisq(chiSq,df=df,lower.tail=F)
- # add row & column names
- if(!is.null(colnames(X))) rownames(xcoef)<-colnames(X)
- if(!is.null(colnames(Y))) rownames(ycoef)<-colnames(Y)
- temp<-vector()
- for(i in 1:min(mX,mY)) temp[i]<-paste("CA",i,sep="")
- colnames(xcoef)<-temp
- colnames(ycoef)<-temp
- colnames(U)<-temp
- colnames(V)<-temp
- # return as list
- lambda<-c(lambda,logL); names(lambda)<-c("lambda","logL")
- obj<-list(cor=ccs,xcoef=xcoef,ycoef=ycoef,xscores=U,yscores=V,lambda=lambda,chisq=chiSq,p=pvalues)
- class(obj)<-"phyl.cca"
- obj
-}
-
-## internal function replace Diag
-## modified from a suggestion by Travis Ingram 2013
-Diag<-function(X){
- if(length(X)==1) X
- else diag(X)
-}
-
-## S3 print method
-print.phyl.cca<-function(x,digits=6,...){
- cat("\nObject of class \"phyl.cca\" from a phylogenetic canonical")
- cat("\n correlation analysis.\n\n")
- object<-data.frame(round(x$cor,digits),round(x$chisq,digits),round(x$p,digits))
- colnames(object)<-c("correlation","X^2","P-value")
- rownames(object)<-paste("CC",1:length(x$cor),sep=":")
- cat("Summary of results:\n")
- print(object)
- cat("\nAssumed or estimated value of lambda:\n")
- print(round(x$lambda,digits))
- cat("\nCanonical x coefficients:\n")
- print(as.data.frame(round(x$xcoef,digits)))
- cat("\nCanonical y coefficients:\n")
- print(as.data.frame(round(x$ycoef,digits)))
- cat("\n")
-}
+# function does phylogenetic canonical correlation analysis (Revell & Harrison 2008)
+# written by Liam Revell 2011, 2012, 2013, 2015
+
+phyl.cca<-function(tree,X,Y,lambda=1.0,fixed=TRUE){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ # misc
+ n<-length(tree$tip)
+ mX<-ncol(X)
+ mY<-ncol(Y)
+ # compute C
+ C<-vcv.phylo(tree)
+ # if X & Y are data frames, convert to matrix
+ if(is.data.frame(X)) X<-as.matrix(X)
+ if(is.data.frame(Y)) Y<-as.matrix(Y)
+ # check to see if X & Y have rownames
+ if(is.null(rownames(X))){
+ message("X is missing rownames; assuming same order as tree$tip.label")
+ if(nrow(X)!=length(tree$tip)) warning("X does not have the correct number of rows")
+ else rownames(X)<-tree$tip.label
+ }
+ if(is.null(rownames(Y))){
+ message("Y is missing rownames; assuming same order as tree$tip.label")
+ if(nrow(Y)!=length(tree$tip)) warning("Y does not have the correct number of rows")
+ else rownames(Y)<-tree$tip.label
+ }
+ # reorder Y & C by tree$tip.label
+ C<-C[tree$tip.label,tree$tip.label] # I think this is superfluous
+ X<-as.matrix(X[tree$tip.label,])
+ Y<-as.matrix(Y[tree$tip.label,])
+ # set or optimize lambda
+ if(fixed) logL<-likMlambda(lambda,cbind(X,Y),C)
+ else {
+ temp<-optimize(f=likMlambda,interval=c(0,maxLambda(tree)),X=cbind(X,Y),C=C,maximum=TRUE)
+ logL<-temp$objective
+ lambda<-temp$maximum
+ }
+ C<-lambda.transform(lambda,C)
+ # invert C
+ invC<-solve(C)
+ # compute means
+ aX<-colSums(invC%*%X)/sum(invC)
+ aY<-colSums(invC%*%Y)/sum(invC)
+ # compute cov & cross-cov matrices
+ one<-as.matrix(rep(1,n))
+ SigXX<-t(X-one%*%aX)%*%invC%*%(X-one%*%aX)/(n-1)
+ SigXY<-t(X-one%*%aX)%*%invC%*%(Y-one%*%aY)/(n-1)
+ SigYX<-t(SigXY)
+ SigYY<-t(Y-one%*%aY)%*%invC%*%(Y-one%*%aY)/(n-1)
+ # compute canonical coefficients
+ A<-eigen(solve(SigXX)%*%SigXY%*%solve(SigYY)%*%SigYX)
+ B<-eigen(solve(SigYY)%*%SigYX%*%solve(SigXX)%*%SigXY)
+ # compute canonical variables, rescale
+ U<-X%*%A$vectors[,1:min(mX,mY)]
+ aU<-colSums(invC%*%U)/sum(invC)
+ vcvU<-t(U-one%*%aU)%*%invC%*%(U-one%*%aU)/(n-1)
+ U<-(U-one%*%aU)%*%Diag(sqrt(Diag(1/vcvU)))
+ V<-Y%*%B$vectors[,1:min(mX,mY)]
+ aV<-colSums(invC%*%V)/sum(invC)
+ vcvV<-t(V-one%*%aV)%*%invC%*%(V-one%*%aV)/(n-1)
+ V<-(V-one%*%aV)%*%Diag(sqrt(Diag(1/vcvV)))
+ # compute canonical correlations
+ aU<-colSums(invC%*%U)/sum(invC)
+ aV<-colSums(invC%*%V)/sum(invC)
+ Ccv<-round(t(cbind(U,V))%*%invC%*%cbind(U,V)/(n-1),10)
+ ccs<-Diag(Ccv[1:min(mX,mY),(1+min(mX,mY)):(2*min(mX,mY))])
+ if(all(Im(ccs)==0)) ccs<-Re(ccs)
+ pos<-2*(as.numeric(ccs>0)-0.5)
+ ccs<-ccs*pos
+ # reorient variables, reorient & rescale coefficents
+ U<-U*one%*%pos
+ xcoef<-A$vectors[,1:min(mX,mY)]*matrix(1,mX,1)%*%pos%*%Diag(sqrt(Diag(1/vcvU)))
+ ycoef<-B$vectors[,1:min(mX,mY)]%*%Diag(sqrt(Diag(1/vcvV)))
+ # conduct hypothesis tests
+ W_lh<-rep(1,min(mX,mY))
+ chiSq<-vector()
+ df<-vector()
+ for(i in 1:min(mX,mY)){
+ for(j in i:min(mX,mY)) W_lh[i]<-W_lh[i]*(1-ccs[j]^2)
+ chiSq[i]<--((n-1)-(mX+mY+1)/2)*log(W_lh[i])
+ df[i]<-(mX+1-i)*(mY+1-i)
+ }
+ pvalues<-pchisq(chiSq,df=df,lower.tail=F)
+ # add row & column names
+ if(!is.null(colnames(X))) rownames(xcoef)<-colnames(X)
+ if(!is.null(colnames(Y))) rownames(ycoef)<-colnames(Y)
+ temp<-vector()
+ for(i in 1:min(mX,mY)) temp[i]<-paste("CA",i,sep="")
+ colnames(xcoef)<-temp
+ colnames(ycoef)<-temp
+ colnames(U)<-temp
+ colnames(V)<-temp
+ # return as list
+ lambda<-c(lambda,logL); names(lambda)<-c("lambda","logL")
+ obj<-list(cor=ccs,xcoef=xcoef,ycoef=ycoef,xscores=U,yscores=V,lambda=lambda,chisq=chiSq,p=pvalues)
+ class(obj)<-"phyl.cca"
+ obj
+}
+
+## internal function replace Diag
+## modified from a suggestion by Travis Ingram 2013
+Diag<-function(X){
+ if(length(X)==1) X
+ else diag(X)
+}
+
+## S3 print method
+print.phyl.cca<-function(x,digits=6,...){
+ cat("\nObject of class \"phyl.cca\" from a phylogenetic canonical")
+ cat("\n correlation analysis.\n\n")
+ object<-data.frame(round(x$cor,digits),round(x$chisq,digits),round(x$p,digits))
+ colnames(object)<-c("correlation","X^2","P-value")
+ rownames(object)<-paste("CC",1:length(x$cor),sep=":")
+ cat("Summary of results:\n")
+ print(object)
+ cat("\nAssumed or estimated value of lambda:\n")
+ print(round(x$lambda,digits))
+ cat("\nCanonical x coefficients:\n")
+ print(as.data.frame(round(x$xcoef,digits)))
+ cat("\nCanonical y coefficients:\n")
+ print(as.data.frame(round(x$ycoef,digits)))
+ cat("\n")
+}
diff --git a/R/phyl.pca.R b/R/phyl.pca.R
index ad1e207..d1ff308 100644
--- a/R/phyl.pca.R
+++ b/R/phyl.pca.R
@@ -1,239 +1,239 @@
-## function to perform phylogenetic principal components analysis
-## multiple morphological traits in Y
-## also can use lambda transformation in which lambda is optimized by ML or REML (in progress)
-## written by Liam Revell 2010, 2011, 2013, 2015, 2016, 2017, 2019, 2020, 2022
-## ref. Revell (2009; Evolution)
-
-phyl.pca<-function(tree,Y,method="BM",mode="cov",...){
- ## get optional argument
- if(hasArg(opt)) opt<-list(...)$opt
- else opt<-"ML"
- # check tree
- if(!inherits(tree,"phylo"))
- stop("tree should be an object of class \"phylo\".")
- # check mode
- if(length(strsplit(mode,split="")[[1]])<=2){
- message(paste("mode = \"",mode,
- "\" not a valid option; setting mode = \"cov\"",sep=""))
- mode<-"cov"
- }
- if(all(strsplit(mode,split="")[[1]]==strsplit("correlation",
- split="")[[1]][1:length(strsplit(mode,split="")[[1]])])) mode<-"corr"
- else if(all(strsplit(mode,split="")[[1]]==strsplit("covariance",
- split="")[[1]][1:length(strsplit(mode,split="")[[1]])])) mode<-"cov"
- else {
- message(paste("mode = \"",mode,
- "\" not a valid option; setting mode = \"cov\"",sep=""))
- mode="cov"
- }
- # preliminaries
- n<-nrow(Y)
- m<-ncol(Y)
- # check and sort data
- if(n>Ntip(tree))
- stop("number of rows in Y cannot be greater than number of taxa in your tree")
- Y<-as.matrix(Y)
- if(is.null(rownames(Y))){
- if(nrow(Y)==n){
- print("Y has no names. function will assume that the row order of Y matches tree$tip.label")
- rownames(Y)<-tree$tip.label
- } else
- stop("Y has no names and does not have the same number of rows as tips in tree")
- } else if(length(setdiff(rownames(Y),tree$tip.label))!=0)
- stop("Y has rownames, but some rownames of Y not found in tree")
- # analyze
- C<-vcv.phylo(tree)[rownames(Y),rownames(Y)]
- if(method=="BM"){
- temp<-phyl.vcv(Y,C,1.0)
- V<-temp$R
- a<-t(temp$alpha)
- C<-temp$C
- } else if(method=="lambda"){
- if(opt=="ML") temp<-optimize(f=likMlambda,interval=c(0,maxLambda(tree)),X=Y,
- C=C,maximum=TRUE)
- else if(opt=="REML") temp<-optimize(f=remlMlambda,interval=c(0,maxLambda(tree)),
- tree=tree,X=Y,maximum=TRUE)
- else if(opt=="fixed"){
- if(hasArg(lambda)) lambda<-list(...)$lambda
- else {
- cat(" opt=\"fixed\" requires the user to specify lambda.\n")
- cat(" setting lambda to 1.0.\n")
- lambda<-1.0
- }
- temp<-list(maximum=lambda,objective=likMlambda(lambda,X=Y,C=C))
- }
- lambda<-temp$maximum
- logL<-as.numeric(temp$objective)
- temp<-phyl.vcv(Y,C,lambda)
- V<-temp$R
- a<-t(temp$alpha)
- C<-temp$C
- }
- invC<-solve(C) ## get inverse of C
- # if correlation matrix
- if(mode=="corr"){
- Y=Y/matrix(rep(sqrt(diag(V)),n),n,m,byrow=T) # standardize Y
- V=V/(sqrt(diag(V))%*%t(sqrt(diag(V)))) # change V to correlation matrix
- a<-matrix(colSums(invC%*%Y)/sum(invC),m,1) # recalculate a
- }
- es=eigen(V) # eigenanalyze
- obj<-list()
- obj$Eval<-diag(es$values[1:min(n-1,m)])
- obj$Evec<-es$vectors[,1:min(n-1,m)]
- dimnames(obj$Eval)<-list(paste("PC",1:min(n-1,m),sep=""),
- paste("PC",1:min(n-1,m),sep=""))
- dimnames(obj$Evec)<-list(colnames(Y),paste("PC",1:min(n-1,m),sep=""))
- A<-matrix(rep(a,n),n,m,byrow=T)
- obj$S<-(Y-A)%*%obj$Evec # compute scores in the species space
- Ccv<-t(Y-A)%*%invC%*%obj$S/(n-1) # compute cross covariance matrix and loadings
- obj$L<-matrix(,m,min(n-1,m),dimnames=list(colnames(Y),paste("PC",1:min(n-1,m),sep="")))
- for(i in 1:m) for(j in 1:min(n-1,m)) obj$L[i,j]<-Ccv[i,j]/sqrt(V[i,i]*obj$Eval[j,j])
- if(method=="lambda"){
- obj$lambda<-lambda
- obj$logL.lambda<-logL
- }
- obj$V<-temp$R
- obj$a<-a
- obj$mode<-mode
- obj$call<-match.call()
- ## assign class attribute (for S3 methods)
- class(obj)<-"phyl.pca"
- # return obj
- obj
-}
-
-## S3 method for object of class "phyl.pca
-## modified from code provided by Joan Maspons
-
-## S3 print method for "phyl.pca"
-## modified from code provided by Joan Maspons
-print.phyl.pca<-function(x, ...){
- cat("Phylogenetic pca\n")
- cat("Standard deviations:\n")
- print(sqrt(diag(x$Eval)))
- cat("Loads:\n")
- print(x$L)
- if("lambda" %in% names(x)){
- cat("lambda:\n")
- print(x$lambda)
- }
-}
-
-## S3 summary method for "phyl.pca"
-## modified from code provided by Joan Maspons
-summary.phyl.pca<-function(object, ...){
- cat("Importance of components:\n")
- sd<-sqrt(diag(object$Eval))
- varProp<- diag(object$Eval)/sum(object$Eval)
- impp<-rbind("Standard deviation"=sd,"Proportion of Variance"=varProp,
- "Cumulative Proportion"=cumsum(varProp))
- print(impp)
- xx<-list(sdev=sd,importance=impp)
- class(xx)<-"summary.phyl.pca"
- invisible(xx)
-}
-
-## S3 biplot method for "phyl.pca"
-## modified from code provided by Joan Maspons
-## written by Liam J. Revell 2015, 2017
-biplot.phyl.pca<-function(x,...){
- to.do<-list(...)
- if(hasArg(choices)){
- choices<-list(...)$choices
- to.do$choices<-NULL
- } else choices<-c(1,2)
- to.do$x<-x$S[,choices]
- to.do$y<-x$Evec[,choices]
- do.call(biplot,to.do)
-}
-
-## lambdaTree for lambda="REML"
-## written by Liam J. Revell 2013
-lambdaTree<-function(tree,lambda){
- n<-length(tree$tip.label)
- h1<-nodeHeights(tree)
- ii<-which(tree$edge[,2]>n)
- tree$edge.length[ii]<-lambda*tree$edge.length[ii]
- h2<-nodeHeights(tree)
- tree$edge.length[-ii]<-tree$edge.length[-ii]+h1[-ii,2]-h2[-ii,2]
- tree
-}
-
-## REML function
-## written by Liam J. Revell 2013
-remlMlambda<-function(lambda,tree,X){
- tt<-lambdaTree(tree,lambda)
- Y<-apply(X,2,pic,phy=tt)
- V<-t(Y)%*%Y/nrow(Y)
- logL<-sum(dmnorm(Y,mean=rep(0,ncol(Y)),varcov=V,log=TRUE))
- ## kronRC<-kronecker(V,diag(rep(1,nrow(Y))))
- ## y<-as.vector(Y)
- ## logL<--y%*%solve(kronRC,y)/2-length(y)*log(2*pi)/2-determinant(kronRC,logarithm=TRUE)$modulus/2
- ## print(V)
- print(c(lambda,logL))
- logL
-}
-
-## S3 plot method (does screeplot)
-plot.phyl.pca<- function(x,...){
- if(hasArg(main)) main<-list(...)$main
- else main="screeplot"
- x$sdev<-sqrt(diag(x$Eval))
- screeplot(x,main=main)
-}
-
-## S3 scores method to extract or compute scores
-
-scores<-function(object,...) UseMethod("scores")
-
-scores.default<-function(object,...){
- warning(paste(
- "scores does not know how to handle objects of class ",
- class(object),"."))
-}
-
-scores.phyl.pca<-function(object,...){
- if(hasArg(newdata))newdata<-list(...)$newdata
- else newdata<-NULL
- if(!is.null(newdata)){
- if(!is.matrix(newdata)) newdata<-as.matrix(newdata)
- if(ncol(newdata)!=nrow(object$Evec))
- stop("Dimensions of newdata incorrect.")
- n<-nrow(newdata)
- m<-ncol(newdata)
- A<-matrix(rep(object$a,n),n,m,byrow=TRUE)
- V<-object$V
- if(object$mode=="corr"){
- Y<-newdata/matrix(rep(sqrt(diag(V)),n),n,m,byrow=TRUE)-A
- } else Y<-newdata-A
- Scores<-Y%*%object$Evec
- } else {
- Scores<-object$S
- }
- Scores
-}
-
-## S3 as.princomp method to convert to "princomp" object class
-
-as.princomp<-function(x,...) UseMethod("as.princomp")
-
-as.princomp.default<-function(x,...){
- warning(paste(
- "as.princomp does not know how to handle objects of class ",
- class(x),"."))
-}
-
-as.princomp.phyl.pca<-function(x,...){
- nn<-paste("Comp.",1:ncol(x$Evec),sep="")
- obj<-list()
- obj$sdev<-setNames(sqrt(diag(x$Eval)),nn)
- obj$loadings<-x$L
- colnames(obj$loadings)<-nn
- obj$center<-setNames(x$a[1,],rownames(x$Evec))
- obj$scale<-setNames(rep(1,length(obj$center)),names(obj$center))
- obj$scores<-x$S
- colnames(obj$scores)<-nn
- obj$call<-x$call
- class(obj)<-"princomp"
- obj
+## function to perform phylogenetic principal components analysis
+## multiple morphological traits in Y
+## also can use lambda transformation in which lambda is optimized by ML or REML (in progress)
+## written by Liam Revell 2010, 2011, 2013, 2015, 2016, 2017, 2019, 2020, 2022
+## ref. Revell (2009; Evolution)
+
+phyl.pca<-function(tree,Y,method="BM",mode="cov",...){
+ ## get optional argument
+ if(hasArg(opt)) opt<-list(...)$opt
+ else opt<-"ML"
+ # check tree
+ if(!inherits(tree,"phylo"))
+ stop("tree should be an object of class \"phylo\".")
+ # check mode
+ if(length(strsplit(mode,split="")[[1]])<=2){
+ message(paste("mode = \"",mode,
+ "\" not a valid option; setting mode = \"cov\"",sep=""))
+ mode<-"cov"
+ }
+ if(all(strsplit(mode,split="")[[1]]==strsplit("correlation",
+ split="")[[1]][1:length(strsplit(mode,split="")[[1]])])) mode<-"corr"
+ else if(all(strsplit(mode,split="")[[1]]==strsplit("covariance",
+ split="")[[1]][1:length(strsplit(mode,split="")[[1]])])) mode<-"cov"
+ else {
+ message(paste("mode = \"",mode,
+ "\" not a valid option; setting mode = \"cov\"",sep=""))
+ mode="cov"
+ }
+ # preliminaries
+ n<-nrow(Y)
+ m<-ncol(Y)
+ # check and sort data
+ if(n>Ntip(tree))
+ stop("number of rows in Y cannot be greater than number of taxa in your tree")
+ Y<-as.matrix(Y)
+ if(is.null(rownames(Y))){
+ if(nrow(Y)==n){
+ print("Y has no names. function will assume that the row order of Y matches tree$tip.label")
+ rownames(Y)<-tree$tip.label
+ } else
+ stop("Y has no names and does not have the same number of rows as tips in tree")
+ } else if(length(setdiff(rownames(Y),tree$tip.label))!=0)
+ stop("Y has rownames, but some rownames of Y not found in tree")
+ # analyze
+ C<-vcv.phylo(tree)[rownames(Y),rownames(Y)]
+ if(method=="BM"){
+ temp<-phyl.vcv(Y,C,1.0)
+ V<-temp$R
+ a<-t(temp$alpha)
+ C<-temp$C
+ } else if(method=="lambda"){
+ if(opt=="ML") temp<-optimize(f=likMlambda,interval=c(0,maxLambda(tree)),X=Y,
+ C=C,maximum=TRUE)
+ else if(opt=="REML") temp<-optimize(f=remlMlambda,interval=c(0,maxLambda(tree)),
+ tree=tree,X=Y,maximum=TRUE)
+ else if(opt=="fixed"){
+ if(hasArg(lambda)) lambda<-list(...)$lambda
+ else {
+ cat(" opt=\"fixed\" requires the user to specify lambda.\n")
+ cat(" setting lambda to 1.0.\n")
+ lambda<-1.0
+ }
+ temp<-list(maximum=lambda,objective=likMlambda(lambda,X=Y,C=C))
+ }
+ lambda<-temp$maximum
+ logL<-as.numeric(temp$objective)
+ temp<-phyl.vcv(Y,C,lambda)
+ V<-temp$R
+ a<-t(temp$alpha)
+ C<-temp$C
+ }
+ invC<-solve(C) ## get inverse of C
+ # if correlation matrix
+ if(mode=="corr"){
+ Y=Y/matrix(rep(sqrt(diag(V)),n),n,m,byrow=T) # standardize Y
+ V=V/(sqrt(diag(V))%*%t(sqrt(diag(V)))) # change V to correlation matrix
+ a<-matrix(colSums(invC%*%Y)/sum(invC),m,1) # recalculate a
+ }
+ es=eigen(V) # eigenanalyze
+ obj<-list()
+ obj$Eval<-diag(es$values[1:min(n-1,m)])
+ obj$Evec<-es$vectors[,1:min(n-1,m)]
+ dimnames(obj$Eval)<-list(paste("PC",1:min(n-1,m),sep=""),
+ paste("PC",1:min(n-1,m),sep=""))
+ dimnames(obj$Evec)<-list(colnames(Y),paste("PC",1:min(n-1,m),sep=""))
+ A<-matrix(rep(a,n),n,m,byrow=T)
+ obj$S<-(Y-A)%*%obj$Evec # compute scores in the species space
+ Ccv<-t(Y-A)%*%invC%*%obj$S/(n-1) # compute cross covariance matrix and loadings
+ obj$L<-matrix(,m,min(n-1,m),dimnames=list(colnames(Y),paste("PC",1:min(n-1,m),sep="")))
+ for(i in 1:m) for(j in 1:min(n-1,m)) obj$L[i,j]<-Ccv[i,j]/sqrt(V[i,i]*obj$Eval[j,j])
+ if(method=="lambda"){
+ obj$lambda<-lambda
+ obj$logL.lambda<-logL
+ }
+ obj$V<-temp$R
+ obj$a<-a
+ obj$mode<-mode
+ obj$call<-match.call()
+ ## assign class attribute (for S3 methods)
+ class(obj)<-"phyl.pca"
+ # return obj
+ obj
+}
+
+## S3 method for object of class "phyl.pca
+## modified from code provided by Joan Maspons
+
+## S3 print method for "phyl.pca"
+## modified from code provided by Joan Maspons
+print.phyl.pca<-function(x, ...){
+ cat("Phylogenetic pca\n")
+ cat("Standard deviations:\n")
+ print(sqrt(diag(x$Eval)))
+ cat("Loads:\n")
+ print(x$L)
+ if("lambda" %in% names(x)){
+ cat("lambda:\n")
+ print(x$lambda)
+ }
+}
+
+## S3 summary method for "phyl.pca"
+## modified from code provided by Joan Maspons
+summary.phyl.pca<-function(object, ...){
+ cat("Importance of components:\n")
+ sd<-sqrt(diag(object$Eval))
+ varProp<- diag(object$Eval)/sum(object$Eval)
+ impp<-rbind("Standard deviation"=sd,"Proportion of Variance"=varProp,
+ "Cumulative Proportion"=cumsum(varProp))
+ print(impp)
+ xx<-list(sdev=sd,importance=impp)
+ class(xx)<-"summary.phyl.pca"
+ invisible(xx)
+}
+
+## S3 biplot method for "phyl.pca"
+## modified from code provided by Joan Maspons
+## written by Liam J. Revell 2015, 2017
+biplot.phyl.pca<-function(x,...){
+ to.do<-list(...)
+ if(hasArg(choices)){
+ choices<-list(...)$choices
+ to.do$choices<-NULL
+ } else choices<-c(1,2)
+ to.do$x<-x$S[,choices]
+ to.do$y<-x$Evec[,choices]
+ do.call(biplot,to.do)
+}
+
+## lambdaTree for lambda="REML"
+## written by Liam J. Revell 2013
+lambdaTree<-function(tree,lambda){
+ n<-length(tree$tip.label)
+ h1<-nodeHeights(tree)
+ ii<-which(tree$edge[,2]>n)
+ tree$edge.length[ii]<-lambda*tree$edge.length[ii]
+ h2<-nodeHeights(tree)
+ tree$edge.length[-ii]<-tree$edge.length[-ii]+h1[-ii,2]-h2[-ii,2]
+ tree
+}
+
+## REML function
+## written by Liam J. Revell 2013
+remlMlambda<-function(lambda,tree,X){
+ tt<-lambdaTree(tree,lambda)
+ Y<-apply(X,2,pic,phy=tt)
+ V<-t(Y)%*%Y/nrow(Y)
+ logL<-sum(dmnorm(Y,mean=rep(0,ncol(Y)),varcov=V,log=TRUE))
+ ## kronRC<-kronecker(V,diag(rep(1,nrow(Y))))
+ ## y<-as.vector(Y)
+ ## logL<--y%*%solve(kronRC,y)/2-length(y)*log(2*pi)/2-determinant(kronRC,logarithm=TRUE)$modulus/2
+ ## print(V)
+ print(c(lambda,logL))
+ logL
+}
+
+## S3 plot method (does screeplot)
+plot.phyl.pca<- function(x,...){
+ if(hasArg(main)) main<-list(...)$main
+ else main="screeplot"
+ x$sdev<-sqrt(diag(x$Eval))
+ screeplot(x,main=main)
+}
+
+## S3 scores method to extract or compute scores
+
+scores<-function(object,...) UseMethod("scores")
+
+scores.default<-function(object,...){
+ warning(paste(
+ "scores does not know how to handle objects of class ",
+ class(object),"."))
+}
+
+scores.phyl.pca<-function(object,...){
+ if(hasArg(newdata))newdata<-list(...)$newdata
+ else newdata<-NULL
+ if(!is.null(newdata)){
+ if(!is.matrix(newdata)) newdata<-as.matrix(newdata)
+ if(ncol(newdata)!=nrow(object$Evec))
+ stop("Dimensions of newdata incorrect.")
+ n<-nrow(newdata)
+ m<-ncol(newdata)
+ A<-matrix(rep(object$a,n),n,m,byrow=TRUE)
+ V<-object$V
+ if(object$mode=="corr"){
+ Y<-newdata/matrix(rep(sqrt(diag(V)),n),n,m,byrow=TRUE)-A
+ } else Y<-newdata-A
+ Scores<-Y%*%object$Evec
+ } else {
+ Scores<-object$S
+ }
+ Scores
+}
+
+## S3 as.princomp method to convert to "princomp" object class
+
+as.princomp<-function(x,...) UseMethod("as.princomp")
+
+as.princomp.default<-function(x,...){
+ warning(paste(
+ "as.princomp does not know how to handle objects of class ",
+ class(x),"."))
+}
+
+as.princomp.phyl.pca<-function(x,...){
+ nn<-paste("Comp.",1:ncol(x$Evec),sep="")
+ obj<-list()
+ obj$sdev<-setNames(sqrt(diag(x$Eval)),nn)
+ obj$loadings<-x$L
+ colnames(obj$loadings)<-nn
+ obj$center<-setNames(x$a[1,],rownames(x$Evec))
+ obj$scale<-setNames(rep(1,length(obj$center)),names(obj$center))
+ obj$scores<-x$S
+ colnames(obj$scores)<-nn
+ obj$call<-x$call
+ class(obj)<-"princomp"
+ obj
}
\ No newline at end of file
diff --git a/R/phyl.resid.R b/R/phyl.resid.R
index 5190868..f7b56be 100644
--- a/R/phyl.resid.R
+++ b/R/phyl.resid.R
@@ -1,57 +1,57 @@
-# function to fit phylogenetic regression and compute residuals
-# multiple morphological traits in Y, size in x
-# written by Liam Revell 2011, 2015 ref. Revell (2009; Evolution)
-
-phyl.resid<-function(tree,x,Y,method="BM"){
- # check tree
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- # check and sort data
- # X
- X<-cbind(1,x)
- if(is.null(rownames(X))){
- print("x has no names. function will assume that the order of x matches tree$tip.label")
- rownames(X)<-tree$tip.label
- } else X<-X[tree$tip.label,] # sort
- # Y
- Y<-as.matrix(Y)
- if(is.null(rownames(Y))){
- print("y has no names. function will assume that the order of y matches tree$tip.label")
- rownames(Y)<-tree$tip.label
- } else Y<-as.matrix(Y[tree$tip.label,]) # sort
-
- # analyze
- if(method=="BM"){
- C<-vcv.phylo(tree)
- beta<-solve(t(X)%*%solve(C)%*%X)%*%t(X)%*%solve(C)%*%Y
- resid<-Y-X%*%beta
- return(list(beta=beta,resid=resid))
- } else if(method=="lambda"){
- C<-vcv.phylo(tree)
- maxLambda<-max(C)/max(C[upper.tri(C)])
- lambda<-vector()
- logL<-vector()
- beta<-matrix(NA,ncol(X),ncol(Y),dimnames=list(colnames(X),colnames(Y)))
- for(i in 1:ncol(Y)){
- res<-optimize(f=likelihood.lambda,interval=c(0,maxLambda),y=Y[,i],X=X,C=C,maximum=TRUE)
- lambda[i]<-res$maximum
- logL[i]<-as.numeric(res$objective)
- C.l<-lambda.transform(lambda[i],C)
- beta[,i]<-solve(t(X)%*%solve(C.l)%*%X)%*%t(X)%*%solve(C.l)%*%Y[,i]
- }
- resid<-Y-X%*%beta
- return(list(beta=beta,lambda=lambda,logL=logL,resid=resid))
- }
-}
-
-# likelihood function for the regression model with lambda
-likelihood.lambda<-function(lambda,y,X,C){
- n<-nrow(C)
- C.lambda<-lambda.transform(lambda,C)
- beta<-solve(t(X)%*%solve(C.lambda)%*%X)%*%(t(X)%*%solve(C.lambda)%*%y)
- sig2e<-as.double((1/n)*(t(y-X%*%beta)%*%solve(C.lambda)%*%(y-X%*%beta)))
- logL<--(1/2)*t(y-X%*%beta)%*%solve(sig2e*C.lambda)%*%(y-X%*%beta)-(1/2)*determinant(sig2e*C.lambda,logarithm=TRUE)$modulus-(n/2)*log(2*pi)
- return(logL)
-}
-
-
-
+# function to fit phylogenetic regression and compute residuals
+# multiple morphological traits in Y, size in x
+# written by Liam Revell 2011, 2015 ref. Revell (2009; Evolution)
+
+phyl.resid<-function(tree,x,Y,method="BM"){
+ # check tree
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ # check and sort data
+ # X
+ X<-cbind(1,x)
+ if(is.null(rownames(X))){
+ print("x has no names. function will assume that the order of x matches tree$tip.label")
+ rownames(X)<-tree$tip.label
+ } else X<-X[tree$tip.label,] # sort
+ # Y
+ Y<-as.matrix(Y)
+ if(is.null(rownames(Y))){
+ print("y has no names. function will assume that the order of y matches tree$tip.label")
+ rownames(Y)<-tree$tip.label
+ } else Y<-as.matrix(Y[tree$tip.label,]) # sort
+
+ # analyze
+ if(method=="BM"){
+ C<-vcv.phylo(tree)
+ beta<-solve(t(X)%*%solve(C)%*%X)%*%t(X)%*%solve(C)%*%Y
+ resid<-Y-X%*%beta
+ return(list(beta=beta,resid=resid))
+ } else if(method=="lambda"){
+ C<-vcv.phylo(tree)
+ maxLambda<-max(C)/max(C[upper.tri(C)])
+ lambda<-vector()
+ logL<-vector()
+ beta<-matrix(NA,ncol(X),ncol(Y),dimnames=list(colnames(X),colnames(Y)))
+ for(i in 1:ncol(Y)){
+ res<-optimize(f=likelihood.lambda,interval=c(0,maxLambda),y=Y[,i],X=X,C=C,maximum=TRUE)
+ lambda[i]<-res$maximum
+ logL[i]<-as.numeric(res$objective)
+ C.l<-lambda.transform(lambda[i],C)
+ beta[,i]<-solve(t(X)%*%solve(C.l)%*%X)%*%t(X)%*%solve(C.l)%*%Y[,i]
+ }
+ resid<-Y-X%*%beta
+ return(list(beta=beta,lambda=lambda,logL=logL,resid=resid))
+ }
+}
+
+# likelihood function for the regression model with lambda
+likelihood.lambda<-function(lambda,y,X,C){
+ n<-nrow(C)
+ C.lambda<-lambda.transform(lambda,C)
+ beta<-solve(t(X)%*%solve(C.lambda)%*%X)%*%(t(X)%*%solve(C.lambda)%*%y)
+ sig2e<-as.double((1/n)*(t(y-X%*%beta)%*%solve(C.lambda)%*%(y-X%*%beta)))
+ logL<--(1/2)*t(y-X%*%beta)%*%solve(sig2e*C.lambda)%*%(y-X%*%beta)-(1/2)*determinant(sig2e*C.lambda,logarithm=TRUE)$modulus-(n/2)*log(2*pi)
+ return(logL)
+}
+
+
+
diff --git a/R/phylo.heatmap.R b/R/phylo.heatmap.R
index 5452555..13647e0 100644
--- a/R/phylo.heatmap.R
+++ b/R/phylo.heatmap.R
@@ -1,75 +1,75 @@
-## function for phylogenetic heat map
-## written by Liam J. Revell 2016, 2017, 2020
-
-phylo.heatmap<-function(tree,X,fsize=1,colors=NULL,standardize=FALSE,...){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- if(length(fsize)!=3) fsize<-rep(fsize,3)
- if(hasArg(legend)) legend<-list(...)$legend
- else legend<-TRUE
- if(hasArg(labels)) labels<-list(...)$labels
- else labels<-TRUE
- if(hasArg(split)) split<-list(...)$split
- else split<-c(0.5,0.5)
- split<-split/sum(split)
- if(is.null(colnames(X))) colnames(X)<-paste("var",1:ncol(X),sep="")
- if(standardize){
- sd<-apply(X,2,function(x) sqrt(var(x,na.rm=TRUE)))
- X<-(X-matrix(rep(1,Ntip(tree)),Ntip(tree),1)%*%colMeans(X,na.rm=TRUE))/
- (matrix(rep(1,Ntip(tree)),Ntip(tree),1)%*%sd)
- }
- if(hasArg(xlim)) xlim<-list(...)$xlim
- else xlim<-c(-0.5,(2-0.5)*split[2]/split[1]+0.5)
- if(hasArg(ylim)) ylim<-list(...)$ylim
- else ylim<-if(legend) c(if(standardize) -0.15 else -0.1,
- if(labels) 1.1 else 1) else c(0,if(labels) 1.1 else 1)
- if(hasArg(mar)) mar<-list(...)$mar
- else mar<-rep(1.1,4)
- if(is.null(colors)) colors<-heat.colors(n=20)[20:1]
- if(hasArg(grid)) add.grid <- list(...)$grid
- else add.grid <- FALSE
- cw<-untangle(as.phylo(tree),"read.tree")
- plot.new()
- par(mar=mar)
- plot.window(xlim=xlim,ylim=ylim)
- h<-phylogram(cw,fsize=fsize[1],...)
- START<-h+1/2*((2-0.5)*split[2]/split[1]+0.5-h)/(ncol(X)-1)+
- 0.5*strwidth("W")*fsize[1]
- END<-(2-0.5)*split[2]/split[1]+0.5-1/2*((2-0.5)*split[2]/split[1]+
- 0.5-START)/(ncol(X)-1)
- X<-X[cw$tip.label,]
- image(x=seq(START,END,by=(END-START)/(ncol(X)-1)),
- z=t(X[cw$tip.label,]),add=TRUE,
- col=colors,...)
- if(add.grid){
- dx <- (END - START)/(ncol(X) - 1)
- x <- seq(START - dx/2, END + dx/2, by = dx)
- nTips <- length(tree$tip.label)
- y <- c(-1/(2*(nTips-1)), seq(0, 1, length = nTips) + 1/(2*(nTips-1)) )
- segments(x, y[1], x, y[length(y)])
- segments(x[1], y, x[length(x)], y)
- }
- if(legend){
- if(hasArg(leg.title)) leg.title<-list(...)$leg.title
- else leg.title<-if(standardize) "standardized value" else "value"
- if(hasArg(leg.subtitle)) leg.subtitle<-list(...)$leg.subtitle
- else leg.subtitle<-if(standardize) "SD units" else ""
- add.color.bar(leg=END-START,cols=colors,lims=range(X,na.rm=TRUE),
- title=leg.title,subtitle=leg.subtitle,prompt=FALSE,x=START,
- y=-1/(2*(Ntip(cw)-1))-3*fsize[3]*strheight("W"),
- digits=if(max(abs(X),na.rm=TRUE)<1) round(log10(1/max(abs(X),na.rm=TRUE)))+1
- else 2,fsize=fsize[3])
- }
- if(labels) text(x=seq(START,END,by=(END-START)/(ncol(X)-1)),
- y=rep(1+1/(2*(Ntip(cw)-1))+0.4*fsize[2]*strwidth("I"),ncol(X)),
- colnames(X),srt=70,adj=c(0,0.5),cex=fsize[2])
- if(any(is.na(X))){
- ii<-which(is.na(X),arr.ind=TRUE)
- x.na<-seq(START,END,by=(END-START)/(ncol(X)-1))[ii[,2]]
- y.na<-seq(0,1,by=1/(nrow(X)-1))[ii[,1]]
- for(i in 1:length(x.na)){
- xx<-x.na[i]+c(1/2,-1/2)*(END-START)/(ncol(X)-1)
- yy<-y.na[i]+c(-1/2,1/2)*1/(nrow(X)-1)
- lines(xx,yy)
- }
- }
-}
+## function for phylogenetic heat map
+## written by Liam J. Revell 2016, 2017, 2020
+
+phylo.heatmap<-function(tree,X,fsize=1,colors=NULL,standardize=FALSE,...){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ if(length(fsize)!=3) fsize<-rep(fsize,3)
+ if(hasArg(legend)) legend<-list(...)$legend
+ else legend<-TRUE
+ if(hasArg(labels)) labels<-list(...)$labels
+ else labels<-TRUE
+ if(hasArg(split)) split<-list(...)$split
+ else split<-c(0.5,0.5)
+ split<-split/sum(split)
+ if(is.null(colnames(X))) colnames(X)<-paste("var",1:ncol(X),sep="")
+ if(standardize){
+ sd<-apply(X,2,function(x) sqrt(var(x,na.rm=TRUE)))
+ X<-(X-matrix(rep(1,Ntip(tree)),Ntip(tree),1)%*%colMeans(X,na.rm=TRUE))/
+ (matrix(rep(1,Ntip(tree)),Ntip(tree),1)%*%sd)
+ }
+ if(hasArg(xlim)) xlim<-list(...)$xlim
+ else xlim<-c(-0.5,(2-0.5)*split[2]/split[1]+0.5)
+ if(hasArg(ylim)) ylim<-list(...)$ylim
+ else ylim<-if(legend) c(if(standardize) -0.15 else -0.1,
+ if(labels) 1.1 else 1) else c(0,if(labels) 1.1 else 1)
+ if(hasArg(mar)) mar<-list(...)$mar
+ else mar<-rep(1.1,4)
+ if(is.null(colors)) colors<-heat.colors(n=20)[20:1]
+ if(hasArg(grid)) add.grid <- list(...)$grid
+ else add.grid <- FALSE
+ cw<-untangle(as.phylo(tree),"read.tree")
+ plot.new()
+ par(mar=mar)
+ plot.window(xlim=xlim,ylim=ylim)
+ h<-phylogram(cw,fsize=fsize[1],...)
+ START<-h+1/2*((2-0.5)*split[2]/split[1]+0.5-h)/(ncol(X)-1)+
+ 0.5*strwidth("W")*fsize[1]
+ END<-(2-0.5)*split[2]/split[1]+0.5-1/2*((2-0.5)*split[2]/split[1]+
+ 0.5-START)/(ncol(X)-1)
+ X<-X[cw$tip.label,]
+ image(x=seq(START,END,by=(END-START)/(ncol(X)-1)),
+ z=t(X[cw$tip.label,]),add=TRUE,
+ col=colors,...)
+ if(add.grid){
+ dx <- (END - START)/(ncol(X) - 1)
+ x <- seq(START - dx/2, END + dx/2, by = dx)
+ nTips <- length(tree$tip.label)
+ y <- c(-1/(2*(nTips-1)), seq(0, 1, length = nTips) + 1/(2*(nTips-1)) )
+ segments(x, y[1], x, y[length(y)])
+ segments(x[1], y, x[length(x)], y)
+ }
+ if(legend){
+ if(hasArg(leg.title)) leg.title<-list(...)$leg.title
+ else leg.title<-if(standardize) "standardized value" else "value"
+ if(hasArg(leg.subtitle)) leg.subtitle<-list(...)$leg.subtitle
+ else leg.subtitle<-if(standardize) "SD units" else ""
+ add.color.bar(leg=END-START,cols=colors,lims=range(X,na.rm=TRUE),
+ title=leg.title,subtitle=leg.subtitle,prompt=FALSE,x=START,
+ y=-1/(2*(Ntip(cw)-1))-3*fsize[3]*strheight("W"),
+ digits=if(max(abs(X),na.rm=TRUE)<1) round(log10(1/max(abs(X),na.rm=TRUE)))+1
+ else 2,fsize=fsize[3])
+ }
+ if(labels) text(x=seq(START,END,by=(END-START)/(ncol(X)-1)),
+ y=rep(1+1/(2*(Ntip(cw)-1))+0.4*fsize[2]*strwidth("I"),ncol(X)),
+ colnames(X),srt=70,adj=c(0,0.5),cex=fsize[2])
+ if(any(is.na(X))){
+ ii<-which(is.na(X),arr.ind=TRUE)
+ x.na<-seq(START,END,by=(END-START)/(ncol(X)-1))[ii[,2]]
+ y.na<-seq(0,1,by=1/(nrow(X)-1))[ii[,1]]
+ for(i in 1:length(x.na)){
+ xx<-x.na[i]+c(1/2,-1/2)*(END-START)/(ncol(X)-1)
+ yy<-y.na[i]+c(-1/2,1/2)*1/(nrow(X)-1)
+ lines(xx,yy)
+ }
+ }
+}
diff --git a/R/phylo.impute.R b/R/phylo.impute.R
index 3b9d971..56312b4 100644
--- a/R/phylo.impute.R
+++ b/R/phylo.impute.R
@@ -1,70 +1,70 @@
-## function to impute missing values in a multivariate data matrix
-## written by Liam J. Revell 2019
-
-phylo.impute<-function(tree,X,...){
- if(hasArg(maxit)) maxit<-list(...)$maxit
- else maxit<-5000
- if(hasArg(quiet)) quiet<-list(...)$quiet
- else quiet<-TRUE
- if(hasArg(fixed)) fixed<-list(...)$fixed
- else fixed<-FALSE
- if(hasArg(p)) p<-list(...)$p
- else p<-2.0
- if(is.data.frame(X)) X<-as.matrix(X)
- ii<-which(is.na(X),arr.ind=TRUE)
- lik<-function(theta,tree,X,ii){
- X[ii]<-theta
- object<-evol.vcv(tree,X)
- if(!quiet) print(object$logL1)
- -object$logL1
- }
- lower<-apply(X,2,expand.range,na.rm=TRUE,p=p)[1,ii[,2]]
- upper<-apply(X,2,expand.range,na.rm=TRUE,p=p)[2,ii[,2]]
- if(hasArg(x.init)) x.init<-list(...)$x.init
- else x.init<-"ace"
- if(x.init[1]=="random") x.init<-runif(n=length(ii),lower,upper)
- else if(x.init[1]=="ace") {
- x.init<-vector()
- for (i in 1:nrow(ii)){
- tip<-rownames(X)[ii[i]]
- tt<-drop.tip(ape::root.phylo(tree,outgroup=tip),
- names(ii[which(ii[,2]==ii[i,2]),1]))
- x.init[i]<-fastAnc(tt,X[!is.na(X[,ii[i,2]]),
- ii[i,2]])[1]
- }
- }
- if(fixed==FALSE){
- fit<-optim(x.init,lik,tree=tree,X=X,ii=ii,method="L-BFGS-B",
- lower=lower,upper=upper,control=list(maxit=maxit))
- } else {
- fit<-list(par=x.init,value=lik(x.init,tree,X,ii),
- counts=c(0,0),convergence=0,
- message="Fixed value of par.")
- }
- X[ii]<-fit$par
- attr(X,"optim")<-list(logLik=-fit$value,counts=fit$counts,
- convergence=fit$convergence,message=fit$message)
- class(X)<-c("matrix","phylo.impute")
- X
-}
-
-expand.range<-function(x,na.rm=FALSE,p=2.0){
- rr<-range(x,na.rm=na.rm)
- mean(rr)+c(p*(rr[1]-mean(rr)),p*(rr[2]-mean(rr)))
-}
-
-print.phylo.impute<-function(x,...){
- if(hasArg(digits)) digits<-list(...)$digits
- else digits<-c(7,3)
- if(hasArg(n)) n<-list(...)$n
- else n<-6L
- if(n>nrow(x)) n<-nrow(x)
- cat("Results from phylogenetic imputation:\n")
- print(head(unclass(x),n),digits=digits[1])
- if(n<nrow(x)) cat("...\n\n") else cat("\n")
- cat(paste("log(L) :",round(attr(x,"optim")$logLik,digits[2]),"\n"))
- if(attr(x,"optim")$convergence==0)
- cat("R thinks it has converged on the correct solution.\n\n")
- else
- cat("R thinks it may not have converged.\n\n")
+## function to impute missing values in a multivariate data matrix
+## written by Liam J. Revell 2019
+
+phylo.impute<-function(tree,X,...){
+ if(hasArg(maxit)) maxit<-list(...)$maxit
+ else maxit<-5000
+ if(hasArg(quiet)) quiet<-list(...)$quiet
+ else quiet<-TRUE
+ if(hasArg(fixed)) fixed<-list(...)$fixed
+ else fixed<-FALSE
+ if(hasArg(p)) p<-list(...)$p
+ else p<-2.0
+ if(is.data.frame(X)) X<-as.matrix(X)
+ ii<-which(is.na(X),arr.ind=TRUE)
+ lik<-function(theta,tree,X,ii){
+ X[ii]<-theta
+ object<-evol.vcv(tree,X)
+ if(!quiet) print(object$logL1)
+ -object$logL1
+ }
+ lower<-apply(X,2,expand.range,na.rm=TRUE,p=p)[1,ii[,2]]
+ upper<-apply(X,2,expand.range,na.rm=TRUE,p=p)[2,ii[,2]]
+ if(hasArg(x.init)) x.init<-list(...)$x.init
+ else x.init<-"ace"
+ if(x.init[1]=="random") x.init<-runif(n=length(ii),lower,upper)
+ else if(x.init[1]=="ace") {
+ x.init<-vector()
+ for (i in 1:nrow(ii)){
+ tip<-rownames(X)[ii[i]]
+ tt<-drop.tip(ape::root.phylo(tree,outgroup=tip),
+ names(ii[which(ii[,2]==ii[i,2]),1]))
+ x.init[i]<-fastAnc(tt,X[!is.na(X[,ii[i,2]]),
+ ii[i,2]])[1]
+ }
+ }
+ if(fixed==FALSE){
+ fit<-optim(x.init,lik,tree=tree,X=X,ii=ii,method="L-BFGS-B",
+ lower=lower,upper=upper,control=list(maxit=maxit))
+ } else {
+ fit<-list(par=x.init,value=lik(x.init,tree,X,ii),
+ counts=c(0,0),convergence=0,
+ message="Fixed value of par.")
+ }
+ X[ii]<-fit$par
+ attr(X,"optim")<-list(logLik=-fit$value,counts=fit$counts,
+ convergence=fit$convergence,message=fit$message)
+ class(X)<-c("matrix","phylo.impute")
+ X
+}
+
+expand.range<-function(x,na.rm=FALSE,p=2.0){
+ rr<-range(x,na.rm=na.rm)
+ mean(rr)+c(p*(rr[1]-mean(rr)),p*(rr[2]-mean(rr)))
+}
+
+print.phylo.impute<-function(x,...){
+ if(hasArg(digits)) digits<-list(...)$digits
+ else digits<-c(7,3)
+ if(hasArg(n)) n<-list(...)$n
+ else n<-6L
+ if(n>nrow(x)) n<-nrow(x)
+ cat("Results from phylogenetic imputation:\n")
+ print(head(unclass(x),n),digits=digits[1])
+ if(n<nrow(x)) cat("...\n\n") else cat("\n")
+ cat(paste("log(L) :",round(attr(x,"optim")$logLik,digits[2]),"\n"))
+ if(attr(x,"optim")$convergence==0)
+ cat("R thinks it has converged on the correct solution.\n\n")
+ else
+ cat("R thinks it may not have converged.\n\n")
}
\ No newline at end of file
diff --git a/R/phylo.to.map.R b/R/phylo.to.map.R
index 72462db..bb9a451 100644
--- a/R/phylo.to.map.R
+++ b/R/phylo.to.map.R
@@ -1,283 +1,283 @@
-## function depends on phytools (& dependencies) and maps (& dependencies)
-## written by Liam J. Revell 2013, 2017, 2019, 2022
-
-phylo.to.map<-function(tree,coords,rotate=TRUE,...){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- # optional arguments
- if(hasArg(database)) database<-list(...)$database
- else database<-"world"
- if(hasArg(regions)) regions<-list(...)$regions
- else regions<-"."
- if(hasArg(plot)) plot<-list(...)$plot
- else plot<-TRUE
- if(hasArg(xlim)) xlim<-list(...)$xlim
- else xlim<-c(-180,180)
- if(hasArg(ylim)) ylim<-list(...)$ylim
- else ylim<-c(-90,90)
- # create a map
- map<-map(database,regions,xlim=xlim,ylim=ylim,plot=FALSE,fill=TRUE,resolution=0)
- # if rotate
- if(hasArg(type)) type<-list(...)$type else type<-"phylogram"
- if(hasArg(direction)) direction<-list(...)$direction else direction<-"downwards"
- if(is.data.frame(coords)) coords<-as.matrix(coords)
- if(rotate&&type=="phylogram"){
- cc<-aggregate(coords,by=list(rownames(coords)),mean)
- cc<-matrix(as.matrix(cc[,2:3]),nrow(cc),2,dimnames=list(cc[,1],colnames(cc)[2:3]))
- tree<-minRotate(tree,cc[,if(direction=="rightwards") 1 else 2])
- } else direction<-"unoptimized"
- x<-list(tree=tree,map=map,coords=coords,direction=direction)
- class(x)<-"phylo.to.map"
- if(plot) plot.phylo.to.map(x,...)
- invisible(x)
-}
-
-## S3 method to plot object of class "phylo.to.map"
-## written by Liam J. Revell 2013, 2014, 2016, 2019, 2020, 2022
-
-plot.phylo.to.map<-function(x,type=c("phylogram","direct"),...){
- type<-type[1]
- if(inherits(x,"phylo.to.map")){
- tree<-x$tree
- map<-x$map
- coords<-x$coords
- } else stop("x should be an object of class \"phylo.to.map\"")
- # get optional arguments
- if(hasArg(xlim)) xlim<-list(...)$xlim
- else xlim<-map$range[1:2]
- if(hasArg(ylim)) ylim<-list(...)$ylim
- else ylim<-map$range[3:4]
- if(hasArg(fsize)) fsize<-list(...)$fsize
- else fsize<-1.0
- if(hasArg(split)) split<-list(...)$split
- else split<-c(0.4,0.6)
- if(hasArg(psize)) psize<-list(...)$psize
- else psize<-1.0
- if(hasArg(cex.points)){
- cex.points<-list(...)$cex.points
- if(length(cex.points)==1) cex.points<-c(0.6*cex.points,cex.points)
- } else cex.points<-c(0.6*psize,psize)
- if(hasArg(mar)) mar<-list(...)$mar
- else mar<-rep(0,4)
- if(hasArg(asp)) asp<-list(...)$asp
- else asp<-1.0
- if(hasArg(ftype)) ftype<-list(...)$ftype
- else ftype<-"reg"
- ftype<-which(c("off","reg","b","i","bi")==ftype)-1
- if(!ftype) fsize=0
- if(hasArg(from.tip)) from.tip<-list(...)$from.tip
- else from.tip<-FALSE
- if(hasArg(colors)) colors<-list(...)$colors
- else colors<-"red"
- if(length(colors)==1) rep(colors[1],2)->colors
- if(length(colors)==2&&type=="phylogram"){
- colors<-matrix(rep(colors,nrow(coords)),nrow(coords),2,byrow=TRUE)
- rownames(colors)<-rownames(coords)
- } else if(is.vector(colors)&&(length(colors)==Ntip(tree))) {
- COLS<-matrix("red",nrow(coords),2,dimnames=list(rownames(coords)))
- for(i in 1:length(colors)) COLS[which(rownames(COLS)==names(colors)[i]),1:2]<-colors[i]
- colors<-COLS
- }
- if(hasArg(direction)) direction<-list(...)$direction
- else direction<-"downwards"
- if(hasArg(pch)) pch<-list(...)$pch
- else pch<-21
- if(length(pch)==1) pch<-rep(pch,2)
- if(hasArg(lwd)) lwd<-list(...)$lwd
- else lwd<-c(2,1)
- if(length(lwd)==1) lwd<-rep(lwd,2)
- if(hasArg(lty)) lty<-list(...)$lty
- else lty<-"dashed"
- if(hasArg(pts)) pts<-list(...)$pts
- else pts<-TRUE
- if(hasArg(col.edge)) col.edge<-list(...)$col.edge
- else col.edge<-rep(par()$fg,nrow(x$tree$edge))
- if(hasArg(map.bg)) map.bg<-list(...)$map.bg
- else map.bg<-"gray95"
- if(type=="phylogram"){
- if(x$direction=="downwards"&&direction=="rightwards"){
- cat("\"phylo.to.map\" direction is \"downwards\" but plot direction has been given as \"rightwards\".\n")
- cat("Re-optimizing object....\n")
- cc<-aggregate(coords,by=list(rownames(coords)),mean)
- cc<-matrix(as.matrix(cc[,2:3]),nrow(cc),2,dimnames=list(cc[,1],colnames(cc)[2:3]))
- tree<-minRotate(tree,cc[,1])
- } else if(x$direction=="rightwards"&&direction=="downwards"){
- cat("\"phylo.to.map\" direction is \"rightwards\" but plot direction has been given as \"downwards\".\n")
- cat("Re-optimizing object....\n")
- cc<-aggregate(coords,by=list(rownames(coords)),mean)
- cc<-matrix(as.matrix(cc[,2:3]),nrow(cc),2,dimnames=list(cc[,1],colnames(cc)[2:3]))
- tree<-minRotate(tree,cc[,2])
- }
- }
- # recompute ylim or xlim to leave space for the tree
- if(type=="phylogram"){
- if(direction=="downwards"){
- if(!ftype) ylim<-c(ylim[1],ylim[2]+0.03*diff(ylim))
- ylim<-c(ylim[1],ylim[2]+
- split[1]/split[2]*(ylim[2]-ylim[1]))
- } else if(direction=="rightwards"){
- if(!ftype) xlim<-c(xlim[1]-0.03*diff(xlim),xlim[2])
- xlim<-c(xlim[1]-split[1]/split[2]*(xlim[2]-xlim[1]),xlim[2])
- }
- }
- # open & size a new plot
- if(all(mar==0)) mar<-mar+0.01
- plot.new()
- par(mar=mar)
- plot.window(xlim=xlim,ylim=ylim,asp=asp)
- map(map,add=TRUE,fill=TRUE,col=map.bg,mar=rep(0,4))
- if(type=="phylogram"){
- ## preliminaries
- cw<-reorder(tree,"cladewise")
- if(!is.binary(cw)) cw<-multi2di(cw)
- n<-Ntip(cw)
- if(direction=="downwards"){
- # plot a white rectangle
- dx<-abs(diff(xlim))
- rect(xlim[1]-1.04*dx,ylim[2]-split[1]*(ylim[2]-ylim[1]),
- xlim[2]+1.04*dx,ylim[2],col=par()$bg,border=par()$bg)
- # rescale tree so it fits in the upper half of the plot
- # with enough space for labels
- pdin<-par()$din[2]
- sh<-(fsize*strwidth(paste(" ",cw$tip.label,sep=""))+
- 0.3*fsize*strwidth("W"))*(par()$din[1]/par()$din[2])*
- (diff(par()$usr[3:4])/diff(par()$usr[1:2]))
- cw$edge.length<-cw$edge.length/max(nodeHeights(cw))*
- (split[1]*(ylim[2]-ylim[1])-max(sh))
- pw<-reorder(cw,"postorder") ## post-order
- x<-vector(length=n+cw$Nnode)
- x[cw$edge[cw$edge[,2]<=n,2]]<-0:(n-1)/(n-1)*(xlim[2]-xlim[1])+xlim[1]
- nn<-unique(pw$edge[,1])
- # compute horizontal position of each edge
- for(i in 1:length(nn)){
- xx<-x[pw$edge[which(pw$edge[,1]==nn[i]),2]]
- x[nn[i]]<-mean(range(xx))
- }
- # compute start & end points of each edge
- Y<-ylim[2]-nodeHeights(cw)
- # plot coordinates & linking lines
- coords<-coords[,2:1]
- for(i in 1:nrow(coords)){
- tip.i<-which(cw$tip.label==rownames(coords)[i])
- lines(c(x[tip.i],coords[i,1]),c(Y[which(cw$edge[,2]==tip.i),2]-
- if(from.tip) 0 else sh[tip.i],coords[i,2]),
- col=colors[i,1],lty=lty,lwd=lwd[2])
- }
- points(coords,pch=pch,cex=cex.points[2],bg=colors[,2])
- # plot vertical edges
- for(i in 1:nrow(Y)) lines(rep(x[cw$edge[i,2]],2),Y[i,],
- lwd=lwd[1],lend=2)
- # plot horizontal relationships
- for(i in 1:cw$Nnode+n){
- ii<-which(cw$edge[,1]==i)
- if(length(ii)>1) lines(range(x[cw$edge[ii,2]]),Y[ii,1],lwd=lwd[1],lend=2)
- }
- # plot tip labels
- for(i in 1:n){
- if(ftype) text(x[i],Y[which(cw$edge[,2]==i),2],
- paste(" ",sub("_"," ",cw$tip.label[i]),sep=""),
- pos=4,offset=c(0,1),
- srt=-90,cex=fsize,font=ftype)
- if(pts) points(x[i],Y[which(cw$edge[,2]==i),2],pch=21,
- bg=colors[cw$tip.label,][i,2],
- cex=cex.points[1])
- }
- PP<-list(type="phylogram",use.edge.length=TRUE,node.pos=1,
- show.tip.label=if(ftype) TRUE else FALSE,show.node.label=FALSE,
- font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE,
- label.offset=fsize*strwidth(" ")/(par()$usr[2]-
- par()$usr[1])*(par()$usr[4]-par()$usr[3]),
- x.lim=xlim,y.lim=ylim,
- direction=direction,tip.color=par()$fg,Ntip=Ntip(cw),
- Nnode=cw$Nnode,edge=cw$edge,xx=x,yy=sapply(1:(Ntip(cw)+
- cw$Nnode),function(x,y,z) y[match(x,z)],y=Y,z=cw$edge))
- } else {
- dy<-abs(diff(ylim))
- rect(xlim[1],ylim[1],xlim[1]+split[1]*(xlim[2]-
- xlim[1]),ylim[2],col=par()$bg,border=par()$bg)
- sh<-fsize*strwidth(paste(" ",cw$tip.label,sep=""))+
- 0.2*fsize*strwidth("W")
- cw$edge.length<-cw$edge.length/max(nodeHeights(cw))*
- (split[1]*(xlim[2]-xlim[1])-max(sh))
- pw<-reorder(cw,"postorder")
- y<-vector(length=n+cw$Nnode)
- y[cw$edge[cw$edge[,2]<=n,2]]<-0:(n-1)/(n-1)*(ylim[2]-ylim[1])+ylim[1]
- nn<-unique(pw$edge[,1])
- for(i in 1:length(nn)){
- yy<-y[pw$edge[which(pw$edge[,1]==nn[i]),2]]
- y[nn[i]]<-mean(range(yy))
- }
- H<-nodeHeights(cw)
- X<-xlim[1]+H
- coords<-coords[,2:1]
- for(i in 1:nrow(coords)){
- tip.i<-which(cw$tip.label==rownames(coords)[i])
- lines(c(X[which(cw$edge[,2]==tip.i),2]+if(from.tip) 0 else sh[tip.i],coords[i,1]),
- c(y[tip.i],coords[i,2]),col=colors[i,1],lty=lty,lwd=lwd[2])
- }
- points(coords,pch=pch,cex=cex.points[2],bg=colors[,2])
- for(i in 1:nrow(X)) lines(X[i,],rep(y[cw$edge[i,2]],2),lwd=lwd[1],lend=2)
- for(i in 1:cw$Nnode+n){
- ii<-which(cw$edge[,1]==i)
- if(length(ii)>1) lines(X[ii,1],range(y[cw$edge[ii,2]]),lwd=lwd[1],lend=2)
- }
- for(i in 1:n){
- if(ftype) text(X[which(cw$edge[,2]==i),2],y[i],
- paste(" ",sub("_"," ",cw$tip.label[i]),sep=""),
- pos=4,offset=0.1,cex=fsize,font=ftype)
- if(pts) points(X[which(cw$edge[,2]==i),2],y[i],
- pch=21,bg=colors[cw$tip.label,][i,2],cex=cex.points[1])
- }
- PP<-list(type="phylogram",use.edge.length=TRUE,node.pos=1,
- show.tip.label=if(ftype) TRUE else FALSE,show.node.label=FALSE,
- font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE,label.offset=0.1,
- x.lim=xlim,y.lim=ylim,
- direction=direction,tip.color=par()$fg,Ntip=Ntip(cw),Nnode=cw$Nnode,
- edge=cw$edge,xx=sapply(1:(Ntip(cw)+cw$Nnode),
- function(x,y,z) y[match(x,z)],y=X,z=cw$edge),yy=y)
- }
- assign("last_plot.phylo",PP,envir=.PlotPhyloEnv)
- } else if(type=="direct"){
- phylomorphospace(tree,coords[,2:1],add=TRUE,label="horizontal",
- node.size=c(0,psize),lwd=lwd[2],control=list(col.node=
- setNames(rep(colors[2],max(tree$edge)),1:max(tree$edge)),
- col.edge=setNames(rep(colors[1],nrow(tree$edge)),tree$edge[,2])),
- ftype=c("off","reg","b","i","bi")[ftype+1],fsize=fsize)
- }
-}
-
-
-## rotates all nodes to try and match tip an ordering
-## written by Liam J. Revell 2013, 2015, 2020
-minRotate<-function(tree,x,...){
- if(hasArg(print)) print<-list(...)$print
- else print<-TRUE
- tree<-reorder(tree)
- nn<-1:tree$Nnode+Ntip(tree)
- x<-x[tree$tip.label]
- for(i in 1:tree$Nnode){
- tt<-read.tree(text=write.tree(if(isSingleton(tree,nn[i])) tree else rotate(tree,nn[i])))
- oo<-sum(abs(order(x[tree$tip.label])-1:length(tree$tip.label)))
- pp<-sum(abs(order(x[tt$tip.label])-1:length(tt$tip.label)))
- if(oo>pp) tree<-tt
- if(print) message(paste("objective:",min(oo,pp)))
- }
- attr(tree,"minRotate")<-min(oo,pp)
- return(tree)
-}
-
-isSingleton<-function(tree,node) if(sum(tree$edge[,1]==node)<=1) TRUE else FALSE
-
-print.phylo.to.map<-function(x,...){
- cat("Object of class \"phylo.to.map\" containing:\n\n")
- cat(paste("(1) A phylogenetic tree with",Ntip(x$tree),"tips and",x$tree$Nnode,"internal nodes.\n\n",sep=" "))
- cat("(2) A geographic map with range:\n")
- cat(paste(" ",paste(round(x$map$range[3:4],2),collapse="N, "),"N\n",sep=""))
- cat(paste(" ",paste(round(x$map$range[1:2],2),collapse="W, "),"W.\n\n",sep=""))
- cat(paste("(3) A table containing ",nrow(x$coords)," geographic coordinates (may include\n",
- " more than one set per species).\n\n",sep=""))
- if(x$direction%in%c("downwards","rightwards"))
- cat(paste("If optimized, tree nodes have been rotated to maximize alignment\n",
- "with the map when the tree is plotted in a ",x$direction," direction.\n\n",sep=""))
- else
- cat("The nodes of the tree may not have yet been rotated to maximize\nalignment between the phylogeny & the map.\n\n")
-}
+## function depends on phytools (& dependencies) and maps (& dependencies)
+## written by Liam J. Revell 2013, 2017, 2019, 2022
+
+phylo.to.map<-function(tree,coords,rotate=TRUE,...){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ # optional arguments
+ if(hasArg(database)) database<-list(...)$database
+ else database<-"world"
+ if(hasArg(regions)) regions<-list(...)$regions
+ else regions<-"."
+ if(hasArg(plot)) plot<-list(...)$plot
+ else plot<-TRUE
+ if(hasArg(xlim)) xlim<-list(...)$xlim
+ else xlim<-c(-180,180)
+ if(hasArg(ylim)) ylim<-list(...)$ylim
+ else ylim<-c(-90,90)
+ # create a map
+ map<-map(database,regions,xlim=xlim,ylim=ylim,plot=FALSE,fill=TRUE,resolution=0)
+ # if rotate
+ if(hasArg(type)) type<-list(...)$type else type<-"phylogram"
+ if(hasArg(direction)) direction<-list(...)$direction else direction<-"downwards"
+ if(is.data.frame(coords)) coords<-as.matrix(coords)
+ if(rotate&&type=="phylogram"){
+ cc<-aggregate(coords,by=list(rownames(coords)),mean)
+ cc<-matrix(as.matrix(cc[,2:3]),nrow(cc),2,dimnames=list(cc[,1],colnames(cc)[2:3]))
+ tree<-minRotate(tree,cc[,if(direction=="rightwards") 1 else 2])
+ } else direction<-"unoptimized"
+ x<-list(tree=tree,map=map,coords=coords,direction=direction)
+ class(x)<-"phylo.to.map"
+ if(plot) plot.phylo.to.map(x,...)
+ invisible(x)
+}
+
+## S3 method to plot object of class "phylo.to.map"
+## written by Liam J. Revell 2013, 2014, 2016, 2019, 2020, 2022
+
+plot.phylo.to.map<-function(x,type=c("phylogram","direct"),...){
+ type<-type[1]
+ if(inherits(x,"phylo.to.map")){
+ tree<-x$tree
+ map<-x$map
+ coords<-x$coords
+ } else stop("x should be an object of class \"phylo.to.map\"")
+ # get optional arguments
+ if(hasArg(xlim)) xlim<-list(...)$xlim
+ else xlim<-map$range[1:2]
+ if(hasArg(ylim)) ylim<-list(...)$ylim
+ else ylim<-map$range[3:4]
+ if(hasArg(fsize)) fsize<-list(...)$fsize
+ else fsize<-1.0
+ if(hasArg(split)) split<-list(...)$split
+ else split<-c(0.4,0.6)
+ if(hasArg(psize)) psize<-list(...)$psize
+ else psize<-1.0
+ if(hasArg(cex.points)){
+ cex.points<-list(...)$cex.points
+ if(length(cex.points)==1) cex.points<-c(0.6*cex.points,cex.points)
+ } else cex.points<-c(0.6*psize,psize)
+ if(hasArg(mar)) mar<-list(...)$mar
+ else mar<-rep(0,4)
+ if(hasArg(asp)) asp<-list(...)$asp
+ else asp<-1.0
+ if(hasArg(ftype)) ftype<-list(...)$ftype
+ else ftype<-"reg"
+ ftype<-which(c("off","reg","b","i","bi")==ftype)-1
+ if(!ftype) fsize=0
+ if(hasArg(from.tip)) from.tip<-list(...)$from.tip
+ else from.tip<-FALSE
+ if(hasArg(colors)) colors<-list(...)$colors
+ else colors<-"red"
+ if(length(colors)==1) rep(colors[1],2)->colors
+ if(length(colors)==2&&type=="phylogram"){
+ colors<-matrix(rep(colors,nrow(coords)),nrow(coords),2,byrow=TRUE)
+ rownames(colors)<-rownames(coords)
+ } else if(is.vector(colors)&&(length(colors)==Ntip(tree))) {
+ COLS<-matrix("red",nrow(coords),2,dimnames=list(rownames(coords)))
+ for(i in 1:length(colors)) COLS[which(rownames(COLS)==names(colors)[i]),1:2]<-colors[i]
+ colors<-COLS
+ }
+ if(hasArg(direction)) direction<-list(...)$direction
+ else direction<-"downwards"
+ if(hasArg(pch)) pch<-list(...)$pch
+ else pch<-21
+ if(length(pch)==1) pch<-rep(pch,2)
+ if(hasArg(lwd)) lwd<-list(...)$lwd
+ else lwd<-c(2,1)
+ if(length(lwd)==1) lwd<-rep(lwd,2)
+ if(hasArg(lty)) lty<-list(...)$lty
+ else lty<-"dashed"
+ if(hasArg(pts)) pts<-list(...)$pts
+ else pts<-TRUE
+ if(hasArg(col.edge)) col.edge<-list(...)$col.edge
+ else col.edge<-rep(par()$fg,nrow(x$tree$edge))
+ if(hasArg(map.bg)) map.bg<-list(...)$map.bg
+ else map.bg<-"gray95"
+ if(type=="phylogram"){
+ if(x$direction=="downwards"&&direction=="rightwards"){
+ cat("\"phylo.to.map\" direction is \"downwards\" but plot direction has been given as \"rightwards\".\n")
+ cat("Re-optimizing object....\n")
+ cc<-aggregate(coords,by=list(rownames(coords)),mean)
+ cc<-matrix(as.matrix(cc[,2:3]),nrow(cc),2,dimnames=list(cc[,1],colnames(cc)[2:3]))
+ tree<-minRotate(tree,cc[,1])
+ } else if(x$direction=="rightwards"&&direction=="downwards"){
+ cat("\"phylo.to.map\" direction is \"rightwards\" but plot direction has been given as \"downwards\".\n")
+ cat("Re-optimizing object....\n")
+ cc<-aggregate(coords,by=list(rownames(coords)),mean)
+ cc<-matrix(as.matrix(cc[,2:3]),nrow(cc),2,dimnames=list(cc[,1],colnames(cc)[2:3]))
+ tree<-minRotate(tree,cc[,2])
+ }
+ }
+ # recompute ylim or xlim to leave space for the tree
+ if(type=="phylogram"){
+ if(direction=="downwards"){
+ if(!ftype) ylim<-c(ylim[1],ylim[2]+0.03*diff(ylim))
+ ylim<-c(ylim[1],ylim[2]+
+ split[1]/split[2]*(ylim[2]-ylim[1]))
+ } else if(direction=="rightwards"){
+ if(!ftype) xlim<-c(xlim[1]-0.03*diff(xlim),xlim[2])
+ xlim<-c(xlim[1]-split[1]/split[2]*(xlim[2]-xlim[1]),xlim[2])
+ }
+ }
+ # open & size a new plot
+ if(all(mar==0)) mar<-mar+0.01
+ plot.new()
+ par(mar=mar)
+ plot.window(xlim=xlim,ylim=ylim,asp=asp)
+ map(map,add=TRUE,fill=TRUE,col=map.bg,mar=rep(0,4))
+ if(type=="phylogram"){
+ ## preliminaries
+ cw<-reorder(tree,"cladewise")
+ if(!is.binary(cw)) cw<-multi2di(cw)
+ n<-Ntip(cw)
+ if(direction=="downwards"){
+ # plot a white rectangle
+ dx<-abs(diff(xlim))
+ rect(xlim[1]-1.04*dx,ylim[2]-split[1]*(ylim[2]-ylim[1]),
+ xlim[2]+1.04*dx,ylim[2],col=par()$bg,border=par()$bg)
+ # rescale tree so it fits in the upper half of the plot
+ # with enough space for labels
+ pdin<-par()$din[2]
+ sh<-(fsize*strwidth(paste(" ",cw$tip.label,sep=""))+
+ 0.3*fsize*strwidth("W"))*(par()$din[1]/par()$din[2])*
+ (diff(par()$usr[3:4])/diff(par()$usr[1:2]))
+ cw$edge.length<-cw$edge.length/max(nodeHeights(cw))*
+ (split[1]*(ylim[2]-ylim[1])-max(sh))
+ pw<-reorder(cw,"postorder") ## post-order
+ x<-vector(length=n+cw$Nnode)
+ x[cw$edge[cw$edge[,2]<=n,2]]<-0:(n-1)/(n-1)*(xlim[2]-xlim[1])+xlim[1]
+ nn<-unique(pw$edge[,1])
+ # compute horizontal position of each edge
+ for(i in 1:length(nn)){
+ xx<-x[pw$edge[which(pw$edge[,1]==nn[i]),2]]
+ x[nn[i]]<-mean(range(xx))
+ }
+ # compute start & end points of each edge
+ Y<-ylim[2]-nodeHeights(cw)
+ # plot coordinates & linking lines
+ coords<-coords[,2:1]
+ for(i in 1:nrow(coords)){
+ tip.i<-which(cw$tip.label==rownames(coords)[i])
+ lines(c(x[tip.i],coords[i,1]),c(Y[which(cw$edge[,2]==tip.i),2]-
+ if(from.tip) 0 else sh[tip.i],coords[i,2]),
+ col=colors[i,1],lty=lty,lwd=lwd[2])
+ }
+ points(coords,pch=pch,cex=cex.points[2],bg=colors[,2])
+ # plot vertical edges
+ for(i in 1:nrow(Y)) lines(rep(x[cw$edge[i,2]],2),Y[i,],
+ lwd=lwd[1],lend=2)
+ # plot horizontal relationships
+ for(i in 1:cw$Nnode+n){
+ ii<-which(cw$edge[,1]==i)
+ if(length(ii)>1) lines(range(x[cw$edge[ii,2]]),Y[ii,1],lwd=lwd[1],lend=2)
+ }
+ # plot tip labels
+ for(i in 1:n){
+ if(ftype) text(x[i],Y[which(cw$edge[,2]==i),2],
+ paste(" ",sub("_"," ",cw$tip.label[i]),sep=""),
+ pos=4,offset=c(0,1),
+ srt=-90,cex=fsize,font=ftype)
+ if(pts) points(x[i],Y[which(cw$edge[,2]==i),2],pch=21,
+ bg=colors[cw$tip.label,][i,2],
+ cex=cex.points[1])
+ }
+ PP<-list(type="phylogram",use.edge.length=TRUE,node.pos=1,
+ show.tip.label=if(ftype) TRUE else FALSE,show.node.label=FALSE,
+ font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE,
+ label.offset=fsize*strwidth(" ")/(par()$usr[2]-
+ par()$usr[1])*(par()$usr[4]-par()$usr[3]),
+ x.lim=xlim,y.lim=ylim,
+ direction=direction,tip.color=par()$fg,Ntip=Ntip(cw),
+ Nnode=cw$Nnode,edge=cw$edge,xx=x,yy=sapply(1:(Ntip(cw)+
+ cw$Nnode),function(x,y,z) y[match(x,z)],y=Y,z=cw$edge))
+ } else {
+ dy<-abs(diff(ylim))
+ rect(xlim[1],ylim[1],xlim[1]+split[1]*(xlim[2]-
+ xlim[1]),ylim[2],col=par()$bg,border=par()$bg)
+ sh<-fsize*strwidth(paste(" ",cw$tip.label,sep=""))+
+ 0.2*fsize*strwidth("W")
+ cw$edge.length<-cw$edge.length/max(nodeHeights(cw))*
+ (split[1]*(xlim[2]-xlim[1])-max(sh))
+ pw<-reorder(cw,"postorder")
+ y<-vector(length=n+cw$Nnode)
+ y[cw$edge[cw$edge[,2]<=n,2]]<-0:(n-1)/(n-1)*(ylim[2]-ylim[1])+ylim[1]
+ nn<-unique(pw$edge[,1])
+ for(i in 1:length(nn)){
+ yy<-y[pw$edge[which(pw$edge[,1]==nn[i]),2]]
+ y[nn[i]]<-mean(range(yy))
+ }
+ H<-nodeHeights(cw)
+ X<-xlim[1]+H
+ coords<-coords[,2:1]
+ for(i in 1:nrow(coords)){
+ tip.i<-which(cw$tip.label==rownames(coords)[i])
+ lines(c(X[which(cw$edge[,2]==tip.i),2]+if(from.tip) 0 else sh[tip.i],coords[i,1]),
+ c(y[tip.i],coords[i,2]),col=colors[i,1],lty=lty,lwd=lwd[2])
+ }
+ points(coords,pch=pch,cex=cex.points[2],bg=colors[,2])
+ for(i in 1:nrow(X)) lines(X[i,],rep(y[cw$edge[i,2]],2),lwd=lwd[1],lend=2)
+ for(i in 1:cw$Nnode+n){
+ ii<-which(cw$edge[,1]==i)
+ if(length(ii)>1) lines(X[ii,1],range(y[cw$edge[ii,2]]),lwd=lwd[1],lend=2)
+ }
+ for(i in 1:n){
+ if(ftype) text(X[which(cw$edge[,2]==i),2],y[i],
+ paste(" ",sub("_"," ",cw$tip.label[i]),sep=""),
+ pos=4,offset=0.1,cex=fsize,font=ftype)
+ if(pts) points(X[which(cw$edge[,2]==i),2],y[i],
+ pch=21,bg=colors[cw$tip.label,][i,2],cex=cex.points[1])
+ }
+ PP<-list(type="phylogram",use.edge.length=TRUE,node.pos=1,
+ show.tip.label=if(ftype) TRUE else FALSE,show.node.label=FALSE,
+ font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE,label.offset=0.1,
+ x.lim=xlim,y.lim=ylim,
+ direction=direction,tip.color=par()$fg,Ntip=Ntip(cw),Nnode=cw$Nnode,
+ edge=cw$edge,xx=sapply(1:(Ntip(cw)+cw$Nnode),
+ function(x,y,z) y[match(x,z)],y=X,z=cw$edge),yy=y)
+ }
+ assign("last_plot.phylo",PP,envir=.PlotPhyloEnv)
+ } else if(type=="direct"){
+ phylomorphospace(tree,coords[,2:1],add=TRUE,label="horizontal",
+ node.size=c(0,psize),lwd=lwd[2],control=list(col.node=
+ setNames(rep(colors[2],max(tree$edge)),1:max(tree$edge)),
+ col.edge=setNames(rep(colors[1],nrow(tree$edge)),tree$edge[,2])),
+ ftype=c("off","reg","b","i","bi")[ftype+1],fsize=fsize)
+ }
+}
+
+
+## rotates all nodes to try and match tip an ordering
+## written by Liam J. Revell 2013, 2015, 2020
+minRotate<-function(tree,x,...){
+ if(hasArg(print)) print<-list(...)$print
+ else print<-TRUE
+ tree<-reorder(tree)
+ nn<-1:tree$Nnode+Ntip(tree)
+ x<-x[tree$tip.label]
+ for(i in 1:tree$Nnode){
+ tt<-read.tree(text=write.tree(if(isSingleton(tree,nn[i])) tree else rotate(tree,nn[i])))
+ oo<-sum(abs(order(x[tree$tip.label])-1:length(tree$tip.label)))
+ pp<-sum(abs(order(x[tt$tip.label])-1:length(tt$tip.label)))
+ if(oo>pp) tree<-tt
+ if(print) message(paste("objective:",min(oo,pp)))
+ }
+ attr(tree,"minRotate")<-min(oo,pp)
+ return(tree)
+}
+
+isSingleton<-function(tree,node) if(sum(tree$edge[,1]==node)<=1) TRUE else FALSE
+
+print.phylo.to.map<-function(x,...){
+ cat("Object of class \"phylo.to.map\" containing:\n\n")
+ cat(paste("(1) A phylogenetic tree with",Ntip(x$tree),"tips and",x$tree$Nnode,"internal nodes.\n\n",sep=" "))
+ cat("(2) A geographic map with range:\n")
+ cat(paste(" ",paste(round(x$map$range[3:4],2),collapse="N, "),"N\n",sep=""))
+ cat(paste(" ",paste(round(x$map$range[1:2],2),collapse="W, "),"W.\n\n",sep=""))
+ cat(paste("(3) A table containing ",nrow(x$coords)," geographic coordinates (may include\n",
+ " more than one set per species).\n\n",sep=""))
+ if(x$direction%in%c("downwards","rightwards"))
+ cat(paste("If optimized, tree nodes have been rotated to maximize alignment\n",
+ "with the map when the tree is plotted in a ",x$direction," direction.\n\n",sep=""))
+ else
+ cat("The nodes of the tree may not have yet been rotated to maximize\nalignment between the phylogeny & the map.\n\n")
+}
diff --git a/R/phylomorphospace.R b/R/phylomorphospace.R
index 6195128..03e0a5a 100644
--- a/R/phylomorphospace.R
+++ b/R/phylomorphospace.R
@@ -1,143 +1,143 @@
-## this funciton creates a phylomorphospace plot (Sidlauskas 2006)
-## written by Liam J. Revell 2010-13, 2015, 2018, 2020
-
-phylomorphospace<-function(tree,X,A=NULL,label=c("radial","horizontal","off"),control=list(),...){
- # some minor error checking
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- if(nrow(X)!=length(tree$tip)) stop("X must contain the same number of rows as species in tree.")
- if(is.null(rownames(X))){
- warning("X is missing row names; assuming order of tip labels.")
- rownames(X)<-tree$tip.label
- }
- if(ncol(X)!=2){
- warning("X has more than 2 columns. Using only the first 2 columns.")
- X<-X[,1:2]
- }
- # get ancestral states
- if(is.null(A)) A<-apply(X,2,fastAnc,tree=tree)
- # control list
- con=list(col.edge=setNames(rep("black",nrow(tree$edge)),as.character(tree$edge[,2])),
- col.node=setNames(rep("black",max(tree$edge)),as.character(1:max(tree$edge))))
- con[(namc<-names(control))]<-control
- # get optional arguments
- if(hasArg(node.by.map)) node.by.map<-list(...)$node.by.map
- else node.by.map<-FALSE
- if(hasArg(ftype)) ftype<-list(...)$ftype
- else ftype<-"reg"
- ftype<-which(c("off","reg","b","i","bi")==ftype)-1
- if(!ftype) label<-"off"
- if(hasArg(node.size)){
- node.size<-list(...)$node.size
- if(length(node.size)==1) node.size<-c(node.size,node.size)
- } else node.size<-c(1,1.3)
- # set xlim & ylim
- if(hasArg(xlim)) xlim<-list(...)$xlim
- else xlim<-expand(range(c(X[,1],A[,1])),1.1)
- if(hasArg(ylim)) ylim<-list(...)$ylim
- else ylim<-expand(range(c(X[,2],A[,2])),1.1)
- # set xlab & ylab
- if(hasArg(xlab)) xlab<-list(...)$xlab
- else xlab<-colnames(X)[1]
- if(hasArg(ylab)) ylab<-list(...)$ylab
- else ylab<-colnames(X)[2]
- # set font size for tip labels
- if(hasArg(fsize)) fsize<-0.75*list(...)$fsize
- else fsize<-0.75
- # check if colors for stochastic mapping
- if(hasArg(colors)) colors<-list(...)$colors
- else if(!is.null(tree$maps)) colors<-setNames(palette()[1:ncol(tree$mapped.edge)],
- sort(colnames(tree$mapped.edge)))
- # set lwd
- if(hasArg(lwd)) lwd<-list(...)$lwd
- else lwd<-if(is.null(tree$maps)) 1 else 2
- # other optional arguments?
- if(hasArg(axes)) axes<-list(...)$axes
- else axes<-TRUE
- if(hasArg(add)) add<-list(...)$add
- else add<-FALSE
- if(hasArg(pch)) pch<-list(...)$pch
- else pch<-21
- if(hasArg(bty)) bty<-list(...)$bty
- else bty<-"o"
- if(hasArg(las)) las<-list(...)$las
- else las<-par()$las
- # deprecate to logical label argument
- label<-label[1]
- if(label==TRUE||label==FALSE)
- message("options for label have changed.\nNow choose \"radial\", \"horizontal\", or \"off\".")
- if(label==TRUE) label<-"radial"
- if(label==FALSE) label<-"off"
- # do some bookkeeping
- aa<-setNames(c(X[tree$tip.label,1],A[,1]),c(1:length(tree$tip.label),rownames(A)))
- bb<-setNames(c(X[tree$tip.label,2],A[,2]),c(1:length(tree$tip.label),rownames(A)))
- XX<-matrix(aa[as.character(tree$edge)],nrow(tree$edge),2)
- YY<-matrix(bb[as.character(tree$edge)],nrow(tree$edge),2)
- # plot projection
- if(!add) plot(x=A[1,1],y=A[1,2],xlim=xlim,ylim=ylim,xlab=xlab,ylab=ylab,pch=16,cex=0.1,
- col="white",axes=axes,frame.plot=TRUE,bty=bty,las=las)
- if(is.null(tree$maps)){
- for(i in 1:nrow(XX)) lines(XX[i,],YY[i,],col=con$col.edge[as.character(tree$edge[i,2])],
- lwd=lwd)
- } else {
- for(i in 1:nrow(XX)){
- xx<-tree$maps[[i]]/sum(tree$maps[[i]])*(XX[i,2]-XX[i,1])
- yy<-tree$maps[[i]]/sum(tree$maps[[i]])*(YY[i,2]-YY[i,1])
- cc<-names(tree$maps[[i]])
- x<-XX[i,1]; y<-YY[i,1]
- for(j in 1:length(xx)){
- lines(c(x,x+xx[j]),c(y,y+yy[j]),col=colors[cc[j]],lwd=lwd)
- x<-x+xx[j]; y<-y+yy[j]
- }
- }
- if(node.by.map){
- zz<-c(getStates(tree,type="tips"),getStates(tree))
- names(zz)[1:length(tree$tip.label)]<-sapply(names(zz)[1:length(tree$tip.label)],
- function(x,y) which(y==x),y=tree$tip.label)
- con$col.node<-setNames(colors[zz],names(zz))
- }
- }
- zz<-c(tree$edge[1,1],tree$edge[tree$edge[,2]>length(tree$tip.label),2])
- points(c(XX[1,1],XX[tree$edge[,2]>length(tree$tip.label),2]),c(YY[1,1],
- YY[tree$edge[,2]>length(tree$tip.label),2]),pch=pch,cex=node.size[1],
- col=if(pch%in%c(1:20)) con$col.node[as.character(zz)] else "black",
- bg=if(pch%in%c(21:25)) con$col.node[as.character(zz)] else NULL)
- zz<-tree$edge[tree$edge[,2]<=length(tree$tip.label),2]
- points(XX[tree$edge[,2]<=length(tree$tip.label),2],YY[tree$edge[,2]<=length(tree$tip.label),2],
- pch=pch,cex=node.size[2],col=if(pch%in%c(1:20)) con$col.node[as.character(zz)] else "black",
- bg=if(pch%in%c(21:25)) con$col.node[as.character(zz)] else NULL)
- zz<-sapply(1:length(tree$tip.label),function(x,y) which(x==y),y=tree$edge[,2])
- if(label!="off"){
- asp<-(par()$usr[2]-par()$usr[1])/(par()$usr[4]-par()$usr[3])
- for(i in 1:length(tree$tip.label)){
- ii<-which(tree$edge[,2]==i)
- aa<-atan(asp*(YY[ii,2]-YY[ii,1])/(XX[ii,2]-XX[ii,1]))/(2*pi)*360
- adj<-if(XX[ii,2]<XX[ii,1]) c(1,0.25) else c(0,0.25)
- tt<-if(XX[ii,2]<XX[ii,1]) paste(tree$tip.label[i]," ",sep="") else
- paste(" ",tree$tip.label[i],sep="")
- if(label=="radial") text(XX[ii,2],YY[ii,2],tt,cex=fsize,srt=aa,adj=adj,font=ftype)
- else if(label=="horizontal") text(XX[ii,2],YY[ii,2],tt,cex=fsize,adj=adj,font=ftype)
- }
- } else adj<-0
- xx<-setNames(c(XX[1,1],XX[,2]),c(tree$edge[1,1],tree$edge[,2]))
- xx<-xx[order(as.numeric(names(xx)))]
- yy<-setNames(c(YY[1,1],YY[,2]),c(tree$edge[1,1],tree$edge[,2]))
- yy<-yy[order(as.numeric(names(yy)))]
- PP<-list(type="phylomorphospace",use.edge.length=TRUE,node.pos=1,
- show.tip.label=if(label!="off") TRUE else FALSE,show.node.label=FALSE,
- font=ftype,cex=fsize,adj=adj,srt=NULL,no.margin=FALSE,label.offset=0,
- x.lim=par()$usr[1:2],y.lim=par()$usr[3:4],
- direction=NULL,tip.color="black",Ntip=Ntip(tree),Nnode=tree$Nnode,
- edge=tree$edge,xx=xx,yy=yy)
- assign("last_plot.phylo",PP,envir=.PlotPhyloEnv)
-}
-
-# function to expand a range
-# written by Liam J. Revell 2013
-expand<-function(x,factor=1.05){
- rr<-x[2]-x[1]
- mm<-mean(x)
- x[1]<-mm-rr*factor/2
- x[2]<-mm+rr*factor/2
- return(x)
-}
-
+## this funciton creates a phylomorphospace plot (Sidlauskas 2006)
+## written by Liam J. Revell 2010-13, 2015, 2018, 2020
+
+phylomorphospace<-function(tree,X,A=NULL,label=c("radial","horizontal","off"),control=list(),...){
+ # some minor error checking
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ if(nrow(X)!=length(tree$tip)) stop("X must contain the same number of rows as species in tree.")
+ if(is.null(rownames(X))){
+ warning("X is missing row names; assuming order of tip labels.")
+ rownames(X)<-tree$tip.label
+ }
+ if(ncol(X)!=2){
+ warning("X has more than 2 columns. Using only the first 2 columns.")
+ X<-X[,1:2]
+ }
+ # get ancestral states
+ if(is.null(A)) A<-apply(X,2,fastAnc,tree=tree)
+ # control list
+ con=list(col.edge=setNames(rep("black",nrow(tree$edge)),as.character(tree$edge[,2])),
+ col.node=setNames(rep("black",max(tree$edge)),as.character(1:max(tree$edge))))
+ con[(namc<-names(control))]<-control
+ # get optional arguments
+ if(hasArg(node.by.map)) node.by.map<-list(...)$node.by.map
+ else node.by.map<-FALSE
+ if(hasArg(ftype)) ftype<-list(...)$ftype
+ else ftype<-"reg"
+ ftype<-which(c("off","reg","b","i","bi")==ftype)-1
+ if(!ftype) label<-"off"
+ if(hasArg(node.size)){
+ node.size<-list(...)$node.size
+ if(length(node.size)==1) node.size<-c(node.size,node.size)
+ } else node.size<-c(1,1.3)
+ # set xlim & ylim
+ if(hasArg(xlim)) xlim<-list(...)$xlim
+ else xlim<-expand(range(c(X[,1],A[,1])),1.1)
+ if(hasArg(ylim)) ylim<-list(...)$ylim
+ else ylim<-expand(range(c(X[,2],A[,2])),1.1)
+ # set xlab & ylab
+ if(hasArg(xlab)) xlab<-list(...)$xlab
+ else xlab<-colnames(X)[1]
+ if(hasArg(ylab)) ylab<-list(...)$ylab
+ else ylab<-colnames(X)[2]
+ # set font size for tip labels
+ if(hasArg(fsize)) fsize<-0.75*list(...)$fsize
+ else fsize<-0.75
+ # check if colors for stochastic mapping
+ if(hasArg(colors)) colors<-list(...)$colors
+ else if(!is.null(tree$maps)) colors<-setNames(palette()[1:ncol(tree$mapped.edge)],
+ sort(colnames(tree$mapped.edge)))
+ # set lwd
+ if(hasArg(lwd)) lwd<-list(...)$lwd
+ else lwd<-if(is.null(tree$maps)) 1 else 2
+ # other optional arguments?
+ if(hasArg(axes)) axes<-list(...)$axes
+ else axes<-TRUE
+ if(hasArg(add)) add<-list(...)$add
+ else add<-FALSE
+ if(hasArg(pch)) pch<-list(...)$pch
+ else pch<-21
+ if(hasArg(bty)) bty<-list(...)$bty
+ else bty<-"o"
+ if(hasArg(las)) las<-list(...)$las
+ else las<-par()$las
+ # deprecate to logical label argument
+ label<-label[1]
+ if(label==TRUE||label==FALSE)
+ message("options for label have changed.\nNow choose \"radial\", \"horizontal\", or \"off\".")
+ if(label==TRUE) label<-"radial"
+ if(label==FALSE) label<-"off"
+ # do some bookkeeping
+ aa<-setNames(c(X[tree$tip.label,1],A[,1]),c(1:length(tree$tip.label),rownames(A)))
+ bb<-setNames(c(X[tree$tip.label,2],A[,2]),c(1:length(tree$tip.label),rownames(A)))
+ XX<-matrix(aa[as.character(tree$edge)],nrow(tree$edge),2)
+ YY<-matrix(bb[as.character(tree$edge)],nrow(tree$edge),2)
+ # plot projection
+ if(!add) plot(x=A[1,1],y=A[1,2],xlim=xlim,ylim=ylim,xlab=xlab,ylab=ylab,pch=16,cex=0.1,
+ col="white",axes=axes,frame.plot=TRUE,bty=bty,las=las)
+ if(is.null(tree$maps)){
+ for(i in 1:nrow(XX)) lines(XX[i,],YY[i,],col=con$col.edge[as.character(tree$edge[i,2])],
+ lwd=lwd)
+ } else {
+ for(i in 1:nrow(XX)){
+ xx<-tree$maps[[i]]/sum(tree$maps[[i]])*(XX[i,2]-XX[i,1])
+ yy<-tree$maps[[i]]/sum(tree$maps[[i]])*(YY[i,2]-YY[i,1])
+ cc<-names(tree$maps[[i]])
+ x<-XX[i,1]; y<-YY[i,1]
+ for(j in 1:length(xx)){
+ lines(c(x,x+xx[j]),c(y,y+yy[j]),col=colors[cc[j]],lwd=lwd)
+ x<-x+xx[j]; y<-y+yy[j]
+ }
+ }
+ if(node.by.map){
+ zz<-c(getStates(tree,type="tips"),getStates(tree))
+ names(zz)[1:length(tree$tip.label)]<-sapply(names(zz)[1:length(tree$tip.label)],
+ function(x,y) which(y==x),y=tree$tip.label)
+ con$col.node<-setNames(colors[zz],names(zz))
+ }
+ }
+ zz<-c(tree$edge[1,1],tree$edge[tree$edge[,2]>length(tree$tip.label),2])
+ points(c(XX[1,1],XX[tree$edge[,2]>length(tree$tip.label),2]),c(YY[1,1],
+ YY[tree$edge[,2]>length(tree$tip.label),2]),pch=pch,cex=node.size[1],
+ col=if(pch%in%c(1:20)) con$col.node[as.character(zz)] else "black",
+ bg=if(pch%in%c(21:25)) con$col.node[as.character(zz)] else NULL)
+ zz<-tree$edge[tree$edge[,2]<=length(tree$tip.label),2]
+ points(XX[tree$edge[,2]<=length(tree$tip.label),2],YY[tree$edge[,2]<=length(tree$tip.label),2],
+ pch=pch,cex=node.size[2],col=if(pch%in%c(1:20)) con$col.node[as.character(zz)] else "black",
+ bg=if(pch%in%c(21:25)) con$col.node[as.character(zz)] else NULL)
+ zz<-sapply(1:length(tree$tip.label),function(x,y) which(x==y),y=tree$edge[,2])
+ if(label!="off"){
+ asp<-(par()$usr[2]-par()$usr[1])/(par()$usr[4]-par()$usr[3])
+ for(i in 1:length(tree$tip.label)){
+ ii<-which(tree$edge[,2]==i)
+ aa<-atan(asp*(YY[ii,2]-YY[ii,1])/(XX[ii,2]-XX[ii,1]))/(2*pi)*360
+ adj<-if(XX[ii,2]<XX[ii,1]) c(1,0.25) else c(0,0.25)
+ tt<-if(XX[ii,2]<XX[ii,1]) paste(tree$tip.label[i]," ",sep="") else
+ paste(" ",tree$tip.label[i],sep="")
+ if(label=="radial") text(XX[ii,2],YY[ii,2],tt,cex=fsize,srt=aa,adj=adj,font=ftype)
+ else if(label=="horizontal") text(XX[ii,2],YY[ii,2],tt,cex=fsize,adj=adj,font=ftype)
+ }
+ } else adj<-0
+ xx<-setNames(c(XX[1,1],XX[,2]),c(tree$edge[1,1],tree$edge[,2]))
+ xx<-xx[order(as.numeric(names(xx)))]
+ yy<-setNames(c(YY[1,1],YY[,2]),c(tree$edge[1,1],tree$edge[,2]))
+ yy<-yy[order(as.numeric(names(yy)))]
+ PP<-list(type="phylomorphospace",use.edge.length=TRUE,node.pos=1,
+ show.tip.label=if(label!="off") TRUE else FALSE,show.node.label=FALSE,
+ font=ftype,cex=fsize,adj=adj,srt=NULL,no.margin=FALSE,label.offset=0,
+ x.lim=par()$usr[1:2],y.lim=par()$usr[3:4],
+ direction=NULL,tip.color="black",Ntip=Ntip(tree),Nnode=tree$Nnode,
+ edge=tree$edge,xx=xx,yy=yy)
+ assign("last_plot.phylo",PP,envir=.PlotPhyloEnv)
+}
+
+# function to expand a range
+# written by Liam J. Revell 2013
+expand<-function(x,factor=1.05){
+ rr<-x[2]-x[1]
+ mm<-mean(x)
+ x[1]<-mm-rr*factor/2
+ x[2]<-mm+rr*factor/2
+ return(x)
+}
+
diff --git a/R/phylomorphospace3d.R b/R/phylomorphospace3d.R
index a87b11d..350278d 100644
--- a/R/phylomorphospace3d.R
+++ b/R/phylomorphospace3d.R
@@ -1,95 +1,95 @@
-## phylomorphospace3d: projection of a tree into three dimensional morphospace
-## written by Liam J. Revell 2012, 2013, 2014, 2016, 2018
-
-phylomorphospace3d<-function(tree,X,A=NULL,label=TRUE,control=list(),method=c("dynamic","static"),...){
- method<-method[1]
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- # control list
- con=list(spin=TRUE,axes=TRUE,box=TRUE,simple.axes=FALSE,lwd=1,ftype="reg",
- col.edge=rep("black",nrow(tree$edge)))
- con[(namc<-names(control))]<-control
- if(con$simple.axes) con$box<-con$axes<-FALSE
- con$ftype<-which(c("off","reg","b","i","bi")==con$ftype)-1
- if(is.null(A)) A<-apply(X,2,function(x,tree) fastAnc(tree,x),tree=tree)
- else A<-A[as.character(1:tree$Nnode+length(tree$tip)),]
- x<-y<-z<-matrix(NA,nrow(tree$edge),2)
- X<-X[tree$tip.label,]
- for(i in 1:length(tree$tip)){
- x[tree$edge[,2]==i,2]<-X[i,1]
- y[tree$edge[,2]==i,2]<-X[i,2]
- z[tree$edge[,2]==i,2]<-X[i,3]
- }
- for(i in length(tree$tip)+1:tree$Nnode){
- x[tree$edge[,1]==i,1]<-x[tree$edge[,2]==i,2]<-A[as.character(i),1]
- y[tree$edge[,1]==i,1]<-y[tree$edge[,2]==i,2]<-A[as.character(i),2]
- z[tree$edge[,1]==i,1]<-z[tree$edge[,2]==i,2]<-A[as.character(i),3]
- }
- if(is.null(colnames(X))) colnames(X)<-c("x","y","z")
- if(method=="dynamic"){
- chk<-.check.pkg("rgl")
- if(!chk){
- cat(" method = \"dynamic\" requires the package \"rgl\"\n Defaulting to method = \"static\"\n\n")
- method<-"static"
- lines3d<-play3d<-plot3d<-segments3d<-spheres3d<-spin3d<-text3d<-function(...) NULL
- }
- }
- if(method=="dynamic"){
- params<-get("r3dDefaults")
- plot3d(rbind(X,A),xlab=colnames(X)[1],ylab=colnames(X)[2],zlab=colnames(X)[3],
- axes=con$axes,box=con$box,params=params)
- spheres3d(X,radius=0.02*mean(apply(X,2,max)-apply(X,2,min)))
- for(i in 1:nrow(tree$edge)) segments3d(x[i,],y[i,],z[i,],lwd=con$lwd,
- col=con$col.edge[i])
- ms<-colMeans(X)
- rs<-apply(rbind(X,A),2,range)
- if(con$simple.axes){
- lines3d(x=rs[,1],y=c(rs[1,2],rs[1,2]),z=c(rs[1,3],rs[1,3]))
- lines3d(x=c(rs[1,1],rs[1,1]),y=rs[,2],z=c(rs[1,3],rs[1,3]))
- lines3d(x=c(rs[1,1],rs[1,1]),y=c(rs[1,2],rs[1,2]),z=rs[,3])
- }
- rs<-rs[2,]-rs[1,]
- for(i in 1:length(tree$tip)){
- adj<-0.03*rs*(2*(X[i,]>ms)-1)
- if(con$ftype) text3d(X[i,]+adj,texts=tree$tip.label[i],font=con$ftype)
- }
- if(con$spin){
- xx<-spin3d(axis=c(0,0,1),rpm=10)
- play3d(xx,duration=5)
- invisible(xx)
- }
- else invisible(NULL)
- } else if(method=="static"){
- if(hasArg(angle)) angle<-list(...)$angle
- else angle<-30
- if(hasArg(xlim)) xlim<-list(...)$xlim
- else xlim<-NULL
- if(hasArg(ylim)) ylim<-list(...)$ylim
- else ylim<-NULL
- if(hasArg(zlim)) zlim<-list(...)$zlim
- else zlim=NULL
- xx<-scatterplot3d(X,xlab=colnames(X)[1],zlab=colnames(X)[3],pch=19,angle=angle,
- ylab=colnames(X)[2],cex.symbols=1.3,xlim=xlim,ylim=ylim,zlim=zlim)
- aa<-xx$xyz.convert(A)
- points(aa$x,aa$y,pch=19,cex=0.8)
- for(i in 1:nrow(tree$edge)){
- aa<-xx$xyz.convert(x[i,],y[i,],z[i,])
- lines(aa$x,aa$y,lwd=2,col=con$col.edge[i])
- }
- for(i in 1:length(tree$tip.label)){
- aa<-xx$xyz.convert(x[which(tree$edge[,2]==i),2],y[which(tree$edge[,2]==i),2],
- z[which(tree$edge[,2]==i),2])
- if(con$ftype) text(tree$tip.label[i],x=aa$x,y=aa$y,pos=2,font=con$ftype)
- }
- invisible(xx)
- }
-}
-
-## check for a package (modified from 'geiger')
-## primarily used for rgl
-## written by Liam J. Revell 2014, 2022
-.check.pkg<-function(pkg){
- if(pkg%in%rownames(installed.packages())){
- require(pkg,character.only=TRUE)
- return(TRUE)
- } else return(FALSE)
-}
+## phylomorphospace3d: projection of a tree into three dimensional morphospace
+## written by Liam J. Revell 2012, 2013, 2014, 2016, 2018
+
+phylomorphospace3d<-function(tree,X,A=NULL,label=TRUE,control=list(),method=c("dynamic","static"),...){
+ method<-method[1]
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ # control list
+ con=list(spin=TRUE,axes=TRUE,box=TRUE,simple.axes=FALSE,lwd=1,ftype="reg",
+ col.edge=rep("black",nrow(tree$edge)))
+ con[(namc<-names(control))]<-control
+ if(con$simple.axes) con$box<-con$axes<-FALSE
+ con$ftype<-which(c("off","reg","b","i","bi")==con$ftype)-1
+ if(is.null(A)) A<-apply(X,2,function(x,tree) fastAnc(tree,x),tree=tree)
+ else A<-A[as.character(1:tree$Nnode+length(tree$tip)),]
+ x<-y<-z<-matrix(NA,nrow(tree$edge),2)
+ X<-X[tree$tip.label,]
+ for(i in 1:length(tree$tip)){
+ x[tree$edge[,2]==i,2]<-X[i,1]
+ y[tree$edge[,2]==i,2]<-X[i,2]
+ z[tree$edge[,2]==i,2]<-X[i,3]
+ }
+ for(i in length(tree$tip)+1:tree$Nnode){
+ x[tree$edge[,1]==i,1]<-x[tree$edge[,2]==i,2]<-A[as.character(i),1]
+ y[tree$edge[,1]==i,1]<-y[tree$edge[,2]==i,2]<-A[as.character(i),2]
+ z[tree$edge[,1]==i,1]<-z[tree$edge[,2]==i,2]<-A[as.character(i),3]
+ }
+ if(is.null(colnames(X))) colnames(X)<-c("x","y","z")
+ if(method=="dynamic"){
+ chk<-.check.pkg("rgl")
+ if(!chk){
+ cat(" method = \"dynamic\" requires the package \"rgl\"\n Defaulting to method = \"static\"\n\n")
+ method<-"static"
+ lines3d<-play3d<-plot3d<-segments3d<-spheres3d<-spin3d<-text3d<-function(...) NULL
+ }
+ }
+ if(method=="dynamic"){
+ params<-get("r3dDefaults")
+ plot3d(rbind(X,A),xlab=colnames(X)[1],ylab=colnames(X)[2],zlab=colnames(X)[3],
+ axes=con$axes,box=con$box,params=params)
+ spheres3d(X,radius=0.02*mean(apply(X,2,max)-apply(X,2,min)))
+ for(i in 1:nrow(tree$edge)) segments3d(x[i,],y[i,],z[i,],lwd=con$lwd,
+ col=con$col.edge[i])
+ ms<-colMeans(X)
+ rs<-apply(rbind(X,A),2,range)
+ if(con$simple.axes){
+ lines3d(x=rs[,1],y=c(rs[1,2],rs[1,2]),z=c(rs[1,3],rs[1,3]))
+ lines3d(x=c(rs[1,1],rs[1,1]),y=rs[,2],z=c(rs[1,3],rs[1,3]))
+ lines3d(x=c(rs[1,1],rs[1,1]),y=c(rs[1,2],rs[1,2]),z=rs[,3])
+ }
+ rs<-rs[2,]-rs[1,]
+ for(i in 1:length(tree$tip)){
+ adj<-0.03*rs*(2*(X[i,]>ms)-1)
+ if(con$ftype) text3d(X[i,]+adj,texts=tree$tip.label[i],font=con$ftype)
+ }
+ if(con$spin){
+ xx<-spin3d(axis=c(0,0,1),rpm=10)
+ play3d(xx,duration=5)
+ invisible(xx)
+ }
+ else invisible(NULL)
+ } else if(method=="static"){
+ if(hasArg(angle)) angle<-list(...)$angle
+ else angle<-30
+ if(hasArg(xlim)) xlim<-list(...)$xlim
+ else xlim<-NULL
+ if(hasArg(ylim)) ylim<-list(...)$ylim
+ else ylim<-NULL
+ if(hasArg(zlim)) zlim<-list(...)$zlim
+ else zlim=NULL
+ xx<-scatterplot3d(X,xlab=colnames(X)[1],zlab=colnames(X)[3],pch=19,angle=angle,
+ ylab=colnames(X)[2],cex.symbols=1.3,xlim=xlim,ylim=ylim,zlim=zlim)
+ aa<-xx$xyz.convert(A)
+ points(aa$x,aa$y,pch=19,cex=0.8)
+ for(i in 1:nrow(tree$edge)){
+ aa<-xx$xyz.convert(x[i,],y[i,],z[i,])
+ lines(aa$x,aa$y,lwd=2,col=con$col.edge[i])
+ }
+ for(i in 1:length(tree$tip.label)){
+ aa<-xx$xyz.convert(x[which(tree$edge[,2]==i),2],y[which(tree$edge[,2]==i),2],
+ z[which(tree$edge[,2]==i),2])
+ if(con$ftype) text(tree$tip.label[i],x=aa$x,y=aa$y,pos=2,font=con$ftype)
+ }
+ invisible(xx)
+ }
+}
+
+## check for a package (modified from 'geiger')
+## primarily used for rgl
+## written by Liam J. Revell 2014, 2022
+.check.pkg<-function(pkg){
+ if(pkg%in%rownames(installed.packages())){
+ require(pkg,character.only=TRUE)
+ return(TRUE)
+ } else return(FALSE)
+}
diff --git a/R/phylosig.R b/R/phylosig.R
index 0d43143..36a8e28 100644
--- a/R/phylosig.R
+++ b/R/phylosig.R
@@ -1,294 +1,297 @@
-## function for computing phylogenetic signal by the lambda (Pagel 1999)
-## or K (Blomberg et al. 2003) methods
-## written by Liam J. Revell 2011/2012, 2019, 2020, 2021
-
-phylosig<-function(tree,x,method="K",test=FALSE,nsim=1000,
- se=NULL,start=NULL,control=list()){
- # some minor error checking
- if(!inherits(tree,"phylo"))
- stop("tree should be an object of class \"phylo\".")
- x<-matchDatatoTree(tree,x,"x")
- tree<-matchTreetoData(tree,x,"x")
- if(!is.null(se)){
- se<-matchDatatoTree(tree,se,"se")
- tree<-matchTreetoData(tree,se,"se")
- me=TRUE
- M<-diag(se^2)
- rownames(M)<-colnames(M)<-names(se)
- } else me=FALSE
- if(!is.null(start)&&!is.null(se)){
- if(start[1]<=0||start[2]<0||start[2]>maxLambda(tree)){
- message("some of the elements of 'start' are invalid, resetting to random")
- start<-NULL
- }
- }
- # done error handling
- if(method=="K"){
- C<-vcv.phylo(tree)
- x<-x[rownames(C)]
- n<-nrow(C)
- if(!me){
- invC<-solve(C)
- a<-sum(invC%*%x)/sum(invC)
- K<-(t(x-a)%*%(x-a)/(t(x-a)%*%invC%*%(x-a)))/((sum(diag(C))-
- n/sum(invC))/(n-1)) # calculate K
- if(!test){
- object<-as.numeric(K)
- } else {
- P=0.0
- simX<-x
- simK<-vector()
- for(i in 1:nsim){
- a<-sum(invC%*%simX)/sum(invC)
- simK[i]<-(t(simX-a)%*%(simX-a)/(t(simX-a)%*%invC%*%
- (simX-a)))/((sum(diag(C))-n/sum(invC))/(n-1))
- ## calculate P-value for randomization test
- if(simK[i]>=K) P<-P+1/nsim
- simX<-sample(simX) # randomize x
- }
- object<-list(K=as.numeric(K),P=P,sim.K=simK)
- }
- } else {
- likelihoodK<-function(theta,C,M,y){
- Ce<-theta*C+M
- invCe<-solve(Ce)
- a<-as.numeric(sum(invCe%*%y)/sum(invCe))
- logL<--t(y-a)%*%invCe%*%(y-a)/2-n*log(2*pi)/2-
- determinant(Ce,logarithm=TRUE)$modulus/2
- logL[1,1]
- }
- M<-M[rownames(C),colnames(C)]
- invC<-solve(C)
- maxSig2<-as.numeric(t(x-as.numeric(sum(invC%*%x)/
- sum(invC)))%*%invC%*%(x-as.numeric(sum(invC%*%x)/
- sum(invC)))/n)
- res<-optimize(f=likelihoodK,interval=c(0,maxSig2),y=x,
- C=C,M=M,maximum=TRUE) # optimize sig2
- sig2<-res$maximum*n/(n-1)
- Ce<-sig2*C+M
- invCe<-solve(Ce)
- a<-as.numeric(sum(invCe%*%x)/sum(invCe))
- K<-(t(x-a)%*%(x-a)/(t(x-a)%*%invCe%*%(x-a)))/((sum(diag(Ce))-
- n/sum(invCe))/(n-1)) # calculate K
- if(!test){
- object<-list(K=as.numeric(K),sig2=as.numeric(sig2),
- logL=res$objective,
- lik=function(sig2) likelihoodK(sig2,C=C,M=M,y=x))
- } else {
- P=0.0
- simX<-x
- simK<-vector()
- for(i in 1:nsim){
- maxSig2<-as.numeric(t(simX-as.numeric(sum(invC%*%
- simX)/sum(invC)))%*%invC%*%(simX-as.numeric(sum(invC%*%
- simX)/sum(invC)))/n)
- simRes<-optimize(f=likelihoodK,interval=c(0,maxSig2),y=simX,
- C=C,M=M,maximum=TRUE) # optimize sig2
- simSig2<-simRes$maximum*n/(n-1)
- Ce<-simSig2*C+M
- invCe<-solve(Ce)
- a<-as.numeric(sum(invCe%*%simX)/sum(invCe))
- # calculate K
- simK[i]<-(t(simX-a)%*%(simX-a)/(t(simX-a)%*%invCe%*%
- (simX-a)))/((sum(diag(Ce))-n/sum(invCe))/(n-1))
- # calculate P-value for randomization test
- if(simK[i]>=K) P<-P+1/nsim
- o<-sample(1:n)
- simX<-x[o]
- M<-diag(se[o]^2) # randomize x & errors
- }
- object<-list(K=as.numeric(K),P=P,sim.K=simK,
- sig2=as.numeric(sig2),logL=res$objective,
- lik=function(sig2) likelihoodK(sig2,C=C,M=M,y=x))
- }
- }
- } else if(method=="lambda"){
- # function to compute C with lambda
- lambda.transform<-function(C,lambda){
- dC<-diag(diag(C))
- C<-lambda*(C-dC)+dC
- C
- }
- # likelihood function
- likelihoodLambda<-function(theta,C,y){
- Cl<-lambda.transform(C,theta)
- invCl<-solve(Cl)
- n<-nrow(Cl)
- y<-y[rownames(Cl)]
- a<-as.numeric(sum(invCl%*%y)/sum(invCl))
- sig2<-as.numeric(t(y-a)%*%invCl%*%(y-a)/n)
- logL<--t(y-a)%*%(1/sig2*invCl)%*%(y-a)/2-n*log(2*pi)/2-
- determinant(sig2*Cl,logarithm=TRUE)$modulus/2
- logL[1,1]
- }
- # likelihood function with error
- likelihoodLambda.me<-function(theta,C,y,M){
- Cl<-theta[1]*lambda.transform(C,theta[2])
- V<-Cl+M
- invV<-solve(V)
- n<-nrow(Cl)
- y<-y[rownames(Cl)]
- a<-as.numeric(sum(invV%*%y)/sum(invV))
- logL<--t(y-a)%*%invV%*%(y-a)/2-n*log(2*pi)/2-
- determinant(V,logarithm=TRUE)$modulus/2
- logL[1,1]
- }
- C<-vcv.phylo(tree)
- x<-x[rownames(C)]
- maxlam<-maxLambda(tree)
- if(!me){
- res<-optimize(f=likelihoodLambda,interval=c(0,maxlam),
- y=x,C=C,maximum=TRUE) # optimize lambda
- if(!test){
- object<-list(lambda=res$maximum,logL=res$objective,
- lik=function(lambda) likelihoodLambda(lambda,
- C=C,y=x))
- } else {
- # compute likelihood of lambda=0
- logL0<-likelihoodLambda(theta=0,C=C,y=x)
- P<-as.numeric(pchisq(2*(res$objective-logL0),df=1,
- lower.tail=FALSE)) # P-value
- object<-list(lambda=res$maximum,logL=res$objective,
- logL0=logL0,P=P,lik=function(lambda)
- likelihoodLambda(lambda,C=C,y=x))
- }
- } else {
- control$fnscale=-1
- M<-M[rownames(C),colnames(C)]
- if(is.null(start)) s<-c(0.02*runif(n=1)*mean(pic(x,
- multi2di(tree,random=FALSE))^2),runif(n=1))
- else s<-start
- res<-optim(s,likelihoodLambda.me,C=C,y=x,M=M,
- method="L-BFGS-B",lower=c(0,0),upper=c(Inf,maxlam),
- control=control)
- if(!test){
- object<-list(lambda=res$par[2],sig2=res$par[1],
- logL=res$value,convergence=res$convergence,
- message=res$message,lik=function(lambda,
- sig2=res$par[1]) likelihoodLambda.me(c(sig2,lambda),
- C=C,M=M,y=x))
- } else {
- res0<-optim(c(s[1],0),likelihoodLambda.me,C=C,
- y=x,M=M,method="L-BFGS-B",lower=c(0,0),
- upper=c(Inf,1e-10),control=control)
- P<-as.numeric(pchisq(2*(res$value-res0$value),df=1,
- lower.tail=FALSE))
- object<-list(lambda=res$par[2],sig2=res$par[1],
- logL=res$value,convergence=res$convergence,
- message=res$message,logL0=res0$value,P=P,
- lik=function(lambda,sig2=res$par[1]) likelihoodLambda.me(c(sig2,
- lambda),C=C,M=M,y=x))
- }
- }
- } else
- stop(paste("do not recognize method = \"",method,
- "\"; methods are \"K\" and \"lambda\"",sep=""))
- attr(object,"class")<-"phylosig"
- attr(object,"method")<-method
- attr(object,"test")<-test
- attr(object,"se")<-!is.null(se)
- object
-}
-
-print.phylosig<-function(x,...){
- if(hasArg(digits)) digits<-list(...)$digits
- else digits<-6
- cat("\n")
- if(attr(x,"method")=="K"){
- if(attr(x,"test")||attr(x,"se")){
- cat(paste("Phylogenetic signal K :",signif(x$K,
- digits),"\n"))
- if(attr(x,"se")){
- cat(paste("MLE(sig2) :",signif(x$sig2,digits),
- "\n"))
- cat(paste("logL(sig2) :",signif(x$logL,digits),
- "\n"))
- }
- if(attr(x,"test"))
- cat(paste("P-value (based on",length(x$sim.K),
- "randomizations) :",signif(x$P,digits),"\n"))
- } else cat(paste("Phylogenetic signal K :",signif(x[1],
- digits),"\n"))
- } else if(attr(x,"method")=="lambda"){
- cat(paste("Phylogenetic signal lambda :",signif(x$lambda,
- digits),"\n"))
- cat(paste("logL(lambda) :",signif(x$logL,digits),"\n"))
- if(attr(x,"se")) cat(paste("MLE(sig2) :",signif(x$sig2,
- digits),"\n"))
- if(attr(x,"test")){
- cat(paste("LR(lambda=0) :",signif(2*(x$logL-x$logL0),
- digits),"\n"))
- cat(paste("P-value (based on LR test) :",signif(x$P,
- digits),"\n"))
- }
- }
- cat("\n")
-}
-
-plot.phylosig<-function(x,...){
- if(hasArg(what)) what<-list(...)$what
- else what<-if(attr(x,"method")=="lambda") "lambda" else
- if(attr(x,"method")=="K"&&attr(x,"test")) "K" else "sig2"
- if(hasArg(res)) res<-list(...)$res
- else res<-100
- if(hasArg(las)) las<-list(...)$las
- else las<-par()$las
- if(hasArg(cex.lab)) cex.lab<-list(...)$cex.lab*par()$cex
- else cex.lab<-par()$cex.lab
- if(hasArg(cex.axis)) cex.axis<-list(...)$cex.axis*par()$cex
- else cex.axis<-par()$cex.axis
- if(hasArg(bty)) bty<-list(...)$bty
- else bty<-par()$bty
- if(attr(x,"method")=="lambda"){
- lambda<-seq(0,max(c(1,x$lambda)),length.out=res)
- logL<-sapply(lambda,x$lik)
- plot(lambda,logL,xlab=expression(lambda),ylab="log(L)",
- type="l",bty=bty,las=las,cex.lab=cex.lab,cex.axis=cex.axis)
- lines(rep(x$lambda,2),c(par()$usr[3],x$logL),lty="dotted")
- text(x=x$lambda+0.01*diff(par()$usr[1:2]),
- par()$usr[3]+0.5*diff(par()$usr[3:4]),
- expression(paste("MLE(",lambda,")")),srt=90,adj=c(0.5,1))
- if(attr(x,"test")){
- lines(c(0,x$lambda),rep(x$logL0,2),lty="dotted")
- text(x=0.5*x$lambda,
- y=x$logL0+
- if(x$logL0>(par()$usr[3]+0.5*(diff(par()$usr[3:4]))))
- -0.01*diff(par()$usr[3:4])
- else 0.01*diff(par()$usr[3:4]),
- expression(paste("logL(",lambda,"=0)")),
- adj=if(x$logL0>(par()$usr[3]+0.5*(diff(par()$usr[3:4]))))
- c(0.5,1)
- else c(0.5,0))
- }
- } else if(attr(x,"method")=="K"){
- if(what=="K"){
- if(attr(x,"test")==FALSE)
- cat("Sorry. This is not a valid plotting option for your object.\n\n")
- else {
- hist(x$sim.K,breaks=min(c(max(12,round(length(x$sim.K)/10)),
- 20)),bty=bty,col="lightgrey",border="lightgrey",
- main="",xlab="K",ylab="null distribution of K",
- las=las,cex.lab=cex.lab,cex.axis=cex.axis)
- arrows(x0=x$K,y0=par()$usr[4],y1=0,length=0.12,
- col=make.transparent("blue",0.5),lwd=2)
- text(x$K,0.95*par()$usr[4],"observed value of K",
- pos=if(x$K>mean(range(x$sim.K))) 2 else 4)
- }
- } else if(what=="sig2"){
- if(attr(x,"se")==FALSE)
- cat("Sorry. This is not a valid plotting option for your object.\n\n")
- else {
- sig2<-seq(0.25*x$sig2,1.75*x$sig2,length.out=res)
- logL<-sapply(sig2,x$lik)
- plot(sig2,logL,xlab=expression(sigma^2),ylab="log(L)",
- type="l",bty=bty,las=las,cex.lab=cex.lab,
- cex.axis=cex.axis)
- lines(rep(x$sig2,2),c(par()$usr[3],x$logL),lty="dotted")
- text(x=x$sig2+0.01*diff(par()$usr[1:2]),
- par()$usr[3]+0.5*diff(par()$usr[3:4]),
- expression(paste("MLE(",sigma^2,")")),srt=90,
- adj=c(0.5,1))
- }
- }
- }
+## function for computing phylogenetic signal by the lambda (Pagel 1999)
+## or K (Blomberg et al. 2003) methods
+## written by Liam J. Revell 2011/2012, 2019, 2020, 2021, 2023
+
+phylosig<-function(tree,x,method="K",test=FALSE,nsim=1000,
+ se=NULL,start=NULL,control=list()){
+ # some minor error checking
+ if(!inherits(tree,"phylo"))
+ stop("tree should be an object of class \"phylo\".")
+ x<-matchDatatoTree(tree,x,"x")
+ tree<-matchTreetoData(tree,x,"x")
+ if(!is.null(se)){
+ se<-matchDatatoTree(tree,se,"se")
+ tree<-matchTreetoData(tree,se,"se")
+ me=TRUE
+ M<-diag(se^2)
+ rownames(M)<-colnames(M)<-names(se)
+ } else me=FALSE
+ if(!is.null(start)&&!is.null(se)){
+ if(start[1]<=0||start[2]<0||start[2]>maxLambda(tree)){
+ message("some of the elements of 'start' are invalid, resetting to random")
+ start<-NULL
+ }
+ }
+ # done error handling
+ if(method=="K"){
+ C<-vcv.phylo(tree)
+ x<-x[rownames(C)]
+ n<-nrow(C)
+ if(!me){
+ invC<-solve(C)
+ a<-sum(invC%*%x)/sum(invC)
+ K<-(t(x-a)%*%(x-a)/(t(x-a)%*%invC%*%(x-a)))/((sum(diag(C))-
+ n/sum(invC))/(n-1)) # calculate K
+ if(!test){
+ object<-as.numeric(K)
+ } else {
+ P=0.0
+ simX<-x
+ simK<-vector()
+ for(i in 1:nsim){
+ a<-sum(invC%*%simX)/sum(invC)
+ simK[i]<-(t(simX-a)%*%(simX-a)/(t(simX-a)%*%invC%*%
+ (simX-a)))/((sum(diag(C))-n/sum(invC))/(n-1))
+ ## calculate P-value for randomization test
+ if(simK[i]>=K) P<-P+1/nsim
+ simX<-sample(simX) # randomize x
+ }
+ object<-list(K=as.numeric(K),P=P,sim.K=simK)
+ }
+ } else {
+ likelihoodK<-function(theta,C,M,y){
+ Ce<-theta*C+M
+ invCe<-solve(Ce)
+ a<-as.numeric(sum(invCe%*%y)/sum(invCe))
+ logL<--t(y-a)%*%invCe%*%(y-a)/2-n*log(2*pi)/2-
+ determinant(Ce,logarithm=TRUE)$modulus/2
+ logL[1,1]
+ }
+ M<-M[rownames(C),colnames(C)]
+ invC<-solve(C)
+ maxSig2<-as.numeric(t(x-as.numeric(sum(invC%*%x)/
+ sum(invC)))%*%invC%*%(x-as.numeric(sum(invC%*%x)/
+ sum(invC)))/n)
+ res<-optimize(f=likelihoodK,interval=c(0,maxSig2),y=x,
+ C=C,M=M,maximum=TRUE) # optimize sig2
+ sig2<-res$maximum*n/(n-1)
+ Ce<-sig2*C+M
+ invCe<-solve(Ce)
+ a<-as.numeric(sum(invCe%*%x)/sum(invCe))
+ K<-(t(x-a)%*%(x-a)/(t(x-a)%*%invCe%*%(x-a)))/((sum(diag(Ce))-
+ n/sum(invCe))/(n-1)) # calculate K
+ if(!test){
+ object<-list(K=as.numeric(K),sig2=as.numeric(sig2),
+ logL=res$objective,
+ lik=function(sig2) likelihoodK(sig2,C=C,M=M,y=x))
+ } else {
+ P=0.0
+ simX<-x
+ simK<-vector()
+ for(i in 1:nsim){
+ maxSig2<-as.numeric(t(simX-as.numeric(sum(invC%*%
+ simX)/sum(invC)))%*%invC%*%(simX-as.numeric(sum(invC%*%
+ simX)/sum(invC)))/n)
+ simRes<-optimize(f=likelihoodK,interval=c(0,maxSig2),y=simX,
+ C=C,M=M,maximum=TRUE) # optimize sig2
+ simSig2<-simRes$maximum*n/(n-1)
+ Ce<-simSig2*C+M
+ invCe<-solve(Ce)
+ a<-as.numeric(sum(invCe%*%simX)/sum(invCe))
+ # calculate K
+ simK[i]<-(t(simX-a)%*%(simX-a)/(t(simX-a)%*%invCe%*%
+ (simX-a)))/((sum(diag(Ce))-n/sum(invCe))/(n-1))
+ # calculate P-value for randomization test
+ if(simK[i]>=K) P<-P+1/nsim
+ o<-sample(1:n)
+ simX<-x[o]
+ M<-diag(se[o]^2) # randomize x & errors
+ }
+ object<-list(K=as.numeric(K),P=P,sim.K=simK,
+ sig2=as.numeric(sig2),logL=res$objective,
+ lik=function(sig2) likelihoodK(sig2,C=C,M=M,y=x))
+ }
+ }
+ } else if(method=="lambda"){
+ # function to compute C with lambda
+ lambda.transform<-function(C,lambda){
+ dC<-diag(diag(C))
+ C<-lambda*(C-dC)+dC
+ C
+ }
+ # likelihood function
+ likelihoodLambda<-function(theta,C,y){
+ Cl<-lambda.transform(C,theta)
+ invCl<-solve(Cl)
+ n<-nrow(Cl)
+ y<-y[rownames(Cl)]
+ a<-as.numeric(sum(invCl%*%y)/sum(invCl))
+ sig2<-as.numeric(t(y-a)%*%invCl%*%(y-a)/n)
+ logL<--t(y-a)%*%(1/sig2*invCl)%*%(y-a)/2-n*log(2*pi)/2-
+ determinant(sig2*Cl,logarithm=TRUE)$modulus/2
+ logL[1,1]
+ }
+ # likelihood function with error
+ likelihoodLambda.me<-function(theta,C,y,M){
+ Cl<-theta[1]*lambda.transform(C,theta[2])
+ V<-Cl+M
+ invV<-solve(V)
+ n<-nrow(Cl)
+ y<-y[rownames(Cl)]
+ a<-as.numeric(sum(invV%*%y)/sum(invV))
+ logL<--t(y-a)%*%invV%*%(y-a)/2-n*log(2*pi)/2-
+ determinant(V,logarithm=TRUE)$modulus/2
+ logL[1,1]
+ }
+ C<-vcv.phylo(tree)
+ x<-x[rownames(C)]
+ maxlam<-maxLambda(tree)
+ if(!me){
+ res<-optimize(f=likelihoodLambda,interval=c(0,maxlam),
+ y=x,C=C,maximum=TRUE) # optimize lambda
+ if(!test){
+ object<-list(lambda=res$maximum,logL=res$objective,
+ lik=function(lambda) likelihoodLambda(lambda,
+ C=C,y=x))
+ } else {
+ # compute likelihood of lambda=0
+ logL0<-likelihoodLambda(theta=0,C=C,y=x)
+ P<-as.numeric(pchisq(2*(res$objective-logL0),df=1,
+ lower.tail=FALSE)) # P-value
+ object<-list(lambda=res$maximum,logL=res$objective,
+ logL0=logL0,P=P,lik=function(lambda)
+ likelihoodLambda(lambda,C=C,y=x))
+ }
+ } else {
+ control$fnscale=-1
+ M<-M[rownames(C),colnames(C)]
+ if(is.null(start)) s<-c(0.02*runif(n=1)*mean(pic(x,
+ multi2di(tree,random=FALSE))^2),runif(n=1))
+ else s<-start
+ res<-optim(s,likelihoodLambda.me,C=C,y=x,M=M,
+ method="L-BFGS-B",lower=c(0,0),upper=c(Inf,maxlam),
+ control=control)
+ if(!test){
+ object<-list(lambda=res$par[2],sig2=res$par[1],
+ logL=res$value,convergence=res$convergence,
+ message=res$message,lik=function(lambda,
+ sig2=res$par[1]) likelihoodLambda.me(c(sig2,lambda),
+ C=C,M=M,y=x))
+ } else {
+ res0<-optim(c(s[1],0),likelihoodLambda.me,C=C,
+ y=x,M=M,method="L-BFGS-B",lower=c(0,0),
+ upper=c(Inf,1e-10),control=control)
+ P<-as.numeric(pchisq(2*(res$value-res0$value),df=1,
+ lower.tail=FALSE))
+ object<-list(lambda=res$par[2],sig2=res$par[1],
+ logL=res$value,convergence=res$convergence,
+ message=res$message,logL0=res0$value,P=P,
+ lik=function(lambda,sig2=res$par[1]) likelihoodLambda.me(c(sig2,
+ lambda),C=C,M=M,y=x))
+ }
+ }
+ } else
+ stop(paste("do not recognize method = \"",method,
+ "\"; methods are \"K\" and \"lambda\"",sep=""))
+ attr(object,"class")<-"phylosig"
+ attr(object,"method")<-method
+ attr(object,"test")<-test
+ attr(object,"se")<-!is.null(se)
+ object
+}
+
+print.phylosig<-function(x,...){
+ if(hasArg(digits)) digits<-list(...)$digits
+ else digits<-6
+ cat("\n")
+ if(attr(x,"method")=="K"){
+ if(attr(x,"test")||attr(x,"se")){
+ cat(paste("Phylogenetic signal K :",signif(x$K,
+ digits),"\n"))
+ if(attr(x,"se")){
+ cat(paste("MLE(sig2) :",signif(x$sig2,digits),
+ "\n"))
+ cat(paste("logL(sig2) :",signif(x$logL,digits),
+ "\n"))
+ }
+ if(attr(x,"test"))
+ cat(paste("P-value (based on",length(x$sim.K),
+ "randomizations) :",signif(x$P,digits),"\n"))
+ } else cat(paste("Phylogenetic signal K :",signif(x[1],
+ digits),"\n"))
+ } else if(attr(x,"method")=="lambda"){
+ cat(paste("Phylogenetic signal lambda :",signif(x$lambda,
+ digits),"\n"))
+ cat(paste("logL(lambda) :",signif(x$logL,digits),"\n"))
+ if(attr(x,"se")) cat(paste("MLE(sig2) :",signif(x$sig2,
+ digits),"\n"))
+ if(attr(x,"test")){
+ cat(paste("LR(lambda=0) :",signif(2*(x$logL-x$logL0),
+ digits),"\n"))
+ cat(paste("P-value (based on LR test) :",signif(x$P,
+ digits),"\n"))
+ }
+ }
+ cat("\n")
+}
+
+plot.phylosig<-function(x,...){
+ if(hasArg(what)) what<-list(...)$what
+ else what<-if(attr(x,"method")=="lambda") "lambda" else
+ if(attr(x,"method")=="K"&&attr(x,"test")) "K" else "sig2"
+ if(hasArg(res)) res<-list(...)$res
+ else res<-100
+ if(hasArg(las)) las<-list(...)$las
+ else las<-par()$las
+ if(hasArg(cex.lab)) cex.lab<-list(...)$cex.lab*par()$cex
+ else cex.lab<-par()$cex.lab
+ if(hasArg(cex.axis)) cex.axis<-list(...)$cex.axis*par()$cex
+ else cex.axis<-par()$cex.axis
+ if(hasArg(bty)) bty<-list(...)$bty
+ else bty<-par()$bty
+ if(hasArg(xlim)) xlim<-list(...)$xlim
+ else xlim<-NULL
+ if(attr(x,"method")=="lambda"){
+ lambda<-seq(0,max(c(1,x$lambda)),length.out=res)
+ logL<-sapply(lambda,x$lik)
+ plot(lambda,logL,xlab=expression(lambda),ylab="log(L)",
+ type="l",bty=bty,las=las,cex.lab=cex.lab,cex.axis=cex.axis,
+ xlim=xlim)
+ lines(rep(x$lambda,2),c(par()$usr[3],x$logL),lty="dotted")
+ text(x=x$lambda+0.01*diff(par()$usr[1:2]),
+ par()$usr[3]+0.5*diff(par()$usr[3:4]),
+ expression(paste("MLE(",lambda,")")),srt=90,adj=c(0.5,1))
+ if(attr(x,"test")){
+ lines(c(0,x$lambda),rep(x$logL0,2),lty="dotted")
+ text(x=0.5*x$lambda,
+ y=x$logL0+
+ if(x$logL0>(par()$usr[3]+0.5*(diff(par()$usr[3:4]))))
+ -0.01*diff(par()$usr[3:4])
+ else 0.01*diff(par()$usr[3:4]),
+ expression(paste("logL(",lambda,"=0)")),
+ adj=if(x$logL0>(par()$usr[3]+0.5*(diff(par()$usr[3:4]))))
+ c(0.5,1)
+ else c(0.5,0))
+ }
+ } else if(attr(x,"method")=="K"){
+ if(what=="K"){
+ if(attr(x,"test")==FALSE)
+ cat("Sorry. This is not a valid plotting option for your object.\n\n")
+ else {
+ hist(x$sim.K,breaks=min(c(max(12,round(length(x$sim.K)/10)),
+ 20)),bty=bty,col="lightgrey",border="lightgrey",
+ main="",xlab="K",ylab="null distribution of K",
+ las=las,cex.lab=cex.lab,cex.axis=cex.axis)
+ arrows(x0=x$K,y0=par()$usr[4],y1=0,length=0.12,
+ col=make.transparent("blue",0.5),lwd=2)
+ text(x$K,0.95*par()$usr[4],"observed value of K",
+ pos=if(x$K>mean(range(x$sim.K))) 2 else 4)
+ }
+ } else if(what=="sig2"){
+ if(attr(x,"se")==FALSE)
+ cat("Sorry. This is not a valid plotting option for your object.\n\n")
+ else {
+ sig2<-seq(0.25*x$sig2,1.75*x$sig2,length.out=res)
+ logL<-sapply(sig2,x$lik)
+ plot(sig2,logL,xlab=expression(sigma^2),ylab="log(L)",
+ type="l",bty=bty,las=las,cex.lab=cex.lab,
+ cex.axis=cex.axis,xlim=xlim)
+ lines(rep(x$sig2,2),c(par()$usr[3],x$logL),lty="dotted")
+ text(x=x$sig2+0.01*diff(par()$usr[1:2]),
+ par()$usr[3]+0.5*diff(par()$usr[3:4]),
+ expression(paste("MLE(",sigma^2,")")),srt=90,
+ adj=c(0.5,1))
+ }
+ }
+ }
}
\ No newline at end of file
diff --git a/R/plotBranchbyTrait.R b/R/plotBranchbyTrait.R
index c99c1c2..ca86400 100644
--- a/R/plotBranchbyTrait.R
+++ b/R/plotBranchbyTrait.R
@@ -1,332 +1,332 @@
-## function to plot probability or trait value by branch
-## written by Liam J. Revell 2013, 2014, 2016, 2020
-
-plotBranchbyTrait<-function(tree,x,mode=c("edges","tips","nodes"),palette="rainbow",
- legend=TRUE,xlims=NULL,...){
- mode<-mode[1]
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- if(mode=="tips"){
- x<-c(x[tree$tip.label],fastAnc(tree,x))
- names(x)[1:length(tree$tip.label)]<-1:length(tree$tip.label)
- XX<-matrix(x[tree$edge],nrow(tree$edge),2)
- x<-rowMeans(XX)
- } else if(mode=="nodes"){
- XX<-matrix(x[tree$edge],nrow(tree$edge),2)
- x<-rowMeans(XX)
- }
- # begin optional arguments
- if(hasArg(tol)) tol<-list(...)$tol
- else tol<-1e-6
- if(hasArg(prompt)) prompt<-list(...)$prompt
- else prompt<-FALSE
- if(hasArg(type)) type<-list(...)$type
- else type<-"phylogram"
- if(hasArg(show.tip.label)) show.tip.label<-list(...)$show.tip.label
- else show.tip.label<-TRUE
- if(hasArg(show.node.label)) show.node.label<-list(...)$show.node.label
- else show.node.label<-FALSE
- if(hasArg(edge.width)) edge.width<-list(...)$edge.width
- else edge.width<-4
- if(hasArg(edge.lty)) edge.lty<-list(...)$edge.lty
- else edge.lty<-1
- if(hasArg(font)) font<-list(...)$font
- else font<-3
- if(hasArg(cex)) cex<-list(...)$cex
- else cex<-par("cex")
- if(length(cex)==1) cex<-rep(cex,2)
- if(hasArg(adj)) adj<-list(...)$adj
- else adj<-NULL
- if(hasArg(srt)) srt<-list(...)$srt
- else srt<-0
- if(hasArg(no.margin)) no.margin<-list(...)$no.margin
- else no.margin<-TRUE
- if(hasArg(root.edge)) root.edge<-list(...)$root.edge
- else root.edge<-FALSE
- if(hasArg(label.offset)) label.offset<-list(...)$label.offset
- else label.offset<-0.01*max(nodeHeights(tree))
- if(hasArg(underscore)) underscore<-list(...)$underscore
- else underscore<-FALSE
- if(hasArg(x.lim)) x.lim<-list(...)$x.lim
- else x.lim<-NULL
- if(hasArg(y.lim)) y.lim<-list(...)$y.lim
- else y.lim<-if(legend&&!prompt&&type%in%c("phylogram","cladogram"))
- c(1-0.06*length(tree$tip.label),length(tree$tip.label)) else NULL
- if(hasArg(direction)) direction<-list(...)$direction
- else direction<-"rightwards"
- if(hasArg(lab4ut)) lab4ut<-list(...)$lab4ut
- else lab4ut<-NULL
- if(hasArg(tip.color)) tip.color<-list(...)$tip.color
- else tip.color<-"black"
- if(hasArg(plot)) plot<-list(...)$plot
- else plot<-TRUE
- if(hasArg(rotate.tree)) rotate.tree<-list(...)$rotate.tree
- else rotate.tree<-0
- if(hasArg(open.angle)) open.angle<-list(...)$open.angle
- else open.angle<-0
- # end optional arguments
- if(is.function(palette)) cols<-palette(n=1000)
- else {
- if(palette=="heat.colors") cols<-heat.colors(n=1000)
- if(palette=="gray") cols<-gray(1000:1/1000)
- if(palette=="rainbow") cols<-rainbow(1000,start=0.7,end=0) # blue->red
- }
- if(is.null(xlims)) xlims<-range(x)+c(-tol,tol)
- breaks<-0:1000/1000*(xlims[2]-xlims[1])+xlims[1]
- whichColor<-function(p,cols,breaks){
- i<-1
- while(p>=breaks[i]&&p>breaks[i+1]) i<-i+1
- cols[i]
- }
- colors<-sapply(x,whichColor,cols=cols,breaks=breaks)
- par(lend=2)
- # now plot
- xx<-plot.phylo(tree,type=type,show.tip.label=show.tip.label,show.node.label=show.node.label,
- edge.color=colors,edge.width=edge.width,edge.lty=edge.lty,font=font,cex=cex[1],adj=adj,
- srt=srt,no.margin=no.margin,root.edge=root.edge,label.offset=label.offset,
- underscore=underscore,x.lim=x.lim,y.lim=y.lim,direction=direction,lab4ut=lab4ut,
- tip.color=tip.color,plot=plot,rotate.tree=rotate.tree,open.angle=open.angle,lend=2,
- new=FALSE)
- if(legend==TRUE&&is.logical(legend)) legend<-round(0.3*max(nodeHeights(tree)),2)
- if(legend){
- if(hasArg(title)) title<-list(...)$title
- else title<-"trait value"
- if(hasArg(digits)) digits<-list(...)$digits
- else digits<-1
- if(prompt) add.color.bar(legend,cols,title,xlims,digits,prompt=TRUE,fsize=cex[2])
- else add.color.bar(legend,cols,title,xlims,digits,prompt=FALSE,
- x=par()$usr[1]+0.05*(par()$usr[2]-par()$usr[1]),
- y=par()$usr[3]+0.05*(par()$usr[4]-par()$usr[3]),fsize=cex[2])
- }
- invisible(xx)
-}
-
-# function to add color bar
-# written by Liam J. Revell 2013, 2015, 2016
-
-add.color.bar<-function(leg,cols,title=NULL,lims=c(0,1),digits=1,prompt=TRUE,lwd=4,outline=TRUE,...){
- if(prompt){
- cat("Click where you want to draw the bar\n")
- flush.console()
- x<-unlist(locator(1))
- y<-x[2]
- x<-x[1]
- } else {
- if(hasArg(x)) x<-list(...)$x
- else x<-0
- if(hasArg(y)) y<-list(...)$y
- else y<-0
- }
- if(hasArg(fsize)) fsize<-list(...)$fsize
- else fsize<-1.0
- if(hasArg(subtitle)) subtitle<-list(...)$subtitle
- else subtitle<-NULL
- if(hasArg(direction)) direction<-list(...)$direction
- else direction<-"rightwards"
- if(direction%in%c("rightwards","leftwards")){
- X<-x+cbind(0:(length(cols)-1)/length(cols),1:length(cols)/length(cols))*(leg)
- if(direction=="leftwards"){
- X<-X[nrow(X):1,]
- if(!is.null(lims)) lims<-lims[2:1]
- }
- Y<-cbind(rep(y,length(cols)),rep(y,length(cols)))
- } else if(direction%in%c("upwards","downwards")){
- Y<-y+cbind(0:(length(cols)-1)/length(cols),1:length(cols)/length(cols))*(leg)
- if(direction=="downwards"){
- X<-X[nrow(X):1,]
- if(!is.null(lims)) lims<-lims[2:1]
- }
- X<-cbind(rep(x,length(cols)),rep(x,length(cols)))
- }
- if(outline) lines(c(X[1,1],X[nrow(X),2]),c(Y[1,1],Y[nrow(Y),2]),lwd=lwd+2,lend=2)
- for(i in 1:length(cols)) lines(X[i,],Y[i,],col=cols[i],lwd=lwd,lend=2)
- if(direction%in%c("rightwards","leftwards")){
- if(!is.null(lims)) text(x=x,y=y,
- round(lims[1],digits),pos=3,cex=fsize)
- if(!is.null(lims)) text(x=x+leg,y=y,
- round(lims[2],digits),pos=3,cex=fsize)
- if(is.null(title)) title<-"P(state=1)"
- text(x=(2*x+leg)/2,y=y,title,pos=3,cex=fsize)
- if(is.null(subtitle))
- text(x=(2*x+leg)/2,y=y,paste("length=",round(leg,3),sep=""),pos=1,cex=fsize)
- else text(x=(2*x+leg)/2,y=y,subtitle,pos=1,cex=fsize)
- } else if(direction%in%c("upwards","downwards")){
- if(!is.null(lims)) text(x=x,y=y-0.02*diff(par()$usr[3:4]),round(lims[1],digits),
- pos=1,cex=fsize)
- if(!is.null(lims)) text(x=x,y=y+leg+0.02*diff(par()$usr[3:4]),
- round(lims[2],digits),
- pos=3,cex=fsize)
- if(is.null(title)) title<-"P(state=1)"
- text(x=x-0.04*diff(par()$usr[1:2]),y=(2*y+leg)/2,title,
- pos=3,cex=fsize,srt=90)
- if(is.null(subtitle))
- text(x=x+0.04*diff(par()$usr[1:2]),y=(2*y+leg)/2,
- paste("length=",round(leg,3),sep=""),pos=1,
- srt=90,cex=fsize)
- else text(x=x+0.04*diff(par()$usr[1:2]),y=(2*y+leg)/2,
- subtitle,pos=1,cex=fsize,srt=90)
- }
-}
-
-## function to create "edge.widthMap" object
-edge.widthMap<-function(tree,x,...){
- if(!inherits(tree,"phylo"))
- stop("tree should be an object of class \"phylo\".")
- tree<-as.phylo(tree)
- a<-fastAnc(tree,x)
- node.values<-c(x[tree$tip.label],a)
- edge.values<-apply(tree$edge,1,function(e,nv)
- mean(nv[e]),nv=node.values)
- edge.widths<-edge.values
- object<-list(tree=tree,edge.widths=edge.widths,
- node.values=node.values)
- class(object)<-"edge.widthMap"
- object
-}
-
-## print method
-print.edge.widthMap<-function(x,...){
- cat("Object of class \"edge.widthMap\" containing:\n")
- cat(paste("(1) Phylogenetic tree with",Ntip(x$tree),
- "tips and",x$tree$Nnode,"internal nodes.\n"))
- cat("(2) Vector of node values for a mapped quantitative\n")
- cat(" trait.\n\n")
-}
-
-## plot method
-plot.edge.widthMap<-function(x,max.width=0.9,legend="trait value",...){
- if(hasArg(min.width)) min.width<-list(...)$min.width
- else min.width<-0
- if(hasArg(vertical.as.polygon))
- vertical.as.polygon<-list(...)$vertical.as.polygon
- else vertical.as.polygon<-TRUE
- if(hasArg(lwd)) lwd<-list(...)$lwd
- else lwd<-2
- h<-max(nodeHeights(x$tree))
- node.values<-x$node.values-min(x$node.values)
- node.values<-node.values*((max.width-min.width)/
- max(node.values))+min.width
- args.list<-list(...)
- args.list$tree<-x$tree
- args.list$type<-"phylogram"
- if(!is.null(args.list$direction)){
- if(!args.list$direction%in%c("leftwards","rightwards"))
- args.list$direction<-"rightwards"
- } else args.list$direction<-"rightwards"
- if(is.null(args.list$ylim))
- args.list$ylim<-c(1,Ntip(x$tree)+Ntip(x$tree)/25)
- if(is.null(args.list$ftype)) args.list$ftype<-"i"
- if(is.null(args.list$fsize))
- args.list$fsize<-36*par()$pin[2]/par()$pin[1]/
- Ntip(x$tree)
- if(is.null(args.list$color)){
- args.list$color<-"transparent"
- color<-"gray62"
- } else {
- color<-args.list$color
- args.list$color<-"transparent"
- }
- if(is.null(args.list$border)){
- border<-color
- } else {
- border<-args.list$border
- args.list$border<-NULL
- }
- do.call(plotTree,args.list)
- obj<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- asp<-par()$pin[2]/par()$pin[1]/
- (diff(par()$usr[4:3])/diff(par()$usr[2:1]))
- for(i in 1:nrow(x$tree$edge)){
- if(vertical.as.polygon){
- xx<-obj$xx[c(x$tree$edge[i,1],
- x$tree$edge[i,1:2],
- x$tree$edge[i,2:1],
- x$tree$edge[i,1])]+c(0,
- asp*node.values[x$tree$edge[i,1]]/2,
- 0,0,asp*node.values[x$tree$edge[i,1]]/2,0)
- yy<-rep(obj$yy[x$tree$edge[i,2]],6)+
- c(node.values[x$tree$edge[i,1]],
- node.values[x$tree$edge[i,1:2]],
- -node.values[x$tree$edge[i,2:1]],
- -node.values[x$tree$edge[i,1]])/2
- }
- else {
- xx<-obj$xx[c(x$tree$edge[i,1:2],
- x$tree$edge[i,2:1])]
- yy<-rep(obj$yy[x$tree$edge[i,2]],4)+
- c(node.values[x$tree$edge[i,1:2]],
- -node.values[x$tree$edge[i,2:1]])/2
- }
- polygon(x=crop.to.h(xx,h),y=yy,
- border=border,col=color,lwd=lwd)
- }
- for(i in 1:x$tree$Nnode+Ntip(x$tree)){
- nn<-x$tree$edge[which(x$tree$edge[,1]==i),2]
- yy<-range(obj$yy[nn])
- if(vertical.as.polygon){
- xx<-rep(obj$xx[i],4)+
- asp*c(-node.values[i]/2,node.values[i]/2,
- node.values[i]/2,-node.values[i]/2)
- polygon(x=crop.to.h(xx,h),
- y=c(rep(yy[1],2),rep(yy[2],2))+
- c(-rep(node.values[i],2),
- rep(node.values[i],2))/2,
- border=border,col=color,lwd=lwd)
- } else {
- lines(rep(obj$xx[i],2),yy+c(-node.values[i],
- node.values[i])/2,lend=2,col=border,
- lwd=lwd)
- }
- }
- if(border!=color&&vertical.as.polygon){
- for(i in 1:nrow(x$tree$edge)){
- xx<-obj$xx[c(x$tree$edge[i,1],
- x$tree$edge[i,1:2],
- x$tree$edge[i,2:1],
- x$tree$edge[i,1])]+c(0,
- asp*node.values[x$tree$edge[i,1]]/2,
- 0,0,asp*node.values[x$tree$edge[i,1]]/2,0)
- yy<-rep(obj$yy[x$tree$edge[i,2]],6)+
- c(node.values[x$tree$edge[i,1]],
- node.values[x$tree$edge[i,1:2]],
- -node.values[x$tree$edge[i,2:1]],
- -node.values[x$tree$edge[i,1]])/2
- polygon(x=crop.to.h(xx,h),y=yy,
- border=FALSE,col=color)
- }
- for(i in 1:x$tree$Nnode+Ntip(x$tree)){
- nn<-x$tree$edge[which(x$tree$edge[,1]==i),2]
- yy<-range(obj$yy[nn])
- xx<-rep(obj$xx[i],4)+
- asp*c(-node.values[i]/2,node.values[i]/2,
- node.values[i]/2,-node.values[i]/2)
- polygon(x=crop.to.h(xx,h),
- y=c(rep(yy[1],2),rep(yy[2],2))+
- c(-rep(node.values[i],2),
- rep(node.values[i],2))/2,
- border=FALSE,col=color)
- }
- }
- leg.length<-0.4*h
- x.adj<-if(obj$direction=="rightwards") 0 else obj$x.lim[2]-leg.length
- polygon(x=c(0,0,leg.length,leg.length)+x.adj,
- y=Ntip(x$tree)+Ntip(x$tree)/25+
- c(-min.width/2,min.width/2,max(node.values)/2,
- -max(node.values)/2),
- border=border,col=color,lwd=lwd)
- if(border!=color)
- polygon(x=c(0,0,leg.length,leg.length)+x.adj,
- y=Ntip(x$tree)+Ntip(x$tree)/25+
- c(-min.width/2,min.width/2,max(node.values)/2,
- -max(node.values)/2),
- border=FALSE,col=color)
- text(0+x.adj,Ntip(x$tree)+Ntip(x$tree)/25-0.2*max.width,
- round(min(x$node.values),2),pos=1,
- cex=0.8)
- text(leg.length+x.adj,Ntip(x$tree)+Ntip(x$tree)/25-0.2*max.width,
- round(max(x$node.values),2),pos=1,cex=0.8)
- text(leg.length/2+x.adj,Ntip(x$tree)+Ntip(x$tree)/25-0.2*max.width,
- legend,pos=1,cex=0.8)
-
-}
-
+## function to plot probability or trait value by branch
+## written by Liam J. Revell 2013, 2014, 2016, 2020
+
+plotBranchbyTrait<-function(tree,x,mode=c("edges","tips","nodes"),palette="rainbow",
+ legend=TRUE,xlims=NULL,...){
+ mode<-mode[1]
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ if(mode=="tips"){
+ x<-c(x[tree$tip.label],fastAnc(tree,x))
+ names(x)[1:length(tree$tip.label)]<-1:length(tree$tip.label)
+ XX<-matrix(x[tree$edge],nrow(tree$edge),2)
+ x<-rowMeans(XX)
+ } else if(mode=="nodes"){
+ XX<-matrix(x[tree$edge],nrow(tree$edge),2)
+ x<-rowMeans(XX)
+ }
+ # begin optional arguments
+ if(hasArg(tol)) tol<-list(...)$tol
+ else tol<-1e-6
+ if(hasArg(prompt)) prompt<-list(...)$prompt
+ else prompt<-FALSE
+ if(hasArg(type)) type<-list(...)$type
+ else type<-"phylogram"
+ if(hasArg(show.tip.label)) show.tip.label<-list(...)$show.tip.label
+ else show.tip.label<-TRUE
+ if(hasArg(show.node.label)) show.node.label<-list(...)$show.node.label
+ else show.node.label<-FALSE
+ if(hasArg(edge.width)) edge.width<-list(...)$edge.width
+ else edge.width<-4
+ if(hasArg(edge.lty)) edge.lty<-list(...)$edge.lty
+ else edge.lty<-1
+ if(hasArg(font)) font<-list(...)$font
+ else font<-3
+ if(hasArg(cex)) cex<-list(...)$cex
+ else cex<-par("cex")
+ if(length(cex)==1) cex<-rep(cex,2)
+ if(hasArg(adj)) adj<-list(...)$adj
+ else adj<-NULL
+ if(hasArg(srt)) srt<-list(...)$srt
+ else srt<-0
+ if(hasArg(no.margin)) no.margin<-list(...)$no.margin
+ else no.margin<-TRUE
+ if(hasArg(root.edge)) root.edge<-list(...)$root.edge
+ else root.edge<-FALSE
+ if(hasArg(label.offset)) label.offset<-list(...)$label.offset
+ else label.offset<-0.01*max(nodeHeights(tree))
+ if(hasArg(underscore)) underscore<-list(...)$underscore
+ else underscore<-FALSE
+ if(hasArg(x.lim)) x.lim<-list(...)$x.lim
+ else x.lim<-NULL
+ if(hasArg(y.lim)) y.lim<-list(...)$y.lim
+ else y.lim<-if(legend&&!prompt&&type%in%c("phylogram","cladogram"))
+ c(1-0.06*length(tree$tip.label),length(tree$tip.label)) else NULL
+ if(hasArg(direction)) direction<-list(...)$direction
+ else direction<-"rightwards"
+ if(hasArg(lab4ut)) lab4ut<-list(...)$lab4ut
+ else lab4ut<-NULL
+ if(hasArg(tip.color)) tip.color<-list(...)$tip.color
+ else tip.color<-"black"
+ if(hasArg(plot)) plot<-list(...)$plot
+ else plot<-TRUE
+ if(hasArg(rotate.tree)) rotate.tree<-list(...)$rotate.tree
+ else rotate.tree<-0
+ if(hasArg(open.angle)) open.angle<-list(...)$open.angle
+ else open.angle<-0
+ # end optional arguments
+ if(is.function(palette)) cols<-palette(n=1000)
+ else {
+ if(palette=="heat.colors") cols<-heat.colors(n=1000)
+ if(palette=="gray") cols<-gray(1000:1/1000)
+ if(palette=="rainbow") cols<-rainbow(1000,start=0.7,end=0) # blue->red
+ }
+ if(is.null(xlims)) xlims<-range(x)+c(-tol,tol)
+ breaks<-0:1000/1000*(xlims[2]-xlims[1])+xlims[1]
+ whichColor<-function(p,cols,breaks){
+ i<-1
+ while(p>=breaks[i]&&p>breaks[i+1]) i<-i+1
+ cols[i]
+ }
+ colors<-sapply(x,whichColor,cols=cols,breaks=breaks)
+ par(lend=2)
+ # now plot
+ xx<-plot.phylo(tree,type=type,show.tip.label=show.tip.label,show.node.label=show.node.label,
+ edge.color=colors,edge.width=edge.width,edge.lty=edge.lty,font=font,cex=cex[1],adj=adj,
+ srt=srt,no.margin=no.margin,root.edge=root.edge,label.offset=label.offset,
+ underscore=underscore,x.lim=x.lim,y.lim=y.lim,direction=direction,lab4ut=lab4ut,
+ tip.color=tip.color,plot=plot,rotate.tree=rotate.tree,open.angle=open.angle,lend=2,
+ new=FALSE)
+ if(legend==TRUE&&is.logical(legend)) legend<-round(0.3*max(nodeHeights(tree)),2)
+ if(legend){
+ if(hasArg(title)) title<-list(...)$title
+ else title<-"trait value"
+ if(hasArg(digits)) digits<-list(...)$digits
+ else digits<-1
+ if(prompt) add.color.bar(legend,cols,title,xlims,digits,prompt=TRUE,fsize=cex[2])
+ else add.color.bar(legend,cols,title,xlims,digits,prompt=FALSE,
+ x=par()$usr[1]+0.05*(par()$usr[2]-par()$usr[1]),
+ y=par()$usr[3]+0.05*(par()$usr[4]-par()$usr[3]),fsize=cex[2])
+ }
+ invisible(xx)
+}
+
+# function to add color bar
+# written by Liam J. Revell 2013, 2015, 2016
+
+add.color.bar<-function(leg,cols,title=NULL,lims=c(0,1),digits=1,prompt=TRUE,lwd=4,outline=TRUE,...){
+ if(prompt){
+ cat("Click where you want to draw the bar\n")
+ flush.console()
+ x<-unlist(locator(1))
+ y<-x[2]
+ x<-x[1]
+ } else {
+ if(hasArg(x)) x<-list(...)$x
+ else x<-0
+ if(hasArg(y)) y<-list(...)$y
+ else y<-0
+ }
+ if(hasArg(fsize)) fsize<-list(...)$fsize
+ else fsize<-1.0
+ if(hasArg(subtitle)) subtitle<-list(...)$subtitle
+ else subtitle<-NULL
+ if(hasArg(direction)) direction<-list(...)$direction
+ else direction<-"rightwards"
+ if(direction%in%c("rightwards","leftwards")){
+ X<-x+cbind(0:(length(cols)-1)/length(cols),1:length(cols)/length(cols))*(leg)
+ if(direction=="leftwards"){
+ X<-X[nrow(X):1,]
+ if(!is.null(lims)) lims<-lims[2:1]
+ }
+ Y<-cbind(rep(y,length(cols)),rep(y,length(cols)))
+ } else if(direction%in%c("upwards","downwards")){
+ Y<-y+cbind(0:(length(cols)-1)/length(cols),1:length(cols)/length(cols))*(leg)
+ if(direction=="downwards"){
+ X<-X[nrow(X):1,]
+ if(!is.null(lims)) lims<-lims[2:1]
+ }
+ X<-cbind(rep(x,length(cols)),rep(x,length(cols)))
+ }
+ if(outline) lines(c(X[1,1],X[nrow(X),2]),c(Y[1,1],Y[nrow(Y),2]),lwd=lwd+2,lend=2)
+ for(i in 1:length(cols)) lines(X[i,],Y[i,],col=cols[i],lwd=lwd,lend=2)
+ if(direction%in%c("rightwards","leftwards")){
+ if(!is.null(lims)) text(x=x,y=y,
+ round(lims[1],digits),pos=3,cex=fsize)
+ if(!is.null(lims)) text(x=x+leg,y=y,
+ round(lims[2],digits),pos=3,cex=fsize)
+ if(is.null(title)) title<-"P(state=1)"
+ text(x=(2*x+leg)/2,y=y,title,pos=3,cex=fsize)
+ if(is.null(subtitle))
+ text(x=(2*x+leg)/2,y=y,paste("length=",round(leg,3),sep=""),pos=1,cex=fsize)
+ else text(x=(2*x+leg)/2,y=y,subtitle,pos=1,cex=fsize)
+ } else if(direction%in%c("upwards","downwards")){
+ if(!is.null(lims)) text(x=x,y=y-0.02*diff(par()$usr[3:4]),round(lims[1],digits),
+ pos=1,cex=fsize)
+ if(!is.null(lims)) text(x=x,y=y+leg+0.02*diff(par()$usr[3:4]),
+ round(lims[2],digits),
+ pos=3,cex=fsize)
+ if(is.null(title)) title<-"P(state=1)"
+ text(x=x-0.04*diff(par()$usr[1:2]),y=(2*y+leg)/2,title,
+ pos=3,cex=fsize,srt=90)
+ if(is.null(subtitle))
+ text(x=x+0.04*diff(par()$usr[1:2]),y=(2*y+leg)/2,
+ paste("length=",round(leg,3),sep=""),pos=1,
+ srt=90,cex=fsize)
+ else text(x=x+0.04*diff(par()$usr[1:2]),y=(2*y+leg)/2,
+ subtitle,pos=1,cex=fsize,srt=90)
+ }
+}
+
+## function to create "edge.widthMap" object
+edge.widthMap<-function(tree,x,...){
+ if(!inherits(tree,"phylo"))
+ stop("tree should be an object of class \"phylo\".")
+ tree<-as.phylo(tree)
+ a<-fastAnc(tree,x)
+ node.values<-c(x[tree$tip.label],a)
+ edge.values<-apply(tree$edge,1,function(e,nv)
+ mean(nv[e]),nv=node.values)
+ edge.widths<-edge.values
+ object<-list(tree=tree,edge.widths=edge.widths,
+ node.values=node.values)
+ class(object)<-"edge.widthMap"
+ object
+}
+
+## print method
+print.edge.widthMap<-function(x,...){
+ cat("Object of class \"edge.widthMap\" containing:\n")
+ cat(paste("(1) Phylogenetic tree with",Ntip(x$tree),
+ "tips and",x$tree$Nnode,"internal nodes.\n"))
+ cat("(2) Vector of node values for a mapped quantitative\n")
+ cat(" trait.\n\n")
+}
+
+## plot method
+plot.edge.widthMap<-function(x,max.width=0.9,legend="trait value",...){
+ if(hasArg(min.width)) min.width<-list(...)$min.width
+ else min.width<-0
+ if(hasArg(vertical.as.polygon))
+ vertical.as.polygon<-list(...)$vertical.as.polygon
+ else vertical.as.polygon<-TRUE
+ if(hasArg(lwd)) lwd<-list(...)$lwd
+ else lwd<-2
+ h<-max(nodeHeights(x$tree))
+ node.values<-x$node.values-min(x$node.values)
+ node.values<-node.values*((max.width-min.width)/
+ max(node.values))+min.width
+ args.list<-list(...)
+ args.list$tree<-x$tree
+ args.list$type<-"phylogram"
+ if(!is.null(args.list$direction)){
+ if(!args.list$direction%in%c("leftwards","rightwards"))
+ args.list$direction<-"rightwards"
+ } else args.list$direction<-"rightwards"
+ if(is.null(args.list$ylim))
+ args.list$ylim<-c(1,Ntip(x$tree)+Ntip(x$tree)/25)
+ if(is.null(args.list$ftype)) args.list$ftype<-"i"
+ if(is.null(args.list$fsize))
+ args.list$fsize<-36*par()$pin[2]/par()$pin[1]/
+ Ntip(x$tree)
+ if(is.null(args.list$color)){
+ args.list$color<-"transparent"
+ color<-"gray62"
+ } else {
+ color<-args.list$color
+ args.list$color<-"transparent"
+ }
+ if(is.null(args.list$border)){
+ border<-color
+ } else {
+ border<-args.list$border
+ args.list$border<-NULL
+ }
+ do.call(plotTree,args.list)
+ obj<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ asp<-par()$pin[2]/par()$pin[1]/
+ (diff(par()$usr[4:3])/diff(par()$usr[2:1]))
+ for(i in 1:nrow(x$tree$edge)){
+ if(vertical.as.polygon){
+ xx<-obj$xx[c(x$tree$edge[i,1],
+ x$tree$edge[i,1:2],
+ x$tree$edge[i,2:1],
+ x$tree$edge[i,1])]+c(0,
+ asp*node.values[x$tree$edge[i,1]]/2,
+ 0,0,asp*node.values[x$tree$edge[i,1]]/2,0)
+ yy<-rep(obj$yy[x$tree$edge[i,2]],6)+
+ c(node.values[x$tree$edge[i,1]],
+ node.values[x$tree$edge[i,1:2]],
+ -node.values[x$tree$edge[i,2:1]],
+ -node.values[x$tree$edge[i,1]])/2
+ }
+ else {
+ xx<-obj$xx[c(x$tree$edge[i,1:2],
+ x$tree$edge[i,2:1])]
+ yy<-rep(obj$yy[x$tree$edge[i,2]],4)+
+ c(node.values[x$tree$edge[i,1:2]],
+ -node.values[x$tree$edge[i,2:1]])/2
+ }
+ polygon(x=crop.to.h(xx,h),y=yy,
+ border=border,col=color,lwd=lwd)
+ }
+ for(i in 1:x$tree$Nnode+Ntip(x$tree)){
+ nn<-x$tree$edge[which(x$tree$edge[,1]==i),2]
+ yy<-range(obj$yy[nn])
+ if(vertical.as.polygon){
+ xx<-rep(obj$xx[i],4)+
+ asp*c(-node.values[i]/2,node.values[i]/2,
+ node.values[i]/2,-node.values[i]/2)
+ polygon(x=crop.to.h(xx,h),
+ y=c(rep(yy[1],2),rep(yy[2],2))+
+ c(-rep(node.values[i],2),
+ rep(node.values[i],2))/2,
+ border=border,col=color,lwd=lwd)
+ } else {
+ lines(rep(obj$xx[i],2),yy+c(-node.values[i],
+ node.values[i])/2,lend=2,col=border,
+ lwd=lwd)
+ }
+ }
+ if(border!=color&&vertical.as.polygon){
+ for(i in 1:nrow(x$tree$edge)){
+ xx<-obj$xx[c(x$tree$edge[i,1],
+ x$tree$edge[i,1:2],
+ x$tree$edge[i,2:1],
+ x$tree$edge[i,1])]+c(0,
+ asp*node.values[x$tree$edge[i,1]]/2,
+ 0,0,asp*node.values[x$tree$edge[i,1]]/2,0)
+ yy<-rep(obj$yy[x$tree$edge[i,2]],6)+
+ c(node.values[x$tree$edge[i,1]],
+ node.values[x$tree$edge[i,1:2]],
+ -node.values[x$tree$edge[i,2:1]],
+ -node.values[x$tree$edge[i,1]])/2
+ polygon(x=crop.to.h(xx,h),y=yy,
+ border=FALSE,col=color)
+ }
+ for(i in 1:x$tree$Nnode+Ntip(x$tree)){
+ nn<-x$tree$edge[which(x$tree$edge[,1]==i),2]
+ yy<-range(obj$yy[nn])
+ xx<-rep(obj$xx[i],4)+
+ asp*c(-node.values[i]/2,node.values[i]/2,
+ node.values[i]/2,-node.values[i]/2)
+ polygon(x=crop.to.h(xx,h),
+ y=c(rep(yy[1],2),rep(yy[2],2))+
+ c(-rep(node.values[i],2),
+ rep(node.values[i],2))/2,
+ border=FALSE,col=color)
+ }
+ }
+ leg.length<-0.4*h
+ x.adj<-if(obj$direction=="rightwards") 0 else obj$x.lim[2]-leg.length
+ polygon(x=c(0,0,leg.length,leg.length)+x.adj,
+ y=Ntip(x$tree)+Ntip(x$tree)/25+
+ c(-min.width/2,min.width/2,max(node.values)/2,
+ -max(node.values)/2),
+ border=border,col=color,lwd=lwd)
+ if(border!=color)
+ polygon(x=c(0,0,leg.length,leg.length)+x.adj,
+ y=Ntip(x$tree)+Ntip(x$tree)/25+
+ c(-min.width/2,min.width/2,max(node.values)/2,
+ -max(node.values)/2),
+ border=FALSE,col=color)
+ text(0+x.adj,Ntip(x$tree)+Ntip(x$tree)/25-0.2*max.width,
+ round(min(x$node.values),2),pos=1,
+ cex=0.8)
+ text(leg.length+x.adj,Ntip(x$tree)+Ntip(x$tree)/25-0.2*max.width,
+ round(max(x$node.values),2),pos=1,cex=0.8)
+ text(leg.length/2+x.adj,Ntip(x$tree)+Ntip(x$tree)/25-0.2*max.width,
+ legend,pos=1,cex=0.8)
+
+}
+
crop.to.h<-function(x,h) sapply(x,function(x,h) if(x<=h) x else h,h=h)
\ No newline at end of file
diff --git a/R/plotSimmap.R b/R/plotSimmap.R
index 767b51a..a13fbb5 100644
--- a/R/plotSimmap.R
+++ b/R/plotSimmap.R
@@ -1,701 +1,701 @@
-## functions plot stochastic character mapped trees
-## written by Liam Revell 2011-2023
-
-plotSimmap<-function(tree,colors=NULL,fsize=1.0,ftype="reg",lwd=2,
- pts=FALSE,node.numbers=FALSE,mar=NULL,add=FALSE,offset=NULL,direction="rightwards",
- type="phylogram",setEnv=TRUE,part=1.0,xlim=NULL,ylim=NULL,nodes="intermediate",
- tips=NULL,maxY=NULL,hold=TRUE,split.vertical=FALSE,lend=2,asp=NA,outline=FALSE,
- plot=TRUE,underscore=FALSE){
- if(inherits(tree,"multiPhylo")){
- par(ask=TRUE)
- for(i in 1:length(tree)) plotSimmap(tree[[i]],colors=colors,fsize=fsize,
- ftype=ftype,lwd=lwd,pts=pts,node.numbers=node.numbers,mar,add,offset,
- direction,type,setEnv,part,xlim,ylim,nodes,tips,maxY,hold,split.vertical,
- lend,asp,outline,plot,underscore)
- } else {
- # check tree
- if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\"")
- if(is.null(tree$maps)) stop("tree should contain mapped states on edges.")
- # check font
- ftype<-which(c("off","reg","b","i","bi")==ftype)-1
- if(!ftype) fsize=0
- # check colors
- if(is.null(colors)){
- st<-sort(unique(unlist(sapply(tree$maps,names))))
- colors<-palette()[1:length(st)]
- names(colors)<-st
- if(length(st)>1){
- cat("no colors provided. using the following legend:\n")
- print(colors)
- }
- }
- # swap out "_" character for spaces (assumes _ is a place holder)
- if(!underscore) tree$tip.label<-gsub("_"," ",tree$tip.label)
- # get margin
- if(is.null(mar)) mar=rep(0.1,4)
- if(hold) null<-dev.hold()
- if(type=="phylogram"){
- if(direction%in%c("upwards","downwards")){
- if(outline){
- fg<-par()$fg
- par(fg="transparent")
- black<-colors
- black[]<-fg
- updownPhylogram(tree,colors=black,fsize,ftype,lwd=lwd+2,pts,
- node.numbers,mar,add,offset,direction,setEnv,xlim,ylim,nodes,
- tips,split.vertical,lend,asp,plot,underscore)
- par(fg=fg)
- }
- updownPhylogram(tree,colors,fsize,ftype,lwd,pts,node.numbers,mar,
- add=if(outline) TRUE else add,offset,direction,setEnv,xlim,ylim,nodes,
- tips,split.vertical,lend,asp,plot,underscore)
- } else {
- if(outline){
- fg<-par()$fg
- par(fg="transparent")
- black<-colors
- black[]<-fg
- plotPhylogram(tree,colors=black,fsize,ftype,lwd=lwd+2,pts,
- node.numbers,mar,add,offset,direction,setEnv,xlim,ylim,nodes,
- tips,split.vertical,lend,asp,plot,underscore)
- par(fg=fg)
- }
- plotPhylogram(tree,colors,fsize,ftype,lwd,pts,node.numbers,mar,
- add=if(outline) TRUE else add,offset,direction,setEnv,xlim,ylim,nodes,
- tips,split.vertical,lend,asp,plot,underscore)
- }
- } else if(type=="fan"){
- if(outline){
- fg<-par()$fg
- par(fg="transparent")
- black<-colors
- black[]<-fg
- plotFan(tree,colors=black,fsize,ftype,lwd=lwd+2,mar,add,part,setEnv,
- xlim,ylim,tips,maxY,lend,plot,offset)
- par(fg=fg)
- }
- plotFan(tree,colors,fsize,ftype,lwd,mar,add=if(outline) TRUE else add,part,
- setEnv,xlim,ylim,tips,maxY,lend,plot,offset)
- } else if(type=="cladogram"){
- if(outline){
- fg<-par()$fg
- par(fg="transparent")
- black<-colors
- black[]<-fg
- plotCladogram(tree,colors=black,fsize,ftype,lwd=lwd+2,mar,add,offset,
- direction,xlim,ylim,nodes,tips,lend,asp,plot)
- par(fg=fg)
- }
- plotCladogram(tree,colors,fsize,ftype,lwd,mar,add=if(outline) TRUE else add,
- offset,direction,xlim,ylim,nodes,tips,lend,asp,plot)
- }
- if(hold) null<-dev.flush()
- }
-}
-
-## function to plot simmap tree in type "phylogram"
-## written by Liam J. Revell 2011-2023
-updownPhylogram<-function(tree,colors,fsize,ftype,lwd,pts,node.numbers,mar,
- add,offset,direction,setEnv,xlim,ylim,placement,tips,split.vertical,lend,
- asp,plot,underscore){
- if(split.vertical&&!setEnv){
- cat("split.vertical requires setEnv=TRUE. Setting split.vertical to FALSE.\n")
- spit.vertical<-FALSE
- }
- # set offset fudge (empirically determined)
- offsetFudge<-1.37
- # reorder
- cw<-reorderSimmap(tree)
- pw<-reorderSimmap(tree,"postorder")
- # count nodes and tips
- n<-Ntip(cw)
- m<-cw$Nnode
- # Y coordinates for nodes
- Y<-matrix(NA,m+n,1)
- # first, assign y coordinates to all the tip nodes
- if(is.null(tips)) Y[cw$edge[cw$edge[,2]<=n,2]]<-1:n
- else Y[cw$edge[cw$edge[,2]<=n,2]]<-if(is.null(names(tips)))
- tips[sapply(1:Ntip(cw),function(x,y) which(y==x),y=cw$edge[cw$edge[,2]<=n,2])]
- else if(!underscore) tips[gsub(" ","_",cw$tip.label)]
- # get Y coordinates of the nodes
- nodes<-unique(pw$edge[,1])
- for(i in 1:m){
- if(placement=="intermediate"){
- desc<-pw$edge[which(pw$edge[,1]==nodes[i]),2]
- Y[nodes[i]]<-(min(Y[desc])+max(Y[desc]))/2
- } else if(placement=="centered"){
- desc<-getDescendants(pw,nodes[i])
- desc<-desc[desc<=Ntip(pw)]
- Y[nodes[i]]<-(min(Y[desc])+max(Y[desc]))/2
- } else if(placement=="weighted"){
- desc<-pw$edge[which(pw$edge[,1]==nodes[i]),2]
- n1<-desc[which(Y[desc]==min(Y[desc]))]
- n2<-desc[which(Y[desc]==max(Y[desc]))]
- v1<-pw$edge.length[which(pw$edge[,2]==n1)]
- v2<-pw$edge.length[which(pw$edge[,2]==n2)]
- Y[nodes[i]]<-((1/v1)*Y[n1]+(1/v2)*Y[n2])/(1/v1+1/v2)
- } else if(placement=="inner"){
- desc<-getDescendants(pw,nodes[i])
- desc<-desc[desc<=Ntip(pw)]
- mm<-which(abs(Y[desc]-median(Y[1:Ntip(pw)]))==min(abs(Y[desc]-
- median(Y[1:Ntip(pw)]))))
- if(length(mm>1)) mm<-mm[which(Y[desc][mm]==min(Y[desc][mm]))]
- Y[nodes[i]]<-Y[desc][mm]
- }
- }
- # compute node heights
- H<-nodeHeights(cw)
- # open plot
- par(mar=mar)
- if(is.null(offset)) offset<-0.2*lwd/3+0.2/3
- if(!add) plot.new()
- ###
- if(is.null(ylim)){
- pp<-par("pin")[2]
- sw<-fsize*(max(strwidth(cw$tip.label,units="inches")))+
- offsetFudge*fsize*strwidth("W",units="inches")
- alp<-optimize(function(a,H,sw,pp) (a*1.04*max(H)+sw-pp)^2,H=H,sw=sw,pp=pp,
- interval=c(0,1e6))$minimum
- ylim<-if(direction=="downwards") c(min(H)-sw/alp,max(H)) else c(min(H),max(H)+sw/alp)
- }
- if(is.null(xlim)) xlim=range(Y)
- if(direction=="downwards") H<-max(H)-H
- plot.window(xlim=xlim,ylim=ylim,asp=asp)
- ####
- if(plot){
- if(!split.vertical){
- for(i in 1:m) lines(Y[cw$edge[which(cw$edge[,1]==nodes[i]),2]],
- H[which(cw$edge[,1]==nodes[i]),1],
- col=colors[names(cw$maps[[match(nodes[i],
- cw$edge[,1])]])[1]],lwd=lwd,lend=lend)
- }
- for(i in 1:nrow(cw$edge)){
- x<-H[i,1]
- for(j in 1:length(cw$maps[[i]])){
- if(direction=="downwards")
- lines(c(Y[cw$edge[i,2]],Y[cw$edge[i,2]]),c(x,x-cw$maps[[i]][j]),
- col=colors[names(cw$maps[[i]])[j]],lwd=lwd,lend=lend)
- else lines(c(Y[cw$edge[i,2]],Y[cw$edge[i,2]]),c(x,x+cw$maps[[i]][j]),
- col=colors[names(cw$maps[[i]])[j]],lwd=lwd,lend=lend)
- if(pts) points(c(Y[cw$edge[i,2]],Y[cw$edge[i,2]]),c(x,x+cw$maps[[i]][j]),
- pch=20,lwd=(lwd-1))
- x<-x+if(direction=="downwards") -cw$maps[[i]][j] else cw$maps[[i]][j]
- j<-j+1
- }
- }
- if(node.numbers){
- symbols(mean(Y[cw$edge[cw$edge[,1]==(Ntip(cw)+1),2]]),
- if(direction=="downwards") max(H) else 0,
- rectangles=matrix(c(1.2*fsize*strwidth(as.character(Ntip(cw)+1)),
- 1.4*fsize*strheight(as.character(Ntip(cw)+1))),1,2),inches=FALSE,
- bg="white",add=TRUE)
- text(mean(Y[cw$edge[cw$edge[,1]==(Ntip(cw)+1),2]]),
- if(direction=="downwards") max(H) else 0,Ntip(cw)+1,
- cex=fsize)
- for(i in 1:nrow(cw$edge)){
- x<-H[i,2]
- if(cw$edge[i,2]>Ntip(cw)){
- symbols(Y[cw$edge[i,2]],x,
- rectangles=matrix(c(1.2*fsize*strwidth(as.character(cw$edge[i,2])),
- 1.4*fsize*strheight(as.character(cw$edge[i,2]))),1,2),inches=FALSE,
- bg="white",add=TRUE)
- text(Y[cw$edge[i,2]],x,cw$edge[i,2],cex=fsize)
- }
- }
- }
- if(direction=="downwards") pos<-if(par()$usr[3]>par()$usr[4]) 2 else 4
- if(direction=="upwards") pos<-if(par()$usr[3]>par()$usr[4]) 2 else 4
- for(i in 1:n){
- shift<-offset*fsize*strwidth("W")*(diff(par()$usr[3:4])/diff(par()$usr[1:2]))
- if((direction=="downwards"&&diff(par()$usr[3:4])>0) ||
- (direction=="upwards"&&diff(par()$usr[3:4])<0)) shift<--shift
- if(ftype){
- text(labels=cw$tip.label[i],Y[i],
- H[which(cw$edge[,2]==i),2]+shift,
- pos=pos,offset=0,cex=fsize,font=ftype,
- srt=if(direction=="downwards") 270 else 90)
- }
- }
- }
- if(setEnv){
- PP<-list(type="phylogram",use.edge.length=TRUE,node.pos=1,
- show.tip.label=if(ftype) TRUE else FALSE,show.node.label=FALSE,
- font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE,label.offset=offset,
- x.lim=xlim,y.lim=ylim,
- direction=direction,tip.color="black",Ntip=Ntip(cw),Nnode=cw$Nnode,
- edge=cw$edge,xx=Y[,1],yy=sapply(1:(Ntip(cw)+cw$Nnode),
- function(x,y,z) y[match(x,z)],y=H,z=cw$edge))
- assign("last_plot.phylo",PP,envir=.PlotPhyloEnv)
- }
- if(plot) if(split.vertical) splitEdgeColor(cw,colors,lwd)
-}
-
-# function to plot simmap tree in type "phylogram"
-# written by Liam J. Revell 2011-2023
-plotPhylogram<-function(tree,colors,fsize,ftype,lwd,pts,node.numbers,mar,
- add,offset,direction,setEnv,xlim,ylim,placement,tips,split.vertical,lend,
- asp,plot,underscore){
- if(split.vertical&&!setEnv){
- cat("split.vertical requires setEnv=TRUE. Setting split.vertical to FALSE.\n")
- spit.vertical<-FALSE
- }
- # set offset fudge (empirically determined)
- offsetFudge<-1.37
- # reorder
- cw<-reorderSimmap(tree)
- pw<-reorderSimmap(tree,"postorder")
- # count nodes and tips
- n<-Ntip(cw)
- m<-cw$Nnode
- # Y coordinates for nodes
- Y<-matrix(NA,m+n,1)
- # first, assign y coordinates to all the tip nodes
- if(is.null(tips)) Y[cw$edge[cw$edge[,2]<=n,2]]<-1:n
- else Y[cw$edge[cw$edge[,2]<=n,2]]<-if(is.null(names(tips)))
- tips[sapply(1:Ntip(cw),function(x,y) which(y==x),y=cw$edge[cw$edge[,2]<=n,2])]
- else if(!underscore) tips[gsub(" ","_",cw$tip.label)]
- # get Y coordinates of the nodes
- nodes<-unique(pw$edge[,1])
- for(i in 1:m){
- if(placement=="intermediate"){
- desc<-pw$edge[which(pw$edge[,1]==nodes[i]),2]
- Y[nodes[i]]<-(min(Y[desc])+max(Y[desc]))/2
- } else if(placement=="centered"){
- desc<-getDescendants(pw,nodes[i])
- desc<-desc[desc<=Ntip(pw)]
- Y[nodes[i]]<-(min(Y[desc])+max(Y[desc]))/2
- } else if(placement=="weighted"){
- desc<-pw$edge[which(pw$edge[,1]==nodes[i]),2]
- n1<-desc[which(Y[desc]==min(Y[desc]))]
- n2<-desc[which(Y[desc]==max(Y[desc]))]
- v1<-pw$edge.length[which(pw$edge[,2]==n1)]
- v2<-pw$edge.length[which(pw$edge[,2]==n2)]
- Y[nodes[i]]<-((1/v1)*Y[n1]+(1/v2)*Y[n2])/(1/v1+1/v2)
- } else if(placement=="inner"){
- desc<-getDescendants(pw,nodes[i])
- desc<-desc[desc<=Ntip(pw)]
- mm<-which(abs(Y[desc]-median(Y[1:Ntip(pw)]))==min(abs(Y[desc]-
- median(Y[1:Ntip(pw)]))))
- if(length(mm>1)) mm<-mm[which(Y[desc][mm]==min(Y[desc][mm]))]
- Y[nodes[i]]<-Y[desc][mm]
- }
- }
- # compute node heights
- H<-nodeHeights(cw)
- # open plot
- par(mar=mar)
- if(is.null(offset)) offset<-0.2*lwd/3+0.2/3
- if(!add) plot.new()
- ###
- if(is.null(xlim)){
- pp<-par("pin")[1]
- sw<-fsize*(max(strwidth(cw$tip.label,units="inches")))+
- offsetFudge*fsize*strwidth("W",units="inches")
- alp<-optimize(function(a,H,sw,pp) (a*1.04*max(H)+sw-pp)^2,H=H,sw=sw,pp=pp,
- interval=c(0,1e6))$minimum
- xlim<-if(direction=="leftwards") c(min(H)-sw/alp,max(H)) else c(min(H),max(H)+sw/alp)
- }
- if(is.null(ylim)) ylim=range(Y)
- if(direction=="leftwards") H<-max(H)-H
- plot.window(xlim=xlim,ylim=ylim,asp=asp)
- if(plot){
- ####
- if(!split.vertical){
- for(i in 1:m) lines(H[which(cw$edge[,1]==nodes[i]),1],
- Y[cw$edge[which(cw$edge[,1]==nodes[i]),2]],col=colors[names(cw$maps[[match(nodes[i],
- cw$edge[,1])]])[1]],lwd=lwd,lend=lend)
- }
- for(i in 1:nrow(cw$edge)){
- x<-H[i,1]
- for(j in 1:length(cw$maps[[i]])){
- if(direction=="leftwards")
- lines(c(x,x-cw$maps[[i]][j]),c(Y[cw$edge[i,2]],Y[cw$edge[i,2]]),
- col=colors[names(cw$maps[[i]])[j]],lwd=lwd,lend=lend)
- else lines(c(x,x+cw$maps[[i]][j]),c(Y[cw$edge[i,2]],Y[cw$edge[i,2]]),
- col=colors[names(cw$maps[[i]])[j]],lwd=lwd,lend=lend)
- if(pts) points(c(x,x+cw$maps[[i]][j]),c(Y[cw$edge[i,2]],Y[cw$edge[i,2]]),
- pch=20,lwd=(lwd-1))
- x<-x+if(direction=="leftwards") -cw$maps[[i]][j] else cw$maps[[i]][j]
- j<-j+1
- }
- }
- if(node.numbers){
- symbols(if(direction=="leftwards") max(H) else 0,
- mean(Y[cw$edge[cw$edge[,1]==(Ntip(cw)+1),2]]),
- rectangles=matrix(c(1.2*fsize*strwidth(as.character(Ntip(cw)+1)),
- 1.4*fsize*strheight(as.character(Ntip(cw)+1))),1,2),inches=FALSE,
- bg="white",add=TRUE)
- text(if(direction=="leftwards") max(H) else 0,
- mean(Y[cw$edge[cw$edge[,1]==(Ntip(cw)+1),2]]),Ntip(cw)+1,
- cex=fsize)
- for(i in 1:nrow(cw$edge)){
- x<-H[i,2]
- if(cw$edge[i,2]>Ntip(cw)){
- symbols(x,Y[cw$edge[i,2]],
- rectangles=matrix(c(1.2*fsize*strwidth(as.character(cw$edge[i,2])),
- 1.4*fsize*strheight(as.character(cw$edge[i,2]))),1,2),inches=FALSE,
- bg="white",add=TRUE)
- text(x,Y[cw$edge[i,2]],cw$edge[i,2],cex=fsize)
- }
- }
- }
- if(direction=="leftwards") pos<-if(par()$usr[1]>par()$usr[2]) 4 else 2
- if(direction=="rightwards") pos<-if(par()$usr[1]>par()$usr[2]) 2 else 4
- for(i in 1:n) if(ftype) text(H[which(cw$edge[,2]==i),2],Y[i],cw$tip.label[i],pos=pos,
- offset=offset,cex=fsize,font=ftype)
- }
- if(setEnv){
- PP<-list(type="phylogram",use.edge.length=TRUE,node.pos=1,
- show.tip.label=if(ftype) TRUE else FALSE,show.node.label=FALSE,
- font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE,label.offset=offset,
- x.lim=xlim,y.lim=ylim,
- direction=direction,tip.color="black",Ntip=Ntip(cw),Nnode=cw$Nnode,
- edge=cw$edge,xx=sapply(1:(Ntip(cw)+cw$Nnode),
- function(x,y,z) y[match(x,z)],y=H,z=cw$edge),yy=Y[,1])
- assign("last_plot.phylo",PP,envir=.PlotPhyloEnv)
- }
- if(plot) if(split.vertical) splitEdgeColor(cw,colors,lwd)
-}
-
-# function to plot simmap tree in type "fan"
-# written by Liam J. Revell 2013-2017
-plotFan<-function(tree,colors,fsize,ftype,lwd,mar,add,part,setEnv,xlim,ylim,tips,maxY,lend,plot,offset){
- if(!plot) cat("plot=FALSE option is not permitted for type=\"fan\". Tree will be plotted.\n")
- if(is.null(offset)) offset<-1
- # reorder
- cw<-reorder(tree)
- pw<-reorder(tree,"pruningwise")
- # count nodes and tips
- n<-Ntip(cw)
- m<-cw$Nnode
- # get Y coordinates on uncurved space
- Y<-vector(length=m+n)
- if(is.null(tips)) tips<-1:n
- if(part<1.0) Y[cw$edge[cw$edge[,2]<=n,2]]<-0:(n-1)
- else Y[cw$edge[cw$edge[,2]<=n,2]]<-tips
- nodes<-unique(pw$edge[,1])
- for(i in 1:m){
- desc<-pw$edge[which(pw$edge[,1]==nodes[i]),2]
- Y[nodes[i]]<-(min(Y[desc])+max(Y[desc]))/2
- }
- if(is.null(maxY)) maxY<-max(Y)
- Y<-setNames(Y/maxY*2*pi,1:(n+m))
- Y<-part*cbind(Y[as.character(cw$edge[,2])],Y[as.character(cw$edge[,2])])
- R<-nodeHeights(cw)
- # now put into a circular coordinate system
- x<-R*cos(Y)
- y<-R*sin(Y)
- # optimize x & y limits
- par(mar=mar)
- offsetFudge<-1.37 # empirically determined
- OFFSET<-0
- pp<-par("pin")[1]
- sw<-fsize*(max(strwidth(cw$tip.label,units="inches")))+
- offsetFudge*OFFSET*fsize*strwidth("W",units="inches")
- alp<-optimize(function(a,H,sw,pp) (2*a*1.04*max(H)+2*sw-pp)^2,H=R,sw=sw,pp=pp,
- interval=c(0,1e6))$minimum
- if(part<=0.25) x.lim<-y.lim<-c(0,max(R)+sw/alp)
- else if(part>0.25&&part<=0.5){
- x.lim<-c(-max(R)-sw/alp,max(R)+sw/alp)
- y.lim<-c(0,max(R)+sw/alp)
- } else x.lim<-y.lim<-c(-max(R)-sw/alp,max(R)+sw/alp)
- if(is.null(xlim)) xlim<-x.lim
- if(is.null(ylim)) ylim<-y.lim
- # plot tree
- if(!add) plot.new()
- plot.window(xlim=xlim,ylim=ylim,asp=1)
- # plot radial lines (edges)
- ## first, the lines emerging from the root (if there are only two):
- jj<-which(cw$edge[,1]==(Ntip(cw)+1))
- if(length(jj)==2){
- m.left<-cumsum(cw$maps[[jj[1]]])/sum(cw$maps[[jj[1]]])
- xx.left<-c(x[jj[1],1],x[jj[1],1]+(x[jj[1],2]-x[jj[1],1])*m.left)
- yy.left<-c(y[jj[1],1],y[jj[1],1]+(y[jj[1],2]-y[jj[1],1])*m.left)
- m.right<-cumsum(cw$maps[[jj[2]]])/sum(cw$maps[[jj[2]]])
- xx.right<-c(x[jj[2],1],x[jj[2],1]+(x[jj[2],2]-x[jj[2],1])*m.right)
- yy.right<-c(y[jj[2],1],y[jj[2],1]+(y[jj[2],2]-y[jj[2],1])*m.right)
- xx<-c(xx.left[length(xx.left):1],xx.right[2:length(xx.right)])
- yy<-c(yy.left[length(yy.left):1],yy.right[2:length(yy.right)])
- col<-colors[c(names(m.left)[length(m.left):1],names(m.right))]
- segments(xx[2:length(xx)-1],yy[2:length(yy)-1],xx[2:length(xx)],yy[2:length(yy)],
- col=col,lwd=lwd,lend=lend)
- } else jj<-NULL
- for(i in 1:nrow(cw$edge)){
- if(i%in%jj==FALSE){
- maps<-cumsum(cw$maps[[i]])/sum(cw$maps[[i]])
- xx<-c(x[i,1],x[i,1]+(x[i,2]-x[i,1])*maps)
- yy<-c(y[i,1],y[i,1]+(y[i,2]-y[i,1])*maps)
- for(i in 1:(length(xx)-1)) lines(xx[i+0:1],yy[i+0:1],col=colors[names(maps)[i]],
- lwd=lwd,lend=lend)
- }
- }
- # plot circular lines
- for(i in 1:m+n){
- r<-R[match(i,cw$edge)]
- a1<-min(Y[which(cw$edge==i)])
- a2<-max(Y[which(cw$edge==i)])
- draw.arc(0,0,r,a1,a2,lwd=lwd,col=colors[names(cw$maps[[match(i,cw$edge[,1])]])[1]])
- }
- # plot labels
- for(i in 1:n){
- ii<-which(cw$edge[,2]==i)
- aa<-Y[ii,2]/(2*pi)*360
- adj<-if(aa>90&&aa<270) c(1,0.25) else c(0,0.25)
- tt<-if(aa>90&&aa<270) paste(cw$tip.label[i],paste(rep(" ",offset),
- collapse=""),sep="") else paste(paste(rep(" ",offset),collapse=""),
- cw$tip.label[i],sep="")
- aa<-if(aa>90&&aa<270) 180+aa else aa
- if(ftype) text(x[ii,2],y[ii,2],tt,srt=aa,adj=adj,cex=fsize,font=ftype)
- }
- if(setEnv){
- PP<-list(type="fan",use.edge.length=TRUE,node.pos=1,
- show.tip.label=if(ftype) TRUE else FALSE,show.node.label=FALSE,
- font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE,label.offset=offset,
- x.lim=xlim,y.lim=ylim,direction="rightwards",tip.color="black",
- Ntip=Ntip(cw),Nnode=cw$Nnode,edge=cw$edge,
- xx=c(x[sapply(1:n,function(x,y) which(x==y)[1],y=cw$edge[,2]),2],x[1,1],
- if(m>1) x[sapply(2:m+n,function(x,y) which(x==y)[1],y=cw$edge[,2]),2] else c()),
- yy=c(y[sapply(1:n,function(x,y) which(x==y)[1],y=cw$edge[,2]),2],y[1,1],
- if(m>1) y[sapply(2:m+n,function(x,y) which(x==y)[1],y=cw$edge[,2]),2] else c()))
- assign("last_plot.phylo",PP,envir=.PlotPhyloEnv)
- }
-}
-
-## internal function for slanted cladogram
-## written by Liam J. Revell 2017-2023
-plotCladogram<-function(tree,colors=NULL,fsize=1.0,ftype="reg",lwd=2,mar=NULL,
- add=FALSE,offset=NULL,direction="rightwards",xlim=NULL,ylim=NULL,
- nodes="intermediate",tips=NULL,lend=2,asp=NA,plot=TRUE,underscore=FALSE){
- placement<-nodes
- # set offset fudge (empirically determined)
- offsetFudge<-1.37
- # reorder
- cw<-reorderSimmap(tree)
- pw<-reorderSimmap(tree,"postorder")
- # count nodes and tips
- n<-Ntip(cw)
- m<-cw$Nnode
- # Y coordinates for nodes
- Y<-matrix(NA,m+n,1)
- # first, assign y coordinates to all the tip nodes
- if(is.null(tips)) Y[cw$edge[cw$edge[,2]<=n,2]]<-1:n
- else Y[cw$edge[cw$edge[,2]<=n,2]]<-if(is.null(names(tips)))
- tips[sapply(1:Ntip(cw),function(x,y) which(y==x),y=cw$edge[cw$edge[,2]<=n,2])]
- else if(!underscore) tips[gsub(" ","_",cw$tip.label)]
- # get Y coordinates of the nodes
- nodes<-unique(pw$edge[,1])
- for(i in 1:m){
- if(placement=="intermediate"){
- desc<-pw$edge[which(pw$edge[,1]==nodes[i]),2]
- Y[nodes[i]]<-(min(Y[desc])+max(Y[desc]))/2
- } else if(placement=="centered"){
- desc<-getDescendants(pw,nodes[i])
- desc<-desc[desc<=Ntip(pw)]
- Y[nodes[i]]<-(min(Y[desc])+max(Y[desc]))/2
- } else if(placement=="weighted"){
- desc<-pw$edge[which(pw$edge[,1]==nodes[i]),2]
- n1<-desc[which(Y[desc]==min(Y[desc]))]
- n2<-desc[which(Y[desc]==max(Y[desc]))]
- v1<-pw$edge.length[which(pw$edge[,2]==n1)]
- v2<-pw$edge.length[which(pw$edge[,2]==n2)]
- Y[nodes[i]]<-((1/v1)*Y[n1]+(1/v2)*Y[n2])/(1/v1+1/v2)
- } else if(placement=="inner"){
- desc<-getDescendants(pw,nodes[i])
- desc<-desc[desc<=Ntip(pw)]
- mm<-which(abs(Y[desc]-median(Y[1:Ntip(pw)]))==min(abs(Y[desc]-
- median(Y[1:Ntip(pw)]))))
- if(length(mm>1)) mm<-mm[which(Y[desc][mm]==min(Y[desc][mm]))]
- Y[nodes[i]]<-Y[desc][mm]
- }
- }
- # compute node heights
- H<-nodeHeights(cw)
- # open plot
- par(mar=mar)
- if(is.null(offset)) offset<-0.2*lwd/3+0.2/3
- if(!add) plot.new()
- ###
- if(is.null(xlim)){
- pp<-par("pin")[1]
- sw<-fsize*(max(strwidth(cw$tip.label,units="inches")))+
- offsetFudge*fsize*strwidth("W",units="inches")
- alp<-optimize(function(a,H,sw,pp) (a*1.04*max(H)+sw-pp)^2,H=H,sw=sw,pp=pp,
- interval=c(0,1e6))$minimum
- xlim<-if(direction=="leftwards") c(min(H)-sw/alp,max(H)) else c(min(H),max(H)+sw/alp)
- }
- if(is.null(ylim)) ylim=range(Y)
- if(direction=="leftwards") H<-max(H)-H
- plot.window(xlim=xlim,ylim=ylim,asp=asp)
- if(plot){
- ####
- for(i in 1:nrow(cw$edge)){
- x<-H[i,1]
- y<-Y[cw$edge[i,1]]
- m<-(Y[cw$edge[i,2]]-Y[cw$edge[i,1]])/(H[i,2]-H[i,1])
- if(is.finite(m)){
- for(j in 1:length(cw$maps[[i]])){
- if(direction=="leftwards")
- lines(c(x,x-cw$maps[[i]][j]),c(y,y-cw$maps[[i]][j]*m),
- col=colors[names(cw$maps[[i]])[j]],lwd=lwd,lend=lend)
- else lines(c(x,x+cw$maps[[i]][j]),c(y,y+cw$maps[[i]][j]*m),
- col=colors[names(cw$maps[[i]])[j]],lwd=lwd,lend=lend)
- x<-x+if(direction=="leftwards") -cw$maps[[i]][j] else cw$maps[[i]][j]
- y<-y+if(direction=="leftwards") -m*cw$maps[[i]][j] else m*cw$maps[[i]][j]
- j<-j+1
- }
- } else {
- lines(rep(x,2),Y[cw$edge[i,]],col=colors[names(cw$maps[[i]])[1]],lwd=lwd,
- lend=lend)
- }
- }
- if(direction=="leftwards") pos<-if(par()$usr[1]>par()$usr[2]) 4 else 2
- if(direction=="rightwards") pos<-if(par()$usr[1]>par()$usr[2]) 2 else 4
- for(i in 1:n) if(ftype) text(H[which(cw$edge[,2]==i),2],Y[i],cw$tip.label[i],pos=pos,
- offset=offset,cex=fsize,font=ftype)
- }
- PP<-list(type="phylogram",use.edge.length=TRUE,node.pos=1,
- show.tip.label=if(ftype) TRUE else FALSE,show.node.label=FALSE,
- font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE,label.offset=offset,
- x.lim=xlim,y.lim=ylim,
- direction=direction,tip.color="black",Ntip=Ntip(cw),Nnode=cw$Nnode,
- edge=cw$edge,xx=sapply(1:(Ntip(cw)+cw$Nnode),
- function(x,y,z) y[match(x,z)],y=H,z=cw$edge),yy=Y[,1])
- assign("last_plot.phylo",PP,envir=.PlotPhyloEnv)
-}
-
-
-## adds legend to an open stochastic map style plot
-## written by Liam J. Revell 2013, 2016, 2017
-add.simmap.legend<-function(leg=NULL,colors,prompt=TRUE,vertical=TRUE,...){
- if(hasArg(shape)) shape<-list(...)$shape
- else shape<-"square"
- if(prompt){
- cat("Click where you want to draw the legend\n")
- x<-unlist(locator(1))
- y<-x[2]
- x<-x[1]
- } else {
- if(hasArg(x)) x<-list(...)$x
- else x<-0
- if(hasArg(y)) y<-list(...)$y
- else y<-0
- }
- if(hasArg(fsize)) fsize<-list(...)$fsize
- else fsize<-1.0
- if(is.null(leg)) leg<-names(colors)
- h<-fsize*strheight(LETTERS[1])
- w<-par()$mfcol[2]*h*abs(diff(par()$usr[1:2])/diff(par()$usr[3:4]))
- flipped<-par()$usr[1]>par()$usr[2]
- if(vertical){
- y<-y-0:(length(leg)-1)*1.5*h
- x<-rep(x+w/2,length(y))
- text(x + if(flipped) -w else w,y,leg,pos=4,cex=fsize/par()$cex)
- } else {
- sp<-abs(fsize*max(strwidth(leg)))
- x<-x + if(flipped) w/2-0:(length(leg)-1)*1.5*(sp+w) else -w/2+0:(length(leg)-1)*1.5*(sp+w)
- y<-rep(y+w/2,length(x))
- text(x,y,leg,pos=4,cex=fsize/par()$cex)
- }
- if(shape=="square") symbols(x,y,squares=rep(w,length(x)),bg=colors,add=TRUE,inches=FALSE)
- else if(shape=="circle") nulo<-mapply(draw.circle,x=x,y=y,col=colors,
- MoreArgs=list(nv=200,radius=w/2))
- else stop(paste("shape=\"",shape,"\" is not a recognized option.",sep=""))
-}
-
-# function plots a tree; in the new version this is just a wrapper for plotSimmap
-# written by Liam Revell 2012-2017
-plotTree<-function(tree,...){
- if(hasArg(color)) color<-list(...)$color
- else color<-NULL
- if(hasArg(fsize)) fsize<-list(...)$fsize
- else fsize<-1.0
- if(hasArg(ftype)) ftype<-list(...)$ftype
- else ftype<-"reg"
- if(hasArg(lwd)) lwd<-list(...)$lwd
- else lwd<-2
- if(hasArg(pts)) pts<-list(...)$pts
- else pts<-FALSE
- if(hasArg(node.numbers)) node.numbers<-list(...)$node.numbers
- else node.numbers<-FALSE
- if(hasArg(mar)) mar<-list(...)$mar
- else mar<-NULL
- if(hasArg(add)) add<-list(...)$add
- else add<-FALSE
- if(hasArg(offset)) offset<-list(...)$offset
- else offset<-NULL
- if(hasArg(type)) type<-list(...)$type
- else type<-"phylogram"
- if(hasArg(direction)) direction<-list(...)$direction
- else direction<-"rightwards"
- if(hasArg(setEnv)) setEnv<-list(...)$setEnv
- else setEnv<-TRUE
- if(hasArg(part)) part<-list(...)$part
- else part<-1.0
- if(hasArg(xlim)) xlim<-list(...)$xlim
- else xlim<-NULL
- if(hasArg(ylim)) ylim<-list(...)$ylim
- else ylim<-NULL
- if(hasArg(nodes)) nodes<-list(...)$nodes
- else nodes<-"intermediate"
- if(hasArg(tips)) tips<-list(...)$tips
- else tips<-NULL
- if(hasArg(maxY)) maxY<-list(...)$maxY
- else maxY<-NULL
- if(hasArg(hold)) hold<-list(...)$hold
- else hold<-TRUE
- if(hasArg(lend)) lend<-list(...)$lend
- else lend<-2
- if(hasArg(asp)) asp<-list(...)$asp
- else asp<-NA
- if(hasArg(plot)) plot<-list(...)$plot
- else plot<-TRUE
- if(hasArg(underscore)) underscore<-list(...)$underscore
- else underscore=FALSE
- if(inherits(tree,"multiPhylo")){
- par(ask=TRUE)
- if(!is.null(color)) names(color)<-"1"
- for(i in 1:length(tree)) plotTree(tree[[i]],color=color,fsize=fsize,ftype=ftype,
- lwd=lwd,pts=pts,node.numbers=node.numbers,mar=mar,add=add,offset=offset,
- direction=direction,type=type,setEnv=setEnv,part=part,xlim=xlim,ylim=ylim,
- nodes=nodes,tips=tips,maxY=maxY,hold=hold,lend=lend,asp=asp,plot=plot,
- underscore=underscore)
- } else {
- if(is.null(tree$edge.length)) tree<-compute.brlen(tree)
- tree$maps<-as.list(tree$edge.length)
- for(i in 1:length(tree$maps)) names(tree$maps[[i]])<-c("1")
- if(!is.null(color)) names(color)<-"1"
- plotSimmap(tree,colors=color,fsize=fsize,ftype=ftype,lwd=lwd,pts=pts,
- node.numbers=node.numbers,mar=mar,add=add,offset=offset,direction=direction,
- type=type,setEnv=setEnv,part=part,xlim=xlim,ylim=ylim,nodes=nodes,tips=tips,maxY=maxY,
- hold=hold,lend=lend,asp=asp,plot=plot,underscore=underscore)
- }
-}
-
-## S3 method for objects of class "simmap" & "multiSimmap"
-## added by Liam J. Revell 2015
-plot.simmap<-function(x,...) plotSimmap(x,...)
-plot.multiSimmap<-function(x,...) plotSimmap(x,...)
-
-## function to split vertical plotted lines by the states of daughter edges
-## written by Liam J. Revell 2015
-splitEdgeColor<-function(tree,colors,lwd=2){
- obj<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- for(i in 1:tree$Nnode+Ntip(tree)){
- daughters<-tree$edge[which(tree$edge[,1]==i),2]
- cols<-vector()
- for(j in 1:length(daughters)){
- jj<-which(tree$edge[,2]==daughters[j])
- cols[j]<-if(tree$maps[[jj]][1]==0&&length(tree$maps[[jj]])>1) colors[names(tree$maps[[jj]])[2]]
- else colors[names(tree$maps[[jj]])[1]]
- }
- ii<-order(obj$yy[c(i,daughters)])
- jj<-order(obj$yy[daughters])
- x0<-x1<-rep(obj$xx[i],length(daughters))
- y0<-obj$yy[c(i,daughters)][ii][1:length(daughters)]
- y1<-obj$yy[c(i,daughters)][ii][2:(length(daughters)+1)]
- cols<-cols[jj]
- for(j in 1:length(x0)) segments(x0[j],y0[j],x1[j],y1[j],col=cols[j],lwd=lwd,lend=2)
- }
-}
-
-
+## functions plot stochastic character mapped trees
+## written by Liam Revell 2011-2023
+
+plotSimmap<-function(tree,colors=NULL,fsize=1.0,ftype="reg",lwd=2,
+ pts=FALSE,node.numbers=FALSE,mar=NULL,add=FALSE,offset=NULL,direction="rightwards",
+ type="phylogram",setEnv=TRUE,part=1.0,xlim=NULL,ylim=NULL,nodes="intermediate",
+ tips=NULL,maxY=NULL,hold=TRUE,split.vertical=FALSE,lend=2,asp=NA,outline=FALSE,
+ plot=TRUE,underscore=FALSE){
+ if(inherits(tree,"multiPhylo")){
+ par(ask=TRUE)
+ for(i in 1:length(tree)) plotSimmap(tree[[i]],colors=colors,fsize=fsize,
+ ftype=ftype,lwd=lwd,pts=pts,node.numbers=node.numbers,mar,add,offset,
+ direction,type,setEnv,part,xlim,ylim,nodes,tips,maxY,hold,split.vertical,
+ lend,asp,outline,plot,underscore)
+ } else {
+ # check tree
+ if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\"")
+ if(is.null(tree$maps)) stop("tree should contain mapped states on edges.")
+ # check font
+ ftype<-which(c("off","reg","b","i","bi")==ftype)-1
+ if(!ftype) fsize=0
+ # check colors
+ if(is.null(colors)){
+ st<-sort(unique(unlist(sapply(tree$maps,names))))
+ colors<-palette()[1:length(st)]
+ names(colors)<-st
+ if(length(st)>1){
+ cat("no colors provided. using the following legend:\n")
+ print(colors)
+ }
+ }
+ # swap out "_" character for spaces (assumes _ is a place holder)
+ if(!underscore) tree$tip.label<-gsub("_"," ",tree$tip.label)
+ # get margin
+ if(is.null(mar)) mar=rep(0.1,4)
+ if(hold) null<-dev.hold()
+ if(type=="phylogram"){
+ if(direction%in%c("upwards","downwards")){
+ if(outline){
+ fg<-par()$fg
+ par(fg="transparent")
+ black<-colors
+ black[]<-fg
+ updownPhylogram(tree,colors=black,fsize,ftype,lwd=lwd+2,pts,
+ node.numbers,mar,add,offset,direction,setEnv,xlim,ylim,nodes,
+ tips,split.vertical,lend,asp,plot,underscore)
+ par(fg=fg)
+ }
+ updownPhylogram(tree,colors,fsize,ftype,lwd,pts,node.numbers,mar,
+ add=if(outline) TRUE else add,offset,direction,setEnv,xlim,ylim,nodes,
+ tips,split.vertical,lend,asp,plot,underscore)
+ } else {
+ if(outline){
+ fg<-par()$fg
+ par(fg="transparent")
+ black<-colors
+ black[]<-fg
+ plotPhylogram(tree,colors=black,fsize,ftype,lwd=lwd+2,pts,
+ node.numbers,mar,add,offset,direction,setEnv,xlim,ylim,nodes,
+ tips,split.vertical,lend,asp,plot,underscore)
+ par(fg=fg)
+ }
+ plotPhylogram(tree,colors,fsize,ftype,lwd,pts,node.numbers,mar,
+ add=if(outline) TRUE else add,offset,direction,setEnv,xlim,ylim,nodes,
+ tips,split.vertical,lend,asp,plot,underscore)
+ }
+ } else if(type=="fan"){
+ if(outline){
+ fg<-par()$fg
+ par(fg="transparent")
+ black<-colors
+ black[]<-fg
+ plotFan(tree,colors=black,fsize,ftype,lwd=lwd+2,mar,add,part,setEnv,
+ xlim,ylim,tips,maxY,lend,plot,offset)
+ par(fg=fg)
+ }
+ plotFan(tree,colors,fsize,ftype,lwd,mar,add=if(outline) TRUE else add,part,
+ setEnv,xlim,ylim,tips,maxY,lend,plot,offset)
+ } else if(type=="cladogram"){
+ if(outline){
+ fg<-par()$fg
+ par(fg="transparent")
+ black<-colors
+ black[]<-fg
+ plotCladogram(tree,colors=black,fsize,ftype,lwd=lwd+2,mar,add,offset,
+ direction,xlim,ylim,nodes,tips,lend,asp,plot)
+ par(fg=fg)
+ }
+ plotCladogram(tree,colors,fsize,ftype,lwd,mar,add=if(outline) TRUE else add,
+ offset,direction,xlim,ylim,nodes,tips,lend,asp,plot)
+ }
+ if(hold) null<-dev.flush()
+ }
+}
+
+## function to plot simmap tree in type "phylogram"
+## written by Liam J. Revell 2011-2023
+updownPhylogram<-function(tree,colors,fsize,ftype,lwd,pts,node.numbers,mar,
+ add,offset,direction,setEnv,xlim,ylim,placement,tips,split.vertical,lend,
+ asp,plot,underscore){
+ if(split.vertical&&!setEnv){
+ cat("split.vertical requires setEnv=TRUE. Setting split.vertical to FALSE.\n")
+ spit.vertical<-FALSE
+ }
+ # set offset fudge (empirically determined)
+ offsetFudge<-1.37
+ # reorder
+ cw<-reorderSimmap(tree)
+ pw<-reorderSimmap(tree,"postorder")
+ # count nodes and tips
+ n<-Ntip(cw)
+ m<-cw$Nnode
+ # Y coordinates for nodes
+ Y<-matrix(NA,m+n,1)
+ # first, assign y coordinates to all the tip nodes
+ if(is.null(tips)) Y[cw$edge[cw$edge[,2]<=n,2]]<-1:n
+ else Y[cw$edge[cw$edge[,2]<=n,2]]<-if(is.null(names(tips)))
+ tips[sapply(1:Ntip(cw),function(x,y) which(y==x),y=cw$edge[cw$edge[,2]<=n,2])]
+ else if(!underscore) tips[gsub(" ","_",cw$tip.label)]
+ # get Y coordinates of the nodes
+ nodes<-unique(pw$edge[,1])
+ for(i in 1:m){
+ if(placement=="intermediate"){
+ desc<-pw$edge[which(pw$edge[,1]==nodes[i]),2]
+ Y[nodes[i]]<-(min(Y[desc])+max(Y[desc]))/2
+ } else if(placement=="centered"){
+ desc<-getDescendants(pw,nodes[i])
+ desc<-desc[desc<=Ntip(pw)]
+ Y[nodes[i]]<-(min(Y[desc])+max(Y[desc]))/2
+ } else if(placement=="weighted"){
+ desc<-pw$edge[which(pw$edge[,1]==nodes[i]),2]
+ n1<-desc[which(Y[desc]==min(Y[desc]))]
+ n2<-desc[which(Y[desc]==max(Y[desc]))]
+ v1<-pw$edge.length[which(pw$edge[,2]==n1)]
+ v2<-pw$edge.length[which(pw$edge[,2]==n2)]
+ Y[nodes[i]]<-((1/v1)*Y[n1]+(1/v2)*Y[n2])/(1/v1+1/v2)
+ } else if(placement=="inner"){
+ desc<-getDescendants(pw,nodes[i])
+ desc<-desc[desc<=Ntip(pw)]
+ mm<-which(abs(Y[desc]-median(Y[1:Ntip(pw)]))==min(abs(Y[desc]-
+ median(Y[1:Ntip(pw)]))))
+ if(length(mm>1)) mm<-mm[which(Y[desc][mm]==min(Y[desc][mm]))]
+ Y[nodes[i]]<-Y[desc][mm]
+ }
+ }
+ # compute node heights
+ H<-nodeHeights(cw)
+ # open plot
+ par(mar=mar)
+ if(is.null(offset)) offset<-0.2*lwd/3+0.2/3
+ if(!add) plot.new()
+ ###
+ if(is.null(ylim)){
+ pp<-par("pin")[2]
+ sw<-fsize*(max(strwidth(cw$tip.label,units="inches")))+
+ offsetFudge*fsize*strwidth("W",units="inches")
+ alp<-optimize(function(a,H,sw,pp) (a*1.04*max(H)+sw-pp)^2,H=H,sw=sw,pp=pp,
+ interval=c(0,1e6))$minimum
+ ylim<-if(direction=="downwards") c(min(H)-sw/alp,max(H)) else c(min(H),max(H)+sw/alp)
+ }
+ if(is.null(xlim)) xlim=range(Y)
+ if(direction=="downwards") H<-max(H)-H
+ plot.window(xlim=xlim,ylim=ylim,asp=asp)
+ ####
+ if(plot){
+ if(!split.vertical){
+ for(i in 1:m) lines(Y[cw$edge[which(cw$edge[,1]==nodes[i]),2]],
+ H[which(cw$edge[,1]==nodes[i]),1],
+ col=colors[names(cw$maps[[match(nodes[i],
+ cw$edge[,1])]])[1]],lwd=lwd,lend=lend)
+ }
+ for(i in 1:nrow(cw$edge)){
+ x<-H[i,1]
+ for(j in 1:length(cw$maps[[i]])){
+ if(direction=="downwards")
+ lines(c(Y[cw$edge[i,2]],Y[cw$edge[i,2]]),c(x,x-cw$maps[[i]][j]),
+ col=colors[names(cw$maps[[i]])[j]],lwd=lwd,lend=lend)
+ else lines(c(Y[cw$edge[i,2]],Y[cw$edge[i,2]]),c(x,x+cw$maps[[i]][j]),
+ col=colors[names(cw$maps[[i]])[j]],lwd=lwd,lend=lend)
+ if(pts) points(c(Y[cw$edge[i,2]],Y[cw$edge[i,2]]),c(x,x+cw$maps[[i]][j]),
+ pch=20,lwd=(lwd-1))
+ x<-x+if(direction=="downwards") -cw$maps[[i]][j] else cw$maps[[i]][j]
+ j<-j+1
+ }
+ }
+ if(node.numbers){
+ symbols(mean(Y[cw$edge[cw$edge[,1]==(Ntip(cw)+1),2]]),
+ if(direction=="downwards") max(H) else 0,
+ rectangles=matrix(c(1.2*fsize*strwidth(as.character(Ntip(cw)+1)),
+ 1.4*fsize*strheight(as.character(Ntip(cw)+1))),1,2),inches=FALSE,
+ bg="white",add=TRUE)
+ text(mean(Y[cw$edge[cw$edge[,1]==(Ntip(cw)+1),2]]),
+ if(direction=="downwards") max(H) else 0,Ntip(cw)+1,
+ cex=fsize)
+ for(i in 1:nrow(cw$edge)){
+ x<-H[i,2]
+ if(cw$edge[i,2]>Ntip(cw)){
+ symbols(Y[cw$edge[i,2]],x,
+ rectangles=matrix(c(1.2*fsize*strwidth(as.character(cw$edge[i,2])),
+ 1.4*fsize*strheight(as.character(cw$edge[i,2]))),1,2),inches=FALSE,
+ bg="white",add=TRUE)
+ text(Y[cw$edge[i,2]],x,cw$edge[i,2],cex=fsize)
+ }
+ }
+ }
+ if(direction=="downwards") pos<-if(par()$usr[3]>par()$usr[4]) 2 else 4
+ if(direction=="upwards") pos<-if(par()$usr[3]>par()$usr[4]) 2 else 4
+ for(i in 1:n){
+ shift<-offset*fsize*strwidth("W")*(diff(par()$usr[3:4])/diff(par()$usr[1:2]))
+ if((direction=="downwards"&&diff(par()$usr[3:4])>0) ||
+ (direction=="upwards"&&diff(par()$usr[3:4])<0)) shift<--shift
+ if(ftype){
+ text(labels=cw$tip.label[i],Y[i],
+ H[which(cw$edge[,2]==i),2]+shift,
+ pos=pos,offset=0,cex=fsize,font=ftype,
+ srt=if(direction=="downwards") 270 else 90)
+ }
+ }
+ }
+ if(setEnv){
+ PP<-list(type="phylogram",use.edge.length=TRUE,node.pos=1,
+ show.tip.label=if(ftype) TRUE else FALSE,show.node.label=FALSE,
+ font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE,label.offset=offset,
+ x.lim=xlim,y.lim=ylim,
+ direction=direction,tip.color="black",Ntip=Ntip(cw),Nnode=cw$Nnode,
+ edge=cw$edge,xx=Y[,1],yy=sapply(1:(Ntip(cw)+cw$Nnode),
+ function(x,y,z) y[match(x,z)],y=H,z=cw$edge))
+ assign("last_plot.phylo",PP,envir=.PlotPhyloEnv)
+ }
+ if(plot) if(split.vertical) splitEdgeColor(cw,colors,lwd)
+}
+
+# function to plot simmap tree in type "phylogram"
+# written by Liam J. Revell 2011-2023
+plotPhylogram<-function(tree,colors,fsize,ftype,lwd,pts,node.numbers,mar,
+ add,offset,direction,setEnv,xlim,ylim,placement,tips,split.vertical,lend,
+ asp,plot,underscore){
+ if(split.vertical&&!setEnv){
+ cat("split.vertical requires setEnv=TRUE. Setting split.vertical to FALSE.\n")
+ spit.vertical<-FALSE
+ }
+ # set offset fudge (empirically determined)
+ offsetFudge<-1.37
+ # reorder
+ cw<-reorderSimmap(tree)
+ pw<-reorderSimmap(tree,"postorder")
+ # count nodes and tips
+ n<-Ntip(cw)
+ m<-cw$Nnode
+ # Y coordinates for nodes
+ Y<-matrix(NA,m+n,1)
+ # first, assign y coordinates to all the tip nodes
+ if(is.null(tips)) Y[cw$edge[cw$edge[,2]<=n,2]]<-1:n
+ else Y[cw$edge[cw$edge[,2]<=n,2]]<-if(is.null(names(tips)))
+ tips[sapply(1:Ntip(cw),function(x,y) which(y==x),y=cw$edge[cw$edge[,2]<=n,2])]
+ else if(!underscore) tips[gsub(" ","_",cw$tip.label)]
+ # get Y coordinates of the nodes
+ nodes<-unique(pw$edge[,1])
+ for(i in 1:m){
+ if(placement=="intermediate"){
+ desc<-pw$edge[which(pw$edge[,1]==nodes[i]),2]
+ Y[nodes[i]]<-(min(Y[desc])+max(Y[desc]))/2
+ } else if(placement=="centered"){
+ desc<-getDescendants(pw,nodes[i])
+ desc<-desc[desc<=Ntip(pw)]
+ Y[nodes[i]]<-(min(Y[desc])+max(Y[desc]))/2
+ } else if(placement=="weighted"){
+ desc<-pw$edge[which(pw$edge[,1]==nodes[i]),2]
+ n1<-desc[which(Y[desc]==min(Y[desc]))]
+ n2<-desc[which(Y[desc]==max(Y[desc]))]
+ v1<-pw$edge.length[which(pw$edge[,2]==n1)]
+ v2<-pw$edge.length[which(pw$edge[,2]==n2)]
+ Y[nodes[i]]<-((1/v1)*Y[n1]+(1/v2)*Y[n2])/(1/v1+1/v2)
+ } else if(placement=="inner"){
+ desc<-getDescendants(pw,nodes[i])
+ desc<-desc[desc<=Ntip(pw)]
+ mm<-which(abs(Y[desc]-median(Y[1:Ntip(pw)]))==min(abs(Y[desc]-
+ median(Y[1:Ntip(pw)]))))
+ if(length(mm>1)) mm<-mm[which(Y[desc][mm]==min(Y[desc][mm]))]
+ Y[nodes[i]]<-Y[desc][mm]
+ }
+ }
+ # compute node heights
+ H<-nodeHeights(cw)
+ # open plot
+ par(mar=mar)
+ if(is.null(offset)) offset<-0.2*lwd/3+0.2/3
+ if(!add) plot.new()
+ ###
+ if(is.null(xlim)){
+ pp<-par("pin")[1]
+ sw<-fsize*(max(strwidth(cw$tip.label,units="inches")))+
+ offsetFudge*fsize*strwidth("W",units="inches")
+ alp<-optimize(function(a,H,sw,pp) (a*1.04*max(H)+sw-pp)^2,H=H,sw=sw,pp=pp,
+ interval=c(0,1e6))$minimum
+ xlim<-if(direction=="leftwards") c(min(H)-sw/alp,max(H)) else c(min(H),max(H)+sw/alp)
+ }
+ if(is.null(ylim)) ylim=range(Y)
+ if(direction=="leftwards") H<-max(H)-H
+ plot.window(xlim=xlim,ylim=ylim,asp=asp)
+ if(plot){
+ ####
+ if(!split.vertical){
+ for(i in 1:m) lines(H[which(cw$edge[,1]==nodes[i]),1],
+ Y[cw$edge[which(cw$edge[,1]==nodes[i]),2]],col=colors[names(cw$maps[[match(nodes[i],
+ cw$edge[,1])]])[1]],lwd=lwd,lend=lend)
+ }
+ for(i in 1:nrow(cw$edge)){
+ x<-H[i,1]
+ for(j in 1:length(cw$maps[[i]])){
+ if(direction=="leftwards")
+ lines(c(x,x-cw$maps[[i]][j]),c(Y[cw$edge[i,2]],Y[cw$edge[i,2]]),
+ col=colors[names(cw$maps[[i]])[j]],lwd=lwd,lend=lend)
+ else lines(c(x,x+cw$maps[[i]][j]),c(Y[cw$edge[i,2]],Y[cw$edge[i,2]]),
+ col=colors[names(cw$maps[[i]])[j]],lwd=lwd,lend=lend)
+ if(pts) points(c(x,x+cw$maps[[i]][j]),c(Y[cw$edge[i,2]],Y[cw$edge[i,2]]),
+ pch=20,lwd=(lwd-1))
+ x<-x+if(direction=="leftwards") -cw$maps[[i]][j] else cw$maps[[i]][j]
+ j<-j+1
+ }
+ }
+ if(node.numbers){
+ symbols(if(direction=="leftwards") max(H) else 0,
+ mean(Y[cw$edge[cw$edge[,1]==(Ntip(cw)+1),2]]),
+ rectangles=matrix(c(1.2*fsize*strwidth(as.character(Ntip(cw)+1)),
+ 1.4*fsize*strheight(as.character(Ntip(cw)+1))),1,2),inches=FALSE,
+ bg="white",add=TRUE)
+ text(if(direction=="leftwards") max(H) else 0,
+ mean(Y[cw$edge[cw$edge[,1]==(Ntip(cw)+1),2]]),Ntip(cw)+1,
+ cex=fsize)
+ for(i in 1:nrow(cw$edge)){
+ x<-H[i,2]
+ if(cw$edge[i,2]>Ntip(cw)){
+ symbols(x,Y[cw$edge[i,2]],
+ rectangles=matrix(c(1.2*fsize*strwidth(as.character(cw$edge[i,2])),
+ 1.4*fsize*strheight(as.character(cw$edge[i,2]))),1,2),inches=FALSE,
+ bg="white",add=TRUE)
+ text(x,Y[cw$edge[i,2]],cw$edge[i,2],cex=fsize)
+ }
+ }
+ }
+ if(direction=="leftwards") pos<-if(par()$usr[1]>par()$usr[2]) 4 else 2
+ if(direction=="rightwards") pos<-if(par()$usr[1]>par()$usr[2]) 2 else 4
+ for(i in 1:n) if(ftype) text(H[which(cw$edge[,2]==i),2],Y[i],cw$tip.label[i],pos=pos,
+ offset=offset,cex=fsize,font=ftype)
+ }
+ if(setEnv){
+ PP<-list(type="phylogram",use.edge.length=TRUE,node.pos=1,
+ show.tip.label=if(ftype) TRUE else FALSE,show.node.label=FALSE,
+ font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE,label.offset=offset,
+ x.lim=xlim,y.lim=ylim,
+ direction=direction,tip.color="black",Ntip=Ntip(cw),Nnode=cw$Nnode,
+ edge=cw$edge,xx=sapply(1:(Ntip(cw)+cw$Nnode),
+ function(x,y,z) y[match(x,z)],y=H,z=cw$edge),yy=Y[,1])
+ assign("last_plot.phylo",PP,envir=.PlotPhyloEnv)
+ }
+ if(plot) if(split.vertical) splitEdgeColor(cw,colors,lwd)
+}
+
+# function to plot simmap tree in type "fan"
+# written by Liam J. Revell 2013-2017
+plotFan<-function(tree,colors,fsize,ftype,lwd,mar,add,part,setEnv,xlim,ylim,tips,maxY,lend,plot,offset){
+ if(!plot) cat("plot=FALSE option is not permitted for type=\"fan\". Tree will be plotted.\n")
+ if(is.null(offset)) offset<-1
+ # reorder
+ cw<-reorder(tree)
+ pw<-reorder(tree,"pruningwise")
+ # count nodes and tips
+ n<-Ntip(cw)
+ m<-cw$Nnode
+ # get Y coordinates on uncurved space
+ Y<-vector(length=m+n)
+ if(is.null(tips)) tips<-1:n
+ if(part<1.0) Y[cw$edge[cw$edge[,2]<=n,2]]<-0:(n-1)
+ else Y[cw$edge[cw$edge[,2]<=n,2]]<-tips
+ nodes<-unique(pw$edge[,1])
+ for(i in 1:m){
+ desc<-pw$edge[which(pw$edge[,1]==nodes[i]),2]
+ Y[nodes[i]]<-(min(Y[desc])+max(Y[desc]))/2
+ }
+ if(is.null(maxY)) maxY<-max(Y)
+ Y<-setNames(Y/maxY*2*pi,1:(n+m))
+ Y<-part*cbind(Y[as.character(cw$edge[,2])],Y[as.character(cw$edge[,2])])
+ R<-nodeHeights(cw)
+ # now put into a circular coordinate system
+ x<-R*cos(Y)
+ y<-R*sin(Y)
+ # optimize x & y limits
+ par(mar=mar)
+ offsetFudge<-1.37 # empirically determined
+ OFFSET<-0
+ pp<-par("pin")[1]
+ sw<-fsize*(max(strwidth(cw$tip.label,units="inches")))+
+ offsetFudge*OFFSET*fsize*strwidth("W",units="inches")
+ alp<-optimize(function(a,H,sw,pp) (2*a*1.04*max(H)+2*sw-pp)^2,H=R,sw=sw,pp=pp,
+ interval=c(0,1e6))$minimum
+ if(part<=0.25) x.lim<-y.lim<-c(0,max(R)+sw/alp)
+ else if(part>0.25&&part<=0.5){
+ x.lim<-c(-max(R)-sw/alp,max(R)+sw/alp)
+ y.lim<-c(0,max(R)+sw/alp)
+ } else x.lim<-y.lim<-c(-max(R)-sw/alp,max(R)+sw/alp)
+ if(is.null(xlim)) xlim<-x.lim
+ if(is.null(ylim)) ylim<-y.lim
+ # plot tree
+ if(!add) plot.new()
+ plot.window(xlim=xlim,ylim=ylim,asp=1)
+ # plot radial lines (edges)
+ ## first, the lines emerging from the root (if there are only two):
+ jj<-which(cw$edge[,1]==(Ntip(cw)+1))
+ if(length(jj)==2){
+ m.left<-cumsum(cw$maps[[jj[1]]])/sum(cw$maps[[jj[1]]])
+ xx.left<-c(x[jj[1],1],x[jj[1],1]+(x[jj[1],2]-x[jj[1],1])*m.left)
+ yy.left<-c(y[jj[1],1],y[jj[1],1]+(y[jj[1],2]-y[jj[1],1])*m.left)
+ m.right<-cumsum(cw$maps[[jj[2]]])/sum(cw$maps[[jj[2]]])
+ xx.right<-c(x[jj[2],1],x[jj[2],1]+(x[jj[2],2]-x[jj[2],1])*m.right)
+ yy.right<-c(y[jj[2],1],y[jj[2],1]+(y[jj[2],2]-y[jj[2],1])*m.right)
+ xx<-c(xx.left[length(xx.left):1],xx.right[2:length(xx.right)])
+ yy<-c(yy.left[length(yy.left):1],yy.right[2:length(yy.right)])
+ col<-colors[c(names(m.left)[length(m.left):1],names(m.right))]
+ segments(xx[2:length(xx)-1],yy[2:length(yy)-1],xx[2:length(xx)],yy[2:length(yy)],
+ col=col,lwd=lwd,lend=lend)
+ } else jj<-NULL
+ for(i in 1:nrow(cw$edge)){
+ if(i%in%jj==FALSE){
+ maps<-cumsum(cw$maps[[i]])/sum(cw$maps[[i]])
+ xx<-c(x[i,1],x[i,1]+(x[i,2]-x[i,1])*maps)
+ yy<-c(y[i,1],y[i,1]+(y[i,2]-y[i,1])*maps)
+ for(i in 1:(length(xx)-1)) lines(xx[i+0:1],yy[i+0:1],col=colors[names(maps)[i]],
+ lwd=lwd,lend=lend)
+ }
+ }
+ # plot circular lines
+ for(i in 1:m+n){
+ r<-R[match(i,cw$edge)]
+ a1<-min(Y[which(cw$edge==i)])
+ a2<-max(Y[which(cw$edge==i)])
+ draw.arc(0,0,r,a1,a2,lwd=lwd,col=colors[names(cw$maps[[match(i,cw$edge[,1])]])[1]])
+ }
+ # plot labels
+ for(i in 1:n){
+ ii<-which(cw$edge[,2]==i)
+ aa<-Y[ii,2]/(2*pi)*360
+ adj<-if(aa>90&&aa<270) c(1,0.25) else c(0,0.25)
+ tt<-if(aa>90&&aa<270) paste(cw$tip.label[i],paste(rep(" ",offset),
+ collapse=""),sep="") else paste(paste(rep(" ",offset),collapse=""),
+ cw$tip.label[i],sep="")
+ aa<-if(aa>90&&aa<270) 180+aa else aa
+ if(ftype) text(x[ii,2],y[ii,2],tt,srt=aa,adj=adj,cex=fsize,font=ftype)
+ }
+ if(setEnv){
+ PP<-list(type="fan",use.edge.length=TRUE,node.pos=1,
+ show.tip.label=if(ftype) TRUE else FALSE,show.node.label=FALSE,
+ font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE,label.offset=offset,
+ x.lim=xlim,y.lim=ylim,direction="rightwards",tip.color="black",
+ Ntip=Ntip(cw),Nnode=cw$Nnode,edge=cw$edge,
+ xx=c(x[sapply(1:n,function(x,y) which(x==y)[1],y=cw$edge[,2]),2],x[1,1],
+ if(m>1) x[sapply(2:m+n,function(x,y) which(x==y)[1],y=cw$edge[,2]),2] else c()),
+ yy=c(y[sapply(1:n,function(x,y) which(x==y)[1],y=cw$edge[,2]),2],y[1,1],
+ if(m>1) y[sapply(2:m+n,function(x,y) which(x==y)[1],y=cw$edge[,2]),2] else c()))
+ assign("last_plot.phylo",PP,envir=.PlotPhyloEnv)
+ }
+}
+
+## internal function for slanted cladogram
+## written by Liam J. Revell 2017-2023
+plotCladogram<-function(tree,colors=NULL,fsize=1.0,ftype="reg",lwd=2,mar=NULL,
+ add=FALSE,offset=NULL,direction="rightwards",xlim=NULL,ylim=NULL,
+ nodes="intermediate",tips=NULL,lend=2,asp=NA,plot=TRUE,underscore=FALSE){
+ placement<-nodes
+ # set offset fudge (empirically determined)
+ offsetFudge<-1.37
+ # reorder
+ cw<-reorderSimmap(tree)
+ pw<-reorderSimmap(tree,"postorder")
+ # count nodes and tips
+ n<-Ntip(cw)
+ m<-cw$Nnode
+ # Y coordinates for nodes
+ Y<-matrix(NA,m+n,1)
+ # first, assign y coordinates to all the tip nodes
+ if(is.null(tips)) Y[cw$edge[cw$edge[,2]<=n,2]]<-1:n
+ else Y[cw$edge[cw$edge[,2]<=n,2]]<-if(is.null(names(tips)))
+ tips[sapply(1:Ntip(cw),function(x,y) which(y==x),y=cw$edge[cw$edge[,2]<=n,2])]
+ else if(!underscore) tips[gsub(" ","_",cw$tip.label)]
+ # get Y coordinates of the nodes
+ nodes<-unique(pw$edge[,1])
+ for(i in 1:m){
+ if(placement=="intermediate"){
+ desc<-pw$edge[which(pw$edge[,1]==nodes[i]),2]
+ Y[nodes[i]]<-(min(Y[desc])+max(Y[desc]))/2
+ } else if(placement=="centered"){
+ desc<-getDescendants(pw,nodes[i])
+ desc<-desc[desc<=Ntip(pw)]
+ Y[nodes[i]]<-(min(Y[desc])+max(Y[desc]))/2
+ } else if(placement=="weighted"){
+ desc<-pw$edge[which(pw$edge[,1]==nodes[i]),2]
+ n1<-desc[which(Y[desc]==min(Y[desc]))]
+ n2<-desc[which(Y[desc]==max(Y[desc]))]
+ v1<-pw$edge.length[which(pw$edge[,2]==n1)]
+ v2<-pw$edge.length[which(pw$edge[,2]==n2)]
+ Y[nodes[i]]<-((1/v1)*Y[n1]+(1/v2)*Y[n2])/(1/v1+1/v2)
+ } else if(placement=="inner"){
+ desc<-getDescendants(pw,nodes[i])
+ desc<-desc[desc<=Ntip(pw)]
+ mm<-which(abs(Y[desc]-median(Y[1:Ntip(pw)]))==min(abs(Y[desc]-
+ median(Y[1:Ntip(pw)]))))
+ if(length(mm>1)) mm<-mm[which(Y[desc][mm]==min(Y[desc][mm]))]
+ Y[nodes[i]]<-Y[desc][mm]
+ }
+ }
+ # compute node heights
+ H<-nodeHeights(cw)
+ # open plot
+ par(mar=mar)
+ if(is.null(offset)) offset<-0.2*lwd/3+0.2/3
+ if(!add) plot.new()
+ ###
+ if(is.null(xlim)){
+ pp<-par("pin")[1]
+ sw<-fsize*(max(strwidth(cw$tip.label,units="inches")))+
+ offsetFudge*fsize*strwidth("W",units="inches")
+ alp<-optimize(function(a,H,sw,pp) (a*1.04*max(H)+sw-pp)^2,H=H,sw=sw,pp=pp,
+ interval=c(0,1e6))$minimum
+ xlim<-if(direction=="leftwards") c(min(H)-sw/alp,max(H)) else c(min(H),max(H)+sw/alp)
+ }
+ if(is.null(ylim)) ylim=range(Y)
+ if(direction=="leftwards") H<-max(H)-H
+ plot.window(xlim=xlim,ylim=ylim,asp=asp)
+ if(plot){
+ ####
+ for(i in 1:nrow(cw$edge)){
+ x<-H[i,1]
+ y<-Y[cw$edge[i,1]]
+ m<-(Y[cw$edge[i,2]]-Y[cw$edge[i,1]])/(H[i,2]-H[i,1])
+ if(is.finite(m)){
+ for(j in 1:length(cw$maps[[i]])){
+ if(direction=="leftwards")
+ lines(c(x,x-cw$maps[[i]][j]),c(y,y-cw$maps[[i]][j]*m),
+ col=colors[names(cw$maps[[i]])[j]],lwd=lwd,lend=lend)
+ else lines(c(x,x+cw$maps[[i]][j]),c(y,y+cw$maps[[i]][j]*m),
+ col=colors[names(cw$maps[[i]])[j]],lwd=lwd,lend=lend)
+ x<-x+if(direction=="leftwards") -cw$maps[[i]][j] else cw$maps[[i]][j]
+ y<-y+if(direction=="leftwards") -m*cw$maps[[i]][j] else m*cw$maps[[i]][j]
+ j<-j+1
+ }
+ } else {
+ lines(rep(x,2),Y[cw$edge[i,]],col=colors[names(cw$maps[[i]])[1]],lwd=lwd,
+ lend=lend)
+ }
+ }
+ if(direction=="leftwards") pos<-if(par()$usr[1]>par()$usr[2]) 4 else 2
+ if(direction=="rightwards") pos<-if(par()$usr[1]>par()$usr[2]) 2 else 4
+ for(i in 1:n) if(ftype) text(H[which(cw$edge[,2]==i),2],Y[i],cw$tip.label[i],pos=pos,
+ offset=offset,cex=fsize,font=ftype)
+ }
+ PP<-list(type="phylogram",use.edge.length=TRUE,node.pos=1,
+ show.tip.label=if(ftype) TRUE else FALSE,show.node.label=FALSE,
+ font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE,label.offset=offset,
+ x.lim=xlim,y.lim=ylim,
+ direction=direction,tip.color="black",Ntip=Ntip(cw),Nnode=cw$Nnode,
+ edge=cw$edge,xx=sapply(1:(Ntip(cw)+cw$Nnode),
+ function(x,y,z) y[match(x,z)],y=H,z=cw$edge),yy=Y[,1])
+ assign("last_plot.phylo",PP,envir=.PlotPhyloEnv)
+}
+
+
+## adds legend to an open stochastic map style plot
+## written by Liam J. Revell 2013, 2016, 2017
+add.simmap.legend<-function(leg=NULL,colors,prompt=TRUE,vertical=TRUE,...){
+ if(hasArg(shape)) shape<-list(...)$shape
+ else shape<-"square"
+ if(prompt){
+ cat("Click where you want to draw the legend\n")
+ x<-unlist(locator(1))
+ y<-x[2]
+ x<-x[1]
+ } else {
+ if(hasArg(x)) x<-list(...)$x
+ else x<-0
+ if(hasArg(y)) y<-list(...)$y
+ else y<-0
+ }
+ if(hasArg(fsize)) fsize<-list(...)$fsize
+ else fsize<-1.0
+ if(is.null(leg)) leg<-names(colors)
+ h<-fsize*strheight(LETTERS[1])
+ w<-par()$mfcol[2]*h*abs(diff(par()$usr[1:2])/diff(par()$usr[3:4]))
+ flipped<-par()$usr[1]>par()$usr[2]
+ if(vertical){
+ y<-y-0:(length(leg)-1)*1.5*h
+ x<-rep(x+w/2,length(y))
+ text(x + if(flipped) -w else w,y,leg,pos=4,cex=fsize/par()$cex)
+ } else {
+ sp<-abs(fsize*max(strwidth(leg)))
+ x<-x + if(flipped) w/2-0:(length(leg)-1)*1.5*(sp+w) else -w/2+0:(length(leg)-1)*1.5*(sp+w)
+ y<-rep(y+w/2,length(x))
+ text(x,y,leg,pos=4,cex=fsize/par()$cex)
+ }
+ if(shape=="square") symbols(x,y,squares=rep(w,length(x)),bg=colors,add=TRUE,inches=FALSE)
+ else if(shape=="circle") nulo<-mapply(draw.circle,x=x,y=y,col=colors,
+ MoreArgs=list(nv=200,radius=w/2))
+ else stop(paste("shape=\"",shape,"\" is not a recognized option.",sep=""))
+}
+
+# function plots a tree; in the new version this is just a wrapper for plotSimmap
+# written by Liam Revell 2012-2017
+plotTree<-function(tree,...){
+ if(hasArg(color)) color<-list(...)$color
+ else color<-NULL
+ if(hasArg(fsize)) fsize<-list(...)$fsize
+ else fsize<-1.0
+ if(hasArg(ftype)) ftype<-list(...)$ftype
+ else ftype<-"reg"
+ if(hasArg(lwd)) lwd<-list(...)$lwd
+ else lwd<-2
+ if(hasArg(pts)) pts<-list(...)$pts
+ else pts<-FALSE
+ if(hasArg(node.numbers)) node.numbers<-list(...)$node.numbers
+ else node.numbers<-FALSE
+ if(hasArg(mar)) mar<-list(...)$mar
+ else mar<-NULL
+ if(hasArg(add)) add<-list(...)$add
+ else add<-FALSE
+ if(hasArg(offset)) offset<-list(...)$offset
+ else offset<-NULL
+ if(hasArg(type)) type<-list(...)$type
+ else type<-"phylogram"
+ if(hasArg(direction)) direction<-list(...)$direction
+ else direction<-"rightwards"
+ if(hasArg(setEnv)) setEnv<-list(...)$setEnv
+ else setEnv<-TRUE
+ if(hasArg(part)) part<-list(...)$part
+ else part<-1.0
+ if(hasArg(xlim)) xlim<-list(...)$xlim
+ else xlim<-NULL
+ if(hasArg(ylim)) ylim<-list(...)$ylim
+ else ylim<-NULL
+ if(hasArg(nodes)) nodes<-list(...)$nodes
+ else nodes<-"intermediate"
+ if(hasArg(tips)) tips<-list(...)$tips
+ else tips<-NULL
+ if(hasArg(maxY)) maxY<-list(...)$maxY
+ else maxY<-NULL
+ if(hasArg(hold)) hold<-list(...)$hold
+ else hold<-TRUE
+ if(hasArg(lend)) lend<-list(...)$lend
+ else lend<-2
+ if(hasArg(asp)) asp<-list(...)$asp
+ else asp<-NA
+ if(hasArg(plot)) plot<-list(...)$plot
+ else plot<-TRUE
+ if(hasArg(underscore)) underscore<-list(...)$underscore
+ else underscore=FALSE
+ if(inherits(tree,"multiPhylo")){
+ par(ask=TRUE)
+ if(!is.null(color)) names(color)<-"1"
+ for(i in 1:length(tree)) plotTree(tree[[i]],color=color,fsize=fsize,ftype=ftype,
+ lwd=lwd,pts=pts,node.numbers=node.numbers,mar=mar,add=add,offset=offset,
+ direction=direction,type=type,setEnv=setEnv,part=part,xlim=xlim,ylim=ylim,
+ nodes=nodes,tips=tips,maxY=maxY,hold=hold,lend=lend,asp=asp,plot=plot,
+ underscore=underscore)
+ } else {
+ if(is.null(tree$edge.length)) tree<-compute.brlen(tree)
+ tree$maps<-as.list(tree$edge.length)
+ for(i in 1:length(tree$maps)) names(tree$maps[[i]])<-c("1")
+ if(!is.null(color)) names(color)<-"1"
+ plotSimmap(tree,colors=color,fsize=fsize,ftype=ftype,lwd=lwd,pts=pts,
+ node.numbers=node.numbers,mar=mar,add=add,offset=offset,direction=direction,
+ type=type,setEnv=setEnv,part=part,xlim=xlim,ylim=ylim,nodes=nodes,tips=tips,maxY=maxY,
+ hold=hold,lend=lend,asp=asp,plot=plot,underscore=underscore)
+ }
+}
+
+## S3 method for objects of class "simmap" & "multiSimmap"
+## added by Liam J. Revell 2015
+plot.simmap<-function(x,...) plotSimmap(x,...)
+plot.multiSimmap<-function(x,...) plotSimmap(x,...)
+
+## function to split vertical plotted lines by the states of daughter edges
+## written by Liam J. Revell 2015
+splitEdgeColor<-function(tree,colors,lwd=2){
+ obj<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ for(i in 1:tree$Nnode+Ntip(tree)){
+ daughters<-tree$edge[which(tree$edge[,1]==i),2]
+ cols<-vector()
+ for(j in 1:length(daughters)){
+ jj<-which(tree$edge[,2]==daughters[j])
+ cols[j]<-if(tree$maps[[jj]][1]==0&&length(tree$maps[[jj]])>1) colors[names(tree$maps[[jj]])[2]]
+ else colors[names(tree$maps[[jj]])[1]]
+ }
+ ii<-order(obj$yy[c(i,daughters)])
+ jj<-order(obj$yy[daughters])
+ x0<-x1<-rep(obj$xx[i],length(daughters))
+ y0<-obj$yy[c(i,daughters)][ii][1:length(daughters)]
+ y1<-obj$yy[c(i,daughters)][ii][2:(length(daughters)+1)]
+ cols<-cols[jj]
+ for(j in 1:length(x0)) segments(x0[j],y0[j],x1[j],y1[j],col=cols[j],lwd=lwd,lend=2)
+ }
+}
+
+
diff --git a/R/plotTree.datamatrix.R b/R/plotTree.datamatrix.R
index c839ed1..06d56e9 100644
--- a/R/plotTree.datamatrix.R
+++ b/R/plotTree.datamatrix.R
@@ -1,79 +1,79 @@
-## function to plot a grid of discrete character data next to the tips of a tree
-## written by Liam J. Revell 2018, 2020, 2021
-
-plotTree.datamatrix<-function(tree,X,...){
- N<-Ntip(tree)
- ss<-lapply(X,function(x) levels(x))
- k<-sapply(ss,length)
- if(hasArg(fsize)) fsize<-list(...)$fsize
- else fsize<-40*par()$pin[2]/par()$pin[1]/Ntip(tree)
- if(hasArg(xexp)) xexp<-list(...)$xexp
- else xexp<-1.3
- if(hasArg(yexp)) yexp<-list(...)$yexp
- else yexp<-1.05
- if(hasArg(colors)) colors<-list(...)$colors
- else {
- chk<-.check.pkg("RColorBrewer")
- if(!chk) brewer.pal<-function(...) NULL
- else {
- if(hasArg(palettes)) palettes<-list(...)$palettes
- else {
- palettes<-c("Accent","Dark2","Paired","Pastel1","Pastel2",
- "Set1","Set2","Set3")
- }
- while(length(palettes)<length(k)) palettes<-c(palettes,palettes)
- BREWER.PAL<-function(k,pal){
- ii<-if(k==2) c(1,3) else 1:k
- brewer.pal(max(k,3),pal)[ii]
- }
- colors<-mapply(setNames,mapply(BREWER.PAL,k,
- palettes[1:length(ss)],SIMPLIFY=FALSE),ss,
- SIMPLIFY=FALSE)
- }
- }
- if(!is.list(colors)) colors<-list(colors)
- if(!is.null(colnames(X))) names(colors)<-colnames(X) else
- names(colors)<-rep("",length(colors))
- if(hasArg(sep)) sep<-list(...)$sep
- else sep<-0.5
- if(hasArg(srt)) srt<-list(...)$srt
- else srt<-60
- if(hasArg(space)) space<-list(...)$space
- else space<-0
- if(hasArg(header)) header<-list(...)$header
- else header<-TRUE
- cw<-reorder(tree,"cladewise")
- X<-X[cw$tip.label,,drop=FALSE]
- plotTree(cw,plot=FALSE,fsize=fsize)
- obj<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- plotTree(cw,lwd=1,ylim=c(0,obj$y.lim[2]*yexp),
- xlim=c(0,obj$x.lim[2]*xexp),fsize=fsize,
- ftype="off",add=TRUE)
- obj<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- h<-max(obj$xx)
- for(i in 1:Ntip(cw)){
- lines(c(obj$xx[i],h),rep(obj$yy[i],2),lty="dotted")
- text(h,obj$yy[i],sub("_"," ",cw$tip.label[i]),cex=fsize,pos=4,
- font=3,offset=0.1)
- }
- s<-max(fsize*strwidth(cw$tip.label))
- start.x<-1.05*h+s
- half<-0.5*(1-space)
- for(i in 1:ncol(X)){
- if(header) text(start.x,max(obj$yy)+1,colnames(X)[i],pos=4,srt=srt,
- cex=fsize,offset=0)
- for(j in 1:nrow(X)){
- xy<-c(start.x,obj$yy[j])
- y<-c(xy[2]-half,xy[2]+half,xy[2]+half,xy[2]-half)
- asp<-(par()$usr[2]-par()$usr[1])/(par()$usr[4]-par()$usr[3])*
- par()$pin[2]/par()$pin[1]
- x<-c(xy[1]-half*asp,xy[1]-half*asp,xy[1]+half*asp,xy[1]+half*asp)
- polygon(x,y,col=colors[[i]][as.character(X[[i]][j])])
- }
- start.x<-start.x+(1+sep)*asp
- }
- obj<-list(fsize=fsize,
- colors=colors,
- end.x=start.x)
- invisible(obj)
+## function to plot a grid of discrete character data next to the tips of a tree
+## written by Liam J. Revell 2018, 2020, 2021
+
+plotTree.datamatrix<-function(tree,X,...){
+ N<-Ntip(tree)
+ ss<-lapply(X,function(x) levels(x))
+ k<-sapply(ss,length)
+ if(hasArg(fsize)) fsize<-list(...)$fsize
+ else fsize<-40*par()$pin[2]/par()$pin[1]/Ntip(tree)
+ if(hasArg(xexp)) xexp<-list(...)$xexp
+ else xexp<-1.3
+ if(hasArg(yexp)) yexp<-list(...)$yexp
+ else yexp<-1.05
+ if(hasArg(colors)) colors<-list(...)$colors
+ else {
+ chk<-.check.pkg("RColorBrewer")
+ if(!chk) brewer.pal<-function(...) NULL
+ else {
+ if(hasArg(palettes)) palettes<-list(...)$palettes
+ else {
+ palettes<-c("Accent","Dark2","Paired","Pastel1","Pastel2",
+ "Set1","Set2","Set3")
+ }
+ while(length(palettes)<length(k)) palettes<-c(palettes,palettes)
+ BREWER.PAL<-function(k,pal){
+ ii<-if(k==2) c(1,3) else 1:k
+ brewer.pal(max(k,3),pal)[ii]
+ }
+ colors<-mapply(setNames,mapply(BREWER.PAL,k,
+ palettes[1:length(ss)],SIMPLIFY=FALSE),ss,
+ SIMPLIFY=FALSE)
+ }
+ }
+ if(!is.list(colors)) colors<-list(colors)
+ if(!is.null(colnames(X))) names(colors)<-colnames(X) else
+ names(colors)<-rep("",length(colors))
+ if(hasArg(sep)) sep<-list(...)$sep
+ else sep<-0.5
+ if(hasArg(srt)) srt<-list(...)$srt
+ else srt<-60
+ if(hasArg(space)) space<-list(...)$space
+ else space<-0
+ if(hasArg(header)) header<-list(...)$header
+ else header<-TRUE
+ cw<-reorder(tree,"cladewise")
+ X<-X[cw$tip.label,,drop=FALSE]
+ plotTree(cw,plot=FALSE,fsize=fsize)
+ obj<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ plotTree(cw,lwd=1,ylim=c(0,obj$y.lim[2]*yexp),
+ xlim=c(0,obj$x.lim[2]*xexp),fsize=fsize,
+ ftype="off",add=TRUE)
+ obj<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ h<-max(obj$xx)
+ for(i in 1:Ntip(cw)){
+ lines(c(obj$xx[i],h),rep(obj$yy[i],2),lty="dotted")
+ text(h,obj$yy[i],sub("_"," ",cw$tip.label[i]),cex=fsize,pos=4,
+ font=3,offset=0.1)
+ }
+ s<-max(fsize*strwidth(cw$tip.label))
+ start.x<-1.05*h+s
+ half<-0.5*(1-space)
+ for(i in 1:ncol(X)){
+ if(header) text(start.x,max(obj$yy)+1,colnames(X)[i],pos=4,srt=srt,
+ cex=fsize,offset=0)
+ for(j in 1:nrow(X)){
+ xy<-c(start.x,obj$yy[j])
+ y<-c(xy[2]-half,xy[2]+half,xy[2]+half,xy[2]-half)
+ asp<-(par()$usr[2]-par()$usr[1])/(par()$usr[4]-par()$usr[3])*
+ par()$pin[2]/par()$pin[1]
+ x<-c(xy[1]-half*asp,xy[1]-half*asp,xy[1]+half*asp,xy[1]+half*asp)
+ polygon(x,y,col=colors[[i]][as.character(X[[i]][j])])
+ }
+ start.x<-start.x+(1+sep)*asp
+ }
+ obj<-list(fsize=fsize,
+ colors=colors,
+ end.x=start.x)
+ invisible(obj)
}
\ No newline at end of file
diff --git a/R/plotTree.errorbars.R b/R/plotTree.errorbars.R
index fc540c3..6f07d8c 100644
--- a/R/plotTree.errorbars.R
+++ b/R/plotTree.errorbars.R
@@ -1,62 +1,62 @@
-## plot tree with error bars around divergence times at nodes
-## written by Liam J. Revell 2017
-
-plotTree.errorbars<-function(tree,CI,...){
- args<-list(...)
- if(!is.null(args$gridlines)){
- gridlines<-args$gridlines
- args$gridlines<-NULL
- } else gridlines<-TRUE
- if(is.null(args$mar)) args$mar<-c(4.1,1.1,1.1,1.1)
- if(is.null(args$ftype)) args$ftype<-"i"
- fsize<-if(!is.null(args$fsize)) args$fsize else 1
- if(is.null(args$direction)) args$direction<-"leftwards"
- if(!is.null(args$bar.width)){
- bar.width<-args$bar.width
- args$bar.width<-NULL
- } else bar.width<-11
- if(!is.null(args$cex)){
- cex<-args$cex
- args$cex<-NULL
- } else cex<-1.2
- if(!is.null(args$bar.col)){
- bar.col<-args$bar.col
- args$bar.col<-NULL
- } else bar.col<-"blue"
- par(mar=args$mar)
- plot.new()
- th<-max(nodeHeights(tree))
- h<-max(th,max(CI))
- if(is.null(args$xlim)){
- m<-min(min(nodeHeights(tree)),min(CI))
- d<-diff(c(m,h))
- pp<-par("pin")[1]
- sw<-fsize*(max(strwidth(tree$tip.label,units="inches")))+
- 1.37*fsize*strwidth("W",units="inches")
- alp<-optimize(function(a,d,sw,pp) (a*1.04*d+sw-pp)^2,
- d=d,sw=sw,pp=pp,
- interval=c(0,1e6))$minimum
- args$xlim<-if(args$direction=="leftwards") c(h,m-sw/alp) else
- c(m,h+sw/alp)
- }
- if(is.null(args$at)) at<-seq(0,h,by=h/5)
- else {
- at<-args$at
- args$at<-NULL
- }
- args$tree<-tree
- args$add<-TRUE
- do.call(plotTree,args=args)
- if(gridlines) abline(v=at,lty="dashed",
- col=make.transparent("grey",0.5))
- axis(1,at=at,labels=signif(at,3))
- obj<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- for(i in 1:tree$Nnode+Ntip(tree))
- lines(x=c(CI[i-Ntip(tree),1],CI[i-Ntip(tree),2]),
- y=rep(obj$yy[i],2),lwd=bar.width,lend=0,
- col=make.transparent(bar.col,0.4))
- points(obj$xx[1:tree$Nnode+Ntip(tree)],
- obj$yy[1:tree$Nnode+Ntip(tree)],pch=19,col=bar.col,
- cex=cex)
-}
-
+## plot tree with error bars around divergence times at nodes
+## written by Liam J. Revell 2017
+
+plotTree.errorbars<-function(tree,CI,...){
+ args<-list(...)
+ if(!is.null(args$gridlines)){
+ gridlines<-args$gridlines
+ args$gridlines<-NULL
+ } else gridlines<-TRUE
+ if(is.null(args$mar)) args$mar<-c(4.1,1.1,1.1,1.1)
+ if(is.null(args$ftype)) args$ftype<-"i"
+ fsize<-if(!is.null(args$fsize)) args$fsize else 1
+ if(is.null(args$direction)) args$direction<-"leftwards"
+ if(!is.null(args$bar.width)){
+ bar.width<-args$bar.width
+ args$bar.width<-NULL
+ } else bar.width<-11
+ if(!is.null(args$cex)){
+ cex<-args$cex
+ args$cex<-NULL
+ } else cex<-1.2
+ if(!is.null(args$bar.col)){
+ bar.col<-args$bar.col
+ args$bar.col<-NULL
+ } else bar.col<-"blue"
+ par(mar=args$mar)
+ plot.new()
+ th<-max(nodeHeights(tree))
+ h<-max(th,max(CI))
+ if(is.null(args$xlim)){
+ m<-min(min(nodeHeights(tree)),min(CI))
+ d<-diff(c(m,h))
+ pp<-par("pin")[1]
+ sw<-fsize*(max(strwidth(tree$tip.label,units="inches")))+
+ 1.37*fsize*strwidth("W",units="inches")
+ alp<-optimize(function(a,d,sw,pp) (a*1.04*d+sw-pp)^2,
+ d=d,sw=sw,pp=pp,
+ interval=c(0,1e6))$minimum
+ args$xlim<-if(args$direction=="leftwards") c(h,m-sw/alp) else
+ c(m,h+sw/alp)
+ }
+ if(is.null(args$at)) at<-seq(0,h,by=h/5)
+ else {
+ at<-args$at
+ args$at<-NULL
+ }
+ args$tree<-tree
+ args$add<-TRUE
+ do.call(plotTree,args=args)
+ if(gridlines) abline(v=at,lty="dashed",
+ col=make.transparent("grey",0.5))
+ axis(1,at=at,labels=signif(at,3))
+ obj<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ for(i in 1:tree$Nnode+Ntip(tree))
+ lines(x=c(CI[i-Ntip(tree),1],CI[i-Ntip(tree),2]),
+ y=rep(obj$yy[i],2),lwd=bar.width,lend=0,
+ col=make.transparent(bar.col,0.4))
+ points(obj$xx[1:tree$Nnode+Ntip(tree)],
+ obj$yy[1:tree$Nnode+Ntip(tree)],pch=19,col=bar.col,
+ cex=cex)
+}
+
diff --git a/R/plotTree.wBars.R b/R/plotTree.wBars.R
index de54812..571ebea 100644
--- a/R/plotTree.wBars.R
+++ b/R/plotTree.wBars.R
@@ -1,252 +1,252 @@
-## plotTree.boxplot
-## written by Liam J. Revell 2016, 2021, 2022
-
-plotTree.boxplot<-function(tree,x,args.plotTree=list(),
- args.boxplot=list(),...){
- tree<-untangle(tree,"read.tree")
- cw<-reorder(tree)
- if(!is.list(x)&&inherits(x,"formula",FALSE)){
- obj<-setNames(
- lapply(cw$tip.label,function(x,y) y[which(names(y)==x)],
- y=x),cw$tip.label)
- } else obj<-x
- if(inherits(x,"formula"))
- args.boxplot$formula<-obj else args.boxplot$x<-obj
- args.boxplot$horizontal<-TRUE
- args.boxplot$axes<-FALSE
- args.boxplot$names.arg<-""
- args.boxplot$xlim<-c(1,Ntip(cw))
- if(is.null(args.boxplot$space)) args.boxplot$space<-0.7
- if(is.null(args.boxplot$mar))
- args.boxplot$mar<-c(5.1,0,2.1,1.1)
- else args.boxplot$mar[2]<-0.1
- args.plotTree$tree<-cw
- if(is.null(args.plotTree$mar))
- args.plotTree$mar<-c(5.1,1.1,2.1,0)
- else {
- args.plotTree$mar[4]<-0
- }
- if(args.plotTree$mar[1]!=args.boxplot$mar[1])
- args.plotTree$mar[1]<-args.boxplot$mar[1]
- if(args.plotTree$mar[3]!=args.boxplot$mar[3])
- args.plotTree$mar[3]<-args.boxplot$mar[3]
- if(is.null(args.plotTree$ftype)) args.plotTree$ftype<-"i"
- if(is.null(args.plotTree$lwd)) args.plotTree$lwd<-1
- par(mfrow=c(1,2))
- ii<-which(names(args.boxplot)%in%c("formula","x"))
- args.boxplot<-c(args.boxplot[ii],args.boxplot[-ii])
- args.boxplot$plot<-FALSE
- obj<-do.call(boxplot,args.boxplot)
- N<-ncol(obj$stats)
- if(hasArg(ylim)) ylim<-list(...)$ylim
- else ylim<-c(0.5,N+0.5)
- args.boxplot$xlim<-ylim
- args.boxplot$plot<-TRUE
- args.plotTree$tips<-setNames(1:Ntip(cw),obj$names)
- args.plotTree$ylim<-ylim
- do.call(plotTree,args.plotTree)
- par(mar=args.boxplot$mar)
- ii<-which(names(args.boxplot)%in%c("formula","x"))
- args.boxplot<-c(args.boxplot[ii],args.boxplot[-ii])
- obj<-do.call(boxplot,args.boxplot)
- axis(1)
- if(!is.null(args.boxplot$xlab)) title(xlab=args.boxplot$xlab)
- else title(xlab="x")
- invisible(obj)
-}
-
-## plotTree.barplot
-## written by Liam J. Revell 2016, 2017, 2018, 2021
-
-plotTree.barplot<-function(tree,x,args.plotTree=list(),
- args.barplot=list(),...){
- tree<-untangle(tree,"read.tree")
- if(hasArg(add)) add<-list(...)$add
- else add<-FALSE
- if(hasArg(args.axis)) args.axis<-list(...)$args.axis
- else args.axis<-list()
- args.axis$side<-1
- cw<-reorder(tree)
- if(is.data.frame(x)) x<-as.matrix(x)
- if(is.matrix(x)){
- x<-x[cw$tip.label,]
- x<-t(x)
- }
- args.barplot$height<-if(is.matrix(x)) x[,cw$tip.label] else x[cw$tip.label]
- args.barplot$plot<-FALSE
- args.barplot$horiz<-TRUE
- args.barplot$axes<-FALSE
- args.barplot$names.arg<-rep("",Ntip(cw))
- if(is.null(args.barplot$beside)) args.barplot$beside<-FALSE
- if(is.null(args.barplot$space))
- args.barplot$space<-if(args.barplot$beside) c(0,1) else 0.7
- if(is.null(args.barplot$mar))
- args.barplot$mar<-c(5.1,0,2.1,1.1)
- else args.barplot$mar[2]<-0.1
- obj<-as.matrix(do.call(barplot,args.barplot))
- if(hasArg(ylim)) ylim<-list(...)$ylim
- else ylim<-c(min(obj)-mean(args.barplot$space),
- max(obj)+mean(args.barplot$space))
- if(dim(obj)[2]==1) obj<-t(obj)
- args.plotTree$tips<-setNames(colMeans(obj),cw$tip.label)
- args.barplot$plot<-TRUE
- args.barplot$ylim<-ylim
- args.plotTree$ylim<-ylim
- args.plotTree$tree<-cw
- if(is.null(args.plotTree$mar))
- args.plotTree$mar<-c(5.1,1.1,2.1,0)
- else {
- args.plotTree$mar[4]<-0.1
- }
- if(args.plotTree$mar[1]!=args.barplot$mar[1])
- args.plotTree$mar[1]<-args.barplot$mar[1]
- if(args.plotTree$mar[3]!=args.barplot$mar[3])
- args.plotTree$mar[3]<-args.barplot$mar[3]
- if(is.null(args.plotTree$ftype)) args.plotTree$ftype<-"i"
- if(is.null(args.plotTree$lwd)) args.plotTree$lwd<-1
- if(!add) par(mfrow=c(1,2))
- do.call(plotTree,args.plotTree)
- if(!is.null(args.plotTree$plot)&&args.plotTree$plot==FALSE) par(new=TRUE)
- par(mar=args.barplot$mar)
- obj<-do.call(barplot,args.barplot)
- if(!is.null(args.barplot$xlab)) args.axis$xlab<-args.barplot$xlab
- else args.axis$xlab<-"x"
- do.call(axis,args.axis)
- invisible(obj)
-}
-
-## function to plot bars at the tips of a plotted tree
-## written by Liam J. Revell 2014, 2015, 2018, 2019
-
-plotTree.wBars<-function(tree,x,scale=NULL,width=NULL,type="phylogram",
- method="plotTree",tip.labels=FALSE,col="grey",border=NULL,...){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- if(is.null(scale)){
- scale<-0.3*max(nodeHeights(tree))/diff(range(x))
- }
- if(is.matrix(x)){
- x.neg<-apply(x,1,function(x) sum(x[x<0]))
- x.pos<-apply(x,1,function(x) sum(x[x>0]))
- } else {
- d<-scale*(max(x)-min(0,min(x)))
- H<-nodeHeights(tree)
- if(tip.labels==FALSE){
- lims<-c(-max(H)-d,max(H)+d)
- sw<-0
- } else {
- if(hasArg(fsize)) fsize<-list(...)$fsize
- else fsize<-1
- if(type=="phylogram"){
- pp<-par("pin")[1]
- sw<-fsize*(max(strwidth(tree$tip.label,
- units="inches")))+1.37*fsize*strwidth("W",
- units="inches")
- alp<-optimize(function(a,H,sw,pp,d)
- (a*1.04*(max(H)+d)+sw-pp)^2,H=H,sw=sw,
- pp=pp,d=d,interval=c(0,1e6))$minimum
- lims<-c(min(H),max(H)+d+sw/alp)
- } else if(type=="fan"){
- pp<-par("pin")[1]
- sw<-fsize*(max(strwidth(tree$tip.label,
- units="inches")))+1.37*fsize*strwidth("W",
- units="inches")
- alp<-optimize(function(a,H,sw,pp,d)
- (a*2*1.04*(max(H)+d)+2*sw-pp)^2,H=H,sw=sw,pp=pp,
- d=d,interval=c(0,1e6))$minimum
- lims<-c(-max(H)-d-sw/alp,max(H)+d+sw/alp)
- }
- }
- if(hasArg(lims)) lims<-list(...)$lims
- um<-tree
- if(!is.ultrametric(um)){
- tip.h<-sapply(1:Ntip(tree),nodeheight,tree=tree)
- for(i in 1:Ntip(tree)){
- ii<-which(um$edge[,2]==i)
- um$edge.length[ii]<-um$edge.length[ii]+(max(tip.h)-tip.h[i])
- }
- }
- if(type=="phylogram"){
- fg<-par()$fg
- if(!is.ultrametric(tree)){
- plotTree(um,ftype=if(tip.labels) "i" else "off",
- xlim=c(0,lims[2]),lwd=1,color="transparent",...)
- for(i in 1:Ntip(tree)) lines(c(max(tip.h),
- tip.h[i]),rep(i,2),lty="dotted")
- add<-TRUE
- par(fg="transparent")
- } else add=FALSE
- if(method=="plotTree") capture.output(plotTree(tree,
- ftype=if(tip.labels) "i" else "off",xlim=c(0,lims[2]),
- add=add,...))
- else if(method=="plotSimmap") capture.output(plotSimmap(tree,
- ftype=if(tip.labels) "i" else "off",xlim=c(0,lims[2]),add=add,...))
- par(fg=fg)
- } else if(type=="fan"){
- fg<-par()$fg
- if(!is.ultrametric(tree)){
- plotTree(um,type="fan",ftype=if(tip.labels) "i" else "off",xlim=lims,ylim=lims,
- lwd=1,color="transparent",...)
- um<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- par(fg="transparent")
- plotTree(tree,type="fan",ftype=if(tip.labels) "i" else "off",xlim=lims,
- ylim=lims,lwd=1,color="transparent",add=TRUE,...)
- tt<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- par(fg="black",lty="solid")
- for(i in 1:Ntip(tree)) lines(c(um$xx[i],tt$xx[i]),c(um$yy[i],tt$yy[i]),lty="dotted")
- par(fg="transparent")
- add<-TRUE
- } else add<-FALSE
- if(method=="plotTree") capture.output(plotTree(tree,type="fan",
- ftype=if(tip.labels) "i" else "off",xlim=lims,ylim=lims,add=add,...))
- else if(method=="plotSimmap") capture.output(plotSimmap(tree,
- type="fan",ftype=if(tip.labels) "i" else "off",xlim=lims,
- ylim=lims,add=add,...))
- par(fg=fg)
- }
- obj<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- x<-x[tree$tip.label]*scale
- if(is.null(width))
- width<-if(type=="fan") (par()$usr[4]-par()$usr[3])/(max(c(max(x)/max(nodeHeights(tree)),1))*length(tree$tip.label))
- else if(type=="phylogram") (par()$usr[4]-par()$usr[3])/(2*length(tree$tip.label))
- w<-width
- if(length(col)<Ntip(tree)) col<-rep(col,ceiling(Ntip(tree)/length(col)))[1:Ntip(tree)]
- if(is.null(names(col))) names(col)<-tree$tip.label
- col<-col[tree$tip.label]
- if(type=="phylogram"){
- if(hasArg(direction)) direction<-list(...)$direction
- else direction<-"rightwards"
- sw<-if(tip.labels) fsize*(max(strwidth(tree$tip.label)))+fsize*strwidth("1") else strwidth("l")
- for(i in 1:length(x)){
- dx<-max(obj$xx)
- dy<-obj$yy[i]
- x1<-x2<-dx+sw
- x3<-x4<-x1+x[i]
- y1<-y4<-dy-w/2
- y2<-y3<-dy+w/2
- polygon(c(x1,x2,x3,x4)-min(0,min(x)),
- c(y1,y2,y3,y4),col=col[i],border=border)
- }
- } else if(type=="fan"){
- h<-max(nodeHeights(tree))
- sw<-if(tip.labels) fsize*(max(strwidth(tree$tip.label)))+fsize*strwidth("1") else strwidth("l")
- for(i in 1:length(x)){
- theta<-atan(obj$yy[i]/obj$xx[i])
- s<-if(obj$xx[i]>0) 1 else -1
- dx<-s*h*cos(theta)+s*cos(theta)*sw
- dy<-s*h*sin(theta)+s*sin(theta)*sw
- x1<-dx+(w/2)*cos(pi/2-theta)-s*min(0,min(x))*cos(theta)
- y1<-dy-(w/2)*sin(pi/2-theta)-s*min(0,min(x))*sin(theta)
- x2<-dx-(w/2)*cos(pi/2-theta)-s*min(0,min(x))*cos(theta)
- y2<-dy+(w/2)*sin(pi/2-theta)-s*min(0,min(x))*sin(theta)
- x3<-s*x[i]*cos(theta)+x2
- y3<-s*x[i]*sin(theta)+y2
- x4<-s*x[i]*cos(theta)+x1
- y4<-s*x[i]*sin(theta)+y1
- polygon(c(x1,x2,x3,x4),c(y1,y2,y3,y4),col=col[i],
- border=border)
- }
- }
- }
- invisible(obj)
-}
-
+## plotTree.boxplot
+## written by Liam J. Revell 2016, 2021, 2022
+
+plotTree.boxplot<-function(tree,x,args.plotTree=list(),
+ args.boxplot=list(),...){
+ tree<-untangle(tree,"read.tree")
+ cw<-reorder(tree)
+ if(!is.list(x)&&inherits(x,"formula",FALSE)){
+ obj<-setNames(
+ lapply(cw$tip.label,function(x,y) y[which(names(y)==x)],
+ y=x),cw$tip.label)
+ } else obj<-x
+ if(inherits(x,"formula"))
+ args.boxplot$formula<-obj else args.boxplot$x<-obj
+ args.boxplot$horizontal<-TRUE
+ args.boxplot$axes<-FALSE
+ args.boxplot$names.arg<-""
+ args.boxplot$xlim<-c(1,Ntip(cw))
+ if(is.null(args.boxplot$space)) args.boxplot$space<-0.7
+ if(is.null(args.boxplot$mar))
+ args.boxplot$mar<-c(5.1,0,2.1,1.1)
+ else args.boxplot$mar[2]<-0.1
+ args.plotTree$tree<-cw
+ if(is.null(args.plotTree$mar))
+ args.plotTree$mar<-c(5.1,1.1,2.1,0)
+ else {
+ args.plotTree$mar[4]<-0
+ }
+ if(args.plotTree$mar[1]!=args.boxplot$mar[1])
+ args.plotTree$mar[1]<-args.boxplot$mar[1]
+ if(args.plotTree$mar[3]!=args.boxplot$mar[3])
+ args.plotTree$mar[3]<-args.boxplot$mar[3]
+ if(is.null(args.plotTree$ftype)) args.plotTree$ftype<-"i"
+ if(is.null(args.plotTree$lwd)) args.plotTree$lwd<-1
+ par(mfrow=c(1,2))
+ ii<-which(names(args.boxplot)%in%c("formula","x"))
+ args.boxplot<-c(args.boxplot[ii],args.boxplot[-ii])
+ args.boxplot$plot<-FALSE
+ obj<-do.call(boxplot,args.boxplot)
+ N<-ncol(obj$stats)
+ if(hasArg(ylim)) ylim<-list(...)$ylim
+ else ylim<-c(0.5,N+0.5)
+ args.boxplot$xlim<-ylim
+ args.boxplot$plot<-TRUE
+ args.plotTree$tips<-setNames(1:Ntip(cw),obj$names)
+ args.plotTree$ylim<-ylim
+ do.call(plotTree,args.plotTree)
+ par(mar=args.boxplot$mar)
+ ii<-which(names(args.boxplot)%in%c("formula","x"))
+ args.boxplot<-c(args.boxplot[ii],args.boxplot[-ii])
+ obj<-do.call(boxplot,args.boxplot)
+ axis(1)
+ if(!is.null(args.boxplot$xlab)) title(xlab=args.boxplot$xlab)
+ else title(xlab="x")
+ invisible(obj)
+}
+
+## plotTree.barplot
+## written by Liam J. Revell 2016, 2017, 2018, 2021
+
+plotTree.barplot<-function(tree,x,args.plotTree=list(),
+ args.barplot=list(),...){
+ tree<-untangle(tree,"read.tree")
+ if(hasArg(add)) add<-list(...)$add
+ else add<-FALSE
+ if(hasArg(args.axis)) args.axis<-list(...)$args.axis
+ else args.axis<-list()
+ args.axis$side<-1
+ cw<-reorder(tree)
+ if(is.data.frame(x)) x<-as.matrix(x)
+ if(is.matrix(x)){
+ x<-x[cw$tip.label,]
+ x<-t(x)
+ }
+ args.barplot$height<-if(is.matrix(x)) x[,cw$tip.label] else x[cw$tip.label]
+ args.barplot$plot<-FALSE
+ args.barplot$horiz<-TRUE
+ args.barplot$axes<-FALSE
+ args.barplot$names.arg<-rep("",Ntip(cw))
+ if(is.null(args.barplot$beside)) args.barplot$beside<-FALSE
+ if(is.null(args.barplot$space))
+ args.barplot$space<-if(args.barplot$beside) c(0,1) else 0.7
+ if(is.null(args.barplot$mar))
+ args.barplot$mar<-c(5.1,0,2.1,1.1)
+ else args.barplot$mar[2]<-0.1
+ obj<-as.matrix(do.call(barplot,args.barplot))
+ if(hasArg(ylim)) ylim<-list(...)$ylim
+ else ylim<-c(min(obj)-mean(args.barplot$space),
+ max(obj)+mean(args.barplot$space))
+ if(dim(obj)[2]==1) obj<-t(obj)
+ args.plotTree$tips<-setNames(colMeans(obj),cw$tip.label)
+ args.barplot$plot<-TRUE
+ args.barplot$ylim<-ylim
+ args.plotTree$ylim<-ylim
+ args.plotTree$tree<-cw
+ if(is.null(args.plotTree$mar))
+ args.plotTree$mar<-c(5.1,1.1,2.1,0)
+ else {
+ args.plotTree$mar[4]<-0.1
+ }
+ if(args.plotTree$mar[1]!=args.barplot$mar[1])
+ args.plotTree$mar[1]<-args.barplot$mar[1]
+ if(args.plotTree$mar[3]!=args.barplot$mar[3])
+ args.plotTree$mar[3]<-args.barplot$mar[3]
+ if(is.null(args.plotTree$ftype)) args.plotTree$ftype<-"i"
+ if(is.null(args.plotTree$lwd)) args.plotTree$lwd<-1
+ if(!add) par(mfrow=c(1,2))
+ do.call(plotTree,args.plotTree)
+ if(!is.null(args.plotTree$plot)&&args.plotTree$plot==FALSE) par(new=TRUE)
+ par(mar=args.barplot$mar)
+ obj<-do.call(barplot,args.barplot)
+ if(!is.null(args.barplot$xlab)) args.axis$xlab<-args.barplot$xlab
+ else args.axis$xlab<-"x"
+ do.call(axis,args.axis)
+ invisible(obj)
+}
+
+## function to plot bars at the tips of a plotted tree
+## written by Liam J. Revell 2014, 2015, 2018, 2019
+
+plotTree.wBars<-function(tree,x,scale=NULL,width=NULL,type="phylogram",
+ method="plotTree",tip.labels=FALSE,col="grey",border=NULL,...){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ if(is.null(scale)){
+ scale<-0.3*max(nodeHeights(tree))/diff(range(x))
+ }
+ if(is.matrix(x)){
+ x.neg<-apply(x,1,function(x) sum(x[x<0]))
+ x.pos<-apply(x,1,function(x) sum(x[x>0]))
+ } else {
+ d<-scale*(max(x)-min(0,min(x)))
+ H<-nodeHeights(tree)
+ if(tip.labels==FALSE){
+ lims<-c(-max(H)-d,max(H)+d)
+ sw<-0
+ } else {
+ if(hasArg(fsize)) fsize<-list(...)$fsize
+ else fsize<-1
+ if(type=="phylogram"){
+ pp<-par("pin")[1]
+ sw<-fsize*(max(strwidth(tree$tip.label,
+ units="inches")))+1.37*fsize*strwidth("W",
+ units="inches")
+ alp<-optimize(function(a,H,sw,pp,d)
+ (a*1.04*(max(H)+d)+sw-pp)^2,H=H,sw=sw,
+ pp=pp,d=d,interval=c(0,1e6))$minimum
+ lims<-c(min(H),max(H)+d+sw/alp)
+ } else if(type=="fan"){
+ pp<-par("pin")[1]
+ sw<-fsize*(max(strwidth(tree$tip.label,
+ units="inches")))+1.37*fsize*strwidth("W",
+ units="inches")
+ alp<-optimize(function(a,H,sw,pp,d)
+ (a*2*1.04*(max(H)+d)+2*sw-pp)^2,H=H,sw=sw,pp=pp,
+ d=d,interval=c(0,1e6))$minimum
+ lims<-c(-max(H)-d-sw/alp,max(H)+d+sw/alp)
+ }
+ }
+ if(hasArg(lims)) lims<-list(...)$lims
+ um<-tree
+ if(!is.ultrametric(um)){
+ tip.h<-sapply(1:Ntip(tree),nodeheight,tree=tree)
+ for(i in 1:Ntip(tree)){
+ ii<-which(um$edge[,2]==i)
+ um$edge.length[ii]<-um$edge.length[ii]+(max(tip.h)-tip.h[i])
+ }
+ }
+ if(type=="phylogram"){
+ fg<-par()$fg
+ if(!is.ultrametric(tree)){
+ plotTree(um,ftype=if(tip.labels) "i" else "off",
+ xlim=c(0,lims[2]),lwd=1,color="transparent",...)
+ for(i in 1:Ntip(tree)) lines(c(max(tip.h),
+ tip.h[i]),rep(i,2),lty="dotted")
+ add<-TRUE
+ par(fg="transparent")
+ } else add=FALSE
+ if(method=="plotTree") capture.output(plotTree(tree,
+ ftype=if(tip.labels) "i" else "off",xlim=c(0,lims[2]),
+ add=add,...))
+ else if(method=="plotSimmap") capture.output(plotSimmap(tree,
+ ftype=if(tip.labels) "i" else "off",xlim=c(0,lims[2]),add=add,...))
+ par(fg=fg)
+ } else if(type=="fan"){
+ fg<-par()$fg
+ if(!is.ultrametric(tree)){
+ plotTree(um,type="fan",ftype=if(tip.labels) "i" else "off",xlim=lims,ylim=lims,
+ lwd=1,color="transparent",...)
+ um<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ par(fg="transparent")
+ plotTree(tree,type="fan",ftype=if(tip.labels) "i" else "off",xlim=lims,
+ ylim=lims,lwd=1,color="transparent",add=TRUE,...)
+ tt<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ par(fg="black",lty="solid")
+ for(i in 1:Ntip(tree)) lines(c(um$xx[i],tt$xx[i]),c(um$yy[i],tt$yy[i]),lty="dotted")
+ par(fg="transparent")
+ add<-TRUE
+ } else add<-FALSE
+ if(method=="plotTree") capture.output(plotTree(tree,type="fan",
+ ftype=if(tip.labels) "i" else "off",xlim=lims,ylim=lims,add=add,...))
+ else if(method=="plotSimmap") capture.output(plotSimmap(tree,
+ type="fan",ftype=if(tip.labels) "i" else "off",xlim=lims,
+ ylim=lims,add=add,...))
+ par(fg=fg)
+ }
+ obj<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ x<-x[tree$tip.label]*scale
+ if(is.null(width))
+ width<-if(type=="fan") (par()$usr[4]-par()$usr[3])/(max(c(max(x)/max(nodeHeights(tree)),1))*length(tree$tip.label))
+ else if(type=="phylogram") (par()$usr[4]-par()$usr[3])/(2*length(tree$tip.label))
+ w<-width
+ if(length(col)<Ntip(tree)) col<-rep(col,ceiling(Ntip(tree)/length(col)))[1:Ntip(tree)]
+ if(is.null(names(col))) names(col)<-tree$tip.label
+ col<-col[tree$tip.label]
+ if(type=="phylogram"){
+ if(hasArg(direction)) direction<-list(...)$direction
+ else direction<-"rightwards"
+ sw<-if(tip.labels) fsize*(max(strwidth(tree$tip.label)))+fsize*strwidth("1") else strwidth("l")
+ for(i in 1:length(x)){
+ dx<-max(obj$xx)
+ dy<-obj$yy[i]
+ x1<-x2<-dx+sw
+ x3<-x4<-x1+x[i]
+ y1<-y4<-dy-w/2
+ y2<-y3<-dy+w/2
+ polygon(c(x1,x2,x3,x4)-min(0,min(x)),
+ c(y1,y2,y3,y4),col=col[i],border=border)
+ }
+ } else if(type=="fan"){
+ h<-max(nodeHeights(tree))
+ sw<-if(tip.labels) fsize*(max(strwidth(tree$tip.label)))+fsize*strwidth("1") else strwidth("l")
+ for(i in 1:length(x)){
+ theta<-atan(obj$yy[i]/obj$xx[i])
+ s<-if(obj$xx[i]>0) 1 else -1
+ dx<-s*h*cos(theta)+s*cos(theta)*sw
+ dy<-s*h*sin(theta)+s*sin(theta)*sw
+ x1<-dx+(w/2)*cos(pi/2-theta)-s*min(0,min(x))*cos(theta)
+ y1<-dy-(w/2)*sin(pi/2-theta)-s*min(0,min(x))*sin(theta)
+ x2<-dx-(w/2)*cos(pi/2-theta)-s*min(0,min(x))*cos(theta)
+ y2<-dy+(w/2)*sin(pi/2-theta)-s*min(0,min(x))*sin(theta)
+ x3<-s*x[i]*cos(theta)+x2
+ y3<-s*x[i]*sin(theta)+y2
+ x4<-s*x[i]*cos(theta)+x1
+ y4<-s*x[i]*sin(theta)+y1
+ polygon(c(x1,x2,x3,x4),c(y1,y2,y3,y4),col=col[i],
+ border=border)
+ }
+ }
+ }
+ invisible(obj)
+}
+
diff --git a/R/project.phylomorphospace.R b/R/project.phylomorphospace.R
index 3cf8717..b4af7fe 100644
--- a/R/project.phylomorphospace.R
+++ b/R/project.phylomorphospace.R
@@ -1,62 +1,62 @@
-## morph a phylogeny to a phylomorphospace, vice versa, or there & back again
-## written by Liam J. Revell 2018
-
-project.phylomorphospace<-function(tree,X,nsteps=200,sleep=0,
- direction=c("to","from","both"),...){
- direction<-direction[1]
- tree<-minRotate(reorder(tree,"cladewise"),X[,2],print=FALSE)
- X<-X[tree$tip.label,]
- A<-cbind(fastAnc(tree,X[,1]),fastAnc(tree,X[,2]))
- cladogram<-tree
- cladogram$edge.length<-NULL
- mar<-par()$mar
- plotTree(cladogram,type="cladogram",nodes="centered",plot=FALSE)
- obj<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- obj$xx<-obj$xx*(max(c(X[,1],A[,1]))-min(c(X[,1],A[,1])))+
- min(c(X[,1],A[,1]))
- xlim<-range(obj$xx)
- xlim[2]<-xlim[2]+abs(diff(xlim))*(obj$x.lim[2]-1)
- obj$yy<-(obj$yy-min(obj$yy))/(max(obj$yy)-min(obj$yy))*
- (max(c(X[,2],A[,2]))-min(c(X[,2],A[,2])))+min(c(X[,2],A[,2]))
- ylim<-range(obj$yy)
- X0<-cbind(obj$xx[1:Ntip(tree)],obj$yy[1:Ntip(tree)])
- rownames(X0)<-tree$tip.label
- A0<-cbind(obj$xx[1:tree$Nnode+Ntip(tree)],
- obj$yy[1:tree$Nnode+Ntip(tree)])
- rownames(A0)<-1:tree$Nnode+Ntip(tree)
- par(mar=mar,new=TRUE)
- dev.hold()
- if(direction%in%c("to","both"))
- phylomorphospace(tree,X0,A0,label="horizontal",xlim=xlim,
- ylim=ylim,...)
- else if(direction=="from")
- phylomorphospace(tree,X,A,label="radial",xlim=xlim,
- ylim=ylim,...)
- dev.flush()
- if(direction=="both") nsteps<-ceiling(nsteps/2)
- if(direction%in%c("to","both")){
- for(i in 2:nsteps){
- Sys.sleep(sleep)
- dev.hold()
- phylomorphospace(tree,((nsteps-i)*X0+i*X)/nsteps,
- ((nsteps-i)*A0+i*A)/nsteps,xlim=xlim,ylim=ylim,
- ...)
- dev.flush()
- }
- }
- if(direction%in%c("from","both")){
- for(i in (nsteps-1):1){
- Sys.sleep(sleep)
- dev.hold()
- phylomorphospace(tree,((nsteps-i)*X0+i*X)/nsteps,
- ((nsteps-i)*A0+i*A)/nsteps,xlim=xlim,ylim=ylim,
- ...)
- dev.flush()
- }
- dev.hold()
- phylomorphospace(tree,X0,A0,label="horizontal",xlim=xlim,
- ylim=ylim,...)
- dev.flush()
- }
- invisible(NULL)
-}
+## morph a phylogeny to a phylomorphospace, vice versa, or there & back again
+## written by Liam J. Revell 2018
+
+project.phylomorphospace<-function(tree,X,nsteps=200,sleep=0,
+ direction=c("to","from","both"),...){
+ direction<-direction[1]
+ tree<-minRotate(reorder(tree,"cladewise"),X[,2],print=FALSE)
+ X<-X[tree$tip.label,]
+ A<-cbind(fastAnc(tree,X[,1]),fastAnc(tree,X[,2]))
+ cladogram<-tree
+ cladogram$edge.length<-NULL
+ mar<-par()$mar
+ plotTree(cladogram,type="cladogram",nodes="centered",plot=FALSE)
+ obj<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ obj$xx<-obj$xx*(max(c(X[,1],A[,1]))-min(c(X[,1],A[,1])))+
+ min(c(X[,1],A[,1]))
+ xlim<-range(obj$xx)
+ xlim[2]<-xlim[2]+abs(diff(xlim))*(obj$x.lim[2]-1)
+ obj$yy<-(obj$yy-min(obj$yy))/(max(obj$yy)-min(obj$yy))*
+ (max(c(X[,2],A[,2]))-min(c(X[,2],A[,2])))+min(c(X[,2],A[,2]))
+ ylim<-range(obj$yy)
+ X0<-cbind(obj$xx[1:Ntip(tree)],obj$yy[1:Ntip(tree)])
+ rownames(X0)<-tree$tip.label
+ A0<-cbind(obj$xx[1:tree$Nnode+Ntip(tree)],
+ obj$yy[1:tree$Nnode+Ntip(tree)])
+ rownames(A0)<-1:tree$Nnode+Ntip(tree)
+ par(mar=mar,new=TRUE)
+ dev.hold()
+ if(direction%in%c("to","both"))
+ phylomorphospace(tree,X0,A0,label="horizontal",xlim=xlim,
+ ylim=ylim,...)
+ else if(direction=="from")
+ phylomorphospace(tree,X,A,label="radial",xlim=xlim,
+ ylim=ylim,...)
+ dev.flush()
+ if(direction=="both") nsteps<-ceiling(nsteps/2)
+ if(direction%in%c("to","both")){
+ for(i in 2:nsteps){
+ Sys.sleep(sleep)
+ dev.hold()
+ phylomorphospace(tree,((nsteps-i)*X0+i*X)/nsteps,
+ ((nsteps-i)*A0+i*A)/nsteps,xlim=xlim,ylim=ylim,
+ ...)
+ dev.flush()
+ }
+ }
+ if(direction%in%c("from","both")){
+ for(i in (nsteps-1):1){
+ Sys.sleep(sleep)
+ dev.hold()
+ phylomorphospace(tree,((nsteps-i)*X0+i*X)/nsteps,
+ ((nsteps-i)*A0+i*A)/nsteps,xlim=xlim,ylim=ylim,
+ ...)
+ dev.flush()
+ }
+ dev.hold()
+ phylomorphospace(tree,X0,A0,label="horizontal",xlim=xlim,
+ ylim=ylim,...)
+ dev.flush()
+ }
+ invisible(NULL)
+}
diff --git a/R/ratebystate.R b/R/ratebystate.R
index 400d65e..bb01c68 100644
--- a/R/ratebystate.R
+++ b/R/ratebystate.R
@@ -1,83 +1,83 @@
-## simulation based test for a correlation between the state of x & the rate of y
-## written by Liam J. Revell 2013, 2017, 2019, 2021
-
-ratebystate<-function(tree,x,y,nsim=100,corr=c("pearson","spearman"),...){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- corr<-corr[1]
- if(hasArg(sim.method)) sim.method<-list(...)$sim.method
- else sim.method<-"sim.corrs"
- if(hasArg(method)) method<-list(...)$method
- else method<-"by.node"
- if(hasArg(message)) message<-list(...)$message
- else message<-TRUE
- if(hasArg(logarithm)) logarithm<-list(...)$logarithm
- else logarithm<-FALSE
- if(!is.binary(tree)) tree<-multi2di(tree,random=FALSE)
- V<-phyl.vcv(cbind(x,y),vcv(tree),lambda=1)$R
- if(method=="by.branch"){
- aa<-c(x[tree$tip.label],fastAnc(tree,x))
- names(aa)[1:length(tree$tip)]<-1:length(tree$tip)
- aa<-rowMeans(matrix(aa[tree$edge],nrow(tree$edge),2))
- a<-vector()
- for(i in 1:tree$Nnode+length(tree$tip)){
- j<-which(tree$edge[,1]==i)
- a[i-length(tree$tip)]<-sum(aa[j]*tree$edge.length[j])/sum(tree$edge.length[j])
- }
- names(a)<-1:tree$Nnode+length(tree$tip)
- }
- else a<-fastAnc(tree,x)
- if(logarithm) a<-exp(a)
- b<-pic(y,tree)[names(a)]^2
- r<-cor(a,b,method=corr)
- beta<-setNames(lm(b~a)$coefficients[2],NULL)
- foo<-function(tree,V){
- if(sim.method=="fastBM") XY<-fastBM(tree,nsim=2)%*%sqrt(diag(diag(V)))
- else if(sim.method=="sim.corrs") XY<-sim.corrs(tree,V)
- a<-fastAnc(tree,XY[,1])
- b<-pic(XY[,2],tree)[names(a)]^2
- r<-cor(a,b,method=corr)
- return(r)
- }
- r.null<-c(r,replicate(nsim-1,foo(tree,V)))
- P<-mean(abs(r.null)>=abs(r))
- obj<-list(beta=beta,r=r,P=P,corr=corr,method=method)
- class(obj)<-"ratebystate"
- obj
-}
-
-# function simulates rate by state evolution for x & y
-# written by Liam J. Revell 2013
-
-sim.ratebystate<-function(tree,sig2x=1,sig2y=1,beta=c(0,1),...){
- if(hasArg(method)) method<-list(...)$method
- else method<-"by.node"
- if(hasArg(plot)) plot<-list(...)$plot
- else plot<-FALSE
- if(hasArg(logarithm)) logarithm<-list(...)$logarithm
- else logarithm<-FALSE
- x<-fastBM(tree,a=if(logarithm) beta[1] else 0,sig2=sig2x,internal=TRUE)
- if(method=="by.node") ss<-x[1:tree$Nnode+length(tree$tip.label)]
- else if(method=="by.branch") ss<-rowMeans(matrix(x[tree$edge],nrow(tree$edge),2))
- zz<-tree
- if(!logarithm) zz$edge.length<-beta[2]*zz$edge.length*(beta[1]+ss-min(ss))
- else zz$edge.length<-beta[2]*zz$edge.length*exp(ss)
- y<-fastBM(zz,sig2=sig2y)
- if(plot) phenogram(zz,x,type="b",colors="blue",ftype="off",
- xlab="expected variance",ylab="independent variable (x)")
- x<-x[tree$tip.label]
- return(cbind(x,y))
-}
-
-## S3 print method
-print.ratebystate<-function(x,digits=6,...){
- cat("\nObject of class \"ratebystate\".\n")
- cat("\nSummary of object:\n")
- cat(paste(" beta[1] = ",round(x$beta,digits),"\n",sep=""))
- cat(paste(" ",if(x$corr=="pearson") "Pearson " else
- "Spearman ","correlation (r) = ",round(x$r,digits),
- "\n",sep=""))
- cat(paste(" P-value (from simulation) = ",round(x$P,digits),
- "\n\n",sep=""))
- cat(paste("Analysis was conducted using \"",x$method,
- "\" method.\n\n",sep=""))
-}
+## simulation based test for a correlation between the state of x & the rate of y
+## written by Liam J. Revell 2013, 2017, 2019, 2021
+
+ratebystate<-function(tree,x,y,nsim=100,corr=c("pearson","spearman"),...){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ corr<-corr[1]
+ if(hasArg(sim.method)) sim.method<-list(...)$sim.method
+ else sim.method<-"sim.corrs"
+ if(hasArg(method)) method<-list(...)$method
+ else method<-"by.node"
+ if(hasArg(message)) message<-list(...)$message
+ else message<-TRUE
+ if(hasArg(logarithm)) logarithm<-list(...)$logarithm
+ else logarithm<-FALSE
+ if(!is.binary(tree)) tree<-multi2di(tree,random=FALSE)
+ V<-phyl.vcv(cbind(x,y),vcv(tree),lambda=1)$R
+ if(method=="by.branch"){
+ aa<-c(x[tree$tip.label],fastAnc(tree,x))
+ names(aa)[1:length(tree$tip)]<-1:length(tree$tip)
+ aa<-rowMeans(matrix(aa[tree$edge],nrow(tree$edge),2))
+ a<-vector()
+ for(i in 1:tree$Nnode+length(tree$tip)){
+ j<-which(tree$edge[,1]==i)
+ a[i-length(tree$tip)]<-sum(aa[j]*tree$edge.length[j])/sum(tree$edge.length[j])
+ }
+ names(a)<-1:tree$Nnode+length(tree$tip)
+ }
+ else a<-fastAnc(tree,x)
+ if(logarithm) a<-exp(a)
+ b<-pic(y,tree)[names(a)]^2
+ r<-cor(a,b,method=corr)
+ beta<-setNames(lm(b~a)$coefficients[2],NULL)
+ foo<-function(tree,V){
+ if(sim.method=="fastBM") XY<-fastBM(tree,nsim=2)%*%sqrt(diag(diag(V)))
+ else if(sim.method=="sim.corrs") XY<-sim.corrs(tree,V)
+ a<-fastAnc(tree,XY[,1])
+ b<-pic(XY[,2],tree)[names(a)]^2
+ r<-cor(a,b,method=corr)
+ return(r)
+ }
+ r.null<-c(r,replicate(nsim-1,foo(tree,V)))
+ P<-mean(abs(r.null)>=abs(r))
+ obj<-list(beta=beta,r=r,P=P,corr=corr,method=method)
+ class(obj)<-"ratebystate"
+ obj
+}
+
+# function simulates rate by state evolution for x & y
+# written by Liam J. Revell 2013
+
+sim.ratebystate<-function(tree,sig2x=1,sig2y=1,beta=c(0,1),...){
+ if(hasArg(method)) method<-list(...)$method
+ else method<-"by.node"
+ if(hasArg(plot)) plot<-list(...)$plot
+ else plot<-FALSE
+ if(hasArg(logarithm)) logarithm<-list(...)$logarithm
+ else logarithm<-FALSE
+ x<-fastBM(tree,a=if(logarithm) beta[1] else 0,sig2=sig2x,internal=TRUE)
+ if(method=="by.node") ss<-x[1:tree$Nnode+length(tree$tip.label)]
+ else if(method=="by.branch") ss<-rowMeans(matrix(x[tree$edge],nrow(tree$edge),2))
+ zz<-tree
+ if(!logarithm) zz$edge.length<-beta[2]*zz$edge.length*(beta[1]+ss-min(ss))
+ else zz$edge.length<-beta[2]*zz$edge.length*exp(ss)
+ y<-fastBM(zz,sig2=sig2y)
+ if(plot) phenogram(zz,x,type="b",colors="blue",ftype="off",
+ xlab="expected variance",ylab="independent variable (x)")
+ x<-x[tree$tip.label]
+ return(cbind(x,y))
+}
+
+## S3 print method
+print.ratebystate<-function(x,digits=6,...){
+ cat("\nObject of class \"ratebystate\".\n")
+ cat("\nSummary of object:\n")
+ cat(paste(" beta[1] = ",round(x$beta,digits),"\n",sep=""))
+ cat(paste(" ",if(x$corr=="pearson") "Pearson " else
+ "Spearman ","correlation (r) = ",round(x$r,digits),
+ "\n",sep=""))
+ cat(paste(" P-value (from simulation) = ",round(x$P,digits),
+ "\n\n",sep=""))
+ cat(paste("Analysis was conducted using \"",x$method,
+ "\" method.\n\n",sep=""))
+}
diff --git a/R/ratebytree.R b/R/ratebytree.R
index 17feb91..f80cb25 100644
--- a/R/ratebytree.R
+++ b/R/ratebytree.R
@@ -1,764 +1,764 @@
-## method to compare the rate of evolution for a character between trees
-## continuous character method closely related to 'censored' approach of O'Meara et al. (2006; Evolution)
-## discrete character method fits Mk model of Lewis 2001
-## diversification method fits Yule or birth-death model of Nee et al. (1994) & Stadler (2012)
-## written by Liam J. Revell 2017
-
-ratebytree<-function(trees,x,...){
- if(hasArg(type)) type<-list(...)$type
- else if(!missing(x)&&!is.null(x)) {
- if(is.factor(unlist(x))||is.character(unlist(x)))
- type<-"discrete"
- else type<-"continuous"
- } else type<-"diversification"
- if(type=="continuous") obj<-rbt.cont(trees,x,...)
- else if(type=="discrete") obj<-rbt.disc(trees,x,...)
- else if(type=="diversification") obj<-rbt.div(trees,...)
- else {
- cat(paste("type =",type,"not recognized.\n"))
- obj<-NULL
- }
- obj
-}
-
-rbt.div<-function(trees,...){
- if(hasArg(trace)) trace<-list(...)$trace
- else trace<-FALSE
- if(hasArg(digits)) digits<-list(...)$digits
- else digits<-4
- if(hasArg(test)) test<-list(...)$test
- else test<-"chisq"
- if(hasArg(quiet)) quiet<-list(...)$quiet
- else quiet<-FALSE
- if(hasArg(model)) model<-list(...)$model
- else model<-"birth-death"
- if(hasArg(rho)) rho<-list(...)$rho
- else rho<-rep(1,length(trees))
- if(hasArg(tol)) tol<-list(...)$tol
- else tol<-1e-12
- if(hasArg(iter)) iter<-list(...)$iter
- else iter<-10
- if(!inherits(trees,"multiPhylo"))
- stop("trees should be object of class \"multiPhylo\".")
- if(any(!sapply(trees,is.ultrametric))){
- cat("One or more trees fails check is.ultrametric.\n")
- cat("If you believe your tree to be ultrametric ")
- cat("use force.ultrametric.\n")
- stop()
- }
- t<-lapply(trees,function(phy) sort(branching.times(phy),
- decreasing=TRUE))
- if(model=="birth-death"){
- fit.multi<-mapply(fit.bd,tree=trees,rho=rho,iter=iter,SIMPLIFY=FALSE)
- logL.multi<-sum(sapply(fit.multi,logLik))
- } else if(model=="equal-extinction"){
- lik.eqmu<-function(theta,t,rho,trace=FALSE){
- lam<-theta[1:length(t)]
- mu<-theta[length(t)+1]
- logL<-0
- for(i in 1:length(t)) logL<-logL-lik.bd(c(lam[i],mu),t[[i]],rho[i])
- if(trace) cat(paste(paste(c(lam,mu,logL),collapse="\t"),"\n",sep=""))
- -logL
- }
- init.b<-sapply(trees,qb)
- obj<-nlminb(c(init.b,0),lik.eqmu,t=t,rho=rho,trace=trace,
- lower=rep(0,length(trees)+1),upper=rep(Inf,length(trees)+1))
- count<-0
- while(!is.finite(obj$objective)&&count<iter){
- obj<-nlminb(runif(n=2,0,2)*c(init.b,0),lik.eqmu,t=t,rho=rho,
- trace=trace,lower=rep(0,length(trees)+1),
- upper=rep(Inf,length(trees)+1))
- count<-count+1
- }
- fit.multi<-vector(mode="list",length=length(t))
- for(i in 1:length(fit.multi)){
- fit.multi[[i]]$b<-obj$par[i]
- fit.multi[[i]]$d<-obj$par[length(obj$par)]
- }
- logL.multi<--obj$objective
- } else if(model=="equal-speciation"){
- lik.eqlam<-function(theta,t,rho,trace=FALSE){
- lam<-theta[1]
- mu<-theta[1:length(t)+1]
- logL<-0
- for(i in 1:length(t)) logL<-logL-lik.bd(c(lam,mu[i]),t[[i]],rho[i])
- if(trace) cat(paste(paste(c(lam,mu,logL),collapse="\t"),"\n",sep=""))
- -logL
- }
- init.b<-mean(sapply(trees,qb))
- obj<-nlminb(c(init.b,rep(0,length(trees))),lik.eqlam,t=t,rho=rho,
- trace=trace,lower=rep(0,length(trees)+1),
- upper=rep(Inf,length(trees)+1))
- print(obj)
- count<-0
- while(!is.finite(obj$objective)&&count<iter){
- obj<-nlminb(runif(n=2,0,2)*c(init.b,rep(0,length(trees))),lik.eqlam,
- t=t,rho=rho,trace=trace,lower=rep(0,length(trees)+1),
- upper=rep(Inf,length(trees)+1))
- count<-count+1
- }
- fit.multi<-vector(mode="list",length=length(t))
- for(i in 1:length(fit.multi)){
- fit.multi[[i]]$b<-obj$par[1]
- fit.multi[[i]]$d<-obj$par[i+1]
- }
- logL.multi<--obj$objective
- } else if(model=="Yule"){
- interval<-if(hasArg(interval)) list(...)$interval else c(0,10*mean(sapply(trees,qb)))
- fit.multi<-mapply(fit.yule,tree=trees,rho=rho,MoreArgs=list(interval=interval),
- SIMPLIFY=FALSE)
- logL.multi<-sum(sapply(fit.multi,logLik))
- }
- if(model!="Yule"){
- lik.onerate<-function(theta,t,rho,model,trace=FALSE){
- logL<-sum(-mapply(lik.bd,t=t,rho=rho,
- MoreArgs=list(theta=theta)))
- if(trace) cat(paste(theta[1],"\t",theta[2],"\t",logL,"\n"))
- -logL
- }
- init.b<-mean(sapply(fit.multi,function(x) x$b))
- init.d<-mean(sapply(fit.multi,function(x) x$d))
- fit.onerate<-nlminb(c(init.b,init.d),lik.onerate,t=t,rho=rho,
- model=model,trace=trace,lower=c(0,0),upper=rep(Inf,2))
- count<-0
- while(!is.finite(fit.onerate$objective)&&count<iter){
- fit.onerate<-nlminb(runif(n=2,0,2)*c(init.b,init.d),lik.onerate,
- t=t,rho=rho,model=model,trace=trace,lower=c(0,0),
- upper=rep(Inf,2))
- count<-count+1
- }
- rates.multi<-cbind(sapply(fit.multi,function(x) x$b),
- sapply(fit.multi,function(x) x$d))
- } else {
- lik.yule<-function(theta,t,rho,trace=FALSE){
- logL<-sum(-mapply(lik.bd,t=t,rho=rho,MoreArgs=list(theta=c(theta,0))))
- if(trace) cat(paste(theta,logL,"\n",sep="\t"))
- -logL
- }
- obj<-optimize(lik.yule,interval,t=t,rho=rho,trace=trace)
- TOL<-diff(interval)*1e-3
- convergence<-if((obj$minimum-TOL)<interval[1]||(obj$minimum+TOL)>interval[2]) 52 else 0
- fit.onerate<-list(par=c(obj$minimum,0),objective=obj$objective,convergence=convergence,
- message=if(convergence!=0) "Estimate at may be at limits of interval." else
- "Probably converged.")
- rates.multi<-cbind(sapply(fit.multi,function(x) x$b),
- rep(0,length(trees)))
- }
- if(!is.null(names(trees))) rownames(rates.multi)<-names(trees)
- else rownames(rates.multi)<-paste("tree",1:length(trees),sep="")
- colnames(rates.multi)<-c("b","d")
- LR<-2*(logL.multi+fit.onerate$objective)
- km<-if(model=="birth-death") 2*length(trees) else
- if(model=="equal-extinction") length(trees)+1 else
- if(model=="equal-speciation") length(trees)+1 else
- if(model=="Yule") length(trees)
- k1<-if(model=="Yule") 1 else 2
- P.chisq<-pchisq(LR,df=km-k1,lower.tail=FALSE)
- obj<-list(
- multi.rate.model=list(
- logL=logL.multi,
- rates=rates.multi,
- k=km,
- method=if(model=="Yule") "optimize" else "nlminb"),
- common.rate.model=list(
- logL=-fit.onerate$objective,
- rates=setNames(fit.onerate$par,c("b","d")),
- k=k1,
- method=if(model=="Yule") "optimize" else "nlminb"),
- model=model,N=length(trees),
- n=sapply(trees,Ntip),
- likelihood.ratio=LR,P.chisq=P.chisq,
- type="diversification")
- class(obj)<-"ratebytree"
- obj
-}
-
-## discrete character ratebytree
-rbt.disc<-function(trees,x,...){
- if(hasArg(trace)) trace<-list(...)$trace
- else trace<-FALSE
- if(hasArg(digits)) digits<-list(...)$digits
- else digits<-4
- if(hasArg(test)) test<-list(...)$test
- else test<-"chisq"
- if(hasArg(quiet)) quiet<-list(...)$quiet
- else quiet<-FALSE
- if(hasArg(model)) model<-list(...)$model
- else model<-"ER"
- if(!inherits(trees,"multiPhylo"))
- stop("trees should be object of class \"multiPhylo\".")
- if(!is.list(x)) stop("x should be a list of vectors.")
- N<-length(trees)
- fit.multi<-mapply(fitMk,tree=trees,x=x,MoreArgs=list(model=model),
- SIMPLIFY=FALSE)
- logL.multi<-sum(sapply(fit.multi,logLik))
- lik.onerate<-function(theta,trees,x,model,trace=FALSE){
- ss<-sort(unique(unlist(x)))
- m<-length(ss)
- if(is.character(model)){
- rate<-matrix(NA,m,m)
- if(model=="ER"){
- k<-rate[]<-1
- diag(rate)<-NA
- }
- else if(model=="ARD") {
- k<-m*(m-1)
- rate[col(rate)!=row(rate)]<-1:k
- }
- else if(model=="SYM") {
- k<-m*(m-1)/2
- ii<-col(rate)<row(rate)
- rate[ii]<-1:k
- rate<-t(rate)
- rate[ii]<-1:k
- }
- } else {
- rate<-model
- k<-max(rate)
- }
- Q <- matrix(0, m, m)
- index.matrix <- rate
- tmp <- cbind(1:m, 1:m)
- rate[tmp] <- 0
- rate[rate == 0] <- k + 1
- Q[]<-c(theta,0)[rate]
- diag(Q)<--rowSums(Q)
- colnames(Q)<-rownames(Q)<-ss
- fit.onerate<-mapply(fitMk,tree=trees,x=x,MoreArgs=list(fixedQ=Q),
- SIMPLIFY=FALSE)
- -sum(sapply(fit.onerate,logLik))
- }
- pp<-sapply(fit.multi,function(x) x$rates)
- pp<-if(is.matrix(pp)) rowMeans(pp) else mean(pp)
- if(length(pp)>1){
- fit.onerate<-optim(pp,lik.onerate,trees=trees,x=x,model=model)
- } else {
- fit.onerate<-optimize(lik.onerate,c(0,1000*pp),trees=trees,x=x,
- model=model)
- names(fit.onerate)<-c("par","value")
- }
- rates.multi<-t(sapply(fit.multi,function(x) x$rates))
- if(is.character(model)){
- m<-length(fit.multi[[1]]$states)
- if(model=="ER"){
- rates.multi<-t(rates.multi)
- colnames(rates.multi)<-"q"
- } else if(model=="SYM"){
- if(length(fit.multi[[1]]$states)==2) rates.multi<-t(rates.multi)
- colnames(rates.multi)<-
- sapply(fit.multi[[1]]$states,function(x,y)
- sapply(y,function(y,x) paste(x,"<->",y,sep=""),x=x),
- y=fit.multi[[1]]$states)[lower.tri(matrix(0,m,m))]
- } else if(model=="ARD"){
- ii<-(upper.tri(matrix(0,m,m))+lower.tri(matrix(0,m,m))==TRUE)
- colnames(rates.multi)<-
- sapply(fit.multi[[1]]$states,function(x,y)
- sapply(y,function(y,x) paste(y,"->",x,sep=""),x=x),
- y=fit.multi[[1]]$states)[ii]
- }
- } else {
- k<-max(fit.multi[[1]]$index.matrix,na.rm=TRUE)
- if(k==1) rates.multi<-t(rates.multi)
- foo<-function(i,index.matrix,states){
- rc<-which(index.matrix==i,arr.ind=TRUE)
- lab<-apply(rc,1,function(ind,ss) paste(ss[ind],collapse="->"),
- ss=states)
- if(length(lab)>1) paste(lab,collapse=",") else lab
- }
- colnames(rates.multi)<-sapply(1:k,
- foo,fit.multi[[1]]$index.matrix,fit.multi[[1]]$states)
- }
- if(!is.null(names(trees))) rownames(rates.multi)<-names(trees)
- else rownames(rates.multi)<-paste("tree",1:length(trees),sep="")
- LR<-2*(logL.multi+fit.onerate$value)
- km<-sum(sapply(fit.multi,function(x) max(x$index.matrix,na.rm=TRUE)))
- k1<-length(pp)
- P.chisq<-pchisq(LR,df=km-k1,lower.tail=FALSE)
- obj<-list(
- multi.rate.model=list(
- logL=logL.multi,
- rates=rates.multi,
- method=fit.multi[[1]]$method),
- common.rate.model=list(
- logL=-fit.onerate$value,
- rates=setNames(fit.onerate$par,colnames(rates.multi)),
- method=if(length(pp)>1) "optim" else "optimize"),
- index.matrix=fit.multi[[1]]$index.matrix,
- states=fit.multi[[1]]$states,
- pi=fit.multi[[1]]$pi,
- model=model,N=N,n=sapply(trees,Ntip),
- likelihood.ratio=LR,P.chisq=P.chisq,
- type="discrete")
- class(obj)<-"ratebytree"
- obj
-}
-
-## continuous character ratebytree
-rbt.cont<-function(trees,x,...){
- if(hasArg(tol)) tol<-list(...)$tol
- else tol<-1e-8
- if(hasArg(trace)) trace<-list(...)$trace
- else trace<-FALSE
- if(hasArg(digits)) digits<-list(...)$digits
- else digits<-4
- if(hasArg(test)) test<-list(...)$test
- else test<-"chisq"
- if(hasArg(quiet)) quiet<-list(...)$quiet
- else quiet<-FALSE
- if(hasArg(maxit)) maxit<-list(...)$maxit
- else maxit<-500
- if(hasArg(regimes)){
- regimes<-list(...)$regimes
- if(!is.factor(regimes)) regimes<-as.factor(regimes)
- } else regimes<-as.factor(1:length(trees))
- if(hasArg(model)) model<-list(...)$model
- else model<-"BM"
- if(!(model%in%c("BM","OU","EB"))){
- cat(paste("model =",model,"not recognized. using model = \"BM\"\n"))
- model<-"BM"
- }
- ## check trees & x
- if(!inherits(trees,"multiPhylo"))
- stop("trees should be object of class \"multiPhylo\".")
- if(!is.list(x)) stop("x should be a list of vectors.")
- if(hasArg(se)) se<-list(...)$se
- else {
- se<-x
- for(i in 1:length(x)) se[[i]][1:length(se[[i]])]<-0
- }
- N<-length(trees)
- m<-length(levels(regimes))
- ## reorder the trait vectors in x & SEs in se
- x<-mapply(function(x,t) x<-x[t$tip.label],x=x,t=trees,SIMPLIFY=FALSE)
- se<-mapply(function(x,t) x<-x[t$tip.label],x=se,t=trees,SIMPLIFY=FALSE)
- ## likelihood functions
- lik.multi<-function(theta,trees,y,se,model,regimes,trace=FALSE){
- m<-length(unique(regimes))
- ind<-setNames(lapply(levels(regimes),function(x,y) which(y==x),y=regimes),
- levels(regimes))
- THETA<-list()
- for(i in 1:m){
- THETA[[i]]<-c(theta[i],theta[ind[[i]]+m])
- if(model%in%c("OU","EB")) THETA[[i]]<-c(THETA[[i]],theta[i+m+N])
- }
- logL<-0
- for(i in 1:m)
- logL<-logL-lik.onerate(THETA[[i]],trees[ind[[i]]],y[ind[[i]]],se[ind[[i]]],
- model=model,trace=FALSE)
- if(trace){
- cat(paste(paste(round(theta[1:m],digits),collapse="\t"),
- if(model=="OU") paste(round(theta[1:m+m+N],digits),collapse="\t"),
- if(model=="EB") paste(round(theta[1:m+m+N],digits),collapse="\t"),
- round(logL,digits),"\n",sep="\t"))
- flush.console()
- }
- -logL
- }
- lik.onerate<-function(theta,trees,y,se,model,trace=FALSE){
- n<-sapply(trees,Ntip)
- N<-length(trees)
- sig<-theta[1]
- a<-theta[1:N+1]
- if(model=="OU") alpha<-theta[N+2]
- if(model=="EB") r<-theta[N+2]
- if(model=="BM") C<-lapply(trees,vcv)
- else if(model=="OU") C<-lapply(trees,vcvPhylo,model="OU",alpha=alpha,
- anc.nodes=FALSE)
- else if(model=="EB") C<-lapply(trees,vcvPhylo,model="EB",r=r,
- anc.nodes=FALSE)
- E<-lapply(se,diag)
- V<-mapply("+",lapply(C,"*",sig),E,SIMPLIFY=FALSE)
- logL<-0
- for(i in 1:N)
- logL<-logL-t(y[[i]]-a[i])%*%solve(V[[i]])%*%(y[[i]]-
- a[i])/2-n[i]*log(2*pi)/2-determinant(V[[i]])$modulus[1]/2
- if(trace){
- cat(paste(round(sig,digits),
- if(model=="OU") round(alpha,digits),
- if(model=="EB") round(r,digits),
- round(logL,digits),"\n",sep="\t"))
- flush.console()
- }
- -logL
- }
- ## first, fit multi-rate model
- f1<-function(tree,x){
- pvcv<-phyl.vcv(as.matrix(x),vcv(tree),1)
- c(pvcv$R[1,1],pvcv$a[1,1])
- }
- P<-mapply(f1,trees,x,SIMPLIFY=FALSE)
- PP<-list()
- PP[[1]]<-vector()
- for(i in 1:m)
- PP[[1]][i]<-mean(sapply(P,function(x) x[1])[which(regimes==levels(regimes)[i])])
- PP[[2]]<-sapply(P,function(x) x[2])
- if(model%in%c("OU","EB")) PP[[3]]<-rep(0,m)
- if(hasArg(init)){
- init<-list(...)$init
- if(!is.null(init$sigm)) PP[[1]]<-init$sigm
- if(!is.null(init$am)) PP[[2]]<-init$am
- if(model=="OU") if(!is.null(init$alpham)) PP[[3]]<-init$alpham
- if(model=="EB") if(!is.null(init$rm)) PP[[3]]<-init$rm
- }
- p<-unlist(PP)
- if(trace){
- if(model=="BM"){
- cat("\nOptimizing multi-rate model....\n")
- cat(paste(paste("sig[",1:m,"]",sep="",collapse="\t"),"logL\n",sep="\t"))
- } else if(model=="OU"){
- cat("\nOptimizing multi-regime model....\n")
- cat(paste(paste("sig[",1:m,"]",sep="",collapse="\t"),
- paste("alpha[",1:m,"]",sep="",collapse="\t"),"logL\n",sep="\t"))
- } else if(model=="EB"){
- cat("\nOptimizing multi-regime model....\n")
- cat(paste(paste("sig[",1:m,"]",sep="",collapse="\t"),
- paste("r[",1:m,"]",sep="",collapse="\t"),"logL\n",sep="\t"))
- }
- }
- fit.multi<-optim(p,lik.multi,trees=trees,y=x,se=se,model=model,
- regimes=regimes,trace=trace,
- method="L-BFGS-B",lower=c(rep(tol,m),rep(-Inf,N),
- if(model%in%c("OU","EB")) rep(-Inf,m)),upper=c(rep(Inf,m),rep(Inf,N),
- if(model%in%c("OU","EB")) rep(Inf,m)),control=list(maxit=maxit))
- ## compute covariance matrix
- H.multi<-hessian(lik.multi,fit.multi$par,trees=trees,y=x,
- se=se,model=model,regimes=regimes,trace=FALSE)
- Cov.multi<-if(qr(H.multi)$rank!=ncol(H.multi)) ginv(H.multi) else solve(H.multi)
- ## now fit single-rate model
- p<-c(mean(fit.multi$par[1:m]),fit.multi$par[1:N+m])
- if(model%in%c("OU","EB")) p<-c(p,mean(fit.multi$par[1:m+m+N]))
- if(hasArg(init)){
- if(!is.null(init$sigc)) p[1]<-init$sigc
- if(!is.null(init$ac)) p[1:N+1]<-init$ac
- if(model=="OU") if(!is.null(init$alphac)) p[N+2]<-init$alphac
- if(model=="EB") if(!is.null(init$rc)) p[N+2]<-init$rc
- }
- if(trace){
- if(model=="BM"){
- cat("\nOptimizing common-rate model....\n")
- cat(paste("sig ","logL\n",sep="\t"))
- } else if(model=="OU"){
- cat("\nOptimizing common-regime model....\n")
- cat(paste("sig ","alpha ","logL\n",sep="\t"))
- } else if(model=="EB"){
- cat("\nOptimizing common-regime mode.....\n")
- cat(paste("sig ","r ","logL\n",sep="\t"))
- }
- }
- fit.onerate<-optim(p,lik.onerate,trees=trees,y=x,se=se,model=model,
- trace=trace,method="L-BFGS-B",
- lower=c(tol,rep(-Inf,N),if(model=="OU") tol else if(model=="EB") -Inf),
- upper=c(Inf,rep(Inf,N),if(model%in%c("OU","EB")) Inf),
- control=list(maxit=maxit))
- ## compute covariance matrix
- H.onerate<-hessian(lik.onerate,fit.onerate$par,trees=trees,y=x,
- se=se,model=model,trace=FALSE)
- Cov.onerate<-if(qr(H.onerate)$rank!=ncol(H.onerate)) ginv(H.onerate) else solve(H.onerate)
- ## compare models:
- LR<-2*(-fit.multi$value+fit.onerate$value)
- km<-N+m+if(model=="BM") 0 else if(model%in%c("OU","EB")) m
- k1<-N+if(model=="BM") 1 else if(model%in%c("OU","EB")) 2
- if(test=="simulation"&&model%in%c("OU","EB")){
- cat("Simulation test not yet available for chosen model. Using chi-square test.\n")
- test<-"chisq"
- }
- if(test=="chisq") P.chisq<-pchisq(LR,df=km-k1,lower.tail=FALSE)
- else if(test=="simulation"){
- if(!quiet) cat("Generating null distribution via simulation -> |")
- flush.console()
- if(hasArg(nsim)) nsim<-list(...)$nsim
- else nsim<-100
- X<-mapply(fastBM,tree=trees,a=as.list(fit.onerate$par[1:N+1]),
- MoreArgs=list(sig2=fit.onerate$par[1],nsim=nsim),
- SIMPLIFY=FALSE)
- P.sim<-1/(nsim+1)
- pct<-0.1
- for(i in 1:nsim){
- x.sim<-lapply(X,function(x,ind) x[,ind],ind=i)
- f2<-function(x,se) sampleFrom(xbar=x,xvar=se^2,n=rep(1,length(x)))
- x.sim<-mapply(f2,x=x.sim,se=se,SIMPLIFY=FALSE)
- fit.sim<-ratebytree(trees,x.sim,se=se)
- P.sim<-P.sim+(fit.sim$likelihood.ratio>=LR)/(nsim+1)
- if(i/nsim>=pct){
- if(!quiet) cat(".")
- flush.console()
- pct<-pct+0.1
- }
- }
- if(!quiet) cat(".|\nDone!\n")
- flush.console()
- }
- obj<-list(
- multi.rate.model=list(sig2=fit.multi$par[1:m],
- SE.sig2=sqrt(diag(Cov.multi)[1:m]),
- a=fit.multi$par[1:N+m],
- SE.a=sqrt(diag(Cov.multi)[1:N+m]),
- alpha=if(model=="OU") fit.multi$par[1:m+m+N] else NULL,
- SE.alpha=if(model=="OU") sqrt(diag(Cov.multi)[1:m+m+N]) else NULL,
- r=if(model=="EB") fit.multi$par[1:N+m+N] else NULL,
- SE.r=if(model=="EB") sqrt(diag(Cov.multi)[1:N+m+N]) else NULL,
- k=km,
- logL=-fit.multi$value,
- counts=fit.multi$counts,convergence=fit.multi$convergence,
- message=fit.multi$message),
- common.rate.model=list(sig2=fit.onerate$par[1],
- SE.sig2=sqrt(diag(Cov.onerate)[1]),
- a=fit.onerate$par[1:N+1],
- SE.a=sqrt(diag(Cov.onerate)[1:N+1]),
- alpha=if(model=="OU") fit.onerate$par[N+2] else NULL,
- SE.alpha=if(model=="OU") sqrt(diag(Cov.onerate)[N+2]) else NULL,
- r=if(model=="EB") fit.onerate$par[N+2] else NULL,
- SE.r=if(model=="EB") sqrt(diag(Cov.onerate)[N+2]) else NULL,
- k=k1,
- logL=-fit.onerate$value,
- counts=fit.onerate$counts,convergence=fit.onerate$convergence,
- message=fit.onerate$message),
- model=model,
- N=N,n=sapply(trees,Ntip),likelihood.ratio=LR,
- regimes=regimes,m=m,
- P.chisq=if(test=="chisq") P.chisq else NULL,
- P.sim=if(test=="simulation") P.sim else NULL,
- type="continuous")
- class(obj)<-"ratebytree"
- obj
-}
-
-## S3 print method for ratebytree
-print.ratebytree<-function(x,...){
- if(hasArg(digits)) digits<-list(...)$digits
- else digits<-4
- if(x$type=="continuous") prbt.cont(x,digits=digits)
- else if(x$type=="discrete") prbt.disc(x,digits=digits)
- else if(x$type=="diversification") prbt.div(x,digits=digits)
- else print(x)
-}
-
-prbt.div<-function(x,digits=digits){
- cat("ML common diversification-rate model:")
- cat("\n\tb\td\tk\tlog(L)")
- cat(paste("\nvalue",round(x$common.rate.model$rates[1],digits),
- round(x$common.rate.model$rates[2],digits),
- x$common.rate.model$k,round(x$common.rate.model$logL,digits),
- sep="\t"))
- cat("\n\nML multi diversification-rate model:")
- cat(paste("\n",paste(paste("b[",1:x$N,"]",sep=""),collapse="\t"),
- paste(paste("d[",1:x$N,"]",sep=""),collapse="\t"),"k\tlog(L)",
- sep="\t"))
- cat(paste("\nvalue",paste(round(x$multi.rate.model$rates[,"b"],digits),
- collapse="\t"),paste(round(x$multi.rate.model$rates[,"d"],digits),
- collapse="\t"),x$multi.rate.model$k,round(x$multi.rate.model$logL,
- digits),sep="\t"))
- cat(paste("\n\nDiversification model was \"",x$model,"\".\n",sep=""))
- cat(paste("Model fitting method was \"",x$multi.rate.model$method,
- "\".\n",sep=""))
- cat(paste("\nLikelihood ratio:",round(x$likelihood.ratio,digits),"\n"))
- cat(paste("P-value (based on X^2):",round(x$P.chisq,digits),"\n\n"))
-}
-
-prbt.cont<-function(x,digits=digits){
- N<-x$N
- m<-x$m
- if(x$model=="BM"){
- cat("ML common-rate model:\n")
- cat(paste("\ts^2\t",paste(paste("a[",1:N,"]",sep=""),collapse="\t")),
- "\tk\tlogL\n")
- cat(paste("value",round(x$common.rate.model$sig2,digits),
- paste(round(x$common.rate.model$a,digits),collapse="\t"),
- x$common.rate.model$k,round(x$common.rate.model$logL,digits),
- "\n",sep="\t"))
- cat(paste("SE ",round(x$common.rate.model$SE.sig2,digits),
- paste(round(x$common.rate.model$SE.a,digits),collapse="\t"),
- "\n\n",sep="\t"))
- cat("ML multi-rate model:\n")
- cat(paste("\t",paste(paste("s^2[",levels(x$regimes),"]",sep=""),collapse="\t"),"\t",
- paste(paste("a[",1:N,"]",sep=""),collapse="\t")),
- "\tk\tlogL\n")
- cat(paste("value",paste(round(x$multi.rate.model$sig2,digits),collapse="\t"),
- paste(round(x$multi.rate.model$a,digits),collapse="\t"),
- x$multi.rate.model$k,round(x$multi.rate.model$logL,digits),
- "\n",sep="\t"))
- cat(paste("SE ",paste(round(x$multi.rate.model$SE.sig2,digits),collapse="\t"),
- paste(round(x$multi.rate.model$SE.a,digits),collapse="\t"),
- "\n\n",sep="\t"))
- } else if(x$model=="OU"){
- cat("ML common-regime OU model:\n")
- cat(paste("\ts^2\t",paste(paste("a[",1:N,"]",sep=""),collapse="\t")),
- "\talpha\tk\tlogL\n")
- cat(paste("value",round(x$common.rate.model$sig2,digits),
- paste(round(x$common.rate.model$a,digits),collapse="\t"),
- round(x$common.rate.model$alpha,digits),
- x$common.rate.model$k,round(x$common.rate.model$logL,digits),
- "\n",sep="\t"))
- cat(paste("SE ",round(x$common.rate.model$SE.sig2,digits),
- paste(round(x$common.rate.model$SE.a,digits),collapse="\t"),
- round(x$common.rate.model$SE.alpha,digits),
- "\n\n",sep="\t"))
- cat("ML multi-regime OU model:\n")
- cat(paste("\t",paste(paste("s^2[",levels(x$regimes),"]",sep=""),collapse="\t"),"\t",
- paste(paste("a[",1:N,"]",sep=""),collapse="\t"),"\t",
- paste(paste("alp[",levels(x$regimes),"]",sep=""),collapse="\t")),
- "\tk\tlogL\n")
- cat(paste("value",paste(round(x$multi.rate.model$sig2,digits),collapse="\t"),
- paste(round(x$multi.rate.model$a,digits),collapse="\t"),
- paste(round(x$multi.rate.model$alpha,digits),collapse="\t"),
- x$multi.rate.model$k,round(x$multi.rate.model$logL,digits),
- "\n",sep="\t"))
- cat(paste("SE ",paste(round(x$multi.rate.model$SE.sig2,digits),collapse="\t"),
- paste(round(x$multi.rate.model$SE.a,digits),collapse="\t"),
- paste(round(x$multi.rate.model$SE.alpha,digits),collapse="\t"),
- "\n\n",sep="\t"))
- } else if(x$model=="EB"){
- cat("ML common-regime EB model:\n")
- cat(paste("\ts^2\t",paste(paste("a[",1:N,"]",sep=""),collapse="\t")),
- "\tr\tk\tlogL\n")
- cat(paste("value",round(x$common.rate.model$sig2,digits),
- paste(round(x$common.rate.model$a,digits),collapse="\t"),
- round(x$common.rate.model$r,digits),
- x$common.rate.model$k,round(x$common.rate.model$logL,digits),
- "\n",sep="\t"))
- cat(paste("SE ",round(x$common.rate.model$SE.sig2,digits),
- paste(round(x$common.rate.model$SE.a,digits),collapse="\t"),
- round(x$common.rate.model$SE.r,digits),
- "\n\n",sep="\t"))
- cat("ML multi-regime EB model:\n")
- cat(paste("\t",paste(paste("s^2[",levels(x$regimes),"]",sep=""),collapse="\t"),"\t",
- paste(paste("a[",1:N,"]",sep=""),collapse="\t"),"\t",
- paste(paste("r[",levels(x$regimes),"]",sep=""),collapse="\t")),
- "\tk\tlogL\n")
- cat(paste("value",paste(round(x$multi.rate.model$sig2,digits),collapse="\t"),
- paste(round(x$multi.rate.model$a,digits),collapse="\t"),
- paste(round(x$multi.rate.model$r,digits),collapse="\t"),
- x$multi.rate.model$k,round(x$multi.rate.model$logL,digits),
- "\n",sep="\t"))
- cat(paste("SE ",paste(round(x$multi.rate.model$SE.sig2,digits),collapse="\t"),
- paste(round(x$multi.rate.model$SE.a,digits),collapse="\t"),
- paste(round(x$multi.rate.model$SE.r,digits),collapse="\t"),
- "\n\n",sep="\t"))
- }
- cat(paste("Likelihood ratio:",round(x$likelihood.ratio,digits),"\n"))
- if(!is.null(x$P.chisq))
- cat(paste("P-value (based on X^2):",round(x$P.chisq,digits),"\n\n"))
- else if(!is.null(x$P.sim))
- cat(paste("P-value (based on simulation):",round(x$P.sim,digits),"\n\n"))
- if(x$multi.rate.model$convergence==0&&x$common.rate.model$convergence==0)
- cat("R thinks it has found the ML solution.\n\n")
- else cat("One or the other optimization may not have converged.\n\n")
-}
-
-prbt.disc<-function(x,digits=digits){
- cat("ML common-rate model:\n")
-
- cat(paste("\t",paste(names(x$common.rate.model$rates),collapse="\t"),
- "\tk\tlogL\n",sep=""))
- cat(paste("value\t",paste(round(x$common.rate.model$rates,digits),
- collapse="\t"),"\t",max(x$index.matrix,na.rm=T),"\t",
- round(x$common.rate.model$logL,digits),"\n",sep=""))
- cat(paste("\nModel fitting method was \"",x$common.rate.model$method,
- "\".\n",sep=""))
- cat("\nML multi-rate model:\n")
- cat(paste("\t",paste(colnames(x$multi.rate.model$rates),collapse="\t"),
- "\tk\tlogL\n",sep=""))
- for(i in 1:nrow(x$multi.rate.model$rates)){
- if(i>1) cat(paste(rownames(x$multi.rate.model$rates)[i],"\t",
- paste(round(x$multi.rate.model$rates[i,],
- digits),collapse="\t"),"\n",sep=""))
- else if(i==1) cat(paste(rownames(x$multi.rate.model$rates)[i],"\t",
- paste(round(x$multi.rate.model$rates[i,],
- digits),collapse="\t"),"\t",x$N*max(x$index.matrix,na.rm=T),"\t",
- round(x$multi.rate.model$logL,digits),"\n",sep=""))
- }
- cat(paste("\nModel fitting method was \"",x$multi.rate.model$method,
- "\".\n",sep=""))
- cat(paste("\nLikelihood ratio:",round(x$likelihood.ratio,digits),"\n"))
- cat(paste("P-value (based on X^2):",round(x$P.chisq,digits),"\n\n"))
-}
-
-## posthoc comparison S3 method
-
-posthoc<-function(x, ...) UseMethod("posthoc")
-
-posthoc.ratebytree<-function(x,...){
- if(hasArg(p.adjust.method)) p.adjust.method<-list(...)$p.adjust.method
- else p.adjust.method<-"none"
- if(x$type!="continuous"){
- cat("Sorry. No posthoc method yet implemented for this data type.\n\n")
- } else {
- if(x$model=="BM") k<-2
- else if(x$model%in%c("EB","OU")) k<-3
- t<-df<-P<-matrix(0,x$m,x$m)
- for(i in 1:x$m){
- for(j in 1:x$m){
- x1<-if(x$model=="BM") x$multi.rate.model$sig2[i]
- else if(x$model=="OU") x$multi.rate.model$alpha[i]
- else if(x$model=="EB") x$multi.rate.model$r[i]
- x2<-if(x$model=="BM") x$multi.rate.model$sig2[j]
- else if(x$model=="OU") x$multi.rate.model$alpha[j]
- else if(x$model=="EB") x$multi.rate.model$r[j]
- s1<-x$multi.rate.model$SE.sig2[i]^2
- s2<-x$multi.rate.model$SE.sig2[j]^2
- n1<-x$n[i]
- n2<-x$n[j]
- se<-sqrt(s1+s2)
- df[i,j]<-(s1/n1+s2/n2)^2/
- ((s1/n1)^2/(n1-k)+(s2/n2)^2/(n2-k))
- t[i,j]<-(x1-x2)/se
- P[i,j]<-2*pt(abs(t[i,j]),df[i,j],lower.tail=FALSE)
- }
- }
- p<-P[upper.tri(P)]
- p<-p.adjust(p,method=p.adjust.method)
- P[upper.tri(P)]<-p
- P[lower.tri(P)]<-p
- }
- obj<-list(t=t,df=df,P=P,model=x$model,type=x$type,
- p.adjust.method=p.adjust.method)
- class(obj)<-"posthoc.ratebytree"
- obj
-}
-
-print.posthoc.ratebytree<-function(x,...){
- if(hasArg(digits)) digits<-list(...)$digits
- else digits<-4
- t<-x$t[upper.tri(x$t)]
- df<-x$df[upper.tri(x$df)]
- P<-x$P[upper.tri(x$P)]
- N<-nrow(x$P)
- paste("reg.",1:(N-1),"vs.",2:N)
- nn<-vector(mode="character",length=N*(N-1)/2)
- k<-1
- for(i in 1:N) for(j in i:N){
- if(i!=j){
- nn[k]<-paste("reg.",i," vs. ",j,sep="")
- k<-k+1
- }
- }
- X<-data.frame(t=t,df=df,P=P)
- rownames(X)<-nn
- cat(paste("\nPost-hoc test for \"",x$model,"\" model.\n",sep=""))
- cat(paste("(Comparison is of estimated values of",
- if(x$model=="BM") "sigma^2.)\n\n"
- else if(x$model=="OU") "alpha.)\n\n"
- else if(x$model=="EB") "r.)\n\n"))
- print(round(X,digits))
- cat(paste("\nP-values adjusted using method=\"",x$p.adjust.method,
- "\".\n\n",sep=""))
-}
-
-AIC.ratebytree<-function(object,...,k=2){
- aic<-data.frame(AIC=c(k*object$common.rate.model$k-2*object$common.rate.model$logL,
- k*object$multi.rate.model$k-2*object$multi.rate.model$logL),
- df=c(object$common.rate.model$k,object$multi.rate.model$k))
- model.names<-if(is.null(object$model)) 1 else object$model
- addtl.obj<-list(...)
- if(length(addtl.obj)>0){
- for(i in 1:length(addtl.obj)){
- aic<-rbind(aic,c(k*addtl.obj[[i]]$multi.rate.model$k-
- 2*addtl.obj[[i]]$multi.rate.model$logL,
- addtl.obj[[i]]$multi.rate.model$k))
- model.names<-c(model.names,
- if(is.null(addtl.obj[[i]]$model)) 1+i else addtl.obj[[i]]$model)
- }
- rownames(aic)<-c("common-rate",paste("multi-rate:",model.names,sep=""))
- } else rownames(aic)<-c("common-rate","multi-rate")
- aic
-}
+## method to compare the rate of evolution for a character between trees
+## continuous character method closely related to 'censored' approach of O'Meara et al. (2006; Evolution)
+## discrete character method fits Mk model of Lewis 2001
+## diversification method fits Yule or birth-death model of Nee et al. (1994) & Stadler (2012)
+## written by Liam J. Revell 2017
+
+ratebytree<-function(trees,x,...){
+ if(hasArg(type)) type<-list(...)$type
+ else if(!missing(x)&&!is.null(x)) {
+ if(is.factor(unlist(x))||is.character(unlist(x)))
+ type<-"discrete"
+ else type<-"continuous"
+ } else type<-"diversification"
+ if(type=="continuous") obj<-rbt.cont(trees,x,...)
+ else if(type=="discrete") obj<-rbt.disc(trees,x,...)
+ else if(type=="diversification") obj<-rbt.div(trees,...)
+ else {
+ cat(paste("type =",type,"not recognized.\n"))
+ obj<-NULL
+ }
+ obj
+}
+
+rbt.div<-function(trees,...){
+ if(hasArg(trace)) trace<-list(...)$trace
+ else trace<-FALSE
+ if(hasArg(digits)) digits<-list(...)$digits
+ else digits<-4
+ if(hasArg(test)) test<-list(...)$test
+ else test<-"chisq"
+ if(hasArg(quiet)) quiet<-list(...)$quiet
+ else quiet<-FALSE
+ if(hasArg(model)) model<-list(...)$model
+ else model<-"birth-death"
+ if(hasArg(rho)) rho<-list(...)$rho
+ else rho<-rep(1,length(trees))
+ if(hasArg(tol)) tol<-list(...)$tol
+ else tol<-1e-12
+ if(hasArg(iter)) iter<-list(...)$iter
+ else iter<-10
+ if(!inherits(trees,"multiPhylo"))
+ stop("trees should be object of class \"multiPhylo\".")
+ if(any(!sapply(trees,is.ultrametric))){
+ cat("One or more trees fails check is.ultrametric.\n")
+ cat("If you believe your tree to be ultrametric ")
+ cat("use force.ultrametric.\n")
+ stop()
+ }
+ t<-lapply(trees,function(phy) sort(branching.times(phy),
+ decreasing=TRUE))
+ if(model=="birth-death"){
+ fit.multi<-mapply(fit.bd,tree=trees,rho=rho,iter=iter,SIMPLIFY=FALSE)
+ logL.multi<-sum(sapply(fit.multi,logLik))
+ } else if(model=="equal-extinction"){
+ lik.eqmu<-function(theta,t,rho,trace=FALSE){
+ lam<-theta[1:length(t)]
+ mu<-theta[length(t)+1]
+ logL<-0
+ for(i in 1:length(t)) logL<-logL-lik.bd(c(lam[i],mu),t[[i]],rho[i])
+ if(trace) cat(paste(paste(c(lam,mu,logL),collapse="\t"),"\n",sep=""))
+ -logL
+ }
+ init.b<-sapply(trees,qb)
+ obj<-nlminb(c(init.b,0),lik.eqmu,t=t,rho=rho,trace=trace,
+ lower=rep(0,length(trees)+1),upper=rep(Inf,length(trees)+1))
+ count<-0
+ while(!is.finite(obj$objective)&&count<iter){
+ obj<-nlminb(runif(n=2,0,2)*c(init.b,0),lik.eqmu,t=t,rho=rho,
+ trace=trace,lower=rep(0,length(trees)+1),
+ upper=rep(Inf,length(trees)+1))
+ count<-count+1
+ }
+ fit.multi<-vector(mode="list",length=length(t))
+ for(i in 1:length(fit.multi)){
+ fit.multi[[i]]$b<-obj$par[i]
+ fit.multi[[i]]$d<-obj$par[length(obj$par)]
+ }
+ logL.multi<--obj$objective
+ } else if(model=="equal-speciation"){
+ lik.eqlam<-function(theta,t,rho,trace=FALSE){
+ lam<-theta[1]
+ mu<-theta[1:length(t)+1]
+ logL<-0
+ for(i in 1:length(t)) logL<-logL-lik.bd(c(lam,mu[i]),t[[i]],rho[i])
+ if(trace) cat(paste(paste(c(lam,mu,logL),collapse="\t"),"\n",sep=""))
+ -logL
+ }
+ init.b<-mean(sapply(trees,qb))
+ obj<-nlminb(c(init.b,rep(0,length(trees))),lik.eqlam,t=t,rho=rho,
+ trace=trace,lower=rep(0,length(trees)+1),
+ upper=rep(Inf,length(trees)+1))
+ print(obj)
+ count<-0
+ while(!is.finite(obj$objective)&&count<iter){
+ obj<-nlminb(runif(n=2,0,2)*c(init.b,rep(0,length(trees))),lik.eqlam,
+ t=t,rho=rho,trace=trace,lower=rep(0,length(trees)+1),
+ upper=rep(Inf,length(trees)+1))
+ count<-count+1
+ }
+ fit.multi<-vector(mode="list",length=length(t))
+ for(i in 1:length(fit.multi)){
+ fit.multi[[i]]$b<-obj$par[1]
+ fit.multi[[i]]$d<-obj$par[i+1]
+ }
+ logL.multi<--obj$objective
+ } else if(model=="Yule"){
+ interval<-if(hasArg(interval)) list(...)$interval else c(0,10*mean(sapply(trees,qb)))
+ fit.multi<-mapply(fit.yule,tree=trees,rho=rho,MoreArgs=list(interval=interval),
+ SIMPLIFY=FALSE)
+ logL.multi<-sum(sapply(fit.multi,logLik))
+ }
+ if(model!="Yule"){
+ lik.onerate<-function(theta,t,rho,model,trace=FALSE){
+ logL<-sum(-mapply(lik.bd,t=t,rho=rho,
+ MoreArgs=list(theta=theta)))
+ if(trace) cat(paste(theta[1],"\t",theta[2],"\t",logL,"\n"))
+ -logL
+ }
+ init.b<-mean(sapply(fit.multi,function(x) x$b))
+ init.d<-mean(sapply(fit.multi,function(x) x$d))
+ fit.onerate<-nlminb(c(init.b,init.d),lik.onerate,t=t,rho=rho,
+ model=model,trace=trace,lower=c(0,0),upper=rep(Inf,2))
+ count<-0
+ while(!is.finite(fit.onerate$objective)&&count<iter){
+ fit.onerate<-nlminb(runif(n=2,0,2)*c(init.b,init.d),lik.onerate,
+ t=t,rho=rho,model=model,trace=trace,lower=c(0,0),
+ upper=rep(Inf,2))
+ count<-count+1
+ }
+ rates.multi<-cbind(sapply(fit.multi,function(x) x$b),
+ sapply(fit.multi,function(x) x$d))
+ } else {
+ lik.yule<-function(theta,t,rho,trace=FALSE){
+ logL<-sum(-mapply(lik.bd,t=t,rho=rho,MoreArgs=list(theta=c(theta,0))))
+ if(trace) cat(paste(theta,logL,"\n",sep="\t"))
+ -logL
+ }
+ obj<-optimize(lik.yule,interval,t=t,rho=rho,trace=trace)
+ TOL<-diff(interval)*1e-3
+ convergence<-if((obj$minimum-TOL)<interval[1]||(obj$minimum+TOL)>interval[2]) 52 else 0
+ fit.onerate<-list(par=c(obj$minimum,0),objective=obj$objective,convergence=convergence,
+ message=if(convergence!=0) "Estimate at may be at limits of interval." else
+ "Probably converged.")
+ rates.multi<-cbind(sapply(fit.multi,function(x) x$b),
+ rep(0,length(trees)))
+ }
+ if(!is.null(names(trees))) rownames(rates.multi)<-names(trees)
+ else rownames(rates.multi)<-paste("tree",1:length(trees),sep="")
+ colnames(rates.multi)<-c("b","d")
+ LR<-2*(logL.multi+fit.onerate$objective)
+ km<-if(model=="birth-death") 2*length(trees) else
+ if(model=="equal-extinction") length(trees)+1 else
+ if(model=="equal-speciation") length(trees)+1 else
+ if(model=="Yule") length(trees)
+ k1<-if(model=="Yule") 1 else 2
+ P.chisq<-pchisq(LR,df=km-k1,lower.tail=FALSE)
+ obj<-list(
+ multi.rate.model=list(
+ logL=logL.multi,
+ rates=rates.multi,
+ k=km,
+ method=if(model=="Yule") "optimize" else "nlminb"),
+ common.rate.model=list(
+ logL=-fit.onerate$objective,
+ rates=setNames(fit.onerate$par,c("b","d")),
+ k=k1,
+ method=if(model=="Yule") "optimize" else "nlminb"),
+ model=model,N=length(trees),
+ n=sapply(trees,Ntip),
+ likelihood.ratio=LR,P.chisq=P.chisq,
+ type="diversification")
+ class(obj)<-"ratebytree"
+ obj
+}
+
+## discrete character ratebytree
+rbt.disc<-function(trees,x,...){
+ if(hasArg(trace)) trace<-list(...)$trace
+ else trace<-FALSE
+ if(hasArg(digits)) digits<-list(...)$digits
+ else digits<-4
+ if(hasArg(test)) test<-list(...)$test
+ else test<-"chisq"
+ if(hasArg(quiet)) quiet<-list(...)$quiet
+ else quiet<-FALSE
+ if(hasArg(model)) model<-list(...)$model
+ else model<-"ER"
+ if(!inherits(trees,"multiPhylo"))
+ stop("trees should be object of class \"multiPhylo\".")
+ if(!is.list(x)) stop("x should be a list of vectors.")
+ N<-length(trees)
+ fit.multi<-mapply(fitMk,tree=trees,x=x,MoreArgs=list(model=model),
+ SIMPLIFY=FALSE)
+ logL.multi<-sum(sapply(fit.multi,logLik))
+ lik.onerate<-function(theta,trees,x,model,trace=FALSE){
+ ss<-sort(unique(unlist(x)))
+ m<-length(ss)
+ if(is.character(model)){
+ rate<-matrix(NA,m,m)
+ if(model=="ER"){
+ k<-rate[]<-1
+ diag(rate)<-NA
+ }
+ else if(model=="ARD") {
+ k<-m*(m-1)
+ rate[col(rate)!=row(rate)]<-1:k
+ }
+ else if(model=="SYM") {
+ k<-m*(m-1)/2
+ ii<-col(rate)<row(rate)
+ rate[ii]<-1:k
+ rate<-t(rate)
+ rate[ii]<-1:k
+ }
+ } else {
+ rate<-model
+ k<-max(rate)
+ }
+ Q <- matrix(0, m, m)
+ index.matrix <- rate
+ tmp <- cbind(1:m, 1:m)
+ rate[tmp] <- 0
+ rate[rate == 0] <- k + 1
+ Q[]<-c(theta,0)[rate]
+ diag(Q)<--rowSums(Q)
+ colnames(Q)<-rownames(Q)<-ss
+ fit.onerate<-mapply(fitMk,tree=trees,x=x,MoreArgs=list(fixedQ=Q),
+ SIMPLIFY=FALSE)
+ -sum(sapply(fit.onerate,logLik))
+ }
+ pp<-sapply(fit.multi,function(x) x$rates)
+ pp<-if(is.matrix(pp)) rowMeans(pp) else mean(pp)
+ if(length(pp)>1){
+ fit.onerate<-optim(pp,lik.onerate,trees=trees,x=x,model=model)
+ } else {
+ fit.onerate<-optimize(lik.onerate,c(0,1000*pp),trees=trees,x=x,
+ model=model)
+ names(fit.onerate)<-c("par","value")
+ }
+ rates.multi<-t(sapply(fit.multi,function(x) x$rates))
+ if(is.character(model)){
+ m<-length(fit.multi[[1]]$states)
+ if(model=="ER"){
+ rates.multi<-t(rates.multi)
+ colnames(rates.multi)<-"q"
+ } else if(model=="SYM"){
+ if(length(fit.multi[[1]]$states)==2) rates.multi<-t(rates.multi)
+ colnames(rates.multi)<-
+ sapply(fit.multi[[1]]$states,function(x,y)
+ sapply(y,function(y,x) paste(x,"<->",y,sep=""),x=x),
+ y=fit.multi[[1]]$states)[lower.tri(matrix(0,m,m))]
+ } else if(model=="ARD"){
+ ii<-(upper.tri(matrix(0,m,m))+lower.tri(matrix(0,m,m))==TRUE)
+ colnames(rates.multi)<-
+ sapply(fit.multi[[1]]$states,function(x,y)
+ sapply(y,function(y,x) paste(y,"->",x,sep=""),x=x),
+ y=fit.multi[[1]]$states)[ii]
+ }
+ } else {
+ k<-max(fit.multi[[1]]$index.matrix,na.rm=TRUE)
+ if(k==1) rates.multi<-t(rates.multi)
+ foo<-function(i,index.matrix,states){
+ rc<-which(index.matrix==i,arr.ind=TRUE)
+ lab<-apply(rc,1,function(ind,ss) paste(ss[ind],collapse="->"),
+ ss=states)
+ if(length(lab)>1) paste(lab,collapse=",") else lab
+ }
+ colnames(rates.multi)<-sapply(1:k,
+ foo,fit.multi[[1]]$index.matrix,fit.multi[[1]]$states)
+ }
+ if(!is.null(names(trees))) rownames(rates.multi)<-names(trees)
+ else rownames(rates.multi)<-paste("tree",1:length(trees),sep="")
+ LR<-2*(logL.multi+fit.onerate$value)
+ km<-sum(sapply(fit.multi,function(x) max(x$index.matrix,na.rm=TRUE)))
+ k1<-length(pp)
+ P.chisq<-pchisq(LR,df=km-k1,lower.tail=FALSE)
+ obj<-list(
+ multi.rate.model=list(
+ logL=logL.multi,
+ rates=rates.multi,
+ method=fit.multi[[1]]$method),
+ common.rate.model=list(
+ logL=-fit.onerate$value,
+ rates=setNames(fit.onerate$par,colnames(rates.multi)),
+ method=if(length(pp)>1) "optim" else "optimize"),
+ index.matrix=fit.multi[[1]]$index.matrix,
+ states=fit.multi[[1]]$states,
+ pi=fit.multi[[1]]$pi,
+ model=model,N=N,n=sapply(trees,Ntip),
+ likelihood.ratio=LR,P.chisq=P.chisq,
+ type="discrete")
+ class(obj)<-"ratebytree"
+ obj
+}
+
+## continuous character ratebytree
+rbt.cont<-function(trees,x,...){
+ if(hasArg(tol)) tol<-list(...)$tol
+ else tol<-1e-8
+ if(hasArg(trace)) trace<-list(...)$trace
+ else trace<-FALSE
+ if(hasArg(digits)) digits<-list(...)$digits
+ else digits<-4
+ if(hasArg(test)) test<-list(...)$test
+ else test<-"chisq"
+ if(hasArg(quiet)) quiet<-list(...)$quiet
+ else quiet<-FALSE
+ if(hasArg(maxit)) maxit<-list(...)$maxit
+ else maxit<-500
+ if(hasArg(regimes)){
+ regimes<-list(...)$regimes
+ if(!is.factor(regimes)) regimes<-as.factor(regimes)
+ } else regimes<-as.factor(1:length(trees))
+ if(hasArg(model)) model<-list(...)$model
+ else model<-"BM"
+ if(!(model%in%c("BM","OU","EB"))){
+ cat(paste("model =",model,"not recognized. using model = \"BM\"\n"))
+ model<-"BM"
+ }
+ ## check trees & x
+ if(!inherits(trees,"multiPhylo"))
+ stop("trees should be object of class \"multiPhylo\".")
+ if(!is.list(x)) stop("x should be a list of vectors.")
+ if(hasArg(se)) se<-list(...)$se
+ else {
+ se<-x
+ for(i in 1:length(x)) se[[i]][1:length(se[[i]])]<-0
+ }
+ N<-length(trees)
+ m<-length(levels(regimes))
+ ## reorder the trait vectors in x & SEs in se
+ x<-mapply(function(x,t) x<-x[t$tip.label],x=x,t=trees,SIMPLIFY=FALSE)
+ se<-mapply(function(x,t) x<-x[t$tip.label],x=se,t=trees,SIMPLIFY=FALSE)
+ ## likelihood functions
+ lik.multi<-function(theta,trees,y,se,model,regimes,trace=FALSE){
+ m<-length(unique(regimes))
+ ind<-setNames(lapply(levels(regimes),function(x,y) which(y==x),y=regimes),
+ levels(regimes))
+ THETA<-list()
+ for(i in 1:m){
+ THETA[[i]]<-c(theta[i],theta[ind[[i]]+m])
+ if(model%in%c("OU","EB")) THETA[[i]]<-c(THETA[[i]],theta[i+m+N])
+ }
+ logL<-0
+ for(i in 1:m)
+ logL<-logL-lik.onerate(THETA[[i]],trees[ind[[i]]],y[ind[[i]]],se[ind[[i]]],
+ model=model,trace=FALSE)
+ if(trace){
+ cat(paste(paste(round(theta[1:m],digits),collapse="\t"),
+ if(model=="OU") paste(round(theta[1:m+m+N],digits),collapse="\t"),
+ if(model=="EB") paste(round(theta[1:m+m+N],digits),collapse="\t"),
+ round(logL,digits),"\n",sep="\t"))
+ flush.console()
+ }
+ -logL
+ }
+ lik.onerate<-function(theta,trees,y,se,model,trace=FALSE){
+ n<-sapply(trees,Ntip)
+ N<-length(trees)
+ sig<-theta[1]
+ a<-theta[1:N+1]
+ if(model=="OU") alpha<-theta[N+2]
+ if(model=="EB") r<-theta[N+2]
+ if(model=="BM") C<-lapply(trees,vcv)
+ else if(model=="OU") C<-lapply(trees,vcvPhylo,model="OU",alpha=alpha,
+ anc.nodes=FALSE)
+ else if(model=="EB") C<-lapply(trees,vcvPhylo,model="EB",r=r,
+ anc.nodes=FALSE)
+ E<-lapply(se,diag)
+ V<-mapply("+",lapply(C,"*",sig),E,SIMPLIFY=FALSE)
+ logL<-0
+ for(i in 1:N)
+ logL<-logL-t(y[[i]]-a[i])%*%solve(V[[i]])%*%(y[[i]]-
+ a[i])/2-n[i]*log(2*pi)/2-determinant(V[[i]])$modulus[1]/2
+ if(trace){
+ cat(paste(round(sig,digits),
+ if(model=="OU") round(alpha,digits),
+ if(model=="EB") round(r,digits),
+ round(logL,digits),"\n",sep="\t"))
+ flush.console()
+ }
+ -logL
+ }
+ ## first, fit multi-rate model
+ f1<-function(tree,x){
+ pvcv<-phyl.vcv(as.matrix(x),vcv(tree),1)
+ c(pvcv$R[1,1],pvcv$a[1,1])
+ }
+ P<-mapply(f1,trees,x,SIMPLIFY=FALSE)
+ PP<-list()
+ PP[[1]]<-vector()
+ for(i in 1:m)
+ PP[[1]][i]<-mean(sapply(P,function(x) x[1])[which(regimes==levels(regimes)[i])])
+ PP[[2]]<-sapply(P,function(x) x[2])
+ if(model%in%c("OU","EB")) PP[[3]]<-rep(0,m)
+ if(hasArg(init)){
+ init<-list(...)$init
+ if(!is.null(init$sigm)) PP[[1]]<-init$sigm
+ if(!is.null(init$am)) PP[[2]]<-init$am
+ if(model=="OU") if(!is.null(init$alpham)) PP[[3]]<-init$alpham
+ if(model=="EB") if(!is.null(init$rm)) PP[[3]]<-init$rm
+ }
+ p<-unlist(PP)
+ if(trace){
+ if(model=="BM"){
+ cat("\nOptimizing multi-rate model....\n")
+ cat(paste(paste("sig[",1:m,"]",sep="",collapse="\t"),"logL\n",sep="\t"))
+ } else if(model=="OU"){
+ cat("\nOptimizing multi-regime model....\n")
+ cat(paste(paste("sig[",1:m,"]",sep="",collapse="\t"),
+ paste("alpha[",1:m,"]",sep="",collapse="\t"),"logL\n",sep="\t"))
+ } else if(model=="EB"){
+ cat("\nOptimizing multi-regime model....\n")
+ cat(paste(paste("sig[",1:m,"]",sep="",collapse="\t"),
+ paste("r[",1:m,"]",sep="",collapse="\t"),"logL\n",sep="\t"))
+ }
+ }
+ fit.multi<-optim(p,lik.multi,trees=trees,y=x,se=se,model=model,
+ regimes=regimes,trace=trace,
+ method="L-BFGS-B",lower=c(rep(tol,m),rep(-Inf,N),
+ if(model%in%c("OU","EB")) rep(-Inf,m)),upper=c(rep(Inf,m),rep(Inf,N),
+ if(model%in%c("OU","EB")) rep(Inf,m)),control=list(maxit=maxit))
+ ## compute covariance matrix
+ H.multi<-hessian(lik.multi,fit.multi$par,trees=trees,y=x,
+ se=se,model=model,regimes=regimes,trace=FALSE)
+ Cov.multi<-if(qr(H.multi)$rank!=ncol(H.multi)) ginv(H.multi) else solve(H.multi)
+ ## now fit single-rate model
+ p<-c(mean(fit.multi$par[1:m]),fit.multi$par[1:N+m])
+ if(model%in%c("OU","EB")) p<-c(p,mean(fit.multi$par[1:m+m+N]))
+ if(hasArg(init)){
+ if(!is.null(init$sigc)) p[1]<-init$sigc
+ if(!is.null(init$ac)) p[1:N+1]<-init$ac
+ if(model=="OU") if(!is.null(init$alphac)) p[N+2]<-init$alphac
+ if(model=="EB") if(!is.null(init$rc)) p[N+2]<-init$rc
+ }
+ if(trace){
+ if(model=="BM"){
+ cat("\nOptimizing common-rate model....\n")
+ cat(paste("sig ","logL\n",sep="\t"))
+ } else if(model=="OU"){
+ cat("\nOptimizing common-regime model....\n")
+ cat(paste("sig ","alpha ","logL\n",sep="\t"))
+ } else if(model=="EB"){
+ cat("\nOptimizing common-regime mode.....\n")
+ cat(paste("sig ","r ","logL\n",sep="\t"))
+ }
+ }
+ fit.onerate<-optim(p,lik.onerate,trees=trees,y=x,se=se,model=model,
+ trace=trace,method="L-BFGS-B",
+ lower=c(tol,rep(-Inf,N),if(model=="OU") tol else if(model=="EB") -Inf),
+ upper=c(Inf,rep(Inf,N),if(model%in%c("OU","EB")) Inf),
+ control=list(maxit=maxit))
+ ## compute covariance matrix
+ H.onerate<-hessian(lik.onerate,fit.onerate$par,trees=trees,y=x,
+ se=se,model=model,trace=FALSE)
+ Cov.onerate<-if(qr(H.onerate)$rank!=ncol(H.onerate)) ginv(H.onerate) else solve(H.onerate)
+ ## compare models:
+ LR<-2*(-fit.multi$value+fit.onerate$value)
+ km<-N+m+if(model=="BM") 0 else if(model%in%c("OU","EB")) m
+ k1<-N+if(model=="BM") 1 else if(model%in%c("OU","EB")) 2
+ if(test=="simulation"&&model%in%c("OU","EB")){
+ cat("Simulation test not yet available for chosen model. Using chi-square test.\n")
+ test<-"chisq"
+ }
+ if(test=="chisq") P.chisq<-pchisq(LR,df=km-k1,lower.tail=FALSE)
+ else if(test=="simulation"){
+ if(!quiet) cat("Generating null distribution via simulation -> |")
+ flush.console()
+ if(hasArg(nsim)) nsim<-list(...)$nsim
+ else nsim<-100
+ X<-mapply(fastBM,tree=trees,a=as.list(fit.onerate$par[1:N+1]),
+ MoreArgs=list(sig2=fit.onerate$par[1],nsim=nsim),
+ SIMPLIFY=FALSE)
+ P.sim<-1/(nsim+1)
+ pct<-0.1
+ for(i in 1:nsim){
+ x.sim<-lapply(X,function(x,ind) x[,ind],ind=i)
+ f2<-function(x,se) sampleFrom(xbar=x,xvar=se^2,n=rep(1,length(x)))
+ x.sim<-mapply(f2,x=x.sim,se=se,SIMPLIFY=FALSE)
+ fit.sim<-ratebytree(trees,x.sim,se=se)
+ P.sim<-P.sim+(fit.sim$likelihood.ratio>=LR)/(nsim+1)
+ if(i/nsim>=pct){
+ if(!quiet) cat(".")
+ flush.console()
+ pct<-pct+0.1
+ }
+ }
+ if(!quiet) cat(".|\nDone!\n")
+ flush.console()
+ }
+ obj<-list(
+ multi.rate.model=list(sig2=fit.multi$par[1:m],
+ SE.sig2=sqrt(diag(Cov.multi)[1:m]),
+ a=fit.multi$par[1:N+m],
+ SE.a=sqrt(diag(Cov.multi)[1:N+m]),
+ alpha=if(model=="OU") fit.multi$par[1:m+m+N] else NULL,
+ SE.alpha=if(model=="OU") sqrt(diag(Cov.multi)[1:m+m+N]) else NULL,
+ r=if(model=="EB") fit.multi$par[1:N+m+N] else NULL,
+ SE.r=if(model=="EB") sqrt(diag(Cov.multi)[1:N+m+N]) else NULL,
+ k=km,
+ logL=-fit.multi$value,
+ counts=fit.multi$counts,convergence=fit.multi$convergence,
+ message=fit.multi$message),
+ common.rate.model=list(sig2=fit.onerate$par[1],
+ SE.sig2=sqrt(diag(Cov.onerate)[1]),
+ a=fit.onerate$par[1:N+1],
+ SE.a=sqrt(diag(Cov.onerate)[1:N+1]),
+ alpha=if(model=="OU") fit.onerate$par[N+2] else NULL,
+ SE.alpha=if(model=="OU") sqrt(diag(Cov.onerate)[N+2]) else NULL,
+ r=if(model=="EB") fit.onerate$par[N+2] else NULL,
+ SE.r=if(model=="EB") sqrt(diag(Cov.onerate)[N+2]) else NULL,
+ k=k1,
+ logL=-fit.onerate$value,
+ counts=fit.onerate$counts,convergence=fit.onerate$convergence,
+ message=fit.onerate$message),
+ model=model,
+ N=N,n=sapply(trees,Ntip),likelihood.ratio=LR,
+ regimes=regimes,m=m,
+ P.chisq=if(test=="chisq") P.chisq else NULL,
+ P.sim=if(test=="simulation") P.sim else NULL,
+ type="continuous")
+ class(obj)<-"ratebytree"
+ obj
+}
+
+## S3 print method for ratebytree
+print.ratebytree<-function(x,...){
+ if(hasArg(digits)) digits<-list(...)$digits
+ else digits<-4
+ if(x$type=="continuous") prbt.cont(x,digits=digits)
+ else if(x$type=="discrete") prbt.disc(x,digits=digits)
+ else if(x$type=="diversification") prbt.div(x,digits=digits)
+ else print(x)
+}
+
+prbt.div<-function(x,digits=digits){
+ cat("ML common diversification-rate model:")
+ cat("\n\tb\td\tk\tlog(L)")
+ cat(paste("\nvalue",round(x$common.rate.model$rates[1],digits),
+ round(x$common.rate.model$rates[2],digits),
+ x$common.rate.model$k,round(x$common.rate.model$logL,digits),
+ sep="\t"))
+ cat("\n\nML multi diversification-rate model:")
+ cat(paste("\n",paste(paste("b[",1:x$N,"]",sep=""),collapse="\t"),
+ paste(paste("d[",1:x$N,"]",sep=""),collapse="\t"),"k\tlog(L)",
+ sep="\t"))
+ cat(paste("\nvalue",paste(round(x$multi.rate.model$rates[,"b"],digits),
+ collapse="\t"),paste(round(x$multi.rate.model$rates[,"d"],digits),
+ collapse="\t"),x$multi.rate.model$k,round(x$multi.rate.model$logL,
+ digits),sep="\t"))
+ cat(paste("\n\nDiversification model was \"",x$model,"\".\n",sep=""))
+ cat(paste("Model fitting method was \"",x$multi.rate.model$method,
+ "\".\n",sep=""))
+ cat(paste("\nLikelihood ratio:",round(x$likelihood.ratio,digits),"\n"))
+ cat(paste("P-value (based on X^2):",round(x$P.chisq,digits),"\n\n"))
+}
+
+prbt.cont<-function(x,digits=digits){
+ N<-x$N
+ m<-x$m
+ if(x$model=="BM"){
+ cat("ML common-rate model:\n")
+ cat(paste("\ts^2\t",paste(paste("a[",1:N,"]",sep=""),collapse="\t")),
+ "\tk\tlogL\n")
+ cat(paste("value",round(x$common.rate.model$sig2,digits),
+ paste(round(x$common.rate.model$a,digits),collapse="\t"),
+ x$common.rate.model$k,round(x$common.rate.model$logL,digits),
+ "\n",sep="\t"))
+ cat(paste("SE ",round(x$common.rate.model$SE.sig2,digits),
+ paste(round(x$common.rate.model$SE.a,digits),collapse="\t"),
+ "\n\n",sep="\t"))
+ cat("ML multi-rate model:\n")
+ cat(paste("\t",paste(paste("s^2[",levels(x$regimes),"]",sep=""),collapse="\t"),"\t",
+ paste(paste("a[",1:N,"]",sep=""),collapse="\t")),
+ "\tk\tlogL\n")
+ cat(paste("value",paste(round(x$multi.rate.model$sig2,digits),collapse="\t"),
+ paste(round(x$multi.rate.model$a,digits),collapse="\t"),
+ x$multi.rate.model$k,round(x$multi.rate.model$logL,digits),
+ "\n",sep="\t"))
+ cat(paste("SE ",paste(round(x$multi.rate.model$SE.sig2,digits),collapse="\t"),
+ paste(round(x$multi.rate.model$SE.a,digits),collapse="\t"),
+ "\n\n",sep="\t"))
+ } else if(x$model=="OU"){
+ cat("ML common-regime OU model:\n")
+ cat(paste("\ts^2\t",paste(paste("a[",1:N,"]",sep=""),collapse="\t")),
+ "\talpha\tk\tlogL\n")
+ cat(paste("value",round(x$common.rate.model$sig2,digits),
+ paste(round(x$common.rate.model$a,digits),collapse="\t"),
+ round(x$common.rate.model$alpha,digits),
+ x$common.rate.model$k,round(x$common.rate.model$logL,digits),
+ "\n",sep="\t"))
+ cat(paste("SE ",round(x$common.rate.model$SE.sig2,digits),
+ paste(round(x$common.rate.model$SE.a,digits),collapse="\t"),
+ round(x$common.rate.model$SE.alpha,digits),
+ "\n\n",sep="\t"))
+ cat("ML multi-regime OU model:\n")
+ cat(paste("\t",paste(paste("s^2[",levels(x$regimes),"]",sep=""),collapse="\t"),"\t",
+ paste(paste("a[",1:N,"]",sep=""),collapse="\t"),"\t",
+ paste(paste("alp[",levels(x$regimes),"]",sep=""),collapse="\t")),
+ "\tk\tlogL\n")
+ cat(paste("value",paste(round(x$multi.rate.model$sig2,digits),collapse="\t"),
+ paste(round(x$multi.rate.model$a,digits),collapse="\t"),
+ paste(round(x$multi.rate.model$alpha,digits),collapse="\t"),
+ x$multi.rate.model$k,round(x$multi.rate.model$logL,digits),
+ "\n",sep="\t"))
+ cat(paste("SE ",paste(round(x$multi.rate.model$SE.sig2,digits),collapse="\t"),
+ paste(round(x$multi.rate.model$SE.a,digits),collapse="\t"),
+ paste(round(x$multi.rate.model$SE.alpha,digits),collapse="\t"),
+ "\n\n",sep="\t"))
+ } else if(x$model=="EB"){
+ cat("ML common-regime EB model:\n")
+ cat(paste("\ts^2\t",paste(paste("a[",1:N,"]",sep=""),collapse="\t")),
+ "\tr\tk\tlogL\n")
+ cat(paste("value",round(x$common.rate.model$sig2,digits),
+ paste(round(x$common.rate.model$a,digits),collapse="\t"),
+ round(x$common.rate.model$r,digits),
+ x$common.rate.model$k,round(x$common.rate.model$logL,digits),
+ "\n",sep="\t"))
+ cat(paste("SE ",round(x$common.rate.model$SE.sig2,digits),
+ paste(round(x$common.rate.model$SE.a,digits),collapse="\t"),
+ round(x$common.rate.model$SE.r,digits),
+ "\n\n",sep="\t"))
+ cat("ML multi-regime EB model:\n")
+ cat(paste("\t",paste(paste("s^2[",levels(x$regimes),"]",sep=""),collapse="\t"),"\t",
+ paste(paste("a[",1:N,"]",sep=""),collapse="\t"),"\t",
+ paste(paste("r[",levels(x$regimes),"]",sep=""),collapse="\t")),
+ "\tk\tlogL\n")
+ cat(paste("value",paste(round(x$multi.rate.model$sig2,digits),collapse="\t"),
+ paste(round(x$multi.rate.model$a,digits),collapse="\t"),
+ paste(round(x$multi.rate.model$r,digits),collapse="\t"),
+ x$multi.rate.model$k,round(x$multi.rate.model$logL,digits),
+ "\n",sep="\t"))
+ cat(paste("SE ",paste(round(x$multi.rate.model$SE.sig2,digits),collapse="\t"),
+ paste(round(x$multi.rate.model$SE.a,digits),collapse="\t"),
+ paste(round(x$multi.rate.model$SE.r,digits),collapse="\t"),
+ "\n\n",sep="\t"))
+ }
+ cat(paste("Likelihood ratio:",round(x$likelihood.ratio,digits),"\n"))
+ if(!is.null(x$P.chisq))
+ cat(paste("P-value (based on X^2):",round(x$P.chisq,digits),"\n\n"))
+ else if(!is.null(x$P.sim))
+ cat(paste("P-value (based on simulation):",round(x$P.sim,digits),"\n\n"))
+ if(x$multi.rate.model$convergence==0&&x$common.rate.model$convergence==0)
+ cat("R thinks it has found the ML solution.\n\n")
+ else cat("One or the other optimization may not have converged.\n\n")
+}
+
+prbt.disc<-function(x,digits=digits){
+ cat("ML common-rate model:\n")
+
+ cat(paste("\t",paste(names(x$common.rate.model$rates),collapse="\t"),
+ "\tk\tlogL\n",sep=""))
+ cat(paste("value\t",paste(round(x$common.rate.model$rates,digits),
+ collapse="\t"),"\t",max(x$index.matrix,na.rm=T),"\t",
+ round(x$common.rate.model$logL,digits),"\n",sep=""))
+ cat(paste("\nModel fitting method was \"",x$common.rate.model$method,
+ "\".\n",sep=""))
+ cat("\nML multi-rate model:\n")
+ cat(paste("\t",paste(colnames(x$multi.rate.model$rates),collapse="\t"),
+ "\tk\tlogL\n",sep=""))
+ for(i in 1:nrow(x$multi.rate.model$rates)){
+ if(i>1) cat(paste(rownames(x$multi.rate.model$rates)[i],"\t",
+ paste(round(x$multi.rate.model$rates[i,],
+ digits),collapse="\t"),"\n",sep=""))
+ else if(i==1) cat(paste(rownames(x$multi.rate.model$rates)[i],"\t",
+ paste(round(x$multi.rate.model$rates[i,],
+ digits),collapse="\t"),"\t",x$N*max(x$index.matrix,na.rm=T),"\t",
+ round(x$multi.rate.model$logL,digits),"\n",sep=""))
+ }
+ cat(paste("\nModel fitting method was \"",x$multi.rate.model$method,
+ "\".\n",sep=""))
+ cat(paste("\nLikelihood ratio:",round(x$likelihood.ratio,digits),"\n"))
+ cat(paste("P-value (based on X^2):",round(x$P.chisq,digits),"\n\n"))
+}
+
+## posthoc comparison S3 method
+
+posthoc<-function(x, ...) UseMethod("posthoc")
+
+posthoc.ratebytree<-function(x,...){
+ if(hasArg(p.adjust.method)) p.adjust.method<-list(...)$p.adjust.method
+ else p.adjust.method<-"none"
+ if(x$type!="continuous"){
+ cat("Sorry. No posthoc method yet implemented for this data type.\n\n")
+ } else {
+ if(x$model=="BM") k<-2
+ else if(x$model%in%c("EB","OU")) k<-3
+ t<-df<-P<-matrix(0,x$m,x$m)
+ for(i in 1:x$m){
+ for(j in 1:x$m){
+ x1<-if(x$model=="BM") x$multi.rate.model$sig2[i]
+ else if(x$model=="OU") x$multi.rate.model$alpha[i]
+ else if(x$model=="EB") x$multi.rate.model$r[i]
+ x2<-if(x$model=="BM") x$multi.rate.model$sig2[j]
+ else if(x$model=="OU") x$multi.rate.model$alpha[j]
+ else if(x$model=="EB") x$multi.rate.model$r[j]
+ s1<-x$multi.rate.model$SE.sig2[i]^2
+ s2<-x$multi.rate.model$SE.sig2[j]^2
+ n1<-x$n[i]
+ n2<-x$n[j]
+ se<-sqrt(s1+s2)
+ df[i,j]<-(s1/n1+s2/n2)^2/
+ ((s1/n1)^2/(n1-k)+(s2/n2)^2/(n2-k))
+ t[i,j]<-(x1-x2)/se
+ P[i,j]<-2*pt(abs(t[i,j]),df[i,j],lower.tail=FALSE)
+ }
+ }
+ p<-P[upper.tri(P)]
+ p<-p.adjust(p,method=p.adjust.method)
+ P[upper.tri(P)]<-p
+ P[lower.tri(P)]<-p
+ }
+ obj<-list(t=t,df=df,P=P,model=x$model,type=x$type,
+ p.adjust.method=p.adjust.method)
+ class(obj)<-"posthoc.ratebytree"
+ obj
+}
+
+print.posthoc.ratebytree<-function(x,...){
+ if(hasArg(digits)) digits<-list(...)$digits
+ else digits<-4
+ t<-x$t[upper.tri(x$t)]
+ df<-x$df[upper.tri(x$df)]
+ P<-x$P[upper.tri(x$P)]
+ N<-nrow(x$P)
+ paste("reg.",1:(N-1),"vs.",2:N)
+ nn<-vector(mode="character",length=N*(N-1)/2)
+ k<-1
+ for(i in 1:N) for(j in i:N){
+ if(i!=j){
+ nn[k]<-paste("reg.",i," vs. ",j,sep="")
+ k<-k+1
+ }
+ }
+ X<-data.frame(t=t,df=df,P=P)
+ rownames(X)<-nn
+ cat(paste("\nPost-hoc test for \"",x$model,"\" model.\n",sep=""))
+ cat(paste("(Comparison is of estimated values of",
+ if(x$model=="BM") "sigma^2.)\n\n"
+ else if(x$model=="OU") "alpha.)\n\n"
+ else if(x$model=="EB") "r.)\n\n"))
+ print(round(X,digits))
+ cat(paste("\nP-values adjusted using method=\"",x$p.adjust.method,
+ "\".\n\n",sep=""))
+}
+
+AIC.ratebytree<-function(object,...,k=2){
+ aic<-data.frame(AIC=c(k*object$common.rate.model$k-2*object$common.rate.model$logL,
+ k*object$multi.rate.model$k-2*object$multi.rate.model$logL),
+ df=c(object$common.rate.model$k,object$multi.rate.model$k))
+ model.names<-if(is.null(object$model)) 1 else object$model
+ addtl.obj<-list(...)
+ if(length(addtl.obj)>0){
+ for(i in 1:length(addtl.obj)){
+ aic<-rbind(aic,c(k*addtl.obj[[i]]$multi.rate.model$k-
+ 2*addtl.obj[[i]]$multi.rate.model$logL,
+ addtl.obj[[i]]$multi.rate.model$k))
+ model.names<-c(model.names,
+ if(is.null(addtl.obj[[i]]$model)) 1+i else addtl.obj[[i]]$model)
+ }
+ rownames(aic)<-c("common-rate",paste("multi-rate:",model.names,sep=""))
+ } else rownames(aic)<-c("common-rate","multi-rate")
+ aic
+}
diff --git a/R/rateshift.R b/R/rateshift.R
index 293b511..7b86b23 100644
--- a/R/rateshift.R
+++ b/R/rateshift.R
@@ -1,251 +1,251 @@
-## find the temporal position of a rate shift using ML
-## written by Liam J. Revell 2013, 2014, 2015, 2020
-
-rateshift<-function(tree,x,nrates=1,niter=10,method="ML",...){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- if(hasArg(tol)) tol<-list(...)$tol
- else tol<-1e-8
- if(hasArg(plot)) plot<-list(...)$plot
- else plot<-FALSE
- if(hasArg(print)) print<-list(...)$print
- else print<-FALSE
- if(hasArg(quiet)) quiet<-list(...)$quiet
- else quiet<-FALSE
- if(hasArg(minL)) minL<-list(...)$minL
- else minL<--1e12
- if(hasArg(fixed.shift)) fixed.shift<-list(...)$fixed.shift
- else fixed.shift<-FALSE
- if(hasArg(compute.se)) compute.se<-list(...)$compute.se
- else compute.se<-TRUE
- fn<-if(method=="ML") brownie.lite else brownieREML
- if(!fixed.shift[1]){
- if(print){
- cat("Optimization progress:\n\n")
- if(nrates>1) cat(paste(c("iter",paste("shift",1:(nrates-1),sep=":"),"logL\n"),collapse="\t"))
- else cat("iter\ts^2(1)\tlogL\n")
- } else if(niter==1) {
- if(!quiet) cat("Optimizing. Please wait.\n\n")
- flush.console()
- } else {
- if(!quiet) cat("Optimization progress:\n|")
- flush.console()
- }
- } else {
- if(!quiet) cat("Estimating rates conditioned on input shift points...\n\n")
- nrates<-if(fixed.shift[1]!=TRUE) length(fixed.shift)+1 else 1
- if(nrates>2) fixed.shift<-sort(fixed.shift)
- names(fixed.shift)<-NULL
- }
- lik<-function(par,tree,y,nrates,plot,print,iter,Tol,maxh,minL){
- shift<-sort(c(setNames(0,1),setNames(par,2:nrates)))
- if((any(shift[2:length(shift)]<=0)||any(shift>=maxh))) logL<-minL
- else {
- tree<-make.era.map(tree,shift,tol=Tol/10)
- if(plot){
- plotSimmap(tree,setNames(rainbow(nrates),1:nrates),lwd=3,ftype="off",mar=c(0.1,0.1,4.1,0.1))
- title(main=paste("Optimizing rate shift(s), round",iter,"....",sep=" "))
- for(i in 2:(length(shift))) lines(rep(shift[i],2),c(0,length(tree$tip.label)+1),lty="dashed")
- }
- logL<-fn(tree,y)$logL.multiple
- }
- if(print){
- if(nrates>1) cat(paste(c(iter,round(shift[2:length(shift)],4),round(logL,4),"\n"),collapse="\t"))
- else cat(paste(c(iter,round(par,4),round(logL,4),"\n"),collapse="\t"))
- }
- -logL
- }
- h<-max(nodeHeights(tree))
- N<-length(tree$tip.label)
- x<-x[tree$tip.label]
- if(!fixed.shift[1]){
- fit<-list()
- for(i in 1:niter){
- if(nrates>1) par<-sort(runif(n=nrates-1)*h)
- if(nrates==1){
- fit[[i]]<-fn(make.era.map(tree,setNames(0,1)),x)
- fit[[i]]$convergence<-if(fit[[i]]$convergence=="Optimization has converged.") 0 else 1
- } else suppressWarnings(fit[[i]]<-optim(par,lik,tree=tree,y=x,nrates=nrates,print=print,plot=plot,
- iter=i,Tol=tol,maxh=h,minL=minL))
- if(!print&&niter>1){
- if(!quiet) cat(".")
- flush.console()
- }
- }
- if(!print&&niter>1) if(!quiet) cat("|\nDone.\n\n")
- ll<-sapply(fit,function(x) if(nrates>1) x$value else -x$logL1)
- fit<-fit[[which(ll==min(ll))[1]]]
- frequency.best<-mean(ll<=(min(ll)+1e-4))
- likHess<-if(method=="ML") function(par,tree,y,nrates,tol,maxh){
- sig2<-par[1:nrates]
- shift<-if(nrates>1) setNames(c(0,par[1:(nrates-1)+nrates]),1:nrates) else shift<-setNames(0,1)
- tree<-make.era.map(tree,shift,tol=tol/10)
- mC<-multiC(tree)
- mC<-mapply("*",mC,sig2,SIMPLIFY=FALSE)
- V<-Reduce("+",mC)
- invV<-solve(V)
- a<-as.numeric(colSums(invV)%*%x/sum(invV))
- logL<-sum(dmnorm(y,rep(a,length(x)),V,log=TRUE))
- -logL
- } else if(method=="REML") function(par,tree,y,nrates,tol,maxh){
- sig2<-par[1:nrates]
- shift<-if(nrates>1) setNames(c(0,par[1:(nrates-1)+nrates]),1:nrates) else shift<-setNames(0,1)
- tree<-make.era.map(tree,shift,tol=tol/10)
- tree<-scaleByMap(tree,setNames(sig2,1:nrates))
- picX<-pic(y,tree,scaled=FALSE,var.contrasts=TRUE)
- logL<-sum(dnorm(picX[,1],sd=sqrt(picX[,2]),log=TRUE))
- -logL
- }
- mtree<-if(nrates>1) make.era.map(tree,c(0,fit$par)) else make.era.map(tree,0)
- obj<-fn(mtree,x)
- if(compute.se){
- H<-optimHess(c(obj$sig2.multiple,fit$par),likHess,tree=tree,y=x,nrates=nrates,tol=tol,maxh=h)
- vcv<-if(nrates>1) solve(H) else 1/H
- } else vcv<-matrix(-1,2*nrates-1,2*nrates-1)
- if(nrates>1)
- rownames(vcv)<-colnames(vcv)<-c(paste("sig2(",1:nrates,")",sep=""),paste(1:(nrates-1),"<->",2:nrates,sep=""))
- else rownames(vcv)<-colnames(vcv)<-"sig2(1)"
- obj<-list(sig2=setNames(obj$sig2.multiple,1:nrates),
- shift=if(nrates>1) setNames(fit$par,paste(1:(nrates-1),"<->",2:nrates,sep="")) else NULL,
- vcv=vcv,tree=mtree,logL=obj$logL.multiple,convergence=fit$convergence,message=fit$message,
- method=method,frequency.best=frequency.best)
- } else {
- mtree<-if(nrates>1) make.era.map(tree,c(0,fixed.shift)) else make.era.map(tree,0)
- fit<-fn(mtree,x)
- if(fit$convergence=="Optimization has converged.") fit$convergence<-0
- obj<-list(sig2=setNames(fit$sig2.multiple,1:nrates),
- shift=if(nrates>1) setNames(fixed.shift,paste(1:(nrates-1),"<->",2:nrates,sep="")) else NULL,
- vcv=matrix(-1,2*nrates-1,2*nrates-1),tree=mtree,logL=fit$logL.multiple,convergence=fit$convergence,
- method=method,message="Fitted rates from a fixed shifts",frequency.best=NA)
- }
- class(obj)<-"rateshift"
- if(plot) plot(obj,ftype="off")
- obj
-}
-
-## S3 print method for object of class "rateshift"
-## written by Liam J. Revell 2013, 2020
-print.rateshift<-function(x,...){
- sqroot<-function(x){
- if(length(x)==1) if(x>=0) sqrt(x) else NaN
- else sapply(x,sqroot)
- }
- if(hasArg(digits)) digits<-list(...)$digits
- else digits<-4
- x<-lapply(x,function(a,b) if(is.numeric(a)) round(a,b) else a,b=digits)
- cat(paste("ML ",length(x$sig2),"-rate model:\n",sep=""))
- tmp<-list()
- nn<-vector()
- for(i in 1:length(x$sig2)){
- tmp[2*i-1]<-x$sig2[i]
- tmp[2*i]<-sqroot(diag(x$vcv)[i])
- nn[2*i-1]<-paste("s^2(",names(x$sig2)[i],")",sep="")
- nn[2*i]<-paste("se(",names(x$sig2)[i],")",sep="")
- }
- tmp[2*i+1]<-2*length(x$sig2)
- tmp[2*i+2]<-x$logL
- nn[2*i+1]<-"k"
- nn[2*i+2]<-"logL"
- tmp<-as.data.frame(tmp)
- colnames(tmp)<-nn
- rownames(tmp)<-"value"
- print(tmp,digits=digits)
- if(!is.null(x$shift)){
- cat("\nShift point(s) between regimes (height above root):\n")
- tmp<-list()
- nn<-vector()
- for(i in 1:length(x$shift)){
- tmp[2*i-1]<-x$shift[i]
- tmp[2*i]<-sqroot(diag(x$vcv)[i+length(x$sig2)])
- nn[2*i-1]<-paste(strsplit(names(x$shift[i]),"<->")[[1]],collapse="|")
- nn[2*i]<-paste("se(",paste(strsplit(names(x$shift[i]),"<->")[[1]],
- collapse="|"),")",sep="")
- }
- tmp<-as.data.frame(tmp)
- colnames(tmp)<-nn
- rownames(tmp)<-"value"
- print(tmp,digits=digits)
- } else cat("\nThis is a one-rate model.\n")
- if(x$method=="ML") cat("\nModel fit using ML.\n\n")
- else if(x$method=="REML") cat("\nModel fit using REML.\n\n")
- cat(paste("Frequency of best fit:",x$frequency.best,"\n\n"))
- if (x$convergence==0) cat(paste("R thinks it has found the",x$method,"solution.\n\n"))
- else cat("Optimization may not have converged.\n\n")
-}
-
-## S3 logLik method for object of class "rateshift"
-## written by Liam J. Revell 2013, 2020
-logLik.rateshift<-function(object,...){
- logLik<-object$logL
- class(logLik)<-"logLik"
- attr(logLik,"df")<-2*length(object$sig2)
- logLik
-}
-
-## S3 plot method for object of class "rateshift"
-## written by Liam J. Revell 2015, 2020, 2021
-plot.rateshift<-function(x,...){
- if(length(x$sig2)>1){
- if(hasArg(col)) col<-list(...)$col
- else col<-c("blue","purple","red")
- cols<-colorRampPalette(col)(101)
- rr<-range(x$sig2)
- names(cols)<-seq(rr[1],rr[2],by=diff(rr)/100)
- ii<-sapply(x$sig2,function(x,y) order(abs(y-x))[1],
- y=as.numeric(names(cols)))
- colors<-setNames(cols[ii],names(ii))
- args<-list(x=x$tree,ylim=c(-0.1*Ntip(x$tree),Ntip(x$tree)),
- colors=colors,...)
- args$col<-NULL
- do.call(plot,args)
- nulo<-lapply(x$shift,function(x,y) lines(rep(x,2),c(1,Ntip(y)),
- lty="dotted",col="grey"),y=x$tree)
- add.color.bar(leg=0.5*max(nodeHeights(x$tree)),cols=cols,
- prompt=FALSE,x=0,y=-0.05*Ntip(x$tree),lims=round(rr,3),
- title=expression(sigma^2))
- } else {
- if(hasArg(col)) col<-list(...)$col
- else col<-"blue"
- colors<-setNames(col[1],1)
- args<-list(x=x$tree,ylim=c(-0.1*Ntip(x$tree),Ntip(x$tree)),
- colors=colors,...)
- args$col<-NULL
- do.call(plot,args)
- legend(x=0,y=0,
- legend=bquote(sigma^2 == .(round(x$sig2,3))),
- pch=15,col=colors,pt.cex=2,bty="n")
- }
-}
-
-## function to visualize the likelihood surface for 2 & 3 rate models (1 & 2 rate-shifts)
-## written by Liam J. Revell 2016
-
-likSurface.rateshift<-function(tree,x,nrates=2,shift.range=NULL,
- density=20,plot=TRUE,...){
- h<-max(nodeHeights(tree))
- if(is.null(shift.range)) shift.range<-c(0.01*h,0.99*h)
- shift<-seq(shift.range[1],shift.range[2],length.out=density)
- if(nrates==2){
- cat("Computing likelihood surface for 2-rate (1 rate-shift) model....\n")
- flush.console()
- logL1<-sapply(shift,function(s,tree,x) logLik(rateshift(tree,x,fixed.shift=s,
- quiet=TRUE)),tree=tree,x=x)
- if(plot) plot(shift,logL1,type="l",lwd=2,xlab="shift point",ylab="log(L)",...)
- cat("Done.\n")
- obj<-list(shift=shift,logL=logL1)
- } else if(nrates==3){
- cat("Computing likelihood surface for 3-rate (2 rate-shift) model....\n")
- flush.console()
- logL2<-sapply(shift,function(s1,s2,tree,x)
- sapply(s2,function(s2,s1,tree,x)
- logLik(rateshift(tree,x,fixed.shift=if(s1!=s2) c(s1,s2) else s1,
- quiet=TRUE)),s1=s1,tree=tree,x=x),s2=shift,tree=tree,x=x)
- if(plot) contour(shift,shift,logL2,nlevels=20,xlab="shift 1 (or 2)",
- ylab="shift 2 (or 1)",...)
- cat("Done.\n")
- obj<-list(shift=shift,logL=logL2)
- } else if((nrates%in%c(2,3))==FALSE){
- cat("Method only available for nrates==2 and nrates==3\n")
- obj<-NULL
- }
- invisible(obj)
-}
+## find the temporal position of a rate shift using ML
+## written by Liam J. Revell 2013, 2014, 2015, 2020
+
+rateshift<-function(tree,x,nrates=1,niter=10,method="ML",...){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ if(hasArg(tol)) tol<-list(...)$tol
+ else tol<-1e-8
+ if(hasArg(plot)) plot<-list(...)$plot
+ else plot<-FALSE
+ if(hasArg(print)) print<-list(...)$print
+ else print<-FALSE
+ if(hasArg(quiet)) quiet<-list(...)$quiet
+ else quiet<-FALSE
+ if(hasArg(minL)) minL<-list(...)$minL
+ else minL<--1e12
+ if(hasArg(fixed.shift)) fixed.shift<-list(...)$fixed.shift
+ else fixed.shift<-FALSE
+ if(hasArg(compute.se)) compute.se<-list(...)$compute.se
+ else compute.se<-TRUE
+ fn<-if(method=="ML") brownie.lite else brownieREML
+ if(!fixed.shift[1]){
+ if(print){
+ cat("Optimization progress:\n\n")
+ if(nrates>1) cat(paste(c("iter",paste("shift",1:(nrates-1),sep=":"),"logL\n"),collapse="\t"))
+ else cat("iter\ts^2(1)\tlogL\n")
+ } else if(niter==1) {
+ if(!quiet) cat("Optimizing. Please wait.\n\n")
+ flush.console()
+ } else {
+ if(!quiet) cat("Optimization progress:\n|")
+ flush.console()
+ }
+ } else {
+ if(!quiet) cat("Estimating rates conditioned on input shift points...\n\n")
+ nrates<-if(fixed.shift[1]!=TRUE) length(fixed.shift)+1 else 1
+ if(nrates>2) fixed.shift<-sort(fixed.shift)
+ names(fixed.shift)<-NULL
+ }
+ lik<-function(par,tree,y,nrates,plot,print,iter,Tol,maxh,minL){
+ shift<-sort(c(setNames(0,1),setNames(par,2:nrates)))
+ if((any(shift[2:length(shift)]<=0)||any(shift>=maxh))) logL<-minL
+ else {
+ tree<-make.era.map(tree,shift,tol=Tol/10)
+ if(plot){
+ plotSimmap(tree,setNames(rainbow(nrates),1:nrates),lwd=3,ftype="off",mar=c(0.1,0.1,4.1,0.1))
+ title(main=paste("Optimizing rate shift(s), round",iter,"....",sep=" "))
+ for(i in 2:(length(shift))) lines(rep(shift[i],2),c(0,length(tree$tip.label)+1),lty="dashed")
+ }
+ logL<-fn(tree,y)$logL.multiple
+ }
+ if(print){
+ if(nrates>1) cat(paste(c(iter,round(shift[2:length(shift)],4),round(logL,4),"\n"),collapse="\t"))
+ else cat(paste(c(iter,round(par,4),round(logL,4),"\n"),collapse="\t"))
+ }
+ -logL
+ }
+ h<-max(nodeHeights(tree))
+ N<-length(tree$tip.label)
+ x<-x[tree$tip.label]
+ if(!fixed.shift[1]){
+ fit<-list()
+ for(i in 1:niter){
+ if(nrates>1) par<-sort(runif(n=nrates-1)*h)
+ if(nrates==1){
+ fit[[i]]<-fn(make.era.map(tree,setNames(0,1)),x)
+ fit[[i]]$convergence<-if(fit[[i]]$convergence=="Optimization has converged.") 0 else 1
+ } else suppressWarnings(fit[[i]]<-optim(par,lik,tree=tree,y=x,nrates=nrates,print=print,plot=plot,
+ iter=i,Tol=tol,maxh=h,minL=minL))
+ if(!print&&niter>1){
+ if(!quiet) cat(".")
+ flush.console()
+ }
+ }
+ if(!print&&niter>1) if(!quiet) cat("|\nDone.\n\n")
+ ll<-sapply(fit,function(x) if(nrates>1) x$value else -x$logL1)
+ fit<-fit[[which(ll==min(ll))[1]]]
+ frequency.best<-mean(ll<=(min(ll)+1e-4))
+ likHess<-if(method=="ML") function(par,tree,y,nrates,tol,maxh){
+ sig2<-par[1:nrates]
+ shift<-if(nrates>1) setNames(c(0,par[1:(nrates-1)+nrates]),1:nrates) else shift<-setNames(0,1)
+ tree<-make.era.map(tree,shift,tol=tol/10)
+ mC<-multiC(tree)
+ mC<-mapply("*",mC,sig2,SIMPLIFY=FALSE)
+ V<-Reduce("+",mC)
+ invV<-solve(V)
+ a<-as.numeric(colSums(invV)%*%x/sum(invV))
+ logL<-sum(dmnorm(y,rep(a,length(x)),V,log=TRUE))
+ -logL
+ } else if(method=="REML") function(par,tree,y,nrates,tol,maxh){
+ sig2<-par[1:nrates]
+ shift<-if(nrates>1) setNames(c(0,par[1:(nrates-1)+nrates]),1:nrates) else shift<-setNames(0,1)
+ tree<-make.era.map(tree,shift,tol=tol/10)
+ tree<-scaleByMap(tree,setNames(sig2,1:nrates))
+ picX<-pic(y,tree,scaled=FALSE,var.contrasts=TRUE)
+ logL<-sum(dnorm(picX[,1],sd=sqrt(picX[,2]),log=TRUE))
+ -logL
+ }
+ mtree<-if(nrates>1) make.era.map(tree,c(0,fit$par)) else make.era.map(tree,0)
+ obj<-fn(mtree,x)
+ if(compute.se){
+ H<-optimHess(c(obj$sig2.multiple,fit$par),likHess,tree=tree,y=x,nrates=nrates,tol=tol,maxh=h)
+ vcv<-if(nrates>1) solve(H) else 1/H
+ } else vcv<-matrix(-1,2*nrates-1,2*nrates-1)
+ if(nrates>1)
+ rownames(vcv)<-colnames(vcv)<-c(paste("sig2(",1:nrates,")",sep=""),paste(1:(nrates-1),"<->",2:nrates,sep=""))
+ else rownames(vcv)<-colnames(vcv)<-"sig2(1)"
+ obj<-list(sig2=setNames(obj$sig2.multiple,1:nrates),
+ shift=if(nrates>1) setNames(fit$par,paste(1:(nrates-1),"<->",2:nrates,sep="")) else NULL,
+ vcv=vcv,tree=mtree,logL=obj$logL.multiple,convergence=fit$convergence,message=fit$message,
+ method=method,frequency.best=frequency.best)
+ } else {
+ mtree<-if(nrates>1) make.era.map(tree,c(0,fixed.shift)) else make.era.map(tree,0)
+ fit<-fn(mtree,x)
+ if(fit$convergence=="Optimization has converged.") fit$convergence<-0
+ obj<-list(sig2=setNames(fit$sig2.multiple,1:nrates),
+ shift=if(nrates>1) setNames(fixed.shift,paste(1:(nrates-1),"<->",2:nrates,sep="")) else NULL,
+ vcv=matrix(-1,2*nrates-1,2*nrates-1),tree=mtree,logL=fit$logL.multiple,convergence=fit$convergence,
+ method=method,message="Fitted rates from a fixed shifts",frequency.best=NA)
+ }
+ class(obj)<-"rateshift"
+ if(plot) plot(obj,ftype="off")
+ obj
+}
+
+## S3 print method for object of class "rateshift"
+## written by Liam J. Revell 2013, 2020
+print.rateshift<-function(x,...){
+ sqroot<-function(x){
+ if(length(x)==1) if(x>=0) sqrt(x) else NaN
+ else sapply(x,sqroot)
+ }
+ if(hasArg(digits)) digits<-list(...)$digits
+ else digits<-4
+ x<-lapply(x,function(a,b) if(is.numeric(a)) round(a,b) else a,b=digits)
+ cat(paste("ML ",length(x$sig2),"-rate model:\n",sep=""))
+ tmp<-list()
+ nn<-vector()
+ for(i in 1:length(x$sig2)){
+ tmp[2*i-1]<-x$sig2[i]
+ tmp[2*i]<-sqroot(diag(x$vcv)[i])
+ nn[2*i-1]<-paste("s^2(",names(x$sig2)[i],")",sep="")
+ nn[2*i]<-paste("se(",names(x$sig2)[i],")",sep="")
+ }
+ tmp[2*i+1]<-2*length(x$sig2)
+ tmp[2*i+2]<-x$logL
+ nn[2*i+1]<-"k"
+ nn[2*i+2]<-"logL"
+ tmp<-as.data.frame(tmp)
+ colnames(tmp)<-nn
+ rownames(tmp)<-"value"
+ print(tmp,digits=digits)
+ if(!is.null(x$shift)){
+ cat("\nShift point(s) between regimes (height above root):\n")
+ tmp<-list()
+ nn<-vector()
+ for(i in 1:length(x$shift)){
+ tmp[2*i-1]<-x$shift[i]
+ tmp[2*i]<-sqroot(diag(x$vcv)[i+length(x$sig2)])
+ nn[2*i-1]<-paste(strsplit(names(x$shift[i]),"<->")[[1]],collapse="|")
+ nn[2*i]<-paste("se(",paste(strsplit(names(x$shift[i]),"<->")[[1]],
+ collapse="|"),")",sep="")
+ }
+ tmp<-as.data.frame(tmp)
+ colnames(tmp)<-nn
+ rownames(tmp)<-"value"
+ print(tmp,digits=digits)
+ } else cat("\nThis is a one-rate model.\n")
+ if(x$method=="ML") cat("\nModel fit using ML.\n\n")
+ else if(x$method=="REML") cat("\nModel fit using REML.\n\n")
+ cat(paste("Frequency of best fit:",x$frequency.best,"\n\n"))
+ if (x$convergence==0) cat(paste("R thinks it has found the",x$method,"solution.\n\n"))
+ else cat("Optimization may not have converged.\n\n")
+}
+
+## S3 logLik method for object of class "rateshift"
+## written by Liam J. Revell 2013, 2020
+logLik.rateshift<-function(object,...){
+ logLik<-object$logL
+ class(logLik)<-"logLik"
+ attr(logLik,"df")<-2*length(object$sig2)
+ logLik
+}
+
+## S3 plot method for object of class "rateshift"
+## written by Liam J. Revell 2015, 2020, 2021
+plot.rateshift<-function(x,...){
+ if(length(x$sig2)>1){
+ if(hasArg(col)) col<-list(...)$col
+ else col<-c("blue","purple","red")
+ cols<-colorRampPalette(col)(101)
+ rr<-range(x$sig2)
+ names(cols)<-seq(rr[1],rr[2],by=diff(rr)/100)
+ ii<-sapply(x$sig2,function(x,y) order(abs(y-x))[1],
+ y=as.numeric(names(cols)))
+ colors<-setNames(cols[ii],names(ii))
+ args<-list(x=x$tree,ylim=c(-0.1*Ntip(x$tree),Ntip(x$tree)),
+ colors=colors,...)
+ args$col<-NULL
+ do.call(plot,args)
+ nulo<-lapply(x$shift,function(x,y) lines(rep(x,2),c(1,Ntip(y)),
+ lty="dotted",col="grey"),y=x$tree)
+ add.color.bar(leg=0.5*max(nodeHeights(x$tree)),cols=cols,
+ prompt=FALSE,x=0,y=-0.05*Ntip(x$tree),lims=round(rr,3),
+ title=expression(sigma^2))
+ } else {
+ if(hasArg(col)) col<-list(...)$col
+ else col<-"blue"
+ colors<-setNames(col[1],1)
+ args<-list(x=x$tree,ylim=c(-0.1*Ntip(x$tree),Ntip(x$tree)),
+ colors=colors,...)
+ args$col<-NULL
+ do.call(plot,args)
+ legend(x=0,y=0,
+ legend=bquote(sigma^2 == .(round(x$sig2,3))),
+ pch=15,col=colors,pt.cex=2,bty="n")
+ }
+}
+
+## function to visualize the likelihood surface for 2 & 3 rate models (1 & 2 rate-shifts)
+## written by Liam J. Revell 2016
+
+likSurface.rateshift<-function(tree,x,nrates=2,shift.range=NULL,
+ density=20,plot=TRUE,...){
+ h<-max(nodeHeights(tree))
+ if(is.null(shift.range)) shift.range<-c(0.01*h,0.99*h)
+ shift<-seq(shift.range[1],shift.range[2],length.out=density)
+ if(nrates==2){
+ cat("Computing likelihood surface for 2-rate (1 rate-shift) model....\n")
+ flush.console()
+ logL1<-sapply(shift,function(s,tree,x) logLik(rateshift(tree,x,fixed.shift=s,
+ quiet=TRUE)),tree=tree,x=x)
+ if(plot) plot(shift,logL1,type="l",lwd=2,xlab="shift point",ylab="log(L)",...)
+ cat("Done.\n")
+ obj<-list(shift=shift,logL=logL1)
+ } else if(nrates==3){
+ cat("Computing likelihood surface for 3-rate (2 rate-shift) model....\n")
+ flush.console()
+ logL2<-sapply(shift,function(s1,s2,tree,x)
+ sapply(s2,function(s2,s1,tree,x)
+ logLik(rateshift(tree,x,fixed.shift=if(s1!=s2) c(s1,s2) else s1,
+ quiet=TRUE)),s1=s1,tree=tree,x=x),s2=shift,tree=tree,x=x)
+ if(plot) contour(shift,shift,logL2,nlevels=20,xlab="shift 1 (or 2)",
+ ylab="shift 2 (or 1)",...)
+ cat("Done.\n")
+ obj<-list(shift=shift,logL=logL2)
+ } else if((nrates%in%c(2,3))==FALSE){
+ cat("Method only available for nrates==2 and nrates==3\n")
+ obj<-NULL
+ }
+ invisible(obj)
+}
diff --git a/R/read.newick.R b/R/read.newick.R
index 8490798..d8c0d15 100644
--- a/R/read.newick.R
+++ b/R/read.newick.R
@@ -1,125 +1,125 @@
-## function to read a Newick string with node labels & (possible) singles
-## written by Liam J. Revell 2013, 2014, 2015, 2017
-
-read.newick<-function(file="",text,...){
- # check to see if reading from file
- if(file!="") text<-scan(file,sep="\n",what="character",...)
- if(length(text)>1){
- tree<-lapply(text,newick)
- class(tree)<-"multiPhylo"
- } else tree<-newick(text)
- return(tree)
-}
-
-# main Newick string function
-# written by Liam J. Revell 2013, 2014
-newick<-function(text){
- text<-unlist(strsplit(text, NULL))
- tip.label<-vector(mode="character")
- node.label<-vector(mode="character")
- edge<-matrix(NA,sum(text=="(")+sum(text==","),2)
- ei<-vector()
- edge.length<-vector()
- currnode<-1
- Nnode<-currnode
- i<-j<-k<-1
- while(text[i]!=";"){
- if(text[i]=="("){
- edge[j,1]<-currnode
- i<-i+1
- # is the next element a label?
- if(is.na(match(text[i],c("(",")",",",":",";")))){
- temp<-getLabel(text,i)
- tip.label[k]<-temp$label
- i<-temp$end
- edge[j,2]<--k
- k<-k+1
- # is there a branch length?
- if(text[i]==":"){
- temp<-getEdgeLength(text,i)
- edge.length[j]<-temp$edge.length
- i<-temp$end
- }
- } else if(text[i]=="("){
- Nnode<-Nnode+1 # creating a new internal node
- currnode<-Nnode
- edge[j,2]<-currnode # move to new internal node
- ei[currnode]<-j
- }
- j<-j+1
- } else if(text[i]==")"){
- i<-i+1
- # is the next element a label?
- if(is.na(match(text[i],c("(",")",",",":",";")))){
- temp<-getLabel(text,i)
- node.label[currnode]<-temp$label
- i<-temp$end
- } else node.label[currnode]<-NA
- ii<-ei[currnode]
- # is there a branch length?
- if(text[i]==":"){
- temp<-getEdgeLength(text,i)
- if(currnode>1) edge.length[ii]<-temp$edge.length
- else root.edge<-temp$edge.length
- i<-temp$end
- }
- if(currnode>1) currnode<-edge[ii,1] # move down the tree `
- } else if(text[i]==","){
- edge[j,1]<-currnode
- i<-i+1
- # is the next element a label?
- if(is.na(match(text[i],c("(",")",",",":",";")))){
- temp<-getLabel(text,i)
- tip.label[k]<-temp$label
- i<-temp$end
- edge[j,2]<--k
- k<-k+1
- # is there a branch length?
- if(text[i]==":"){
- temp<-getEdgeLength(text,i)
- edge.length[j]<-temp$edge.length
- i<-temp$end
- }
- } else if(text[i]=="("){
- Nnode<-Nnode+1 # creating a new internal node
- currnode<-Nnode
- edge[j,2]<-currnode # move to internal node
- ei[currnode]<-j
- }
- j<-j+1
- }
- }
- Ntip<-k-1
- edge<-edge[!is.na(edge[,2]),,drop=F]
- edge[edge>0]<-edge[edge>0]+Ntip
- edge[edge<0]<--edge[edge<0]
- edge.length[is.na(edge.length)]<-0
- if(length(edge.length)==0) edge.length<-NULL
- if(all(is.na(node.label))) node.label<-NULL
- else node.label[is.na(node.label)]<-""
- # assemble into "phylo" object
- tree<-list(edge=edge,Nnode=as.integer(Nnode),tip.label=tip.label,
- edge.length=edge.length,node.label=node.label)
- class(tree)<-"phylo"
- attr(tree,"order")<-"cladewise"
- tree
-}
-
-# function gets label
-# written by Liam J. Revell 2011-2013, 2014
-getLabel<-function(text,start,stop.char=c(",",":",")",";")){
- i<-0
- while(is.na(match(text[i+start],stop.char))) i<-i+1
- label<-paste(text[0:(i-1)+start],collapse="")
- return(list(label=paste(label,collapse=""),end=i+start))
-}
-
-# function gets branch length
-# written by Liam J. Revell 2011-2013, 2014
-getEdgeLength<-function(text,start){
- i<-start+1
- stop.char<-c(",",")",";")
- while(is.na(match(text[i],stop.char))) i<-i+1
- edge.length<-as.numeric(paste(text[(start+1):(i-1)],collapse=""))
- return(list(edge.length=edge.length,end=i))
-}
+## function to read a Newick string with node labels & (possible) singles
+## written by Liam J. Revell 2013, 2014, 2015, 2017
+
+read.newick<-function(file="",text,...){
+ # check to see if reading from file
+ if(file!="") text<-scan(file,sep="\n",what="character",...)
+ if(length(text)>1){
+ tree<-lapply(text,newick)
+ class(tree)<-"multiPhylo"
+ } else tree<-newick(text)
+ return(tree)
+}
+
+# main Newick string function
+# written by Liam J. Revell 2013, 2014
+newick<-function(text){
+ text<-unlist(strsplit(text, NULL))
+ tip.label<-vector(mode="character")
+ node.label<-vector(mode="character")
+ edge<-matrix(NA,sum(text=="(")+sum(text==","),2)
+ ei<-vector()
+ edge.length<-vector()
+ currnode<-1
+ Nnode<-currnode
+ i<-j<-k<-1
+ while(text[i]!=";"){
+ if(text[i]=="("){
+ edge[j,1]<-currnode
+ i<-i+1
+ # is the next element a label?
+ if(is.na(match(text[i],c("(",")",",",":",";")))){
+ temp<-getLabel(text,i)
+ tip.label[k]<-temp$label
+ i<-temp$end
+ edge[j,2]<--k
+ k<-k+1
+ # is there a branch length?
+ if(text[i]==":"){
+ temp<-getEdgeLength(text,i)
+ edge.length[j]<-temp$edge.length
+ i<-temp$end
+ }
+ } else if(text[i]=="("){
+ Nnode<-Nnode+1 # creating a new internal node
+ currnode<-Nnode
+ edge[j,2]<-currnode # move to new internal node
+ ei[currnode]<-j
+ }
+ j<-j+1
+ } else if(text[i]==")"){
+ i<-i+1
+ # is the next element a label?
+ if(is.na(match(text[i],c("(",")",",",":",";")))){
+ temp<-getLabel(text,i)
+ node.label[currnode]<-temp$label
+ i<-temp$end
+ } else node.label[currnode]<-NA
+ ii<-ei[currnode]
+ # is there a branch length?
+ if(text[i]==":"){
+ temp<-getEdgeLength(text,i)
+ if(currnode>1) edge.length[ii]<-temp$edge.length
+ else root.edge<-temp$edge.length
+ i<-temp$end
+ }
+ if(currnode>1) currnode<-edge[ii,1] # move down the tree `
+ } else if(text[i]==","){
+ edge[j,1]<-currnode
+ i<-i+1
+ # is the next element a label?
+ if(is.na(match(text[i],c("(",")",",",":",";")))){
+ temp<-getLabel(text,i)
+ tip.label[k]<-temp$label
+ i<-temp$end
+ edge[j,2]<--k
+ k<-k+1
+ # is there a branch length?
+ if(text[i]==":"){
+ temp<-getEdgeLength(text,i)
+ edge.length[j]<-temp$edge.length
+ i<-temp$end
+ }
+ } else if(text[i]=="("){
+ Nnode<-Nnode+1 # creating a new internal node
+ currnode<-Nnode
+ edge[j,2]<-currnode # move to internal node
+ ei[currnode]<-j
+ }
+ j<-j+1
+ }
+ }
+ Ntip<-k-1
+ edge<-edge[!is.na(edge[,2]),,drop=F]
+ edge[edge>0]<-edge[edge>0]+Ntip
+ edge[edge<0]<--edge[edge<0]
+ edge.length[is.na(edge.length)]<-0
+ if(length(edge.length)==0) edge.length<-NULL
+ if(all(is.na(node.label))) node.label<-NULL
+ else node.label[is.na(node.label)]<-""
+ # assemble into "phylo" object
+ tree<-list(edge=edge,Nnode=as.integer(Nnode),tip.label=tip.label,
+ edge.length=edge.length,node.label=node.label)
+ class(tree)<-"phylo"
+ attr(tree,"order")<-"cladewise"
+ tree
+}
+
+# function gets label
+# written by Liam J. Revell 2011-2013, 2014
+getLabel<-function(text,start,stop.char=c(",",":",")",";")){
+ i<-0
+ while(is.na(match(text[i+start],stop.char))) i<-i+1
+ label<-paste(text[0:(i-1)+start],collapse="")
+ return(list(label=paste(label,collapse=""),end=i+start))
+}
+
+# function gets branch length
+# written by Liam J. Revell 2011-2013, 2014
+getEdgeLength<-function(text,start){
+ i<-start+1
+ stop.char<-c(",",")",";")
+ while(is.na(match(text[i],stop.char))) i<-i+1
+ edge.length<-as.numeric(paste(text[(start+1):(i-1)],collapse=""))
+ return(list(edge.length=edge.length,end=i))
+}
diff --git a/R/read.simmap.R b/R/read.simmap.R
index 7211c6d..4ecbd23 100644
--- a/R/read.simmap.R
+++ b/R/read.simmap.R
@@ -1,350 +1,350 @@
-# function reads SIMMAP v1.0 & v1.5 style trees into file
-# written by Liam J. Revell 2011-2015
-
-read.simmap<-function(file="",text,format="nexus",rev.order=TRUE,version=1.0){
- if(file!=""){
- trans<-NULL
- if(format=="nexus"){
- XX<-readNexusData(file,version)
- text<-XX$text
- trans<-XX$trans
- Ntree<-XX$Ntree
- } else if(format=="phylip"){
- text<-scan(file,sep="\n",what="character")
- Ntree<-length(text)
-
- }
- } else {
- trans<-NULL
- Ntree<-length(text)
- }
- tree<-lapply(text,text_to_tree,version,rev.order,trans)
- class(tree)<-c("multiSimmap","multiPhylo")
- if(length(tree)==1) tree<-tree[[1]]
- return(tree)
-}
-
-# function gets branch length
-# written by Liam J. Revell 2011-2013
-
-getBranch<-function(text,start,version){
- if(version<=1.0){
- i<-start+1
- l<-1
- if(text[i]=="{"){
- maps<-vector()
- i<-i+1
- while(text[i]!="}"){
- temp<-vector()
- m<-1
- while(text[i]!=","){
- temp[m]<-text[i]
- i<-i+1
- m<-m+1
- }
- state<-paste(temp,collapse="")
- i<-i+1
- temp<-vector()
- m<-1
- while(text[i]!=":"&&text[i]!="}"){
- temp[m]<-text[i]
- i<-i+1
- m<-m+1
- }
- length<-as.numeric(paste(temp,collapse=""))
- maps[l]<-length
- names(maps)[l]<-as.character(state)
- l<-l+1
- if(text[i]==":") i<-i+1
- }
- }
- edge.length<-sum(maps) # create branch length
- i<-i+1
- } else if(version>1.0){
- i<-start+1
- l<-1
- if(text[i]=="["){
- maps<-vector()
- i<-i+7
- while(text[i]!="}"){
- temp<-vector()
- m<-1
- while(text[i]!=","&&text[i]!="}"){
- temp[m]<-text[i]
- i<-i+1
- m<-m+1
- }
- state<-paste(temp,collapse="")
- if(text[i]!="}"){
- i<-i+1
- temp<-vector()
- m<-1
- while(text[i]!=","&&text[i]!="}"){
- temp[m]<-text[i]
- i<-i+1
- m<-m+1
- }
- ll<-as.numeric(paste(temp,collapse=""))
- maps[l]<-ll
- names(maps)[l]<-as.character(state)
- l<-l+1
- if(text[i]==",") i<-i+1
- }
- }
- temp<-vector()
- m<-1
- i<-i+2
- while(is.na(match(text[i],c(",",")")))){
- temp[m]<-text[i]
- i<-i+1
- m<-m+1
- }
- maps[l]<-as.numeric(paste(temp,collapse=""))-sum(maps)
- names(maps)[l]<-as.character(state)
- }
- edge.length<-sum(maps)
- }
- return(list(maps=maps,edge.length=edge.length,end=i))
-}
-
-# make a mapped edge matrix
-# written by Liam J. Revell 2013
-
-makeMappedEdge<-function(edge,maps){
- st<-sort(unique(unlist(sapply(maps,function(x) names(x)))))
- mapped.edge<-matrix(0,nrow(edge),length(st))
- rownames(mapped.edge)<-apply(edge,1,function(x) paste(x,collapse=","))
- colnames(mapped.edge)<-st
- for(i in 1:length(maps))
- for(j in 1:length(maps[[i]]))
- mapped.edge[i,names(maps[[i]])[j]]<-mapped.edge[i,names(maps[[i]])[j]]+maps[[i]][j]
- return(mapped.edge)
-}
-
-
-# function translates text-string to tree
-# written by Liam J. Revell 2011-2015, 2019
-
-text_to_tree<-function(text,version,rev.order,trans){
- text<-unlist(strsplit(text, NULL))
- while(text[1]!="(") text<-text[2:length(text)]
- tip.label<-vector(mode="character")
- edge<-matrix(c(1,NA),1,2)
- edge.length<-vector()
- maps<-list()
- currnode<-1
- Nnode<-currnode
- i<-j<-k<-1
- while(text[i]!=";"){
- if(text[i]=="("){
- if(j>nrow(edge)) edge<-rbind(edge,c(NA,NA))
- edge[j,1]<-currnode
- i<-i+1
- # is the next element a label?
- if(is.na(match(text[i],c("(",")",",",":",";")))){
- temp<-getLabel(text,i)
- tip.label[k]<-temp$label
- i<-temp$end
- edge[j,2]<--k
- k<-k+1
- # is there a branch length?
- if(text[i]==":"){
- temp<-getBranch(text,i,version)
- maps[[j]]<-temp$maps
- edge.length[j]<-temp$edge.length
- i<-temp$end
- }
- } else if(text[i]=="("){
- Nnode<-Nnode+1 # creating a new internal node
- currnode<-Nnode
- edge[j,2]<-currnode # move to new internal node
- }
- j<-j+1
- } else if(text[i]==")"){
- i<-i+1
- # is there a branch length?
- if(text[i]==":"){
- temp<-getBranch(text,i,version)
- ii<-match(currnode,edge[,2])
- maps[[ii]]<-temp$maps
- edge.length[ii]<-temp$edge.length
- i<-temp$end
- }
- currnode<-edge[match(currnode,edge[,2]),1] # move down the tree
- } else if(text[i]==","){
- if(j>nrow(edge)) edge<-rbind(edge,c(NA,NA))
- edge[j,1]<-currnode
- i<-i+1
- # is the next element a label?
- if(is.na(match(text[i],c("(",")",",",":",";")))){
- temp<-getLabel(text,i)
- tip.label[k]<-temp$label
- i<-temp$end
- edge[j,2]<--k
- k<-k+1
- # is there a branch length?
- if(text[i]==":"){
- temp<-getBranch(text,i,version)
- maps[[j]]<-temp$maps
- edge.length[j]<-temp$edge.length
- i<-temp$end
- }
- } else if(text[i]=="("){
- Nnode<-Nnode+1 # creating a new internal node
- currnode<-Nnode
- edge[j,2]<-currnode # move to internal node
- }
- j<-j+1
- }
- }
- Ntip<-k-1
- edge[edge>0]<-edge[edge>0]+Ntip
- edge[edge<0]<--edge[edge<0]
- mapped.edge<-makeMappedEdge(edge,maps)
- maps<-if(rev.order) lapply(maps,function(x) x<-x[length(x):1]) else maps
- if(!is.null(trans))tip.label<-trans[tip.label]
- # assemble into modified "phylo" object
- tree<-list(edge=edge,Nnode=as.integer(Nnode),tip.label=tip.label,edge.length=edge.length,maps=maps,mapped.edge=mapped.edge)
- class(tree)<-c("simmap","phylo")
- attr(tree,"map.order")<-if(rev.order) "right-to-left" else "left-to-right"
- return(tree)
-}
-
-# function reads Nexus taxa block in SIMMAP format trees
-# modified from ape:read.nexus
-# written by Liam J. Revell 2011-2013
-
-readNexusData<-function(file,version){
- # read modified nexus block
- # this function is adapted from ape:read.nexus (Paradis et al. 2004)
- if(version<=1.0){
- X<-scan(file=file,what="",sep="\n",quiet=TRUE)
- left<-grep("\\[",X)
- right<-grep("\\]",X)
- if(length(left)){
- w<-left==right
- if(any(w)){
- s<-left[w]
- X[s]<-gsub("\\[[^]]*\\]","",X[s])
- }
- 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 smptrees;",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]
- x<-unlist(strsplit(x,"[,;\t]"))
- x<-unlist(strsplit(x," ")) # this is an addition
- 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 semico[semico>i1][1]
- end<-endblock[endblock>i1][1]-1
- tree<-X[start:end]
- tree<-gsub("^.*= *","",tree)
- tree<-tree[tree!=""]
- semico<-grep(";",tree)
- Ntree<-length(semico)
- 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
- }
- text<-STRING
- if(translation==TRUE){
- rownames(trans)<-trans[,1]
- trans<-trans[,2]
- return(list(text=text,trans=trans,Ntree=Ntree))
- } else return(list(text=text,Ntree=Ntree))
- } else if(version>1.0){
- X<-scan(file=file,what="",sep="\n",quiet=TRUE)
- left<-grep("\\[",X)
- right<-grep("\\]",X)
- skip<-if(version<=2.0) grep("\\&map",X) else
- if(version>2.0&&version<=3.0) grep("\\&prob",X) else
- if(version>3.0) grep("\\&label",X)
- left<-setdiff(left,skip)
- right<-setdiff(right,skip)
- if(length(left)){
- w<-left==right
- if(any(w)){
- s<-left[w]
- X[s]<-gsub("\\[[^]]*\\]","",X[s])
- }
- 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]
- x<-unlist(strsplit(x,"[,;\t]"))
- x<-unlist(strsplit(x," ")) # this is an addition
- 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 semico[semico>i1][1]
- end<-endblock[endblock>i1][1]-1
- tree<-X[start:end]
- tree<-sub(".* = *","",tree)
- tree<-tree[tree!=""]
- semico<-grep(";",tree)
- Ntree<-length(semico)
- 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
- }
- text<-STRING
- if(translation==TRUE){
- rownames(trans)<-trans[,1]
- trans<-trans[,2]
- return(list(text=text,trans=trans,Ntree=Ntree))
- } else return(list(text=text,Ntree=Ntree))
- }
-}
+# function reads SIMMAP v1.0 & v1.5 style trees into file
+# written by Liam J. Revell 2011-2015
+
+read.simmap<-function(file="",text,format="nexus",rev.order=TRUE,version=1.0){
+ if(file!=""){
+ trans<-NULL
+ if(format=="nexus"){
+ XX<-readNexusData(file,version)
+ text<-XX$text
+ trans<-XX$trans
+ Ntree<-XX$Ntree
+ } else if(format=="phylip"){
+ text<-scan(file,sep="\n",what="character")
+ Ntree<-length(text)
+
+ }
+ } else {
+ trans<-NULL
+ Ntree<-length(text)
+ }
+ tree<-lapply(text,text_to_tree,version,rev.order,trans)
+ class(tree)<-c("multiSimmap","multiPhylo")
+ if(length(tree)==1) tree<-tree[[1]]
+ return(tree)
+}
+
+# function gets branch length
+# written by Liam J. Revell 2011-2013
+
+getBranch<-function(text,start,version){
+ if(version<=1.0){
+ i<-start+1
+ l<-1
+ if(text[i]=="{"){
+ maps<-vector()
+ i<-i+1
+ while(text[i]!="}"){
+ temp<-vector()
+ m<-1
+ while(text[i]!=","){
+ temp[m]<-text[i]
+ i<-i+1
+ m<-m+1
+ }
+ state<-paste(temp,collapse="")
+ i<-i+1
+ temp<-vector()
+ m<-1
+ while(text[i]!=":"&&text[i]!="}"){
+ temp[m]<-text[i]
+ i<-i+1
+ m<-m+1
+ }
+ length<-as.numeric(paste(temp,collapse=""))
+ maps[l]<-length
+ names(maps)[l]<-as.character(state)
+ l<-l+1
+ if(text[i]==":") i<-i+1
+ }
+ }
+ edge.length<-sum(maps) # create branch length
+ i<-i+1
+ } else if(version>1.0){
+ i<-start+1
+ l<-1
+ if(text[i]=="["){
+ maps<-vector()
+ i<-i+7
+ while(text[i]!="}"){
+ temp<-vector()
+ m<-1
+ while(text[i]!=","&&text[i]!="}"){
+ temp[m]<-text[i]
+ i<-i+1
+ m<-m+1
+ }
+ state<-paste(temp,collapse="")
+ if(text[i]!="}"){
+ i<-i+1
+ temp<-vector()
+ m<-1
+ while(text[i]!=","&&text[i]!="}"){
+ temp[m]<-text[i]
+ i<-i+1
+ m<-m+1
+ }
+ ll<-as.numeric(paste(temp,collapse=""))
+ maps[l]<-ll
+ names(maps)[l]<-as.character(state)
+ l<-l+1
+ if(text[i]==",") i<-i+1
+ }
+ }
+ temp<-vector()
+ m<-1
+ i<-i+2
+ while(is.na(match(text[i],c(",",")")))){
+ temp[m]<-text[i]
+ i<-i+1
+ m<-m+1
+ }
+ maps[l]<-as.numeric(paste(temp,collapse=""))-sum(maps)
+ names(maps)[l]<-as.character(state)
+ }
+ edge.length<-sum(maps)
+ }
+ return(list(maps=maps,edge.length=edge.length,end=i))
+}
+
+# make a mapped edge matrix
+# written by Liam J. Revell 2013
+
+makeMappedEdge<-function(edge,maps){
+ st<-sort(unique(unlist(sapply(maps,function(x) names(x)))))
+ mapped.edge<-matrix(0,nrow(edge),length(st))
+ rownames(mapped.edge)<-apply(edge,1,function(x) paste(x,collapse=","))
+ colnames(mapped.edge)<-st
+ for(i in 1:length(maps))
+ for(j in 1:length(maps[[i]]))
+ mapped.edge[i,names(maps[[i]])[j]]<-mapped.edge[i,names(maps[[i]])[j]]+maps[[i]][j]
+ return(mapped.edge)
+}
+
+
+# function translates text-string to tree
+# written by Liam J. Revell 2011-2015, 2019
+
+text_to_tree<-function(text,version,rev.order,trans){
+ text<-unlist(strsplit(text, NULL))
+ while(text[1]!="(") text<-text[2:length(text)]
+ tip.label<-vector(mode="character")
+ edge<-matrix(c(1,NA),1,2)
+ edge.length<-vector()
+ maps<-list()
+ currnode<-1
+ Nnode<-currnode
+ i<-j<-k<-1
+ while(text[i]!=";"){
+ if(text[i]=="("){
+ if(j>nrow(edge)) edge<-rbind(edge,c(NA,NA))
+ edge[j,1]<-currnode
+ i<-i+1
+ # is the next element a label?
+ if(is.na(match(text[i],c("(",")",",",":",";")))){
+ temp<-getLabel(text,i)
+ tip.label[k]<-temp$label
+ i<-temp$end
+ edge[j,2]<--k
+ k<-k+1
+ # is there a branch length?
+ if(text[i]==":"){
+ temp<-getBranch(text,i,version)
+ maps[[j]]<-temp$maps
+ edge.length[j]<-temp$edge.length
+ i<-temp$end
+ }
+ } else if(text[i]=="("){
+ Nnode<-Nnode+1 # creating a new internal node
+ currnode<-Nnode
+ edge[j,2]<-currnode # move to new internal node
+ }
+ j<-j+1
+ } else if(text[i]==")"){
+ i<-i+1
+ # is there a branch length?
+ if(text[i]==":"){
+ temp<-getBranch(text,i,version)
+ ii<-match(currnode,edge[,2])
+ maps[[ii]]<-temp$maps
+ edge.length[ii]<-temp$edge.length
+ i<-temp$end
+ }
+ currnode<-edge[match(currnode,edge[,2]),1] # move down the tree
+ } else if(text[i]==","){
+ if(j>nrow(edge)) edge<-rbind(edge,c(NA,NA))
+ edge[j,1]<-currnode
+ i<-i+1
+ # is the next element a label?
+ if(is.na(match(text[i],c("(",")",",",":",";")))){
+ temp<-getLabel(text,i)
+ tip.label[k]<-temp$label
+ i<-temp$end
+ edge[j,2]<--k
+ k<-k+1
+ # is there a branch length?
+ if(text[i]==":"){
+ temp<-getBranch(text,i,version)
+ maps[[j]]<-temp$maps
+ edge.length[j]<-temp$edge.length
+ i<-temp$end
+ }
+ } else if(text[i]=="("){
+ Nnode<-Nnode+1 # creating a new internal node
+ currnode<-Nnode
+ edge[j,2]<-currnode # move to internal node
+ }
+ j<-j+1
+ }
+ }
+ Ntip<-k-1
+ edge[edge>0]<-edge[edge>0]+Ntip
+ edge[edge<0]<--edge[edge<0]
+ mapped.edge<-makeMappedEdge(edge,maps)
+ maps<-if(rev.order) lapply(maps,function(x) x<-x[length(x):1]) else maps
+ if(!is.null(trans))tip.label<-trans[tip.label]
+ # assemble into modified "phylo" object
+ tree<-list(edge=edge,Nnode=as.integer(Nnode),tip.label=tip.label,edge.length=edge.length,maps=maps,mapped.edge=mapped.edge)
+ class(tree)<-c("simmap","phylo")
+ attr(tree,"map.order")<-if(rev.order) "right-to-left" else "left-to-right"
+ return(tree)
+}
+
+# function reads Nexus taxa block in SIMMAP format trees
+# modified from ape:read.nexus
+# written by Liam J. Revell 2011-2013
+
+readNexusData<-function(file,version){
+ # read modified nexus block
+ # this function is adapted from ape:read.nexus (Paradis et al. 2004)
+ if(version<=1.0){
+ X<-scan(file=file,what="",sep="\n",quiet=TRUE)
+ left<-grep("\\[",X)
+ right<-grep("\\]",X)
+ if(length(left)){
+ w<-left==right
+ if(any(w)){
+ s<-left[w]
+ X[s]<-gsub("\\[[^]]*\\]","",X[s])
+ }
+ 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 smptrees;",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]
+ x<-unlist(strsplit(x,"[,;\t]"))
+ x<-unlist(strsplit(x," ")) # this is an addition
+ 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 semico[semico>i1][1]
+ end<-endblock[endblock>i1][1]-1
+ tree<-X[start:end]
+ tree<-gsub("^.*= *","",tree)
+ tree<-tree[tree!=""]
+ semico<-grep(";",tree)
+ Ntree<-length(semico)
+ 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
+ }
+ text<-STRING
+ if(translation==TRUE){
+ rownames(trans)<-trans[,1]
+ trans<-trans[,2]
+ return(list(text=text,trans=trans,Ntree=Ntree))
+ } else return(list(text=text,Ntree=Ntree))
+ } else if(version>1.0){
+ X<-scan(file=file,what="",sep="\n",quiet=TRUE)
+ left<-grep("\\[",X)
+ right<-grep("\\]",X)
+ skip<-if(version<=2.0) grep("\\&map",X) else
+ if(version>2.0&&version<=3.0) grep("\\&prob",X) else
+ if(version>3.0) grep("\\&label",X)
+ left<-setdiff(left,skip)
+ right<-setdiff(right,skip)
+ if(length(left)){
+ w<-left==right
+ if(any(w)){
+ s<-left[w]
+ X[s]<-gsub("\\[[^]]*\\]","",X[s])
+ }
+ 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]
+ x<-unlist(strsplit(x,"[,;\t]"))
+ x<-unlist(strsplit(x," ")) # this is an addition
+ 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 semico[semico>i1][1]
+ end<-endblock[endblock>i1][1]-1
+ tree<-X[start:end]
+ tree<-sub(".* = *","",tree)
+ tree<-tree[tree!=""]
+ semico<-grep(";",tree)
+ Ntree<-length(semico)
+ 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
+ }
+ text<-STRING
+ if(translation==TRUE){
+ rownames(trans)<-trans[,1]
+ trans<-trans[,2]
+ return(list(text=text,trans=trans,Ntree=Ntree))
+ } else return(list(text=text,Ntree=Ntree))
+ }
+}
diff --git a/R/readNexus.R b/R/readNexus.R
index 1bedc40..9fd164d 100644
--- a/R/readNexus.R
+++ b/R/readNexus.R
@@ -1,144 +1,144 @@
-## function
-## written by Liam J. Revell 2013, 2021
-
-readNexus<-function(file="",format=c("standard","raxml")){
- format<-format[1]
- if(tolower(format)=="standard") tree<-read.nexus(file)
- else if(tolower(format)=="raxml"){
- XX<-readNexusData(file,version=3.5)
- text<-XX$text
- trans<-XX$trans
- Ntree<-XX$Ntree
- tree<-lapply(text,modified.text_to_tree,trans=trans)
- if(length(tree)==1) tree<-tree[[1]] else
- class(tree)<-"multiPhylo"
- }
- else {
- cat("Do not recognize format\n")
- tree<-NULL
- }
- tree
-}
-
-# function gets edge length
-# written by Liam J. Revell 2013, 2021
-
-getEdgeLength<-function(text,start){
- i<-start+1
- l<-1
- temp<-vector()
- while(is.na(match(text[i],c(",",")")))){
- temp[l]<-text[i]; l<-l+1; i<-i+1
- }
- list(edge.length=as.numeric(paste(temp,collapse="")),
- end=i)
-}
-
-## function gets bootstrap stored as [&label="bootstrap%"]
-## written by Liam J. Revell 2021
-
-getBS<-function(text,start){
- i<-start
- if(text[i]=="["){
- j<-1
- xx<-vector()
- while(text[i]!="]"){
- i<-i+1
- xx[j]<-text[i]
- j<-j+1
- }
- label<-paste(xx[1:(length(xx)-1)],collapse="")
- label<-sub("&label=","",label)
- }
- list(label=label,end=i+1)
-}
-
-## function translates text-string to tree
-## written by Liam J. Revell 2011-2013, 2021
-
-modified.text_to_tree<-function(text,trans){
- text<-unlist(strsplit(text,NULL))
- tip.label<-vector(mode="character")
- edge<-matrix(c(1,NA),1,2)
- edge.length<-vector()
- node.label<-vector(mode="character")
- currnode<-1
- Nnode<-currnode
- i<-j<-k<-1
- while(text[i]!="(") i<-i+1
- while(text[i]!=";"){
- if(text[i]=="("){
- if(j>nrow(edge)) edge<-rbind(edge,c(NA,NA))
- edge[j,1]<-currnode
- i<-i+1
- # is the next element a label?
- if(is.na(match(text[i],c("(",")",",",":",";")))){
- temp<-getLabel(text,i)
- tip.label[k]<-temp$label
- i<-temp$end
- edge[j,2]<--k
- k<-k+1
- # is there a branch length?
- if(text[i]==":"){
- temp<-getEdgeLength(text,i)
- edge.length[j]<-temp$edge.length
- i<-temp$end
- }
- } else if(text[i]=="("){
- Nnode<-Nnode+1 # creating a new internal node
- currnode<-Nnode
- edge[j,2]<-currnode # move to new internal node
- }
- j<-j+1
- } else if(text[i]==")"){
- i<-i+1
- # is there a node label?
- if(text[i]=="["){
- temp<-getBS(text,i)
- node.label[currnode]<-as.character(temp$label)
- i<-temp$end
- }
- # is there a branch length?
- if(text[i]==":"){
- temp<-getEdgeLength(text,i)
- ii<-match(currnode,edge[,2])
- edge.length[ii]<-temp$edge.length
- i<-temp$end
- }
- currnode<-edge[match(currnode,edge[,2]),1] # move down the tree
- } else if(text[i]==","){
- if(j>nrow(edge)) edge<-rbind(edge,c(NA,NA))
- edge[j,1]<-currnode
- i<-i+1
- # is the next element a label?
- if(is.na(match(text[i],c("(",")",",",":",";")))){
- temp<-getLabel(text,i)
- tip.label[k]<-temp$label
- i<-temp$end
- edge[j,2]<--k
- k<-k+1
- # is there a branch length?
- if(text[i]==":"){
- temp<-getEdgeLength(text,i)
- edge.length[j]<-temp$edge.length
- i<-temp$end
- }
- } else if(text[i]=="("){
- Nnode<-Nnode+1 # creating a new internal node
- currnode<-Nnode
- edge[j,2]<-currnode # move to internal node
- }
- j<-j+1
- }
- }
- Ntip<-k-1
- if(!is.null(trans)) tip.label<-trans[tip.label]
- # assemble into modified "phylo" object
- ntip<-abs(min(edge))
- edge[which(edge>0)]<-ntip+edge[which(edge>0)]
- edge[which(edge<0)]<-abs(edge[which(edge<0)])
- tree<-list(edge=edge,Nnode=as.integer(Nnode),tip.label=tip.label,
- edge.length=edge.length,node.label=node.label)
- class(tree)<-"phylo"
- tree
-}
+## function
+## written by Liam J. Revell 2013, 2021
+
+readNexus<-function(file="",format=c("standard","raxml")){
+ format<-format[1]
+ if(tolower(format)=="standard") tree<-read.nexus(file)
+ else if(tolower(format)=="raxml"){
+ XX<-readNexusData(file,version=3.5)
+ text<-XX$text
+ trans<-XX$trans
+ Ntree<-XX$Ntree
+ tree<-lapply(text,modified.text_to_tree,trans=trans)
+ if(length(tree)==1) tree<-tree[[1]] else
+ class(tree)<-"multiPhylo"
+ }
+ else {
+ cat("Do not recognize format\n")
+ tree<-NULL
+ }
+ tree
+}
+
+# function gets edge length
+# written by Liam J. Revell 2013, 2021
+
+getEdgeLength<-function(text,start){
+ i<-start+1
+ l<-1
+ temp<-vector()
+ while(is.na(match(text[i],c(",",")")))){
+ temp[l]<-text[i]; l<-l+1; i<-i+1
+ }
+ list(edge.length=as.numeric(paste(temp,collapse="")),
+ end=i)
+}
+
+## function gets bootstrap stored as [&label="bootstrap%"]
+## written by Liam J. Revell 2021
+
+getBS<-function(text,start){
+ i<-start
+ if(text[i]=="["){
+ j<-1
+ xx<-vector()
+ while(text[i]!="]"){
+ i<-i+1
+ xx[j]<-text[i]
+ j<-j+1
+ }
+ label<-paste(xx[1:(length(xx)-1)],collapse="")
+ label<-sub("&label=","",label)
+ }
+ list(label=label,end=i+1)
+}
+
+## function translates text-string to tree
+## written by Liam J. Revell 2011-2013, 2021
+
+modified.text_to_tree<-function(text,trans){
+ text<-unlist(strsplit(text,NULL))
+ tip.label<-vector(mode="character")
+ edge<-matrix(c(1,NA),1,2)
+ edge.length<-vector()
+ node.label<-vector(mode="character")
+ currnode<-1
+ Nnode<-currnode
+ i<-j<-k<-1
+ while(text[i]!="(") i<-i+1
+ while(text[i]!=";"){
+ if(text[i]=="("){
+ if(j>nrow(edge)) edge<-rbind(edge,c(NA,NA))
+ edge[j,1]<-currnode
+ i<-i+1
+ # is the next element a label?
+ if(is.na(match(text[i],c("(",")",",",":",";")))){
+ temp<-getLabel(text,i)
+ tip.label[k]<-temp$label
+ i<-temp$end
+ edge[j,2]<--k
+ k<-k+1
+ # is there a branch length?
+ if(text[i]==":"){
+ temp<-getEdgeLength(text,i)
+ edge.length[j]<-temp$edge.length
+ i<-temp$end
+ }
+ } else if(text[i]=="("){
+ Nnode<-Nnode+1 # creating a new internal node
+ currnode<-Nnode
+ edge[j,2]<-currnode # move to new internal node
+ }
+ j<-j+1
+ } else if(text[i]==")"){
+ i<-i+1
+ # is there a node label?
+ if(text[i]=="["){
+ temp<-getBS(text,i)
+ node.label[currnode]<-as.character(temp$label)
+ i<-temp$end
+ }
+ # is there a branch length?
+ if(text[i]==":"){
+ temp<-getEdgeLength(text,i)
+ ii<-match(currnode,edge[,2])
+ edge.length[ii]<-temp$edge.length
+ i<-temp$end
+ }
+ currnode<-edge[match(currnode,edge[,2]),1] # move down the tree
+ } else if(text[i]==","){
+ if(j>nrow(edge)) edge<-rbind(edge,c(NA,NA))
+ edge[j,1]<-currnode
+ i<-i+1
+ # is the next element a label?
+ if(is.na(match(text[i],c("(",")",",",":",";")))){
+ temp<-getLabel(text,i)
+ tip.label[k]<-temp$label
+ i<-temp$end
+ edge[j,2]<--k
+ k<-k+1
+ # is there a branch length?
+ if(text[i]==":"){
+ temp<-getEdgeLength(text,i)
+ edge.length[j]<-temp$edge.length
+ i<-temp$end
+ }
+ } else if(text[i]=="("){
+ Nnode<-Nnode+1 # creating a new internal node
+ currnode<-Nnode
+ edge[j,2]<-currnode # move to internal node
+ }
+ j<-j+1
+ }
+ }
+ Ntip<-k-1
+ if(!is.null(trans)) tip.label<-trans[tip.label]
+ # assemble into modified "phylo" object
+ ntip<-abs(min(edge))
+ edge[which(edge>0)]<-ntip+edge[which(edge>0)]
+ edge[which(edge<0)]<-abs(edge[which(edge<0)])
+ tree<-list(edge=edge,Nnode=as.integer(Nnode),tip.label=tip.label,
+ edge.length=edge.length,node.label=node.label)
+ class(tree)<-"phylo"
+ tree
+}
diff --git a/R/rerootingMethod.R b/R/rerootingMethod.R
index 0f005cd..db33d59 100644
--- a/R/rerootingMethod.R
+++ b/R/rerootingMethod.R
@@ -1,86 +1,86 @@
-## function to compute the marginal posterior probabilities for nodes
-## using the rerooting method
-## written by Liam J. Revell 2013, 2015, 2017, 2018, 2020
-
-rerootingMethod<-function(tree,x,model=c("ER","SYM"),...){
- if(!inherits(tree,"phylo"))
- stop("tree should be an object of class \"phylo\".")
- if(hasArg(tips)) tips<-list(...)$tips
- else tips<-NULL
- if(!is.matrix(model)) model<-model[1]
- n<-Ntip(tree)
- # if vector convert to binary matrix
- if(!is.matrix(x)){
- yy<-to.matrix(x,sort(unique(x)))
- if(is.null(tips)) tips<-FALSE
- } else {
- if(is.null(tips)) tips<-TRUE
- yy<-x
- }
- yy<-yy[tree$tip.label,]
- yy<-yy/rowSums(yy)
- YY<-fitMk(tree,yy,model=model,output.liks=TRUE,...)
- Q<-matrix(c(0,YY$rates)[YY$index.matrix+1],length(YY$states),
- length(YY$states),dimnames=list(YY$states,YY$states))
- diag(Q)<--colSums(Q,na.rm=TRUE)
- nn<-if(tips) c(1:n,if(tree$Nnode>1) 2:tree$Nnode+n) else {
- if(tree$Nnode>1) 2:tree$Nnode+n else vector() }
- ff<-function(nn){
- tt<-if(nn>Ntip(tree)) ape::root.phylo(tree,node=nn) else
- reroot(tree,nn,tree$edge.length[which(tree$edge[,2]==nn)])
- fitMk(tt,yy,model=model,fixedQ=Q,output.liks=TRUE)$lik.anc[1,]
- }
- XX<-t(sapply(nn,ff))
- if(tips) XX<-rbind(XX[1:n,],YY$lik.anc[1,],if(tree$Nnode>1)
- XX[(n+1):nrow(XX),])
- else XX<-rbind(yy,YY$lik.anc[1,],if(tree$Nnode>1) XX)
- rownames(XX)<-1:(tree$Nnode+n)
- if(tips) rownames(XX)[1:n]<-tree$tip.label
- XX<-if(tips) XX else XX[1:tree$Nnode+n,]
- obj<-list(loglik=YY$logLik,Q=Q,marginal.anc=XX,tree=tree,x=yy)
- class(obj)<-"rerootingMethod"
- obj
-}
-
-print.rerootingMethod<-function(x,digits=6,printlen=NULL,...){
- cat("Ancestral character estimates using re-rooting method")
- cat("\nof Yang et al. (1995):\n")
- if(is.null(printlen)) print(round(x$marginal.anc,digits)) else {
- print(round(x$marginal.anc[1:printlen,],digits))
- cat("...\n")
- }
- cat("\nEstimated transition matrix,\nQ =\n")
- print(round(x$Q,digits))
- cat("\n**Note that if Q is not symmetric the marginal")
- cat("\nreconstructions may be invalid.\n")
- cat(paste("\nLog-likelihood =",round(x$loglik,digits),"\n\n"))
-}
-
-plot.rerootingMethod<-function(x, ...){
- args<-list(...)
- if(is.null(args$lwd)) args$lwd<-1
- if(is.null(args$ylim)) args$ylim<-c(-0.1*Ntip(x$tree),
- Ntip(x$tree))
- if(is.null(args$offset)) args$offset<-0.5
- if(is.null(args$ftype)) args$ftype="i"
- args$tree<-x$tree
- do.call(plotTree,args)
- if(hasArg(piecol)) piecol<-list(...)$piecol
- else piecol<-setNames(colorRampPalette(c("blue",
- "yellow"))(ncol(x$marginal.anc)),
- colnames(x$marginal.anc))
- if(hasArg(node.cex)) node.cex<-list(...)$node.cex
- else node.cex<-0.6
- nodelabels(pie=x$marginal.anc[
- as.character(1:x$tree$Nnode+Ntip(x$tree)),],
- piecol=piecol,cex=node.cex)
- if(hasArg(tip.cex)) tip.cex<-list(...)$tip.cex
- else tip.cex<-0.4
- tiplabels(pie=x$x[x$tree$tip.label,],piecol=piecol,
- cex=tip.cex)
- legend(x=par()$usr[1],y=par()$usr[1],
- legend=colnames(x$marginal.anc),
- pch=21,pt.bg=piecol,pt.cex=2.2,bty="n")
-}
-
-logLik.rerootingMethod<-function(object,...) object$loglik
+## function to compute the marginal posterior probabilities for nodes
+## using the rerooting method
+## written by Liam J. Revell 2013, 2015, 2017, 2018, 2020
+
+rerootingMethod<-function(tree,x,model=c("ER","SYM"),...){
+ if(!inherits(tree,"phylo"))
+ stop("tree should be an object of class \"phylo\".")
+ if(hasArg(tips)) tips<-list(...)$tips
+ else tips<-NULL
+ if(!is.matrix(model)) model<-model[1]
+ n<-Ntip(tree)
+ # if vector convert to binary matrix
+ if(!is.matrix(x)){
+ yy<-to.matrix(x,sort(unique(x)))
+ if(is.null(tips)) tips<-FALSE
+ } else {
+ if(is.null(tips)) tips<-TRUE
+ yy<-x
+ }
+ yy<-yy[tree$tip.label,]
+ yy<-yy/rowSums(yy)
+ YY<-fitMk(tree,yy,model=model,output.liks=TRUE,...)
+ Q<-matrix(c(0,YY$rates)[YY$index.matrix+1],length(YY$states),
+ length(YY$states),dimnames=list(YY$states,YY$states))
+ diag(Q)<--colSums(Q,na.rm=TRUE)
+ nn<-if(tips) c(1:n,if(tree$Nnode>1) 2:tree$Nnode+n) else {
+ if(tree$Nnode>1) 2:tree$Nnode+n else vector() }
+ ff<-function(nn){
+ tt<-if(nn>Ntip(tree)) ape::root.phylo(tree,node=nn) else
+ reroot(tree,nn,tree$edge.length[which(tree$edge[,2]==nn)])
+ fitMk(tt,yy,model=model,fixedQ=Q,output.liks=TRUE)$lik.anc[1,]
+ }
+ XX<-t(sapply(nn,ff))
+ if(tips) XX<-rbind(XX[1:n,],YY$lik.anc[1,],if(tree$Nnode>1)
+ XX[(n+1):nrow(XX),])
+ else XX<-rbind(yy,YY$lik.anc[1,],if(tree$Nnode>1) XX)
+ rownames(XX)<-1:(tree$Nnode+n)
+ if(tips) rownames(XX)[1:n]<-tree$tip.label
+ XX<-if(tips) XX else XX[1:tree$Nnode+n,]
+ obj<-list(loglik=YY$logLik,Q=Q,marginal.anc=XX,tree=tree,x=yy)
+ class(obj)<-"rerootingMethod"
+ obj
+}
+
+print.rerootingMethod<-function(x,digits=6,printlen=NULL,...){
+ cat("Ancestral character estimates using re-rooting method")
+ cat("\nof Yang et al. (1995):\n")
+ if(is.null(printlen)) print(round(x$marginal.anc,digits)) else {
+ print(round(x$marginal.anc[1:printlen,],digits))
+ cat("...\n")
+ }
+ cat("\nEstimated transition matrix,\nQ =\n")
+ print(round(x$Q,digits))
+ cat("\n**Note that if Q is not symmetric the marginal")
+ cat("\nreconstructions may be invalid.\n")
+ cat(paste("\nLog-likelihood =",round(x$loglik,digits),"\n\n"))
+}
+
+plot.rerootingMethod<-function(x, ...){
+ args<-list(...)
+ if(is.null(args$lwd)) args$lwd<-1
+ if(is.null(args$ylim)) args$ylim<-c(-0.1*Ntip(x$tree),
+ Ntip(x$tree))
+ if(is.null(args$offset)) args$offset<-0.5
+ if(is.null(args$ftype)) args$ftype="i"
+ args$tree<-x$tree
+ do.call(plotTree,args)
+ if(hasArg(piecol)) piecol<-list(...)$piecol
+ else piecol<-setNames(colorRampPalette(c("blue",
+ "yellow"))(ncol(x$marginal.anc)),
+ colnames(x$marginal.anc))
+ if(hasArg(node.cex)) node.cex<-list(...)$node.cex
+ else node.cex<-0.6
+ nodelabels(pie=x$marginal.anc[
+ as.character(1:x$tree$Nnode+Ntip(x$tree)),],
+ piecol=piecol,cex=node.cex)
+ if(hasArg(tip.cex)) tip.cex<-list(...)$tip.cex
+ else tip.cex<-0.4
+ tiplabels(pie=x$x[x$tree$tip.label,],piecol=piecol,
+ cex=tip.cex)
+ legend(x=par()$usr[1],y=par()$usr[1],
+ legend=colnames(x$marginal.anc),
+ pch=21,pt.bg=piecol,pt.cex=2.2,bty="n")
+}
+
+logLik.rerootingMethod<-function(object,...) object$loglik
diff --git a/R/resolveNodes.R b/R/resolveNodes.R
index 1e4c422..0ce887f 100644
--- a/R/resolveNodes.R
+++ b/R/resolveNodes.R
@@ -1,67 +1,67 @@
-## function to resolve nodes in a multifurcating tree
-## written by Liam J. Revell 2016
-
-resolveNode<-function(tree,node){
- dd<-Children(tree,node)
- if(length(dd)>2){
- EL<-!is.null(tree$edge.length)
- if(!EL) tree<-compute.brlen(tree)
- n<-length(dd)
- tt<-lapply(allTrees(n,TRUE,dd),untangle,"read.tree")
- ROOT<-node==(Ntip(tree)+1)
- SPL<-if(!ROOT) splitTree(tree,split=list(node=node,
- bp=tree$edge.length[which(tree$edge[,2]==node)])) else
- list(NULL,tree)
- KIDS<-Children(SPL[[2]],SPL[[2]]$edge[1,1])
- KIDS<-setNames(KIDS,dd)[KIDS>Ntip(SPL[[2]])]
- SUBS<-list()
- if(length(KIDS)>0)
- for(i in 1:length(KIDS))
- SUBS[[i]]<-extract.clade(SPL[[2]],KIDS[i])
- obj<-list()
- for(i in 1:length(tt)){
- tt[[i]]$edge.length<-rep(0,nrow(tt[[i]]$edge))
- for(j in 1:Ntip(tt[[i]]))
- tt[[i]]$edge.length[which(tt[[i]]$edge[,2]==j)]<-
- tree$edge.length[which(tree$edge[,2]==
- as.numeric(tt[[i]]$tip.label[j]))]
- ind<-as.numeric(tt[[i]]$tip.label)<=Ntip(tree)
- tt[[i]]$tip.label[ind]<-
- tree$tip.label[as.numeric(tt[[i]]$tip.label[ind])]
- if(length(KIDS)>0)
- for(j in 1:length(KIDS))
- tt[[i]]<-bind.tree(tt[[i]],SUBS[[j]],
- where=which(tt[[i]]$tip.label==
- names(KIDS)[j]))
- obj[[i]]<-if(!ROOT) bind.tree(SPL[[1]],tt[[i]],
- where=which(SPL[[1]]$tip.label=="NA")) else
- tt[[i]]
- if(!EL) obj[[i]]$edge.length<-NULL
- }
- class(obj)<-"multiPhylo"
- } else obj<-tree
- obj
-}
-
-## function to resolve all nodes in a tree with multifurcations
-## written by Liam J. Revell 2016
-
-resolveAllNodes<-function(tree){
- foo<-function(node,tree) length(Children(tree,node))
- nodes<-1:tree$Nnode+Ntip(tree) ## all nodes
- nodes<-nodes[sapply(1:tree$Nnode+Ntip(tree),foo,
- tree=tree)>2]
- for(i in 1:length(nodes)){
- if(i==1) obj<-resolveNode(tree,nodes[i])
- else {
- for(j in 1:length(obj)){
- MM<-matchNodes(tree,obj[[j]])
- NODE<-MM[which(MM[,1]==nodes[i]),2]
- if(j==1) tmp<-resolveNode(obj[[j]],NODE)
- else tmp<-c(tmp,resolveNode(obj[[j]],NODE))
- }
- obj<-tmp
- }
- }
- obj
-}
+## function to resolve nodes in a multifurcating tree
+## written by Liam J. Revell 2016
+
+resolveNode<-function(tree,node){
+ dd<-Children(tree,node)
+ if(length(dd)>2){
+ EL<-!is.null(tree$edge.length)
+ if(!EL) tree<-compute.brlen(tree)
+ n<-length(dd)
+ tt<-lapply(allTrees(n,TRUE,dd),untangle,"read.tree")
+ ROOT<-node==(Ntip(tree)+1)
+ SPL<-if(!ROOT) splitTree(tree,split=list(node=node,
+ bp=tree$edge.length[which(tree$edge[,2]==node)])) else
+ list(NULL,tree)
+ KIDS<-Children(SPL[[2]],SPL[[2]]$edge[1,1])
+ KIDS<-setNames(KIDS,dd)[KIDS>Ntip(SPL[[2]])]
+ SUBS<-list()
+ if(length(KIDS)>0)
+ for(i in 1:length(KIDS))
+ SUBS[[i]]<-extract.clade(SPL[[2]],KIDS[i])
+ obj<-list()
+ for(i in 1:length(tt)){
+ tt[[i]]$edge.length<-rep(0,nrow(tt[[i]]$edge))
+ for(j in 1:Ntip(tt[[i]]))
+ tt[[i]]$edge.length[which(tt[[i]]$edge[,2]==j)]<-
+ tree$edge.length[which(tree$edge[,2]==
+ as.numeric(tt[[i]]$tip.label[j]))]
+ ind<-as.numeric(tt[[i]]$tip.label)<=Ntip(tree)
+ tt[[i]]$tip.label[ind]<-
+ tree$tip.label[as.numeric(tt[[i]]$tip.label[ind])]
+ if(length(KIDS)>0)
+ for(j in 1:length(KIDS))
+ tt[[i]]<-bind.tree(tt[[i]],SUBS[[j]],
+ where=which(tt[[i]]$tip.label==
+ names(KIDS)[j]))
+ obj[[i]]<-if(!ROOT) bind.tree(SPL[[1]],tt[[i]],
+ where=which(SPL[[1]]$tip.label=="NA")) else
+ tt[[i]]
+ if(!EL) obj[[i]]$edge.length<-NULL
+ }
+ class(obj)<-"multiPhylo"
+ } else obj<-tree
+ obj
+}
+
+## function to resolve all nodes in a tree with multifurcations
+## written by Liam J. Revell 2016
+
+resolveAllNodes<-function(tree){
+ foo<-function(node,tree) length(Children(tree,node))
+ nodes<-1:tree$Nnode+Ntip(tree) ## all nodes
+ nodes<-nodes[sapply(1:tree$Nnode+Ntip(tree),foo,
+ tree=tree)>2]
+ for(i in 1:length(nodes)){
+ if(i==1) obj<-resolveNode(tree,nodes[i])
+ else {
+ for(j in 1:length(obj)){
+ MM<-matchNodes(tree,obj[[j]])
+ NODE<-MM[which(MM[,1]==nodes[i]),2]
+ if(j==1) tmp<-resolveNode(obj[[j]],NODE)
+ else tmp<-c(tmp,resolveNode(obj[[j]],NODE))
+ }
+ obj<-tmp
+ }
+ }
+ obj
+}
diff --git a/R/roundPhylogram.R b/R/roundPhylogram.R
index ca33c91..a03cb9e 100644
--- a/R/roundPhylogram.R
+++ b/R/roundPhylogram.R
@@ -1,236 +1,248 @@
-## function plots a sigmoid or spline phylogram or cladogram
-## written by Liam J. Revell 2022, 2023
-
-splinePhylogram<-function(tree,...){
- if(hasArg(df)) df<-list(...)$df
- else df<-50
- if(hasArg(res)) res<-list(...)$res
- else res<-4*df
- if(hasArg(lwd)) lwd<-list(...)$lwd
- else lwd<-par()$lwd
- if(hasArg(color)) color<-list(...)$color
- else color<-par()$fg
- if(is.null(tree$edge.length)) tree<-compute.brlen(tree)
- h<-max(nodeHeights(tree))/res
- tree<-make.era.map(tree,seq(0,max(nodeHeights(tree)),by=h))
- tree<-map.to.singleton(tree)
- args<-list(...)
- args$tree<-tree
- args$color<-"transparent"
- dev.hold()
- do.call(plotTree,args)
- obj<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- phy<-list(edge=obj$edge,Nnode=obj$Nnode,
- tip.label=1:obj$Ntip)
- attr(phy,"class")<-"phylo"
- for(i in 1:Ntip(phy)){
- aa<-c(i,Ancestors(phy,i))
- xx<-obj$xx[aa]
- yy<-obj$yy[aa]
- DF<-min(min(length(xx)-1,df),df)
- tmp<-predict(smooth.spline(xx,yy,df=DF))
- tmp$x<-c(xx[length(xx)],tmp$x)
- tmp$y<-c(yy[length(yy)],tmp$y)
- lines(tmp,lwd=lwd,col=color)
- }
- nulo<-dev.flush()
- args$tree<-collapse.singles(tree)
- args$add<-TRUE
- ffg<-par()$fg
- par(fg="transparent")
- do.call(plotTree,args)
- par(fg=ffg)
-}
-
-compute.brlen.simmap<-function(phy,method="Grafen",power=1,...){
- if(inherits(phy,"simmap")){
- tt<-as.phylo(phy)
- tt<-compute.brlen(tt,method=method,power=power,...)
- ss<-tt$edge.length/phy$edge.length
- phy$maps<-mapply("*",ss,phy$maps,SIMPLIFY=FALSE)
- phy$mapped.edge<-phy$mapped.edge*
- matrix(rep(ss,ncol(phy$mapped.edge)),
- nrow(phy$mapped.edge),ncol(phy$mapped.edge))
- phy$edge.length<-tt$edge.length
- } else if(inherits(phy,"phylo"))
- phy<-compute.brlen(phy,method=method,power=power,...)
- phy
-}
-
-sigmoidPhylogram<-function(tree,...){
- ## b=5,m1=0.01,m2=0.5,v=1
- b<-if(hasArg(b)) list(...)$b else 5
- m1<-if(hasArg(m1)) list(...)$m1 else 0.01
- m2<-if(hasArg(m2)) list(...)$m2 else 0.5
- v<-if(hasArg(v)) list(...)$v else 1
- direction<-if(hasArg(direction)) list(...)$direction else "rightwards"
- show.hidden<-if(hasArg(show.hidden)) list(...)$show.hidden else FALSE
- if(inherits(tree,"simmap")){
- if(hasArg(colors)) colors<-list(...)$colors
- else {
- ss<-sort(unique(c(getStates(tree,"nodes"),
- getStates(tree,"tips"))))
- mm<-length(ss)
- colors<-setNames(
- colorRampPalette(palette()[1:min(8,mm)])(mm),
- ss)
- }
- } else if(inherits(tree,"phylo")) {
- if(hasArg(color)){
- color<-setNames(list(...)$color,"1")
- colors<-color
- } else colors<-setNames(par()$fg,"1")
- tree<-paintSubTree(tree,Ntip(tree)+1,"1")
- }
- if(hasArg(res)) res<-list(...)$res
- else res<-199
- if(hasArg(use.edge.length))
- use.edge.length<-list(...)$use.edge.length
- else use.edge.length<-TRUE
- if(!use.edge.length){
- if(hasArg(power)) power<-list(...)$power
- else power<-1
- tree<-compute.brlen.simmap(tree,power=power)
- }
- if(hasArg(lwd)) lwd<-list(...)$lwd
- else lwd<-2
- h<-max(nodeHeights(tree))
- args<-list(...)
- args$power<-NULL
- args$res<-NULL
- args$colors<-NULL
- args$b<-NULL
- args$m1<-NULL
- args$m2<-NULL
- args$v<-NULL
- args$tree<-tree
- args$color<-if(show.hidden) make.transparent("red",0.25) else
- "transparent"
- dev.hold()
- par_fg<-par()$fg
- par(fg="transparent")
- do.call(plotTree,args)
- par(fg=par_fg)
- pp<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- par_usr<-par()$usr
- args$add<-TRUE
- if(direction=="downwards"){
- args$xlim<-pp$x.lim
- args$ylim<-pp$y.lim[2:1]-pp$y.lim[1]
- args$direction<-"upwards"
- } else if(direction=="leftwards"){
- args$xlim<-pp$x.lim[2:1]-pp$x.lim[1]
- args$ylim<-pp$y.lim
- args$direction<-"rightwards"
- }
- do.call(plotTree,args)
- pp<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- xx<-if(direction%in%c("rightwards","leftwards")) pp$xx else pp$yy
- yy<-if(direction%in%c("rightwards","leftwards")) pp$yy else pp$xx
- ## Yt<-A+(K-A)/((C+exp(-B*(t-M)))^(1/v))
- sigmoid<-function(x,.A=A,.K=K,.C=C,.B=B,.M=M,.v=v)
- return(.A+(.K-.A)/((.C+exp(-.B*(x-.M)))^(1/.v)))
- for(i in 1:nrow(tree$edge)){
- A<-yy[tree$edge[i,1]]
- K<-yy[tree$edge[i,2]]
- if(i==1) dy<-abs(A-K)
- B<-b*Ntip(tree)/h
- t<-seq(xx[tree$edge[i,1]],xx[tree$edge[i,2]],
- length.out=res)
- t<-sort(c(t,t[1]+cumsum(tree$maps[[i]])))
- dd<-diff(range(t))
- M<-t[1] + if(m1*h>(m2*dd)) m2*dd else m1*h
- C<-1
- Yt<-c(A,sigmoid(t),K)
- t<-c(t[1],t,t[length(t)])
- COLS<-vector()
- bb<-setNames(t[1]+cumsum(tree$maps[[i]]),names(tree$maps[[i]]))
- for(j in 1:length(t))
- COLS[j]<-colors[names(bb[which(t[j]<=bb)])[1]]
- nn<-length(t)
- if(direction%in%c("rightwards","leftwards"))
- segments(t[1:(nn-1)],Yt[1:(nn-1)],x1=t[2:nn],y1=Yt[2:nn],
- col=COLS,lwd=lwd)
- else if(direction%in%c("upwards","downwards"))
- segments(Yt[1:(nn-1)],t[1:(nn-1)],x1=Yt[2:nn],y1=t[2:nn],
- col=COLS,lwd=lwd)
- }
- nulo<-dev.flush()
-}
-
-## function plots a round phylogram
-## written by Liam J. Revell 2014, 2015, 2016
-
-roundPhylogram<-function(tree,fsize=1.0,ftype="reg",lwd=2,mar=NULL,offset=NULL,
- direction="rightwards",type="phylogram",xlim=NULL,ylim=NULL,...){
- if(inherits(tree,"multiPhylo")){
- par(ask=TRUE)
- tt<-lapply(tree,roundPhylogram,fsize=fsize,ftype=ftype,lwd=lwd,mar=mar,offset=offset,
- direction=direction,type=type,xlim=xlim,ylim=ylim)
- } else {
- if(hasArg(lty)) lty<-list(...)$lty
- else lty<-"solid"
- if(length(lty)!=nrow(tree$edge)) lty<-rep(lty,ceiling(nrow(tree$edge)/length(lty)))
- if(length(lwd)!=nrow(tree$edge)) lwd<-rep(lwd,ceiling(nrow(tree$edge)/length(lwd)))
- if(type=="cladogram"||is.null(tree$edge.length)) tree<-compute.brlen(tree)
- ftype<-which(c("off","reg","b","i","bi")==ftype)-1
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- # swap out "_" character for spaces (assumes _ is a place holder)
- tree$tip.label<-gsub("_"," ",tree$tip.label)
- if(is.null(mar)) mar=rep(0.1,4)
- n<-length(tree$tip.label)
- # set offset fudge (empirically determined)
- offsetFudge<-1.37
- # reorder cladewise to assign tip positions
- cw<-reorder(tree,"cladewise")
- io<-reorder(tree,index.only=TRUE)
- lwd<-lwd[io]
- lty<-lty[io]
- y<-vector(length=n+cw$Nnode)
- y[cw$edge[cw$edge[,2]<=n,2]]<-1:n
- # reorder pruningwise for post-order traversal
- pw<-reorder(tree,"pruningwise")
- nn<-unique(pw$edge[,1])
- # compute vertical position of each edge
- for(i in 1:length(nn)){
- yy<-y[pw$edge[which(pw$edge[,1]==nn[i]),2]]
- y[nn[i]]<-mean(range(yy))
- }
- # compute start & end points of each edge
- X<-nodeHeights(cw)
- if(is.null(xlim)){
- pp<-par("pin")[1]
- sw<-fsize*(max(strwidth(cw$tip.label,units="inches")))+offsetFudge*fsize*strwidth("W",units="inches")
- alp<-optimize(function(a,H,sw,pp) (a*1.04*max(H)+sw-pp)^2,H=X,sw=sw,pp=pp,interval=c(0,1e6))$minimum
- xlim<-c(min(X),max(X)+sw/alp)
- }
- if(is.null(ylim)) ylim=c(1,max(y))
- ## end preliminaries
- # open & size a new plot
- plot.new()
- par(mar=mar)
- if(is.null(offset)) offset<-0.2*lwd/3+0.2/3
- plot.window(xlim=xlim,ylim=ylim)
- # plot edges
- for(i in 1:nrow(X)){
- x<-NULL
- b<-y[cw$edge[i,1]]
- c<-X[i,1]
- d<-if(y[cw$edge[i,2]]>y[cw$edge[i,1]]) 1 else -1
- xx<-X[i,2]
- yy<-y[cw$edge[i,2]]
- a<-(xx-c)/(yy-b)^2
- curve(d*sqrt((x-c)/a)+b,from=X[i,1],to=X[i,2],add=TRUE,lwd=lwd[i],lty=lty[i])
- }
- # plot tip labels
- for(i in 1:n)
- if(ftype) text(X[which(cw$edge[,2]==i),2],y[i],tree$tip.label[i],pos=4,offset=offset,font=ftype,cex=fsize)
- PP<-list(type=type,use.edge.length=if(type=="phylogram") TRUE else FALSE,node.pos=1,
- show.tip.label=if(ftype) TRUE else FALSE,show.node.label=FALSE,font=ftype,cex=fsize,
- adj=0,srt=0,no.margin=FALSE,label.offset=offset,x.lim=par()$usr[1:2],y.lim=par()$usr[3:4],
- direction=direction,tip.color="black",Ntip=length(cw$tip.label),Nnode=cw$Nnode,edge=cw$edge,
- xx=sapply(1:(length(cw$tip.label)+cw$Nnode),function(x,y,z) y[match(x,z)],y=X,z=cw$edge),
- yy=y)
- assign("last_plot.phylo",PP,envir=.PlotPhyloEnv)
- }
-}
+## function plots a sigmoid or spline phylogram or cladogram
+## written by Liam J. Revell 2022, 2023
+
+splinePhylogram<-function(tree,...){
+ if(hasArg(df)) df<-list(...)$df
+ else df<-50
+ if(hasArg(res)) res<-list(...)$res
+ else res<-4*df
+ if(hasArg(lwd)) lwd<-list(...)$lwd
+ else lwd<-par()$lwd
+ if(hasArg(color)) color<-list(...)$color
+ else color<-par()$fg
+ if(is.null(tree$edge.length)) tree<-compute.brlen(tree)
+ h<-max(nodeHeights(tree))/res
+ tree<-make.era.map(tree,seq(0,max(nodeHeights(tree)),by=h))
+ tree<-map.to.singleton(tree)
+ args<-list(...)
+ args$tree<-tree
+ args$color<-"transparent"
+ dev.hold()
+ do.call(plotTree,args)
+ obj<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ phy<-list(edge=obj$edge,Nnode=obj$Nnode,
+ tip.label=1:obj$Ntip)
+ attr(phy,"class")<-"phylo"
+ for(i in 1:Ntip(phy)){
+ aa<-c(i,Ancestors(phy,i))
+ xx<-obj$xx[aa]
+ yy<-obj$yy[aa]
+ DF<-min(min(length(xx)-1,df),df)
+ tmp<-predict(smooth.spline(xx,yy,df=DF))
+ tmp$x<-c(xx[length(xx)],tmp$x)
+ tmp$y<-c(yy[length(yy)],tmp$y)
+ lines(tmp,lwd=lwd,col=color)
+ }
+ nulo<-dev.flush()
+ args$tree<-collapse.singles(tree)
+ args$add<-TRUE
+ ffg<-par()$fg
+ par(fg="transparent")
+ do.call(plotTree,args)
+ par(fg=ffg)
+}
+
+compute.brlen.simmap<-function(phy,method="Grafen",power=1,...){
+ if(inherits(phy,"simmap")){
+ tt<-as.phylo(phy)
+ tt<-compute.brlen(tt,method=method,power=power,...)
+ ss<-tt$edge.length/phy$edge.length
+ phy$maps<-mapply("*",ss,phy$maps,SIMPLIFY=FALSE)
+ phy$mapped.edge<-phy$mapped.edge*
+ matrix(rep(ss,ncol(phy$mapped.edge)),
+ nrow(phy$mapped.edge),ncol(phy$mapped.edge))
+ phy$edge.length<-tt$edge.length
+ } else if(inherits(phy,"phylo"))
+ phy<-compute.brlen(phy,method=method,power=power,...)
+ phy
+}
+
+sigmoidPhylogram<-function(tree,...){
+ if(hasArg(outline)) outline<-list(...)$outline
+ else outline<-FALSE
+ if(hasArg(lwd)) lwd<-list(...)$lwd
+ else lwd<-2
+ if(outline){
+ args<-list(...)
+ args$tree<-as.phylo(tree)
+ args$lwd<-lwd+2
+ args$colors<-par()$fg
+ args$outline<-FALSE
+ do.call(sigmoidPhylogram,args)
+ }
+ ## b=5,m1=0.01,m2=0.5,v=1
+ b<-if(hasArg(b)) list(...)$b else 5
+ m1<-if(hasArg(m1)) list(...)$m1 else 0.01
+ m2<-if(hasArg(m2)) list(...)$m2 else 0.5
+ v<-if(hasArg(v)) list(...)$v else 1
+ direction<-if(hasArg(direction)) list(...)$direction else "rightwards"
+ show.hidden<-if(hasArg(show.hidden)) list(...)$show.hidden else FALSE
+ if(inherits(tree,"simmap")){
+ if(hasArg(colors)) colors<-list(...)$colors
+ else {
+ ss<-sort(unique(c(getStates(tree,"nodes"),
+ getStates(tree,"tips"))))
+ mm<-length(ss)
+ colors<-setNames(
+ colorRampPalette(palette()[1:min(8,mm)])(mm),
+ ss)
+ }
+ } else if(inherits(tree,"phylo")) {
+ if(hasArg(color)){
+ color<-setNames(list(...)$color,"1")
+ colors<-color
+ } else colors<-setNames(par()$fg,"1")
+ tree<-paintSubTree(tree,Ntip(tree)+1,"1")
+ }
+ if(hasArg(res)) res<-list(...)$res
+ else res<-199
+ if(hasArg(use.edge.length))
+ use.edge.length<-list(...)$use.edge.length
+ else use.edge.length<-TRUE
+ if(!use.edge.length){
+ if(hasArg(power)) power<-list(...)$power
+ else power<-1
+ tree<-compute.brlen.simmap(tree,power=power)
+ }
+ h<-max(nodeHeights(tree))
+ args<-list(...)
+ args$power<-NULL
+ args$res<-NULL
+ args$colors<-NULL
+ args$b<-NULL
+ args$m1<-NULL
+ args$m2<-NULL
+ args$v<-NULL
+ args$tree<-tree
+ args$color<-if(show.hidden) make.transparent("red",0.25) else
+ "transparent"
+ if(outline) args$add<-TRUE
+ args$outline<-FALSE
+ dev.hold()
+ par_fg<-par()$fg
+ par(fg="transparent")
+ do.call(plotTree,args)
+ par(fg=par_fg)
+ pp<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ par_usr<-par()$usr
+ args$add<-TRUE
+ if(direction=="downwards"){
+ args$xlim<-pp$x.lim
+ args$ylim<-pp$y.lim[2:1]-pp$y.lim[1]
+ args$direction<-"upwards"
+ } else if(direction=="leftwards"){
+ args$xlim<-pp$x.lim[2:1]-pp$x.lim[1]
+ args$ylim<-pp$y.lim
+ args$direction<-"rightwards"
+ }
+ do.call(plotTree,args)
+ pp<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ xx<-if(direction%in%c("rightwards","leftwards")) pp$xx else pp$yy
+ yy<-if(direction%in%c("rightwards","leftwards")) pp$yy else pp$xx
+ ## Yt<-A+(K-A)/((C+exp(-B*(t-M)))^(1/v))
+ sigmoid<-function(x,.A=A,.K=K,.C=C,.B=B,.M=M,.v=v)
+ return(.A+(.K-.A)/((.C+exp(-.B*(x-.M)))^(1/.v)))
+ for(i in 1:nrow(tree$edge)){
+ A<-yy[tree$edge[i,1]]
+ K<-yy[tree$edge[i,2]]
+ if(i==1) dy<-abs(A-K)
+ B<-b*Ntip(tree)/h
+ t<-seq(xx[tree$edge[i,1]],xx[tree$edge[i,2]],
+ length.out=res)
+ t<-sort(c(t,t[1]+cumsum(tree$maps[[i]])))
+ dd<-diff(range(t))
+ M<-t[1] + if(m1*h>(m2*dd)) m2*dd else m1*h
+ C<-1
+ Yt<-c(A,sigmoid(t),K)
+ t<-c(t[1],t,t[length(t)])
+ COLS<-vector()
+ bb<-setNames(t[1]+cumsum(tree$maps[[i]]),names(tree$maps[[i]]))
+ for(j in 1:length(t))
+ COLS[j]<-colors[names(bb[which(t[j]<=bb)])[1]]
+ nn<-length(t)
+ if(direction%in%c("rightwards","leftwards"))
+ segments(t[1:(nn-1)],Yt[1:(nn-1)],x1=t[2:nn],y1=Yt[2:nn],
+ col=COLS,lwd=lwd)
+ else if(direction%in%c("upwards","downwards"))
+ segments(Yt[1:(nn-1)],t[1:(nn-1)],x1=Yt[2:nn],y1=t[2:nn],
+ col=COLS,lwd=lwd)
+ }
+ nulo<-dev.flush()
+}
+
+## function plots a round phylogram
+## written by Liam J. Revell 2014, 2015, 2016
+
+roundPhylogram<-function(tree,fsize=1.0,ftype="reg",lwd=2,mar=NULL,offset=NULL,
+ direction="rightwards",type="phylogram",xlim=NULL,ylim=NULL,...){
+ if(inherits(tree,"multiPhylo")){
+ par(ask=TRUE)
+ tt<-lapply(tree,roundPhylogram,fsize=fsize,ftype=ftype,lwd=lwd,mar=mar,offset=offset,
+ direction=direction,type=type,xlim=xlim,ylim=ylim)
+ } else {
+ if(hasArg(lty)) lty<-list(...)$lty
+ else lty<-"solid"
+ if(length(lty)!=nrow(tree$edge)) lty<-rep(lty,ceiling(nrow(tree$edge)/length(lty)))
+ if(length(lwd)!=nrow(tree$edge)) lwd<-rep(lwd,ceiling(nrow(tree$edge)/length(lwd)))
+ if(type=="cladogram"||is.null(tree$edge.length)) tree<-compute.brlen(tree)
+ ftype<-which(c("off","reg","b","i","bi")==ftype)-1
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ # swap out "_" character for spaces (assumes _ is a place holder)
+ tree$tip.label<-gsub("_"," ",tree$tip.label)
+ if(is.null(mar)) mar=rep(0.1,4)
+ n<-length(tree$tip.label)
+ # set offset fudge (empirically determined)
+ offsetFudge<-1.37
+ # reorder cladewise to assign tip positions
+ cw<-reorder(tree,"cladewise")
+ io<-reorder(tree,index.only=TRUE)
+ lwd<-lwd[io]
+ lty<-lty[io]
+ y<-vector(length=n+cw$Nnode)
+ y[cw$edge[cw$edge[,2]<=n,2]]<-1:n
+ # reorder pruningwise for post-order traversal
+ pw<-reorder(tree,"pruningwise")
+ nn<-unique(pw$edge[,1])
+ # compute vertical position of each edge
+ for(i in 1:length(nn)){
+ yy<-y[pw$edge[which(pw$edge[,1]==nn[i]),2]]
+ y[nn[i]]<-mean(range(yy))
+ }
+ # compute start & end points of each edge
+ X<-nodeHeights(cw)
+ if(is.null(xlim)){
+ pp<-par("pin")[1]
+ sw<-fsize*(max(strwidth(cw$tip.label,units="inches")))+offsetFudge*fsize*strwidth("W",units="inches")
+ alp<-optimize(function(a,H,sw,pp) (a*1.04*max(H)+sw-pp)^2,H=X,sw=sw,pp=pp,interval=c(0,1e6))$minimum
+ xlim<-c(min(X),max(X)+sw/alp)
+ }
+ if(is.null(ylim)) ylim=c(1,max(y))
+ ## end preliminaries
+ # open & size a new plot
+ plot.new()
+ par(mar=mar)
+ if(is.null(offset)) offset<-0.2*lwd/3+0.2/3
+ plot.window(xlim=xlim,ylim=ylim)
+ # plot edges
+ for(i in 1:nrow(X)){
+ x<-NULL
+ b<-y[cw$edge[i,1]]
+ c<-X[i,1]
+ d<-if(y[cw$edge[i,2]]>y[cw$edge[i,1]]) 1 else -1
+ xx<-X[i,2]
+ yy<-y[cw$edge[i,2]]
+ a<-(xx-c)/(yy-b)^2
+ curve(d*sqrt((x-c)/a)+b,from=X[i,1],to=X[i,2],add=TRUE,lwd=lwd[i],lty=lty[i])
+ }
+ # plot tip labels
+ for(i in 1:n)
+ if(ftype) text(X[which(cw$edge[,2]==i),2],y[i],tree$tip.label[i],pos=4,offset=offset,font=ftype,cex=fsize)
+ PP<-list(type=type,use.edge.length=if(type=="phylogram") TRUE else FALSE,node.pos=1,
+ show.tip.label=if(ftype) TRUE else FALSE,show.node.label=FALSE,font=ftype,cex=fsize,
+ adj=0,srt=0,no.margin=FALSE,label.offset=offset,x.lim=par()$usr[1:2],y.lim=par()$usr[3:4],
+ direction=direction,tip.color="black",Ntip=length(cw$tip.label),Nnode=cw$Nnode,edge=cw$edge,
+ xx=sapply(1:(length(cw$tip.label)+cw$Nnode),function(x,y,z) y[match(x,z)],y=X,z=cw$edge),
+ yy=y)
+ assign("last_plot.phylo",PP,envir=.PlotPhyloEnv)
+ }
+}
diff --git a/R/sim.corrs.R b/R/sim.corrs.R
index ec108e1..d51bd6b 100644
--- a/R/sim.corrs.R
+++ b/R/sim.corrs.R
@@ -1,45 +1,45 @@
-# sim.corrs
-# written by Liam J. Revell 2012, 2013, 2015
-
-sim.corrs<-function(tree,vcv,anc=NULL,internal=FALSE){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- if(!is.list(vcv)){
- p<-nrow(vcv)
- if(is.null(anc)) anc<-rep(0,p)
- cholvcv<-chol(vcv)
- X<-matrix(rnorm(p*nrow(tree$edge),sd=rep(sqrt(tree$edge.length),p)),nrow(tree$edge),p)
- X<-X%*%cholvcv
- } else {
- p<-nrow(vcv[[1]])
- if(is.null(anc)) anc<-rep(0,p)
- if(is.null(names(vcv))){
- names(vcv)<-colnames(tree$mapped.edge)
- message("names absent from vcv: assuming same order as $mapped.edge")
- }
- vcv<-vcv[colnames(tree$mapped.edge)]
- cholvcv<-lapply(vcv,chol)
- X<-matrix(0,nrow(tree$edge),p)
- for(i in 1:length(vcv)){
- Y<-matrix(rnorm(p*nrow(tree$edge),sd=rep(sqrt(tree$mapped.edge[,i]),p)),nrow(tree$edge),p)
- X<-X+Y%*%cholvcv[[i]]
- }
- }
- Y<-array(0,dim=c(nrow(tree$edge),ncol(tree$edge),p))
- n<-length(tree$tip)
- for(i in 1:nrow(X)){
- if(tree$edge[i,1]==(n+1))
- Y[i,1,]<-anc
- else
- Y[i,1,]<-Y[match(tree$edge[i,1],tree$edge[,2]),2,]
- Y[i,2,]<-Y[i,1,]+X[i,]
- }
- X<-matrix(data=rbind(Y[1,1,],as.matrix(Y[,2,])),length(tree$edge.length)+1,p)
- rownames(X)<-c(n+1,tree$edge[,2])
- X<-as.matrix(X[as.character(1:(n+tree$Nnode)),])
- rownames(X)[1:n]<-tree$tip.label
- if(internal==TRUE)
- return(X)
- else
- return(X[1:length(tree$tip.label),])
-
-}
+# sim.corrs
+# written by Liam J. Revell 2012, 2013, 2015
+
+sim.corrs<-function(tree,vcv,anc=NULL,internal=FALSE){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ if(!is.list(vcv)){
+ p<-nrow(vcv)
+ if(is.null(anc)) anc<-rep(0,p)
+ cholvcv<-chol(vcv)
+ X<-matrix(rnorm(p*nrow(tree$edge),sd=rep(sqrt(tree$edge.length),p)),nrow(tree$edge),p)
+ X<-X%*%cholvcv
+ } else {
+ p<-nrow(vcv[[1]])
+ if(is.null(anc)) anc<-rep(0,p)
+ if(is.null(names(vcv))){
+ names(vcv)<-colnames(tree$mapped.edge)
+ message("names absent from vcv: assuming same order as $mapped.edge")
+ }
+ vcv<-vcv[colnames(tree$mapped.edge)]
+ cholvcv<-lapply(vcv,chol)
+ X<-matrix(0,nrow(tree$edge),p)
+ for(i in 1:length(vcv)){
+ Y<-matrix(rnorm(p*nrow(tree$edge),sd=rep(sqrt(tree$mapped.edge[,i]),p)),nrow(tree$edge),p)
+ X<-X+Y%*%cholvcv[[i]]
+ }
+ }
+ Y<-array(0,dim=c(nrow(tree$edge),ncol(tree$edge),p))
+ n<-length(tree$tip)
+ for(i in 1:nrow(X)){
+ if(tree$edge[i,1]==(n+1))
+ Y[i,1,]<-anc
+ else
+ Y[i,1,]<-Y[match(tree$edge[i,1],tree$edge[,2]),2,]
+ Y[i,2,]<-Y[i,1,]+X[i,]
+ }
+ X<-matrix(data=rbind(Y[1,1,],as.matrix(Y[,2,])),length(tree$edge.length)+1,p)
+ rownames(X)<-c(n+1,tree$edge[,2])
+ X<-as.matrix(X[as.character(1:(n+tree$Nnode)),])
+ rownames(X)[1:n]<-tree$tip.label
+ if(internal==TRUE)
+ return(X)
+ else
+ return(X[1:length(tree$tip.label),])
+
+}
diff --git a/R/sim.history.R b/R/sim.history.R
index 4ecbe7a..e67aaae 100644
--- a/R/sim.history.R
+++ b/R/sim.history.R
@@ -1,159 +1,159 @@
-## function simulates stochastic character history under some model
-## written by Liam J. Revell 2011, 2013, 2014, 2016, 2020
-
-sim.history<-function(tree,Q,anc=NULL,nsim=1,direction=c("column_to_row","row_to_column"),
- ...){
- if(!inherits(tree,"phylo"))
- stop("tree should be an object of class \"phylo\".")
- if(hasArg(message)) message<-list(...)$message
- else message<-TRUE
- direction<-direction[1]
- direction<-strsplit(direction,"_")[[1]][1]
- # reorder to cladewise
- tree<-reorder.phylo(tree,"cladewise")
- # check Q
- if(!isSymmetric(Q)) if(message){
- if(direction=="column")
- cat("Note - the rate of substitution from i->j should be given by Q[j,i].\n")
- else if(direction=="row")
- cat("Note - the rate of substitution from i->j should be given by Q[i,j].\n")
- }
- if(direction=="column"){
- if(!all(round(colSums(Q),10)==0)){
- if(all(round(rowSums(Q),10)==0)&&!isSymmetric(Q)){
- if(message){
- cat("Detecting that rows, not columns, of Q sum to zero :\n")
- cat("Transposing Q for internal calculations.\n")
- }
- Q<-t(Q)
- } else {
- if(message)
- cat("Some columns (or rows) of Q don't sum to 0.0. Fixing.\n")
- diag(Q)<-0
- diag(Q)<--colSums(Q,na.rm=TRUE)
- }
- }
- } else if(direction=="row"){
- Q<-t(Q)
- if(!all(round(colSums(Q),10)==0)){
- if(all(round(rowSums(Q),10)==0)&&!isSymmetric(Q)){
- if(message){
- cat("Detecting that columns, not rows, of Q sum to zero :\n")
- cat("Transposing Q for internal calculations.\n")
- }
- Q<-t(Q)
- } else {
- if(message)
- cat("Some columns (or rows) of Q don't sum to 0.0. Fixing.\n")
- diag(Q)<-0
- diag(Q)<--colSums(Q,na.rm=TRUE)
- }
- }
- }
- # does Q have names?
- if(is.null(dimnames(Q))) dimnames(Q)<-list(1:nrow(Q),1:ncol(Q))
- # create "multiPhylo" object
- mtrees<-vector(mode="list",length=nsim)
- class(mtrees)<-c("multiSimmap","multiPhylo")
- ## deal with ancestral state
- if(is.null(anc))
- anc<-setNames(rep(1/ncol(Q),ncol(Q)),colnames(Q))
- if(is.character(anc)){
- anc<-colSums(to.matrix(anc,colnames(Q)))
- anc<-anc/sum(anc)
- }
- # now loop
- for(i in 1:nsim){
- # set root state
- a<-rstate(anc)
- # create the map tree object
- mtree<-tree
- mtree$maps<-vector(mode="list",length=nrow(tree$edge))
- # now we want to simulate the node states on the tree
- node.states<-matrix(NA,nrow(tree$edge),ncol(tree$edge))
- node.states[which(tree$edge[,1]==(length(tree$tip)+1)),1]<-a
- for(j in 1:nrow(tree$edge)){
- if(tree$edge.length[j]==0){
- map<-vector()
- map[1]<-tree$edge.length[j]
- names(map)[1]<-
- node.states[which(tree$edge[,1]==tree$edge[j,2]),1]<-
- node.states[j,2]<-node.states[j,1]
- } else {
- time=0
- state<-node.states[j,1]
- new.state<-state
- dt<-vector()
- map<-vector()
- k<-1
- while(time<tree$edge.length[j]){
- dt[1]<-time
- dt[2]<-dt[1]+rexp(n=1,rate=-Q[state,state])
- if(dt[2]<tree$edge.length[j])
- new.state<-rstate(Q[,state][-match(state,rownames(Q))]/
- sum(Q[,state][-match(state,rownames(Q))]))
- dt[2]<-min(dt[2],tree$edge.length[j])
- map[k]<-dt[2]-dt[1]
- names(map)[k]<-state
- k<-k+1
- state<-new.state
- time<-dt[2]
- }
- names(map)[length(map)]->node.states[j,2]->
- node.states[which(tree$edge[,1]==tree$edge[j,2]),1]
- }
- mtree$maps[[j]]<-map
- }
- # add a couple of elements
- mtree$node.states<-node.states
- tip.states<-node.states[tree$edge[,2]<=length(tree$tip),2]
- tip.states<-tip.states[order(tree$edge[tree$edge[,2]<=length(tree$tip),2])]
- names(tip.states)<-tree$tip.label
- mtree$states<-tip.states
- # now construct the matrix "mapped.edge" (for backward compatibility
- allstates<-vector()
- for(j in 1:nrow(mtree$edge))
- allstates<-c(allstates,names(mtree$maps[[j]]))
- allstates<-unique(allstates)
- mtree$mapped.edge<-matrix(data=0,length(mtree$edge.length),
- length(allstates),dimnames=list(apply(mtree$edge,1,
- function(x) paste(x,collapse=",")),state=allstates))
- for(j in 1:length(mtree$maps))
- for(k in 1:length(mtree$maps[[j]]))
- mtree$mapped.edge[j,names(mtree$maps[[j]])[k]]<-
- mtree$mapped.edge[j,names(mtree$maps[[j]])[k]]+
- mtree$maps[[j]][k]
- class(mtree)<-c("simmap",setdiff(class(mtree),"simmap"))
- mtrees[[i]]<-mtree
- }
- if(nsim==1) mtrees<-mtrees[[1]]
- if(message) cat("Done simulation(s).\n")
- mtrees
-}
-
-## simulate DNA sequence from a tree & model parameters
-## written by Liam J. Revell 2013, 2019
-
-genSeq<-function(tree,l=1000,Q=NULL,rate=1,format="DNAbin",...){
- if(is.null(Q)){
- Q<-matrix(1,4,4)
- rownames(Q)<-colnames(Q)<-c("a","c","g","t")
- diag(Q)<-0
- diag(Q)<--colSums(Q)
- }
- if(length(rate)!=l){
- if(length(rate)==1) rate<-rep(rate,l)
- else {
- cat("warning: length(rate) & l should match for length(rate)>1\n")
- cat(" rate will be recycled.\n")
- rate<-rep(rate,ceiling(l/length(rate)))[1:l]
- }
- }
- cat("simulating sequences....\n")
- flush.console()
- X<-sapply(rate,function(a,b,c) sim.Mk(b,a*c),b=tree,c=Q)
- if(format=="DNAbin") return(as.DNAbin(X))
- else if(format=="phyDat") return(as.phyDat(X))
- else if(format=="matrix") return(X)
-}
-
+## function simulates stochastic character history under some model
+## written by Liam J. Revell 2011, 2013, 2014, 2016, 2020
+
+sim.history<-function(tree,Q,anc=NULL,nsim=1,direction=c("column_to_row","row_to_column"),
+ ...){
+ if(!inherits(tree,"phylo"))
+ stop("tree should be an object of class \"phylo\".")
+ if(hasArg(message)) message<-list(...)$message
+ else message<-TRUE
+ direction<-direction[1]
+ direction<-strsplit(direction,"_")[[1]][1]
+ # reorder to cladewise
+ tree<-reorder.phylo(tree,"cladewise")
+ # check Q
+ if(!isSymmetric(Q)) if(message){
+ if(direction=="column")
+ cat("Note - the rate of substitution from i->j should be given by Q[j,i].\n")
+ else if(direction=="row")
+ cat("Note - the rate of substitution from i->j should be given by Q[i,j].\n")
+ }
+ if(direction=="column"){
+ if(!all(round(colSums(Q),10)==0)){
+ if(all(round(rowSums(Q),10)==0)&&!isSymmetric(Q)){
+ if(message){
+ cat("Detecting that rows, not columns, of Q sum to zero :\n")
+ cat("Transposing Q for internal calculations.\n")
+ }
+ Q<-t(Q)
+ } else {
+ if(message)
+ cat("Some columns (or rows) of Q don't sum to 0.0. Fixing.\n")
+ diag(Q)<-0
+ diag(Q)<--colSums(Q,na.rm=TRUE)
+ }
+ }
+ } else if(direction=="row"){
+ Q<-t(Q)
+ if(!all(round(colSums(Q),10)==0)){
+ if(all(round(rowSums(Q),10)==0)&&!isSymmetric(Q)){
+ if(message){
+ cat("Detecting that columns, not rows, of Q sum to zero :\n")
+ cat("Transposing Q for internal calculations.\n")
+ }
+ Q<-t(Q)
+ } else {
+ if(message)
+ cat("Some columns (or rows) of Q don't sum to 0.0. Fixing.\n")
+ diag(Q)<-0
+ diag(Q)<--colSums(Q,na.rm=TRUE)
+ }
+ }
+ }
+ # does Q have names?
+ if(is.null(dimnames(Q))) dimnames(Q)<-list(1:nrow(Q),1:ncol(Q))
+ # create "multiPhylo" object
+ mtrees<-vector(mode="list",length=nsim)
+ class(mtrees)<-c("multiSimmap","multiPhylo")
+ ## deal with ancestral state
+ if(is.null(anc))
+ anc<-setNames(rep(1/ncol(Q),ncol(Q)),colnames(Q))
+ if(is.character(anc)){
+ anc<-colSums(to.matrix(anc,colnames(Q)))
+ anc<-anc/sum(anc)
+ }
+ # now loop
+ for(i in 1:nsim){
+ # set root state
+ a<-rstate(anc)
+ # create the map tree object
+ mtree<-tree
+ mtree$maps<-vector(mode="list",length=nrow(tree$edge))
+ # now we want to simulate the node states on the tree
+ node.states<-matrix(NA,nrow(tree$edge),ncol(tree$edge))
+ node.states[which(tree$edge[,1]==(length(tree$tip)+1)),1]<-a
+ for(j in 1:nrow(tree$edge)){
+ if(tree$edge.length[j]==0){
+ map<-vector()
+ map[1]<-tree$edge.length[j]
+ names(map)[1]<-
+ node.states[which(tree$edge[,1]==tree$edge[j,2]),1]<-
+ node.states[j,2]<-node.states[j,1]
+ } else {
+ time=0
+ state<-node.states[j,1]
+ new.state<-state
+ dt<-vector()
+ map<-vector()
+ k<-1
+ while(time<tree$edge.length[j]){
+ dt[1]<-time
+ dt[2]<-dt[1]+rexp(n=1,rate=-Q[state,state])
+ if(dt[2]<tree$edge.length[j])
+ new.state<-rstate(Q[,state][-match(state,rownames(Q))]/
+ sum(Q[,state][-match(state,rownames(Q))]))
+ dt[2]<-min(dt[2],tree$edge.length[j])
+ map[k]<-dt[2]-dt[1]
+ names(map)[k]<-state
+ k<-k+1
+ state<-new.state
+ time<-dt[2]
+ }
+ names(map)[length(map)]->node.states[j,2]->
+ node.states[which(tree$edge[,1]==tree$edge[j,2]),1]
+ }
+ mtree$maps[[j]]<-map
+ }
+ # add a couple of elements
+ mtree$node.states<-node.states
+ tip.states<-node.states[tree$edge[,2]<=length(tree$tip),2]
+ tip.states<-tip.states[order(tree$edge[tree$edge[,2]<=length(tree$tip),2])]
+ names(tip.states)<-tree$tip.label
+ mtree$states<-tip.states
+ # now construct the matrix "mapped.edge" (for backward compatibility
+ allstates<-vector()
+ for(j in 1:nrow(mtree$edge))
+ allstates<-c(allstates,names(mtree$maps[[j]]))
+ allstates<-unique(allstates)
+ mtree$mapped.edge<-matrix(data=0,length(mtree$edge.length),
+ length(allstates),dimnames=list(apply(mtree$edge,1,
+ function(x) paste(x,collapse=",")),state=allstates))
+ for(j in 1:length(mtree$maps))
+ for(k in 1:length(mtree$maps[[j]]))
+ mtree$mapped.edge[j,names(mtree$maps[[j]])[k]]<-
+ mtree$mapped.edge[j,names(mtree$maps[[j]])[k]]+
+ mtree$maps[[j]][k]
+ class(mtree)<-c("simmap",setdiff(class(mtree),"simmap"))
+ mtrees[[i]]<-mtree
+ }
+ if(nsim==1) mtrees<-mtrees[[1]]
+ if(message) cat("Done simulation(s).\n")
+ mtrees
+}
+
+## simulate DNA sequence from a tree & model parameters
+## written by Liam J. Revell 2013, 2019
+
+genSeq<-function(tree,l=1000,Q=NULL,rate=1,format="DNAbin",...){
+ if(is.null(Q)){
+ Q<-matrix(1,4,4)
+ rownames(Q)<-colnames(Q)<-c("a","c","g","t")
+ diag(Q)<-0
+ diag(Q)<--colSums(Q)
+ }
+ if(length(rate)!=l){
+ if(length(rate)==1) rate<-rep(rate,l)
+ else {
+ cat("warning: length(rate) & l should match for length(rate)>1\n")
+ cat(" rate will be recycled.\n")
+ rate<-rep(rate,ceiling(l/length(rate)))[1:l]
+ }
+ }
+ cat("simulating sequences....\n")
+ flush.console()
+ X<-sapply(rate,function(a,b,c) sim.Mk(b,a*c),b=tree,c=Q)
+ if(format=="DNAbin") return(as.DNAbin(X))
+ else if(format=="phyDat") return(as.phyDat(X))
+ else if(format=="matrix") return(X)
+}
+
diff --git a/R/simBMphylo.R b/R/simBMphylo.R
index dffad6c..84c9a67 100644
--- a/R/simBMphylo.R
+++ b/R/simBMphylo.R
@@ -1,74 +1,74 @@
-## functions & methods to simulate & plot discrete time Brownian motion
-## on a simulated discrete-time tree
-
-simBMphylo<-function(n,t,sig2,plot=TRUE,...){
- if(length(sig2)!=t) sig2<-rep(sig2[1],t)
- b<-exp((log(n)-log(2))/t)-1
- tree<-pbtree(b=b,d=0,t=t,n=n,type="discrete",
- tip.label=if(n<=26) LETTERS[n:1] else NULL,
- quiet=TRUE)
- H<-nodeHeights(tree)
- root<-Ntip(tree)+1
- xx<-list()
- for(i in 1:nrow(tree$edge)){
- sd<-sqrt(sig2[H[i,1]+1:tree$edge.length[i]])
- x<-rnorm(n=tree$edge.length[i],sd=sd)
- x<-c(0,cumsum(x))
- if(tree$edge[i,1]!=root){
- ii<-which(tree$edge[,2]==tree$edge[i,1])
- x<-x+xx[[ii]][length(xx[[ii]])]
- }
- xx[[i]]<-x
- }
- object<-list(tree=tree,x=xx)
- class(object)<-"simBMphylo"
- if(plot) plot(object,...)
- invisible(object)
-}
-
-plot.simBMphylo<-function(x,...){
- xx<-x$x
- tree<-x$tree
- H<-nodeHeights(tree)
- layout(mat=matrix(c(1,2),2,1),
- heights=c(1/3,2/3))
- if(hasArg(fsize)) fsize<-list(...)$fsize
- else fsize<-0.9
- if(hasArg(cex.axis)) cex.axis<-list(...)$cex.axis
- else cex.axis<-0.9
- if(hasArg(cex.lab)) cex.lab=list(...)$cex.lab
- else cex.lab<-1
- if(hasArg(las)) las<-list(...)$las
- else las<-par()$las
- plotTree(tree,mar=c(0.1,4.1,2.1,1.1),
- xlim=c(0,1.05*max(H)),
- ylim=c(1-2*(Ntip(tree)-1)*0.04,
- Ntip(tree)+(Ntip(tree)-1)*0.04),lwd=1,
- fsize=fsize)
- ## axis(1,cex.axis=cex.axis)
- mtext("a)",line=0,adj=0,cex=cex.lab)
- plot.new()
- par(mar=c(5.1,4.1,1.1,1.1))
- plot.window(xlim=c(0,1.05*max(H)),ylim=range(xx))
- axis(1,cex.axis=cex.axis,las=las)
- axis(2,cex.axis=cex.axis,las=las)
- for(i in 1:length(xx))
- lines(H[i,1]:H[i,2],xx[[i]])
- for(i in 1:Ntip(tree)){
- ii<-which(tree$edge[,2]==i)
- text(max(H),xx[[ii]][length(xx[[ii]])],
- tree$tip.label[i],pos=4,offset=0.4/3,
- cex=fsize)
- }
- mtext("b)",line=0,adj=0,cex=cex.lab)
-
- title(xlab="time",ylab="phenotype",
- cex.lab=cex.lab)
-}
-
-print.simBMphylo<-function(x,...){
- cat(paste("\nObject of class \"simBMphylo\" with",Ntip(x$tree),"taxa.\n"),
- sep="")
- cat("To print use plot method.\n\n")
-}
-
+## functions & methods to simulate & plot discrete time Brownian motion
+## on a simulated discrete-time tree
+
+simBMphylo<-function(n,t,sig2,plot=TRUE,...){
+ if(length(sig2)!=t) sig2<-rep(sig2[1],t)
+ b<-exp((log(n)-log(2))/t)-1
+ tree<-pbtree(b=b,d=0,t=t,n=n,type="discrete",
+ tip.label=if(n<=26) LETTERS[n:1] else NULL,
+ quiet=TRUE)
+ H<-nodeHeights(tree)
+ root<-Ntip(tree)+1
+ xx<-list()
+ for(i in 1:nrow(tree$edge)){
+ sd<-sqrt(sig2[H[i,1]+1:tree$edge.length[i]])
+ x<-rnorm(n=tree$edge.length[i],sd=sd)
+ x<-c(0,cumsum(x))
+ if(tree$edge[i,1]!=root){
+ ii<-which(tree$edge[,2]==tree$edge[i,1])
+ x<-x+xx[[ii]][length(xx[[ii]])]
+ }
+ xx[[i]]<-x
+ }
+ object<-list(tree=tree,x=xx)
+ class(object)<-"simBMphylo"
+ if(plot) plot(object,...)
+ invisible(object)
+}
+
+plot.simBMphylo<-function(x,...){
+ xx<-x$x
+ tree<-x$tree
+ H<-nodeHeights(tree)
+ layout(mat=matrix(c(1,2),2,1),
+ heights=c(1/3,2/3))
+ if(hasArg(fsize)) fsize<-list(...)$fsize
+ else fsize<-0.9
+ if(hasArg(cex.axis)) cex.axis<-list(...)$cex.axis
+ else cex.axis<-0.9
+ if(hasArg(cex.lab)) cex.lab=list(...)$cex.lab
+ else cex.lab<-1
+ if(hasArg(las)) las<-list(...)$las
+ else las<-par()$las
+ plotTree(tree,mar=c(0.1,4.1,2.1,1.1),
+ xlim=c(0,1.05*max(H)),
+ ylim=c(1-2*(Ntip(tree)-1)*0.04,
+ Ntip(tree)+(Ntip(tree)-1)*0.04),lwd=1,
+ fsize=fsize)
+ ## axis(1,cex.axis=cex.axis)
+ mtext("a)",line=0,adj=0,cex=cex.lab)
+ plot.new()
+ par(mar=c(5.1,4.1,1.1,1.1))
+ plot.window(xlim=c(0,1.05*max(H)),ylim=range(xx))
+ axis(1,cex.axis=cex.axis,las=las)
+ axis(2,cex.axis=cex.axis,las=las)
+ for(i in 1:length(xx))
+ lines(H[i,1]:H[i,2],xx[[i]])
+ for(i in 1:Ntip(tree)){
+ ii<-which(tree$edge[,2]==i)
+ text(max(H),xx[[ii]][length(xx[[ii]])],
+ tree$tip.label[i],pos=4,offset=0.4/3,
+ cex=fsize)
+ }
+ mtext("b)",line=0,adj=0,cex=cex.lab)
+
+ title(xlab="time",ylab="phenotype",
+ cex.lab=cex.lab)
+}
+
+print.simBMphylo<-function(x,...){
+ cat(paste("\nObject of class \"simBMphylo\" with",Ntip(x$tree),"taxa.\n"),
+ sep="")
+ cat("To print use plot method.\n\n")
+}
+
diff --git a/R/skewers.R b/R/skewers.R
index a7e2723..4fe7ecb 100644
--- a/R/skewers.R
+++ b/R/skewers.R
@@ -1,37 +1,37 @@
-## this function does random skewers following Cheverud & Marroig (2007)
-## for is.null(method)==FALSE uses clusterGeneration::genPositiveDefMat
-## written by Liam J. Revell 2013
-
-skewers<-function(X,Y,nsim=100,method=NULL){
- m<-nrow(X)
- if(!all(sapply(c(dim(X),dim(Y)),"==",m)))
- stop("X & Y should be square matrices of equal dimension")
- S<-matrix(runif(nsim*m,min=-1,max=1),nsim,m)
- S<-S/matrix(sqrt(rowSums(S^2)),nsim,m)
- Sx<-apply(S,1,"%*%",X)
- Sy<-apply(S,1,"%*%",Y)
- R<-colMeans(Sx*Sy)/sqrt(colMeans(Sx^2)*colMeans(Sy^2))
- r<-mean(R)
- ## get null distribution
- foo<-function(m,method,rangeVar){
- if(is.null(method)){
- x<-runif(m,min=-1,max=1)
- x<-x/sqrt(sum(x^2))
- y<-runif(m)
- y<-y/sqrt(sum(y^2))
- r<-mean(x*y)/sqrt(mean(x^2)*mean(y^2))
- } else {
- X<-genPositiveDefMat(m,covMethod=method,rangeVar=rangeVar)$Sigma
- Y<-genPositiveDefMat(m,covMethod=method,rangeVar=rangeVar)$Sigma
- S<-matrix(runif(nsim*m,min=-1,max=1),nsim,m)
- S<-S/matrix(sqrt(rowSums(S^2)),nsim,m)
- Sx<-apply(S,1,"%*%",X)
- Sy<-apply(S,1,"%*%",Y)
- R<-colMeans(Sx*Sy)/sqrt(colMeans(Sx^2)*colMeans(Sy^2))
- r<-mean(R)
- }
- r
- }
- Rnull<-replicate(nsim,foo(m,method=method,rangeVar=range(c(diag(X),diag(Y)))))
- return(list(r=r,p=mean(Rnull>=r)))
+## this function does random skewers following Cheverud & Marroig (2007)
+## for is.null(method)==FALSE uses clusterGeneration::genPositiveDefMat
+## written by Liam J. Revell 2013
+
+skewers<-function(X,Y,nsim=100,method=NULL){
+ m<-nrow(X)
+ if(!all(sapply(c(dim(X),dim(Y)),"==",m)))
+ stop("X & Y should be square matrices of equal dimension")
+ S<-matrix(runif(nsim*m,min=-1,max=1),nsim,m)
+ S<-S/matrix(sqrt(rowSums(S^2)),nsim,m)
+ Sx<-apply(S,1,"%*%",X)
+ Sy<-apply(S,1,"%*%",Y)
+ R<-colMeans(Sx*Sy)/sqrt(colMeans(Sx^2)*colMeans(Sy^2))
+ r<-mean(R)
+ ## get null distribution
+ foo<-function(m,method,rangeVar){
+ if(is.null(method)){
+ x<-runif(m,min=-1,max=1)
+ x<-x/sqrt(sum(x^2))
+ y<-runif(m)
+ y<-y/sqrt(sum(y^2))
+ r<-mean(x*y)/sqrt(mean(x^2)*mean(y^2))
+ } else {
+ X<-genPositiveDefMat(m,covMethod=method,rangeVar=rangeVar)$Sigma
+ Y<-genPositiveDefMat(m,covMethod=method,rangeVar=rangeVar)$Sigma
+ S<-matrix(runif(nsim*m,min=-1,max=1),nsim,m)
+ S<-S/matrix(sqrt(rowSums(S^2)),nsim,m)
+ Sx<-apply(S,1,"%*%",X)
+ Sy<-apply(S,1,"%*%",Y)
+ R<-colMeans(Sx*Sy)/sqrt(colMeans(Sx^2)*colMeans(Sy^2))
+ r<-mean(R)
+ }
+ r
+ }
+ Rnull<-replicate(nsim,foo(m,method=method,rangeVar=range(c(diag(X),diag(Y)))))
+ return(list(r=r,p=mean(Rnull>=r)))
}
\ No newline at end of file
diff --git a/R/splitplotTree.R b/R/splitplotTree.R
index d12dcfc..cd4eb91 100644
--- a/R/splitplotTree.R
+++ b/R/splitplotTree.R
@@ -1,97 +1,97 @@
-## functions to split a tree into two (or more) plots by different methods
-## written by Liam J. Revell 2012, 2015
-
-plotTree.splits<-function(tree,splits=NULL,file=NULL,fn=NULL,...){
- if(is.null(fn)) fn<-function(){}
- ef<-0.037037037037 ## expansion factor
- if(!is.null(file)) pdf(file,width=8.5,height=11)
- if(is.null(splits)) splits<-(floor(0.5*Ntip(tree))+0.5)/Ntip(tree)
- if(hasArg(y.lim)) y.lim<-list(...)$y.lim
- else y.lim<-c(0,Ntip(tree))
- S<-matrix(c(0,splits,splits,1+1/Ntip(tree)),length(splits)+1,2)
- S<-cbind(S[,1]+ef*(S[,2]-S[,1]),S[,2]-ef*(S[,2]-S[,1]))
- S<-S*diff(y.lim)+y.lim[1]
- for(i in nrow(S):1){
- if(is.null(file)&&i<nrow(S)) par(ask=TRUE)
- plotTree(tree,ylim=S[i,],...)
- fn()
- }
- if(!is.null(file)) oo<-dev.off()
-}
-
-splitplotTree<-function(tree,fsize=1.0,ftype="reg",lwd=2,split=NULL,new.window=FALSE){
- # check font
- ftype<-which(c("off","reg","b","i","bi")==ftype)-1
- if(!ftype) fsize=0 # check tree
- # check tree
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- # rescale tree
- tree$edge.length<-tree$edge.length/max(nodeHeights(tree))
- # check split
- n<-length(tree$tip)
- if(is.null(split))
- split<-0.5
- s<-(1-split)*(n+1)
- # reorder
- cw<-reorder(tree)
- pw<-reorder(tree,"pruningwise")
- # count nodes
- m<-cw$Nnode
- # y coordinates for nodes
- y<-matrix(NA,m+n,1)
- y[cw$edge[cw$edge[,2]<=length(cw$tip),2]]<-1:n
- nodes<-unique(pw$edge[,1])
- for(i in 1:m){
- desc<-pw$edge[which(pw$edge[,1]==nodes[i]),2]
- y[nodes[i]]<-(min(y[desc])+max(y[desc]))/2
- }
- Y<-matrix(NA,nrow(cw$edge),ncol(cw$edge))
- for(i in 1:nrow(cw$edge)) Y[i,]<-rep(y[cw$edge[i,2]])
- # compute node heights
- H<-nodeHeights(tree)
- # now split
- a<-which(Y[,1]>=s)
- Y1<-Y[a,]; Y2<-Y[-a,]
- b<-(min(Y1)-max(Y2))/2
- Y1<-Y1-s+1; Y2<-Y2
- H1<-H[a,]; H2<-H[-a,]
- edge1<-cw$edge[a,]; edge2<-cw$edge[-a,]
- if(length(H1)==2){ H1<-matrix(H1,1,2); Y1<-matrix(Y1,1,2); edge1<-matrix(edge1,1,2) }
- if(length(H2)==2){ H2<-matrix(H2,1,2); Y2<-matrix(Y2,1,2); edge2<-matrix(edge2,1,2) }
- # label offset
- offset<-0.2*lwd/3+0.2/3
- # open plot
- par(mar=c(0.1,0.1,0.1,0.1))
- if(!new.window) layout(matrix(c(1,2),1,2))
- # first half
- plot.new();
- if(fsize*max(strwidth(cw$tip.label))<1.0){
- k<-(1-fsize*max(strwidth(cw$tip.label)))/max(H)
- H<-k*H
- H1<-k*H1
- H2<-k*H2
- } else message("Font size too large to properly rescale tree to window.")
- plot.window(xlim=c(0,max(H)+fsize*max(strwidth(cw$tip.label))),ylim=c(1-b,max(rbind(Y1,Y2))))
- for(i in 1:nrow(H1)) lines(H1[i,],Y1[i,],lwd=lwd,lend=2)
- nodes<-unique(edge1[,1])
- for(i in 1:length(nodes)) lines(H1[which(edge1[,1]==nodes[i]),1],Y1[which(edge1[,1]==nodes[i]),1],lwd=lwd)
- for(i in 1:nrow(edge1)) if(edge1[i,1]%in%edge2[,1]) lines(c(H1[i,1],H1[i,1]),c(Y1[i,1],1-b),lwd=lwd,lend=2)
- tips<-edge1[edge1[,2]<=n,2]
- for(i in 1:length(tips))
- if(ftype) text(H1[which(edge1[,2]==tips[i]),2],Y1[which(edge1[,2]==tips[i]),1],cw$tip.label[tips[i]],pos=4,cex=fsize,font=ftype,offset=offset)
- # second half
- if(new.window){ dev.new(); par(mar=c(0.1,0.1,0.1,0.1)) }
- plot.new()
- if(max(Y1)>max(Y2)) Y2<-Y2+max(Y1)-max(Y2)
- plot.window(xlim=c(0,max(H)+fsize*max(strwidth(cw$tip.label))),ylim=c(1,max(rbind(Y1,Y2)+b)))
- for(i in 1:nrow(H2)) lines(H2[i,],Y2[i,],lwd=lwd,lend=2)
- nodes<-unique(edge2[,1])
- for(i in 1:length(nodes)) lines(H2[which(edge2[,1]==nodes[i]),1],Y2[which(edge2[,1]==nodes[i]),1],lwd=lwd)
- for(i in 1:nrow(edge2)) if(edge2[i,1]%in%edge1[,1]) lines(c(H2[i,1],H2[i,1]),c(Y2[i,1],max(Y2)+b),lwd=lwd,lend=2)
- tips<-edge2[edge2[,2]<=n,2]
- for(i in 1:length(tips))
- if(ftype) text(H2[which(edge2[,2]==tips[i]),2],Y2[which(edge2[,2]==tips[i]),1],cw$tip.label[tips[i]],pos=4,cex=fsize,font=ftype,offset=offset)
- # reset margin and layout
- layout(1)
- par(mar=c(5,4,4,2)+0.1)
-}
+## functions to split a tree into two (or more) plots by different methods
+## written by Liam J. Revell 2012, 2015
+
+plotTree.splits<-function(tree,splits=NULL,file=NULL,fn=NULL,...){
+ if(is.null(fn)) fn<-function(){}
+ ef<-0.037037037037 ## expansion factor
+ if(!is.null(file)) pdf(file,width=8.5,height=11)
+ if(is.null(splits)) splits<-(floor(0.5*Ntip(tree))+0.5)/Ntip(tree)
+ if(hasArg(y.lim)) y.lim<-list(...)$y.lim
+ else y.lim<-c(0,Ntip(tree))
+ S<-matrix(c(0,splits,splits,1+1/Ntip(tree)),length(splits)+1,2)
+ S<-cbind(S[,1]+ef*(S[,2]-S[,1]),S[,2]-ef*(S[,2]-S[,1]))
+ S<-S*diff(y.lim)+y.lim[1]
+ for(i in nrow(S):1){
+ if(is.null(file)&&i<nrow(S)) par(ask=TRUE)
+ plotTree(tree,ylim=S[i,],...)
+ fn()
+ }
+ if(!is.null(file)) oo<-dev.off()
+}
+
+splitplotTree<-function(tree,fsize=1.0,ftype="reg",lwd=2,split=NULL,new.window=FALSE){
+ # check font
+ ftype<-which(c("off","reg","b","i","bi")==ftype)-1
+ if(!ftype) fsize=0 # check tree
+ # check tree
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ # rescale tree
+ tree$edge.length<-tree$edge.length/max(nodeHeights(tree))
+ # check split
+ n<-length(tree$tip)
+ if(is.null(split))
+ split<-0.5
+ s<-(1-split)*(n+1)
+ # reorder
+ cw<-reorder(tree)
+ pw<-reorder(tree,"pruningwise")
+ # count nodes
+ m<-cw$Nnode
+ # y coordinates for nodes
+ y<-matrix(NA,m+n,1)
+ y[cw$edge[cw$edge[,2]<=length(cw$tip),2]]<-1:n
+ nodes<-unique(pw$edge[,1])
+ for(i in 1:m){
+ desc<-pw$edge[which(pw$edge[,1]==nodes[i]),2]
+ y[nodes[i]]<-(min(y[desc])+max(y[desc]))/2
+ }
+ Y<-matrix(NA,nrow(cw$edge),ncol(cw$edge))
+ for(i in 1:nrow(cw$edge)) Y[i,]<-rep(y[cw$edge[i,2]])
+ # compute node heights
+ H<-nodeHeights(tree)
+ # now split
+ a<-which(Y[,1]>=s)
+ Y1<-Y[a,]; Y2<-Y[-a,]
+ b<-(min(Y1)-max(Y2))/2
+ Y1<-Y1-s+1; Y2<-Y2
+ H1<-H[a,]; H2<-H[-a,]
+ edge1<-cw$edge[a,]; edge2<-cw$edge[-a,]
+ if(length(H1)==2){ H1<-matrix(H1,1,2); Y1<-matrix(Y1,1,2); edge1<-matrix(edge1,1,2) }
+ if(length(H2)==2){ H2<-matrix(H2,1,2); Y2<-matrix(Y2,1,2); edge2<-matrix(edge2,1,2) }
+ # label offset
+ offset<-0.2*lwd/3+0.2/3
+ # open plot
+ par(mar=c(0.1,0.1,0.1,0.1))
+ if(!new.window) layout(matrix(c(1,2),1,2))
+ # first half
+ plot.new();
+ if(fsize*max(strwidth(cw$tip.label))<1.0){
+ k<-(1-fsize*max(strwidth(cw$tip.label)))/max(H)
+ H<-k*H
+ H1<-k*H1
+ H2<-k*H2
+ } else message("Font size too large to properly rescale tree to window.")
+ plot.window(xlim=c(0,max(H)+fsize*max(strwidth(cw$tip.label))),ylim=c(1-b,max(rbind(Y1,Y2))))
+ for(i in 1:nrow(H1)) lines(H1[i,],Y1[i,],lwd=lwd,lend=2)
+ nodes<-unique(edge1[,1])
+ for(i in 1:length(nodes)) lines(H1[which(edge1[,1]==nodes[i]),1],Y1[which(edge1[,1]==nodes[i]),1],lwd=lwd)
+ for(i in 1:nrow(edge1)) if(edge1[i,1]%in%edge2[,1]) lines(c(H1[i,1],H1[i,1]),c(Y1[i,1],1-b),lwd=lwd,lend=2)
+ tips<-edge1[edge1[,2]<=n,2]
+ for(i in 1:length(tips))
+ if(ftype) text(H1[which(edge1[,2]==tips[i]),2],Y1[which(edge1[,2]==tips[i]),1],cw$tip.label[tips[i]],pos=4,cex=fsize,font=ftype,offset=offset)
+ # second half
+ if(new.window){ dev.new(); par(mar=c(0.1,0.1,0.1,0.1)) }
+ plot.new()
+ if(max(Y1)>max(Y2)) Y2<-Y2+max(Y1)-max(Y2)
+ plot.window(xlim=c(0,max(H)+fsize*max(strwidth(cw$tip.label))),ylim=c(1,max(rbind(Y1,Y2)+b)))
+ for(i in 1:nrow(H2)) lines(H2[i,],Y2[i,],lwd=lwd,lend=2)
+ nodes<-unique(edge2[,1])
+ for(i in 1:length(nodes)) lines(H2[which(edge2[,1]==nodes[i]),1],Y2[which(edge2[,1]==nodes[i]),1],lwd=lwd)
+ for(i in 1:nrow(edge2)) if(edge2[i,1]%in%edge1[,1]) lines(c(H2[i,1],H2[i,1]),c(Y2[i,1],max(Y2)+b),lwd=lwd,lend=2)
+ tips<-edge2[edge2[,2]<=n,2]
+ for(i in 1:length(tips))
+ if(ftype) text(H2[which(edge2[,2]==tips[i]),2],Y2[which(edge2[,2]==tips[i]),1],cw$tip.label[tips[i]],pos=4,cex=fsize,font=ftype,offset=offset)
+ # reset margin and layout
+ layout(1)
+ par(mar=c(5,4,4,2)+0.1)
+}
diff --git a/R/strahlerNumber.R b/R/strahlerNumber.R
index c4d7ec6..bda7d87 100644
--- a/R/strahlerNumber.R
+++ b/R/strahlerNumber.R
@@ -1,49 +1,49 @@
-# function computes the Strahler number at each node
-# written by Liam J. Revell 2013, 2015
-
-strahlerNumber<-function(tree,plot=TRUE){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- pw<-reorder(tree,"pruningwise")
- oo<-sapply(tree$edge[,2],function(x,y) which(x==y),y=pw$edge[,2])
- SS<-matrix(0,nrow(pw$edge),2)
- SS[pw$edge[,2]<=length(pw$tip.label),2]<-1
- nn<-unique(pw$edge[,1])
- for(i in 1:pw$Nnode){
- jj<-which(pw$edge[,1]==nn[i])
- s<-sort(SS[jj,2],decreasing=TRUE)
- SS[jj,1]<-if(all(sapply(s[2:length(s)],"<",s[1]))) s[1] else s[1]+1
- SS[which(pw$edge[,2]==pw$edge[jj[1],1]),2]<-SS[jj[1],1]
- }
- ss<-setNames(c(SS[oo,][1,1],SS[oo,2]),c(tree$edge[1,1],tree$edge[,2]))
- ss<-ss[order(as.numeric(names(ss)))]
- names(ss)[1:length(tree$tip.label)]<-tree$tip.label
- if(plot){
- plotTree(tree)
- nodelabels(ss[1:tree$Nnode+length(tree$tip.label)])
- }
- return(ss)
-}
-
-# extracts all the most inclusive clades with Strahler number i from tree
-# written by Liam J. Revell 2013, 2015
-
-extract.strahlerNumber<-function(tree,i,plot=TRUE){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- sn<-strahlerNumber(tree)
- sn<-sn[sn==i]
- # get descendant tip numbers for all clades
- ll<-lapply(as.numeric(names(sn)),getDescendants,tree=tree)
- # figure out which ones are most inclusive
- ff<-function(x,y) !all(sapply(x,"%in%",y))
- GG<-sapply(ll,function(x,y) sapply(y,ff,x=x),y=ll)
- ii<-which(colSums(GG)==(ncol(GG)-1))
- # extract these clades
- trees<-lapply(as.numeric(names(sn))[ii],extract.clade,phy=tree)
- if(plot){
- nplots<-2*ceiling(length(trees)/2)
- layout(matrix(1:nplots,ceiling(nplots/2),min(c(length(trees),2)),byrow=TRUE))
- sNN<-lapply(trees,strahlerNumber,plot=TRUE)
- }
- if(length(trees)>1) class(trees)<-"multiPhylo" else trees<-trees[[1]]
- return(trees)
-}
+# function computes the Strahler number at each node
+# written by Liam J. Revell 2013, 2015
+
+strahlerNumber<-function(tree,plot=TRUE){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ pw<-reorder(tree,"pruningwise")
+ oo<-sapply(tree$edge[,2],function(x,y) which(x==y),y=pw$edge[,2])
+ SS<-matrix(0,nrow(pw$edge),2)
+ SS[pw$edge[,2]<=length(pw$tip.label),2]<-1
+ nn<-unique(pw$edge[,1])
+ for(i in 1:pw$Nnode){
+ jj<-which(pw$edge[,1]==nn[i])
+ s<-sort(SS[jj,2],decreasing=TRUE)
+ SS[jj,1]<-if(all(sapply(s[2:length(s)],"<",s[1]))) s[1] else s[1]+1
+ SS[which(pw$edge[,2]==pw$edge[jj[1],1]),2]<-SS[jj[1],1]
+ }
+ ss<-setNames(c(SS[oo,][1,1],SS[oo,2]),c(tree$edge[1,1],tree$edge[,2]))
+ ss<-ss[order(as.numeric(names(ss)))]
+ names(ss)[1:length(tree$tip.label)]<-tree$tip.label
+ if(plot){
+ plotTree(tree)
+ nodelabels(ss[1:tree$Nnode+length(tree$tip.label)])
+ }
+ return(ss)
+}
+
+# extracts all the most inclusive clades with Strahler number i from tree
+# written by Liam J. Revell 2013, 2015
+
+extract.strahlerNumber<-function(tree,i,plot=TRUE){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ sn<-strahlerNumber(tree)
+ sn<-sn[sn==i]
+ # get descendant tip numbers for all clades
+ ll<-lapply(as.numeric(names(sn)),getDescendants,tree=tree)
+ # figure out which ones are most inclusive
+ ff<-function(x,y) !all(sapply(x,"%in%",y))
+ GG<-sapply(ll,function(x,y) sapply(y,ff,x=x),y=ll)
+ ii<-which(colSums(GG)==(ncol(GG)-1))
+ # extract these clades
+ trees<-lapply(as.numeric(names(sn))[ii],extract.clade,phy=tree)
+ if(plot){
+ nplots<-2*ceiling(length(trees)/2)
+ layout(matrix(1:nplots,ceiling(nplots/2),min(c(length(trees),2)),byrow=TRUE))
+ sNN<-lapply(trees,strahlerNumber,plot=TRUE)
+ }
+ if(length(trees)>1) class(trees)<-"multiPhylo" else trees<-trees[[1]]
+ return(trees)
+}
diff --git a/R/threshBayes.R b/R/threshBayes.R
index 8db34b4..3c734aa 100644
--- a/R/threshBayes.R
+++ b/R/threshBayes.R
@@ -1,379 +1,379 @@
-## Function fits the threshold model for two characters using Bayesian MCMC.
-## All characters should be provided either in the form of a numeric matrix, X, or as
-## a data frame in which the discrete character is coded as a factor
-## Row names of X should match the species names of the tree.
-## types=c("discrete","discrete"), c("discrete","continuous"), c("cont","disc") etc. should
-## be used to indicate the data type of each column in X
-## written by Liam J. Revell 2012, 2014, 2017, 2018, 2020, 2021
-
-threshBayes<-function(tree,X,types=NULL,ngen=10000,control=list(),...){
-
- if(hasArg(burnin)) burnin<-list(...)$burnin
- else burnin<-round(0.2*ngen)
-
- if(hasArg(plot)) plot<-list(...)$plot
- else plot<-TRUE
-
- if(hasArg(auto.tune)) auto.tune<-list(...)$auto.tune
- else auto.tune<-TRUE
- if(is.logical(auto.tune)) if(auto.tune==TRUE) auto.tune<-0.234
- else if(is.numeric(auto.tune)) if(auto.tune>=1.0||auto.tune<=0.0){
- cat("value for auto.tune outside allowable range. Resetting....\n")
- auto.tune<-0.234
- }
-
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
-
- # likelihood function for the liabilities
- lik<-function(a,V,invV,detV,D,Y){
- y<-as.vector(Y)
- logL<--t(y-D%*%a)%*%invV%*%(y-D%*%a)/2-n*m*log(2*pi)/2-detV/2
- return(logL[1,1])
- }
-
- # function for the log-prior (presently returns 0, i.e. a flat prior)
- logPrior<-function(sig2,a,r,Yp){
- pp<-dexp(sig2[1],rate=1/con$pr.mean[1],log=T)+
- dexp(sig2[2],rate=1/con$pr.mean[2],log=T)+
- dnorm(a[1],mean=con$pr.mean[3],sd=sqrt(con$pr.var[3]),log=T)+
- dnorm(a[2],mean=con$pr.mean[4],sd=sqrt(con$pr.var[4]),log=T)+
- dunif(r,min=con$pr.mean[5]-0.5*sqrt(12*con$pr.var[5]),
- max=con$pr.mean[5]+0.5*sqrt(12*con$pr.var[5]),log=T)
- return(pp)
- }
-
- # function to crop the first 4 characters from a vector of strings
- crop<-function(x){
- for(i in 1:length(x)) x[i]<-paste(strsplit(x[i],"")[[1]][1:4],collapse="")
- return(x)
- }
-
- ## bookkeeping
- C<-vcv.phylo(tree)
- n<-nrow(X)
- m<-ncol(X)
- if(is.null(types)){
- types<-rep("cont",m)
- if(is.data.frame(X)){
- ii<-which(sapply(X,is.factor))
- if(length(ii)>0) types[ii]<-"disc"
- } else if(is.matrix(X)){
- ii<-which(apply(X,2,function(x) all(x%in%c(0,1))))
- if(length(ii)>0) types[ii]<-"disc"
- }
- }
- X<-X[tree$tip.label,]
- levels<-as.list(rep(NA,m))
- if(is.data.frame(X)){
- ii<-sapply(X,is.character)
- if(any(ii)) X[,ii]<-sapply(X[,ii],as.factor)
- ii<-sapply(X,is.factor)
- if(any(ii)){
- d<-which(ii)
- for(i in 1:length(d)) levels[[d[i]]]<-levels(X[,d[i]])
- X[,ii]<-sapply(X[,ii],as.numeric)-1
- }
- X<-as.matrix(X)
- } else {
- d<-which(crop(types)=="disc")
- if(length(d)>0) for(i in 1:length(d))
- levels[[d[i]]]<-as.character(0:1)
- }
-
- if(m!=2) stop("number of traits must equal 2")
- npar<-n*m+5 # or npar<-n*m+1
-
- # design matrix
- D<-matrix(0,n*m,m)
- for(i in 1:(n*m)) for(j in 1:m) if((j-1)*n<i&&i<=j*n) D[i,j]<-1
-
- # set starting values
- if(is.null(types)){
- Y<-matrix(-1,Ntip(tree),2,dimnames=list(rownames(X),NULL))
- Y[X==1]<-1 # for liability
- disc<-1:m
- cont<-vector()
- } else {
- Y<-X
- types<-crop(types)
- disc<-which(types=="disc")
- cont<-which(types=="cont")
- for(i in 1:length(disc)) Y[Y[,disc[i]]==0,disc[i]]<--1
- }
- Y[,disc]<-Y[,disc]*abs(rnorm(n=length(as.vector(Y[,disc])),
- sd=sqrt(max(nodeHeights(tree)))))
-
- npar<-npar-n*(m-length(disc))-length(disc)
- if(is.null(colnames(X))) colnames(Y)<-paste("V",1:m,sep="")
- else colnames(Y)<-colnames(X)
- r<-0 # for the correlation
- sig2<-colMeans(apply(Y,2,pic,phy=multi2di(tree,random=FALSE))^2)
- sig2[disc]<-1
- a<-colMeans(Y)
- a[disc]<-0
- R<-matrix(c(sig2[1],r*sqrt(sig2[1]*sig2[2]),r*sqrt(sig2[1]*sig2[2]),
- sig2[2]),2,2)
- V<-kronecker(R,C)
- invV<-solve(V)
- detV<-determinant(V)$modulus[1]
-
- # populate control list
- con=list(sample=100,
- propvar=c(0.3*sig2,0.3*sqrt(sig2),0.2),
- propliab=0.3,
- pr.mean=c(rep(1000,m),rep(0,m),0),
- pr.liab=0,
- pr.var=c(rep(1000,m)^2,rep(1000,m),4/12),
- pr.vliab=1000,
- quiet=FALSE,
- print.interval=1000)
- con[(namc<-names(control))]<-control
- con<-con[!sapply(con,is.null)]
-
- ## permit different proposal variances for each tip/trait
- if(length(con$propliab)!=(n*(m-length(cont)))) con$propliab<-rep(con$propliab,n*(m-length(cont)))
-
- # for updating
- P<-Pp<-matrix(NA,n,m)
- P[Y<0]<-0
- P[Y>0]<-1
- Vp<-V
- invVp<-invV
- detVp<-detV
-
- # for storing the posterior sample
- Z<-matrix(NA,ngen/con$sample+1,8,dimnames=list(NULL,c("gen","sig1","sig2",
- "a1","a2","r","logL","accept_rate")))
- Z[1,]<-c(0,sig2,a,r,lik1<-lik(a,V,invV,detV,D,Y),0)
- L<-matrix(NA,ngen/con$sample+1,m*Ntip(tree)+1,dimnames=list(NULL,c("gen",
- as.vector(apply(matrix(colnames(Y)),1,paste,".",tree$tip.label,sep="")))))
- L[1,]<-c(0,as.vector(Y))
-
- logL.trace<-r.trace<-rep(0,ngen)
- running.accept<-0
-
- ## maybe help with memory
- Yp<-Y
-
- # start MCMC
- cat("Starting MCMC....\n")
- flush.console()
- for(i in 1:ngen){
- if(i%%10000==1){
- ## reset acceptance rates
- accept.rate<-accept<-hit<-rep(0,npar)
- }
- d<-i%%npar
- if(ngen>=con$print.interval) if(i%%con$print.interval==0) if(!con$quiet){
- cat(paste("generation: ",i,"; mean acceptance rate: ",round(mean(accept.rate),2),"\n",sep=""))
- flush.console()
- }
- Yp[]<-Y
- sig2p<-sig2
- ap<-a
- rp<-r
- if(d<=length(Y[,disc])&&d>0){
- # update liabilities
- Yp[,disc][d]<-Y[,disc][d]+rnorm(n=1,sd=sqrt(con$propliab[d]))
- } else {
- key<-c("sig1","sig2","a1","a2","r")[c(cont,3,4,5)]
- key<-key[if(d>0) d-length(Y[,disc]) else length(key)]
- if(key=="sig1"){
- sig2p[1]<-sig2[1]+rnorm(n=1,sd=sqrt(con$propvar[1]))
- if(sig2p[1]<0) sig2p[1]=-sig2p[1]
- R<-matrix(c(sig2p[1],rp*sqrt(sig2p[1]*sig2p[2]),
- rp*sqrt(sig2p[1]*sig2p[2]),sig2p[2]),2,2)
- Vp<-kronecker(R,C)
- invVp<-solve(Vp)
- detVp<-determinant(Vp)$modulus[1]
- } else if(key=="sig2"){
- sig2p[2]<-sig2[2]+rnorm(n=1,sd=sqrt(con$propvar[2]))
- if(sig2p[2]<0) sig2p[2]=-sig2p[2]
- R<-matrix(c(sig2p[1],rp*sqrt(sig2p[1]*sig2p[2]),
- rp*sqrt(sig2p[1]*sig2p[2]),sig2p[2]),2,2)
- Vp<-kronecker(R,C)
- invVp<-solve(Vp)
- detVp<-determinant(Vp)$modulus[1]
- } else if(key=="a1") {
- ap[1]<-a[1]+rnorm(n=1,sd=sqrt(con$propvar[3]))
- } else if(key=="a2") {
- ap[2]<-a[2]+rnorm(n=1,sd=sqrt(con$propvar[4]))
- } else if(key=="r"){
- rp<-r+rnorm(n=1,sd=sqrt(con$propvar[5]))
- while(rp>1||rp< -1){
- if(rp>1) rp<-2-rp
- if(rp< -1) rp<--2-rp
- }
- R<-matrix(c(sig2p[1],rp*sqrt(sig2p[1]*sig2p[2]),
- rp*sqrt(sig2p[1]*sig2p[2]),sig2p[2]),2,2)
- Vp<-kronecker(R,C)
- invVp<-solve(Vp)
- detVp<-determinant(Vp)$modulus[1]
- }
- }
- Pp[Yp<0]<-0
- Pp[Yp>0]<-1
- lik2<-lik(ap,Vp,invVp,detVp,D,Yp)+log(all(Pp[,disc]==X[,disc]))
- p.odds<-min(c(1,exp(lik2+logPrior(sig2p,ap,rp,Yp)-lik1-
- logPrior(sig2,a,r,Yp))))
- hit[if(d>0) d else npar]<-hit[if(d>0) d else npar]+1
- if(p.odds>runif(n=1)){
- accept[if(d>0) d else npar]<-accept[if(d>0) d else npar]+1
- running.accept<-running.accept+1/con$sample
- Y[]<-Yp
- sig2<-sig2p
- a<-ap
- r<-rp
- V<-Vp
- invV<-invVp
- detV<-detVp
- logL<-lik2
- lik1<-lik2
- } else logL<-lik1
- accept.rate[if(d>0) d else npar]<-accept[if(d>0) d else npar]/hit[if(d>0) d else npar]
- if(is.numeric(auto.tune)){
- if(accept.rate[if(d>0) d else npar]>auto.tune){
- if(d>=1&&d<=(length(Y[,disc]))) con$propliab[d]<-1.1*con$propliab[d]
- else {
- ii<-which(c("sig1","sig2","a1","a2","r")==key)
- con$propvar[ii]<-1.1*con$propvar[ii]
- if(key=="r"&&con$propvar[ii]>1) con$propvar[ii]<-1
- }
- } else if(accept.rate[if(d>0) d else npar]<auto.tune){
- if(d>=1&&d<=(length(Y[,disc]))) con$propliab[d]<-con$propliab[d]/1.1
- else {
- ii<-which(c("sig1","sig2","a1","a2","r")==key)
- con$propvar[ii]<-con$propvar[ii]/1.1
- }
- }
- }
- logL.trace[i]<-logL
- r.trace[i]<-r
- if(plot&&(i%%100==1)){
- dev.hold()
- par(mfrow=c(3,1))
- par(mar=c(5.1,4.1,2.1,1.1))
- plot(1:i,logL.trace[1:i],type="l",bty="l",col=make.transparent("grey",0.5),
- xlab="generation",ylab="log(L)",xlim=c(0,ngen))
- mtext("a) log-likelihood trace",side=3,line=0,cex=1,at=0,outer=FALSE,
- adj=0)
- par(mar=c(5.1,4.1,2.1,1.1))
- h<-barplot(accept.rate,ylim=c(0,1),col=make.transparent("blue",0.25),
- border=NA)
- if(is.numeric(auto.tune)) lines(range(h),rep(auto.tune,2),lty="dotted")
- mtext("b) acceptance rates (resets every 10,000 generations)",side=3,line=0,
- cex=1,at=0,outer=FALSE,adj=0)
- plot(1:i,r.trace[1:i],type="l",bty="l",col=make.transparent("blue",0.5),
- xlab="generation",ylab="r",xlim=c(0,ngen))
- mtext("c) trace of the correlation coefficient, r",side=3,line=0,cex=1,at=0,
- outer=FALSE,adj=0)
- lines(c(par()$usr[1],ngen),rep(mean(r.trace[1:i]),2),lty="dotted")
- dev.flush()
- }
- if(i%%con$sample==0){
- Z[i/con$sample+1,]<-c(i,sig2,a,r,logL,running.accept)
- L[i/con$sample+1,]<-c(i,Y[,1],Y[,2])
- running.accept<-0 ## reset running acceptance rate
- }
- }
- cat("Done MCMC.\n")
- obj<-list(par=as.data.frame(Z),liab=as.data.frame(L),
- burnin=burnin,levels=levels,types=types)
- attr(obj,"auto.tune")<-auto.tune
- class(obj)<-"threshBayes"
- obj
-}
-
-## S3 methods for the object class
-
-print.threshBayes<-function(x,...){
- cat("\nObject of class \"threshBayes\" consisting of a matrix (L) of\n")
- cat("sampled liabilities for the tips of the tree & a second matrix\n")
- cat("(par) with the sample model parameters & correlation.\n")
- cat(paste("\nMean correlation (r) from the posterior sample is: ",
- round(mean(x$par[,"r"]),5),".\n",sep=""))
- if(any(x$types=="disc")){
- cat("\nOrdination of discrete traits:\n\n")
- for(i in 1:length(x$types)){
- if(x$types[i]=="disc") cat(paste("\tTrait ",i,": ",x$levels[[i]][1]," <-> ",
- x$levels[[i]][2],"\n",sep=""))
- }
- }
- cat("\n")
-}
-
-plot.density.threshBayes<-function(x,...){
- d<-x$density
- r<-x$mean.r
- if(hasArg(xlim)) xlim<-list(...)$xlim
- else xlim<-c(-1,1)
- if(hasArg(ylim)) ylim<-list(...)$ylim
- else ylim<-c(0,1.2*max(d$y))
- if(hasArg(bty)) bty<-list(...)$bty
- else bty<-"n"
- if(hasArg(cex.lab)) cex.lab<-list(...)$cex.lab
- else cex.lab<-1
- if(hasArg(cex.axis)) cex.axis<-list(...)$cex.axis
- else cex.axis<-1
- plot(d,xlim=xlim,ylim=ylim,col="blue",xlab="Posterior sample of r",
- ylab="Density",main="",bty=bty,cex.lab=cex.lab,cex.axis=cex.axis)
- polygon(x=c(min(d$x),d$x,max(d$x)),y=c(0,d$y,0),
- col=make.transparent("blue",0.2))
- lines(rep(r,2),c(0,max(d$y)),col="blue",lty="dashed",
- lwd=2)
- text(r,max(d$y),"mean post-burnin\nvalue of r",cex=0.7,
- pos=if(r>0) 2 else 4,font=3)
-}
-
-density.threshBayes<-function(x,...){
- if(hasArg(burnin)) burnin<-list(...)$burnin
- else burnin<-x$burnin
- if(hasArg(bw)) bw<-list(...)$bw
- else bw<-0.05
- ii<-which(((x$par$gen-burnin)^2)==min((x$par$gen-burnin)^2))[1]+1
- d<-density(x$par$r[ii:nrow(x$par)],bw=bw)
- r<-mean(x$par$r[ii:nrow(x$par)])
- d$data.name<-deparse(substitute(x))
- d$call<-paste("density.threshBayes(x =",d$data.name," bw = bw)")
- d$bw<-bw
- object<-list(density=d,mean.r=r)
- class(object)<-"density.threshBayes"
- object
-}
-
-print.density.threshBayes<-function(x,...){
- print(x$density)
- cat("\n")
- cat("To plot enter plot(\'object_name\') at the command line interface.\n\n")
-}
-
-plot.threshBayes<-function(x,...){
- if(hasArg(bw)) bw<-list(...)$bw
- else bw<-floor(length(x$par$gen)/100)
- if(hasArg(bty)) bty<-list(...)$bty
- else bty<-"n"
- if(hasArg(las)) las<-list(...)$las
- else las<-1
- if(hasArg(cex.main)) cex.main<-list(...)$cex.main
- else cex.main<-1
- par(mfrow=c(3,1))
- par(mar=c(5.1,4.1,2.1,1.1))
- plot(x$par$gen,x$par$logL,type="l",bty=bty,col=make.transparent("grey",0.5),
- xlab="generation",ylab="log(L)",las=las)
- mtext("a) log-likelihood trace",side=3,line=0.5,cex=cex.main,at=0,
- outer=FALSE,adj=0)
- par(mar=c(5.1,4.1,2.1,1.1))
- accept<-vector()
- for(i in 1:length(x$par$gen))
- accept[i]<-mean(x$par$accept_rate[max(c(1,i-bw)):i])
- plot(x$par$gen,accept,type="l",bty=bty,col=make.transparent("red",0.5),
- xlab="generation",ylab="mean acceptance rate",las=las)
- if(is.numeric(attr(x,"auto.tune"))) lines(c(par()$usr[1],max(x$par$gen)),
- rep(attr(x,"auto.tune"),2),lty="dotted")
- mtext(paste("b) mean acceptance rate (sliding window: bw=",bw,")",sep=""),
- side=3,line=0.5,cex=cex.main,at=0,outer=FALSE,adj=0)
- plot(x$par$gen,x$par$r,type="l",bty=bty,col=make.transparent("blue",0.5),
- xlab="generation",ylab="r",las=las)
- mtext("c) trace of the correlation coefficient, r",side=3,line=0.5,
- cex=cex.main,at=0,outer=FALSE,adj=0)
-}
+## Function fits the threshold model for two characters using Bayesian MCMC.
+## All characters should be provided either in the form of a numeric matrix, X, or as
+## a data frame in which the discrete character is coded as a factor
+## Row names of X should match the species names of the tree.
+## types=c("discrete","discrete"), c("discrete","continuous"), c("cont","disc") etc. should
+## be used to indicate the data type of each column in X
+## written by Liam J. Revell 2012, 2014, 2017, 2018, 2020, 2021
+
+threshBayes<-function(tree,X,types=NULL,ngen=10000,control=list(),...){
+
+ if(hasArg(burnin)) burnin<-list(...)$burnin
+ else burnin<-round(0.2*ngen)
+
+ if(hasArg(plot)) plot<-list(...)$plot
+ else plot<-TRUE
+
+ if(hasArg(auto.tune)) auto.tune<-list(...)$auto.tune
+ else auto.tune<-TRUE
+ if(is.logical(auto.tune)) if(auto.tune==TRUE) auto.tune<-0.234
+ else if(is.numeric(auto.tune)) if(auto.tune>=1.0||auto.tune<=0.0){
+ cat("value for auto.tune outside allowable range. Resetting....\n")
+ auto.tune<-0.234
+ }
+
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+
+ # likelihood function for the liabilities
+ lik<-function(a,V,invV,detV,D,Y){
+ y<-as.vector(Y)
+ logL<--t(y-D%*%a)%*%invV%*%(y-D%*%a)/2-n*m*log(2*pi)/2-detV/2
+ return(logL[1,1])
+ }
+
+ # function for the log-prior (presently returns 0, i.e. a flat prior)
+ logPrior<-function(sig2,a,r,Yp){
+ pp<-dexp(sig2[1],rate=1/con$pr.mean[1],log=T)+
+ dexp(sig2[2],rate=1/con$pr.mean[2],log=T)+
+ dnorm(a[1],mean=con$pr.mean[3],sd=sqrt(con$pr.var[3]),log=T)+
+ dnorm(a[2],mean=con$pr.mean[4],sd=sqrt(con$pr.var[4]),log=T)+
+ dunif(r,min=con$pr.mean[5]-0.5*sqrt(12*con$pr.var[5]),
+ max=con$pr.mean[5]+0.5*sqrt(12*con$pr.var[5]),log=T)
+ return(pp)
+ }
+
+ # function to crop the first 4 characters from a vector of strings
+ crop<-function(x){
+ for(i in 1:length(x)) x[i]<-paste(strsplit(x[i],"")[[1]][1:4],collapse="")
+ return(x)
+ }
+
+ ## bookkeeping
+ C<-vcv.phylo(tree)
+ n<-nrow(X)
+ m<-ncol(X)
+ if(is.null(types)){
+ types<-rep("cont",m)
+ if(is.data.frame(X)){
+ ii<-which(sapply(X,is.factor))
+ if(length(ii)>0) types[ii]<-"disc"
+ } else if(is.matrix(X)){
+ ii<-which(apply(X,2,function(x) all(x%in%c(0,1))))
+ if(length(ii)>0) types[ii]<-"disc"
+ }
+ }
+ X<-X[tree$tip.label,]
+ levels<-as.list(rep(NA,m))
+ if(is.data.frame(X)){
+ ii<-sapply(X,is.character)
+ if(any(ii)) X[,ii]<-sapply(X[,ii],as.factor)
+ ii<-sapply(X,is.factor)
+ if(any(ii)){
+ d<-which(ii)
+ for(i in 1:length(d)) levels[[d[i]]]<-levels(X[,d[i]])
+ X[,ii]<-sapply(X[,ii],as.numeric)-1
+ }
+ X<-as.matrix(X)
+ } else {
+ d<-which(crop(types)=="disc")
+ if(length(d)>0) for(i in 1:length(d))
+ levels[[d[i]]]<-as.character(0:1)
+ }
+
+ if(m!=2) stop("number of traits must equal 2")
+ npar<-n*m+5 # or npar<-n*m+1
+
+ # design matrix
+ D<-matrix(0,n*m,m)
+ for(i in 1:(n*m)) for(j in 1:m) if((j-1)*n<i&&i<=j*n) D[i,j]<-1
+
+ # set starting values
+ if(is.null(types)){
+ Y<-matrix(-1,Ntip(tree),2,dimnames=list(rownames(X),NULL))
+ Y[X==1]<-1 # for liability
+ disc<-1:m
+ cont<-vector()
+ } else {
+ Y<-X
+ types<-crop(types)
+ disc<-which(types=="disc")
+ cont<-which(types=="cont")
+ for(i in 1:length(disc)) Y[Y[,disc[i]]==0,disc[i]]<--1
+ }
+ Y[,disc]<-Y[,disc]*abs(rnorm(n=length(as.vector(Y[,disc])),
+ sd=sqrt(max(nodeHeights(tree)))))
+
+ npar<-npar-n*(m-length(disc))-length(disc)
+ if(is.null(colnames(X))) colnames(Y)<-paste("V",1:m,sep="")
+ else colnames(Y)<-colnames(X)
+ r<-0 # for the correlation
+ sig2<-colMeans(apply(Y,2,pic,phy=multi2di(tree,random=FALSE))^2)
+ sig2[disc]<-1
+ a<-colMeans(Y)
+ a[disc]<-0
+ R<-matrix(c(sig2[1],r*sqrt(sig2[1]*sig2[2]),r*sqrt(sig2[1]*sig2[2]),
+ sig2[2]),2,2)
+ V<-kronecker(R,C)
+ invV<-solve(V)
+ detV<-determinant(V)$modulus[1]
+
+ # populate control list
+ con=list(sample=100,
+ propvar=c(0.3*sig2,0.3*sqrt(sig2),0.2),
+ propliab=0.3,
+ pr.mean=c(rep(1000,m),rep(0,m),0),
+ pr.liab=0,
+ pr.var=c(rep(1000,m)^2,rep(1000,m),4/12),
+ pr.vliab=1000,
+ quiet=FALSE,
+ print.interval=1000)
+ con[(namc<-names(control))]<-control
+ con<-con[!sapply(con,is.null)]
+
+ ## permit different proposal variances for each tip/trait
+ if(length(con$propliab)!=(n*(m-length(cont)))) con$propliab<-rep(con$propliab,n*(m-length(cont)))
+
+ # for updating
+ P<-Pp<-matrix(NA,n,m)
+ P[Y<0]<-0
+ P[Y>0]<-1
+ Vp<-V
+ invVp<-invV
+ detVp<-detV
+
+ # for storing the posterior sample
+ Z<-matrix(NA,ngen/con$sample+1,8,dimnames=list(NULL,c("gen","sig1","sig2",
+ "a1","a2","r","logL","accept_rate")))
+ Z[1,]<-c(0,sig2,a,r,lik1<-lik(a,V,invV,detV,D,Y),0)
+ L<-matrix(NA,ngen/con$sample+1,m*Ntip(tree)+1,dimnames=list(NULL,c("gen",
+ as.vector(apply(matrix(colnames(Y)),1,paste,".",tree$tip.label,sep="")))))
+ L[1,]<-c(0,as.vector(Y))
+
+ logL.trace<-r.trace<-rep(0,ngen)
+ running.accept<-0
+
+ ## maybe help with memory
+ Yp<-Y
+
+ # start MCMC
+ cat("Starting MCMC....\n")
+ flush.console()
+ for(i in 1:ngen){
+ if(i%%10000==1){
+ ## reset acceptance rates
+ accept.rate<-accept<-hit<-rep(0,npar)
+ }
+ d<-i%%npar
+ if(ngen>=con$print.interval) if(i%%con$print.interval==0) if(!con$quiet){
+ cat(paste("generation: ",i,"; mean acceptance rate: ",round(mean(accept.rate),2),"\n",sep=""))
+ flush.console()
+ }
+ Yp[]<-Y
+ sig2p<-sig2
+ ap<-a
+ rp<-r
+ if(d<=length(Y[,disc])&&d>0){
+ # update liabilities
+ Yp[,disc][d]<-Y[,disc][d]+rnorm(n=1,sd=sqrt(con$propliab[d]))
+ } else {
+ key<-c("sig1","sig2","a1","a2","r")[c(cont,3,4,5)]
+ key<-key[if(d>0) d-length(Y[,disc]) else length(key)]
+ if(key=="sig1"){
+ sig2p[1]<-sig2[1]+rnorm(n=1,sd=sqrt(con$propvar[1]))
+ if(sig2p[1]<0) sig2p[1]=-sig2p[1]
+ R<-matrix(c(sig2p[1],rp*sqrt(sig2p[1]*sig2p[2]),
+ rp*sqrt(sig2p[1]*sig2p[2]),sig2p[2]),2,2)
+ Vp<-kronecker(R,C)
+ invVp<-solve(Vp)
+ detVp<-determinant(Vp)$modulus[1]
+ } else if(key=="sig2"){
+ sig2p[2]<-sig2[2]+rnorm(n=1,sd=sqrt(con$propvar[2]))
+ if(sig2p[2]<0) sig2p[2]=-sig2p[2]
+ R<-matrix(c(sig2p[1],rp*sqrt(sig2p[1]*sig2p[2]),
+ rp*sqrt(sig2p[1]*sig2p[2]),sig2p[2]),2,2)
+ Vp<-kronecker(R,C)
+ invVp<-solve(Vp)
+ detVp<-determinant(Vp)$modulus[1]
+ } else if(key=="a1") {
+ ap[1]<-a[1]+rnorm(n=1,sd=sqrt(con$propvar[3]))
+ } else if(key=="a2") {
+ ap[2]<-a[2]+rnorm(n=1,sd=sqrt(con$propvar[4]))
+ } else if(key=="r"){
+ rp<-r+rnorm(n=1,sd=sqrt(con$propvar[5]))
+ while(rp>1||rp< -1){
+ if(rp>1) rp<-2-rp
+ if(rp< -1) rp<--2-rp
+ }
+ R<-matrix(c(sig2p[1],rp*sqrt(sig2p[1]*sig2p[2]),
+ rp*sqrt(sig2p[1]*sig2p[2]),sig2p[2]),2,2)
+ Vp<-kronecker(R,C)
+ invVp<-solve(Vp)
+ detVp<-determinant(Vp)$modulus[1]
+ }
+ }
+ Pp[Yp<0]<-0
+ Pp[Yp>0]<-1
+ lik2<-lik(ap,Vp,invVp,detVp,D,Yp)+log(all(Pp[,disc]==X[,disc]))
+ p.odds<-min(c(1,exp(lik2+logPrior(sig2p,ap,rp,Yp)-lik1-
+ logPrior(sig2,a,r,Yp))))
+ hit[if(d>0) d else npar]<-hit[if(d>0) d else npar]+1
+ if(p.odds>runif(n=1)){
+ accept[if(d>0) d else npar]<-accept[if(d>0) d else npar]+1
+ running.accept<-running.accept+1/con$sample
+ Y[]<-Yp
+ sig2<-sig2p
+ a<-ap
+ r<-rp
+ V<-Vp
+ invV<-invVp
+ detV<-detVp
+ logL<-lik2
+ lik1<-lik2
+ } else logL<-lik1
+ accept.rate[if(d>0) d else npar]<-accept[if(d>0) d else npar]/hit[if(d>0) d else npar]
+ if(is.numeric(auto.tune)){
+ if(accept.rate[if(d>0) d else npar]>auto.tune){
+ if(d>=1&&d<=(length(Y[,disc]))) con$propliab[d]<-1.1*con$propliab[d]
+ else {
+ ii<-which(c("sig1","sig2","a1","a2","r")==key)
+ con$propvar[ii]<-1.1*con$propvar[ii]
+ if(key=="r"&&con$propvar[ii]>1) con$propvar[ii]<-1
+ }
+ } else if(accept.rate[if(d>0) d else npar]<auto.tune){
+ if(d>=1&&d<=(length(Y[,disc]))) con$propliab[d]<-con$propliab[d]/1.1
+ else {
+ ii<-which(c("sig1","sig2","a1","a2","r")==key)
+ con$propvar[ii]<-con$propvar[ii]/1.1
+ }
+ }
+ }
+ logL.trace[i]<-logL
+ r.trace[i]<-r
+ if(plot&&(i%%100==1)){
+ dev.hold()
+ par(mfrow=c(3,1))
+ par(mar=c(5.1,4.1,2.1,1.1))
+ plot(1:i,logL.trace[1:i],type="l",bty="l",col=make.transparent("grey",0.5),
+ xlab="generation",ylab="log(L)",xlim=c(0,ngen))
+ mtext("a) log-likelihood trace",side=3,line=0,cex=1,at=0,outer=FALSE,
+ adj=0)
+ par(mar=c(5.1,4.1,2.1,1.1))
+ h<-barplot(accept.rate,ylim=c(0,1),col=make.transparent("blue",0.25),
+ border=NA)
+ if(is.numeric(auto.tune)) lines(range(h),rep(auto.tune,2),lty="dotted")
+ mtext("b) acceptance rates (resets every 10,000 generations)",side=3,line=0,
+ cex=1,at=0,outer=FALSE,adj=0)
+ plot(1:i,r.trace[1:i],type="l",bty="l",col=make.transparent("blue",0.5),
+ xlab="generation",ylab="r",xlim=c(0,ngen))
+ mtext("c) trace of the correlation coefficient, r",side=3,line=0,cex=1,at=0,
+ outer=FALSE,adj=0)
+ lines(c(par()$usr[1],ngen),rep(mean(r.trace[1:i]),2),lty="dotted")
+ dev.flush()
+ }
+ if(i%%con$sample==0){
+ Z[i/con$sample+1,]<-c(i,sig2,a,r,logL,running.accept)
+ L[i/con$sample+1,]<-c(i,Y[,1],Y[,2])
+ running.accept<-0 ## reset running acceptance rate
+ }
+ }
+ cat("Done MCMC.\n")
+ obj<-list(par=as.data.frame(Z),liab=as.data.frame(L),
+ burnin=burnin,levels=levels,types=types)
+ attr(obj,"auto.tune")<-auto.tune
+ class(obj)<-"threshBayes"
+ obj
+}
+
+## S3 methods for the object class
+
+print.threshBayes<-function(x,...){
+ cat("\nObject of class \"threshBayes\" consisting of a matrix (L) of\n")
+ cat("sampled liabilities for the tips of the tree & a second matrix\n")
+ cat("(par) with the sample model parameters & correlation.\n")
+ cat(paste("\nMean correlation (r) from the posterior sample is: ",
+ round(mean(x$par[,"r"]),5),".\n",sep=""))
+ if(any(x$types=="disc")){
+ cat("\nOrdination of discrete traits:\n\n")
+ for(i in 1:length(x$types)){
+ if(x$types[i]=="disc") cat(paste("\tTrait ",i,": ",x$levels[[i]][1]," <-> ",
+ x$levels[[i]][2],"\n",sep=""))
+ }
+ }
+ cat("\n")
+}
+
+plot.density.threshBayes<-function(x,...){
+ d<-x$density
+ r<-x$mean.r
+ if(hasArg(xlim)) xlim<-list(...)$xlim
+ else xlim<-c(-1,1)
+ if(hasArg(ylim)) ylim<-list(...)$ylim
+ else ylim<-c(0,1.2*max(d$y))
+ if(hasArg(bty)) bty<-list(...)$bty
+ else bty<-"n"
+ if(hasArg(cex.lab)) cex.lab<-list(...)$cex.lab
+ else cex.lab<-1
+ if(hasArg(cex.axis)) cex.axis<-list(...)$cex.axis
+ else cex.axis<-1
+ plot(d,xlim=xlim,ylim=ylim,col="blue",xlab="Posterior sample of r",
+ ylab="Density",main="",bty=bty,cex.lab=cex.lab,cex.axis=cex.axis)
+ polygon(x=c(min(d$x),d$x,max(d$x)),y=c(0,d$y,0),
+ col=make.transparent("blue",0.2))
+ lines(rep(r,2),c(0,max(d$y)),col="blue",lty="dashed",
+ lwd=2)
+ text(r,max(d$y),"mean post-burnin\nvalue of r",cex=0.7,
+ pos=if(r>0) 2 else 4,font=3)
+}
+
+density.threshBayes<-function(x,...){
+ if(hasArg(burnin)) burnin<-list(...)$burnin
+ else burnin<-x$burnin
+ if(hasArg(bw)) bw<-list(...)$bw
+ else bw<-0.05
+ ii<-which(((x$par$gen-burnin)^2)==min((x$par$gen-burnin)^2))[1]+1
+ d<-density(x$par$r[ii:nrow(x$par)],bw=bw)
+ r<-mean(x$par$r[ii:nrow(x$par)])
+ d$data.name<-deparse(substitute(x))
+ d$call<-paste("density.threshBayes(x =",d$data.name," bw = bw)")
+ d$bw<-bw
+ object<-list(density=d,mean.r=r)
+ class(object)<-"density.threshBayes"
+ object
+}
+
+print.density.threshBayes<-function(x,...){
+ print(x$density)
+ cat("\n")
+ cat("To plot enter plot(\'object_name\') at the command line interface.\n\n")
+}
+
+plot.threshBayes<-function(x,...){
+ if(hasArg(bw)) bw<-list(...)$bw
+ else bw<-floor(length(x$par$gen)/100)
+ if(hasArg(bty)) bty<-list(...)$bty
+ else bty<-"n"
+ if(hasArg(las)) las<-list(...)$las
+ else las<-1
+ if(hasArg(cex.main)) cex.main<-list(...)$cex.main
+ else cex.main<-1
+ par(mfrow=c(3,1))
+ par(mar=c(5.1,4.1,2.1,1.1))
+ plot(x$par$gen,x$par$logL,type="l",bty=bty,col=make.transparent("grey",0.5),
+ xlab="generation",ylab="log(L)",las=las)
+ mtext("a) log-likelihood trace",side=3,line=0.5,cex=cex.main,at=0,
+ outer=FALSE,adj=0)
+ par(mar=c(5.1,4.1,2.1,1.1))
+ accept<-vector()
+ for(i in 1:length(x$par$gen))
+ accept[i]<-mean(x$par$accept_rate[max(c(1,i-bw)):i])
+ plot(x$par$gen,accept,type="l",bty=bty,col=make.transparent("red",0.5),
+ xlab="generation",ylab="mean acceptance rate",las=las)
+ if(is.numeric(attr(x,"auto.tune"))) lines(c(par()$usr[1],max(x$par$gen)),
+ rep(attr(x,"auto.tune"),2),lty="dotted")
+ mtext(paste("b) mean acceptance rate (sliding window: bw=",bw,")",sep=""),
+ side=3,line=0.5,cex=cex.main,at=0,outer=FALSE,adj=0)
+ plot(x$par$gen,x$par$r,type="l",bty=bty,col=make.transparent("blue",0.5),
+ xlab="generation",ylab="r",las=las)
+ mtext("c) trace of the correlation coefficient, r",side=3,line=0.5,
+ cex=cex.main,at=0,outer=FALSE,adj=0)
+}
diff --git a/R/tree.grow.R b/R/tree.grow.R
index 48172db..675e068 100644
--- a/R/tree.grow.R
+++ b/R/tree.grow.R
@@ -1,46 +1,46 @@
-## function to 'grow' a birth-death tree from left-to-right or from upwards
-## written by Liam J. Revell 2019
-
-tree.grow<-function(...,res=200,direction="rightwards",ladderize=TRUE){
- tree<-if(ladderize) ladderize(pbtree(...),FALSE) else pbtree(...)
- h<-max(nodeHeights(tree))
- for(i in 1:res){
- dev.hold()
- if(direction=="upwards"){
- if(i<res){
- tt<-make.era.map(tree,c(0,i*h/res))
- plot(tt,colors=setNames(c('blue','transparent'),1:2),
- ftype="off",lwd=2,direction="downwards",
- ylim=c(h,0),mar=c(1.1,4.1,1.1,1.1))
- } else {
- tt<-paintSubTree(tree,Ntip(tree)+1,"1","2")
- tt$mapped.edge<-cbind(tt$mapped.edge,
- rep(0,nrow(tt$mapped.edge)))
- plot(tt,colors=setNames('blue',1),
- ftype="off",lwd=2,direction="downwards",
- ylim=c(h,0),mar=c(1.1,4.1,1.1,1.1))
- }
- axis(2)
- title(ylab="time before present")
- } else {
- if(i<res){
- tt<-make.era.map(tree,c(0,i*h/res))
- plot(tt,colors=setNames(c('blue','transparent'),1:2),
- ftype="off",lwd=2,direction="leftwards",
- xlim=c(h,0),mar=c(4.1,1.1,1.1,1.1))
- } else {
- tt<-paintSubTree(tree,Ntip(tree)+1,"1","2")
- tt$mapped.edge<-cbind(tt$mapped.edge,
- rep(0,nrow(tt$mapped.edge)))
- plot(tt,colors=setNames('blue',1),
- ftype="off",lwd=2,direction="leftwards",
- xlim=c(h,0),mar=c(4.1,1.1,1.1,1.1))
- }
- axis(1)
- title(xlab="time before present")
- }
- dev.flush()
- Sys.sleep(1/res)
- }
- invisible(tree)
-}
+## function to 'grow' a birth-death tree from left-to-right or from upwards
+## written by Liam J. Revell 2019
+
+tree.grow<-function(...,res=200,direction="rightwards",ladderize=TRUE){
+ tree<-if(ladderize) ladderize(pbtree(...),FALSE) else pbtree(...)
+ h<-max(nodeHeights(tree))
+ for(i in 1:res){
+ dev.hold()
+ if(direction=="upwards"){
+ if(i<res){
+ tt<-make.era.map(tree,c(0,i*h/res))
+ plot(tt,colors=setNames(c('blue','transparent'),1:2),
+ ftype="off",lwd=2,direction="downwards",
+ ylim=c(h,0),mar=c(1.1,4.1,1.1,1.1))
+ } else {
+ tt<-paintSubTree(tree,Ntip(tree)+1,"1","2")
+ tt$mapped.edge<-cbind(tt$mapped.edge,
+ rep(0,nrow(tt$mapped.edge)))
+ plot(tt,colors=setNames('blue',1),
+ ftype="off",lwd=2,direction="downwards",
+ ylim=c(h,0),mar=c(1.1,4.1,1.1,1.1))
+ }
+ axis(2)
+ title(ylab="time before present")
+ } else {
+ if(i<res){
+ tt<-make.era.map(tree,c(0,i*h/res))
+ plot(tt,colors=setNames(c('blue','transparent'),1:2),
+ ftype="off",lwd=2,direction="leftwards",
+ xlim=c(h,0),mar=c(4.1,1.1,1.1,1.1))
+ } else {
+ tt<-paintSubTree(tree,Ntip(tree)+1,"1","2")
+ tt$mapped.edge<-cbind(tt$mapped.edge,
+ rep(0,nrow(tt$mapped.edge)))
+ plot(tt,colors=setNames('blue',1),
+ ftype="off",lwd=2,direction="leftwards",
+ xlim=c(h,0),mar=c(4.1,1.1,1.1,1.1))
+ }
+ axis(1)
+ title(xlab="time before present")
+ }
+ dev.flush()
+ Sys.sleep(1/res)
+ }
+ invisible(tree)
+}
diff --git a/R/treeSlice.R b/R/treeSlice.R
index 1b1aee5..47ef4f9 100644
--- a/R/treeSlice.R
+++ b/R/treeSlice.R
@@ -1,93 +1,93 @@
-## function slices a tree at slice and returns all subtrees
-## it uses extract.clade(), if trivial==FALSE subtrees with length than 2 taxa are ignored
-## for orientation="rootwards" it will return the tree rootward of the slice point
-## written by Liam J. Revell 2011, 2012, 2015, 2017
-
-treeSlice<-function(tree,slice=NULL,trivial=FALSE,prompt=FALSE,...){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- if(hasArg(orientation)) orientation<-list(...)$orientation
- else orientation<-"tipwards"
- if(prompt){
- cat("Inside prompt.\n")
- plotTree(tree,mar=c(3.1,rep(0.1,3)),...)
- axis(1)
- cat("Click at the tree height where cutting is desired...\n")
- flush.console()
- xy<-unlist(locator(1))
- slice<-xy[1]
- cat(paste("Slice height is ",signif(slice,6),". Thank you!\n",sep=""))
- flush.console()
- lines(rep(slice,2),par()$usr[3:4],lty="dashed")
- obj<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- X<-cbind(obj$xx[obj$edge[,1]],obj$xx[obj$edge[,2]])
- y<-obj$yy[obj$edge[,2]]
- if(trivial){
- for(i in 1:nrow(X)) if(X[i,1]<slice&&X[i,2]>slice)
- points(slice,y[i],pch=19)
- } else {
- for(i in 1:nrow(X))
- if(X[i,1]<slice&&X[i,2]>slice&&obj$edge[i,2]>Ntip(tree))
- points(slice,y[i],pch=19)
- }
- }
- tree<-reorder(tree) # reorder cladewise
- H<-nodeHeights(tree)
- edges<-which(H[,2]>slice&H[,1]<slice)
- nodes<-tree$edge[edges,2]
- if(orientation=="tipwards"){
- if(!trivial) nodes<-nodes[nodes>length(tree$tip)]
- trees<-list()
- class(trees)<-"multiPhylo"
- for(i in 1:length(nodes)){
- if(nodes[i]>Ntip(tree)){
- trees[[i]]<-extract.clade(tree,node=nodes[i])
- trees[[i]]$root.edge<-H[which(tree$edge[,2]==nodes[i]),2]-slice
- } else {
- z<-list(edge=matrix(c(2,1),1,2),
- edge.length=H[which(tree$edge[,2]==nodes[i]),2]-slice,
- tip.label=tree$tip.label[nodes[i]],Nnode=1L)
- class(z)<-"phylo"
- trees[[i]]<-z
- }
- }
- return(trees)
- } else if(orientation=="rootwards"){
- obj<-tree
- obj$node.label<-1:obj$Nnode+Ntip(obj)
- if(any(nodes<=Ntip(obj))){
- tips<-nodes[nodes<=Ntip(obj)]
- tips<-obj$tip.label[tips]
- nodes<-nodes[nodes>Ntip(obj)]
- } else tips<-NULL
- if(length(nodes)>0){
- for(i in 1:length(nodes)){
- nn<-which(obj$node.label==nodes[i])+Ntip(obj)
- parent<-getParent(obj,nn)
- bp<-slice-nodeheight(obj,parent)
- obj<-splitTree(obj,list(node=nn,bp=bp))[[1]]
- obj$tip.label[obj$tip.label=="NA"]<-nodes[i]
- }
- }
- if(!is.null(tips[1])){
- for(i in 1:length(tips)){
- nn<-which(obj$tip.label==tips[i])
- parent<-getParent(obj,nn)
- obj$edge.length[which(obj$edge[,2]==nn)]<-slice-nodeheight(obj,parent)
- }
- }
- return(obj)
- }
-}
-
-
-## function returns the parent of node or NULL if node is the root
-getParent<-function(tree,node){
- ind<-which(tree$edge[,2]==node)
- if(length(ind)>0) pp<-tree$edge[which(tree$edge[,2]==node),1]
- else {
- pp<-NULL
- cat("node is the root. returning NULL\n")
- }
- pp
-}
+## function slices a tree at slice and returns all subtrees
+## it uses extract.clade(), if trivial==FALSE subtrees with length than 2 taxa are ignored
+## for orientation="rootwards" it will return the tree rootward of the slice point
+## written by Liam J. Revell 2011, 2012, 2015, 2017
+
+treeSlice<-function(tree,slice=NULL,trivial=FALSE,prompt=FALSE,...){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ if(hasArg(orientation)) orientation<-list(...)$orientation
+ else orientation<-"tipwards"
+ if(prompt){
+ cat("Inside prompt.\n")
+ plotTree(tree,mar=c(3.1,rep(0.1,3)),...)
+ axis(1)
+ cat("Click at the tree height where cutting is desired...\n")
+ flush.console()
+ xy<-unlist(locator(1))
+ slice<-xy[1]
+ cat(paste("Slice height is ",signif(slice,6),". Thank you!\n",sep=""))
+ flush.console()
+ lines(rep(slice,2),par()$usr[3:4],lty="dashed")
+ obj<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ X<-cbind(obj$xx[obj$edge[,1]],obj$xx[obj$edge[,2]])
+ y<-obj$yy[obj$edge[,2]]
+ if(trivial){
+ for(i in 1:nrow(X)) if(X[i,1]<slice&&X[i,2]>slice)
+ points(slice,y[i],pch=19)
+ } else {
+ for(i in 1:nrow(X))
+ if(X[i,1]<slice&&X[i,2]>slice&&obj$edge[i,2]>Ntip(tree))
+ points(slice,y[i],pch=19)
+ }
+ }
+ tree<-reorder(tree) # reorder cladewise
+ H<-nodeHeights(tree)
+ edges<-which(H[,2]>slice&H[,1]<slice)
+ nodes<-tree$edge[edges,2]
+ if(orientation=="tipwards"){
+ if(!trivial) nodes<-nodes[nodes>length(tree$tip)]
+ trees<-list()
+ class(trees)<-"multiPhylo"
+ for(i in 1:length(nodes)){
+ if(nodes[i]>Ntip(tree)){
+ trees[[i]]<-extract.clade(tree,node=nodes[i])
+ trees[[i]]$root.edge<-H[which(tree$edge[,2]==nodes[i]),2]-slice
+ } else {
+ z<-list(edge=matrix(c(2,1),1,2),
+ edge.length=H[which(tree$edge[,2]==nodes[i]),2]-slice,
+ tip.label=tree$tip.label[nodes[i]],Nnode=1L)
+ class(z)<-"phylo"
+ trees[[i]]<-z
+ }
+ }
+ return(trees)
+ } else if(orientation=="rootwards"){
+ obj<-tree
+ obj$node.label<-1:obj$Nnode+Ntip(obj)
+ if(any(nodes<=Ntip(obj))){
+ tips<-nodes[nodes<=Ntip(obj)]
+ tips<-obj$tip.label[tips]
+ nodes<-nodes[nodes>Ntip(obj)]
+ } else tips<-NULL
+ if(length(nodes)>0){
+ for(i in 1:length(nodes)){
+ nn<-which(obj$node.label==nodes[i])+Ntip(obj)
+ parent<-getParent(obj,nn)
+ bp<-slice-nodeheight(obj,parent)
+ obj<-splitTree(obj,list(node=nn,bp=bp))[[1]]
+ obj$tip.label[obj$tip.label=="NA"]<-nodes[i]
+ }
+ }
+ if(!is.null(tips[1])){
+ for(i in 1:length(tips)){
+ nn<-which(obj$tip.label==tips[i])
+ parent<-getParent(obj,nn)
+ obj$edge.length[which(obj$edge[,2]==nn)]<-slice-nodeheight(obj,parent)
+ }
+ }
+ return(obj)
+ }
+}
+
+
+## function returns the parent of node or NULL if node is the root
+getParent<-function(tree,node){
+ ind<-which(tree$edge[,2]==node)
+ if(length(ind)>0) pp<-tree$edge[which(tree$edge[,2]==node),1]
+ else {
+ pp<-NULL
+ cat("node is the root. returning NULL\n")
+ }
+ pp
+}
\ No newline at end of file
diff --git a/R/utilities.R b/R/utilities.R
index 0b6d829..0eef943 100644
--- a/R/utilities.R
+++ b/R/utilities.R
@@ -1,2198 +1,2198 @@
-## some utility functions
-## written by Liam J. Revell 2011, 2012, 2013, 2014, 2015, 2016, 2017,
-## 2018, 2019, 2020, 2021, 2022, 2023
-
-## function to rescale simmap style trees
-## written by Liam J. Revell 2012, 2013, 2014, 2015, 2017, 2023
-
-rescale<-function(x,...) UseMethod("rescale")
-
-rescale.default<-function(x, ...){
- warning(paste(
- "rescale does not know how to handle objects of class ",class(x),".\n",
- "if",class(x),"= \"phylo\" load geiger package to rescale.\n"))
-}
-
-rescale.simmap<-function(x, model="depth", ...) rescaleSimmap(x,...)
-
-rescale.multiSimmap<-function(x, model="depth", ...) rescaleSimmap(x,...)
-
-rescaleSimmap<-function(tree,...){
- if(inherits(tree,"multiSimmap")){
- cls<-class(tree)
- trees<-unclass(tree)
- trees<-lapply(trees,rescaleSimmap,...)
- class(trees)<-cls
- return(trees)
- } else if(inherits(tree,"simmap")){
- if(hasArg(lambda)) lambda<-list(...)$lambda
- else lambda<-1
- if(hasArg(totalDepth)) depth<-totalDepth<-list(...)$totalDepth
- else if(hasArg(depth)) depth<-totalDepth<-list(...)$depth
- else depth<-totalDepth<-max(nodeHeights(tree))
- if(lambda!=1){
- e<-lambdaTree(tree,lambda)$edge.length/tree$edge.length
- tree$edge.length<-tree$edge.length*e
- tree$maps<-mapply(function(x,y) x*y,tree$maps,e)
- tree$mapped.edge<-tree$mapped.edge*matrix(rep(e,ncol(tree$mapped.edge)),length(e),ncol(tree$mapped.edge))
- }
- if(depth!=max(nodeHeights(tree))){
- h<-max(nodeHeights(tree))
- s<-depth/h
- tree$edge.length<-tree$edge.length*s
- tree$maps<-lapply(tree$maps,"*",s)
- tree$mapped.edge<-tree$mapped.edge*s
- }
- return(tree)
- } else message("tree should be an object of class \"simmap\" or \"multiSimmap\"")
-}
-
-
-## function forces a tree to be ultrametric using two different methods
-## written by Liam J. Revell 2017, 2021, 2022
-
-force.ultrametric<-function(tree,method=c("nnls","extend"),...){
- if(hasArg(message)) message<-list(...)$message
- else message<-TRUE
- if(message){
- cat("***************************************************************\n")
- cat("* Note: *\n")
- cat("* force.ultrametric does not include a formal method to *\n")
- cat("* ultrametricize a tree & should only be used to coerce *\n")
- cat("* a phylogeny that fails is.ultramtric due to rounding -- *\n")
- cat("* not as a substitute for formal rate-smoothing methods. *\n")
- cat("***************************************************************\n")
- }
- method<-method[1]
- if(method=="nnls") tree<-nnls.tree(cophenetic(tree),tree,
- method="ultrametric",rooted=is.rooted(tree),trace=0)
- else if(method=="extend"){
- h<-diag(vcv(tree))
- d<-max(h)-h
- ii<-sapply(1:Ntip(tree),function(x,y) which(y==x),
- y=tree$edge[,2])
- tree$edge.length[ii]<-tree$edge.length[ii]+d
- } else
- cat("method not recognized: returning input tree\n\n")
- tree
-}
-
-## function to summarize the results of stochastic mapping
-## written by Liam J. Revell 2013, 2014, 2015, 2021, 2022
-describe.simmap<-function(tree,...){
- if(hasArg(plot)) plot<-list(...)$plot
- else plot<-FALSE
- if(hasArg(check.equal)) check.equal<-list(...)$check.equal
- else check.equal<-FALSE
- if(hasArg(message)) message<-list(...)$message
- else message<-FALSE
- if(hasArg(ref.tree)) ref.tree<-list(...)$ref.tree
- else ref.tree<-NULL
- if(inherits(tree,"multiPhylo")){
- if(check.equal){
- TT<-sapply(tree,function(x,y) sapply(y,all.equal.phylo,x),y=tree)
- check<-all(TT)
- if(!check) cat("Note: Some trees are not equal.\nA \"reference\" tree will be computed if none was provided.\n\n")
- } else check<-TRUE
- if(is.null(ref.tree)&&check){
- YY<-getStates(tree,"both")
- states<-sort(unique(as.vector(YY)))
- ZZ<-t(apply(YY,1,function(x,levels,Nsim) summary(factor(x,levels))/Nsim,
- levels=states,Nsim=length(tree)))
- } else {
- YY<-getStates(tree)
- states<-sort(unique(as.vector(YY)))
- if(is.null(ref.tree)){
- cat("No reference tree provided & some trees are unequal.\nComputing majority-rule consensus tree.\n")
- ref.tree<-consensus(tree,p=0.5)
- }
- YYp<-matrix(NA,ref.tree$Nnode,length(tree),dimnames=list(1:ref.tree$Nnode+Ntip(ref.tree),
- NULL))
- for(i in 1:length(tree)){
- M<-matchNodes(ref.tree,tree[[i]])
- jj<-sapply(M[,2],function(x,y) if(x%in%y) which(as.numeric(y)==x) else NA,
- y=as.numeric(rownames(YY)))
- YYp[,i]<-YY[jj,i]
- }
- ZZ<-t(apply(YYp,1,function(x,levels) summary(factor(x[!is.na(x)],
- levels))/sum(!is.na(x)),levels=states))
- }
- XX<-countSimmap(tree,states,FALSE)
- XX<-XX[,-(which(as.vector(diag(-1,length(states)))==-1)+1)]
- AA<-t(sapply(unclass(tree),function(x) c(colSums(x$mapped.edge),sum(x$edge.length))))
- colnames(AA)[ncol(AA)]<-"total"
- BB<-getStates(tree,type="tips")
- CC<-t(apply(BB,1,function(x,levels,Nsim) summary(factor(x,levels))/Nsim,levels=states,
- Nsim=length(tree)))
- x<-list(count=XX,times=AA,ace=ZZ,tips=CC,tree=tree,ref.tree=if(!is.null(ref.tree))
- ref.tree else NULL)
- class(x)<-"describe.simmap"
- } else if(inherits(tree,"phylo")){
- XX<-countSimmap(tree,message=FALSE)
- YY<-getStates(tree)
- states<-sort(unique(YY))
- AA<-setNames(c(colSums(tree$mapped.edge),sum(tree$edge.length)),
- c(colnames(tree$mapped.edge),"total"))
- AA<-rbind(AA,AA/AA[length(AA)]); rownames(AA)<-c("raw","prop")
- x<-list(N=XX$N,Tr=XX$Tr,times=AA,states=YY,tree=tree)
- class(x)<-"describe.simmap"
- }
- if(message) print(x)
- if(plot) plot(x)
- x
-}
-
-## function to get states at internal nodes from simmap style trees
-## written by Liam J. Revell 2013, 2014, 2015, 2021
-getStates<-function(tree,type=c("nodes","tips","both")){
- type<-type[1]
- if(inherits(tree,"multiPhylo")){
- tree<-unclass(tree)
- obj<-lapply(tree,getStates,type=type)
- nn<-names(obj[[1]])
- y<-sapply(obj,function(x,n) x[n],n=nn)
- } else if(inherits(tree,"phylo")){
- if(type%in%c("nodes","both")){
- a<-setNames(sapply(tree$maps,function(x) names(x)[1]),tree$edge[,1])
- a<-a[as.character(Ntip(tree)+1:tree$Nnode)]
- }
- if(type%in%c("tips","both")){
- b<-setNames(sapply(tree$maps,function(x) names(x)[length(x)]),tree$edge[,2])
- b<-setNames(b[as.character(1:Ntip(tree))],tree$tip.label)
- }
- y<-if(type=="both") c(a,b) else if(type=="nodes") a else b
- } else stop("tree should be an object of class \"phylo\" or \"multiPhylo\".")
- return(y)
-}
-
-## di2multi & multi2di for "contMap" & "densityMap" object classes
-
-di2multi.contMap<-function(phy,...){
- phy$tree<-di2multi(phy$tree,...)
- phy
-}
-
-di2multi.densityMap<-function(phy,...){
- phy$tree<-di2multi(phy$tree,...)
- phy
-}
-
-multi2di.contMap<-function(phy,...){
- phy$tree<-multi2di(phy$tree,...)
- phy
-}
-
-multi2di.densityMap<-function(phy,...){
- phy$tree<-multi2di(phy$tree,...)
- phy
-}
-
-## multi2di for "simmap" object class
-
-multi2di.simmap<-function(phy,...){
- obj<-multi2di(as.phylo(phy),...)
- M<-rbind(matchNodes(obj,phy),
- matchLabels(obj,phy))
- obj$maps<-vector(mode="list",length=nrow(obj$edge))
- for(i in 2:nrow(M)){
- if(!is.na(M[i,2])){
- obj$maps[[which(obj$edge[,2]==M[i,1])]]<-
- phy$maps[[which(phy$edge[,2]==M[i,2])]]
- } else {
- ii<-which(obj$edge[,2]==getParent(obj,M[i,1]))
- state<-names(obj$maps[[ii]])[length(obj$maps[[ii]])]
- obj$maps[[which(obj$edge[,2]==M[i,1])]]<-
- setNames(0,state)
- }
- }
- obj$node.states<-getStates(obj,"nodes")
- obj$states<-getStates(obj,"tips")
- obj$mapped.edge<-makeMappedEdge(obj$edge,obj$maps)
- class(obj)<-c("simmap",class(obj))
- obj
-}
-
-## di2multi & multi2di for "multiSimmap" object class
-
-di2multi.multiSimmap<-function(phy,...){
- obj<-lapply(phy,di2multi,...)
- class(obj)<-c("multiSimmap","multiPhylo")
- obj
-}
-multi2di.multiSimmap<-function(phy,...){
- obj<-lapply(phy,multi2di,...)
- class(obj)<-c("multiSimmap","multiPhylo")
- obj
-}
-
-## function to rescale a tree according to an EB model
-## written by Liam J. Revell 2017
-
-ebTree<-function(tree,r){
- if(r!=0){
- H<-nodeHeights(tree)
- e<-(exp(r*H[,2])-exp(r*H[,1]))/r
- tree$edge.length<-e
- }
- tree
-}
-
-## function to expand clades in a plot by a given factor
-## written by Liam J. Revell 2017
-expand.clade<-function(tree,node,factor=5){
- cw<-reorder(tree)
- tips<-setNames(rep(1,Ntip(tree)),cw$tip.label)
- get.tips<-function(node,tree){
- dd<-getDescendants(tree,node)
- tree$tip.label[dd[dd<=Ntip(tree)]]
- }
- desc<-unlist(lapply(node,get.tips,tree=cw))
- for(i in 2:Ntip(cw)){
- tips[i]<-tips[i-1]+
- if(names(tips)[i]%in%desc){
- 1
- } else if(names(tips)[i-1]%in%desc){
- 1
- } else 1/factor
- }
- obj<-list(tree=tree,tips=tips)
- class(obj)<-"expand.clade"
- obj
-}
-
-## S3 print method for the object class "expand.clade"
-print.expand.clade<-function(x,...){
- cat("An object of class \"expand.clade\" consisting of:\n")
- cat(paste("(1) A phylogenetic tree (x$tree) with",Ntip(x$tree),
- "tips and\n ",x$tree$Nnode,"internal nodes.\n"))
- cat("(2) A vector (x$tips) containing the desired tip-spacing.\n\n")
-}
-
-## S3 plot method for the object class "expand.clade"
-plot.expand.clade<-function(x,...){
- args<-list(...)
- args$tree<-x$tree
- args$tips<-x$tips
- if(inherits(args$tree,"simmap")) do.call(plotSimmap,args)
- else do.call(plotTree,args)
-}
-
-## function to add a geological or other temporal legend to a plotted tree
-## written by Liam J. Revell 2017, 2019
-geo.legend<-function(leg=NULL,colors=NULL,alpha=0.2,...){
- if(hasArg(cex)) cex<-list(...)$cex
- else cex<-par()$cex
- if(hasArg(plot)) plot<-list(...)$plot
- else plot<-TRUE
- if(hasArg(show.lines)) show.lines<-list(...)$show.lines
- else show.lines<-TRUE
- obj<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- if(is.null(colors)){
- colors<-setNames(c(
- rgb(255,242,127,255,maxColorValue=255),
- rgb(255,230,25,255,maxColorValue=255),
- rgb(253,154,82,255,maxColorValue=255),
- rgb(127,198,78,255,maxColorValue=255),
- rgb(52,178,201,255,maxColorValue=255),
- rgb(129,43,146,255,maxColorValue=255),
- rgb(240,64,40,255,maxColorValue=255),
- rgb(103,165,153,255,maxColorValue=255),
- rgb(203,140,55,255,maxColorValue=255),
- rgb(179,225,182,255,maxColorValue=255),
- rgb(0,146,112,255,maxColorValue=255),
- rgb(127,160,86,255,maxColorValue=255),
- rgb(247,67,112,255,maxColorValue=255)),
- c("Quaternary","Neogene","Paleogene",
- "Cretaceous","Jurassic","Triassic",
- "Permian","Carboniferous","Devonian",
- "Silurian","Ordovician","Cambrian",
- "Precambrian"))
- }
- if(is.null(leg)){
- leg<-rbind(c(2.588,0),
- c(23.03,2.588),
- c(66.0,23.03),
- c(145.0,66.0),
- c(201.3,145.0),
- c(252.17,201.3),
- c(298.9,252.17),
- c(358.9,298.9),
- c(419.2,358.9),
- c(443.8,419.2),
- c(485.4,443.8),
- c(541.0,485.4),
- c(4600,541.0))
- rownames(leg)<-c("Quaternary","Neogene","Paleogene",
- "Cretaceous","Jurassic","Triassic",
- "Permian","Carboniferous","Devonian",
- "Silurian","Ordovician","Cambrian",
- "Precambrian")
- t.max<-max(obj$xx)
- ii<-which(leg[,2]<=t.max)
- leg<-leg[ii,]
- leg[max(ii),1]<-t.max
- }
- colors<-sapply(colors,make.transparent,alpha=alpha)
- if(plot){
- y<-c(rep(0,2),rep(par()$usr[4],2))
- ylabel<--1/25*obj$Ntip
- if(obj$direction=="rightwards"){
- old.usr<-par()$usr
- h<-max(obj$xx)
- new.xlim<-c(h-par()$usr[1],h-par()$usr[2])
- par(usr=c(new.xlim,old.usr[3:4]))
- } else old.usr<-par()$usr
- for(i in 1:nrow(leg)){
- strh<-strheight(rownames(leg)[i])
- polygon(c(leg[i,1:2],leg[i,2:1]),y,
- col=colors[rownames(leg)[i]],border=NA)
- if(show.lines){
- lines(x=rep(leg[i,1],2),y=c(0,par()$usr[4]),
- lty="dotted",col="grey")
- lines(x=c(leg[i,1],mean(leg[i,])-0.8*cex*
- get.asp()*strheight(rownames(leg)[i])),
- y=c(0,ylabel),lty="dotted",col="grey")
- lines(x=c(leg[i,2],mean(leg[i,])+0.8*cex*
- get.asp()*strheight(rownames(leg)[i])),
- y=c(0,ylabel),lty="dotted",col="grey")
- lines(x=rep(mean(leg[i,])-0.8*cex*
- get.asp()*strheight(rownames(leg)[i]),2),
- y=c(ylabel,par()$usr[3]),lty="dotted",col="grey")
- lines(x=rep(mean(leg[i,])+0.8*cex*
- get.asp()*strheight(rownames(leg)[i]),2),
- y=c(ylabel,par()$usr[3]),lty="dotted",col="grey")
- }
- polygon(x=c(leg[i,1],
- mean(leg[i,])-0.8*cex*get.asp()*strh,
- mean(leg[i,])-0.8*cex*get.asp()*strh,
- mean(leg[i,])+0.8*cex*get.asp()*strh,
- mean(leg[i,])+0.8*cex*get.asp()*strh,
- leg[i,2]),y=c(0,ylabel,par()$usr[3],
- par()$usr[3],ylabel,0),
- col=colors[rownames(leg)[i]],border=NA)
- strh<-strh*get.asp()
- text(x=mean(leg[i,])+
- if(obj$direction=="leftwards") 0.12*strh else -0.12*strh,
- y=ylabel,labels=rownames(leg)[i],
- srt=90,adj=c(1,0.5),cex=cex)
- }
- }
- par(usr=old.usr)
- object<-list(leg=leg,colors=colors[1:nrow(leg)])
- class(object)<-"geo.legend"
- invisible(object)
-}
-
-print.geo.legend<-function(x,...){
- cat("A geological period legend:\n")
- colnames(x$leg)<-c("start","end")
- print(data.frame(x$leg,color=x$colors))
- cat("\n")
-}
-
-geo.palette<-function(){
- colors<-setNames(c(
- rgb(255,242,127,255,maxColorValue=255),
- rgb(255,230,25,255,maxColorValue=255),
- rgb(253,154,82,255,maxColorValue=255),
- rgb(127,198,78,255,maxColorValue=255),
- rgb(52,178,201,255,maxColorValue=255),
- rgb(129,43,146,255,maxColorValue=255),
- rgb(240,64,40,255,maxColorValue=255),
- rgb(103,165,153,255,maxColorValue=255),
- rgb(203,140,55,255,maxColorValue=255),
- rgb(179,225,182,255,maxColorValue=255),
- rgb(0,146,112,255,maxColorValue=255),
- rgb(127,160,86,255,maxColorValue=255),
- rgb(247,67,112,255,maxColorValue=255)),
- c("Quaternary","Neogene","Paleogene",
- "Cretaceous","Jurassic","Triassic",
- "Permian","Carboniferous","Devonian",
- "Silurian","Ordovician","Cambrian",
- "Precambrian"))
- leg<-rbind(c(2.588,0),
- c(23.03,2.588),
- c(66.0,23.03),
- c(145.0,66.0),
- c(201.3,145.0),
- c(252.17,201.3),
- c(298.9,252.17),
- c(358.9,298.9),
- c(419.2,358.9),
- c(443.8,419.2),
- c(485.4,443.8),
- c(541.0,485.4),
- c(4600,541.0))
- rownames(leg)<-c("Quaternary","Neogene","Paleogene",
- "Cretaceous","Jurassic","Triassic",
- "Permian","Carboniferous","Devonian",
- "Silurian","Ordovician","Cambrian",
- "Precambrian")
- colnames(leg)<-c("start","end")
- object<-list(period=leg,cols=colors)
- class(object)<-"geo.palette"
- object
-}
-
-print.geo.palette<-function(x,...){
- cat("A geological period color palette:\n")
- print(data.frame(x$period,color=x$cols))
- cat("\n")
-}
-
-## borrowed from mapplots
-get.asp<-function(){
- pin<-par("pin")
- usr<-par("usr")
- asp<-(pin[2]/(usr[4]-usr[3]))/(pin[1]/(usr[2]-usr[1]))
- asp
-}
-
-round.polygon<-function(x,y,col="transparent"){
- ## just space holding for now
-}
-
-## draw a box around a clade
-## written by Liam J. Revell 2017
-
-cladebox<-function(tree,node,color=NULL,...){
- if(is.null(color)) color<-make.transparent("yellow",0.2)
- obj<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- h<-max(nodeHeights(tree))
- parent<-tree$edge[which(tree$edge[,2]==node),1]
- x0<-max(c(obj$xx[node]+obj$xx[parent])/2,obj$xx[node]-0.05*h)
- x1<-obj$x.lim[2]
- dd<-getDescendants(tree,node)
- y0<-min(range(obj$yy[dd]))-0.5
- y1<-max(range(obj$yy[dd]))+0.5
- polygon(c(x0,x1,x1,x0),c(y0,y0,y1,y1),col=color,
- border=0)
-}
-
-## draw tip labels as linking lines to text
-## written by Liam J. Revell 2017
-
-linklabels<-function(text,tips,link.type=c("bent","curved","straight"),
- ...){
- lastPP<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- if(!(lastPP$direction%in%c("leftwards","rightwards")))
- stop("direction should be \"rightwards\" or \"leftwards\".")
- if(hasArg(cex)) cex<-list(...)$cex
- else cex<-1
- if(hasArg(col)) col<-list(...)$col
- else col<-"black"
- if(hasArg(lty)) lty<-list(...)$lty
- else lty<-"dashed"
- if(hasArg(lwd)) lwd<-list(...)$lwd
- else lwd<-1
- if(hasArg(link.offset)) link.offset<-list(...)$link.offset
- else link.offset<-0.1*max(lastPP$xx)
- if(hasArg(font)) font<-list(...)$font
- else font<-3
- link.type<-link.type[1]
- xpos<-lastPP$xx[tips]+strwidth("i")
- ypos<-lastPP$yy[tips]
- xmax<-rep(max(lastPP$xx),length(tips))+link.offset
- ylab<-seq(min(lastPP$yy),max(lastPP$yy),
- by=(max(lastPP$yy)-min(lastPP$yy))/(length(tips)-1))
- ylab<-ylab[rank(ypos)]
- text(xmax,ylab,gsub("_"," ",text),pos=4,font=font,cex=cex,
- offset=0)
- if(link.type=="curved"){
- for(i in 1:length(tips))
- drawCurve(c(xpos[i],xmax[i]),c(ypos[i],ylab[i]),
- scale=0.01*diff(range(lastPP$xx)),lty=lty,
- col=col,lwd=lwd)
- } else if(link.type=="bent"){
- tipmax<-max(lastPP$xx)
- for(i in 1:length(tips)){
- ff<-strwidth("W")
- segments(xpos[i],ypos[i],tipmax+link.offset/2,ypos[i],
- lty=lty,col=col,lwd=lwd)
- segments(tipmax+link.offset/2,ypos[i],tipmax+
- link.offset/2+ff,ylab[i],lty=lty,col=col,lwd=lwd)
- segments(tipmax+link.offset/2+ff,ylab[i],xmax[i],ylab[i],
- lty=lty,col=col,lwd=lwd)
- }
- } else if(link.type=="straight")
- segments(xpos,ypos,xmax,ylab,lty=lty,col=col)
-}
-
-## function to create curved clade labels for a fan tree
-## written by Liam J. Revell 2017, 2022
-
-arc.cladelabels<-function(tree=NULL,text,node=NULL,ln.offset=1.02,
- lab.offset=1.06,cex=1,orientation="curved",stretch=1,...){
- obj<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- if(obj$type!="fan") stop("method works only for type=\"fan\"")
- h<-max(sqrt(obj$xx^2+obj$yy^2))
- if(hasArg(mark.node)) mark.node<-list(...)$mark.node
- else mark.node<-TRUE
- if(hasArg(interactive)) interactive<-list(...)$interactive
- else {
- if(is.null(node)) interactive<-TRUE
- else interactive<-FALSE
- }
- if(interactive) node<-getnode()
- if(hasArg(lwd)) lwd<-list(...)$lwd
- else lwd<-par()$lwd
- if(hasArg(col)) col<-list(...)$col
- else col<-par()$col
- if(hasArg(lend)) lend<-list(...)$lend
- else lend<-par()$lend
- if(hasArg(clockwise)) clockwise<-list(...)$clockwise
- else clockwise<-TRUE
- if(hasArg(n)) n<-list(...)$n
- else n<-0.05
- if(mark.node) points(obj$xx[node],obj$yy[node],pch=21,
- bg="red")
- if(is.null(tree)){
- tree<-list(edge=obj$edge,tip.label=1:obj$Ntip,
- Nnode=obj$Nnode)
- class(tree)<-"phylo"
- }
- d<-getDescendants(tree,node)
- d<-sort(d[d<=Ntip(tree)])
- deg<-atan(obj$yy[d]/obj$xx[d])*180/pi
- ii<-intersect(which(obj$yy[d]>=0),which(obj$xx[d]<0))
- deg[ii]<-180+deg[ii]
- ii<-intersect(which(obj$yy[d]<0),which(obj$xx[d]<0))
- deg[ii]<-180+deg[ii]
- ii<-intersect(which(obj$yy[d]<0),which(obj$xx[d]>=0))
- deg[ii]<-360+deg[ii]
- draw.arc(x=0,y=0,radius=ln.offset*h,deg1=min(deg),
- deg2=max(deg),lwd=lwd,col=col,lend=lend,n=n)
- if(orientation=="curved")
- arctext(text,radius=lab.offset*h,
- middle=mean(range(deg*pi/180)),cex=cex,
- clockwise=clockwise,stretch=stretch)
- else if(orientation=="horizontal"){
- x0<-lab.offset*cos(median(deg)*pi/180)*h
- y0<-lab.offset*sin(median(deg)*pi/180)*h
- text(x=x0,y=y0,label=text,
- adj=c(if(x0>=0) 0 else 1,if(y0>=0) 0 else 1),
- offset=0,cex=cex)
- }
-}
-
-## function to return a node index interactively from a plotted tree
-## written by Liam J. Revell 2017
-getnode<-function(...){
- if(hasArg(env)) env<-list(...)$env
- else env<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- if(hasArg(show.pt)) show.pt<-list(...)$show.pt
- else show.pt<-FALSE
- xy<-unlist(locator(n=1))
- if(show.pt) points(xy[1],xy[2])
- d<-sqrt((xy[1]-env$xx)^2+(xy[2]-env$yy)^2)
- ii<-which(d==min(d))[1]
- ii
-}
-
-## function mostly to interactively label nodes by clicking
-## written by Liam J. Revell 2017, 2020
-labelnodes<-function(text,node=NULL,interactive=TRUE,
- shape=c("circle","ellipse","rect"),...){
- shape<-shape[1]
- if(hasArg(circle.exp)) circle.exp<-list(...)$circle.exp
- else circle.exp<-1.3
- if(hasArg(rect.exp)) rect.exp<-list(...)$rect.exp
- else rect.exp<-1.6
- if(hasArg(cex)) cex<-list(...)$cex
- else cex<-1
- if(hasArg(bg)) bg<-list(...)$bg
- else bg<-"white"
- obj<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- h<-cex*strheight("A")
- w<-cex*strwidth(text)
- rad<-circle.exp*h*diff(par()$usr[1:2])/diff(par()$usr[3:4])
- if(is.null(node)){
- if(!interactive){
- cat("No nodes provided. Setting interactive mode to TRUE.\n")
- interactive<-TRUE
- }
- node<-vector(length=length(text))
- }
- for(i in 1:length(text)){
- if(interactive){
- cat(paste("Click on the node you would like to label ",
- text[i],".\n",sep=""))
- flush.console()
- ii<-getnode(env=obj)
- node[i]<-ii
- } else ii<-node[i]
- if(shape=="circle")
- draw.circle(obj$xx[ii],obj$yy[ii],rad,col=bg)
- else if(shape=="ellipse")
- draw.ellipse(obj$xx[ii],obj$yy[ii],0.8*w[i],h,
- col=bg)
- else if(shape=="rect")
- rect(xleft=obj$xx[ii]-0.5*rect.exp*w[i],
- ybottom=obj$yy[ii]-0.5*rect.exp*h,
- xright=obj$xx[ii]+0.5*rect.exp*w[i],
- ytop=obj$yy[ii]+0.5*rect.exp*h,col=bg,
- ljoin=1)
- text(obj$xx[ii],obj$yy[ii],label=text[i],cex=cex)
- }
- invisible(node)
-}
-
-## convert object of class "birthdeath" into birth & death rates
-bd<-function(x){
- if(!inherits(x,"birthdeath")) stop("x should be an object of class 'birthdeath'")
- b<-x$para[2]/(1-x$para[1])
- d<-b-x$para[2]
- setNames(c(b,d),c("b","d"))
-}
-
-## compute AIC weights
-aic.w<-function(aic){
- d.aic<-aic-min(aic)
- x<-exp(-1/2*d.aic)/sum(exp(-1/2*d.aic))
- class(x)<-"aic.w"
- x
-}
-
-print.aic.w<-function(x,...){
- if(hasArg(signif)) signif<-list(...)$signif
- else signif<-8
- print(round(unclass(x),signif))
-}
-
-## function to compute all paths towards the tips from a node
-## written by Liam J. Revell
-node.paths<-function(tree,node){
- d<-Descendants(tree,node,"children")
- paths<-as.list(d)
- while(any(d>Ntip(tree))){
- jj<-1
- new.paths<-list()
- for(i in 1:length(paths)){
- if(paths[[i]][length(paths[[i]])]<=Ntip(tree)){
- new.paths[[jj]]<-paths[[i]]
- jj<-jj+1
- } else {
- ch<-Descendants(tree,paths[[i]][length(paths[[i]])],
- "children")
- for(j in 1:length(ch)){
- new.paths[[jj]]<-c(paths[[i]],ch[j])
- jj<-jj+1
- }
- }
- }
- paths<-new.paths
- d<-sapply(paths,function(x) x[length(x)])
- }
- paths
-}
-
-## function to compute a modification of Grafen's edge lengths
-## written by Liam J. Revell 2016
-modified.Grafen<-function(tree,power=2){
- max.np<-function(tree,node){
- np<-node.paths(tree,node)
- if(length(np)>0) max(sapply(np,length)) else 0
- }
- nn<-1:(Ntip(tree)+tree$Nnode)
- h<-sapply(nn,max.np,tree=tree)+1
- h<-(h/max(h))^power
- edge.length<-vector()
- for(i in 1:nrow(tree$edge))
- edge.length[i]<-diff(h[tree$edge[i,2:1]])
- tree$edge.length<-edge.length
- tree
-}
-
-## function to compute all rotations
-## written by Liam J. Revell 2016
-allRotations<-function(tree){
- if(!is.binary(tree)){
- was.binary<-FALSE
- if(is.null(tree$edge.length)){
- tree<-compute.brlen(tree)
- had.edge.lengths<-FALSE
- } else had.edge.lengths<-TRUE
- tree<-multi2di(tree)
- } else was.binary<-TRUE
- nodes<-1:tree$Nnode+Ntip(tree)
- trees<-vector(mode="list",length=2^length(nodes))
- ii<-2
- trees[[1]]<-tree
- for(i in 1:length(nodes)){
- N<-ii-1
- for(j in 1:N){
- trees[[ii]]<-rotate(trees[[j]],nodes[i])
- ii<-ii+1
- }
- }
- trees<-lapply(trees,untangle,"read.tree")
- if(!was.binary){
- trees<-lapply(trees,di2multi)
- if(!had.edge.lengths) trees<-lapply(trees,
- function(x){
- x$edge.length<-NULL
- x
- })
- }
- class(trees)<-"multiPhylo"
- trees
-}
-
-## function to rotate a multifurcation in all possible ways
-## written by Liam J. Revell 2016
-rotate.multi<-function(tree,node){
- kids<-Children(tree,node)
- if(length(kids)>2){
- ii<-sapply(kids,function(x,y) which(y==x),y=tree$edge[,2])
- jj<-permn(ii)
- foo<-function(j,i,t){
- t$edge[i,]<-t$edge[j,]
- if(!is.null(t$edge.length))
- t$edge.length[i]<-t$edge.length[j]
- untangle(t,"read.tree")
- }
- obj<-lapply(jj[2:length(jj)],foo,i=ii,t=tree)
- class(obj)<-"multiPhylo"
- } else obj<-untangle(rotate(tree,node),"read.tree")
- obj
-}
-
-## wrapper for bind.tree that takes objects of class "simmap"
-## written by Liam J. Revell 2016
-bind.tree.simmap<-function(x,y,where="root"){
- x<-reorder(x)
- y<-reorder(y)
- rootx<-x$edge[1,1]
- rooty<-y$edge[1,1]
- xy<-read.tree(text=write.tree(bind.tree(x,y,where)))
- Mx<-rbind(matchLabels(x,xy),matchNodes(x,xy,"distances"))
- My<-rbind(matchLabels(y,xy),matchNodes(y,xy,"distances"))
- if(where!="root"&&where<=Ntip(x))
- Mx[which(is.na(Mx[,2])),2]<-findMRCA(xy,y$tip.label)
- xy$maps<-vector(mode="list",length=nrow(xy$edge))
- ix<-sapply(Mx[-which(Mx[,1]==rootx),1],
- function(x,y) which(y==x),y=x$edge[,2])
- ixy<-sapply(Mx[-which(Mx[,1]==rootx),2],
- function(x,y) which(y==x),y=xy$edge[,2])
- xy$maps[ixy]<-x$maps[ix]
- iy<-sapply(My[-which(My[,1]==rooty),1],
- function(x,y) which(y==x),y=y$edge[,2])
- ixy<-sapply(My[-which(My[,1]==rooty),2],
- function(x,y) which(y==x),y=xy$edge[,2])
- xy$maps[ixy]<-y$maps[iy]
- xy$mapped.edge<-makeMappedEdge(xy$edge,xy$maps)
- ns<-c(setNames(getStates(xy,"tips"),1:Ntip(xy)),
- getStates(xy,"nodes"))
- xy$node.states<-cbind(ns[as.character(xy$edge[,1])],
- ns[as.character(xy$edge[,2])])
- xy$states<-getStates(xy,"tips")
- attr(xy,"class")<-c("simmap",class(xy))
- xy
-}
-
-## generic function to convert an object of class "simmap" to "phylo"
-## written by Liam J. Revell 2016
-as.phylo.simmap<-function(x,...){
- x$maps<-NULL
- x$mapped.edge<-NULL
- if(!is.null(x$node.states)) x$node.states<-NULL
- if(!is.null(x$states)) x$states<-NULL
- if(!is.null(x$Q)) x$Q<-NULL
- if(!is.null(x$logL)) x$logL<-NULL
- if(!is.null(attr(x,"map.order"))) attr(x,"map.order")<-NULL
- class(x)<-setdiff(class(x),"simmap")
- x
-}
-
-## generic function to convert an object of class "multiSimmap" to "multiPhylo"
-## written by Liam J. Revell 2016
-as.multiPhylo.multiSimmap<-function(x,...){
- obj<-lapply(x,as.phylo)
- class(obj)<-setdiff(class(x),"multiSimmap")
- obj
-}
-
-## generic function to convert object of class "phylo" to "multiPhylo"
-## written by Liam J. Revell 2016
-as.multiPhylo.phylo<-function(x,...){
- obj<-list(x)
- class(obj)<-"multiPhylo"
- obj
-}
-
-as.multiPhylo<-function(x,...){
- if (identical(class(x),"multiPhylo")) return(x)
- UseMethod("as.multiPhylo")
-}
-
-## get mapped states
-## written by Liam J. Revell 2016
-mapped.states<-function(tree,...){
- if(!(inherits(tree,"simmap")||inherits(tree,"multiSimmap")))
- stop("tree should be an object of class \"simmap\" or \"multiSimmap\".")
- else {
- if(inherits(tree,"simmap")){
- if(!is.null(tree$mapped.edge))
- obj<-sort(colnames(tree$mapped.edge))
- else
- obj<-sort(unique(unlist(lapply(tree$maps,function(x) names(x)))))
- } else if(inherits(tree,"multiSimmap")) {
- obj<-sapply(tree,mapped.states,...)
- }
- }
- obj
-}
-
-## match labels between trees (equivalent to matchNodes)
-## written by Liam J. Revell 2016
-matchLabels<-function(tr1,tr2){
- foo<-function(x,y) if(length(obj<-which(y==x))>0) obj else NA
- M<-cbind(1:Ntip(tr1),sapply(tr1$tip.label,foo,y=tr2$tip.label))
- colnames(M)<-c("tr1","tr2")
- M
-}
-
-## compute the probability of states changes along edges of the tree
-## written by Liam J. Revell 2015
-edgeProbs<-function(trees){
- if(!inherits(trees,"multiSimmap")) stop("trees should be an object of class \"multiSimmap\".")
- SS<-sapply(trees,getStates,"tips")
- states<-sort(unique(as.vector(SS)))
- m<-length(states)
- TT<-sapply(states,function(x,y) sapply(y,paste,x,sep="->"),
- y=states)
- nn<-c(TT[upper.tri(TT)],TT[lower.tri(TT)])
- ## this function computes for a given edge
- fn<-function(edge,trees,states){
- obj<-sapply(trees,function(x,e,s)
- if(names(x$maps[[e]])[1]==
- s[1]&&names(x$maps[[e]])[length(x$maps[[e]])]==s[2]) TRUE
- else FALSE,e=edge,s=states)
- sum(obj)/length(obj)
- }
- edge.probs<-matrix(0,nrow(trees[[1]]$edge),m,
- dimnames=list(apply(trees[[1]]$edge,1,paste,collapse=","),nn))
- k<-1
- for(i in 1:m) for(j in 1:m){
- if(i!=j){
- edge.probs[,k]<-sapply(1:nrow(trees[[1]]$edge),fn,
- trees=trees,states=states[c(i,j)])
- k<-k+1
- }
- }
- edge.probs<-cbind(edge.probs,1-rowSums(edge.probs))
- colnames(edge.probs)[ncol(edge.probs)]<-"no change"
- edge.probs
-}
-
-## get a position in the tree interactively
-## written by Liam J. Revell 2015, 2016, 2020
-get.treepos<-function(message=TRUE,...){
- obj<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- if(obj$type=="phylogram"&&obj$direction=="rightwards"){
- if(message){
- cat("Click on the tree position you want to capture...\n")
- flush.console()
- }
- if(hasArg(x)) x<-list(...)$x
- else x<-NULL
- if(hasArg(y)) y<-list(...)$y
- else y<-NULL
- if(is.null(x)||is.null(y)){
- x<-unlist(locator(1))
- y<-x[2]
- x<-x[1]
- }
- d<-pos<-c()
- for(i in 1:nrow(obj$edge)){
- x0<-obj$xx[obj$edge[i,]]
- y0<-obj$yy[obj$edge[i,2]]
- if(x<x0[1]||x>x0[2]){
- d[i]<-min(dist(rbind(c(x,y),c(x0[1],y0))),
- dist(rbind(c(x,y),c(x0[2],y0))))
- pos[i]<-if(x>x0[2]) 0 else diff(obj$xx[obj$edge[i,]])
- } else {
- d[i]<-abs(y0-y)
- pos[i]<-obj$xx[obj$edge[i,2]]-x
- }
- }
- ii<-which(d==min(d))
- ## check to make sure the root is not closer:
- root.d<-dist(rbind(c(x,y),c(obj$xx[obj$Ntip+1],obj$yy[obj$Ntip+1])))
- if(root.d<min(d)) return(list(where=obj$Ntip+1,pos=0))
- else list(where=obj$edge[ii,2],pos=pos[ii])
- } else stop("Does not work for the plotted tree type.")
-}
-
-## fastDist: uses fastHeight to compute patristic distance between a pair of species
-fastDist<-function(tree,sp1,sp2){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- if(is.null(tree$edge.length)) stop("tree should have edge lengths.")
- if(sp1==sp2) 0
- else fastHeight(tree,sp1,sp1)+fastHeight(tree,sp2,sp2)-
- 2*fastHeight(tree,sp1,sp2)
-}
-
-## function reorders simmap tree
-## written Liam Revell 2011, 2013, 2015, 2019
-reorderSimmap<-function(tree,order="cladewise",index.only=FALSE,...){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- ii<-reorder.phylo(tree,order,index.only=TRUE,...)
- if(!index.only){
- if(inherits(ii,"phylo")) ii<-whichorder(ii$edge[,2],
- tree$edge[,2]) ## bug workaround
- tree$edge<-tree$edge[ii,]
- tree$edge.length<-tree$edge.length[ii]
- if(!is.null(tree$maps)){
- tree$maps<-tree$maps[ii]
- tree$mapped.edge<-tree$mapped.edge[ii,,drop=FALSE]
- }
- attr(tree,"order")<-order
- return(tree)
- } else return(ii)
-}
-
-## S3 reorder method for objects of class "simmap"
-reorder.simmap<-function(x,...) reorderSimmap(x,...)
-
-# function whichorder
-# written by Liam Revell 2011, 2013, 2015
-whichorder<-function(x,y) sapply(x,function(x,y) which(x==y),y=y)
-
-# function returns random state with probability given by y
-# written by Liam J. Revell 2013, 2015
-rstate<-function(y){
- if(length(y)==1) return(names(y)[1])
- else {
- p<-y/sum(y)
- if(any(p<0)){
- warning("Some probabilities (slightly?) < 0. Setting p < 0 to zero.")
- p[p<0]<-0
- }
- return(names(which(rmultinom(1,1,p)[,1]==1)))
- }
-}
-
-## mark the changes on a plotted "simmap" object
-## written by Liam J. Revell 2015
-markChanges<-function(tree,colors=NULL,cex=1,lwd=2,plot=TRUE){
- states<-sort(unique(getStates(tree)))
- if(is.null(colors)) colors<-setNames(palette()[1:length(states)],
- states)
- obj<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- nc<-sapply(tree$maps,length)-1
- ii<-which(nc>0)
- nc<-nc[ii]
- xx<-yy<-vector()
- for(i in 1:length(ii)){
- for(j in 1:nc[i]){
- ss<-names(tree$maps[[ii[i]]])[j+1]
- mm<-tree$edge[ii[i],1]
- dd<-tree$edge[ii[i],2]
- x<-rep(obj$xx[mm]+cumsum(tree$maps[[ii[i]]])[j],2)
- y<-c(obj$yy[dd]-0.5*mean(strheight(LETTERS)*cex),
- obj$yy[dd]+0.5*mean(strheight(LETTERS)*cex))
- if(plot) lines(x,y,lwd=lwd,col=colors[ss],lend=2)
- xx<-c(xx,setNames(x[1],
- paste(names(tree$maps[[ii[i]]])[j:(j+1)],
- collapse="->")))
- yy<-c(yy,mean(y))
- }
- }
- XY<-cbind(xx,yy)
- colnames(XY)<-c("x","y")
- invisible(XY)
-}
-
-## function to label clades
-## written by Liam J. Revell 2014, 2015, 2022
-cladelabels<-function(tree=NULL,text,node,offset=NULL,wing.length=NULL,cex=1,
- orientation="vertical"){
- lastPP<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- if(is.null(tree)){
- if(is.null(wing.length)) wing.length<-1
- if(is.null(offset)) offset<-8
- tree<-list(edge=lastPP$edge,
- tip.label=1:lastPP$Ntip,
- Nnode=lastPP$Nnode)
- H<-matrix(lastPP$xx[tree$edge],nrow(tree$edge),2)
- tree$edge.length<-H[,2]-H[,1]
- class(tree)<-"phylo"
- }
- if(is.null(offset)) offset<-0.5
- xx<-mapply(labelSubTree,node,text,
- MoreArgs=list(tree=tree,pp=lastPP,offset=offset,wl=wing.length,cex=cex,
- orientation=orientation),SIMPLIFY=FALSE)
-}
-
-## internal function used by cladelabels
-## written by Liam J. Revell 2014, 2015, 2022
-labelSubTree<-function(tree,nn,label,pp,offset,wl,cex,orientation){
- if(is.null(wl)) wl<-1
- tree<-reorder(tree)
- tips<-getDescendants(tree,nn)
- tips<-tips[tips<=Ntip(tree)]
- ec<-0.7 ## expansion constant
- sw<-pp$cex*max(strwidth(tree$tip.label[tips]))
- sh<-pp$cex*max(strheight(tree$tip.label))
- cw<-mean(strwidth(LETTERS)*cex)
- h<-max(sapply(tips,function(x,tree)
- nodeHeights(tree)[which(tree$edge[,2]==x),2],
- tree=tree))+sw+offset*cw
- y<-range(pp$yy[tips])
- lines(c(h,h),y+ec*c(-sh,sh),col=par()$fg)
- lines(c(h-wl*cw,h),
- c(y[1]-ec*sh,y[1]-ec*sh),col=par()$fg)
- lines(c(h-wl*cw,h),
- c(y[2]+ec*sh,y[2]+ec*sh),col=par()$fg)
- text(h+cw,mean(y),
- label,srt=if(orientation=="horizontal") 0 else 90,
- adj=if(orientation=="horizontal") 0 else 0.5,cex=cex,
- col=par()$col.lab)
- list(xx=c(h,h),yy=y+ec*c(-sh,sh))
-}
-
-## get all the extant/extinct tip names
-## written by Liam J. Revell 2012, 2015
-
-getExtant<-function(tree,tol=1e-8){
- if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".")
- H<-nodeHeights(tree)
- tl<-max(H)
- x<-which(H[,2]>=(tl-tol))
- y<-tree$edge[x,2]
- y<-y[y<=Ntip(tree)]
- z<-tree$tip.label[y]
- return(z)
-}
-
-getExtinct<-function(tree,tol=1e-8) setdiff(tree$tip.label,getExtant(tree,tol))
-
-# function splits tree at split
-# written by Liam Revell 2011, 2014, 2015, 2020
-
-splitTree<-function(tree,split){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- if(split$node>Ntip(tree)){
- # first extract the clade given by shift$node
- tr2<-extract.clade(tree,node=split$node)
- tr2$root.edge<-tree$edge.length[which(tree$edge[,2]==split$node)]-split$bp
- #now remove tips in tr2 from tree
- tr1<-drop.clade(tree,tr2$tip.label)
- nn<-if(!is.null(tree$node.label)) c(tree$node.label,"NA") else "NA"
- tr1$tip.label[which(tr1$tip.label%in%nn)]<-"NA"
- tr1$edge.length[match(which(tr1$tip.label=="NA"),tr1$edge[,2])]<-split$bp
- } else {
- # first extract the clade given by shift$node
- tr2<-list(edge=matrix(c(2L,1L),1,2),tip.label=tree$tip.label[split$node],edge.length=tree$edge.length[which(tree$edge[,2]==split$node)]-split$bp,Nnode=1L)
- class(tr2)<-"phylo"
- # now remove tip in tr2 from tree
- tr1<-tree
- tr1$edge.length[match(which(tr1$tip.label==tr2$tip.label[1]),tr1$edge[,2])]<-split$bp
- tr1$tip.label[which(tr1$tip.label==tr2$tip.label[1])]<-"NA"
- }
- trees<-list(tr1,tr2)
- class(trees)<-"multiPhylo"
- trees
-}
-
-# function drops entire clade
-# written by Liam Revell 2011, 2015, 2020
-
-drop.clade<-function(tree,tip){
- ## step 1, check to make sure tips form a monophyletic clade
- node<-getMRCA(tree,tip)
- desc<-getDescendants(tree,node)
- chk<-tree$tip.label[desc[desc<=Ntip(tree)]]
- if(!setequal(tip,chk)){
- cat("Caution: Species in tip do not form a monophyletic clade.\n")
- cat(" Pruning all tips descended from ancestor.\n\n")
- tip<-chk
- }
- ## step 2, find all edges in the clade & set them to zero length
- ee<-sapply(desc,function(node,edge) which(edge==node),
- edge=tree$edge[,2])
- tree$edge.length[ee]<-0
- ## step 3, bind a tip labeled "NA" to the node
- tree<-bind.tip(tree,"NA",0,node)
- ## step 4, prune the other tips
- tree<-drop.tip(tree,tip)
- ## step 5, return tree
- tree
-}
-
-## function to re-root a phylogeny along an edge
-## written by Liam J. Revell 2011-2016, 2019, 2020
-
-reroot<-function(tree,node.number,position=NULL,interactive=FALSE,...){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- if(interactive){
- plotTree(tree,...)
- cat("Click where you would like re-root the plotted tree\n")
- flush.console()
- obj<-get.treepos(message=FALSE)
- node.number<-obj$where
- position<-tree$edge.length[which(tree$edge[,2]==node.number)]-obj$pos
- }
- if(node.number==(Ntip(tree)+1))
- cat("Note: you chose to re-root the tree at it's current root.\n")
- if(is.null(position)){
- if(node.number==(Ntip(tree)+1)) position=0
- else position<-tree$edge.length[which(tree$edge[,2]==node.number)]
- } else {
- if(node.number==(Ntip(tree)+1))
- cat(" A value of position != 0 has been reset to zero.\n")
- }
- if(hasArg(edgelabel)) edgelabel<-list(...)$edgelabel
- else edgelabel<-FALSE
- if(node.number!=(Ntip(tree)+1)){
- tt<-splitTree(tree,list(node=node.number,bp=position))
- p<-tt[[1]]
- d<-tt[[2]]
- tip<-if(length(which(p$tip.label=="NA"))>0) "NA" else p$tip.label[which(p$tip.label%in%tree$node.label)]
- p<-ape::root.phylo(p,outgroup=tip,resolve.root=TRUE,edgelabel=edgelabel)
- bb<-which(p$tip.label==tip)
- p$tip.label[bb]<-"NA"
- ee<-p$edge.length[which(p$edge[,2]==bb)]
- p$edge.length[which(p$edge[,2]==bb)]<-0
- cc<-p$edge[which(p$edge[,2]==bb),1]
- dd<-setdiff(p$edge[which(p$edge[,1]==cc),2],bb)
- p$edge.length[which(p$edge[,2]==dd)]<-p$edge.length[which(p$edge[,2]==dd)]+ee
- obj<-paste.tree(p,d)
- } else obj<-tree
- if(interactive) plotTree(obj,...)
- obj
-}
-
-## function to add an arrow pointing to a tip or node in the tree
-## written by Liam J. Revell 2014, 2017, 2020
-
-add.arrow<-function(tree=NULL,tip,...){
- if(length(tip)>1){
- object<-sapply(tip,add.arrow,tree=tree,...)
- invisible(object)
- } else {
- lastPP<-get("last_plot.phylo",envir=.PlotPhyloEnv)
- if(!is.null(tree)){
- if(inherits(tree,"contMap")) tree<-tree$tree
- else if(inherits(tree,"densityMap")) tree<-tree$tree
- }
- if(is.numeric(tip)){
- ii<-tip
- if(!is.null(tree)&&ii<=Ntip(tree)) tip<-tree$tip.label[ii]
- else tip<-""
- } else if(is.character(tip)&&!is.null(tree)) ii<-which(tree$tip.label==tip)
- if(hasArg(offset)) offset<-list(...)$offset
- else offset<-1
- strw<-lastPP$cex*(strwidth(tip)+offset*mean(strwidth(c(LETTERS,letters))))
- if(hasArg(arrl)) arrl<-list(...)$arrl
- else {
- if(lastPP$type=="fan") arrl<-0.3*max(lastPP$xx)
- else if(lastPP$type=="phylogram") arrl<-0.15*max(lastPP$xx)
- }
- if(hasArg(hedl)) hedl<-list(...)$hedl
- else hedl<-arrl/3
- if(hasArg(angle)) angle<-list(...)$angle
- else angle<-45
- arra<-angle*pi/180
- asp<-if(lastPP$type=="fan") 1 else (par()$usr[4]-par()$usr[3])/(par()$usr[2]-
- par()$usr[1])
- if(hasArg(col)) col<-list(...)$col
- else col<-"black"
- if(hasArg(lwd)) lwd<-list(...)$lwd
- else lwd<-2
- if(lastPP$type=="fan") theta<-atan2(lastPP$yy[ii],lastPP$xx[ii])
- else if(lastPP$type=="phylogram") theta<-0
- segments(x0=lastPP$xx[ii]+cos(theta)*(strw+arrl),
- y0=lastPP$yy[ii]+sin(theta)*(strw+arrl),
- x1=lastPP$xx[ii]+cos(theta)*strw,
- y1=lastPP$yy[ii]+sin(theta)*strw,
- col=col,lwd=lwd,lend="round")
- segments(x0=lastPP$xx[ii]+cos(theta)*strw+cos(theta+arra/2)*hedl,
- y0=lastPP$yy[ii]+sin(theta)*strw+sin(theta+arra/2)*hedl*asp,
- x1=lastPP$xx[ii]+cos(theta)*strw,
- y1=lastPP$yy[ii]+sin(theta)*strw,
- col=col,lwd=lwd,lend="round")
- segments(x0=lastPP$xx[ii]+cos(theta)*strw+cos(theta-arra/2)*hedl,
- y0=lastPP$yy[ii]+sin(theta)*strw+sin(theta-arra/2)*hedl*asp,
- x1=lastPP$xx[ii]+cos(theta)*strw,
- y1=lastPP$yy[ii]+sin(theta)*strw,
- col=col,lwd=lwd,lend="round")
- invisible(list(x0=lastPP$xx[ii]+cos(theta)*(strw+arrl),
- y0=lastPP$yy[ii]+sin(theta)*(strw+arrl),
- x1=lastPP$xx[ii]+cos(theta)*strw,
- y1=lastPP$yy[ii]+sin(theta)*strw))
- }
-}
-
-## function to ladderize phylogeny with mapped discrete character
-## written by Liam J. Revell 2014, 2015, 2019
-
-ladderize.simmap<-function(tree,right=TRUE){
- if(!inherits(tree,"simmap")){
- if(!inherits(tree,"phylo"))
- stop("tree should be an object of class \"phylo\".")
- else {
- cat("Do not detect a mapped character. Using ape::ladderize.\n")
- obj<-ladderize(tree,right=right)
- }
- } else {
- obj<-read.tree(text=write.tree(ladderize(tree,right=right)))
- rN<-Ntip(obj)+1
- T<-cbind(1:Ntip(obj),sapply(obj$tip.label,
- function(x,y) which(y==x),y=tree$tip.label))
- N<-matchNodes(obj,tree)
- M<-rbind(T,N[N[,1]!=rN,])
- ii<-sapply(M[,1],function(x,y) which(y==x),y=obj$edge[,2])
- jj<-sapply(M[,2],function(x,y) which(y==x),y=tree$edge[,2])
- obj$maps<-vector(length=nrow(tree$edge),mode="list")
- obj$mapped.edge<-matrix(NA,nrow(tree$edge),ncol(tree$mapped.edge),
- dimnames=list(apply(tree$edge,1,paste,collapse=","),
- colnames(tree$mapped.edge)))
- if(!is.null(tree$states))
- obj$states<-tree$states[sapply(obj$tip.label,
- function(x,y) which(y==x),y=tree$tip.label)]
- if(!is.null(tree$node.states)) obj$node.states<-matrix(NA,nrow(tree$edge),2)
- for(i in 1:length(ii)){
- obj$maps[[ii[i]]]<-tree$maps[[jj[i]]]
- obj$mapped.edge[ii[i],]<-tree$mapped.edge[jj[i],]
- if(!is.null(tree$node.states)) obj$node.states[ii[i],]<-
- tree$node.states[jj[i],]
- }
- class(obj)<-c("simmap","phylo")
- }
- obj
-}
-
-## for backward compatibility
-
-repPhylo<-function(tree,times) rep(tree,times)
-
-## S3 method rep for objects of class "phylo" and "multiPhylo"
-## written by Liam J. Revell 2014, 2021
-
-rep.phylo<-function(x,...){
- if(hasArg(times)) times<-list(...)$times
- else times<-(...)[[1]]
- for(i in 1:times) obj<-if(i==1) x else if(i==2) c(obj,x) else c(unclass(obj),list(x))
- class(obj)<-"multiPhylo"
- obj
-}
-
-rep.multiPhylo<-function(x,...){
- if(hasArg(times)) times<-list(...)$times
- else times<-(...)[[1]]
- for(i in 1:times) obj<-if(i==1) x else if(i>=2) c(obj,x)
- class(obj)<-"multiPhylo"
- obj
-}
-
-## function to drop one or more tips from a tree but retain all ancestral nodes as singletons
-## written by Liam J. Revell 2014, 2015, 2023
-drop.tip.singleton<-function(phy,tip,...){
- if(!inherits(phy,"singleton")&&!inherits(phy,"phylo"))
- stop("phy should be an object of class \"singleton\".")
- N<-Ntip(phy)
- m<-length(tip)
- ii<-sapply(tip,function(x,y) which(y==x),y=phy$tip.label)
- phy$tip.label<-phy$tip.label[-ii]
- ii<-sapply(ii,function(x,y) which(y==x),y=phy$edge[,2])
- phy$edge<-phy$edge[-ii,]
- phy$edge.length<-phy$edge.length[-ii]
- phy$edge[phy$edge<=N]<-as.integer(rank(phy$edge[phy$edge<=N]))
- phy$edge[phy$edge>N]<-phy$edge[phy$edge>N]-m
- N<-N-m
- if(any(sapply(phy$edge[phy$edge[,2]>N,2],"%in%",phy$edge[,1])==FALSE)) internal<-TRUE
- else internal<-FALSE
- while(internal){
- ii<-which(sapply(phy$edge[,2],"%in%",c(1:N,phy$edge[,1]))==FALSE)[1]
- nn<-phy$edge[ii,2]
- phy$edge<-phy$edge[-ii,]
- phy$edge.length<-phy$edge.length[-ii]
- phy$edge[phy$edge>nn]<-phy$edge[phy$edge>nn]-1
- phy$Nnode<-phy$Nnode-length(ii)
- if(any(sapply(phy$edge[phy$edge[,2]>N,2],"%in%",phy$edge[,1])==FALSE)) internal<-TRUE
- else internal<-FALSE
- }
- class(phy)<-union("singleton",class(phy))
- phy
-}
-
-## S3 print method for object of class 'describe.simmap'
-## written by Liam J. Revell 2014, 2015
-print.describe.simmap<-function(x,...){
- if(inherits(x$tree,"multiPhylo")){
- cat(paste(length(x$tree),"trees with a mapped discrete character with states:\n",paste(colnames(x$ace),collapse=", "),"\n\n"))
- cat(paste("trees have",colMeans(x$count)["N"],"changes between states on average\n\n"))
- cat(paste("changes are of the following types:\n"))
- aa<-t(as.matrix(colMeans(x$count)[2:ncol(x$count)]))
- rownames(aa)<-"x->y"
- print(aa)
- cat(paste("\nmean total time spent in each state is:\n"))
- print(matrix(c(colMeans(x$times),colMeans(x$times[,1:ncol(x$times)]/x$times[,ncol(x$times)])),2,ncol(x$times),byrow=TRUE,
- dimnames=list(c("raw","prop"),c(colnames(x$times)))))
- cat("\n")
- } else if(inherits(x$tree,"phylo")){
- cat(paste("1 tree with a mapped discrete character with states:\n",paste(colnames(x$Tr),collapse=", "),"\n\n"))
- cat(paste("tree has",x$N,"changes between states\n\n"))
- cat(paste("changes are of the following types:\n"))
- print(x$Tr)
- cat(paste("\nmean total time spent in each state is:\n"))
- print(x$times)
- cat("\n")
- }
-}
-
-## S3 plot method for object of class 'describe.simmap'
-## written by Liam J. Revell 2014, 2015, 2020
-plot.describe.simmap<-function(x,...){
- if(hasArg(lwd)) lwd<-list(...)$lwd
- else lwd<-2
- if(hasArg(cex)) cex<-list(...)$cex
- else cex<-c(0.6,0.4)
- if(length(cex)==1) cex<-rep(cex,2)
- if(hasArg(type)) type<-list(...)$type
- else type<-"phylogram"
- if(hasArg(offset)) offset<-list(...)$offset
- else offset<-0
- if(hasArg(fsize)) fsize<-list(...)$fsize
- else fsize<-1
- if(inherits(x$tree,"multiPhylo")){
- states<-colnames(x$ace)
- if(hasArg(colors)) colors<-list(...)$colors
- else colors<-setNames(palette()[1:length(states)],states)
- plotTree(if(is.null(x$ref.tree)) x$tree[[1]] else x$ref.tree,lwd=lwd,
- offset=cex[2]+offset*fsize,...)
- nodelabels(pie=x$ace,piecol=colors[colnames(x$ace)],cex=cex[1])
- if(!is.null(x$tips)) tips<-x$tips
- else tips<-to.matrix(getStates(x$tree[[1]],"tips"),seq=states)
- tiplabels(pie=tips[if(is.null(x$ref.tree)) x$tree[[1]]$tip.label else
- x$ref.tree$tip.label,],piecol=colors[colnames(tips)],cex=cex[2])
- } else if(inherits(x$tree,"phylo")){
- states<-colnames(x$Tr)
- if(hasArg(colors)) colors<-list(...)$colors
- else colors<-setNames(palette()[1:length(states)],states)
- plotSimmap(x$tree,lwd=lwd,colors=colors,type=type,offset=offset)
- }
-}
-
-## function finds the height of a given node
-## written by Liam Revell 2014, 2015, 2016
-nodeheight<-function(tree,node,...){
- if(hasArg(root.edge)) root.edge<-list(...)$root.edge
- else root.edge<-FALSE
- if(root.edge) ROOT<-if(!is.null(tree$root.edge)) tree$root.edge else 0
- else ROOT<-0
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- if(node==(Ntip(tree)+1)) h<-0
- else {
- a<-setdiff(c(getAncestors(tree,node),node),Ntip(tree)+1)
- h<-sum(tree$edge.length[sapply(a,function(x,e) which(e==x),e=tree$edge[,2])])
- }
- h+ROOT
-}
-
-# fast pairwise MRCA function
-# written by Liam Revell 2012, 2014, 2015
-fastMRCA<-function(tree,sp1,sp2){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- x<-match(sp1,tree$tip.label)
- y<-match(sp2,tree$tip.label)
- a<-c(x,getAncestors(tree,x))
- b<-c(y,getAncestors(tree,y))
- z<-a%in%b
- return(a[min(which(z))])
-}
-
-## function to find the height of the MRCA of sp1 & sp2
-## written by Liam J. Revell 2014, 2015
-fastHeight<-function(tree,sp1,sp2){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- if(is.null(tree$edge.length)) stop("tree should have edge lengths.")
- sp1<-which(tree$tip.label==sp1)
- sp2<-which(tree$tip.label==sp2)
- a1<-c(sp1,getAncestors(tree,sp1))
- a2<-c(sp2,getAncestors(tree,sp2))
- a12<-intersect(a1,a2)
- if(length(a12)>1){
- a12<-a12[2:length(a12)-1]
- h<-sapply(a12,function(i,tree) tree$edge.length[which(tree$edge[,2]==i)],tree=tree)
- return(sum(h))
- } else return(0)
-}
-
-## function gets ancestor node numbers, to be used internally by
-## written by Liam J. Revell 2014
-getAncestors<-function(tree,node,type=c("all","parent")){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- type<-type[1]
- if(type=="all"){
- aa<-vector()
- rt<-Ntip(tree)+1
- currnode<-node
- while(currnode!=rt){
- currnode<-getAncestors(tree,currnode,"parent")
- aa<-c(aa,currnode)
- }
- return(aa)
- } else if(type=="parent"){
- aa<-tree$edge[which(tree$edge[,2]==node),1]
- return(aa)
- } else stop("do not recognize type")
-}
-
-## function for midpoint rooting
-## written by Liam J. Revell 2014
-midpoint.root<-function(tree){
- D<-cophenetic(tree)
- dd<-max(D)
- ii<-which(D==dd)[1]
- ii<-c(ceiling(ii/nrow(D)),ii%%nrow(D))
- if(ii[2]==0) ii[2]<-nrow(D)
- spp<-rownames(D)[ii]
- nn<-which(tree$tip.label==spp[2])
- tree<-reroot(tree,nn,tree$edge.length[which(tree$edge[,2]==nn)])
- aa<-getAncestors(tree,which(tree$tip.label==spp[1]))
- D<-c(0,dist.nodes(tree)[which(tree$tip.label==spp[1]),aa])
- names(D)[1]<-which(tree$tip.label==spp[1])
- i<-0
- while(D[i+1]<(dd/2)) i<-i+1
- tree<-reroot(tree,as.numeric(names(D)[i]),D[i+1]-dd/2)
- tree
-}
-
-# function computes phylogenetic variance-covariance matrix, including for internal nodes
-# written by Liam J. Revell 2011, 2013, 2014, 2015
-vcvPhylo<-function(tree,anc.nodes=TRUE,...){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- # get & set optional arguments
- if(hasArg(internal)) internal<-list(...)$internal
- else internal<-anc.nodes
- if(internal!=anc.nodes){
- message(paste("arguments \"internal\" and \"anc.nodes\" are synonyms; setting internal =",anc.nodes))
- internal<-anc.nodes
- }
- if(hasArg(model)) model<-list(...)$model
- else model<-"BM"
- if(hasArg(tol)) tol<-list(...)$tol
- else tol<-1e-12
- if(model=="OU"){
- if(hasArg(alpha)) alpha<-list(...)$alpha
- else alpha<-0
- }
- if(model=="OU"&&alpha<tol) model<-"BM"
- if(model=="lambda"){
- if(hasArg(lambda)){
- lambda<-list(...)$lambda
- tree<-lambdaTree(tree,lambda)
- } else model<-"BM"
- model<-"BM"
- }
- if(model=="EB"){
- if(hasArg(r)){
- r<-list(...)$r
- tree<-ebTree(tree,r)
- } else model<-"BM"
- }
- # done settings
- n<-Ntip(tree)
- h<-nodeHeights(tree)[order(tree$edge[,2]),2]
- h<-c(h[1:n],0,h[(n+1):length(h)])
- M<-mrca(tree,full=internal)[c(1:n,internal*(n+2:tree$Nnode)),c(1:n,internal*(n+2:tree$Nnode))]
- C<-matrix(h[M],nrow(M),ncol(M))
- if(internal) rownames(C)<-colnames(C)<-c(tree$tip.label,n+2:tree$Nnode)
- else rownames(C)<-colnames(C)<-tree$tip.label
- if(model=="OU"){
- D<-dist.nodes(tree)
- rownames(D)[1:n]<-colnames(D)[1:n]<-tree$tip.label
- D<-D[rownames(C),colnames(C)]
- # not sure
- C<-(1-exp(-2*alpha*C))*exp(-alpha*D)/(2*alpha) # Hansen (2007)
- # C<-(1-exp(-2*alpha*C))*exp(-2*alpha*(1-C))/(2*alpha) # Butler & King (2004)
- }
- return(C)
-}
-
-## simplified lambdaTree to be used internally by vcvPhylo
-## written by Liam J. Revell 2014
-lambdaTree<-function(tree,lambda){
- ii<-which(tree$edge[,2]>Ntip(tree))
- H1<-nodeHeights(tree)
- tree$edge.length[ii]<-lambda*tree$edge.length[ii]
- H2<-nodeHeights(tree)
- tree$edge.length[-ii]<-tree$edge.length[-ii]+ H1[-ii,2]-H2[-ii,2]
- tree
-}
-
-## di2multi method for tree with mapped state
-## written by Liam J. Revell 2013, 2015, 2016
-di2multi.simmap<-function(phy,...){
- if(hasArg(tol)) tol<-list(...)$tol
- else tol<-1e-08
- if(!inherits(phy,"phylo")) stop("tree should be an object of class \"phylo\".")
- if(is.null(phy$maps)){
- cat("Warning: tree does not contain mapped state. Using di2multi.\n")
- return(di2multi(phy,tol))
- }
- N<-length(phy$tip.label)
- n<-length(intersect(which(phy$edge.length<tol),which(phy$edge[,2]>N)))
- if(n==0) return(phy)
- edge<-phy$edge
- edge[edge>N]<--edge[edge>N]+N
- edge.length<-phy$edge.length
- maps<-phy$maps
- Nnode<-phy$Nnode
- for(i in 1:n){
- ii<-intersect(which(edge.length<tol),which(edge[,2]<0))[1]
- node<-edge[ii,2]
- edge[edge==node]<-edge[ii,1]
- jj<-which(apply(edge,1,function(x) x[1]==x[2]))[1]
- edge<-edge[-jj,]
- edge.length<-edge.length[-jj]
- maps<-maps[-jj]
- Nnode<-Nnode-1
- }
- nn<-sort(unique(edge[edge<0]),decreasing=TRUE)
- mm<-1:Nnode+N
- for(i in 1:length(edge)) if(edge[i]%in%nn) edge[i]<-mm[which(nn==edge[i])]
- mapped.edge<-makeMappedEdge(edge,maps)
- tt<-list(edge=edge,Nnode=Nnode,tip.label=phy$tip.label,edge.length=edge.length,
- maps=maps,mapped.edge=mapped.edge)
- class(tt)<-"phylo"
- if(!is.null(attr(phy,"order"))) attr(tt,"order")<-attr(phy,"order")
- if(!is.null(phy$node.states)) tt$node.states<-getStates(tt,"nodes")
- if(!is.null(phy$states)) tt$states<-getStates(tt,"tips")
- return(tt)
-}
-
-# returns the heights of each node
-# written by Liam J. Revell 2011, 2012, 2013, 2015, 2016
-# modified by Klaus Schliep 2017
-nodeHeights<-function(tree,...){
- if(hasArg(root.edge)) root.edge<-list(...)$root.edge
- else root.edge<-FALSE
- if(root.edge) ROOT<-if(!is.null(tree$root.edge)) tree$root.edge else 0
- else ROOT<-0
- nHeight <- function(tree){
- tree <- reorder(tree)
- edge <- tree$edge
- el <- tree$edge.length
- res <- numeric(max(tree$edge))
- for(i in seq_len(nrow(edge))) res[edge[i,2]] <- res[edge[i,1]] + el[i]
- res
- }
- nh <- nHeight(tree)
- return(matrix(nh[tree$edge], ncol=2L)+ROOT)
-}
-
-## function drops all the leaves from the tree & collapses singleton nodes
-## written by Liam J. Revell 2013, 2014, 2015
-drop.leaves<-function(tree,...){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- ## optional arguments
- if(hasArg(keep.tip.labels)) keep.tip.labels<-list(...)$keep.tip.labels
- else keep.tip.labels<-FALSE
- ## end optional arguments
- n<-Ntip(tree)
- edge<-tree$edge
- edge[edge>n]<--edge[edge>n]+n
- ii<-which(edge[,2]>0)
- edge<-edge[-ii,]
- if(!is.null(tree$edge.length)){
- edge.length<-tree$edge.length
- edge.length<-edge.length[-ii]
- }
- zz<-sapply(edge[,2],function(x,y) !(x%in%y),y=edge[,1])
- if(is.null(tree$node.label)) tree$node.label<-1:tree$Nnode+n
- nn<-matrix(tree$node.label[-edge],nrow(edge),ncol(edge))
- tip.label<-nn[zz,2]
- node.label<-c(nn[1,1],nn[!zz,2])
- edge[zz,2]<-1:sum(zz)
- Nnode<-length(unique(edge[edge<0]))
- rr<-cbind(sort(unique(edge[edge<0]),decreasing=TRUE),1:Nnode+sum(zz))
- for(i in 1:nrow(rr)) edge[edge==rr[i,1]]<-rr[i,2]
- tt<-list(edge=edge,Nnode=Nnode,tip.label=tip.label,edge.length=edge.length,node.label=node.label)
- class(tt)<-"phylo"
- tt<-collapse.singles(tt)
- if(keep.tip.labels){
- for(i in 1:length(tt$tip.label)){
- yy<-getDescendants(tree,node=which(tree$node.label==tt$tip.label[i])+n)
- tt$tip.label[i]<-paste(tree$tip.label[yy[yy<=n]],collapse=",")
- }
- }
- return(tt)
-}
-
-# function rounds the branch lengths of the tree & applies rounding to simmap tree
-# written by Liam J. Revell 2012, 2013, 2015
-roundBranches<-function(tree,digits=0){
- if(inherits(tree,"multiPhylo")){
- trees<-lapply(tree,roundBranches,digits=digits)
- class(trees)<-"multiPhylo"
- return(trees)
- } else if(inherits(tree,"phylo")) {
- tree$edge.length<-round(tree$edge.length,digits)
- if(!is.null(tree$maps)){
- for(i in 1:nrow(tree$edge)){
- temp<-tree$maps[[i]]/sum(tree$maps[[i]])
- tree$maps[[i]]<-temp*tree$edge.length[i]
- }
- }
- if(!is.null(tree$mapped.edge)){
- a<-vector()
- for(i in 1:nrow(tree$edge)) a<-c(a,names(tree$maps[[i]]))
- a<-unique(a)
- tree$mapped.edge<-matrix(data=0,length(tree$edge.length),length(a),dimnames=list(apply(tree$edge,1,function(x) paste(x,collapse=",")),state=a))
- for(i in 1:length(tree$maps)) for(j in 1:length(tree$maps[[i]])) tree$mapped.edge[i,names(tree$maps[[i]])[j]]<-tree$mapped.edge[i,names(tree$maps[[i]])[j]]+tree$maps[[i]][j]
- }
- return(tree)
- } else stop("tree should be an object of class \"phylo\" or \"multiPhylo\".")
-}
-
-# function to merge mapped states
-# written by Liam J. Revell 2013, 2015, 2019
-mergeMappedStates<-function(tree,old.states,new.state){
- if(inherits(tree,"multiSimmap")){
- tree<-unclass(tree)
- tree<-lapply(tree,mergeMappedStates,old.states=old.states,new.state=new.state)
- class(tree)<-c("multiSimmap","multiPhylo")
- } else if(inherits(tree,"simmap")) {
- maps<-tree$maps
- rr<-function(map,oo,nn){
- for(i in 1:length(map)) if(names(map)[i]%in%oo) names(map)[i]<-nn
- map
- }
- mm<-function(map){
- if(length(map)>1){
- new.map<-vector()
- j<-1
- new.map[j]<-map[1]
- names(new.map)[j]<-names(map)[1]
- for(i in 2:length(map)){
- if(names(map)[i]==names(map)[i-1]){
- new.map[j]<-map[i]+new.map[j]
- names(new.map)[j]<-names(map)[i]
- } else {
- j<-j+1
- new.map[j]<-map[i]
- names(new.map)[j]<-names(map)[i]
- }
-
- }
- map<-new.map
- }
- map
- }
- maps<-lapply(maps,rr,oo=old.states,nn=new.state)
- if(length(old.states)>1){
- maps<-lapply(maps,mm)
- mapped.edge<-tree$mapped.edge
- mapped.edge<-cbind(rowSums(mapped.edge[,colnames(mapped.edge)%in%old.states]),
- mapped.edge[,setdiff(colnames(mapped.edge),old.states)])
- colnames(mapped.edge)<-c(new.state,setdiff(colnames(tree$mapped.edge),old.states))
- } else {
- mapped.edge<-tree$mapped.edge
- colnames(mapped.edge)[which(colnames(mapped.edge)==old.states)]<-new.state
- }
- tree$maps<-maps
- tree$mapped.edge<-mapped.edge
- } else stop("tree should be an object of class \"simmap\" or \"multiSimmap\".")
- return(tree)
-}
-
-# function rotates a node or multiple nodes
-# written by Liam J. Revell 2013, 2015
-rotateNodes<-function(tree,nodes,polytom=c(1,2),...){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- n<-Ntip(tree)
- if(nodes[1]=="all") nodes<-1:tree$Nnode+n
- for(i in 1:length(nodes)) tree<-rotate(tree,nodes[i],polytom)
- if(hasArg(reversible)) reversible<-list(...)$reversible
- else reversible<-TRUE
- if(reversible){
- ii<-which(tree$edge[,2]<=n)
- jj<-tree$edge[ii,2]
- tree$edge[ii,2]<-1:n
- tree$tip.label<-tree$tip.label[jj]
- }
- return(tree)
-}
-
-# function simulates random sampling from xbar, xvar, with sample sizes n
-# written by Liam J. Revell 2012
-sampleFrom<-function(xbar=0,xvar=1,n=1,randn=NULL,type="norm"){
- if(length(xvar)==1&&length(xbar)!=length(xvar)) xvar<-rep(xvar,length(xbar))
- if(!is.null(randn))
- for(i in 1:length(xbar)) n[i]<-floor(runif(n=1,min=randn[1],max=(randn[2]+1)))
- x<-vector()
-
- for(i in 1:length(xbar)){
- y<-rnorm(n=n[i],mean=xbar[i],sd=sqrt(xvar[i]))
- names(y)<-rep(names(xbar)[i],length(y))
- x<-c(x,y)
- }
- return(x)
-}
-
-# function adds a new tip to the tree
-# written by Liam J. Revell 2012, 2013, 2014, 2015
-bind.tip<-function(tree,tip.label,edge.length=NULL,where=NULL,position=0,interactive=FALSE,...){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- use.edge.length<-if(is.null(tree$edge.length)) FALSE else TRUE
- if(use.edge.length==FALSE) tree<-compute.brlen(tree)
- if(interactive==TRUE){
- plotTree(tree,...)
- cat(paste("Click where you would like to bind the tip \"",tip.label,"\"\n",sep=""))
- flush.console()
- obj<-get.treepos(message=FALSE)
- where<-obj$where
- position<-obj$pos
- } else if(is.null(where)) where<-Ntip(tree)+1
- if(where<=Ntip(tree)&&position==0){
- pp<-1e-12
- if(tree$edge.length[which(tree$edge[,2]==where)]<=1e-12){
- tree$edge.length[which(tree$edge[,2]==where)]<-2e-12
- ff<-TRUE
- } else ff<-FALSE
- } else pp<-position
- if(is.null(edge.length)&&is.ultrametric(tree)){
- H<-nodeHeights(tree)
- if(where==(Ntip(tree)+1)) edge.length<-max(H)
- else edge.length<-max(H)-H[tree$edge[,2]==where,2]+position
- }
- tip<-list(edge=matrix(c(2,1),1,2),
- tip.label=tip.label,
- edge.length=edge.length,
- Nnode=1)
- class(tip)<-"phylo"
- obj<-bind.tree(tree,tip,where=where,position=pp)
- if(where<=Ntip(tree)&&position==0){
- nn<-obj$edge[which(obj$edge[,2]==which(obj$tip.label==tip$tip.label)),1]
- obj$edge.length[which(obj$edge[,2]==nn)]<-obj$edge.length[which(obj$edge[,2]==nn)]+1e-12
- obj$edge.length[which(obj$edge[,2]==which(obj$tip.label==tip$tip.label))]<-0
- obj$edge.length[which(obj$edge[,2]==which(obj$tip.label==tree$tip.label[where]))]<-0
- }
- root.time<-if(!is.null(obj$root.time)) obj$root.time else NULL
- obj<-untangle(obj,"read.tree")
- if(!is.null(root.time)) obj$root.time<-root.time
- if(interactive) plotTree(obj,...)
- if(!use.edge.length) obj$edge.length<-NULL
- obj
-}
-
-## function collapses the subtree descended from node to a star tree
-## written by Liam J. Revell 2013, 2015, 2019
-collapse.to.star<-function(tree,node){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- if(node==(Ntip(tree)+1)){
- object<-list(edge=cbind(rep(Ntip(tree)+1,Ntip(tree)),1:Ntip(tree)),
- tip.label=tree$tip.label,Nnode=1)
- if(!is.null(tree$edge.length)) object$edge.length<-sapply(1:Ntip(tree),nodeheight,tree=tree)
- class(object)<-"phylo"
- tree<-object
- } else {
- nel<-if(is.null(tree$edge.length)) TRUE else FALSE
- if(nel) tree$edge.length<-rep(1,nrow(tree$edge))
- tt<-splitTree(tree,split=list(node=node,
- bp=tree$edge.length[which(tree$edge[,2]==node)]))
- ss<-starTree(species=tt[[2]]$tip.label,
- branch.lengths=diag(vcv(tt[[2]])))
- ss$root.edge<-0
- tree<-paste.tree(tt[[1]],ss)
- if(nel) tree$edge.length<-NULL
- }
- tree
-}
-
-## function returns the MRCA, or its height above the root, for a set of taxa (in tips)
-## written by Liam Revell 2012, 2013, 2015, 2016
-findMRCA<-function(tree,tips=NULL,type=c("node","height")){
- type<-type[1]
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- if(is.null(tips)){
- X<-mrca(tree)
- if(type=="height"){
- H<-nodeHeights(tree)
- X<-apply(X,c(1,2),function(x,y,z) y[which(z==x)[1]],y=H,z=tree$edge)
- }
- return(X)
- } else {
- node<-getMRCA(tree,tips)
- if (type == "node") return(node)
- else if(type=="height") return(nodeheight(tree,node))
- }
-}
-
-# function works like extract.clade in ape but will preserve a discrete character mapping
-# written by Liam J. Revell 2013
-extract.clade.simmap<-function(tree,node){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- x<-getDescendants(tree,node)
- x<-x[x<=Ntip(tree)]
- drop.tip.simmap(tree,tree$tip.label[-x])
-}
-
-# function gets all subtrees that cannot be further subdivided into two clades of >= clade.size
-# written by Liam J. Revell 2013, 2015
-getCladesofSize<-function(tree,clade.size=2){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- n<-Ntip(tree)
- nn<-1:(tree$Nnode+n)
- ndesc<-function(tree,node){
- x<-getDescendants(tree,node)
- sum(x<=Ntip(tree))
- }
- dd<-setNames(sapply(nn,ndesc,tree=tree),nn)
- aa<-n+1 # root
- nodes<-vector()
- while(length(aa)){
- bb<-lapply(aa,function(x,tree) tree$edge[which(tree$edge[,1]==x),2],tree=tree)
- cc<-lapply(bb,function(x) dd[as.character(x)])
- gg<-sapply(cc,function(x,cs) any(x<cs),cs=clade.size)
- nodes<-c(nodes,aa[gg])
- aa<-unlist(bb[!gg])
- }
- trees<-lapply(nodes,extract.clade,phy=tree)
- class(trees)<-"multiPhylo"
- return(trees)
-}
-
-# function counts transitions from a mapped history
-# written by Liam J. Revell 2013, 2015
-countSimmap<-function(tree,states=NULL,message=TRUE){
- if(inherits(tree,"multiPhylo")){
- ff<-function(zz){
- XX<-countSimmap(zz,states,message)
- setNames(c(XX$N,as.vector(t(XX$Tr))),c("N",
- sapply(rownames(XX$Tr),paste,colnames(XX$Tr),sep=",")))
- }
- tree<-unclass(tree)
- XX<-t(sapply(tree,ff))
- if(!message) return(XX)
- else return(list(Tr=XX,message=
- c("Column N is the total number of character changes on the tree",
- "Other columns give transitions x,y from x->y")))
- } else if(inherits(tree,"phylo")) {
- n<-sum(sapply(tree$maps,length))-nrow(tree$edge)
- if(is.null(states)) states<-colnames(tree$mapped.edge)
- m<-length(states)
- TT<-matrix(NA,m,m,dimnames=list(states,states))
- gg<-function(map,a,b){
- if(length(map)==1) zz<-0
- else {
- zz<-0; i<-2
- while(i<=length(map)){
- if(names(map)[i]==b&&names(map)[i-1]==a) zz<-zz+1
- i<-i+1
- }
- }
- return(zz)
- }
- for(i in 1:m) for(j in 1:m)
- if(i==j) TT[i,j]<-0
- else TT[i,j]<-sum(sapply(tree$maps,gg,a=states[i],b=states[j]))
- if(!message) return(list(N=n,Tr=TT))
- else return(list(N=n,Tr=TT,message=c(
- "N is the total number of character changes on the tree",
- "Tr gives the number of transitions from row state->column state")))
- }
-}
-
-# function to match nodes between trees
-# written by Liam J. Revell 2012, 2013, 2015
-matchNodes<-function(tr1,tr2,method=c("descendants","distances"),...){
- if(!inherits(tr1,"phylo")||!inherits(tr1,"phylo")) stop("tr1 & tr2 should both be objects of class \"phylo\".")
- if(hasArg(quiet)) quiet<-list(...)$quiet
- else quiet<-FALSE
- method<-method[1]
- method<-matchType(method,c("descendants","distances"))
- if(method=="descendants"){
- desc.tr1<-lapply(1:tr1$Nnode+length(tr1$tip),function(x) extract.clade(tr1,x)$tip.label)
- names(desc.tr1)<-1:tr1$Nnode+length(tr1$tip)
- desc.tr2<-lapply(1:tr2$Nnode+length(tr2$tip),function(x) extract.clade(tr2,x)$tip.label)
- names(desc.tr2)<-1:tr2$Nnode+length(tr2$tip)
- Nodes<-matrix(NA,length(desc.tr1),2,dimnames=list(NULL,c("tr1","tr2")))
- for(i in 1:length(desc.tr1)){
- Nodes[i,1]<-as.numeric(names(desc.tr1)[i])
- for(j in 1:length(desc.tr2))
- if(all(desc.tr1[[i]]%in%desc.tr2[[j]])&&all(desc.tr2[[j]]%in%desc.tr1[[i]]))
- Nodes[i,2]<-as.numeric(names(desc.tr2)[j])
- }
- } else if(method=="distances"){
- if(hasArg(tol)) tol<-list(...)$tol
- else tol<-1e-6
- if(hasArg(corr)) corr<-list(...)$corr
- else corr<-FALSE
- if(corr) tr1$edge.length<-tr1$edge.length/max(nodeHeights(tr1))
- if(corr) tr2$edge.length<-tr2$edge.length/max(nodeHeights(tr2))
- D1<-dist.nodes(tr1)[1:length(tr1$tip),1:tr1$Nnode+length(tr1$tip)]
- D2<-dist.nodes(tr2)[1:length(tr2$tip),1:tr2$Nnode+length(tr2$tip)]
- rownames(D1)<-tr1$tip.label
- rownames(D2)<-tr2$tip.label
- common.tips<-intersect(tr1$tip.label,tr2$tip.label)
- D1<-D1[common.tips,]
- D2<-D2[common.tips,]
- Nodes<-matrix(NA,tr1$Nnode,2,dimnames=list(NULL,c("tr1","tr2")))
- for(i in 1:tr1$Nnode){
- if(corr) z<-apply(D2,2,function(X,y) cor(X,y),y=D1[,i])
- else z<-apply(D2,2,function(X,y) 1-sum(abs(X-y)),y=D1[,i])
- Nodes[i,1]<-as.numeric(colnames(D1)[i])
- if(any(z>=(1-tol))){
- a<-as.numeric(names(which(z>=(1-tol))))
- if(length(a)==1) Nodes[i,2]<-a
- else {
- Nodes[i,2]<-a[1]
- if(!quiet) warning("polytomy detected; some node matches may be arbitrary")
- }
- }
- }
- }
- return(Nodes)
-}
-
-# function applies the branch lengths of a reference tree to a second tree, including mappings
-
-# written by Liam J. Revell 2012, 2015
-applyBranchLengths<-function(tree,edge.length){
- if(inherits(tree,"multiPhylo")){
- trees<-lapply(tree,applyBranchLengths,edge.length=edge.length)
- class(trees)<-"multiPhylo"
- return(trees)
- } else if(inherits(tree,"phylo")) {
- tree$edge.length<-edge.length
- if(!is.null(tree$maps)){
- for(i in 1:nrow(tree$edge)){
- temp<-tree$maps[[i]]/sum(tree$maps[[i]])
- tree$maps[[i]]<-temp*tree$edge.length[i]
- }
- }
- if(!is.null(tree$mapped.edge)){
- a<-vector()
- for(i in 1:nrow(tree$edge)) a<-c(a,names(tree$maps[[i]]))
- a<-unique(a)
- tree$mapped.edge<-matrix(data=0,length(tree$edge.length),length(a),dimnames=list(apply(tree$edge,1,function(x) paste(x,collapse=",")),state=a))
- for(i in 1:length(tree$maps)) for(j in 1:length(tree$maps[[i]])) tree$mapped.edge[i,names(tree$maps[[i]])[j]]<-tree$mapped.edge[i,names(tree$maps[[i]])[j]]+tree$maps[[i]][j]
- }
- return(tree)
- }
-}
-
-# function to compute phylogenetic VCV using joint Pagel's lambda
-# written by Liam Revell 2011
-
-phyl.vcv<-function(X,C,lambda){
- C<-lambda.transform(lambda,C)
- invC<-solve(C)
- a<-matrix(colSums(invC%*%X)/sum(invC),ncol(X),1)
- A<-matrix(rep(a,nrow(X)),nrow(X),ncol(X),byrow=T)
- V<-t(X-A)%*%invC%*%(X-A)/(nrow(C)-1)
- return(list(C=C,R=V,alpha=a))
-}
-
-# lambda transformation of C
-# written by Liam Revell 2011
-lambda.transform<-function(lambda,C){
- if(lambda==1) return(C)
- else {
- V<-diag(diag(C))
- C<-C-V
- C.lambda<-(V+lambda*C)
- return(C.lambda)
- }
-}
-
-# likelihood function for joint estimation of lambda for multiple traits
-# written by Liam Revell 2011/2012
-likMlambda<-function(lambda,X,C){
- # compute R, conditioned on lambda
- temp<-phyl.vcv(X,C,lambda);
- C<-temp$C; R<-temp$R; a<-temp$alpha
- # prep
- n<-nrow(X); m<-ncol(X); D<-matrix(0,n*m,m)
- for(i in 1:(n*m)) for(j in 1:m) if((j-1)*n<i&&i<=j*n) D[i,j]=1.0
- y<-as.matrix(as.vector(X))
- # compute the log-likelihood
- kronRC<-kronecker(R,C)
- logL<--t(y-D%*%a)%*%solve(kronRC,y-D%*%a)/2-n*m*log(2*pi)/2-determinant(kronRC,logarithm=TRUE)$modulus/2
- return(logL)
-}
-
-# function matches data to tree
-# written by Liam J. Revell 2011, 2015
-matchDatatoTree<-function(tree,x,name){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- if(is.matrix(x)) x<-x[,1]
- if(is.null(names(x))){
- if(length(x)==Ntip(tree)){
- print(paste(name,"has no names; assuming x is in the same order as tree$tip.label"))
- names(x)<-tree$tip.label
- } else
-
- stop(paste(name,"has no names and is a different length than tree$tip.label"))
-
- }
- if(any(is.na(match(names(x),tree$tip.label)))){
- print(paste("some species in",name,"are missing from tree, dropping missing taxa from",name))
- x<-x[intersect(tree$tip.label,names(x))]
- }
- return(x)
-}
-
-# function matches tree to data
-# written by Liam J. Revell 2011, 2015
-matchTreetoData<-function(tree,x,name){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- if(any(is.na(match(tree$tip.label,names(x))))){
- print(paste("some species in tree are missing from",name,", dropping missing taxa from the tree"))
- tree<-drop.tip(tree,setdiff(tree$tip.label,names(x)))
- }
- if(any(is.na(x))){
- print(paste("some data in",name,"given as 'NA', dropping corresponding species from tree"))
- tree<-drop.tip(tree,names(which(is.na(x))))
- }
- return(tree)
-}
-
-# function finds the maximum value of Pagel's lambda
-# written by Liam J. Revell 2011
-maxLambda<-function(tree){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- if(is.ultrametric(tree)){
- H<-nodeHeights(tree)
- return(max(H[,2])/max(H[,1]))
- } else return(1)
-}
-
-# function reorders the columns of mapped.edge from a set of simmap trees
-
-# written by Liam J. Revell 2013, 2015
-orderMappedEdge<-function(trees,ordering=NULL){
- if(!inherits(trees,"phylo")&&!inherits(trees,"multiPhylo"))
- stop("trees should be an object of class \"phylo\" or \"multiPhylo\".")
- f1<-function(tree,ordering){
- mapped.edge<-matrix(0,nrow(tree$mapped.edge),length(ordering),
- dimnames=list(rownames(tree$mapped.edge),ordering))
- mapped.edge[,colnames(tree$mapped.edge)]<-tree$mapped.edge
- tree$mapped.edge<-mapped.edge
- return(tree)
- }
- f2<-function(tree) colnames(tree$mapped.edge)
- if(inherits(trees,"phylo")) states<-colnames(trees$mapped.edge)
- else if(inherits(trees,"multiPhylo")) states<-unique(as.vector(sapply(trees,f2)))
- if(length(ordering)>1) if(length(intersect(states,ordering))<length(states)){
- warning("not all states represented in input ordering; setting to default")
- ordering<-NULL
- }
- if(is.null(ordering)) ordering<-"alphabetical"
- if(length(ordering)==1){
- ordering<-matchType(ordering,c("alphabetical","numerical"))
- if(ordering=="alphabetical") ordering<-sort(states)
- else if(ordering=="numerical") ordering<-as.character(sort(as.numeric(states)))
- }
- if(inherits(trees,"phylo")) trees<-f1(trees,ordering)
- else {
- trees<-lapply(trees,f1,ordering=ordering)
- class(trees)<-"multiPhylo"
- }
- return(trees)
-}
-
-# function gets sister node numbers or names
-# written by Liam J. Revell 2013, 2015
-getSisters<-function(tree,node,mode=c("number","label")){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- mode<-mode[1]
- if(is.character(node)) node<-match(node,c(tree$tip.label,tree$node.label))
- sisters<-tree$edge[which(tree$edge[,1]==tree$edge[which(tree$edge[,2]==node),1]),2]
- sisters<-setdiff(sisters,node)
- if(mode=="number") return(sisters)
- else if(mode=="label"){
- result<-list()
- n<-Ntip(tree)
- if(is.null(tree$node.label)&&any(sisters>n)) result$nodes<-sisters[which(sisters>n)]
- else if(any(sisters>n)) result$nodes<-tree$node.label[sisters[which(sisters>n)]-n]
- if(any(sisters<=n)) result$tips<-tree$tip.label[sisters[which(sisters<=n)]]
- return(result)
- }
-}
-
-# gets descendant node numbers
-# written by Liam Revell 2012, 2013, 2014
-getDescendants<-function(tree,node,curr=NULL){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- if(is.null(curr)) curr<-vector()
- daughters<-tree$edge[which(tree$edge[,1]==node),2]
- curr<-c(curr,daughters)
- if(length(curr)==0&&node<=Ntip(tree)) curr<-node
- w<-which(daughters>Ntip(tree))
- if(length(w)>0) for(i in 1:length(w))
- curr<-getDescendants(tree,daughters[w[i]],curr)
- return(curr)
-}
-
-# function computes vcv for each state, and stores in array
-# written by Liam J. Revell 2011, 2012, 2016
-multiC<-function(tree,internal=FALSE){
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- if(!inherits(tree,"simmap")) stop("tree should be an object of class \"simmap\".")
- m<-ncol(tree$mapped.edge)
- # compute separate C for each state
- mC<-list()
- for(i in 1:m){
- mtree<-list(edge=tree$edge,
- Nnode=tree$Nnode,
- tip.label=tree$tip.label,
- edge.length=tree$mapped.edge[,i])
- class(mtree)<-"phylo"
- mC[[i]]<-if(internal) vcvPhylo(mtree,internal=TRUE) else vcv.phylo(mtree)
- }
- names(mC)<-colnames(tree$mapped.edge)
- mC
-}
-
-# function pastes subtree onto tip
-# written by Liam Revell 2011, 2015
-paste.tree<-function(tr1,tr2){
- if(!inherits(tr1,"phylo")||!inherits(tr2,"phylo")) stop("tr1 & tr2 should be objects of class \"phylo\".")
- if(length(tr2$tip)>1){
- temp<-tr2$root.edge; tr2$root.edge<-NULL
- tr1$edge.length[match(which(tr1$tip.label=="NA"),tr1$edge[,2])]<-tr1$edge.length[match(which(tr1$tip.label=="NA"),tr1$edge[,2])]+temp
- }
- tr.bound<-bind.tree(tr1,tr2,where=which(tr1$tip.label=="NA"))
- return(tr.bound)
-}
-
-# match type
-# written by Liam J. Revell 2012
-matchType<-function(type,types){
- for(i in 1:length(types))
- if(all(strsplit(type,split="")[[1]]==strsplit(types[i],split="")[[1]][1:length(strsplit(type,split="")[[1]])]))
- type=types[i]
- return(type)
-}
-
-## function 'untangles' (or attempts to untangle) a tree with crossing branches
-## written by Liam J. Revell 2013, 2015, 2020, 2021
-untangle<-function(tree,method=c("reorder","read.tree")){
- if(inherits(tree,"multiPhylo")){
- tree<-lapply(tree,untangle,method=method)
- class(tree)<-"multiPhylo"
- } else {
- if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
- obj<-attributes(tree)
- method<-method[1]
- if(method=="reorder") tree<-reorder(reorder(tree,"pruningwise"))
- else if(method=="read.tree"){
- tip.label<-tree$tip.label
- tree$tip.label<-1:Ntip(tree)
- if(inherits(tree,"simmap"))
- tree<-read.simmap(text=capture.output(write.simmap(tree,file=stdout())))
- else tree<-if(Ntip(tree)>1) read.tree(text=write.tree(tree)) else read.newick(text=write.tree(tree))
- tree$tip.label<-tip.label[as.numeric(tree$tip.label)]
- }
- ii<-!names(obj)%in%names(attributes(tree))
- attributes(tree)<-c(attributes(tree),obj[ii])
- }
- tree
-}
-
+## some utility functions
+## written by Liam J. Revell 2011, 2012, 2013, 2014, 2015, 2016, 2017,
+## 2018, 2019, 2020, 2021, 2022, 2023
+
+## function to rescale simmap style trees
+## written by Liam J. Revell 2012, 2013, 2014, 2015, 2017, 2023
+
+rescale<-function(x,...) UseMethod("rescale")
+
+rescale.default<-function(x,...){
+ warning(paste(
+ "rescale does not know how to handle objects of class ",class(x),".\n",
+ "if",class(x),"= \"phylo\" load geiger package to rescale.\n"))
+}
+
+rescale.simmap<-function(x, model="depth", ...) rescaleSimmap(x,...)
+
+rescale.multiSimmap<-function(x, model="depth", ...) rescaleSimmap(x,...)
+
+rescaleSimmap<-function(tree,...){
+ if(inherits(tree,"multiSimmap")){
+ cls<-class(tree)
+ trees<-unclass(tree)
+ trees<-lapply(trees,rescaleSimmap,...)
+ class(trees)<-cls
+ return(trees)
+ } else if(inherits(tree,"simmap")){
+ if(hasArg(lambda)) lambda<-list(...)$lambda
+ else lambda<-1
+ if(hasArg(totalDepth)) depth<-totalDepth<-list(...)$totalDepth
+ else if(hasArg(depth)) depth<-totalDepth<-list(...)$depth
+ else depth<-totalDepth<-max(nodeHeights(tree))
+ if(lambda!=1){
+ e<-lambdaTree(tree,lambda)$edge.length/tree$edge.length
+ tree$edge.length<-tree$edge.length*e
+ tree$maps<-mapply(function(x,y) x*y,tree$maps,e)
+ tree$mapped.edge<-tree$mapped.edge*matrix(rep(e,ncol(tree$mapped.edge)),length(e),ncol(tree$mapped.edge))
+ }
+ if(depth!=max(nodeHeights(tree))){
+ h<-max(nodeHeights(tree))
+ s<-depth/h
+ tree$edge.length<-tree$edge.length*s
+ tree$maps<-lapply(tree$maps,"*",s)
+ tree$mapped.edge<-tree$mapped.edge*s
+ }
+ return(tree)
+ } else message("tree should be an object of class \"simmap\" or \"multiSimmap\"")
+}
+
+
+## function forces a tree to be ultrametric using two different methods
+## written by Liam J. Revell 2017, 2021, 2022
+
+force.ultrametric<-function(tree,method=c("nnls","extend"),...){
+ if(hasArg(message)) message<-list(...)$message
+ else message<-TRUE
+ if(message){
+ cat("***************************************************************\n")
+ cat("* Note: *\n")
+ cat("* force.ultrametric does not include a formal method to *\n")
+ cat("* ultrametricize a tree & should only be used to coerce *\n")
+ cat("* a phylogeny that fails is.ultramtric due to rounding -- *\n")
+ cat("* not as a substitute for formal rate-smoothing methods. *\n")
+ cat("***************************************************************\n")
+ }
+ method<-method[1]
+ if(method=="nnls") tree<-nnls.tree(cophenetic(tree),tree,
+ method="ultrametric",rooted=is.rooted(tree),trace=0)
+ else if(method=="extend"){
+ h<-diag(vcv(tree))
+ d<-max(h)-h
+ ii<-sapply(1:Ntip(tree),function(x,y) which(y==x),
+ y=tree$edge[,2])
+ tree$edge.length[ii]<-tree$edge.length[ii]+d
+ } else
+ cat("method not recognized: returning input tree\n\n")
+ tree
+}
+
+## function to summarize the results of stochastic mapping
+## written by Liam J. Revell 2013, 2014, 2015, 2021, 2022
+describe.simmap<-function(tree,...){
+ if(hasArg(plot)) plot<-list(...)$plot
+ else plot<-FALSE
+ if(hasArg(check.equal)) check.equal<-list(...)$check.equal
+ else check.equal<-FALSE
+ if(hasArg(message)) message<-list(...)$message
+ else message<-FALSE
+ if(hasArg(ref.tree)) ref.tree<-list(...)$ref.tree
+ else ref.tree<-NULL
+ if(inherits(tree,"multiPhylo")){
+ if(check.equal){
+ TT<-sapply(tree,function(x,y) sapply(y,all.equal.phylo,x),y=tree)
+ check<-all(TT)
+ if(!check) cat("Note: Some trees are not equal.\nA \"reference\" tree will be computed if none was provided.\n\n")
+ } else check<-TRUE
+ if(is.null(ref.tree)&&check){
+ YY<-getStates(tree,"both")
+ states<-sort(unique(as.vector(YY)))
+ ZZ<-t(apply(YY,1,function(x,levels,Nsim) summary(factor(x,levels))/Nsim,
+ levels=states,Nsim=length(tree)))
+ } else {
+ YY<-getStates(tree)
+ states<-sort(unique(as.vector(YY)))
+ if(is.null(ref.tree)){
+ cat("No reference tree provided & some trees are unequal.\nComputing majority-rule consensus tree.\n")
+ ref.tree<-consensus(tree,p=0.5)
+ }
+ YYp<-matrix(NA,ref.tree$Nnode,length(tree),dimnames=list(1:ref.tree$Nnode+Ntip(ref.tree),
+ NULL))
+ for(i in 1:length(tree)){
+ M<-matchNodes(ref.tree,tree[[i]])
+ jj<-sapply(M[,2],function(x,y) if(x%in%y) which(as.numeric(y)==x) else NA,
+ y=as.numeric(rownames(YY)))
+ YYp[,i]<-YY[jj,i]
+ }
+ ZZ<-t(apply(YYp,1,function(x,levels) summary(factor(x[!is.na(x)],
+ levels))/sum(!is.na(x)),levels=states))
+ }
+ XX<-countSimmap(tree,states,FALSE)
+ XX<-XX[,-(which(as.vector(diag(-1,length(states)))==-1)+1)]
+ AA<-t(sapply(unclass(tree),function(x) c(colSums(x$mapped.edge),sum(x$edge.length))))
+ colnames(AA)[ncol(AA)]<-"total"
+ BB<-getStates(tree,type="tips")
+ CC<-t(apply(BB,1,function(x,levels,Nsim) summary(factor(x,levels))/Nsim,levels=states,
+ Nsim=length(tree)))
+ x<-list(count=XX,times=AA,ace=ZZ,tips=CC,tree=tree,ref.tree=if(!is.null(ref.tree))
+ ref.tree else NULL)
+ class(x)<-"describe.simmap"
+ } else if(inherits(tree,"phylo")){
+ XX<-countSimmap(tree,message=FALSE)
+ YY<-getStates(tree)
+ states<-sort(unique(YY))
+ AA<-setNames(c(colSums(tree$mapped.edge),sum(tree$edge.length)),
+ c(colnames(tree$mapped.edge),"total"))
+ AA<-rbind(AA,AA/AA[length(AA)]); rownames(AA)<-c("raw","prop")
+ x<-list(N=XX$N,Tr=XX$Tr,times=AA,states=YY,tree=tree)
+ class(x)<-"describe.simmap"
+ }
+ if(message) print(x)
+ if(plot) plot(x)
+ x
+}
+
+## function to get states at internal nodes from simmap style trees
+## written by Liam J. Revell 2013, 2014, 2015, 2021
+getStates<-function(tree,type=c("nodes","tips","both")){
+ type<-type[1]
+ if(inherits(tree,"multiPhylo")){
+ tree<-unclass(tree)
+ obj<-lapply(tree,getStates,type=type)
+ nn<-names(obj[[1]])
+ y<-sapply(obj,function(x,n) x[n],n=nn)
+ } else if(inherits(tree,"phylo")){
+ if(type%in%c("nodes","both")){
+ a<-setNames(sapply(tree$maps,function(x) names(x)[1]),tree$edge[,1])
+ a<-a[as.character(Ntip(tree)+1:tree$Nnode)]
+ }
+ if(type%in%c("tips","both")){
+ b<-setNames(sapply(tree$maps,function(x) names(x)[length(x)]),tree$edge[,2])
+ b<-setNames(b[as.character(1:Ntip(tree))],tree$tip.label)
+ }
+ y<-if(type=="both") c(a,b) else if(type=="nodes") a else b
+ } else stop("tree should be an object of class \"phylo\" or \"multiPhylo\".")
+ return(y)
+}
+
+## di2multi & multi2di for "contMap" & "densityMap" object classes
+
+di2multi.contMap<-function(phy,...){
+ phy$tree<-di2multi(phy$tree,...)
+ phy
+}
+
+di2multi.densityMap<-function(phy,...){
+ phy$tree<-di2multi(phy$tree,...)
+ phy
+}
+
+multi2di.contMap<-function(phy,...){
+ phy$tree<-multi2di(phy$tree,...)
+ phy
+}
+
+multi2di.densityMap<-function(phy,...){
+ phy$tree<-multi2di(phy$tree,...)
+ phy
+}
+
+## multi2di for "simmap" object class
+
+multi2di.simmap<-function(phy,...){
+ obj<-multi2di(as.phylo(phy),...)
+ M<-rbind(matchNodes(obj,phy),
+ matchLabels(obj,phy))
+ obj$maps<-vector(mode="list",length=nrow(obj$edge))
+ for(i in 2:nrow(M)){
+ if(!is.na(M[i,2])){
+ obj$maps[[which(obj$edge[,2]==M[i,1])]]<-
+ phy$maps[[which(phy$edge[,2]==M[i,2])]]
+ } else {
+ ii<-which(obj$edge[,2]==getParent(obj,M[i,1]))
+ state<-names(obj$maps[[ii]])[length(obj$maps[[ii]])]
+ obj$maps[[which(obj$edge[,2]==M[i,1])]]<-
+ setNames(0,state)
+ }
+ }
+ obj$node.states<-getStates(obj,"nodes")
+ obj$states<-getStates(obj,"tips")
+ obj$mapped.edge<-makeMappedEdge(obj$edge,obj$maps)
+ class(obj)<-c("simmap",class(obj))
+ obj
+}
+
+## di2multi & multi2di for "multiSimmap" object class
+
+di2multi.multiSimmap<-function(phy,...){
+ obj<-lapply(phy,di2multi,...)
+ class(obj)<-c("multiSimmap","multiPhylo")
+ obj
+}
+multi2di.multiSimmap<-function(phy,...){
+ obj<-lapply(phy,multi2di,...)
+ class(obj)<-c("multiSimmap","multiPhylo")
+ obj
+}
+
+## function to rescale a tree according to an EB model
+## written by Liam J. Revell 2017
+
+ebTree<-function(tree,r){
+ if(r!=0){
+ H<-nodeHeights(tree)
+ e<-(exp(r*H[,2])-exp(r*H[,1]))/r
+ tree$edge.length<-e
+ }
+ tree
+}
+
+## function to expand clades in a plot by a given factor
+## written by Liam J. Revell 2017
+expand.clade<-function(tree,node,factor=5){
+ cw<-reorder(tree)
+ tips<-setNames(rep(1,Ntip(tree)),cw$tip.label)
+ get.tips<-function(node,tree){
+ dd<-getDescendants(tree,node)
+ tree$tip.label[dd[dd<=Ntip(tree)]]
+ }
+ desc<-unlist(lapply(node,get.tips,tree=cw))
+ for(i in 2:Ntip(cw)){
+ tips[i]<-tips[i-1]+
+ if(names(tips)[i]%in%desc){
+ 1
+ } else if(names(tips)[i-1]%in%desc){
+ 1
+ } else 1/factor
+ }
+ obj<-list(tree=tree,tips=tips)
+ class(obj)<-"expand.clade"
+ obj
+}
+
+## S3 print method for the object class "expand.clade"
+print.expand.clade<-function(x,...){
+ cat("An object of class \"expand.clade\" consisting of:\n")
+ cat(paste("(1) A phylogenetic tree (x$tree) with",Ntip(x$tree),
+ "tips and\n ",x$tree$Nnode,"internal nodes.\n"))
+ cat("(2) A vector (x$tips) containing the desired tip-spacing.\n\n")
+}
+
+## S3 plot method for the object class "expand.clade"
+plot.expand.clade<-function(x,...){
+ args<-list(...)
+ args$tree<-x$tree
+ args$tips<-x$tips
+ if(inherits(args$tree,"simmap")) do.call(plotSimmap,args)
+ else do.call(plotTree,args)
+}
+
+## function to add a geological or other temporal legend to a plotted tree
+## written by Liam J. Revell 2017, 2019
+geo.legend<-function(leg=NULL,colors=NULL,alpha=0.2,...){
+ if(hasArg(cex)) cex<-list(...)$cex
+ else cex<-par()$cex
+ if(hasArg(plot)) plot<-list(...)$plot
+ else plot<-TRUE
+ if(hasArg(show.lines)) show.lines<-list(...)$show.lines
+ else show.lines<-TRUE
+ obj<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ if(is.null(colors)){
+ colors<-setNames(c(
+ rgb(255,242,127,255,maxColorValue=255),
+ rgb(255,230,25,255,maxColorValue=255),
+ rgb(253,154,82,255,maxColorValue=255),
+ rgb(127,198,78,255,maxColorValue=255),
+ rgb(52,178,201,255,maxColorValue=255),
+ rgb(129,43,146,255,maxColorValue=255),
+ rgb(240,64,40,255,maxColorValue=255),
+ rgb(103,165,153,255,maxColorValue=255),
+ rgb(203,140,55,255,maxColorValue=255),
+ rgb(179,225,182,255,maxColorValue=255),
+ rgb(0,146,112,255,maxColorValue=255),
+ rgb(127,160,86,255,maxColorValue=255),
+ rgb(247,67,112,255,maxColorValue=255)),
+ c("Quaternary","Neogene","Paleogene",
+ "Cretaceous","Jurassic","Triassic",
+ "Permian","Carboniferous","Devonian",
+ "Silurian","Ordovician","Cambrian",
+ "Precambrian"))
+ }
+ if(is.null(leg)){
+ leg<-rbind(c(2.588,0),
+ c(23.03,2.588),
+ c(66.0,23.03),
+ c(145.0,66.0),
+ c(201.3,145.0),
+ c(252.17,201.3),
+ c(298.9,252.17),
+ c(358.9,298.9),
+ c(419.2,358.9),
+ c(443.8,419.2),
+ c(485.4,443.8),
+ c(541.0,485.4),
+ c(4600,541.0))
+ rownames(leg)<-c("Quaternary","Neogene","Paleogene",
+ "Cretaceous","Jurassic","Triassic",
+ "Permian","Carboniferous","Devonian",
+ "Silurian","Ordovician","Cambrian",
+ "Precambrian")
+ t.max<-max(obj$xx)
+ ii<-which(leg[,2]<=t.max)
+ leg<-leg[ii,]
+ leg[max(ii),1]<-t.max
+ }
+ colors<-sapply(colors,make.transparent,alpha=alpha)
+ if(plot){
+ y<-c(rep(0,2),rep(par()$usr[4],2))
+ ylabel<--1/25*obj$Ntip
+ if(obj$direction=="rightwards"){
+ old.usr<-par()$usr
+ h<-max(obj$xx)
+ new.xlim<-c(h-par()$usr[1],h-par()$usr[2])
+ par(usr=c(new.xlim,old.usr[3:4]))
+ } else old.usr<-par()$usr
+ for(i in 1:nrow(leg)){
+ strh<-strheight(rownames(leg)[i])
+ polygon(c(leg[i,1:2],leg[i,2:1]),y,
+ col=colors[rownames(leg)[i]],border=NA)
+ if(show.lines){
+ lines(x=rep(leg[i,1],2),y=c(0,par()$usr[4]),
+ lty="dotted",col="grey")
+ lines(x=c(leg[i,1],mean(leg[i,])-0.8*cex*
+ get.asp()*strheight(rownames(leg)[i])),
+ y=c(0,ylabel),lty="dotted",col="grey")
+ lines(x=c(leg[i,2],mean(leg[i,])+0.8*cex*
+ get.asp()*strheight(rownames(leg)[i])),
+ y=c(0,ylabel),lty="dotted",col="grey")
+ lines(x=rep(mean(leg[i,])-0.8*cex*
+ get.asp()*strheight(rownames(leg)[i]),2),
+ y=c(ylabel,par()$usr[3]),lty="dotted",col="grey")
+ lines(x=rep(mean(leg[i,])+0.8*cex*
+ get.asp()*strheight(rownames(leg)[i]),2),
+ y=c(ylabel,par()$usr[3]),lty="dotted",col="grey")
+ }
+ polygon(x=c(leg[i,1],
+ mean(leg[i,])-0.8*cex*get.asp()*strh,
+ mean(leg[i,])-0.8*cex*get.asp()*strh,
+ mean(leg[i,])+0.8*cex*get.asp()*strh,
+ mean(leg[i,])+0.8*cex*get.asp()*strh,
+ leg[i,2]),y=c(0,ylabel,par()$usr[3],
+ par()$usr[3],ylabel,0),
+ col=colors[rownames(leg)[i]],border=NA)
+ strh<-strh*get.asp()
+ text(x=mean(leg[i,])+
+ if(obj$direction=="leftwards") 0.12*strh else -0.12*strh,
+ y=ylabel,labels=rownames(leg)[i],
+ srt=90,adj=c(1,0.5),cex=cex)
+ }
+ }
+ par(usr=old.usr)
+ object<-list(leg=leg,colors=colors[1:nrow(leg)])
+ class(object)<-"geo.legend"
+ invisible(object)
+}
+
+print.geo.legend<-function(x,...){
+ cat("A geological period legend:\n")
+ colnames(x$leg)<-c("start","end")
+ print(data.frame(x$leg,color=x$colors))
+ cat("\n")
+}
+
+geo.palette<-function(){
+ colors<-setNames(c(
+ rgb(255,242,127,255,maxColorValue=255),
+ rgb(255,230,25,255,maxColorValue=255),
+ rgb(253,154,82,255,maxColorValue=255),
+ rgb(127,198,78,255,maxColorValue=255),
+ rgb(52,178,201,255,maxColorValue=255),
+ rgb(129,43,146,255,maxColorValue=255),
+ rgb(240,64,40,255,maxColorValue=255),
+ rgb(103,165,153,255,maxColorValue=255),
+ rgb(203,140,55,255,maxColorValue=255),
+ rgb(179,225,182,255,maxColorValue=255),
+ rgb(0,146,112,255,maxColorValue=255),
+ rgb(127,160,86,255,maxColorValue=255),
+ rgb(247,67,112,255,maxColorValue=255)),
+ c("Quaternary","Neogene","Paleogene",
+ "Cretaceous","Jurassic","Triassic",
+ "Permian","Carboniferous","Devonian",
+ "Silurian","Ordovician","Cambrian",
+ "Precambrian"))
+ leg<-rbind(c(2.588,0),
+ c(23.03,2.588),
+ c(66.0,23.03),
+ c(145.0,66.0),
+ c(201.3,145.0),
+ c(252.17,201.3),
+ c(298.9,252.17),
+ c(358.9,298.9),
+ c(419.2,358.9),
+ c(443.8,419.2),
+ c(485.4,443.8),
+ c(541.0,485.4),
+ c(4600,541.0))
+ rownames(leg)<-c("Quaternary","Neogene","Paleogene",
+ "Cretaceous","Jurassic","Triassic",
+ "Permian","Carboniferous","Devonian",
+ "Silurian","Ordovician","Cambrian",
+ "Precambrian")
+ colnames(leg)<-c("start","end")
+ object<-list(period=leg,cols=colors)
+ class(object)<-"geo.palette"
+ object
+}
+
+print.geo.palette<-function(x,...){
+ cat("A geological period color palette:\n")
+ print(data.frame(x$period,color=x$cols))
+ cat("\n")
+}
+
+## borrowed from mapplots
+get.asp<-function(){
+ pin<-par("pin")
+ usr<-par("usr")
+ asp<-(pin[2]/(usr[4]-usr[3]))/(pin[1]/(usr[2]-usr[1]))
+ asp
+}
+
+round.polygon<-function(x,y,col="transparent"){
+ ## just space holding for now
+}
+
+## draw a box around a clade
+## written by Liam J. Revell 2017
+
+cladebox<-function(tree,node,color=NULL,...){
+ if(is.null(color)) color<-make.transparent("yellow",0.2)
+ obj<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ h<-max(nodeHeights(tree))
+ parent<-tree$edge[which(tree$edge[,2]==node),1]
+ x0<-max(c(obj$xx[node]+obj$xx[parent])/2,obj$xx[node]-0.05*h)
+ x1<-obj$x.lim[2]
+ dd<-getDescendants(tree,node)
+ y0<-min(range(obj$yy[dd]))-0.5
+ y1<-max(range(obj$yy[dd]))+0.5
+ polygon(c(x0,x1,x1,x0),c(y0,y0,y1,y1),col=color,
+ border=0)
+}
+
+## draw tip labels as linking lines to text
+## written by Liam J. Revell 2017
+
+linklabels<-function(text,tips,link.type=c("bent","curved","straight"),
+ ...){
+ lastPP<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ if(!(lastPP$direction%in%c("leftwards","rightwards")))
+ stop("direction should be \"rightwards\" or \"leftwards\".")
+ if(hasArg(cex)) cex<-list(...)$cex
+ else cex<-1
+ if(hasArg(col)) col<-list(...)$col
+ else col<-"black"
+ if(hasArg(lty)) lty<-list(...)$lty
+ else lty<-"dashed"
+ if(hasArg(lwd)) lwd<-list(...)$lwd
+ else lwd<-1
+ if(hasArg(link.offset)) link.offset<-list(...)$link.offset
+ else link.offset<-0.1*max(lastPP$xx)
+ if(hasArg(font)) font<-list(...)$font
+ else font<-3
+ link.type<-link.type[1]
+ xpos<-lastPP$xx[tips]+strwidth("i")
+ ypos<-lastPP$yy[tips]
+ xmax<-rep(max(lastPP$xx),length(tips))+link.offset
+ ylab<-seq(min(lastPP$yy),max(lastPP$yy),
+ by=(max(lastPP$yy)-min(lastPP$yy))/(length(tips)-1))
+ ylab<-ylab[rank(ypos)]
+ text(xmax,ylab,gsub("_"," ",text),pos=4,font=font,cex=cex,
+ offset=0)
+ if(link.type=="curved"){
+ for(i in 1:length(tips))
+ drawCurve(c(xpos[i],xmax[i]),c(ypos[i],ylab[i]),
+ scale=0.01*diff(range(lastPP$xx)),lty=lty,
+ col=col,lwd=lwd)
+ } else if(link.type=="bent"){
+ tipmax<-max(lastPP$xx)
+ for(i in 1:length(tips)){
+ ff<-strwidth("W")
+ segments(xpos[i],ypos[i],tipmax+link.offset/2,ypos[i],
+ lty=lty,col=col,lwd=lwd)
+ segments(tipmax+link.offset/2,ypos[i],tipmax+
+ link.offset/2+ff,ylab[i],lty=lty,col=col,lwd=lwd)
+ segments(tipmax+link.offset/2+ff,ylab[i],xmax[i],ylab[i],
+ lty=lty,col=col,lwd=lwd)
+ }
+ } else if(link.type=="straight")
+ segments(xpos,ypos,xmax,ylab,lty=lty,col=col)
+}
+
+## function to create curved clade labels for a fan tree
+## written by Liam J. Revell 2017, 2022
+
+arc.cladelabels<-function(tree=NULL,text,node=NULL,ln.offset=1.02,
+ lab.offset=1.06,cex=1,orientation="curved",stretch=1,...){
+ obj<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ if(obj$type!="fan") stop("method works only for type=\"fan\"")
+ h<-max(sqrt(obj$xx^2+obj$yy^2))
+ if(hasArg(mark.node)) mark.node<-list(...)$mark.node
+ else mark.node<-TRUE
+ if(hasArg(interactive)) interactive<-list(...)$interactive
+ else {
+ if(is.null(node)) interactive<-TRUE
+ else interactive<-FALSE
+ }
+ if(interactive) node<-getnode()
+ if(hasArg(lwd)) lwd<-list(...)$lwd
+ else lwd<-par()$lwd
+ if(hasArg(col)) col<-list(...)$col
+ else col<-par()$col
+ if(hasArg(lend)) lend<-list(...)$lend
+ else lend<-par()$lend
+ if(hasArg(clockwise)) clockwise<-list(...)$clockwise
+ else clockwise<-TRUE
+ if(hasArg(n)) n<-list(...)$n
+ else n<-0.05
+ if(mark.node) points(obj$xx[node],obj$yy[node],pch=21,
+ bg="red")
+ if(is.null(tree)){
+ tree<-list(edge=obj$edge,tip.label=1:obj$Ntip,
+ Nnode=obj$Nnode)
+ class(tree)<-"phylo"
+ }
+ d<-getDescendants(tree,node)
+ d<-sort(d[d<=Ntip(tree)])
+ deg<-atan(obj$yy[d]/obj$xx[d])*180/pi
+ ii<-intersect(which(obj$yy[d]>=0),which(obj$xx[d]<0))
+ deg[ii]<-180+deg[ii]
+ ii<-intersect(which(obj$yy[d]<0),which(obj$xx[d]<0))
+ deg[ii]<-180+deg[ii]
+ ii<-intersect(which(obj$yy[d]<0),which(obj$xx[d]>=0))
+ deg[ii]<-360+deg[ii]
+ draw.arc(x=0,y=0,radius=ln.offset*h,deg1=min(deg),
+ deg2=max(deg),lwd=lwd,col=col,lend=lend,n=n)
+ if(orientation=="curved")
+ arctext(text,radius=lab.offset*h,
+ middle=mean(range(deg*pi/180)),cex=cex,
+ clockwise=clockwise,stretch=stretch)
+ else if(orientation=="horizontal"){
+ x0<-lab.offset*cos(median(deg)*pi/180)*h
+ y0<-lab.offset*sin(median(deg)*pi/180)*h
+ text(x=x0,y=y0,label=text,
+ adj=c(if(x0>=0) 0 else 1,if(y0>=0) 0 else 1),
+ offset=0,cex=cex)
+ }
+}
+
+## function to return a node index interactively from a plotted tree
+## written by Liam J. Revell 2017
+getnode<-function(...){
+ if(hasArg(env)) env<-list(...)$env
+ else env<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ if(hasArg(show.pt)) show.pt<-list(...)$show.pt
+ else show.pt<-FALSE
+ xy<-unlist(locator(n=1))
+ if(show.pt) points(xy[1],xy[2])
+ d<-sqrt((xy[1]-env$xx)^2+(xy[2]-env$yy)^2)
+ ii<-which(d==min(d))[1]
+ ii
+}
+
+## function mostly to interactively label nodes by clicking
+## written by Liam J. Revell 2017, 2020
+labelnodes<-function(text,node=NULL,interactive=TRUE,
+ shape=c("circle","ellipse","rect"),...){
+ shape<-shape[1]
+ if(hasArg(circle.exp)) circle.exp<-list(...)$circle.exp
+ else circle.exp<-1.3
+ if(hasArg(rect.exp)) rect.exp<-list(...)$rect.exp
+ else rect.exp<-1.6
+ if(hasArg(cex)) cex<-list(...)$cex
+ else cex<-1
+ if(hasArg(bg)) bg<-list(...)$bg
+ else bg<-"white"
+ obj<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ h<-cex*strheight("A")
+ w<-cex*strwidth(text)
+ rad<-circle.exp*h*diff(par()$usr[1:2])/diff(par()$usr[3:4])
+ if(is.null(node)){
+ if(!interactive){
+ cat("No nodes provided. Setting interactive mode to TRUE.\n")
+ interactive<-TRUE
+ }
+ node<-vector(length=length(text))
+ }
+ for(i in 1:length(text)){
+ if(interactive){
+ cat(paste("Click on the node you would like to label ",
+ text[i],".\n",sep=""))
+ flush.console()
+ ii<-getnode(env=obj)
+ node[i]<-ii
+ } else ii<-node[i]
+ if(shape=="circle")
+ draw.circle(obj$xx[ii],obj$yy[ii],rad,col=bg)
+ else if(shape=="ellipse")
+ draw.ellipse(obj$xx[ii],obj$yy[ii],0.8*w[i],h,
+ col=bg)
+ else if(shape=="rect")
+ rect(xleft=obj$xx[ii]-0.5*rect.exp*w[i],
+ ybottom=obj$yy[ii]-0.5*rect.exp*h,
+ xright=obj$xx[ii]+0.5*rect.exp*w[i],
+ ytop=obj$yy[ii]+0.5*rect.exp*h,col=bg,
+ ljoin=1)
+ text(obj$xx[ii],obj$yy[ii],label=text[i],cex=cex)
+ }
+ invisible(node)
+}
+
+## convert object of class "birthdeath" into birth & death rates
+bd<-function(x){
+ if(!inherits(x,"birthdeath")) stop("x should be an object of class 'birthdeath'")
+ b<-x$para[2]/(1-x$para[1])
+ d<-b-x$para[2]
+ setNames(c(b,d),c("b","d"))
+}
+
+## compute AIC weights
+aic.w<-function(aic){
+ d.aic<-aic-min(aic)
+ x<-exp(-1/2*d.aic)/sum(exp(-1/2*d.aic))
+ class(x)<-"aic.w"
+ x
+}
+
+print.aic.w<-function(x,...){
+ if(hasArg(signif)) signif<-list(...)$signif
+ else signif<-8
+ print(round(unclass(x),signif))
+}
+
+## function to compute all paths towards the tips from a node
+## written by Liam J. Revell
+node.paths<-function(tree,node){
+ d<-Descendants(tree,node,"children")
+ paths<-as.list(d)
+ while(any(d>Ntip(tree))){
+ jj<-1
+ new.paths<-list()
+ for(i in 1:length(paths)){
+ if(paths[[i]][length(paths[[i]])]<=Ntip(tree)){
+ new.paths[[jj]]<-paths[[i]]
+ jj<-jj+1
+ } else {
+ ch<-Descendants(tree,paths[[i]][length(paths[[i]])],
+ "children")
+ for(j in 1:length(ch)){
+ new.paths[[jj]]<-c(paths[[i]],ch[j])
+ jj<-jj+1
+ }
+ }
+ }
+ paths<-new.paths
+ d<-sapply(paths,function(x) x[length(x)])
+ }
+ paths
+}
+
+## function to compute a modification of Grafen's edge lengths
+## written by Liam J. Revell 2016
+modified.Grafen<-function(tree,power=2){
+ max.np<-function(tree,node){
+ np<-node.paths(tree,node)
+ if(length(np)>0) max(sapply(np,length)) else 0
+ }
+ nn<-1:(Ntip(tree)+tree$Nnode)
+ h<-sapply(nn,max.np,tree=tree)+1
+ h<-(h/max(h))^power
+ edge.length<-vector()
+ for(i in 1:nrow(tree$edge))
+ edge.length[i]<-diff(h[tree$edge[i,2:1]])
+ tree$edge.length<-edge.length
+ tree
+}
+
+## function to compute all rotations
+## written by Liam J. Revell 2016
+allRotations<-function(tree){
+ if(!is.binary(tree)){
+ was.binary<-FALSE
+ if(is.null(tree$edge.length)){
+ tree<-compute.brlen(tree)
+ had.edge.lengths<-FALSE
+ } else had.edge.lengths<-TRUE
+ tree<-multi2di(tree)
+ } else was.binary<-TRUE
+ nodes<-1:tree$Nnode+Ntip(tree)
+ trees<-vector(mode="list",length=2^length(nodes))
+ ii<-2
+ trees[[1]]<-tree
+ for(i in 1:length(nodes)){
+ N<-ii-1
+ for(j in 1:N){
+ trees[[ii]]<-rotate(trees[[j]],nodes[i])
+ ii<-ii+1
+ }
+ }
+ trees<-lapply(trees,untangle,"read.tree")
+ if(!was.binary){
+ trees<-lapply(trees,di2multi)
+ if(!had.edge.lengths) trees<-lapply(trees,
+ function(x){
+ x$edge.length<-NULL
+ x
+ })
+ }
+ class(trees)<-"multiPhylo"
+ trees
+}
+
+## function to rotate a multifurcation in all possible ways
+## written by Liam J. Revell 2016
+rotate.multi<-function(tree,node){
+ kids<-Children(tree,node)
+ if(length(kids)>2){
+ ii<-sapply(kids,function(x,y) which(y==x),y=tree$edge[,2])
+ jj<-permn(ii)
+ foo<-function(j,i,t){
+ t$edge[i,]<-t$edge[j,]
+ if(!is.null(t$edge.length))
+ t$edge.length[i]<-t$edge.length[j]
+ untangle(t,"read.tree")
+ }
+ obj<-lapply(jj[2:length(jj)],foo,i=ii,t=tree)
+ class(obj)<-"multiPhylo"
+ } else obj<-untangle(rotate(tree,node),"read.tree")
+ obj
+}
+
+## wrapper for bind.tree that takes objects of class "simmap"
+## written by Liam J. Revell 2016
+bind.tree.simmap<-function(x,y,where="root"){
+ x<-reorder(x)
+ y<-reorder(y)
+ rootx<-x$edge[1,1]
+ rooty<-y$edge[1,1]
+ xy<-read.tree(text=write.tree(bind.tree(x,y,where)))
+ Mx<-rbind(matchLabels(x,xy),matchNodes(x,xy,"distances"))
+ My<-rbind(matchLabels(y,xy),matchNodes(y,xy,"distances"))
+ if(where!="root"&&where<=Ntip(x))
+ Mx[which(is.na(Mx[,2])),2]<-findMRCA(xy,y$tip.label)
+ xy$maps<-vector(mode="list",length=nrow(xy$edge))
+ ix<-sapply(Mx[-which(Mx[,1]==rootx),1],
+ function(x,y) which(y==x),y=x$edge[,2])
+ ixy<-sapply(Mx[-which(Mx[,1]==rootx),2],
+ function(x,y) which(y==x),y=xy$edge[,2])
+ xy$maps[ixy]<-x$maps[ix]
+ iy<-sapply(My[-which(My[,1]==rooty),1],
+ function(x,y) which(y==x),y=y$edge[,2])
+ ixy<-sapply(My[-which(My[,1]==rooty),2],
+ function(x,y) which(y==x),y=xy$edge[,2])
+ xy$maps[ixy]<-y$maps[iy]
+ xy$mapped.edge<-makeMappedEdge(xy$edge,xy$maps)
+ ns<-c(setNames(getStates(xy,"tips"),1:Ntip(xy)),
+ getStates(xy,"nodes"))
+ xy$node.states<-cbind(ns[as.character(xy$edge[,1])],
+ ns[as.character(xy$edge[,2])])
+ xy$states<-getStates(xy,"tips")
+ attr(xy,"class")<-c("simmap",class(xy))
+ xy
+}
+
+## generic function to convert an object of class "simmap" to "phylo"
+## written by Liam J. Revell 2016
+as.phylo.simmap<-function(x,...){
+ x$maps<-NULL
+ x$mapped.edge<-NULL
+ if(!is.null(x$node.states)) x$node.states<-NULL
+ if(!is.null(x$states)) x$states<-NULL
+ if(!is.null(x$Q)) x$Q<-NULL
+ if(!is.null(x$logL)) x$logL<-NULL
+ if(!is.null(attr(x,"map.order"))) attr(x,"map.order")<-NULL
+ class(x)<-setdiff(class(x),"simmap")
+ x
+}
+
+## generic function to convert an object of class "multiSimmap" to "multiPhylo"
+## written by Liam J. Revell 2016
+as.multiPhylo.multiSimmap<-function(x,...){
+ obj<-lapply(x,as.phylo)
+ class(obj)<-setdiff(class(x),"multiSimmap")
+ obj
+}
+
+## generic function to convert object of class "phylo" to "multiPhylo"
+## written by Liam J. Revell 2016
+as.multiPhylo.phylo<-function(x,...){
+ obj<-list(x)
+ class(obj)<-"multiPhylo"
+ obj
+}
+
+as.multiPhylo<-function(x,...){
+ if (identical(class(x),"multiPhylo")) return(x)
+ UseMethod("as.multiPhylo")
+}
+
+## get mapped states
+## written by Liam J. Revell 2016
+mapped.states<-function(tree,...){
+ if(!(inherits(tree,"simmap")||inherits(tree,"multiSimmap")))
+ stop("tree should be an object of class \"simmap\" or \"multiSimmap\".")
+ else {
+ if(inherits(tree,"simmap")){
+ if(!is.null(tree$mapped.edge))
+ obj<-sort(colnames(tree$mapped.edge))
+ else
+ obj<-sort(unique(unlist(lapply(tree$maps,function(x) names(x)))))
+ } else if(inherits(tree,"multiSimmap")) {
+ obj<-sapply(tree,mapped.states,...)
+ }
+ }
+ obj
+}
+
+## match labels between trees (equivalent to matchNodes)
+## written by Liam J. Revell 2016
+matchLabels<-function(tr1,tr2){
+ foo<-function(x,y) if(length(obj<-which(y==x))>0) obj else NA
+ M<-cbind(1:Ntip(tr1),sapply(tr1$tip.label,foo,y=tr2$tip.label))
+ colnames(M)<-c("tr1","tr2")
+ M
+}
+
+## compute the probability of states changes along edges of the tree
+## written by Liam J. Revell 2015
+edgeProbs<-function(trees){
+ if(!inherits(trees,"multiSimmap")) stop("trees should be an object of class \"multiSimmap\".")
+ SS<-sapply(trees,getStates,"tips")
+ states<-sort(unique(as.vector(SS)))
+ m<-length(states)
+ TT<-sapply(states,function(x,y) sapply(y,paste,x,sep="->"),
+ y=states)
+ nn<-c(TT[upper.tri(TT)],TT[lower.tri(TT)])
+ ## this function computes for a given edge
+ fn<-function(edge,trees,states){
+ obj<-sapply(trees,function(x,e,s)
+ if(names(x$maps[[e]])[1]==
+ s[1]&&names(x$maps[[e]])[length(x$maps[[e]])]==s[2]) TRUE
+ else FALSE,e=edge,s=states)
+ sum(obj)/length(obj)
+ }
+ edge.probs<-matrix(0,nrow(trees[[1]]$edge),m,
+ dimnames=list(apply(trees[[1]]$edge,1,paste,collapse=","),nn))
+ k<-1
+ for(i in 1:m) for(j in 1:m){
+ if(i!=j){
+ edge.probs[,k]<-sapply(1:nrow(trees[[1]]$edge),fn,
+ trees=trees,states=states[c(i,j)])
+ k<-k+1
+ }
+ }
+ edge.probs<-cbind(edge.probs,1-rowSums(edge.probs))
+ colnames(edge.probs)[ncol(edge.probs)]<-"no change"
+ edge.probs
+}
+
+## get a position in the tree interactively
+## written by Liam J. Revell 2015, 2016, 2020
+get.treepos<-function(message=TRUE,...){
+ obj<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ if(obj$type=="phylogram"&&obj$direction=="rightwards"){
+ if(message){
+ cat("Click on the tree position you want to capture...\n")
+ flush.console()
+ }
+ if(hasArg(x)) x<-list(...)$x
+ else x<-NULL
+ if(hasArg(y)) y<-list(...)$y
+ else y<-NULL
+ if(is.null(x)||is.null(y)){
+ x<-unlist(locator(1))
+ y<-x[2]
+ x<-x[1]
+ }
+ d<-pos<-c()
+ for(i in 1:nrow(obj$edge)){
+ x0<-obj$xx[obj$edge[i,]]
+ y0<-obj$yy[obj$edge[i,2]]
+ if(x<x0[1]||x>x0[2]){
+ d[i]<-min(dist(rbind(c(x,y),c(x0[1],y0))),
+ dist(rbind(c(x,y),c(x0[2],y0))))
+ pos[i]<-if(x>x0[2]) 0 else diff(obj$xx[obj$edge[i,]])
+ } else {
+ d[i]<-abs(y0-y)
+ pos[i]<-obj$xx[obj$edge[i,2]]-x
+ }
+ }
+ ii<-which(d==min(d))
+ ## check to make sure the root is not closer:
+ root.d<-dist(rbind(c(x,y),c(obj$xx[obj$Ntip+1],obj$yy[obj$Ntip+1])))
+ if(root.d<min(d)) return(list(where=obj$Ntip+1,pos=0))
+ else list(where=obj$edge[ii,2],pos=pos[ii])
+ } else stop("Does not work for the plotted tree type.")
+}
+
+## fastDist: uses fastHeight to compute patristic distance between a pair of species
+fastDist<-function(tree,sp1,sp2){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ if(is.null(tree$edge.length)) stop("tree should have edge lengths.")
+ if(sp1==sp2) 0
+ else fastHeight(tree,sp1,sp1)+fastHeight(tree,sp2,sp2)-
+ 2*fastHeight(tree,sp1,sp2)
+}
+
+## function reorders simmap tree
+## written Liam Revell 2011, 2013, 2015, 2019
+reorderSimmap<-function(tree,order="cladewise",index.only=FALSE,...){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ ii<-reorder.phylo(tree,order,index.only=TRUE,...)
+ if(!index.only){
+ if(inherits(ii,"phylo")) ii<-whichorder(ii$edge[,2],
+ tree$edge[,2]) ## bug workaround
+ tree$edge<-tree$edge[ii,]
+ tree$edge.length<-tree$edge.length[ii]
+ if(!is.null(tree$maps)){
+ tree$maps<-tree$maps[ii]
+ tree$mapped.edge<-tree$mapped.edge[ii,,drop=FALSE]
+ }
+ attr(tree,"order")<-order
+ return(tree)
+ } else return(ii)
+}
+
+## S3 reorder method for objects of class "simmap"
+reorder.simmap<-function(x,...) reorderSimmap(x,...)
+
+# function whichorder
+# written by Liam Revell 2011, 2013, 2015
+whichorder<-function(x,y) sapply(x,function(x,y) which(x==y),y=y)
+
+# function returns random state with probability given by y
+# written by Liam J. Revell 2013, 2015
+rstate<-function(y){
+ if(length(y)==1) return(names(y)[1])
+ else {
+ p<-y/sum(y)
+ if(any(p<0)){
+ warning("Some probabilities (slightly?) < 0. Setting p < 0 to zero.")
+ p[p<0]<-0
+ }
+ return(names(which(rmultinom(1,1,p)[,1]==1)))
+ }
+}
+
+## mark the changes on a plotted "simmap" object
+## written by Liam J. Revell 2015
+markChanges<-function(tree,colors=NULL,cex=1,lwd=2,plot=TRUE){
+ states<-sort(unique(getStates(tree)))
+ if(is.null(colors)) colors<-setNames(palette()[1:length(states)],
+ states)
+ obj<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ nc<-sapply(tree$maps,length)-1
+ ii<-which(nc>0)
+ nc<-nc[ii]
+ xx<-yy<-vector()
+ for(i in 1:length(ii)){
+ for(j in 1:nc[i]){
+ ss<-names(tree$maps[[ii[i]]])[j+1]
+ mm<-tree$edge[ii[i],1]
+ dd<-tree$edge[ii[i],2]
+ x<-rep(obj$xx[mm]+cumsum(tree$maps[[ii[i]]])[j],2)
+ y<-c(obj$yy[dd]-0.5*mean(strheight(LETTERS)*cex),
+ obj$yy[dd]+0.5*mean(strheight(LETTERS)*cex))
+ if(plot) lines(x,y,lwd=lwd,col=colors[ss],lend=2)
+ xx<-c(xx,setNames(x[1],
+ paste(names(tree$maps[[ii[i]]])[j:(j+1)],
+ collapse="->")))
+ yy<-c(yy,mean(y))
+ }
+ }
+ XY<-cbind(xx,yy)
+ colnames(XY)<-c("x","y")
+ invisible(XY)
+}
+
+## function to label clades
+## written by Liam J. Revell 2014, 2015, 2022
+cladelabels<-function(tree=NULL,text,node,offset=NULL,wing.length=NULL,cex=1,
+ orientation="vertical"){
+ lastPP<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ if(is.null(tree)){
+ if(is.null(wing.length)) wing.length<-1
+ if(is.null(offset)) offset<-8
+ tree<-list(edge=lastPP$edge,
+ tip.label=1:lastPP$Ntip,
+ Nnode=lastPP$Nnode)
+ H<-matrix(lastPP$xx[tree$edge],nrow(tree$edge),2)
+ tree$edge.length<-H[,2]-H[,1]
+ class(tree)<-"phylo"
+ }
+ if(is.null(offset)) offset<-0.5
+ xx<-mapply(labelSubTree,node,text,
+ MoreArgs=list(tree=tree,pp=lastPP,offset=offset,wl=wing.length,cex=cex,
+ orientation=orientation),SIMPLIFY=FALSE)
+}
+
+## internal function used by cladelabels
+## written by Liam J. Revell 2014, 2015, 2022
+labelSubTree<-function(tree,nn,label,pp,offset,wl,cex,orientation){
+ if(is.null(wl)) wl<-1
+ tree<-reorder(tree)
+ tips<-getDescendants(tree,nn)
+ tips<-tips[tips<=Ntip(tree)]
+ ec<-0.7 ## expansion constant
+ sw<-pp$cex*max(strwidth(tree$tip.label[tips]))
+ sh<-pp$cex*max(strheight(tree$tip.label))
+ cw<-mean(strwidth(LETTERS)*cex)
+ h<-max(sapply(tips,function(x,tree)
+ nodeHeights(tree)[which(tree$edge[,2]==x),2],
+ tree=tree))+sw+offset*cw
+ y<-range(pp$yy[tips])
+ lines(c(h,h),y+ec*c(-sh,sh),col=par()$fg)
+ lines(c(h-wl*cw,h),
+ c(y[1]-ec*sh,y[1]-ec*sh),col=par()$fg)
+ lines(c(h-wl*cw,h),
+ c(y[2]+ec*sh,y[2]+ec*sh),col=par()$fg)
+ text(h+cw,mean(y),
+ label,srt=if(orientation=="horizontal") 0 else 90,
+ adj=if(orientation=="horizontal") 0 else 0.5,cex=cex,
+ col=par()$col.lab)
+ list(xx=c(h,h),yy=y+ec*c(-sh,sh))
+}
+
+## get all the extant/extinct tip names
+## written by Liam J. Revell 2012, 2015
+
+getExtant<-function(tree,tol=1e-8){
+ if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".")
+ H<-nodeHeights(tree)
+ tl<-max(H)
+ x<-which(H[,2]>=(tl-tol))
+ y<-tree$edge[x,2]
+ y<-y[y<=Ntip(tree)]
+ z<-tree$tip.label[y]
+ return(z)
+}
+
+getExtinct<-function(tree,tol=1e-8) setdiff(tree$tip.label,getExtant(tree,tol))
+
+# function splits tree at split
+# written by Liam Revell 2011, 2014, 2015, 2020
+
+splitTree<-function(tree,split){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ if(split$node>Ntip(tree)){
+ # first extract the clade given by shift$node
+ tr2<-extract.clade(tree,node=split$node)
+ tr2$root.edge<-tree$edge.length[which(tree$edge[,2]==split$node)]-split$bp
+ #now remove tips in tr2 from tree
+ tr1<-drop.clade(tree,tr2$tip.label)
+ nn<-if(!is.null(tree$node.label)) c(tree$node.label,"NA") else "NA"
+ tr1$tip.label[which(tr1$tip.label%in%nn)]<-"NA"
+ tr1$edge.length[match(which(tr1$tip.label=="NA"),tr1$edge[,2])]<-split$bp
+ } else {
+ # first extract the clade given by shift$node
+ tr2<-list(edge=matrix(c(2L,1L),1,2),tip.label=tree$tip.label[split$node],edge.length=tree$edge.length[which(tree$edge[,2]==split$node)]-split$bp,Nnode=1L)
+ class(tr2)<-"phylo"
+ # now remove tip in tr2 from tree
+ tr1<-tree
+ tr1$edge.length[match(which(tr1$tip.label==tr2$tip.label[1]),tr1$edge[,2])]<-split$bp
+ tr1$tip.label[which(tr1$tip.label==tr2$tip.label[1])]<-"NA"
+ }
+ trees<-list(tr1,tr2)
+ class(trees)<-"multiPhylo"
+ trees
+}
+
+# function drops entire clade
+# written by Liam Revell 2011, 2015, 2020
+
+drop.clade<-function(tree,tip){
+ ## step 1, check to make sure tips form a monophyletic clade
+ node<-getMRCA(tree,tip)
+ desc<-getDescendants(tree,node)
+ chk<-tree$tip.label[desc[desc<=Ntip(tree)]]
+ if(!setequal(tip,chk)){
+ cat("Caution: Species in tip do not form a monophyletic clade.\n")
+ cat(" Pruning all tips descended from ancestor.\n\n")
+ tip<-chk
+ }
+ ## step 2, find all edges in the clade & set them to zero length
+ ee<-sapply(desc,function(node,edge) which(edge==node),
+ edge=tree$edge[,2])
+ tree$edge.length[ee]<-0
+ ## step 3, bind a tip labeled "NA" to the node
+ tree<-bind.tip(tree,"NA",0,node)
+ ## step 4, prune the other tips
+ tree<-drop.tip(tree,tip)
+ ## step 5, return tree
+ tree
+}
+
+## function to re-root a phylogeny along an edge
+## written by Liam J. Revell 2011-2016, 2019, 2020
+
+reroot<-function(tree,node.number,position=NULL,interactive=FALSE,...){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ if(interactive){
+ plotTree(tree,...)
+ cat("Click where you would like re-root the plotted tree\n")
+ flush.console()
+ obj<-get.treepos(message=FALSE)
+ node.number<-obj$where
+ position<-tree$edge.length[which(tree$edge[,2]==node.number)]-obj$pos
+ }
+ if(node.number==(Ntip(tree)+1))
+ cat("Note: you chose to re-root the tree at it's current root.\n")
+ if(is.null(position)){
+ if(node.number==(Ntip(tree)+1)) position=0
+ else position<-tree$edge.length[which(tree$edge[,2]==node.number)]
+ } else {
+ if(node.number==(Ntip(tree)+1))
+ cat(" A value of position != 0 has been reset to zero.\n")
+ }
+ if(hasArg(edgelabel)) edgelabel<-list(...)$edgelabel
+ else edgelabel<-FALSE
+ if(node.number!=(Ntip(tree)+1)){
+ tt<-splitTree(tree,list(node=node.number,bp=position))
+ p<-tt[[1]]
+ d<-tt[[2]]
+ tip<-if(length(which(p$tip.label=="NA"))>0) "NA" else p$tip.label[which(p$tip.label%in%tree$node.label)]
+ p<-ape::root.phylo(p,outgroup=tip,resolve.root=TRUE,edgelabel=edgelabel)
+ bb<-which(p$tip.label==tip)
+ p$tip.label[bb]<-"NA"
+ ee<-p$edge.length[which(p$edge[,2]==bb)]
+ p$edge.length[which(p$edge[,2]==bb)]<-0
+ cc<-p$edge[which(p$edge[,2]==bb),1]
+ dd<-setdiff(p$edge[which(p$edge[,1]==cc),2],bb)
+ p$edge.length[which(p$edge[,2]==dd)]<-p$edge.length[which(p$edge[,2]==dd)]+ee
+ obj<-paste.tree(p,d)
+ } else obj<-tree
+ if(interactive) plotTree(obj,...)
+ obj
+}
+
+## function to add an arrow pointing to a tip or node in the tree
+## written by Liam J. Revell 2014, 2017, 2020
+
+add.arrow<-function(tree=NULL,tip,...){
+ if(length(tip)>1){
+ object<-sapply(tip,add.arrow,tree=tree,...)
+ invisible(object)
+ } else {
+ lastPP<-get("last_plot.phylo",envir=.PlotPhyloEnv)
+ if(!is.null(tree)){
+ if(inherits(tree,"contMap")) tree<-tree$tree
+ else if(inherits(tree,"densityMap")) tree<-tree$tree
+ }
+ if(is.numeric(tip)){
+ ii<-tip
+ if(!is.null(tree)&&ii<=Ntip(tree)) tip<-tree$tip.label[ii]
+ else tip<-""
+ } else if(is.character(tip)&&!is.null(tree)) ii<-which(tree$tip.label==tip)
+ if(hasArg(offset)) offset<-list(...)$offset
+ else offset<-1
+ strw<-lastPP$cex*(strwidth(tip)+offset*mean(strwidth(c(LETTERS,letters))))
+ if(hasArg(arrl)) arrl<-list(...)$arrl
+ else {
+ if(lastPP$type=="fan") arrl<-0.3*max(lastPP$xx)
+ else if(lastPP$type=="phylogram") arrl<-0.15*max(lastPP$xx)
+ }
+ if(hasArg(hedl)) hedl<-list(...)$hedl
+ else hedl<-arrl/3
+ if(hasArg(angle)) angle<-list(...)$angle
+ else angle<-45
+ arra<-angle*pi/180
+ asp<-if(lastPP$type=="fan") 1 else (par()$usr[4]-par()$usr[3])/(par()$usr[2]-
+ par()$usr[1])
+ if(hasArg(col)) col<-list(...)$col
+ else col<-"black"
+ if(hasArg(lwd)) lwd<-list(...)$lwd
+ else lwd<-2
+ if(lastPP$type=="fan") theta<-atan2(lastPP$yy[ii],lastPP$xx[ii])
+ else if(lastPP$type=="phylogram") theta<-0
+ segments(x0=lastPP$xx[ii]+cos(theta)*(strw+arrl),
+ y0=lastPP$yy[ii]+sin(theta)*(strw+arrl),
+ x1=lastPP$xx[ii]+cos(theta)*strw,
+ y1=lastPP$yy[ii]+sin(theta)*strw,
+ col=col,lwd=lwd,lend="round")
+ segments(x0=lastPP$xx[ii]+cos(theta)*strw+cos(theta+arra/2)*hedl,
+ y0=lastPP$yy[ii]+sin(theta)*strw+sin(theta+arra/2)*hedl*asp,
+ x1=lastPP$xx[ii]+cos(theta)*strw,
+ y1=lastPP$yy[ii]+sin(theta)*strw,
+ col=col,lwd=lwd,lend="round")
+ segments(x0=lastPP$xx[ii]+cos(theta)*strw+cos(theta-arra/2)*hedl,
+ y0=lastPP$yy[ii]+sin(theta)*strw+sin(theta-arra/2)*hedl*asp,
+ x1=lastPP$xx[ii]+cos(theta)*strw,
+ y1=lastPP$yy[ii]+sin(theta)*strw,
+ col=col,lwd=lwd,lend="round")
+ invisible(list(x0=lastPP$xx[ii]+cos(theta)*(strw+arrl),
+ y0=lastPP$yy[ii]+sin(theta)*(strw+arrl),
+ x1=lastPP$xx[ii]+cos(theta)*strw,
+ y1=lastPP$yy[ii]+sin(theta)*strw))
+ }
+}
+
+## function to ladderize phylogeny with mapped discrete character
+## written by Liam J. Revell 2014, 2015, 2019
+
+ladderize.simmap<-function(tree,right=TRUE){
+ if(!inherits(tree,"simmap")){
+ if(!inherits(tree,"phylo"))
+ stop("tree should be an object of class \"phylo\".")
+ else {
+ cat("Do not detect a mapped character. Using ape::ladderize.\n")
+ obj<-ladderize(tree,right=right)
+ }
+ } else {
+ obj<-read.tree(text=write.tree(ladderize(tree,right=right)))
+ rN<-Ntip(obj)+1
+ T<-cbind(1:Ntip(obj),sapply(obj$tip.label,
+ function(x,y) which(y==x),y=tree$tip.label))
+ N<-matchNodes(obj,tree)
+ M<-rbind(T,N[N[,1]!=rN,])
+ ii<-sapply(M[,1],function(x,y) which(y==x),y=obj$edge[,2])
+ jj<-sapply(M[,2],function(x,y) which(y==x),y=tree$edge[,2])
+ obj$maps<-vector(length=nrow(tree$edge),mode="list")
+ obj$mapped.edge<-matrix(NA,nrow(tree$edge),ncol(tree$mapped.edge),
+ dimnames=list(apply(tree$edge,1,paste,collapse=","),
+ colnames(tree$mapped.edge)))
+ if(!is.null(tree$states))
+ obj$states<-tree$states[sapply(obj$tip.label,
+ function(x,y) which(y==x),y=tree$tip.label)]
+ if(!is.null(tree$node.states)) obj$node.states<-matrix(NA,nrow(tree$edge),2)
+ for(i in 1:length(ii)){
+ obj$maps[[ii[i]]]<-tree$maps[[jj[i]]]
+ obj$mapped.edge[ii[i],]<-tree$mapped.edge[jj[i],]
+ if(!is.null(tree$node.states)) obj$node.states[ii[i],]<-
+ tree$node.states[jj[i],]
+ }
+ class(obj)<-c("simmap","phylo")
+ }
+ obj
+}
+
+## for backward compatibility
+
+repPhylo<-function(tree,times) rep(tree,times)
+
+## S3 method rep for objects of class "phylo" and "multiPhylo"
+## written by Liam J. Revell 2014, 2021
+
+rep.phylo<-function(x,...){
+ if(hasArg(times)) times<-list(...)$times
+ else times<-(...)[[1]]
+ for(i in 1:times) obj<-if(i==1) x else if(i==2) c(obj,x) else c(unclass(obj),list(x))
+ class(obj)<-"multiPhylo"
+ obj
+}
+
+rep.multiPhylo<-function(x,...){
+ if(hasArg(times)) times<-list(...)$times
+ else times<-(...)[[1]]
+ for(i in 1:times) obj<-if(i==1) x else if(i>=2) c(obj,x)
+ class(obj)<-"multiPhylo"
+ obj
+}
+
+## function to drop one or more tips from a tree but retain all ancestral nodes as singletons
+## written by Liam J. Revell 2014, 2015, 2023
+drop.tip.singleton<-function(phy,tip,...){
+ if(!inherits(phy,"singleton")&&!inherits(phy,"phylo"))
+ stop("phy should be an object of class \"singleton\".")
+ N<-Ntip(phy)
+ m<-length(tip)
+ ii<-sapply(tip,function(x,y) which(y==x),y=phy$tip.label)
+ phy$tip.label<-phy$tip.label[-ii]
+ ii<-sapply(ii,function(x,y) which(y==x),y=phy$edge[,2])
+ phy$edge<-phy$edge[-ii,]
+ phy$edge.length<-phy$edge.length[-ii]
+ phy$edge[phy$edge<=N]<-as.integer(rank(phy$edge[phy$edge<=N]))
+ phy$edge[phy$edge>N]<-phy$edge[phy$edge>N]-m
+ N<-N-m
+ if(any(sapply(phy$edge[phy$edge[,2]>N,2],"%in%",phy$edge[,1])==FALSE)) internal<-TRUE
+ else internal<-FALSE
+ while(internal){
+ ii<-which(sapply(phy$edge[,2],"%in%",c(1:N,phy$edge[,1]))==FALSE)[1]
+ nn<-phy$edge[ii,2]
+ phy$edge<-phy$edge[-ii,]
+ phy$edge.length<-phy$edge.length[-ii]
+ phy$edge[phy$edge>nn]<-phy$edge[phy$edge>nn]-1
+ phy$Nnode<-phy$Nnode-length(ii)
+ if(any(sapply(phy$edge[phy$edge[,2]>N,2],"%in%",phy$edge[,1])==FALSE)) internal<-TRUE
+ else internal<-FALSE
+ }
+ class(phy)<-union("singleton",class(phy))
+ phy
+}
+
+## S3 print method for object of class 'describe.simmap'
+## written by Liam J. Revell 2014, 2015
+print.describe.simmap<-function(x,...){
+ if(inherits(x$tree,"multiPhylo")){
+ cat(paste(length(x$tree),"trees with a mapped discrete character with states:\n",paste(colnames(x$ace),collapse=", "),"\n\n"))
+ cat(paste("trees have",colMeans(x$count)["N"],"changes between states on average\n\n"))
+ cat(paste("changes are of the following types:\n"))
+ aa<-t(as.matrix(colMeans(x$count)[2:ncol(x$count)]))
+ rownames(aa)<-"x->y"
+ print(aa)
+ cat(paste("\nmean total time spent in each state is:\n"))
+ print(matrix(c(colMeans(x$times),colMeans(x$times[,1:ncol(x$times)]/x$times[,ncol(x$times)])),2,ncol(x$times),byrow=TRUE,
+ dimnames=list(c("raw","prop"),c(colnames(x$times)))))
+ cat("\n")
+ } else if(inherits(x$tree,"phylo")){
+ cat(paste("1 tree with a mapped discrete character with states:\n",paste(colnames(x$Tr),collapse=", "),"\n\n"))
+ cat(paste("tree has",x$N,"changes between states\n\n"))
+ cat(paste("changes are of the following types:\n"))
+ print(x$Tr)
+ cat(paste("\nmean total time spent in each state is:\n"))
+ print(x$times)
+ cat("\n")
+ }
+}
+
+## S3 plot method for object of class 'describe.simmap'
+## written by Liam J. Revell 2014, 2015, 2020
+plot.describe.simmap<-function(x,...){
+ if(hasArg(lwd)) lwd<-list(...)$lwd
+ else lwd<-2
+ if(hasArg(cex)) cex<-list(...)$cex
+ else cex<-c(0.6,0.4)
+ if(length(cex)==1) cex<-rep(cex,2)
+ if(hasArg(type)) type<-list(...)$type
+ else type<-"phylogram"
+ if(hasArg(offset)) offset<-list(...)$offset
+ else offset<-0
+ if(hasArg(fsize)) fsize<-list(...)$fsize
+ else fsize<-1
+ if(inherits(x$tree,"multiPhylo")){
+ states<-colnames(x$ace)
+ if(hasArg(colors)) colors<-list(...)$colors
+ else colors<-setNames(palette()[1:length(states)],states)
+ plotTree(if(is.null(x$ref.tree)) x$tree[[1]] else x$ref.tree,lwd=lwd,
+ offset=cex[2]+offset*fsize,...)
+ nodelabels(pie=x$ace,piecol=colors[colnames(x$ace)],cex=cex[1])
+ if(!is.null(x$tips)) tips<-x$tips
+ else tips<-to.matrix(getStates(x$tree[[1]],"tips"),seq=states)
+ tiplabels(pie=tips[if(is.null(x$ref.tree)) x$tree[[1]]$tip.label else
+ x$ref.tree$tip.label,],piecol=colors[colnames(tips)],cex=cex[2])
+ } else if(inherits(x$tree,"phylo")){
+ states<-colnames(x$Tr)
+ if(hasArg(colors)) colors<-list(...)$colors
+ else colors<-setNames(palette()[1:length(states)],states)
+ plotSimmap(x$tree,lwd=lwd,colors=colors,type=type,offset=offset)
+ }
+}
+
+## function finds the height of a given node
+## written by Liam Revell 2014, 2015, 2016
+nodeheight<-function(tree,node,...){
+ if(hasArg(root.edge)) root.edge<-list(...)$root.edge
+ else root.edge<-FALSE
+ if(root.edge) ROOT<-if(!is.null(tree$root.edge)) tree$root.edge else 0
+ else ROOT<-0
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ if(node==(Ntip(tree)+1)) h<-0
+ else {
+ a<-setdiff(c(getAncestors(tree,node),node),Ntip(tree)+1)
+ h<-sum(tree$edge.length[sapply(a,function(x,e) which(e==x),e=tree$edge[,2])])
+ }
+ h+ROOT
+}
+
+# fast pairwise MRCA function
+# written by Liam Revell 2012, 2014, 2015
+fastMRCA<-function(tree,sp1,sp2){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ x<-match(sp1,tree$tip.label)
+ y<-match(sp2,tree$tip.label)
+ a<-c(x,getAncestors(tree,x))
+ b<-c(y,getAncestors(tree,y))
+ z<-a%in%b
+ return(a[min(which(z))])
+}
+
+## function to find the height of the MRCA of sp1 & sp2
+## written by Liam J. Revell 2014, 2015
+fastHeight<-function(tree,sp1,sp2){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ if(is.null(tree$edge.length)) stop("tree should have edge lengths.")
+ sp1<-which(tree$tip.label==sp1)
+ sp2<-which(tree$tip.label==sp2)
+ a1<-c(sp1,getAncestors(tree,sp1))
+ a2<-c(sp2,getAncestors(tree,sp2))
+ a12<-intersect(a1,a2)
+ if(length(a12)>1){
+ a12<-a12[2:length(a12)-1]
+ h<-sapply(a12,function(i,tree) tree$edge.length[which(tree$edge[,2]==i)],tree=tree)
+ return(sum(h))
+ } else return(0)
+}
+
+## function gets ancestor node numbers, to be used internally by
+## written by Liam J. Revell 2014
+getAncestors<-function(tree,node,type=c("all","parent")){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ type<-type[1]
+ if(type=="all"){
+ aa<-vector()
+ rt<-Ntip(tree)+1
+ currnode<-node
+ while(currnode!=rt){
+ currnode<-getAncestors(tree,currnode,"parent")
+ aa<-c(aa,currnode)
+ }
+ return(aa)
+ } else if(type=="parent"){
+ aa<-tree$edge[which(tree$edge[,2]==node),1]
+ return(aa)
+ } else stop("do not recognize type")
+}
+
+## function for midpoint rooting
+## written by Liam J. Revell 2014
+midpoint.root<-function(tree){
+ D<-cophenetic(tree)
+ dd<-max(D)
+ ii<-which(D==dd)[1]
+ ii<-c(ceiling(ii/nrow(D)),ii%%nrow(D))
+ if(ii[2]==0) ii[2]<-nrow(D)
+ spp<-rownames(D)[ii]
+ nn<-which(tree$tip.label==spp[2])
+ tree<-reroot(tree,nn,tree$edge.length[which(tree$edge[,2]==nn)])
+ aa<-getAncestors(tree,which(tree$tip.label==spp[1]))
+ D<-c(0,dist.nodes(tree)[which(tree$tip.label==spp[1]),aa])
+ names(D)[1]<-which(tree$tip.label==spp[1])
+ i<-0
+ while(D[i+1]<(dd/2)) i<-i+1
+ tree<-reroot(tree,as.numeric(names(D)[i]),D[i+1]-dd/2)
+ tree
+}
+
+# function computes phylogenetic variance-covariance matrix, including for internal nodes
+# written by Liam J. Revell 2011, 2013, 2014, 2015
+vcvPhylo<-function(tree,anc.nodes=TRUE,...){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ # get & set optional arguments
+ if(hasArg(internal)) internal<-list(...)$internal
+ else internal<-anc.nodes
+ if(internal!=anc.nodes){
+ message(paste("arguments \"internal\" and \"anc.nodes\" are synonyms; setting internal =",anc.nodes))
+ internal<-anc.nodes
+ }
+ if(hasArg(model)) model<-list(...)$model
+ else model<-"BM"
+ if(hasArg(tol)) tol<-list(...)$tol
+ else tol<-1e-12
+ if(model=="OU"){
+ if(hasArg(alpha)) alpha<-list(...)$alpha
+ else alpha<-0
+ }
+ if(model=="OU"&&alpha<tol) model<-"BM"
+ if(model=="lambda"){
+ if(hasArg(lambda)){
+ lambda<-list(...)$lambda
+ tree<-lambdaTree(tree,lambda)
+ } else model<-"BM"
+ model<-"BM"
+ }
+ if(model=="EB"){
+ if(hasArg(r)){
+ r<-list(...)$r
+ tree<-ebTree(tree,r)
+ } else model<-"BM"
+ }
+ # done settings
+ n<-Ntip(tree)
+ h<-nodeHeights(tree)[order(tree$edge[,2]),2]
+ h<-c(h[1:n],0,h[(n+1):length(h)])
+ M<-mrca(tree,full=internal)[c(1:n,internal*(n+2:tree$Nnode)),c(1:n,internal*(n+2:tree$Nnode))]
+ C<-matrix(h[M],nrow(M),ncol(M))
+ if(internal) rownames(C)<-colnames(C)<-c(tree$tip.label,n+2:tree$Nnode)
+ else rownames(C)<-colnames(C)<-tree$tip.label
+ if(model=="OU"){
+ D<-dist.nodes(tree)
+ rownames(D)[1:n]<-colnames(D)[1:n]<-tree$tip.label
+ D<-D[rownames(C),colnames(C)]
+ # not sure
+ C<-(1-exp(-2*alpha*C))*exp(-alpha*D)/(2*alpha) # Hansen (2007)
+ # C<-(1-exp(-2*alpha*C))*exp(-2*alpha*(1-C))/(2*alpha) # Butler & King (2004)
+ }
+ return(C)
+}
+
+## simplified lambdaTree to be used internally by vcvPhylo
+## written by Liam J. Revell 2014
+lambdaTree<-function(tree,lambda){
+ ii<-which(tree$edge[,2]>Ntip(tree))
+ H1<-nodeHeights(tree)
+ tree$edge.length[ii]<-lambda*tree$edge.length[ii]
+ H2<-nodeHeights(tree)
+ tree$edge.length[-ii]<-tree$edge.length[-ii]+ H1[-ii,2]-H2[-ii,2]
+ tree
+}
+
+## di2multi method for tree with mapped state
+## written by Liam J. Revell 2013, 2015, 2016
+di2multi.simmap<-function(phy,...){
+ if(hasArg(tol)) tol<-list(...)$tol
+ else tol<-1e-08
+ if(!inherits(phy,"phylo")) stop("tree should be an object of class \"phylo\".")
+ if(is.null(phy$maps)){
+ cat("Warning: tree does not contain mapped state. Using di2multi.\n")
+ return(di2multi(phy,tol))
+ }
+ N<-length(phy$tip.label)
+ n<-length(intersect(which(phy$edge.length<tol),which(phy$edge[,2]>N)))
+ if(n==0) return(phy)
+ edge<-phy$edge
+ edge[edge>N]<--edge[edge>N]+N
+ edge.length<-phy$edge.length
+ maps<-phy$maps
+ Nnode<-phy$Nnode
+ for(i in 1:n){
+ ii<-intersect(which(edge.length<tol),which(edge[,2]<0))[1]
+ node<-edge[ii,2]
+ edge[edge==node]<-edge[ii,1]
+ jj<-which(apply(edge,1,function(x) x[1]==x[2]))[1]
+ edge<-edge[-jj,]
+ edge.length<-edge.length[-jj]
+ maps<-maps[-jj]
+ Nnode<-Nnode-1
+ }
+ nn<-sort(unique(edge[edge<0]),decreasing=TRUE)
+ mm<-1:Nnode+N
+ for(i in 1:length(edge)) if(edge[i]%in%nn) edge[i]<-mm[which(nn==edge[i])]
+ mapped.edge<-makeMappedEdge(edge,maps)
+ tt<-list(edge=edge,Nnode=Nnode,tip.label=phy$tip.label,edge.length=edge.length,
+ maps=maps,mapped.edge=mapped.edge)
+ class(tt)<-"phylo"
+ if(!is.null(attr(phy,"order"))) attr(tt,"order")<-attr(phy,"order")
+ if(!is.null(phy$node.states)) tt$node.states<-getStates(tt,"nodes")
+ if(!is.null(phy$states)) tt$states<-getStates(tt,"tips")
+ return(tt)
+}
+
+# returns the heights of each node
+# written by Liam J. Revell 2011, 2012, 2013, 2015, 2016
+# modified by Klaus Schliep 2017
+nodeHeights<-function(tree,...){
+ if(hasArg(root.edge)) root.edge<-list(...)$root.edge
+ else root.edge<-FALSE
+ if(root.edge) ROOT<-if(!is.null(tree$root.edge)) tree$root.edge else 0
+ else ROOT<-0
+ nHeight <- function(tree){
+ tree <- reorder(tree)
+ edge <- tree$edge
+ el <- tree$edge.length
+ res <- numeric(max(tree$edge))
+ for(i in seq_len(nrow(edge))) res[edge[i,2]] <- res[edge[i,1]] + el[i]
+ res
+ }
+ nh <- nHeight(tree)
+ return(matrix(nh[tree$edge], ncol=2L)+ROOT)
+}
+
+## function drops all the leaves from the tree & collapses singleton nodes
+## written by Liam J. Revell 2013, 2014, 2015
+drop.leaves<-function(tree,...){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ ## optional arguments
+ if(hasArg(keep.tip.labels)) keep.tip.labels<-list(...)$keep.tip.labels
+ else keep.tip.labels<-FALSE
+ ## end optional arguments
+ n<-Ntip(tree)
+ edge<-tree$edge
+ edge[edge>n]<--edge[edge>n]+n
+ ii<-which(edge[,2]>0)
+ edge<-edge[-ii,]
+ if(!is.null(tree$edge.length)){
+ edge.length<-tree$edge.length
+ edge.length<-edge.length[-ii]
+ }
+ zz<-sapply(edge[,2],function(x,y) !(x%in%y),y=edge[,1])
+ if(is.null(tree$node.label)) tree$node.label<-1:tree$Nnode+n
+ nn<-matrix(tree$node.label[-edge],nrow(edge),ncol(edge))
+ tip.label<-nn[zz,2]
+ node.label<-c(nn[1,1],nn[!zz,2])
+ edge[zz,2]<-1:sum(zz)
+ Nnode<-length(unique(edge[edge<0]))
+ rr<-cbind(sort(unique(edge[edge<0]),decreasing=TRUE),1:Nnode+sum(zz))
+ for(i in 1:nrow(rr)) edge[edge==rr[i,1]]<-rr[i,2]
+ tt<-list(edge=edge,Nnode=Nnode,tip.label=tip.label,edge.length=edge.length,node.label=node.label)
+ class(tt)<-"phylo"
+ tt<-collapse.singles(tt)
+ if(keep.tip.labels){
+ for(i in 1:length(tt$tip.label)){
+ yy<-getDescendants(tree,node=which(tree$node.label==tt$tip.label[i])+n)
+ tt$tip.label[i]<-paste(tree$tip.label[yy[yy<=n]],collapse=",")
+ }
+ }
+ return(tt)
+}
+
+# function rounds the branch lengths of the tree & applies rounding to simmap tree
+# written by Liam J. Revell 2012, 2013, 2015
+roundBranches<-function(tree,digits=0){
+ if(inherits(tree,"multiPhylo")){
+ trees<-lapply(tree,roundBranches,digits=digits)
+ class(trees)<-"multiPhylo"
+ return(trees)
+ } else if(inherits(tree,"phylo")) {
+ tree$edge.length<-round(tree$edge.length,digits)
+ if(!is.null(tree$maps)){
+ for(i in 1:nrow(tree$edge)){
+ temp<-tree$maps[[i]]/sum(tree$maps[[i]])
+ tree$maps[[i]]<-temp*tree$edge.length[i]
+ }
+ }
+ if(!is.null(tree$mapped.edge)){
+ a<-vector()
+ for(i in 1:nrow(tree$edge)) a<-c(a,names(tree$maps[[i]]))
+ a<-unique(a)
+ tree$mapped.edge<-matrix(data=0,length(tree$edge.length),length(a),dimnames=list(apply(tree$edge,1,function(x) paste(x,collapse=",")),state=a))
+ for(i in 1:length(tree$maps)) for(j in 1:length(tree$maps[[i]])) tree$mapped.edge[i,names(tree$maps[[i]])[j]]<-tree$mapped.edge[i,names(tree$maps[[i]])[j]]+tree$maps[[i]][j]
+ }
+ return(tree)
+ } else stop("tree should be an object of class \"phylo\" or \"multiPhylo\".")
+}
+
+# function to merge mapped states
+# written by Liam J. Revell 2013, 2015, 2019
+mergeMappedStates<-function(tree,old.states,new.state){
+ if(inherits(tree,"multiSimmap")){
+ tree<-unclass(tree)
+ tree<-lapply(tree,mergeMappedStates,old.states=old.states,new.state=new.state)
+ class(tree)<-c("multiSimmap","multiPhylo")
+ } else if(inherits(tree,"simmap")) {
+ maps<-tree$maps
+ rr<-function(map,oo,nn){
+ for(i in 1:length(map)) if(names(map)[i]%in%oo) names(map)[i]<-nn
+ map
+ }
+ mm<-function(map){
+ if(length(map)>1){
+ new.map<-vector()
+ j<-1
+ new.map[j]<-map[1]
+ names(new.map)[j]<-names(map)[1]
+ for(i in 2:length(map)){
+ if(names(map)[i]==names(map)[i-1]){
+ new.map[j]<-map[i]+new.map[j]
+ names(new.map)[j]<-names(map)[i]
+ } else {
+ j<-j+1
+ new.map[j]<-map[i]
+ names(new.map)[j]<-names(map)[i]
+ }
+
+ }
+ map<-new.map
+ }
+ map
+ }
+ maps<-lapply(maps,rr,oo=old.states,nn=new.state)
+ if(length(old.states)>1){
+ maps<-lapply(maps,mm)
+ mapped.edge<-tree$mapped.edge
+ mapped.edge<-cbind(rowSums(mapped.edge[,colnames(mapped.edge)%in%old.states]),
+ mapped.edge[,setdiff(colnames(mapped.edge),old.states)])
+ colnames(mapped.edge)<-c(new.state,setdiff(colnames(tree$mapped.edge),old.states))
+ } else {
+ mapped.edge<-tree$mapped.edge
+ colnames(mapped.edge)[which(colnames(mapped.edge)==old.states)]<-new.state
+ }
+ tree$maps<-maps
+ tree$mapped.edge<-mapped.edge
+ } else stop("tree should be an object of class \"simmap\" or \"multiSimmap\".")
+ return(tree)
+}
+
+# function rotates a node or multiple nodes
+# written by Liam J. Revell 2013, 2015
+rotateNodes<-function(tree,nodes,polytom=c(1,2),...){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ n<-Ntip(tree)
+ if(nodes[1]=="all") nodes<-1:tree$Nnode+n
+ for(i in 1:length(nodes)) tree<-rotate(tree,nodes[i],polytom)
+ if(hasArg(reversible)) reversible<-list(...)$reversible
+ else reversible<-TRUE
+ if(reversible){
+ ii<-which(tree$edge[,2]<=n)
+ jj<-tree$edge[ii,2]
+ tree$edge[ii,2]<-1:n
+ tree$tip.label<-tree$tip.label[jj]
+ }
+ return(tree)
+}
+
+# function simulates random sampling from xbar, xvar, with sample sizes n
+# written by Liam J. Revell 2012
+sampleFrom<-function(xbar=0,xvar=1,n=1,randn=NULL,type="norm"){
+ if(length(xvar)==1&&length(xbar)!=length(xvar)) xvar<-rep(xvar,length(xbar))
+ if(!is.null(randn))
+ for(i in 1:length(xbar)) n[i]<-floor(runif(n=1,min=randn[1],max=(randn[2]+1)))
+ x<-vector()
+
+ for(i in 1:length(xbar)){
+ y<-rnorm(n=n[i],mean=xbar[i],sd=sqrt(xvar[i]))
+ names(y)<-rep(names(xbar)[i],length(y))
+ x<-c(x,y)
+ }
+ return(x)
+}
+
+# function adds a new tip to the tree
+# written by Liam J. Revell 2012, 2013, 2014, 2015
+bind.tip<-function(tree,tip.label,edge.length=NULL,where=NULL,position=0,interactive=FALSE,...){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ use.edge.length<-if(is.null(tree$edge.length)) FALSE else TRUE
+ if(use.edge.length==FALSE) tree<-compute.brlen(tree)
+ if(interactive==TRUE){
+ plotTree(tree,...)
+ cat(paste("Click where you would like to bind the tip \"",tip.label,"\"\n",sep=""))
+ flush.console()
+ obj<-get.treepos(message=FALSE)
+ where<-obj$where
+ position<-obj$pos
+ } else if(is.null(where)) where<-Ntip(tree)+1
+ if(where<=Ntip(tree)&&position==0){
+ pp<-1e-12
+ if(tree$edge.length[which(tree$edge[,2]==where)]<=1e-12){
+ tree$edge.length[which(tree$edge[,2]==where)]<-2e-12
+ ff<-TRUE
+ } else ff<-FALSE
+ } else pp<-position
+ if(is.null(edge.length)&&is.ultrametric(tree)){
+ H<-nodeHeights(tree)
+ if(where==(Ntip(tree)+1)) edge.length<-max(H)
+ else edge.length<-max(H)-H[tree$edge[,2]==where,2]+position
+ }
+ tip<-list(edge=matrix(c(2,1),1,2),
+ tip.label=tip.label,
+ edge.length=edge.length,
+ Nnode=1)
+ class(tip)<-"phylo"
+ obj<-bind.tree(tree,tip,where=where,position=pp)
+ if(where<=Ntip(tree)&&position==0){
+ nn<-obj$edge[which(obj$edge[,2]==which(obj$tip.label==tip$tip.label)),1]
+ obj$edge.length[which(obj$edge[,2]==nn)]<-obj$edge.length[which(obj$edge[,2]==nn)]+1e-12
+ obj$edge.length[which(obj$edge[,2]==which(obj$tip.label==tip$tip.label))]<-0
+ obj$edge.length[which(obj$edge[,2]==which(obj$tip.label==tree$tip.label[where]))]<-0
+ }
+ root.time<-if(!is.null(obj$root.time)) obj$root.time else NULL
+ obj<-untangle(obj,"read.tree")
+ if(!is.null(root.time)) obj$root.time<-root.time
+ if(interactive) plotTree(obj,...)
+ if(!use.edge.length) obj$edge.length<-NULL
+ obj
+}
+
+## function collapses the subtree descended from node to a star tree
+## written by Liam J. Revell 2013, 2015, 2019
+collapse.to.star<-function(tree,node){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ if(node==(Ntip(tree)+1)){
+ object<-list(edge=cbind(rep(Ntip(tree)+1,Ntip(tree)),1:Ntip(tree)),
+ tip.label=tree$tip.label,Nnode=1)
+ if(!is.null(tree$edge.length)) object$edge.length<-sapply(1:Ntip(tree),nodeheight,tree=tree)
+ class(object)<-"phylo"
+ tree<-object
+ } else {
+ nel<-if(is.null(tree$edge.length)) TRUE else FALSE
+ if(nel) tree$edge.length<-rep(1,nrow(tree$edge))
+ tt<-splitTree(tree,split=list(node=node,
+ bp=tree$edge.length[which(tree$edge[,2]==node)]))
+ ss<-starTree(species=tt[[2]]$tip.label,
+ branch.lengths=diag(vcv(tt[[2]])))
+ ss$root.edge<-0
+ tree<-paste.tree(tt[[1]],ss)
+ if(nel) tree$edge.length<-NULL
+ }
+ tree
+}
+
+## function returns the MRCA, or its height above the root, for a set of taxa (in tips)
+## written by Liam Revell 2012, 2013, 2015, 2016
+findMRCA<-function(tree,tips=NULL,type=c("node","height")){
+ type<-type[1]
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ if(is.null(tips)){
+ X<-mrca(tree)
+ if(type=="height"){
+ H<-nodeHeights(tree)
+ X<-apply(X,c(1,2),function(x,y,z) y[which(z==x)[1]],y=H,z=tree$edge)
+ }
+ return(X)
+ } else {
+ node<-getMRCA(tree,tips)
+ if (type == "node") return(node)
+ else if(type=="height") return(nodeheight(tree,node))
+ }
+}
+
+# function works like extract.clade in ape but will preserve a discrete character mapping
+# written by Liam J. Revell 2013
+extract.clade.simmap<-function(tree,node){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ x<-getDescendants(tree,node)
+ x<-x[x<=Ntip(tree)]
+ drop.tip.simmap(tree,tree$tip.label[-x])
+}
+
+# function gets all subtrees that cannot be further subdivided into two clades of >= clade.size
+# written by Liam J. Revell 2013, 2015
+getCladesofSize<-function(tree,clade.size=2){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ n<-Ntip(tree)
+ nn<-1:(tree$Nnode+n)
+ ndesc<-function(tree,node){
+ x<-getDescendants(tree,node)
+ sum(x<=Ntip(tree))
+ }
+ dd<-setNames(sapply(nn,ndesc,tree=tree),nn)
+ aa<-n+1 # root
+ nodes<-vector()
+ while(length(aa)){
+ bb<-lapply(aa,function(x,tree) tree$edge[which(tree$edge[,1]==x),2],tree=tree)
+ cc<-lapply(bb,function(x) dd[as.character(x)])
+ gg<-sapply(cc,function(x,cs) any(x<cs),cs=clade.size)
+ nodes<-c(nodes,aa[gg])
+ aa<-unlist(bb[!gg])
+ }
+ trees<-lapply(nodes,extract.clade,phy=tree)
+ class(trees)<-"multiPhylo"
+ return(trees)
+}
+
+# function counts transitions from a mapped history
+# written by Liam J. Revell 2013, 2015
+countSimmap<-function(tree,states=NULL,message=TRUE){
+ if(inherits(tree,"multiPhylo")){
+ ff<-function(zz){
+ XX<-countSimmap(zz,states,message)
+ setNames(c(XX$N,as.vector(t(XX$Tr))),c("N",
+ sapply(rownames(XX$Tr),paste,colnames(XX$Tr),sep=",")))
+ }
+ tree<-unclass(tree)
+ XX<-t(sapply(tree,ff))
+ if(!message) return(XX)
+ else return(list(Tr=XX,message=
+ c("Column N is the total number of character changes on the tree",
+ "Other columns give transitions x,y from x->y")))
+ } else if(inherits(tree,"phylo")) {
+ n<-sum(sapply(tree$maps,length))-nrow(tree$edge)
+ if(is.null(states)) states<-colnames(tree$mapped.edge)
+ m<-length(states)
+ TT<-matrix(NA,m,m,dimnames=list(states,states))
+ gg<-function(map,a,b){
+ if(length(map)==1) zz<-0
+ else {
+ zz<-0; i<-2
+ while(i<=length(map)){
+ if(names(map)[i]==b&&names(map)[i-1]==a) zz<-zz+1
+ i<-i+1
+ }
+ }
+ return(zz)
+ }
+ for(i in 1:m) for(j in 1:m)
+ if(i==j) TT[i,j]<-0
+ else TT[i,j]<-sum(sapply(tree$maps,gg,a=states[i],b=states[j]))
+ if(!message) return(list(N=n,Tr=TT))
+ else return(list(N=n,Tr=TT,message=c(
+ "N is the total number of character changes on the tree",
+ "Tr gives the number of transitions from row state->column state")))
+ }
+}
+
+# function to match nodes between trees
+# written by Liam J. Revell 2012, 2013, 2015
+matchNodes<-function(tr1,tr2,method=c("descendants","distances"),...){
+ if(!inherits(tr1,"phylo")||!inherits(tr1,"phylo")) stop("tr1 & tr2 should both be objects of class \"phylo\".")
+ if(hasArg(quiet)) quiet<-list(...)$quiet
+ else quiet<-FALSE
+ method<-method[1]
+ method<-matchType(method,c("descendants","distances"))
+ if(method=="descendants"){
+ desc.tr1<-lapply(1:tr1$Nnode+length(tr1$tip),function(x) extract.clade(tr1,x)$tip.label)
+ names(desc.tr1)<-1:tr1$Nnode+length(tr1$tip)
+ desc.tr2<-lapply(1:tr2$Nnode+length(tr2$tip),function(x) extract.clade(tr2,x)$tip.label)
+ names(desc.tr2)<-1:tr2$Nnode+length(tr2$tip)
+ Nodes<-matrix(NA,length(desc.tr1),2,dimnames=list(NULL,c("tr1","tr2")))
+ for(i in 1:length(desc.tr1)){
+ Nodes[i,1]<-as.numeric(names(desc.tr1)[i])
+ for(j in 1:length(desc.tr2))
+ if(all(desc.tr1[[i]]%in%desc.tr2[[j]])&&all(desc.tr2[[j]]%in%desc.tr1[[i]]))
+ Nodes[i,2]<-as.numeric(names(desc.tr2)[j])
+ }
+ } else if(method=="distances"){
+ if(hasArg(tol)) tol<-list(...)$tol
+ else tol<-1e-6
+ if(hasArg(corr)) corr<-list(...)$corr
+ else corr<-FALSE
+ if(corr) tr1$edge.length<-tr1$edge.length/max(nodeHeights(tr1))
+ if(corr) tr2$edge.length<-tr2$edge.length/max(nodeHeights(tr2))
+ D1<-dist.nodes(tr1)[1:length(tr1$tip),1:tr1$Nnode+length(tr1$tip)]
+ D2<-dist.nodes(tr2)[1:length(tr2$tip),1:tr2$Nnode+length(tr2$tip)]
+ rownames(D1)<-tr1$tip.label
+ rownames(D2)<-tr2$tip.label
+ common.tips<-intersect(tr1$tip.label,tr2$tip.label)
+ D1<-D1[common.tips,]
+ D2<-D2[common.tips,]
+ Nodes<-matrix(NA,tr1$Nnode,2,dimnames=list(NULL,c("tr1","tr2")))
+ for(i in 1:tr1$Nnode){
+ if(corr) z<-apply(D2,2,function(X,y) cor(X,y),y=D1[,i])
+ else z<-apply(D2,2,function(X,y) 1-sum(abs(X-y)),y=D1[,i])
+ Nodes[i,1]<-as.numeric(colnames(D1)[i])
+ if(any(z>=(1-tol))){
+ a<-as.numeric(names(which(z>=(1-tol))))
+ if(length(a)==1) Nodes[i,2]<-a
+ else {
+ Nodes[i,2]<-a[1]
+ if(!quiet) warning("polytomy detected; some node matches may be arbitrary")
+ }
+ }
+ }
+ }
+ return(Nodes)
+}
+
+# function applies the branch lengths of a reference tree to a second tree, including mappings
+
+# written by Liam J. Revell 2012, 2015
+applyBranchLengths<-function(tree,edge.length){
+ if(inherits(tree,"multiPhylo")){
+ trees<-lapply(tree,applyBranchLengths,edge.length=edge.length)
+ class(trees)<-"multiPhylo"
+ return(trees)
+ } else if(inherits(tree,"phylo")) {
+ tree$edge.length<-edge.length
+ if(!is.null(tree$maps)){
+ for(i in 1:nrow(tree$edge)){
+ temp<-tree$maps[[i]]/sum(tree$maps[[i]])
+ tree$maps[[i]]<-temp*tree$edge.length[i]
+ }
+ }
+ if(!is.null(tree$mapped.edge)){
+ a<-vector()
+ for(i in 1:nrow(tree$edge)) a<-c(a,names(tree$maps[[i]]))
+ a<-unique(a)
+ tree$mapped.edge<-matrix(data=0,length(tree$edge.length),length(a),dimnames=list(apply(tree$edge,1,function(x) paste(x,collapse=",")),state=a))
+ for(i in 1:length(tree$maps)) for(j in 1:length(tree$maps[[i]])) tree$mapped.edge[i,names(tree$maps[[i]])[j]]<-tree$mapped.edge[i,names(tree$maps[[i]])[j]]+tree$maps[[i]][j]
+ }
+ return(tree)
+ }
+}
+
+# function to compute phylogenetic VCV using joint Pagel's lambda
+# written by Liam Revell 2011
+
+phyl.vcv<-function(X,C,lambda){
+ C<-lambda.transform(lambda,C)
+ invC<-solve(C)
+ a<-matrix(colSums(invC%*%X)/sum(invC),ncol(X),1)
+ A<-matrix(rep(a,nrow(X)),nrow(X),ncol(X),byrow=T)
+ V<-t(X-A)%*%invC%*%(X-A)/(nrow(C)-1)
+ return(list(C=C,R=V,alpha=a))
+}
+
+# lambda transformation of C
+# written by Liam Revell 2011
+lambda.transform<-function(lambda,C){
+ if(lambda==1) return(C)
+ else {
+ V<-diag(diag(C))
+ C<-C-V
+ C.lambda<-(V+lambda*C)
+ return(C.lambda)
+ }
+}
+
+# likelihood function for joint estimation of lambda for multiple traits
+# written by Liam Revell 2011/2012
+likMlambda<-function(lambda,X,C){
+ # compute R, conditioned on lambda
+ temp<-phyl.vcv(X,C,lambda);
+ C<-temp$C; R<-temp$R; a<-temp$alpha
+ # prep
+ n<-nrow(X); m<-ncol(X); D<-matrix(0,n*m,m)
+ for(i in 1:(n*m)) for(j in 1:m) if((j-1)*n<i&&i<=j*n) D[i,j]=1.0
+ y<-as.matrix(as.vector(X))
+ # compute the log-likelihood
+ kronRC<-kronecker(R,C)
+ logL<--t(y-D%*%a)%*%solve(kronRC,y-D%*%a)/2-n*m*log(2*pi)/2-determinant(kronRC,logarithm=TRUE)$modulus/2
+ return(logL)
+}
+
+# function matches data to tree
+# written by Liam J. Revell 2011, 2015
+matchDatatoTree<-function(tree,x,name){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ if(is.matrix(x)) x<-x[,1]
+ if(is.null(names(x))){
+ if(length(x)==Ntip(tree)){
+ print(paste(name,"has no names; assuming x is in the same order as tree$tip.label"))
+ names(x)<-tree$tip.label
+ } else
+
+ stop(paste(name,"has no names and is a different length than tree$tip.label"))
+
+ }
+ if(any(is.na(match(names(x),tree$tip.label)))){
+ print(paste("some species in",name,"are missing from tree, dropping missing taxa from",name))
+ x<-x[intersect(tree$tip.label,names(x))]
+ }
+ return(x)
+}
+
+# function matches tree to data
+# written by Liam J. Revell 2011, 2015
+matchTreetoData<-function(tree,x,name){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ if(any(is.na(match(tree$tip.label,names(x))))){
+ print(paste("some species in tree are missing from",name,", dropping missing taxa from the tree"))
+ tree<-drop.tip(tree,setdiff(tree$tip.label,names(x)))
+ }
+ if(any(is.na(x))){
+ print(paste("some data in",name,"given as 'NA', dropping corresponding species from tree"))
+ tree<-drop.tip(tree,names(which(is.na(x))))
+ }
+ return(tree)
+}
+
+# function finds the maximum value of Pagel's lambda
+# written by Liam J. Revell 2011
+maxLambda<-function(tree){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ if(is.ultrametric(tree)){
+ H<-nodeHeights(tree)
+ return(max(H[,2])/max(H[,1]))
+ } else return(1)
+}
+
+# function reorders the columns of mapped.edge from a set of simmap trees
+
+# written by Liam J. Revell 2013, 2015
+orderMappedEdge<-function(trees,ordering=NULL){
+ if(!inherits(trees,"phylo")&&!inherits(trees,"multiPhylo"))
+ stop("trees should be an object of class \"phylo\" or \"multiPhylo\".")
+ f1<-function(tree,ordering){
+ mapped.edge<-matrix(0,nrow(tree$mapped.edge),length(ordering),
+ dimnames=list(rownames(tree$mapped.edge),ordering))
+ mapped.edge[,colnames(tree$mapped.edge)]<-tree$mapped.edge
+ tree$mapped.edge<-mapped.edge
+ return(tree)
+ }
+ f2<-function(tree) colnames(tree$mapped.edge)
+ if(inherits(trees,"phylo")) states<-colnames(trees$mapped.edge)
+ else if(inherits(trees,"multiPhylo")) states<-unique(as.vector(sapply(trees,f2)))
+ if(length(ordering)>1) if(length(intersect(states,ordering))<length(states)){
+ warning("not all states represented in input ordering; setting to default")
+ ordering<-NULL
+ }
+ if(is.null(ordering)) ordering<-"alphabetical"
+ if(length(ordering)==1){
+ ordering<-matchType(ordering,c("alphabetical","numerical"))
+ if(ordering=="alphabetical") ordering<-sort(states)
+ else if(ordering=="numerical") ordering<-as.character(sort(as.numeric(states)))
+ }
+ if(inherits(trees,"phylo")) trees<-f1(trees,ordering)
+ else {
+ trees<-lapply(trees,f1,ordering=ordering)
+ class(trees)<-"multiPhylo"
+ }
+ return(trees)
+}
+
+# function gets sister node numbers or names
+# written by Liam J. Revell 2013, 2015
+getSisters<-function(tree,node,mode=c("number","label")){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ mode<-mode[1]
+ if(is.character(node)) node<-match(node,c(tree$tip.label,tree$node.label))
+ sisters<-tree$edge[which(tree$edge[,1]==tree$edge[which(tree$edge[,2]==node),1]),2]
+ sisters<-setdiff(sisters,node)
+ if(mode=="number") return(sisters)
+ else if(mode=="label"){
+ result<-list()
+ n<-Ntip(tree)
+ if(is.null(tree$node.label)&&any(sisters>n)) result$nodes<-sisters[which(sisters>n)]
+ else if(any(sisters>n)) result$nodes<-tree$node.label[sisters[which(sisters>n)]-n]
+ if(any(sisters<=n)) result$tips<-tree$tip.label[sisters[which(sisters<=n)]]
+ return(result)
+ }
+}
+
+# gets descendant node numbers
+# written by Liam Revell 2012, 2013, 2014
+getDescendants<-function(tree,node,curr=NULL){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ if(is.null(curr)) curr<-vector()
+ daughters<-tree$edge[which(tree$edge[,1]==node),2]
+ curr<-c(curr,daughters)
+ if(length(curr)==0&&node<=Ntip(tree)) curr<-node
+ w<-which(daughters>Ntip(tree))
+ if(length(w)>0) for(i in 1:length(w))
+ curr<-getDescendants(tree,daughters[w[i]],curr)
+ return(curr)
+}
+
+# function computes vcv for each state, and stores in array
+# written by Liam J. Revell 2011, 2012, 2016
+multiC<-function(tree,internal=FALSE){
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ if(!inherits(tree,"simmap")) stop("tree should be an object of class \"simmap\".")
+ m<-ncol(tree$mapped.edge)
+ # compute separate C for each state
+ mC<-list()
+ for(i in 1:m){
+ mtree<-list(edge=tree$edge,
+ Nnode=tree$Nnode,
+ tip.label=tree$tip.label,
+ edge.length=tree$mapped.edge[,i])
+ class(mtree)<-"phylo"
+ mC[[i]]<-if(internal) vcvPhylo(mtree,internal=TRUE) else vcv.phylo(mtree)
+ }
+ names(mC)<-colnames(tree$mapped.edge)
+ mC
+}
+
+# function pastes subtree onto tip
+# written by Liam Revell 2011, 2015
+paste.tree<-function(tr1,tr2){
+ if(!inherits(tr1,"phylo")||!inherits(tr2,"phylo")) stop("tr1 & tr2 should be objects of class \"phylo\".")
+ if(length(tr2$tip)>1){
+ temp<-tr2$root.edge; tr2$root.edge<-NULL
+ tr1$edge.length[match(which(tr1$tip.label=="NA"),tr1$edge[,2])]<-tr1$edge.length[match(which(tr1$tip.label=="NA"),tr1$edge[,2])]+temp
+ }
+ tr.bound<-bind.tree(tr1,tr2,where=which(tr1$tip.label=="NA"))
+ return(tr.bound)
+}
+
+# match type
+# written by Liam J. Revell 2012
+matchType<-function(type,types){
+ for(i in 1:length(types))
+ if(all(strsplit(type,split="")[[1]]==strsplit(types[i],split="")[[1]][1:length(strsplit(type,split="")[[1]])]))
+ type=types[i]
+ return(type)
+}
+
+## function 'untangles' (or attempts to untangle) a tree with crossing branches
+## written by Liam J. Revell 2013, 2015, 2020, 2021
+untangle<-function(tree,method=c("reorder","read.tree")){
+ if(inherits(tree,"multiPhylo")){
+ tree<-lapply(tree,untangle,method=method)
+ class(tree)<-"multiPhylo"
+ } else {
+ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".")
+ obj<-attributes(tree)
+ method<-method[1]
+ if(method=="reorder") tree<-reorder(reorder(tree,"pruningwise"))
+ else if(method=="read.tree"){
+ tip.label<-tree$tip.label
+ tree$tip.label<-1:Ntip(tree)
+ if(inherits(tree,"simmap"))
+ tree<-read.simmap(text=capture.output(write.simmap(tree,file=stdout())))
+ else tree<-if(Ntip(tree)>1) read.tree(text=write.tree(tree)) else read.newick(text=write.tree(tree))
+ tree$tip.label<-tip.label[as.numeric(tree$tip.label)]
+ }
+ ii<-!names(obj)%in%names(attributes(tree))
+ attributes(tree)<-c(attributes(tree),obj[ii])
+ }
+ tree
+}
+
diff --git a/R/writeNexus.R b/R/writeNexus.R
index dd8fc91..bc642cf 100644
--- a/R/writeNexus.R
+++ b/R/writeNexus.R
@@ -1,29 +1,29 @@
-# function
-# written by Liam J. Revell 2012, 2015
-
-writeNexus<-function(tree,file=""){
- if(inherits(tree,"multiPhylo")) N<-length(tree)
- else {
- N<-1
- tree<-list(tree)
- }
- n<-length(tree[[1]]$tip.label)
- write("#NEXUS",file)
- write(paste("[R-package PHYTOOLS, ",date(),"]\n",sep=""),file,append=TRUE)
- write("BEGIN TAXA;",file,append=TRUE)
- write(paste("\tDIMENSIONS NTAX = ",n,";",sep=""),file,append=TRUE)
- write("\tTAXLABELS",file,append=TRUE)
- trans<-tree[[1]]$tip.label; trans<-sort(trans)
- for(i in 1:n) write(paste("\t\t",trans[i],sep=""),file,append=TRUE)
- write("\t;",file,append=TRUE)
- write("END;",file,append=TRUE)
- write("BEGIN TREES;\n\tTRANSLATE",file,append=TRUE)
- for(i in 1:(n-1)) write(paste("\t\t",i,"\t",trans[i],",",sep=""),file,append=TRUE)
- write(paste("\t\t",i+1,"\t",trans[i+1],sep=""),file,append=TRUE)
- write("\t;",file,append=TRUE)
- for(i in 1:N){
- tree[[i]]$tip.label<-sapply(tree[[i]]$tip.label,function(x) which(x==trans))
- write(paste("\tTREE * UNTITLED = [&R] ",write.tree(tree[[i]]),sep=""),file,append=TRUE)
- }
- write("END;",file,append=TRUE)
-}
+# function
+# written by Liam J. Revell 2012, 2015
+
+writeNexus<-function(tree,file=""){
+ if(inherits(tree,"multiPhylo")) N<-length(tree)
+ else {
+ N<-1
+ tree<-list(tree)
+ }
+ n<-length(tree[[1]]$tip.label)
+ write("#NEXUS",file)
+ write(paste("[R-package PHYTOOLS, ",date(),"]\n",sep=""),file,append=TRUE)
+ write("BEGIN TAXA;",file,append=TRUE)
+ write(paste("\tDIMENSIONS NTAX = ",n,";",sep=""),file,append=TRUE)
+ write("\tTAXLABELS",file,append=TRUE)
+ trans<-tree[[1]]$tip.label; trans<-sort(trans)
+ for(i in 1:n) write(paste("\t\t",trans[i],sep=""),file,append=TRUE)
+ write("\t;",file,append=TRUE)
+ write("END;",file,append=TRUE)
+ write("BEGIN TREES;\n\tTRANSLATE",file,append=TRUE)
+ for(i in 1:(n-1)) write(paste("\t\t",i,"\t",trans[i],",",sep=""),file,append=TRUE)
+ write(paste("\t\t",i+1,"\t",trans[i+1],sep=""),file,append=TRUE)
+ write("\t;",file,append=TRUE)
+ for(i in 1:N){
+ tree[[i]]$tip.label<-sapply(tree[[i]]$tip.label,function(x) which(x==trans))
+ write(paste("\tTREE * UNTITLED = [&R] ",write.tree(tree[[i]]),sep=""),file,append=TRUE)
+ }
+ write("END;",file,append=TRUE)
+}
diff --git a/data/butterfly.data.rda b/data/butterfly.data.rda
new file mode 100644
index 0000000..bbbffc2
Binary files /dev/null and b/data/butterfly.data.rda differ
diff --git a/data/butterfly.tree.rda b/data/butterfly.tree.rda
new file mode 100644
index 0000000..a92707a
Binary files /dev/null and b/data/butterfly.tree.rda differ
diff --git a/data/cordylid.data.rda b/data/cordylid.data.rda
new file mode 100644
index 0000000..9ad9c65
Binary files /dev/null and b/data/cordylid.data.rda differ
diff --git a/data/cordylid.tree.rda b/data/cordylid.tree.rda
new file mode 100644
index 0000000..a671c0a
Binary files /dev/null and b/data/cordylid.tree.rda differ
diff --git a/data/datalist b/data/datalist
index ee7e60d..95fe03a 100644
--- a/data/datalist
+++ b/data/datalist
@@ -1,15 +1,24 @@
-anole.data
-anoletree
-bonyfish.data
-bonyfish.tree
-flatworm.data
-flatworm.tree
-mammal.data
-mammal.tree
-salamanders
-sunfish.data
-sunfish.tree
-vertebrate.data
-vertebrate.tree
-wasp.data
-wasp.trees
+anole.data
+anoletree
+butterfly.data
+butterfly.tree
+bonyfish.data
+bonyfish.tree
+cordylid.data
+cordylid.tree
+flatworm.data
+flatworm.tree
+liolaemid.tree
+mammal.data
+mammal.tree
+primate.data
+primate.tree
+salamanders
+sunfish.data
+sunfish.tree
+tropidurid.data
+tropidurid.tree
+vertebrate.data
+vertebrate.tree
+wasp.data
+wasp.trees
diff --git a/data/liolaemid.tree.rda b/data/liolaemid.tree.rda
new file mode 100644
index 0000000..73e33f5
Binary files /dev/null and b/data/liolaemid.tree.rda differ
diff --git a/data/primate.data.rda b/data/primate.data.rda
new file mode 100644
index 0000000..0895a39
Binary files /dev/null and b/data/primate.data.rda differ
diff --git a/data/primate.tree.rda b/data/primate.tree.rda
new file mode 100644
index 0000000..05a1667
Binary files /dev/null and b/data/primate.tree.rda differ
diff --git a/data/tropidurid.data.rda b/data/tropidurid.data.rda
new file mode 100644
index 0000000..757bb0b
Binary files /dev/null and b/data/tropidurid.data.rda differ
diff --git a/data/tropidurid.tree.rda b/data/tropidurid.tree.rda
new file mode 100644
index 0000000..7c255e0
Binary files /dev/null and b/data/tropidurid.tree.rda differ
diff --git a/debian/changelog b/debian/changelog
index e3e4f97..b2757fb 100644
--- a/debian/changelog
+++ b/debian/changelog
@@ -1,3 +1,9 @@
+r-cran-phytools (1.5-1+git20230225.1.06aba3c-1) UNRELEASED; urgency=low
+
+ * New upstream snapshot.
+
+ -- Debian Janitor <janitor@jelmer.uk> Sun, 26 Feb 2023 12:45:48 -0000
+
r-cran-phytools (1.5-1-1) unstable; urgency=medium
* New upstream version
diff --git a/inst/CITATION b/inst/CITATION
index 476791f..c6b3e91 100644
--- a/inst/CITATION
+++ b/inst/CITATION
@@ -7,4 +7,5 @@ bibentry(bibtype = "Article",
pages = "217-223",
doi = "10.1111/j.2041-210X.2011.00169.x",
header = "To cite phytools in a publication please use:",
+ textVersion = "Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). Methods in Ecology and Evolution, 3, 217-223.",
footer = "As phytools is continually evolving you may also want to cite its version number (found with 'library(help = phytools)' or 'packageVersion(\"phytools\")').")
diff --git a/man/Dtest.Rd b/man/Dtest.Rd
index 9a78fb3..2c7597f 100644
--- a/man/Dtest.Rd
+++ b/man/Dtest.Rd
@@ -1,35 +1,35 @@
-\name{Dtest}
-\alias{Dtest}
-\title{Conducts correlational D-test from stochastic mapping}
-\usage{
-Dtest(t1, t2, nsim=100, ...)
-}
-\arguments{
- \item{t1}{set of stochastic map trees (i.e., object of class \code{"multiSimmap"} for character 1. Note that \code{t1} and \code{t2} should be of the same length.}
- \item{t2}{set of stochastic map trees (i.e., object of class \code{"multiSimmap"} for character 2. Note that \code{t1} and \code{t2} should be of the same length.}
- \item{nsim}{number of simulations to use in the test.}
- \item{...}{arguments to be passed internally to \code{make.simmap}. Note that (for now) these must be the same for both \code{t1} and \code{t2} (that is to say, we are not able to assume different trait evolution models for each tree).}
-}
-\description{
- Conducts the 'D-test' of Huelsenbeck et al. (2003).
-}
-\details{
- Note that this function has been included without much testing, and so the user should be wary.
-}
-\value{
- An object of class \code{"Dtest"}.
-}
-\references{
- Huelsenbeck, J. P., R. Neilsen, and J. P. Bollback (2003) Stochastic mapping of morphological characters. \emph{Systematic Biology}, \bold{52}, 131-138.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{make.simmap}}, \code{\link{map.overlap}}
-}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{simulation}
-\keyword{bayesian}
-\keyword{discrete character}
+\name{Dtest}
+\alias{Dtest}
+\title{Conducts correlational D-test from stochastic mapping}
+\usage{
+Dtest(t1, t2, nsim=100, ...)
+}
+\arguments{
+ \item{t1}{set of stochastic map trees (i.e., object of class \code{"multiSimmap"} for character 1. Note that \code{t1} and \code{t2} should be of the same length.}
+ \item{t2}{set of stochastic map trees (i.e., object of class \code{"multiSimmap"} for character 2. Note that \code{t1} and \code{t2} should be of the same length.}
+ \item{nsim}{number of simulations to use in the test.}
+ \item{...}{arguments to be passed internally to \code{make.simmap}. Note that (for now) these must be the same for both \code{t1} and \code{t2} (that is to say, we are not able to assume different trait evolution models for each tree).}
+}
+\description{
+ Conducts the 'D-test' of Huelsenbeck et al. (2003).
+}
+\details{
+ Note that this function has been included without much testing, and so the user should be wary.
+}
+\value{
+ An object of class \code{"Dtest"}.
+}
+\references{
+ Huelsenbeck, J. P., R. Neilsen, and J. P. Bollback (2003) Stochastic mapping of morphological characters. \emph{Systematic Biology}, \bold{52}, 131-138.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{make.simmap}}, \code{\link{map.overlap}}
+}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{simulation}
+\keyword{bayesian}
+\keyword{discrete character}
diff --git a/man/add.arrow.Rd b/man/add.arrow.Rd
index ca84c57..5c06fb3 100644
--- a/man/add.arrow.Rd
+++ b/man/add.arrow.Rd
@@ -1,51 +1,51 @@
-\name{add.arrow}
-\alias{add.arrow}
-\title{Add an arrow pointing to a tip or node on the tree}
-\usage{
-add.arrow(tree=NULL, tip, ...)
-}
-\arguments{
- \item{tree}{an object of class \code{"phylo"}, \code{"contMap"}, or \code{"densityMap"}. If not supplied, the function will obtain the last plotted phylogeny from the environmental variable \code{last_plot.phylo}.}
- \item{tip}{label of tip or tip or node number; or vector of such values. If \code{tree=NULL} then the tip label(s) or node number(s) must be supplied.}
- \item{...}{optional arguments to control the shape and size of the arrow including: its length (\code{arrl}) in the units of the plot; the length of the arrowhead (\code{hedl}); the total angle between the wings in the arrowhead (\code{angle}); the line width for the plotted lines (\code{lwd}); the offset from the tip or end of tip label, in character widths (\code{offset}); and the color (\code{col}).}
-}
-\description{
- Adds an arrow or a set of arrows to a plotted tree.
-}
-\details{
- This function presently works for radial (\code{type="fan"}) and right facing square phylograms (\code{type=} \code{"phylogram"}). Trees can be plotted using \pkg{phytools} function \code{plotTree}, \code{plotSimmap}, \code{contMap}, \code{densityMap}, and \pkg{ape} S3 method \code{plot.phylo}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{nodelabels}}
-}
-\examples{
-## show arrows with a black outline
-data(anoletree)
-plotTree(anoletree,type="fan",fsize=0.7,ftype="i")
-add.arrow(anoletree,tip=c("cuvieri","krugi",
- "pulchellus","poncensis","stratulus",
- "evermanni","cooki","cristatellus",
- "gundlachi","occultus"),lwd=5,arrl=1)
-add.arrow(anoletree,tip="cuvieri",col="green",
- lwd=3,arrl=1)
-add.arrow(anoletree,tip=c("krugi","pulchellus",
- "poncensis"),col="#E4D96F",lwd=3,arrl=1)
-add.arrow(anoletree,tip=c("stratulus","evermanni"),
- col="darkgreen",lwd=3,arrl=1)
-add.arrow(anoletree,tip=c("cooki","cristatellus",
- "gundlachi"),col="brown",lwd=3,arrl=1)
-add.arrow(anoletree,tip="occultus",col="darkgrey",
- lwd=3,arrl=1)
-legend(x="topleft",c("crown-giant","grass-bush","trunk-crown","trunk-ground",
- "twig"),pch=22,pt.bg=c("green","#E4D96F","darkgreen",
- "brown","darkgrey"),cex=0.9,
- pt.cex=2,title="PR ecomorphs",bty="n")
-par(mar=c(5.1,4.1,4.1,2.1)) ## reset margins to default
-}
-\keyword{phylogenetics}
-\keyword{utilities}
-\keyword{plotting}
+\name{add.arrow}
+\alias{add.arrow}
+\title{Add an arrow pointing to a tip or node on the tree}
+\usage{
+add.arrow(tree=NULL, tip, ...)
+}
+\arguments{
+ \item{tree}{an object of class \code{"phylo"}, \code{"contMap"}, or \code{"densityMap"}. If not supplied, the function will obtain the last plotted phylogeny from the environmental variable \code{last_plot.phylo}.}
+ \item{tip}{label of tip or tip or node number; or vector of such values. If \code{tree=NULL} then the tip label(s) or node number(s) must be supplied.}
+ \item{...}{optional arguments to control the shape and size of the arrow including: its length (\code{arrl}) in the units of the plot; the length of the arrowhead (\code{hedl}); the total angle between the wings in the arrowhead (\code{angle}); the line width for the plotted lines (\code{lwd}); the offset from the tip or end of tip label, in character widths (\code{offset}); and the color (\code{col}).}
+}
+\description{
+ Adds an arrow or a set of arrows to a plotted tree.
+}
+\details{
+ This function presently works for radial (\code{type="fan"}) and right facing square phylograms (\code{type=} \code{"phylogram"}). Trees can be plotted using \pkg{phytools} function \code{plotTree}, \code{plotSimmap}, \code{contMap}, \code{densityMap}, and \pkg{ape} S3 method \code{plot.phylo}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{nodelabels}}
+}
+\examples{
+## show arrows with a black outline
+data(anoletree)
+plotTree(anoletree,type="fan",fsize=0.7,ftype="i")
+add.arrow(anoletree,tip=c("cuvieri","krugi",
+ "pulchellus","poncensis","stratulus",
+ "evermanni","cooki","cristatellus",
+ "gundlachi","occultus"),lwd=5,arrl=1)
+add.arrow(anoletree,tip="cuvieri",col="green",
+ lwd=3,arrl=1)
+add.arrow(anoletree,tip=c("krugi","pulchellus",
+ "poncensis"),col="#E4D96F",lwd=3,arrl=1)
+add.arrow(anoletree,tip=c("stratulus","evermanni"),
+ col="darkgreen",lwd=3,arrl=1)
+add.arrow(anoletree,tip=c("cooki","cristatellus",
+ "gundlachi"),col="brown",lwd=3,arrl=1)
+add.arrow(anoletree,tip="occultus",col="darkgrey",
+ lwd=3,arrl=1)
+legend(x="topleft",c("crown-giant","grass-bush","trunk-crown","trunk-ground",
+ "twig"),pch=22,pt.bg=c("green","#E4D96F","darkgreen",
+ "brown","darkgrey"),cex=0.9,
+ pt.cex=2,title="PR ecomorphs",bty="n")
+par(mar=c(5.1,4.1,4.1,2.1)) ## reset margins to default
+}
+\keyword{phylogenetics}
+\keyword{utilities}
+\keyword{plotting}
diff --git a/man/aic.w.Rd b/man/aic.w.Rd
index 0bf8df0..b90d68d 100644
--- a/man/aic.w.Rd
+++ b/man/aic.w.Rd
@@ -1,31 +1,31 @@
-\name{aic.w}
-\alias{aic.w}
-\title{Computes Akaike weights}
-\usage{
-aic.w(aic)
-}
-\arguments{
- \item{aic}{vector of Akaike Information Criterion (AIC; Akaike, 1974) values for different fitted models. If the vector has names, these names will be inherited by the vector returned by the function.}
-}
-\description{
- Computes Akaike weights based on a set of AIC values.
-}
-\details{
- This function computes Akaike weights from a set of AIC values obtained from fitted models.
-
- It returns an object of class \code{"aic.w"} which is just a vector which allows it to be automatically printed with a numerical precision of 8 significant digits.
-}
-\value{
- A vector of Akaike weights.
-}
-\references{
- Akaike, H. (1974) A new look at the statistical model identification. \emph{IEEE Transactions on Automatic Control}, \bold{19}, 716-723.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{statistics}
-\keyword{utilities}
-\keyword{math}
-\keyword{maximum likelihood}
-\keyword{information criteria}
+\name{aic.w}
+\alias{aic.w}
+\title{Computes Akaike weights}
+\usage{
+aic.w(aic)
+}
+\arguments{
+ \item{aic}{vector of Akaike Information Criterion (AIC; Akaike, 1974) values for different fitted models. If the vector has names, these names will be inherited by the vector returned by the function.}
+}
+\description{
+ Computes Akaike weights based on a set of AIC values.
+}
+\details{
+ This function computes Akaike weights from a set of AIC values obtained from fitted models.
+
+ It returns an object of class \code{"aic.w"} which is just a vector which allows it to be automatically printed with a numerical precision of 8 significant digits.
+}
+\value{
+ A vector of Akaike weights.
+}
+\references{
+ Akaike, H. (1974) A new look at the statistical model identification. \emph{IEEE Transactions on Automatic Control}, \bold{19}, 716-723.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{statistics}
+\keyword{utilities}
+\keyword{math}
+\keyword{maximum likelihood}
+\keyword{information criteria}
diff --git a/man/allFurcTrees.Rd b/man/allFurcTrees.Rd
index 09a62fa..90eec30 100644
--- a/man/allFurcTrees.Rd
+++ b/man/allFurcTrees.Rd
@@ -1,40 +1,40 @@
-\name{allFurcTrees}
-\alias{allFurcTrees}
-\title{Generate all bi- and multifurcating unrooted trees}
-\usage{
-allFurcTrees(n, tip.label=NULL, to.plot=TRUE)
-}
-\arguments{
- \item{n}{an integer giving the desired number of species.}
- \item{tip.label}{an optional vector of length n containing the tip names.}
- \item{to.plot}{an optional logical value indicating whether or not to plot the trees.}
-}
-\description{
- This function creates all possible unrooted bi- and multifurcating trees and returns a list of trees as an object of class \code{"multiPhylo"}.
-}
-\details{
- This function should be used with extreme caution for \code{n} greater than about 8, as in this case the number of possible trees is extremely large.
-}
-\value{
- A list of trees as an object of class \code{"multiPhylo"}.
-}
-\references{
- Felsenstein, J. 2004. \emph{Inferring Phylogenies}. Sinauer.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{add.everywhere}}, \code{\link{exhaustiveMP}}
-}
-\examples{
-## compute & plot all bi- and multifurcating
-## trees for six taxa
-trees<-allFurcTrees(n=6)
-par(mfrow=c(16,15))
-nulo<-sapply(trees,plot,type="unrooted",
- no.margin=TRUE)
-par(mfrow=c(1,1))
-}
-\keyword{phylogenetics}
-\keyword{phylogeny inference}
+\name{allFurcTrees}
+\alias{allFurcTrees}
+\title{Generate all bi- and multifurcating unrooted trees}
+\usage{
+allFurcTrees(n, tip.label=NULL, to.plot=TRUE)
+}
+\arguments{
+ \item{n}{an integer giving the desired number of species.}
+ \item{tip.label}{an optional vector of length n containing the tip names.}
+ \item{to.plot}{an optional logical value indicating whether or not to plot the trees.}
+}
+\description{
+ This function creates all possible unrooted bi- and multifurcating trees and returns a list of trees as an object of class \code{"multiPhylo"}.
+}
+\details{
+ This function should be used with extreme caution for \code{n} greater than about 8, as in this case the number of possible trees is extremely large.
+}
+\value{
+ A list of trees as an object of class \code{"multiPhylo"}.
+}
+\references{
+ Felsenstein, J. 2004. \emph{Inferring Phylogenies}. Sinauer.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{add.everywhere}}, \code{\link{exhaustiveMP}}
+}
+\examples{
+## compute & plot all bi- and multifurcating
+## trees for six taxa
+trees<-allFurcTrees(n=6)
+par(mfrow=c(16,15))
+nulo<-sapply(trees,plot,type="unrooted",
+ no.margin=TRUE)
+par(mfrow=c(1,1))
+}
+\keyword{phylogenetics}
+\keyword{phylogeny inference}
diff --git a/man/anc.Bayes.Rd b/man/anc.Bayes.Rd
index 56c9a8d..e300dd8 100644
--- a/man/anc.Bayes.Rd
+++ b/man/anc.Bayes.Rd
@@ -1,66 +1,66 @@
-\name{anc.Bayes}
-\alias{anc.Bayes}
-\alias{plot.anc.Bayes}
-\alias{density.anc.Bayes}
-\title{Bayesian ancestral character estimation}
-\usage{
-anc.Bayes(tree, x, ngen=10000, control=list(), ...)
-\method{plot}{anc.Bayes}(x, ...)
-\method{density}{anc.Bayes}(x, ...)
-}
-\arguments{
- \item{tree}{an object of class \code{"phylo"}.}
- \item{x}{a vector of tip values for species; \code{names(x)} should be the species names. In the case of the \code{plot} and \code{density} methods, an object of class \code{"anc.Bayes"}.}
- \item{ngen}{a integer indicating the number of generations for the MCMC.}
- \item{control}{a list of control parameters containing the following elements: \code{sig2}: starting value for \eqn{\sigma^2} (BM rate); \code{a}: starting for the state at the root node; \code{y}: starting values for the states at all internal nodes excluding the root (should be labeled with node numbers); \code{pr.mean}: means for the prior distributions in the following order - \code{sig2}, \code{a}, \code{y}, note that the prior probability distribution is exponential for \code{sig2} and normal for \code{a} and \code{y}; \code{pr.var}: variances on the prior distributions, same order as \code{pr.mean} (but the variance is not used for \code{sig2}); \code{prop}: variances on the normal proposal distributions in the same order as \code{pr.mean}; \code{sample}: sample frequency from the MCMC.}
- \item{...}{optional arguments, including to be passed to \code{plot} and \code{density} methods.}
-}
-\description{
- This function uses Bayesian MCMC to sample from the posterior distribution for the states at internal nodes in the tree.
-}
-\value{
- \code{anc.Bayes} returns an object of class \code{"anc.Bayes"} including at least two components:
- \item{mcmc}{a data frame with rows \code{ngen/sample+1} containing the posterior sample and likelihoods. Matrix columns are labeled either \code{sig2} or by the node number of the internal node.}
- \item{tree}{our input phylogeny.}
-}
-\details{
- \code{plot.anc.Bayes} generates a likelihood profile plot of the MCMC by default, but can also create a profile plot for any of the sampled variables by using the optional argument \code{what}. For instance, \code{what=40} (or, equivalently, \code{what="40"}) will create a profile plot of the MCMC for node \code{40}. Additional arguments are passed to \code{\link{plot}}.
-
- \code{density.anc.Bayes} computes a posterior density from the MCMC sample. Like \code{plot.anc.Bayes} takes the optional argument \code{what}, but unlike \code{plot.anc.Bayes} computes the posterior density for the root node by default. The object computed by this function is of class \code{"density"} and can be visualized using \code{\link{plot.density}}. Burn-in (in generations) can be set using the optional argument \code{burnin}, otherwise it will be assumed to be 20% of the sample.
-
- The \code{print} and \code{summary} methods for this object class also return (invisibly) a vector of estimated ancestral states based on a user-supplied burn-in (or 20\% of the number of generations of MCMC, if no burn-in is provided). Burn-in can be specified with the optional argument \code{burnin}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{ace}}, \code{\link{anc.ML}}, \code{\link{anc.trend}}, \code{\link{evol.rate.mcmc}}, \code{\link{fastAnc}}
-}
-\examples{
-## set seed
-set.seed(77)
-## load data from Garland et al. (1992)
-data(mammal.tree)
-data(mammal.data)
-## extract character of interest
-ln.bodyMass<-log(setNames(mammal.data$bodyMass,
- rownames(mammal.data)))
-## run MCMC (should be run at least 1e6 generations)
-mcmc<-anc.Bayes(mammal.tree,ln.bodyMass,
- ngen=50000)
-print(mcmc,printlen=20) ## estimates
-par(mfrow=c(2,1))
-plot(mcmc,bty="l",main="Likelihood-profile from MCMC",
- font.main=3) ## likelihood-profile
-plot(density(mcmc,what=Ntip(mammal.tree)+1,
- burnin=20000),bty="l",
- main="Posterior density for root state of log(body mass)",
- font.main=3)
-par(mfrow=c(1,1)) ## reset par to default
-}
-\keyword{ancestral states}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{bayesian}
+\name{anc.Bayes}
+\alias{anc.Bayes}
+\alias{plot.anc.Bayes}
+\alias{density.anc.Bayes}
+\title{Bayesian ancestral character estimation}
+\usage{
+anc.Bayes(tree, x, ngen=10000, control=list(), ...)
+\method{plot}{anc.Bayes}(x, ...)
+\method{density}{anc.Bayes}(x, ...)
+}
+\arguments{
+ \item{tree}{an object of class \code{"phylo"}.}
+ \item{x}{a vector of tip values for species; \code{names(x)} should be the species names. In the case of the \code{plot} and \code{density} methods, an object of class \code{"anc.Bayes"}.}
+ \item{ngen}{a integer indicating the number of generations for the MCMC.}
+ \item{control}{a list of control parameters containing the following elements: \code{sig2}: starting value for \eqn{\sigma^2} (BM rate); \code{a}: starting for the state at the root node; \code{y}: starting values for the states at all internal nodes excluding the root (should be labeled with node numbers); \code{pr.mean}: means for the prior distributions in the following order - \code{sig2}, \code{a}, \code{y}, note that the prior probability distribution is exponential for \code{sig2} and normal for \code{a} and \code{y}; \code{pr.var}: variances on the prior distributions, same order as \code{pr.mean} (but the variance is not used for \code{sig2}); \code{prop}: variances on the normal proposal distributions in the same order as \code{pr.mean}; \code{sample}: sample frequency from the MCMC.}
+ \item{...}{optional arguments, including to be passed to \code{plot} and \code{density} methods.}
+}
+\description{
+ This function uses Bayesian MCMC to sample from the posterior distribution for the states at internal nodes in the tree.
+}
+\value{
+ \code{anc.Bayes} returns an object of class \code{"anc.Bayes"} including at least two components:
+ \item{mcmc}{a data frame with rows \code{ngen/sample+1} containing the posterior sample and likelihoods. Matrix columns are labeled either \code{sig2} or by the node number of the internal node.}
+ \item{tree}{our input phylogeny.}
+}
+\details{
+ \code{plot.anc.Bayes} generates a likelihood profile plot of the MCMC by default, but can also create a profile plot for any of the sampled variables by using the optional argument \code{what}. For instance, \code{what=40} (or, equivalently, \code{what="40"}) will create a profile plot of the MCMC for node \code{40}. Additional arguments are passed to \code{\link{plot}}.
+
+ \code{density.anc.Bayes} computes a posterior density from the MCMC sample. Like \code{plot.anc.Bayes} takes the optional argument \code{what}, but unlike \code{plot.anc.Bayes} computes the posterior density for the root node by default. The object computed by this function is of class \code{"density"} and can be visualized using \code{\link{plot.density}}. Burn-in (in generations) can be set using the optional argument \code{burnin}, otherwise it will be assumed to be 20% of the sample.
+
+ The \code{print} and \code{summary} methods for this object class also return (invisibly) a vector of estimated ancestral states based on a user-supplied burn-in (or 20\% of the number of generations of MCMC, if no burn-in is provided). Burn-in can be specified with the optional argument \code{burnin}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{ace}}, \code{\link{anc.ML}}, \code{\link{anc.trend}}, \code{\link{evol.rate.mcmc}}, \code{\link{fastAnc}}
+}
+\examples{
+## set seed
+set.seed(77)
+## load data from Garland et al. (1992)
+data(mammal.tree)
+data(mammal.data)
+## extract character of interest
+ln.bodyMass<-log(setNames(mammal.data$bodyMass,
+ rownames(mammal.data)))
+## run MCMC (should be run at least 1e6 generations)
+mcmc<-anc.Bayes(mammal.tree,ln.bodyMass,
+ ngen=50000)
+print(mcmc,printlen=20) ## estimates
+par(mfrow=c(2,1))
+plot(mcmc,bty="l",main="Likelihood-profile from MCMC",
+ font.main=3) ## likelihood-profile
+plot(density(mcmc,what=Ntip(mammal.tree)+1,
+ burnin=20000),bty="l",
+ main="Posterior density for root state of log(body mass)",
+ font.main=3)
+par(mfrow=c(1,1)) ## reset par to default
+}
+\keyword{ancestral states}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{bayesian}
\keyword{continuous character}
\ No newline at end of file
diff --git a/man/anc.ML.Rd b/man/anc.ML.Rd
index 4a83107..ee8ded4 100644
--- a/man/anc.ML.Rd
+++ b/man/anc.ML.Rd
@@ -1,55 +1,55 @@
-\name{anc.ML}
-\alias{anc.ML}
-\title{Ancestral character estimation using likelihood}
-\usage{
-anc.ML(tree, x, maxit=2000, model=c("BM","OU","EB"), ...)
-}
-\arguments{
- \item{tree}{an object of class \code{"phylo"}.}
- \item{x}{a vector of tip values for species; \code{names(x)} should be the species names.}
- \item{maxit}{an optional integer value indicating the maximum number of iterations for optimization.}
- \item{model}{model of continuous character evolution ont he tree. It's possible that only \code{model="BM"} & \code{model="EB"} work in the present version as \code{model="OU"} has not be thoroughly tested & some bugs were reported for an earlier version.}
- \item{...}{optional arguments.}
-}
-\description{
- This function estimates the evolutionary parameters and ancestral states for Brownian evolution using likelihood. It is also possible (for \code{model="BM"}) to allow for missing data for some tip taxa.
-}
-\details{
- Because this function relies on a high dimensional numerical optimization of the likelihood function, \code{\link{fastAnc}} should probably be preferred for most purposes. If using \code{\link{anc.ML}}, users should be cautious to ensure convergence.
-
- This issue has been ameliorated in \pkg{phytools} >= 0.2-48 by seeding the ML optimization with the result from \code{\link{fastAnc}}.
-
- For \code{model="EB"} this should also not be a problem as the numerical optimization is performed for only \code{sig2} and \code{r}, while the ML values of the ancestral states are obtained during every iteration of the optimization algorithmically using the re-rooting method.
-}
-\value{
- An object of class \code{"anc.ML"} with at least the following four elements (if not more, depending on \code{model}):
- \item{sig2}{the variance of the BM process.}
- \item{ace}{a vector with the ancestral states.}
- \item{logLik}{the log-likelihood.}
- \item{convergence}{the value of \code{convergence} returned by \code{\link{optim}} (0 is good).}
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-
- Schluter, D., Price, T., Mooers, A. O., and Ludwig, D. (1997) Likelihood of ancestor states in adaptive radiation. \emph{Evolution} \bold{51}, 1699-1711.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{ace}}, \code{\link{anc.Bayes}}, \code{\link{fastAnc}}, \code{\link{optim}}
-}
-\examples{
-## load data from Garland et al. (1992)
-data(mammal.tree)
-data(mammal.data)
-## extract character of interest
-ln.bodyMass<-log(setNames(mammal.data$bodyMass,
- rownames(mammal.data)))
-## estimate ancestral state under BM model
-fit.BM<-anc.ML(mammal.tree,ln.bodyMass)
-print(fit.BM)
-}
-\keyword{ancestral states}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{maximum likelihood}
-\keyword{continuous character}
+\name{anc.ML}
+\alias{anc.ML}
+\title{Ancestral character estimation using likelihood}
+\usage{
+anc.ML(tree, x, maxit=2000, model=c("BM","OU","EB"), ...)
+}
+\arguments{
+ \item{tree}{an object of class \code{"phylo"}.}
+ \item{x}{a vector of tip values for species; \code{names(x)} should be the species names.}
+ \item{maxit}{an optional integer value indicating the maximum number of iterations for optimization.}
+ \item{model}{model of continuous character evolution ont he tree. It's possible that only \code{model="BM"} & \code{model="EB"} work in the present version as \code{model="OU"} has not be thoroughly tested & some bugs were reported for an earlier version.}
+ \item{...}{optional arguments.}
+}
+\description{
+ This function estimates the evolutionary parameters and ancestral states for Brownian evolution using likelihood. It is also possible (for \code{model="BM"}) to allow for missing data for some tip taxa.
+}
+\details{
+ Because this function relies on a high dimensional numerical optimization of the likelihood function, \code{\link{fastAnc}} should probably be preferred for most purposes. If using \code{\link{anc.ML}}, users should be cautious to ensure convergence.
+
+ This issue has been ameliorated in \pkg{phytools} >= 0.2-48 by seeding the ML optimization with the result from \code{\link{fastAnc}}.
+
+ For \code{model="EB"} this should also not be a problem as the numerical optimization is performed for only \code{sig2} and \code{r}, while the ML values of the ancestral states are obtained during every iteration of the optimization algorithmically using the re-rooting method.
+}
+\value{
+ An object of class \code{"anc.ML"} with at least the following four elements (if not more, depending on \code{model}):
+ \item{sig2}{the variance of the BM process.}
+ \item{ace}{a vector with the ancestral states.}
+ \item{logLik}{the log-likelihood.}
+ \item{convergence}{the value of \code{convergence} returned by \code{\link{optim}} (0 is good).}
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+
+ Schluter, D., Price, T., Mooers, A. O., and Ludwig, D. (1997) Likelihood of ancestor states in adaptive radiation. \emph{Evolution} \bold{51}, 1699-1711.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{ace}}, \code{\link{anc.Bayes}}, \code{\link{fastAnc}}, \code{\link{optim}}
+}
+\examples{
+## load data from Garland et al. (1992)
+data(mammal.tree)
+data(mammal.data)
+## extract character of interest
+ln.bodyMass<-log(setNames(mammal.data$bodyMass,
+ rownames(mammal.data)))
+## estimate ancestral state under BM model
+fit.BM<-anc.ML(mammal.tree,ln.bodyMass)
+print(fit.BM)
+}
+\keyword{ancestral states}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{maximum likelihood}
+\keyword{continuous character}
diff --git a/man/anc.trend.Rd b/man/anc.trend.Rd
index 382a971..1732948 100644
--- a/man/anc.trend.Rd
+++ b/man/anc.trend.Rd
@@ -1,77 +1,77 @@
-\name{anc.trend}
-\alias{anc.trend}
-\title{Ancestral character estimation with a trend}
-\usage{
-anc.trend(tree, x, maxit=2000)
-}
-\arguments{
- \item{tree}{an object of class \code{"phylo"}.}
- \item{x}{a vector of tip values for species; \code{names(x)} should be the species names.}
- \item{maxit}{an optional integer value indicating the maximum number of iterations for optimization.}
-}
-\description{
- This function estimates the evolutionary parameters and ancestral states for Brownian evolution with a directional trend.
-}
-\details{
- Note that this will generally only work and produce sensible results for a phylogeny with some non-contemporaneous tips (i.e., a tree with some fossil species).
-
- The function uses \code{\link{optim}} with \code{method=} \code{"L-BFGS-B"} internally; however, optimization is only constrained for the \code{sig2} which must be > 0.
-}
-\value{
- An object of class \code{"anc.trend"} with the following components:
- \item{ace}{a vector with the ancestral states.}
- \item{mu}{a trend parameter per unit time.}
- \item{sig2}{the variance of the BM process, \eqn{\sigma^2}.}
- \item{logL}{the log-likelihood.}
- \item{convergence}{the value of \code{$convergence} returned by \code{optim()} (0 is good).}
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{ace}}, \code{\link{anc.Bayes}}, \code{\link{anc.ML}}, \code{\link{optim}}
-}
-\examples{
-## simulate tree & data using fastBM with a trend (m!=0)
-tree<-rtree(n=26,tip.label=LETTERS)
-x<-fastBM(tree,mu=4,internal=TRUE)
-a<-x[as.character(1:tree$Nnode+Ntip(tree))]
-x<-x[tree$tip.label]
-## fit no trend model
-fit.bm<-anc.ML(tree,x,model="BM")
-print(fit.bm)
-## fit trend model
-fit.trend<-anc.trend(tree,x)
-print(fit.trend)
-## compare trend vs. no-trend models & estimates
-AIC(fit.bm,fit.trend)
-layout(matrix(c(3,4,1,2,5,6),3,2,byrow=TRUE),
- heights=c(1.5,3,1.5),widths=c(3,3))
-xlim<-ylim<-range(c(a,fit.bm$ace,
- fit.trend$ace))
-plot(a,fit.bm$ace,pch=19,
- col=make.transparent("blue",0.5),
- xlab="true ancestral states",
- ylab="ML estimates",
- main=paste("Comparison of true and estimated",
- "\nstates under a no-trend model"),font.main=3,
- cex.main=1.2,bty="l",cex=1.5,
- xlim=xlim,ylim=ylim)
-lines(xlim,ylim,lty="dotted")
-plot(a,fit.trend$ace,pch=19,
- col=make.transparent("blue",0.5),
- xlab="true ancestral states",
- ylab="ML estimates",
- main=paste("Comparison of true and estimated",
- "\nstates under a trend model"),font.main=3,
- cex.main=1.2,bty="l",cex=1.5,
- xlim=xlim,ylim=ylim)
-lines(xlim,ylim,lty="dotted")
-par(mfrow=c(1,1))
-}
-\keyword{ancestral states}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{maximum likelihood}
-\keyword{continuous character}
+\name{anc.trend}
+\alias{anc.trend}
+\title{Ancestral character estimation with a trend}
+\usage{
+anc.trend(tree, x, maxit=2000)
+}
+\arguments{
+ \item{tree}{an object of class \code{"phylo"}.}
+ \item{x}{a vector of tip values for species; \code{names(x)} should be the species names.}
+ \item{maxit}{an optional integer value indicating the maximum number of iterations for optimization.}
+}
+\description{
+ This function estimates the evolutionary parameters and ancestral states for Brownian evolution with a directional trend.
+}
+\details{
+ Note that this will generally only work and produce sensible results for a phylogeny with some non-contemporaneous tips (i.e., a tree with some fossil species).
+
+ The function uses \code{\link{optim}} with \code{method=} \code{"L-BFGS-B"} internally; however, optimization is only constrained for the \code{sig2} which must be > 0.
+}
+\value{
+ An object of class \code{"anc.trend"} with the following components:
+ \item{ace}{a vector with the ancestral states.}
+ \item{mu}{a trend parameter per unit time.}
+ \item{sig2}{the variance of the BM process, \eqn{\sigma^2}.}
+ \item{logL}{the log-likelihood.}
+ \item{convergence}{the value of \code{$convergence} returned by \code{optim()} (0 is good).}
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{ace}}, \code{\link{anc.Bayes}}, \code{\link{anc.ML}}, \code{\link{optim}}
+}
+\examples{
+## simulate tree & data using fastBM with a trend (m!=0)
+tree<-rtree(n=26,tip.label=LETTERS)
+x<-fastBM(tree,mu=4,internal=TRUE)
+a<-x[as.character(1:tree$Nnode+Ntip(tree))]
+x<-x[tree$tip.label]
+## fit no trend model
+fit.bm<-anc.ML(tree,x,model="BM")
+print(fit.bm)
+## fit trend model
+fit.trend<-anc.trend(tree,x)
+print(fit.trend)
+## compare trend vs. no-trend models & estimates
+AIC(fit.bm,fit.trend)
+layout(matrix(c(3,4,1,2,5,6),3,2,byrow=TRUE),
+ heights=c(1.5,3,1.5),widths=c(3,3))
+xlim<-ylim<-range(c(a,fit.bm$ace,
+ fit.trend$ace))
+plot(a,fit.bm$ace,pch=19,
+ col=make.transparent("blue",0.5),
+ xlab="true ancestral states",
+ ylab="ML estimates",
+ main=paste("Comparison of true and estimated",
+ "\nstates under a no-trend model"),font.main=3,
+ cex.main=1.2,bty="l",cex=1.5,
+ xlim=xlim,ylim=ylim)
+lines(xlim,ylim,lty="dotted")
+plot(a,fit.trend$ace,pch=19,
+ col=make.transparent("blue",0.5),
+ xlab="true ancestral states",
+ ylab="ML estimates",
+ main=paste("Comparison of true and estimated",
+ "\nstates under a trend model"),font.main=3,
+ cex.main=1.2,bty="l",cex=1.5,
+ xlim=xlim,ylim=ylim)
+lines(xlim,ylim,lty="dotted")
+par(mfrow=c(1,1))
+}
+\keyword{ancestral states}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{maximum likelihood}
+\keyword{continuous character}
diff --git a/man/ancThresh.Rd b/man/ancThresh.Rd
index 9cf5fed..dd44bbb 100644
--- a/man/ancThresh.Rd
+++ b/man/ancThresh.Rd
@@ -1,61 +1,61 @@
-\name{ancThresh}
-\alias{ancThresh}
-\title{Ancestral character estimation under the threshold model using Bayesian MCMC}
-\usage{
-ancThresh(tree, x, ngen=100000, sequence=NULL, method="mcmc",
- model=c("BM","OU","lambda"), control=list(), ...)
-}
-\arguments{
- \item{tree}{phylogenetic tree.}
- \item{x}{a named vector containing discrete character states; or a matrix containing the tip species, in rows, and probabilities of being in each state, in columns.}
- \item{ngen}{number of generations to run the MCMC.}
- \item{sequence}{assumed ordering of the discrete character state. If not supplied and \code{x} is a vector then numerical/alphabetical order is assumed; if not supplied and \code{x} is a matrix, then the column order of \code{x} is used.}
- \item{method}{only method currently available is \code{"mcmc"}.}
- \item{model}{model for the evolution of the liability. Options are \code{"BM"} (Brownian motion, the default), \code{"OU"} (Ornstein-Uhlenbeck), or \code{"lambda"} (the \eqn{\lambda} model).}
- \item{control}{list containing the following elements: \code{sample}, the sampling interval; \code{propliab} variance of the proposal distribution for liabilities; \code{propthresh} variance on the proposal distribution for the thresholds; \code{propalpha} variance on the proposal distribution for \code{alpha} (for \code{model="OU"}); \code{pr.anc} prior probability distribution on the ancestral states for each node, in a matrix - not all nodes need to be supplied; \code{pr.th} prior density on the thresholds; \code{burnin} number of generations to exclude for burn-in when plotting posterior probabilities on the tree; \code{plot} logical value indicating whether or not to plot the posterior probabilities; \code{print} logical value indicating whether or not to print the state of the MCMC; \code{piecol} colors for the posterior probabilities plotted as pie charts at internal nodes; and \code{tipcol} which indicates whether the tip colors should be based on the input data (\code{"input"}) or sampled tip liabilities (\code{"estimated"}). These will only differ if there is uncertainty in the tip states.}
- \item{...}{additional arguments to be passed to \code{\link{plotThresh}} (called internally).}
-}
-\description{
- This function uses Bayesian MCMC to estimate ancestral states and thresholds for a discrete character under the threshold model from quantitative genetics (Felsenstein 2012).
-}
-\details{
- According to the threshold model from evolutionary quantitative genetics, values for our observed discrete character are determined by an unseen continuous trait, normally referred to as liability. Every time the value for liability crosses a threshold, the observed discrete character changes in state.
-
- Felsenstein (2012) first had the insight that this model could be used to study the evolution of discrete character traits on a reconstructed phylogenetic tree.
-
- This function uses Bayesian MCMC to sample ancestral liabilities and thresholds for a discrete character evolution under the threshold model.
-
- \code{print} and \code{plot} S3 methods are now available for the object class \code{"ancThresh"}.
-}
-\value{
- This function returns an object of class \code{"ancThresh"} containing the posterior sample from our analysis, along with other components.
-}
-\references{
- Felsenstein, J. (2012) A comparative method for both discrete and continuous characters using the threshold model. \emph{American Naturalist}, \bold{179}, 145-156.
-
- Revell, L. J. (2014) Ancestral character estimation under the threshold model from quantitative genetics. \emph{Evolution}, \bold{68}, 743-759.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{anc.Bayes}}, \code{\link{threshBayes}}
-}
-\examples{
-\dontrun{
-## load data from Revell & Collar (2009)
-data(sunfish.tree)
-data(sunfish.data)
-## extract character of interest
-fmode<-setNames(sunfish.data$feeding.mode,
- rownames(sunfish.data))
-## run MCMC
-mcmc<-ancThresh(sunfish.tree,fmode,ngen=1000000)
-## plot results
-plot(mcmc,mar=c(0.1,0.1,4.1,0.1))
-title(main="Posterior probabilities for node states",
- font.main=3)}
-}
-\keyword{ancestral states}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{bayesian}
-\keyword{discrete character}
+\name{ancThresh}
+\alias{ancThresh}
+\title{Ancestral character estimation under the threshold model using Bayesian MCMC}
+\usage{
+ancThresh(tree, x, ngen=100000, sequence=NULL, method="mcmc",
+ model=c("BM","OU","lambda"), control=list(), ...)
+}
+\arguments{
+ \item{tree}{phylogenetic tree.}
+ \item{x}{a named vector containing discrete character states; or a matrix containing the tip species, in rows, and probabilities of being in each state, in columns.}
+ \item{ngen}{number of generations to run the MCMC.}
+ \item{sequence}{assumed ordering of the discrete character state. If not supplied and \code{x} is a vector then numerical/alphabetical order is assumed; if not supplied and \code{x} is a matrix, then the column order of \code{x} is used.}
+ \item{method}{only method currently available is \code{"mcmc"}.}
+ \item{model}{model for the evolution of the liability. Options are \code{"BM"} (Brownian motion, the default), \code{"OU"} (Ornstein-Uhlenbeck), or \code{"lambda"} (the \eqn{\lambda} model).}
+ \item{control}{list containing the following elements: \code{sample}, the sampling interval; \code{propliab} variance of the proposal distribution for liabilities; \code{propthresh} variance on the proposal distribution for the thresholds; \code{propalpha} variance on the proposal distribution for \code{alpha} (for \code{model="OU"}); \code{pr.anc} prior probability distribution on the ancestral states for each node, in a matrix - not all nodes need to be supplied; \code{pr.th} prior density on the thresholds; \code{burnin} number of generations to exclude for burn-in when plotting posterior probabilities on the tree; \code{plot} logical value indicating whether or not to plot the posterior probabilities; \code{print} logical value indicating whether or not to print the state of the MCMC; \code{piecol} colors for the posterior probabilities plotted as pie charts at internal nodes; and \code{tipcol} which indicates whether the tip colors should be based on the input data (\code{"input"}) or sampled tip liabilities (\code{"estimated"}). These will only differ if there is uncertainty in the tip states.}
+ \item{...}{additional arguments to be passed to \code{\link{plotThresh}} (called internally).}
+}
+\description{
+ This function uses Bayesian MCMC to estimate ancestral states and thresholds for a discrete character under the threshold model from quantitative genetics (Felsenstein 2012).
+}
+\details{
+ According to the threshold model from evolutionary quantitative genetics, values for our observed discrete character are determined by an unseen continuous trait, normally referred to as liability. Every time the value for liability crosses a threshold, the observed discrete character changes in state.
+
+ Felsenstein (2012) first had the insight that this model could be used to study the evolution of discrete character traits on a reconstructed phylogenetic tree.
+
+ This function uses Bayesian MCMC to sample ancestral liabilities and thresholds for a discrete character evolution under the threshold model.
+
+ \code{print} and \code{plot} S3 methods are now available for the object class \code{"ancThresh"}.
+}
+\value{
+ This function returns an object of class \code{"ancThresh"} containing the posterior sample from our analysis, along with other components.
+}
+\references{
+ Felsenstein, J. (2012) A comparative method for both discrete and continuous characters using the threshold model. \emph{American Naturalist}, \bold{179}, 145-156.
+
+ Revell, L. J. (2014) Ancestral character estimation under the threshold model from quantitative genetics. \emph{Evolution}, \bold{68}, 743-759.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{anc.Bayes}}, \code{\link{threshBayes}}
+}
+\examples{
+\dontrun{
+## load data from Revell & Collar (2009)
+data(sunfish.tree)
+data(sunfish.data)
+## extract character of interest
+fmode<-setNames(sunfish.data$feeding.mode,
+ rownames(sunfish.data))
+## run MCMC
+mcmc<-ancThresh(sunfish.tree,fmode,ngen=1000000)
+## plot results
+plot(mcmc,mar=c(0.1,0.1,4.1,0.1))
+title(main="Posterior probabilities for node states",
+ font.main=3)}
+}
+\keyword{ancestral states}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{bayesian}
+\keyword{discrete character}
diff --git a/man/anoletree.Rd b/man/anoletree.Rd
index 9c8cbb3..f3f7f6b 100644
--- a/man/anoletree.Rd
+++ b/man/anoletree.Rd
@@ -1,85 +1,137 @@
-\name{anoletree}
-\alias{anole.data}
-\alias{anoletree}
-\alias{bonyfish.data}
-\alias{bonyfish.tree}
-\alias{flatworm.tree}
-\alias{flatworm.data}
-\alias{mammal.tree}
-\alias{mammal.data}
-\alias{salamanders}
-\alias{sunfish.tree}
-\alias{sunfish.data}
-\alias{vertebrate.tree}
-\alias{vertebrate.data}
-\alias{wasp.trees}
-\alias{wasp.data}
-\title{Phylogenetic datasets}
-\description{
- Various phylogenetic datasets for comparative analysis.
-}
-\details{
- \code{anoletree} is a phylogeny of Greater Antillean anole species with a mapped discrete character - \emph{ecomorph class}. \code{anole.data} is a data frame of morphological characters. Data and tree are from Mahler et al. (2010).
-
- \code{bonyfish.tree} and \code{bonyfish.data} are a phylogeny and dataset of spawning mode and parental care in bony fishes from Benun Sutton and Wilson (2019).
-
- \code{flatworm.tree} and \code{flatworm.data} are a phylogeny and dataset of habitat preferences for flatworms from Benitez-Alvarez et al. (2020). \code{flatworm.tree} has been made ultrametric using penalized likelihood.
-
- \code{mammal.tree} and \code{mammal.data} are the phylogeny and dataset for mammal body size and home range size from Garland et al. (1992).
-
- \code{salamanders} is a phylogeny of \emph{Plethodon} salamanders from Highton and Larson (1979). According to Wikipedia, the genus \emph{Plethodon} contains 55 species in total.
-
- \code{sunfish.tree} and \code{sunfish.data} are the phylogeny and dataset for Centrarchidae and buccal morphology (respectively) from Revell and Collar (2009).
-
- \code{vertebrate.tree} is a time-calibrated phylogeny of vertebrates and \code{vertebrate.data} is a dataset of phenotypic traits. The phylogeny is from \url{http://www.timetree.org/} (Hedges et al. 2006).
-
- \code{wasp.trees} and \code{wasp.data} are the phylogeny and host-parasite associations from Lopez-Vaamonde et al. (2001).
-}
-\usage{
-data(anole.data)
-data(anoletree)
-data(flatworm.tree)
-data(flatworm.data)
-data(mammal.data)
-data(mammal.tree)
-data(salamanders)
-data(sunfish.data)
-data(sunfish.tree)
-data(vertebrate.tree)
-data(vertebrate.data)
-data(wasp.data)
-data(wasp.trees)
-}
-\format{
- \code{anoletree} is an object of class \code{"simmap"}. \code{anole.data} is a data frame.
-
- \code{flatworm.tree} is an object of class \code{"phylo"}. \code{flatworm.data} is a data frame.
-
- \code{mammal.tree} is an object of class \code{"phylo"}. \code{mammal.data} is a data frame.
-
- \code{salamanders} is an object of class \code{"phylo"}.
-
- \code{sunfish.tree} is an object of class \code{"simmap"}. \code{sunfish.data} is a data frame.
-
- \code{vertebrate.tree} is an object of class \code{"phylo"}. \code{vertebrate.data} is a data frame.
-
- \code{wasp.trees} is an object of class \code{"multiPhylo"}. \code{wasp.data} is a data frame.
-}
-\source{
- Benitez-Alvarez, L., A. Maria Leal-Zanchet, A. Oceguera-Figueroa, R. Lopes Ferreira, D. de Medeiros Bento, J. Braccini, R. Sluys, and M. Riutort (2020) Phylogeny and biogeography of the Cavernicola (Platyhelminthes: Tricladida): Relicts of an epigean group sheltering in caves? \emph{Molecular Phylogenetics and Evolution}, \bold{145}, 106709.
-
- Benun Sutton, F., and A. B. Wilson (2019) Where are all the moms? External fertilization predicts the rise of male parental care in bony fishes. \emph{Evolution}, \bold{73}, 2451-2460.
-
- Garland, T., Jr., P. H. Harvey, and A. R. Ives (1992) Procedures for the analysis of comparative data using phylogenetically independent contrasts. \emph{Systematic Biology}, \bold{41}, 18-32.
-
- Hedges, S. B., J. Dudley, and S. Kumar (2006) TimeTree: A public knowledgebase of divergence times among organisms. \emph{Bioinformatics}, \bold{22}, 2971-2972.
-
- Highton, R., and A. Larson (1979) The genetic relationships of the salamanders of the genus \emph{Plethodon}. \emph{Systematic Zoology}, \bold{28}, 579-599.
-
- Lopez-Vaamonde, C., J. Y. Rasplus, G. D. Weiblen, and J. M. Cook (2001) Molecular phylogenies of fig wasps: Partial cocladogenesis of pollinators and parasites. \emph{Molecular Phylogenetics and Evolution}, \bold{21}, 55-71.
-
- Mahler, D. L, L. J. Revell, R. E. Glor, and J. B. Losos (2010) Ecological opportunity and the rate of morphological evolution in the diversification of Greater Antillean anoles. \emph{Evolution}, \bold{64}, 2731-2745.
-
- Revell, L. J., and D. C. Collar (2009) Phylogenetic analysis of the evolutionary correlation using likelihood. \emph{Evolution}, \bold{63}, 1090-1100.
-}
-\keyword{datasets}
+\name{anoletree}
+\alias{anole.data}
+\alias{anoletree}
+\alias{bonyfish.data}
+\alias{bonyfish.tree}
+\alias{butterfly.data}
+\alias{butterfly.tree}
+\alias{cordylid.data}
+\alias{cordylid.tree}
+\alias{flatworm.data}
+\alias{flatworm.tree}
+\alias{liolaemid.tree}
+\alias{mammal.data}
+\alias{mammal.tree}
+\alias{primate.data}
+\alias{primate.tree}
+\alias{salamanders}
+\alias{sunfish.data}
+\alias{sunfish.tree}
+\alias{tropidurid.data}
+\alias{tropidurid.tree}
+\alias{vertebrate.data}
+\alias{vertebrate.tree}
+\alias{wasp.data}
+\alias{wasp.trees}
+\title{Phylogenetic datasets}
+\description{
+ Various phylogenetic datasets for comparative analysis.
+}
+\details{
+ \code{anoletree} is a phylogeny of Greater Antillean anole species with a mapped discrete character - \emph{ecomorph class}. \code{anole.data} is a data frame of morphological characters. Data and tree are from Mahler et al. (2010).
+
+ \code{butterfly.tree} and \code{butterfly.data} are a phylogeny and dataset of habitat use in Mycalesina butterflies from Halali et al. (2020).
+
+ \code{bonyfish.tree} and \code{bonyfish.data} are a phylogeny and dataset of spawning mode and parental care in bony fishes from Benun Sutton and Wilson (2019).
+
+ \code{cordylid.tree} and \code{cordylid.data} are a phylogeny and dataset of morphological traits for three different principal components axes from Broeckhoven et al. (2016).
+
+ \code{flatworm.tree} and \code{flatworm.data} are a phylogeny and dataset of habitat preferences for flatworms from Benitez-Alvarez et al. (2020). \code{flatworm.tree} has been made ultrametric using penalized likelihood.
+
+ \code{liolaemid.tree} is a phylogenetic tree of lizards from the family Liolaemidae from Esquerre et al. (2019).
+
+ \code{mammal.tree} and \code{mammal.data} are the phylogeny and dataset for mammal body size and home range size from Garland et al. (1992).
+
+ \code{primate.tree} and \code{primate.data} are a phylogeny and phenotypic trait dataset from Kirk and Kay (2004).
+
+ \code{salamanders} is a phylogeny of \emph{Plethodon} salamanders from Highton and Larson (1979). According to Wikipedia, the genus \emph{Plethodon} contains 55 species in total.
+
+ \code{sunfish.tree} and \code{sunfish.data} are the phylogeny and dataset for Centrarchidae and buccal morphology (respectively) from Revell and Collar (2009).
+
+ \code{tropidurid.tree} and \code{tropidurid.data} are the phylogeny and bivariate quantitative trait dataset of tropidurid lizards from Revell et al. (2022).
+
+ \code{vertebrate.tree} is a time-calibrated phylogeny of vertebrates and \code{vertebrate.data} is a dataset of phenotypic traits. The phylogeny is from \url{http://www.timetree.org/} (Hedges et al. 2006).
+
+ \code{wasp.trees} and \code{wasp.data} are the phylogeny and host-parasite associations from Lopez-Vaamonde et al. (2001).
+}
+\usage{
+data(anole.data)
+data(anoletree)
+data(bonyfish.data)
+data(bonyfish.tree)
+data(butterfly.data)
+data(butterfly.tree)
+data(cordylid.data)
+data(cordylid.tree)
+data(flatworm.data)
+data(flatworm.tree)
+data(liolaemid.tree)
+data(mammal.data)
+data(mammal.tree)
+data(primate.data)
+data(primate.tree)
+data(salamanders)
+data(sunfish.data)
+data(sunfish.tree)
+data(tropidurid.data)
+data(tropidurid.tree)
+data(vertebrate.data)
+data(vertebrate.tree)
+data(wasp.data)
+data(wasp.trees)
+}
+\format{
+ \code{anoletree} is an object of class \code{"simmap"}. \code{anole.data} is a data frame.
+
+ \code{bonyfish.tree} is an object of class \code{"phylo"}. \code{bonyfish.data} is a data frame.
+
+ \code{butterfly.tree} is an object of class \code{"phylo"}. \code{butterfly.data} is a data frame.
+
+ \code{cordylid.tree} is an object of class \code{"phylo"}. \code{cordylid.data} is a data frame.
+
+ \code{flatworm.tree} is an object of class \code{"phylo"}. \code{flatworm.data} is a data frame.
+
+ \code{liolaemid.tree} is an object of class \code{"phylo"}.
+
+ \code{mammal.tree} is an object of class \code{"phylo"}. \code{mammal.data} is a data frame.
+
+ \code{primate.tree} is an object of class \code{"phylo"}. \code{primate.data} is a data frame.
+
+ \code{salamanders} is an object of class \code{"phylo"}.
+
+ \code{sunfish.tree} is an object of class \code{"simmap"}. \code{sunfish.data} is a data frame.
+
+ \code{tropidurid.tree} is an object of class \code{"simmap"}. \code{tropidurid.data} is a data frame.
+
+ \code{vertebrate.tree} is an object of class \code{"phylo"}. \code{vertebrate.data} is a data frame.
+
+ \code{wasp.trees} is an object of class \code{"multiPhylo"}. \code{wasp.data} is a data frame.
+}
+\source{
+ Benitez-Alvarez, L., A. Maria Leal-Zanchet, A. Oceguera-Figueroa, R. Lopes Ferreira, D. de Medeiros Bento, J. Braccini, R. Sluys, and M. Riutort (2020) Phylogeny and biogeography of the Cavernicola (Platyhelminthes: Tricladida): Relicts of an epigean group sheltering in caves? \emph{Molecular Phylogenetics and Evolution}, \bold{145}, 106709.
+
+ Benun Sutton, F., and A. B. Wilson (2019) Where are all the moms? External fertilization predicts the rise of male parental care in bony fishes. \emph{Evolution}, \bold{73}, 2451-2460.
+
+ Broeckhoven, C., G. Diedericks, C. Hui, B. G. Makhubo, P. le Fras N. Mouton (2016) Enemy at the gates: Rapid defensive trait diversification in an adaptive radiation of lizards. \emph{Evolution}, \bold{70}, 2647-2656.
+
+ Esquerre, D., D. Ramirez-Alvarez, C. J. Pavon-Vazquez, J. Troncoso-Palacios, C. F. Garin, J. S. Keogh, and A. D. Leache (2019) Speciation across mountains: Phylogenomics, species delimitation and taxonomy of the \emph{Liolaemus leopardinus} clade (Squamata, Liolaemidae). \emph{Molecular Phylogenetics and Evolution}, \bold{139}, 106524.
+
+ Garland, T., Jr., P. H. Harvey, and A. R. Ives (1992) Procedures for the analysis of comparative data using phylogenetically independent contrasts. \emph{Systematic Biology}, \bold{41}, 18-32.
+
+ Kirk, E. C., and R. F. Kay (2004) The evolution of high visual acuity in the Anthropoidea. In: Ross, C. F., Kay R. F. (Eds), \emph{Anthropoid Origins. Developments in Primatology: Progress and Prospects}, 539-602. Springer, Boston, MA.
+
+ Halali, S., E. van Bergen, C. J. Breuker, P. M. Brakefield, and O. Brattstrom (2020) Seasonal environments drive convergent evolution of a faster pace-of-life in tropical butterflies. \emph{Ecology Letters}, \bold{24}, 102-112.
+
+ Hedges, S. B., J. Dudley, and S. Kumar (2006) TimeTree: A public knowledgebase of divergence times among organisms. \emph{Bioinformatics}, \bold{22}, 2971-2972.
+
+ Highton, R., and A. Larson (1979) The genetic relationships of the salamanders of the genus \emph{Plethodon}. \emph{Systematic Zoology}, \bold{28}, 579-599.
+
+ Lopez-Vaamonde, C., J. Y. Rasplus, G. D. Weiblen, and J. M. Cook (2001) Molecular phylogenies of fig wasps: Partial cocladogenesis of pollinators and parasites. \emph{Molecular Phylogenetics and Evolution}, \bold{21}, 55-71.
+
+ Mahler, D. L, L. J. Revell, R. E. Glor, and J. B. Losos (2010) Ecological opportunity and the rate of morphological evolution in the diversification of Greater Antillean anoles. \emph{Evolution}, \bold{64}, 2731-2745.
+
+ Revell, L. J., and D. C. Collar (2009) Phylogenetic analysis of the evolutionary correlation using likelihood. \emph{Evolution}, \bold{63}, 1090-1100.
+
+ Revell, L. J., K. S. Toyama, and D. L. Mahler (2022) A simple hierarchical model for heterogeneity in the evolutionary correlation a phylogenetic tree. \emph{PeerJ}, \bold{10}, e13910.
+}
+\keyword{datasets}
diff --git a/man/applyBranchLengths.Rd b/man/applyBranchLengths.Rd
index 3d7cb24..a3dea7d 100644
--- a/man/applyBranchLengths.Rd
+++ b/man/applyBranchLengths.Rd
@@ -1,25 +1,25 @@
-\name{applyBranchLengths}
-\alias{applyBranchLengths}
-\title{Applies the branch lengths of a reference tree to a target}
-\usage{
-applyBranchLengths(tree, edge.length)
-}
-\arguments{
- \item{tree}{target tree.}
- \item{edge.length}{number of digits for rounding. Passed to \code{\link{round}}.}
-}
-\description{
- Applies the branch lengths of a reference tree to a target.
-}
-\details{
- This function applies the set of branch lengths from a reference tree to a target tree while reconciling any mappings (as in \code{\link{read.simmap}}) with the new branch lengths.
-}
-\value{
- An object of class \code{"phylo"} or \code{"simmap"}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{phylogenetics}
-\keyword{utilities}
+\name{applyBranchLengths}
+\alias{applyBranchLengths}
+\title{Applies the branch lengths of a reference tree to a target}
+\usage{
+applyBranchLengths(tree, edge.length)
+}
+\arguments{
+ \item{tree}{target tree.}
+ \item{edge.length}{number of digits for rounding. Passed to \code{\link{round}}.}
+}
+\description{
+ Applies the branch lengths of a reference tree to a target.
+}
+\details{
+ This function applies the set of branch lengths from a reference tree to a target tree while reconciling any mappings (as in \code{\link{read.simmap}}) with the new branch lengths.
+}
+\value{
+ An object of class \code{"phylo"} or \code{"simmap"}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{phylogenetics}
+\keyword{utilities}
diff --git a/man/as.Qmatrix.Rd b/man/as.Qmatrix.Rd
index 3d8969c..4cb2a17 100644
--- a/man/as.Qmatrix.Rd
+++ b/man/as.Qmatrix.Rd
@@ -1,39 +1,39 @@
-\name{as.Qmatrix}
-\alias{as.Qmatrix}
-\alias{as.Qmatrix.fitMk}
-\alias{plot.Qmatrix}
-\alias{print.Qmatrix}
-\title{Convert a fitted M\emph{k} model to a Q-matrix}
-\usage{
-as.Qmatrix(x, ...)
-\method{as.Qmatrix}{fitMk}(x, ...)
-\method{plot}{Qmatrix}(x, ...)
-\method{print}{Qmatrix}(x, ...)
-}
-\arguments{
- \item{x}{fitted M\emph{k} model. (For instance, an object of class \code{"fitMk"}.) In the case of \code{print.Qmatrix}, an object of class \code{"Qmatrix"}.}
- \item{...}{optional arguments.}
-}
-\description{
- Extracts a \bold{Q}-matrix from a fitted M\emph{k} model.
-}
-\details{
- This function extracts a \bold{Q}-matrix (in the form of an object of class \code{"Qmatrix"}) from a fitted M\emph{k} model.
-}
-\value{
- An object of class \code{"Qmatrix"}.
-
- \code{plot.Qmatrix} invisibly returns the coordinates of vertices of the plotted \bold{Q}-matrix.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}, Joan Maspons}
-\seealso{
- \code{\link{fitMk}}
-}
-\keyword{phylogenetics}
-\keyword{maximum likelihood}
-\keyword{comparative method}
-\keyword{discrete character}
-\keyword{utilities}
+\name{as.Qmatrix}
+\alias{as.Qmatrix}
+\alias{as.Qmatrix.fitMk}
+\alias{plot.Qmatrix}
+\alias{print.Qmatrix}
+\title{Convert a fitted M\emph{k} model to a Q-matrix}
+\usage{
+as.Qmatrix(x, ...)
+\method{as.Qmatrix}{fitMk}(x, ...)
+\method{plot}{Qmatrix}(x, ...)
+\method{print}{Qmatrix}(x, ...)
+}
+\arguments{
+ \item{x}{fitted M\emph{k} model. (For instance, an object of class \code{"fitMk"}.) In the case of \code{print.Qmatrix}, an object of class \code{"Qmatrix"}.}
+ \item{...}{optional arguments.}
+}
+\description{
+ Extracts a \bold{Q}-matrix from a fitted M\emph{k} model.
+}
+\details{
+ This function extracts a \bold{Q}-matrix (in the form of an object of class \code{"Qmatrix"}) from a fitted M\emph{k} model.
+}
+\value{
+ An object of class \code{"Qmatrix"}.
+
+ \code{plot.Qmatrix} invisibly returns the coordinates of vertices of the plotted \bold{Q}-matrix.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}, Joan Maspons}
+\seealso{
+ \code{\link{fitMk}}
+}
+\keyword{phylogenetics}
+\keyword{maximum likelihood}
+\keyword{comparative method}
+\keyword{discrete character}
+\keyword{utilities}
diff --git a/man/as.multiPhylo.Rd b/man/as.multiPhylo.Rd
index 2187242..7ddb3a7 100644
--- a/man/as.multiPhylo.Rd
+++ b/man/as.multiPhylo.Rd
@@ -1,26 +1,26 @@
-\name{as.multiPhylo}
-\alias{as.multiPhylo}
-\alias{as.multiPhylo.multiSimmap}
-\alias{as.multiPhylo.phylo}
-\title{Conversion to object of class \code{"multiPhylo"}}
-\usage{
-as.multiPhylo(x, ...)
-\method{as.multiPhylo}{multiSimmap}(x, ...)
-\method{as.multiPhylo}{phylo}(x, ...)
-}
-\arguments{
- \item{x}{object to be converted to \code{"multiPhylo"}. Presently an object of class \code{"multiSimmap"}, or an object of class \code{"phylo"}. In the latter case an object of class \code{"multiPhylo"} with length \code{1} is generated.}
- \item{...}{optional arguments.}
-}
-\description{
- This function converts between object classes.
-}
-\value{
- An object of class \code{"multiPhylo"}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{phylogenetics}
-\keyword{utilities}
+\name{as.multiPhylo}
+\alias{as.multiPhylo}
+\alias{as.multiPhylo.multiSimmap}
+\alias{as.multiPhylo.phylo}
+\title{Conversion to object of class \code{"multiPhylo"}}
+\usage{
+as.multiPhylo(x, ...)
+\method{as.multiPhylo}{multiSimmap}(x, ...)
+\method{as.multiPhylo}{phylo}(x, ...)
+}
+\arguments{
+ \item{x}{object to be converted to \code{"multiPhylo"}. Presently an object of class \code{"multiSimmap"}, or an object of class \code{"phylo"}. In the latter case an object of class \code{"multiPhylo"} with length \code{1} is generated.}
+ \item{...}{optional arguments.}
+}
+\description{
+ This function converts between object classes.
+}
+\value{
+ An object of class \code{"multiPhylo"}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{phylogenetics}
+\keyword{utilities}
diff --git a/man/ave.rates.Rd b/man/ave.rates.Rd
index 76d9598..d2644af 100644
--- a/man/ave.rates.Rd
+++ b/man/ave.rates.Rd
@@ -1,34 +1,34 @@
-\name{ave.rates}
-\alias{ave.rates}
-\title{Average the posterior rates}
-\usage{
-ave.rates(tree, shift, tips, sig1, sig2, ave.shift, showTree=TRUE)
-}
-\arguments{
- \item{tree}{a tree.}
- \item{shift}{the shift point for this sample.}
- \item{tips}{tip names tipward of \code{shift}.}
- \item{sig1}{\eqn{\sigma_1^2}.}
- \item{sig2}{\eqn{\sigma_2^2}.}
- \item{ave.shift}{average shift from all samples.}
- \item{showTree}{logical value indicating whether to plot the rate-stretched tree.}
-
-}
-\description{
- Internal function for \code{\link{posterior.evolrate}}.
-}
-\value{
- A list of the rates.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{evol.rate.mcmc}}, \code{\link{minSplit}}, \code{\link{posterior.evolrate}}
-}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{bayesian}
-\keyword{continuous characters}
-\keyword{math}
+\name{ave.rates}
+\alias{ave.rates}
+\title{Average the posterior rates}
+\usage{
+ave.rates(tree, shift, tips, sig1, sig2, ave.shift, showTree=TRUE)
+}
+\arguments{
+ \item{tree}{a tree.}
+ \item{shift}{the shift point for this sample.}
+ \item{tips}{tip names tipward of \code{shift}.}
+ \item{sig1}{\eqn{\sigma_1^2}.}
+ \item{sig2}{\eqn{\sigma_2^2}.}
+ \item{ave.shift}{average shift from all samples.}
+ \item{showTree}{logical value indicating whether to plot the rate-stretched tree.}
+
+}
+\description{
+ Internal function for \code{\link{posterior.evolrate}}.
+}
+\value{
+ A list of the rates.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{evol.rate.mcmc}}, \code{\link{minSplit}}, \code{\link{posterior.evolrate}}
+}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{bayesian}
+\keyword{continuous characters}
+\keyword{math}
diff --git a/man/bd.Rd b/man/bd.Rd
index 347634b..bac868b 100644
--- a/man/bd.Rd
+++ b/man/bd.Rd
@@ -1,30 +1,30 @@
-\name{bd}
-\alias{bd}
-\title{Convert object of class "birthdeath" to raw birth & death rates}
-\usage{
-bd(x)
-}
-\arguments{
- \item{x}{object of class \code{"birthdeath"}.}
-}
-\description{
- Converts an object of class \code{"birthdeath"} (from \code{\link{birthdeath}}) to a vector with the ML birth & death rates.
-}
-\details{
- This is now somewhat obsolete as \pkg{phytools} now contains functions to fit birth-death and pure-birth diversification models from trees (\code{\link{fit.bd}} and \code{\link{fit.yule}}) that also take into account incomplete sampling fraction.
-}
-\value{
- A vector.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{birthdeath}}, \code{\link{fit.bd}}, \code{\link{fit.yule}}
-}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{utilities}
-\keyword{diversification}
-\keyword{maximum likelihood}
+\name{bd}
+\alias{bd}
+\title{Convert object of class "birthdeath" to raw birth & death rates}
+\usage{
+bd(x)
+}
+\arguments{
+ \item{x}{object of class \code{"birthdeath"}.}
+}
+\description{
+ Converts an object of class \code{"birthdeath"} (from \code{\link{birthdeath}}) to a vector with the ML birth & death rates.
+}
+\details{
+ This is now somewhat obsolete as \pkg{phytools} now contains functions to fit birth-death and pure-birth diversification models from trees (\code{\link{fit.bd}} and \code{\link{fit.yule}}) that also take into account incomplete sampling fraction.
+}
+\value{
+ A vector.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{birthdeath}}, \code{\link{fit.bd}}, \code{\link{fit.yule}}
+}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{utilities}
+\keyword{diversification}
+\keyword{maximum likelihood}
diff --git a/man/bind.tip.Rd b/man/bind.tip.Rd
index 1e2ca9e..695daaf 100644
--- a/man/bind.tip.Rd
+++ b/man/bind.tip.Rd
@@ -1,62 +1,62 @@
-\name{bind.tip}
-\alias{bind.tip}
-\title{Attaches a new tip to a tree}
-\usage{
-bind.tip(tree, tip.label, edge.length=NULL, where=NULL, position=0,
- interactive=FALSE, ...)
-}
-\arguments{
- \item{tree}{receptor tree.}
- \item{tip.label}{a string containing the species name for the new tip.}
- \item{edge.length}{edge length for the new tip (a scalar).}
- \item{where}{node number to attach new tip. If \code{position>0} then then tip will be attached \emph{rootward} of the specified node. Node numbers can also be tips, in which case the new tip will be added along the terminal edge. To find out the tip number for given species with name \emph{"species"} type: \code{which(tree$tip.label=="species")}.}
- \item{position}{distance \emph{rootward} of the node to add the new tip.}
- \item{interactive}{logical value indicating whether or not the species should be added interactively. (Defaults to \code{FALSE}.)}
- \item{...}{arguments to be passed to \code{plotTree} (for \code{interactive=TRUE}.)}
-}
-\description{
- Adds a new tip to the tree.
-}
-\details{
- If the tree is ultrametric and no branch length is specified, then \code{edge.length} is scaled so that the tree remains ultrametric after the new tip is added.
-
- Wrapper function for \pkg{ape} \code{\link{bind.tree}}. Note that \code{interactive=TRUE} works only for right-facing phylograms.
-}
-\value{
- An object of class \code{"phylo"}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\examples{
-set.seed(123)
-## generate tree
-tree<-pbtree(b=0.1, n=10)
-
-## plot original tree
-plot(tree)
-axisPhylo()
-
-## add an extant tip ("t_extant") sister to taxon 't5'
-## with divergence time of 4.5 Ma
-node <- which(tree$tip.label=="t5")
-tree <- bind.tip(tree, tip.label="t_extant",
- where=node, position=4.5)
-# plot to see the result
-plot(tree)
-axisPhylo()
-
-## add an extinct tip ("t_extinct") sister to 't2' with
-## divergence time of 7.8 Ma and duration (edge length) of
-## 3.3 Ma
-node <- which(tree$tip.label=="t2")
-tree <- bind.tip(tree, tip.label="t_extinct", where=node,
- position=7.8, edge.length=3.3)
-
-## plot to see the result
-plot(tree)
-axisPhylo()
-}
-\keyword{phylogenetics}
-\keyword{utilities}
+\name{bind.tip}
+\alias{bind.tip}
+\title{Attaches a new tip to a tree}
+\usage{
+bind.tip(tree, tip.label, edge.length=NULL, where=NULL, position=0,
+ interactive=FALSE, ...)
+}
+\arguments{
+ \item{tree}{receptor tree.}
+ \item{tip.label}{a string containing the species name for the new tip.}
+ \item{edge.length}{edge length for the new tip (a scalar).}
+ \item{where}{node number to attach new tip. If \code{position>0} then then tip will be attached \emph{rootward} of the specified node. Node numbers can also be tips, in which case the new tip will be added along the terminal edge. To find out the tip number for given species with name \emph{"species"} type: \code{which(tree$tip.label=="species")}.}
+ \item{position}{distance \emph{rootward} of the node to add the new tip.}
+ \item{interactive}{logical value indicating whether or not the species should be added interactively. (Defaults to \code{FALSE}.)}
+ \item{...}{arguments to be passed to \code{plotTree} (for \code{interactive=TRUE}.)}
+}
+\description{
+ Adds a new tip to the tree.
+}
+\details{
+ If the tree is ultrametric and no branch length is specified, then \code{edge.length} is scaled so that the tree remains ultrametric after the new tip is added.
+
+ Wrapper function for \pkg{ape} \code{\link{bind.tree}}. Note that \code{interactive=TRUE} works only for right-facing phylograms.
+}
+\value{
+ An object of class \code{"phylo"}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\examples{
+set.seed(123)
+## generate tree
+tree<-pbtree(b=0.1, n=10)
+
+## plot original tree
+plot(tree)
+axisPhylo()
+
+## add an extant tip ("t_extant") sister to taxon 't5'
+## with divergence time of 4.5 Ma
+node <- which(tree$tip.label=="t5")
+tree <- bind.tip(tree, tip.label="t_extant",
+ where=node, position=4.5)
+# plot to see the result
+plot(tree)
+axisPhylo()
+
+## add an extinct tip ("t_extinct") sister to 't2' with
+## divergence time of 7.8 Ma and duration (edge length) of
+## 3.3 Ma
+node <- which(tree$tip.label=="t2")
+tree <- bind.tip(tree, tip.label="t_extinct", where=node,
+ position=7.8, edge.length=3.3)
+
+## plot to see the result
+plot(tree)
+axisPhylo()
+}
+\keyword{phylogenetics}
+\keyword{utilities}
diff --git a/man/bind.tree.simmap.Rd b/man/bind.tree.simmap.Rd
index d5bef33..3b2d3ba 100644
--- a/man/bind.tree.simmap.Rd
+++ b/man/bind.tree.simmap.Rd
@@ -1,26 +1,26 @@
-\name{bind.tree.simmap}
-\alias{bind.tree.simmap}
-\title{Binds two trees of class \code{"simmap"}}
-\usage{
-bind.tree.simmap(x, y, where="root")
-}
-\arguments{
- \item{x}{an object of class \code{"simmap"}. (The receptor tree.)}
- \item{y}{an object of class \code{"simmap"}. (The tree being grafted.)}
- \item{where}{node number to attach new tip, or the root node if \code{where="root"}.}
-}
-\description{
- This function grafts tree \code{y} onto tree \code{x} at node \code{where}.
-}
-\details{
- This function wraps around \code{\link{bind.tree}} for objects of class \code{"simmap"}; however it presently only allows \code{y} to be grafted at a node of \code{x} and it does not allow \code{y} to possess a root edge.
-}
-\value{
- An object of class \code{"simmap"}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{phylogenetics}
-\keyword{utilities}
+\name{bind.tree.simmap}
+\alias{bind.tree.simmap}
+\title{Binds two trees of class \code{"simmap"}}
+\usage{
+bind.tree.simmap(x, y, where="root")
+}
+\arguments{
+ \item{x}{an object of class \code{"simmap"}. (The receptor tree.)}
+ \item{y}{an object of class \code{"simmap"}. (The tree being grafted.)}
+ \item{where}{node number to attach new tip, or the root node if \code{where="root"}.}
+}
+\description{
+ This function grafts tree \code{y} onto tree \code{x} at node \code{where}.
+}
+\details{
+ This function wraps around \code{\link{bind.tree}} for objects of class \code{"simmap"}; however it presently only allows \code{y} to be grafted at a node of \code{x} and it does not allow \code{y} to possess a root edge.
+}
+\value{
+ An object of class \code{"simmap"}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{phylogenetics}
+\keyword{utilities}
diff --git a/man/bmPlot.Rd b/man/bmPlot.Rd
index 994ce2b..f70d20d 100644
--- a/man/bmPlot.Rd
+++ b/man/bmPlot.Rd
@@ -1,63 +1,63 @@
-\name{bmPlot}
-\alias{bmPlot}
-\title{Simulates and visualizes discrete-time Brownian evolution on a phylogeny}
-\usage{
-bmPlot(tree, type="BM", anc=0, sig2=1/1000, ngen=1000, ...)
-}
-\arguments{
- \item{tree}{a phylogenetic tree in \code{"phylo"} format.}
- \item{type}{the type of plot to create. See Description.}
- \item{anc}{the ancestral value for the root node.}
- \item{sig2}{the BM rate (variance of the Brownian evolution process), \eqn{\sigma^2}.}
- \item{ngen}{number of generations for the simulation: will rescale the tree to this total length.}
- \item{...}{arguments to be passed to different methods.}
-}
-\description{
- Conducts a discrete-time Brownian motion simulation on an input tree, plots the outcome, and returns the tip and internal node states to the user as a named vector.
-}
-\details{
- The function will first rescale and round the branch lengths to integer length, if they are not already in integer values. If integer branch lengths are provided, the user should also set \code{ngen} to be equal to the total height of the tree in generations (and thus avoid rescaling).
-
- For \code{type="threshold"} the visualization is of the threshold model (Felsenstein 2012), in which the evolving character is liability and the segments of evolution are colored by their value for the threshold trait. If \code{type="threshold"} is used, the function requires at least one addition input: \code{thresholds}, a vector containing the ordered thresholds between states. The user can also provide the colors for plotting in \code{colors}. Note that one more color than threshold should be provided as one threshold implies two states; two thresholds, three states; etc. If no value for \code{colors} is provided, the function will recycle a set of four colors up to the number of times required by \code{thresholds}. Finally, the optional argument \code{return.tree=TRUE} will tell the function to return a list with the tip and note states and an object of class \code{"phylo"} with (for \code{type="threshold"}), the state for the threshold model through time mapped on the branches of the tree in discrete time.
-}
-\value{
- This function conducts and plots discrete time Brownian simulation and returns a vector containing the simulated states at internal nodes and tips of the tree.
-
- It also returns, by default (although this can be turned off) a tree with the branch lengths in discrete time and with a mapped discrete character (for \code{type="threshold"}).
-}
-\references{
- Felsenstein, J. 2012. A comparative method for both discrete and continuous characters using the threshold model. \emph{American Naturalist}, \bold{179}, 145-156.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-
- Revell, L. J. (2014) Ancestral character estimation under the threshold model from quantitative genetics. \emph{Evolution}, bold{68}, 743-759.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{fastBM}}, \code{\link{pbtree}}, \code{\link{phenogram}}, \code{\link{threshBayes}}
-}
-\examples{
-set.seed(999)
-## plot BM simulation on 12 taxon tree
-tree<-pbtree(n=12)
-par(mfrow=c(1,2),mar=c(5.1,4.1,4.1,0.1))
-x<-bmPlot(tree,bty="l")
-plotTree(tree,direction="upwards",
- mar=c(5.1,0.1,4.1,1.1),ftype="off")
-## reset par to default values
-par(mfrow=c(1,1),mar=c(5.1,4.1,4.1,2.1))
-## plot simulation of a threshold character
-par(mfrow=c(1,2),mar=c(5.1,4.1,4.1,0.1))
-tt<-bmPlot(tree,type="threshold",thresholds=c(0,1,2),
- bty="l")
-plot(tt$tree,direction="upwards",
- mar=c(5.1,0.1,4.1,1.1),ftype="off",
- colors=setNames(c("black","red","blue"),
- letters[1:3]),lwd=3)
-## reset par to default values
-par(mfrow=c(1,1),mar=c(5.1,4.1,4.1,2.1))
-}
-\keyword{phylogenetics}
-\keyword{plotting}
-\keyword{simulation}
-\keyword{continuous character}
+\name{bmPlot}
+\alias{bmPlot}
+\title{Simulates and visualizes discrete-time Brownian evolution on a phylogeny}
+\usage{
+bmPlot(tree, type="BM", anc=0, sig2=1/1000, ngen=1000, ...)
+}
+\arguments{
+ \item{tree}{a phylogenetic tree in \code{"phylo"} format.}
+ \item{type}{the type of plot to create. See Description.}
+ \item{anc}{the ancestral value for the root node.}
+ \item{sig2}{the BM rate (variance of the Brownian evolution process), \eqn{\sigma^2}.}
+ \item{ngen}{number of generations for the simulation: will rescale the tree to this total length.}
+ \item{...}{arguments to be passed to different methods.}
+}
+\description{
+ Conducts a discrete-time Brownian motion simulation on an input tree, plots the outcome, and returns the tip and internal node states to the user as a named vector.
+}
+\details{
+ The function will first rescale and round the branch lengths to integer length, if they are not already in integer values. If integer branch lengths are provided, the user should also set \code{ngen} to be equal to the total height of the tree in generations (and thus avoid rescaling).
+
+ For \code{type="threshold"} the visualization is of the threshold model (Felsenstein 2012), in which the evolving character is liability and the segments of evolution are colored by their value for the threshold trait. If \code{type="threshold"} is used, the function requires at least one addition input: \code{thresholds}, a vector containing the ordered thresholds between states. The user can also provide the colors for plotting in \code{colors}. Note that one more color than threshold should be provided as one threshold implies two states; two thresholds, three states; etc. If no value for \code{colors} is provided, the function will recycle a set of four colors up to the number of times required by \code{thresholds}. Finally, the optional argument \code{return.tree=TRUE} will tell the function to return a list with the tip and note states and an object of class \code{"phylo"} with (for \code{type="threshold"}), the state for the threshold model through time mapped on the branches of the tree in discrete time.
+}
+\value{
+ This function conducts and plots discrete time Brownian simulation and returns a vector containing the simulated states at internal nodes and tips of the tree.
+
+ It also returns, by default (although this can be turned off) a tree with the branch lengths in discrete time and with a mapped discrete character (for \code{type="threshold"}).
+}
+\references{
+ Felsenstein, J. 2012. A comparative method for both discrete and continuous characters using the threshold model. \emph{American Naturalist}, \bold{179}, 145-156.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+
+ Revell, L. J. (2014) Ancestral character estimation under the threshold model from quantitative genetics. \emph{Evolution}, bold{68}, 743-759.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{fastBM}}, \code{\link{pbtree}}, \code{\link{phenogram}}, \code{\link{threshBayes}}
+}
+\examples{
+set.seed(999)
+## plot BM simulation on 12 taxon tree
+tree<-pbtree(n=12)
+par(mfrow=c(1,2),mar=c(5.1,4.1,4.1,0.1))
+x<-bmPlot(tree,bty="l")
+plotTree(tree,direction="upwards",
+ mar=c(5.1,0.1,4.1,1.1),ftype="off")
+## reset par to default values
+par(mfrow=c(1,1),mar=c(5.1,4.1,4.1,2.1))
+## plot simulation of a threshold character
+par(mfrow=c(1,2),mar=c(5.1,4.1,4.1,0.1))
+tt<-bmPlot(tree,type="threshold",thresholds=c(0,1,2),
+ bty="l")
+plot(tt$tree,direction="upwards",
+ mar=c(5.1,0.1,4.1,1.1),ftype="off",
+ colors=setNames(c("black","red","blue"),
+ letters[1:3]),lwd=3)
+## reset par to default values
+par(mfrow=c(1,1),mar=c(5.1,4.1,4.1,2.1))
+}
+\keyword{phylogenetics}
+\keyword{plotting}
+\keyword{simulation}
+\keyword{continuous character}
diff --git a/man/branching.diffusion.Rd b/man/branching.diffusion.Rd
index 35cc021..8d09d80 100644
--- a/man/branching.diffusion.Rd
+++ b/man/branching.diffusion.Rd
@@ -1,39 +1,39 @@
-\name{branching.diffusion}
-\alias{branching.diffusion}
-\title{Animation of branching random diffusion}
-\usage{
-branching.diffusion(sig2=1, b=0.0023, time.stop=1000, ylim=NULL,
- smooth=TRUE, pause=0.02, record=NULL, path=NULL, ...)
-}
-\arguments{
- \item{sig2}{variance of BM process, \eqn{\sigma^2}.}
- \item{b}{birthrate for branching process.}
- \item{time.stop}{number of generations to run.}
- \item{ylim}{\emph{y} limits (for plotting).}
- \item{smooth}{no longer used.}
- \item{pause}{pause (in s) between generations.}
- \item{record}{filename for video file output (no video if \code{NULL}).}
- \item{path}{full path to file for video rendering. (By default \code{branching.diffusion} will look for the executable \code{ffmpeg.exe} in the directory \code{C:/Program Files/ffmpeg/bin}, even though this will not make sense on non-Windows machines.)}
- \item{...}{optional arguments.}
-}
-\description{
- This function creates an animation of branching random diffusion (i.e., Brownian motion evolution with speciation).
-}
-\details{
- For animation to be recorded to file, the function requires the package \emph{animation} as well as a video renderer.
-}
-\value{
- An animated plot and (optionally) a recorded video file.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{bmPlot}}, \code{\link{fastBM}}
-}
-\keyword{phylogenetics}
-\keyword{animation}
-\keyword{plotting}
-\keyword{simulation}
-\keyword{continuous character}
+\name{branching.diffusion}
+\alias{branching.diffusion}
+\title{Animation of branching random diffusion}
+\usage{
+branching.diffusion(sig2=1, b=0.0023, time.stop=1000, ylim=NULL,
+ smooth=TRUE, pause=0.02, record=NULL, path=NULL, ...)
+}
+\arguments{
+ \item{sig2}{variance of BM process, \eqn{\sigma^2}.}
+ \item{b}{birthrate for branching process.}
+ \item{time.stop}{number of generations to run.}
+ \item{ylim}{\emph{y} limits (for plotting).}
+ \item{smooth}{no longer used.}
+ \item{pause}{pause (in s) between generations.}
+ \item{record}{filename for video file output (no video if \code{NULL}).}
+ \item{path}{full path to file for video rendering. (By default \code{branching.diffusion} will look for the executable \code{ffmpeg.exe} in the directory \code{C:/Program Files/ffmpeg/bin}, even though this will not make sense on non-Windows machines.)}
+ \item{...}{optional arguments.}
+}
+\description{
+ This function creates an animation of branching random diffusion (i.e., Brownian motion evolution with speciation).
+}
+\details{
+ For animation to be recorded to file, the function requires the package \emph{animation} as well as a video renderer.
+}
+\value{
+ An animated plot and (optionally) a recorded video file.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{bmPlot}}, \code{\link{fastBM}}
+}
+\keyword{phylogenetics}
+\keyword{animation}
+\keyword{plotting}
+\keyword{simulation}
+\keyword{continuous character}
diff --git a/man/brownie.lite.Rd b/man/brownie.lite.Rd
index 194f223..5fcd715 100644
--- a/man/brownie.lite.Rd
+++ b/man/brownie.lite.Rd
@@ -1,64 +1,64 @@
-\name{brownie.lite}
-\alias{brownie.lite}
-\title{Likelihood test for rate variation in a continuous trait}
-\usage{
-brownie.lite(tree, x, maxit=2000, test="chisq", nsim=100, se=NULL, ...)
-}
-\arguments{
- \item{tree}{a phylogenetic tree either as an object of class \code{"phylo"} or \code{"simmap"}. (See \code{\link{read.simmap}}, \code{\link{make.simmap}}, or \code{\link{paintSubTree}} for more details about the latter object class.)}
- \item{x}{a vector of tip values for species. \code{names(x)} should be the species names.}
- \item{maxit}{an optional integer value indicating the maximum number of iterations for optimization - may need to be increased for large trees.}
- \item{test}{an optional string indicating the method for hypothesis testing - options are \code{"chisq"} or \code{"simulation"}.}
- \item{nsim}{number of simulations (only used if \code{test="simulation"}).}
- \item{se}{a vector containing the standard errors for each estimated mean in \code{x}.}
- \item{...}{optional arguments.}
-}
-\description{
- Fits a multi-rate Brownian motion evolution model using maximum likelihood.
-}
-\details{
- This function takes an object of class \code{"phylo"} or class \code{"simmap"} with a mapped binary or multistate trait (see \code{\link{read.simmap}}) and data for a single continuously valued character. It then fits the Brownian rate variation ("noncensored") model of O'Meara et al. (2006; \emph{Evolution}). This is also the basic model implemented in Brian O'Meara's \emph{Brownie} software.
-
- Sampling error in the estimation of species means can also be accounted for by assigning the vector \code{se} with the species specific sampling errors for \code{x}.
-}
-\value{
- An object of class \code{"brownie.lite"} containing the following elements:
- \item{sig2.single}{is the rate, \eqn{\sigma^2}, for a single-rate model. This is usually the "null" model.}
- \item{a.single}{is the estimated state at the root node for the single rate model.}
- \item{var.single}{variance on the single rate estimator - obtained from the Hessian.}
- \item{logL1}{log-likelihood of the single-rate model.}
- \item{k1}{number of parameters in the single rate model (always 2).}
- \item{sig2.multiple}{is a length \emph{p} (for \emph{p} rates) vector of BM rates (\eqn{\sigma_1^2}, \eqn{\sigma_2^2}, and so on) from the multi-rate model.}
- \item{a.multiple}{is the estimated state at the root node for the multi-rate model.}
- \item{var.multiple}{\emph{p} x \emph{p} variance-covariance matrix for the \emph{p} rates - the square-roots of the diagonals should give the standard error for each rate.}
- \item{logL.multiple}{log-likelihood of the multi-rate model.}
- \item{k2}{number of parameters in the multi-rate model (\emph{p}+1).}
- \item{P.chisq}{P-value for a likelihood ratio test against the \eqn{\chi^2} distribution; or}
- \item{P.sim}{P-value for a likelihood ratio test agains a simulated null distribution.}
- \item{convergence}{logical value indicating if the likelihood optimization converged.}
-}
-\references{
- O'Meara, B. C., C. Ane, M. J. Sanderson, and P. C. Wainwright. (2006) Testing for different rates of continuous trait evolution using likelihood. \emph{Evolution}, \bold{60}, 922-933.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{brownieREML}}, \code{\link{evol.vcv}}, \code{\link{ratebytree}}
-}
-\examples{
-## load data from Revell & Collar (2009)
-data(sunfish.tree)
-data(sunfish.data)
-## extract character of interest
-buccal.length<-setNames(sunfish.data$buccal.length,
- rownames(sunfish.data))
-## fit model
-multiBM.fit<-brownie.lite(sunfish.tree,
- buccal.length)
-print(multiBM.fit)
-}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{maximum likelihood}
-\keyword{continuous character}
+\name{brownie.lite}
+\alias{brownie.lite}
+\title{Likelihood test for rate variation in a continuous trait}
+\usage{
+brownie.lite(tree, x, maxit=2000, test="chisq", nsim=100, se=NULL, ...)
+}
+\arguments{
+ \item{tree}{a phylogenetic tree either as an object of class \code{"phylo"} or \code{"simmap"}. (See \code{\link{read.simmap}}, \code{\link{make.simmap}}, or \code{\link{paintSubTree}} for more details about the latter object class.)}
+ \item{x}{a vector of tip values for species. \code{names(x)} should be the species names.}
+ \item{maxit}{an optional integer value indicating the maximum number of iterations for optimization - may need to be increased for large trees.}
+ \item{test}{an optional string indicating the method for hypothesis testing - options are \code{"chisq"} or \code{"simulation"}.}
+ \item{nsim}{number of simulations (only used if \code{test="simulation"}).}
+ \item{se}{a vector containing the standard errors for each estimated mean in \code{x}.}
+ \item{...}{optional arguments.}
+}
+\description{
+ Fits a multi-rate Brownian motion evolution model using maximum likelihood.
+}
+\details{
+ This function takes an object of class \code{"phylo"} or class \code{"simmap"} with a mapped binary or multistate trait (see \code{\link{read.simmap}}) and data for a single continuously valued character. It then fits the Brownian rate variation ("noncensored") model of O'Meara et al. (2006; \emph{Evolution}). This is also the basic model implemented in Brian O'Meara's \emph{Brownie} software.
+
+ Sampling error in the estimation of species means can also be accounted for by assigning the vector \code{se} with the species specific sampling errors for \code{x}.
+}
+\value{
+ An object of class \code{"brownie.lite"} containing the following elements:
+ \item{sig2.single}{is the rate, \eqn{\sigma^2}, for a single-rate model. This is usually the "null" model.}
+ \item{a.single}{is the estimated state at the root node for the single rate model.}
+ \item{var.single}{variance on the single rate estimator - obtained from the Hessian.}
+ \item{logL1}{log-likelihood of the single-rate model.}
+ \item{k1}{number of parameters in the single rate model (always 2).}
+ \item{sig2.multiple}{is a length \emph{p} (for \emph{p} rates) vector of BM rates (\eqn{\sigma_1^2}, \eqn{\sigma_2^2}, and so on) from the multi-rate model.}
+ \item{a.multiple}{is the estimated state at the root node for the multi-rate model.}
+ \item{var.multiple}{\emph{p} x \emph{p} variance-covariance matrix for the \emph{p} rates - the square-roots of the diagonals should give the standard error for each rate.}
+ \item{logL.multiple}{log-likelihood of the multi-rate model.}
+ \item{k2}{number of parameters in the multi-rate model (\emph{p}+1).}
+ \item{P.chisq}{P-value for a likelihood ratio test against the \eqn{\chi^2} distribution; or}
+ \item{P.sim}{P-value for a likelihood ratio test agains a simulated null distribution.}
+ \item{convergence}{logical value indicating if the likelihood optimization converged.}
+}
+\references{
+ O'Meara, B. C., C. Ane, M. J. Sanderson, and P. C. Wainwright. (2006) Testing for different rates of continuous trait evolution using likelihood. \emph{Evolution}, \bold{60}, 922-933.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{brownieREML}}, \code{\link{evol.vcv}}, \code{\link{ratebytree}}
+}
+\examples{
+## load data from Revell & Collar (2009)
+data(sunfish.tree)
+data(sunfish.data)
+## extract character of interest
+buccal.length<-setNames(sunfish.data$buccal.length,
+ rownames(sunfish.data))
+## fit model
+multiBM.fit<-brownie.lite(sunfish.tree,
+ buccal.length)
+print(multiBM.fit)
+}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{maximum likelihood}
+\keyword{continuous character}
diff --git a/man/brownieREML.Rd b/man/brownieREML.Rd
index 704cbab..86cbd41 100644
--- a/man/brownieREML.Rd
+++ b/man/brownieREML.Rd
@@ -1,54 +1,54 @@
-\name{brownieREML}
-\alias{brownieREML}
-\title{REML version of brownie.lite}
-\usage{
-brownieREML(tree, x, maxit=2000, ...)
-}
-\arguments{
- \item{tree}{an object of class \code{"phylo"} or \code{"simmap"}. (See \code{\link{read.simmap}} and \code{\link{make.simmap}} for more information about the latter object class.)}
- \item{x}{a vector of tip values for species. \code{names(x)} should be the species names.}
- \item{maxit}{an optional integer value indicating the maximum number of iterations for optimization - may need to be increased for large trees.}
- \item{...}{optional arguments.}
-}
-
-\description{
- Fits a multi-rate Brownian motion evolution model using REML. (See \code{\link{brownie.lite}} for more details.)
-}
-\details{
- This function takes an object of class \code{"phylo"} or an object of class \code{"simmap"} with a mapped binary or multistate trait (see \code{\link{read.simmap}}) and data for a single continuously valued character. It then uses restricted maximum likelihood (REML) to fit the Brownian rate variation ("noncensored") model of O'Meara et al. (2006; \emph{Evolution}). This function is similar to \code{\link{brownie.lite}} but uses REML (which is faster and unbiased) instead of ML. REML optimization takes advantage of Felsenstein's (1985) contrasts algorithm.
-}
-\value{
- An object of class \code{"brownieREML"} containing the following components:
- \item{sig2.single}{is the rate, \eqn{\sigma^2}, for a single rate model - this is usually the "null" model.}
- \item{logL1}{log-likelihood of the single-rate model.}
- \item{sig2.multiple}{is a length \emph{p} (for \emph{p} rates) vector of BM rates (\eqn{\sigma_1^2}, \eqn{\sigma_2^2}, and so on) from the multi-rate model.}
- \item{logL2}{log-likelihood of the multi-rate model.}
- \item{convergence}{numerical value from \code{\link{optim}}.}
-}
-\references{
- Felsenstein, J. 1985. Phylogenies and the comparative method. \emph{American Naturalist}, \bold{125}, 1-15.
-
- O'Meara, B. C., C. Ane, M. J. Sanderson, and P. C. Wainwright. 2006. Testing for different rates of continuous trait evolution using likelihood. \emph{Evolution}, \bold{60}, 922-933.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{brownie.lite}}, \code{\link{evol.vcv}}, \code{\link{evol.rate.mcmc}}, \code{\link{ratebytree}}
-}
-\examples{
-## load data from Revell & Collar (2009)
-data(sunfish.tree)
-data(sunfish.data)
-## extract character of interest
-gape.width<-setNames(sunfish.data$gape.width,
- rownames(sunfish.data))
-## fit model
-multiBM.reml<-brownieREML(sunfish.tree,
- gape.width)
-print(multiBM.reml)
-}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{continuous character}
-\keyword{maximum likelihood}
+\name{brownieREML}
+\alias{brownieREML}
+\title{REML version of brownie.lite}
+\usage{
+brownieREML(tree, x, maxit=2000, ...)
+}
+\arguments{
+ \item{tree}{an object of class \code{"phylo"} or \code{"simmap"}. (See \code{\link{read.simmap}} and \code{\link{make.simmap}} for more information about the latter object class.)}
+ \item{x}{a vector of tip values for species. \code{names(x)} should be the species names.}
+ \item{maxit}{an optional integer value indicating the maximum number of iterations for optimization - may need to be increased for large trees.}
+ \item{...}{optional arguments.}
+}
+
+\description{
+ Fits a multi-rate Brownian motion evolution model using REML. (See \code{\link{brownie.lite}} for more details.)
+}
+\details{
+ This function takes an object of class \code{"phylo"} or an object of class \code{"simmap"} with a mapped binary or multistate trait (see \code{\link{read.simmap}}) and data for a single continuously valued character. It then uses restricted maximum likelihood (REML) to fit the Brownian rate variation ("noncensored") model of O'Meara et al. (2006; \emph{Evolution}). This function is similar to \code{\link{brownie.lite}} but uses REML (which is faster and unbiased) instead of ML. REML optimization takes advantage of Felsenstein's (1985) contrasts algorithm.
+}
+\value{
+ An object of class \code{"brownieREML"} containing the following components:
+ \item{sig2.single}{is the rate, \eqn{\sigma^2}, for a single rate model - this is usually the "null" model.}
+ \item{logL1}{log-likelihood of the single-rate model.}
+ \item{sig2.multiple}{is a length \emph{p} (for \emph{p} rates) vector of BM rates (\eqn{\sigma_1^2}, \eqn{\sigma_2^2}, and so on) from the multi-rate model.}
+ \item{logL2}{log-likelihood of the multi-rate model.}
+ \item{convergence}{numerical value from \code{\link{optim}}.}
+}
+\references{
+ Felsenstein, J. 1985. Phylogenies and the comparative method. \emph{American Naturalist}, \bold{125}, 1-15.
+
+ O'Meara, B. C., C. Ane, M. J. Sanderson, and P. C. Wainwright. 2006. Testing for different rates of continuous trait evolution using likelihood. \emph{Evolution}, \bold{60}, 922-933.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{brownie.lite}}, \code{\link{evol.vcv}}, \code{\link{evol.rate.mcmc}}, \code{\link{ratebytree}}
+}
+\examples{
+## load data from Revell & Collar (2009)
+data(sunfish.tree)
+data(sunfish.data)
+## extract character of interest
+gape.width<-setNames(sunfish.data$gape.width,
+ rownames(sunfish.data))
+## fit model
+multiBM.reml<-brownieREML(sunfish.tree,
+ gape.width)
+print(multiBM.reml)
+}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{continuous character}
+\keyword{maximum likelihood}
diff --git a/man/cladelabels.Rd b/man/cladelabels.Rd
index 5a7db29..93328df 100644
--- a/man/cladelabels.Rd
+++ b/man/cladelabels.Rd
@@ -1,42 +1,42 @@
-\name{cladelabels}
-\alias{cladelabels}
-\alias{arc.cladelabels}
-\title{Add labels to subtrees of a plotted phylogeny}
-\usage{
-cladelabels(tree=NULL, text, node, offset=NULL, wing.length=NULL, cex=1,
- orientation="vertical")
-arc.cladelabels(tree=NULL, text, node=NULL, ln.offset=1.02,
- lab.offset=1.06, cex=1, orientation="curved", stretch=1, ...)
-}
-\arguments{
- \item{tree}{an object of class \code{"phylo"}. If not supplied, the function will obtain the last plotted phylogeny from the environmental variable \code{last_plot.phylo}.}
- \item{text}{desired clade label text.}
- \item{node}{node number for the most recent common ancestor of members of the clade. For \code{arc.cladelabels} this defaults to \code{NULL} which means that the node of the clade to be labeled should be specified interactively (that is, by clicking on the graphical device).}
- \item{offset}{offset (as a multiplier of character width) for the label. Defaults to \code{offset=1} if \code{tree} is supplied or \code{offset=8} otherwise.}
- \item{wing.length}{length of the wings to add to the top & bottom of the label bar (in character widths).}
- \item{cex}{character expansion factor.}
- \item{orientation}{orientation of the text. Can be \code{orientation = "vertical"} (the default) or \code{"horizontal"}.}
- \item{ln.offset}{line offset (as a function of total tree height) for \code{arc.cladelabels}.}
- \item{lab.offset}{label offset for \code{arc.cladelabels}.}
- \item{stretch}{argument for \code{arc.cladelabels} to be passed to \code{arctext}.}
- \item{...}{optional arguments for \code{arc.cladelabels}.}
-}
-\description{
- This function adds clade labels to a plotted tree.
-}
-\details{
- \code{cladelabels} presently works only for rightward facing plotted phylogenies - but no warning will be returned if your tree does not conform to this requirement!
-
- \code{arc.cladelabels} is designed to do a similar thing to \code{cladelabels}, but for plotted fan trees. This function checks to ensure that the most recently plotted tree was plotted with \code{type="fan"} style.
-}
-\references{
- Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{nodelabels}}
-}
-\keyword{phylogenetics}
-\keyword{utilities}
+\name{cladelabels}
+\alias{cladelabels}
+\alias{arc.cladelabels}
+\title{Add labels to subtrees of a plotted phylogeny}
+\usage{
+cladelabels(tree=NULL, text, node, offset=NULL, wing.length=NULL, cex=1,
+ orientation="vertical")
+arc.cladelabels(tree=NULL, text, node=NULL, ln.offset=1.02,
+ lab.offset=1.06, cex=1, orientation="curved", stretch=1, ...)
+}
+\arguments{
+ \item{tree}{an object of class \code{"phylo"}. If not supplied, the function will obtain the last plotted phylogeny from the environmental variable \code{last_plot.phylo}.}
+ \item{text}{desired clade label text.}
+ \item{node}{node number for the most recent common ancestor of members of the clade. For \code{arc.cladelabels} this defaults to \code{NULL} which means that the node of the clade to be labeled should be specified interactively (that is, by clicking on the graphical device).}
+ \item{offset}{offset (as a multiplier of character width) for the label. Defaults to \code{offset=1} if \code{tree} is supplied or \code{offset=8} otherwise.}
+ \item{wing.length}{length of the wings to add to the top & bottom of the label bar (in character widths).}
+ \item{cex}{character expansion factor.}
+ \item{orientation}{orientation of the text. Can be \code{orientation = "vertical"} (the default) or \code{"horizontal"}.}
+ \item{ln.offset}{line offset (as a function of total tree height) for \code{arc.cladelabels}.}
+ \item{lab.offset}{label offset for \code{arc.cladelabels}.}
+ \item{stretch}{argument for \code{arc.cladelabels} to be passed to \code{arctext}.}
+ \item{...}{optional arguments for \code{arc.cladelabels}.}
+}
+\description{
+ This function adds clade labels to a plotted tree.
+}
+\details{
+ \code{cladelabels} presently works only for rightward facing plotted phylogenies - but no warning will be returned if your tree does not conform to this requirement!
+
+ \code{arc.cladelabels} is designed to do a similar thing to \code{cladelabels}, but for plotted fan trees. This function checks to ensure that the most recently plotted tree was plotted with \code{type="fan"} style.
+}
+\references{
+ Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{nodelabels}}
+}
+\keyword{phylogenetics}
+\keyword{utilities}
diff --git a/man/collapseTree.Rd b/man/collapseTree.Rd
index 44ac727..ecbaa2d 100644
--- a/man/collapseTree.Rd
+++ b/man/collapseTree.Rd
@@ -1,34 +1,34 @@
-\name{collapseTree}
-\alias{collapseTree}
-\title{Interactive tree visualizer}
-\usage{
-collapseTree(tree, ...)
-}
-\arguments{
- \item{tree}{an object of class \code{"phylo"}.}
- \item{...}{optional arguments. These \emph{mostly} match the arguments of \code{\link{plotSimmap}}, but also include the argument \code{drop.extinct=TRUE} which will (if the input tree is ultrametric) drop any 'extinct' lineages from the tree that is returned by the function.}
-}
-\description{
- Function creates an interactive visualization of collapsing & expanding clades on the tree.
-}
-\details{
- Function first plots a fan style tree, and then the user collapses node on the tree by clicking on them. Collapsed nodes are collapsed to the common ancestor of the clade. Nodes that have been collapsed can also be expanded by clicking. Right-click to end.
-}
-\value{
- Returns the final plotted tree.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{plotTree}}, \code{\link{plotSimmap}}
-}
-\examples{
-\dontrun{
-data(anoletree)
-pruned<-collapseTree(anoletree)}
-}
-\keyword{phylogenetics}
-\keyword{plotting}
-\keyword{utilities}
+\name{collapseTree}
+\alias{collapseTree}
+\title{Interactive tree visualizer}
+\usage{
+collapseTree(tree, ...)
+}
+\arguments{
+ \item{tree}{an object of class \code{"phylo"}.}
+ \item{...}{optional arguments. These \emph{mostly} match the arguments of \code{\link{plotSimmap}}, but also include the argument \code{drop.extinct=TRUE} which will (if the input tree is ultrametric) drop any 'extinct' lineages from the tree that is returned by the function.}
+}
+\description{
+ Function creates an interactive visualization of collapsing & expanding clades on the tree.
+}
+\details{
+ Function first plots a fan style tree, and then the user collapses node on the tree by clicking on them. Collapsed nodes are collapsed to the common ancestor of the clade. Nodes that have been collapsed can also be expanded by clicking. Right-click to end.
+}
+\value{
+ Returns the final plotted tree.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{plotTree}}, \code{\link{plotSimmap}}
+}
+\examples{
+\dontrun{
+data(anoletree)
+pruned<-collapseTree(anoletree)}
+}
+\keyword{phylogenetics}
+\keyword{plotting}
+\keyword{utilities}
diff --git a/man/compare.chronograms.Rd b/man/compare.chronograms.Rd
index b28aebc..e2ea235 100644
--- a/man/compare.chronograms.Rd
+++ b/man/compare.chronograms.Rd
@@ -1,26 +1,26 @@
-\name{compare.chronograms}
-\alias{compare.chronograms}
-\title{Compares two chronograms with precisely matching nodes in a visual manner}
-\usage{
-compare.chronograms(t1, t2, ...)
-}
-\arguments{
- \item{t1}{object of class \code{"phylo"}.}
- \item{t2}{object of class \code{"phylo"} that matches \code{t1} precisely in topology & node rotations, but differs in edge lengths.}
- \item{...}{optional arguments.}
-}
-\description{
- Creates a visual comparison of two chronograms that differ in edge lengths but not topology.
-}
-\details{
- This function plots two trees, with semi-transparent colors by default, & uses arrows to highlight differences in depth of corresponding nodes between the trees.
-}
-\value{
- Function creates a plot.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{phylogenetics}
-\keyword{plotting}
+\name{compare.chronograms}
+\alias{compare.chronograms}
+\title{Compares two chronograms with precisely matching nodes in a visual manner}
+\usage{
+compare.chronograms(t1, t2, ...)
+}
+\arguments{
+ \item{t1}{object of class \code{"phylo"}.}
+ \item{t2}{object of class \code{"phylo"} that matches \code{t1} precisely in topology & node rotations, but differs in edge lengths.}
+ \item{...}{optional arguments.}
+}
+\description{
+ Creates a visual comparison of two chronograms that differ in edge lengths but not topology.
+}
+\details{
+ This function plots two trees, with semi-transparent colors by default, & uses arrows to highlight differences in depth of corresponding nodes between the trees.
+}
+\value{
+ Function creates a plot.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{phylogenetics}
+\keyword{plotting}
diff --git a/man/contMap.Rd b/man/contMap.Rd
index 6ba400f..a6758d6 100644
--- a/man/contMap.Rd
+++ b/man/contMap.Rd
@@ -1,81 +1,81 @@
-\name{contMap}
-\alias{contMap}
-\alias{plot.contMap}
-\alias{errorbar.contMap}
-\title{Map continuous trait evolution on the tree}
-\usage{
-contMap(tree, x, res=100, fsize=NULL, ftype=NULL, lwd=4, legend=NULL,
- lims=NULL, outline=TRUE, sig=3, type="phylogram", direction="rightwards",
- plot=TRUE, ...)
-\method{plot}{contMap}(x, ...)
-errorbar.contMap(obj, ...)
-}
-\arguments{
- \item{tree}{object of class \code{"phylo"}.}
- \item{x}{a numerical vector of phenotypic trait values for species. \code{names(x)} should contain the species names and match \code{tree$tip.label}. Or, for \code{plot.contMap}, an object of class \code{"contMap"}.}
- \item{res}{resolution for gradient plotting. Larger numbers (to a point) indicate a finer (smoother) gradient.}
- \item{fsize}{relative font size - can be a vector of length 2 in which the first element gives the font size for the tip labels & the second element giving the font size for the legend.}
- \item{ftype}{font type - see options in \code{\link{plotSimmap}}. As with \code{fsize}, this can be a vector with the second element giving font type for the legend.}
- \item{lwd}{line width for branches. Can be a single integer number or a vector. In the latter case, the second number will be taken to be the desired legend width.}
- \item{legend}{if \code{FALSE} no legend is plotted; if a numeric value, it gives the length of the legend in units of branch length. Default is 0.5 times the total tree length.}
- \item{lims}{range for the color map. By default, this will be \code{c(min(x),max(x))}, and should always include this range.}
- \item{outline}{logical value indicating whether or not to outline the branches of the tree in black.}
- \item{sig}{the number of decimal places to show on the legend limits.}
- \item{type}{type of plot desired. Options are \code{"phylogram"} for a rightward square phylogram; and \code{"fan"} for a circular phylogram.}
- \item{direction}{plotting direction for \code{type="phylogram"}.}
- \item{plot}{logical value indicating whether or not to plot the tree. If \code{plot=FALSE} then an object of class \code{"contMap"} will be returned without plotting.}
- \item{obj}{object of class \code{"contMap"}.}
- \item{...}{optional arguments for \code{plot.contMap} which include all the arguments of \code{contMap} except for \code{tree}, \code{x}, \code{res}, and \code{lims}. Also \code{method}, \code{"fastAnc"}, \code{"anc.ML"}, or \code{"user"} (for user-supplied states) specifying which function to use for ancestral state estimation; \code{hold} specifies whether or not to hold output to graphical device before plotting (defaults to \code{hold=TRUE}); and \code{anc.states} a vector containing some or multiple ancestral user-supplied ancestral states at nodes. Some other plotting arguments, such as \code{xlim} and \code{ylim}, may also work. Optional arguments for \code{errorbar.contMap} include \code{x}, a vector containing the original trait values mapped onto the tree (otherwise these will be obtained from \code{obj}), \code{scale.by.ci}, a logical argument (defaulting to \code{TRUE}) that determines whether or not the length of the error bars will be scaled by the CI width, and \code{lwd}, which detemines the line width of the plotted error bars.}
-}
-\description{
- Projects the observed and reconstructed values of a continuous trait onto the edges of a tree using a color gradient.
-}
-\details{
- Function plots a tree with a mapped continuous character.
-
- The mapping is accomplished by estimating states at internal nodes using ML with \code{\link{fastAnc}}, and then interpolating the states along each edge using equation [2] of Felsenstein (1985). This makes these interpolated values equal to the maximum likelihood estimates under a Brownian evolutionary process.
-
- The default color palette is \emph{not} recommended as it is not colorblind friendly and does not render well into gray scale; however, this can be updated using the helper function \code{\link{setMap}}.
-
- \code{errorbar.contMap} adds error bars to an existing plot.
-}
-\value{
- Plots a tree. An object of class \code{"contMap"} is returned invisibly.
-
- \code{errorbar.contMap} adds colorful error bars to a plotted tree.
-}
-\references{
- Felsenstein, J. 1985. Phylogenies and the comparative method. \emph{American Naturalist}, \bold{125}, 1-15.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-
- Revell, L. J. 2013. Two new graphical methods for mapping trait evolution on phylogenies. \emph{Methods in Ecology and Evolution}, \bold{4}, 754-759.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{anc.ML}}, \code{\link{densityMap}}, \code{\link{fastAnc}}, \code{\link{plotSimmap}}
-}
-\examples{
-## load data from Garland et al. (1992)
-data(mammal.tree)
-data(mammal.data)
-## extract character of interest
-ln.bodyMass<-log(setNames(mammal.data$bodyMass,
- rownames(mammal.data)))
-## create "contMap" object
-mammal.contMap<-contMap(mammal.tree,
- ln.bodyMass,plot=FALSE,res=200)
-## change color scheme
-mammal.contMap<-setMap(mammal.contMap,
- c("white","#FFFFB2","#FECC5C","#FD8D3C",
- "#E31A1C"))
-plot(mammal.contMap,fsize=c(0.7,0.8),
- leg.txt="log(body mass)")
-par(mar=c(5.1,4.1,4.1,2.1)) ## reset margins to default
-}
-\keyword{ancestral states}
-\keyword{phylogenetics}
-\keyword{plotting}
-\keyword{comparative method}
-\keyword{continuous character}
-\keyword{maximum likelihood}
+\name{contMap}
+\alias{contMap}
+\alias{plot.contMap}
+\alias{errorbar.contMap}
+\title{Map continuous trait evolution on the tree}
+\usage{
+contMap(tree, x, res=100, fsize=NULL, ftype=NULL, lwd=4, legend=NULL,
+ lims=NULL, outline=TRUE, sig=3, type="phylogram", direction="rightwards",
+ plot=TRUE, ...)
+\method{plot}{contMap}(x, ...)
+errorbar.contMap(obj, ...)
+}
+\arguments{
+ \item{tree}{object of class \code{"phylo"}.}
+ \item{x}{a numerical vector of phenotypic trait values for species. \code{names(x)} should contain the species names and match \code{tree$tip.label}. Or, for \code{plot.contMap}, an object of class \code{"contMap"}.}
+ \item{res}{resolution for gradient plotting. Larger numbers (to a point) indicate a finer (smoother) gradient.}
+ \item{fsize}{relative font size - can be a vector of length 2 in which the first element gives the font size for the tip labels & the second element giving the font size for the legend.}
+ \item{ftype}{font type - see options in \code{\link{plotSimmap}}. As with \code{fsize}, this can be a vector with the second element giving font type for the legend.}
+ \item{lwd}{line width for branches. Can be a single integer number or a vector. In the latter case, the second number will be taken to be the desired legend width.}
+ \item{legend}{if \code{FALSE} no legend is plotted; if a numeric value, it gives the length of the legend in units of branch length. Default is 0.5 times the total tree length.}
+ \item{lims}{range for the color map. By default, this will be \code{c(min(x),max(x))}, and should always include this range.}
+ \item{outline}{logical value indicating whether or not to outline the branches of the tree in black.}
+ \item{sig}{the number of decimal places to show on the legend limits.}
+ \item{type}{type of plot desired. Options are \code{"phylogram"} for a rightward square phylogram; and \code{"fan"} for a circular phylogram.}
+ \item{direction}{plotting direction for \code{type="phylogram"}.}
+ \item{plot}{logical value indicating whether or not to plot the tree. If \code{plot=FALSE} then an object of class \code{"contMap"} will be returned without plotting.}
+ \item{obj}{object of class \code{"contMap"}.}
+ \item{...}{optional arguments for \code{plot.contMap} which include all the arguments of \code{contMap} except for \code{tree}, \code{x}, \code{res}, and \code{lims}. Also \code{method}, \code{"fastAnc"}, \code{"anc.ML"}, or \code{"user"} (for user-supplied states) specifying which function to use for ancestral state estimation; \code{hold} specifies whether or not to hold output to graphical device before plotting (defaults to \code{hold=TRUE}); and \code{anc.states} a vector containing some or multiple ancestral user-supplied ancestral states at nodes. Some other plotting arguments, such as \code{xlim} and \code{ylim}, may also work. Optional arguments for \code{errorbar.contMap} include \code{x}, a vector containing the original trait values mapped onto the tree (otherwise these will be obtained from \code{obj}), \code{scale.by.ci}, a logical argument (defaulting to \code{TRUE}) that determines whether or not the length of the error bars will be scaled by the CI width, and \code{lwd}, which detemines the line width of the plotted error bars.}
+}
+\description{
+ Projects the observed and reconstructed values of a continuous trait onto the edges of a tree using a color gradient.
+}
+\details{
+ Function plots a tree with a mapped continuous character.
+
+ The mapping is accomplished by estimating states at internal nodes using ML with \code{\link{fastAnc}}, and then interpolating the states along each edge using equation [2] of Felsenstein (1985). This makes these interpolated values equal to the maximum likelihood estimates under a Brownian evolutionary process.
+
+ The default color palette is \emph{not} recommended as it is not colorblind friendly and does not render well into gray scale; however, this can be updated using the helper function \code{\link{setMap}}.
+
+ \code{errorbar.contMap} adds error bars to an existing plot.
+}
+\value{
+ Plots a tree. An object of class \code{"contMap"} is returned invisibly.
+
+ \code{errorbar.contMap} adds colorful error bars to a plotted tree.
+}
+\references{
+ Felsenstein, J. 1985. Phylogenies and the comparative method. \emph{American Naturalist}, \bold{125}, 1-15.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+
+ Revell, L. J. 2013. Two new graphical methods for mapping trait evolution on phylogenies. \emph{Methods in Ecology and Evolution}, \bold{4}, 754-759.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{anc.ML}}, \code{\link{densityMap}}, \code{\link{fastAnc}}, \code{\link{plotSimmap}}
+}
+\examples{
+## load data from Garland et al. (1992)
+data(mammal.tree)
+data(mammal.data)
+## extract character of interest
+ln.bodyMass<-log(setNames(mammal.data$bodyMass,
+ rownames(mammal.data)))
+## create "contMap" object
+mammal.contMap<-contMap(mammal.tree,
+ ln.bodyMass,plot=FALSE,res=200)
+## change color scheme
+mammal.contMap<-setMap(mammal.contMap,
+ c("white","#FFFFB2","#FECC5C","#FD8D3C",
+ "#E31A1C"))
+plot(mammal.contMap,fsize=c(0.7,0.8),
+ leg.txt="log(body mass)")
+par(mar=c(5.1,4.1,4.1,2.1)) ## reset margins to default
+}
+\keyword{ancestral states}
+\keyword{phylogenetics}
+\keyword{plotting}
+\keyword{comparative method}
+\keyword{continuous character}
+\keyword{maximum likelihood}
diff --git a/man/cophylo.Rd b/man/cophylo.Rd
index 321a9d9..023f3e9 100644
--- a/man/cophylo.Rd
+++ b/man/cophylo.Rd
@@ -1,59 +1,59 @@
-\name{cophylo}
-\alias{cophylo}
-\alias{plot.cophylo}
-\alias{cotangleplot}
-\title{Creates a co-phylogenetic plot}
-\usage{
-cophylo(tr1, tr2, assoc=NULL, rotate=TRUE, ...)
-\method{plot}{cophylo}(x, ...)
-cotangleplot(tr1, tr2, type=c("cladogram","phylogram"),
- use.edge.length=TRUE, tangle=c("both","tree1","tree2"), ...)
-}
-\arguments{
- \item{tr1}{object of class \code{"phylo"}.}
- \item{tr2}{object of class \code{"phylo"}.}
- \item{assoc}{matrix containing the tip labels in \code{tr1} to match to the tip labels in \code{tr2}. Note that not all labels in either tree need to be included; and, furthermore, one label in \code{tr1} can be matched with more than one label in \code{tr2}, or vice versa.}
- \item{rotate}{logical argument indicating whether nodes on both trees should be rotated to attempt to match in vertical position.}
- \item{x}{in the case of \code{plot.cophylo}, an object of class \code{"cophylo"} to be plotted.}
- \item{type}{for \code{cotangleplot}, the tree plotting style.}
- \item{use.edge.length}{for \code{cotangleplot}, a logical value indicating whether or not to plot trees with edge lengths.}
- \item{tangle}{for \code{cotangleplot}, whether to tangle the left tree, the right tree, or both.}
- \item{...}{optional arguments to be passed to \code{\link{tipRotate}}, or, in the case of \code{plot.cophylo}, to the internally used tree plotting function, \code{phylogram}. \code{phylogram} takes similar arguments to \code{\link{plotSimmap}}, such as \code{fsize}, \code{ftype}, \code{lwd}, and \code{pts}, though not all options from \code{plotSimmap} and \code{plotTree} are available. If \code{fsize} is supplied as a vector, different size fonts for the left & right facing trees may be used. In addition, the optional argument \code{scale.bar}, which should be a vector containing the lengths of the scale bars desired for the right & left trees, will add scale bars to the plot when supplied to \code{plot.cophylo}. If either tree contains polytomies, the \code{cophylo} argument \code{rotate.multi} should be set to \code{TRUE}. If curved linking lines are desired, the \code{plot.cophylo} argument \code{link.type} should be set to \code{"curved"}. Other arguments for the \code{plot} method include \code{link.col}, \code{link.lty}, and \code{link.lwd}, which can be supplied as a scalar or a vector in which the order of the elements corresponds to the order of the associations in \code{assoc}. Finally, \code{edge.col}, a list consisting of two vectors (\code{left} and \code{right}) can be used to specify the edge colors of the two left & right plotted trees. Note that the edge order is the same as in the \emph{rotated} trees, assuming that a rotation has been performed on \code{x}.}
-}
-\description{
- Visualize co-phylogenetic trees by multiple methods.
-}
-\details{
- \code{cophylo} an object of class \code{"cophylo"} or, in the case of \code{plot.cophylo}, plots that object. The function can (optionally) first attempt to rotate the nodes of both trees to optimize vertical matching of tips.
-
- If no matrix of associations, \code{assoc}, is provided, then \code{cophylo} will look for exact matches of tip labels between trees.
-
- \code{cotangleplot} creates a co-phylogenetic plot in which the edges of the matched trees are crossing and is designed to be used \emph{only} on phylogenies with matching tip labels.
-}
-\value{
- An object of class \code{"cophylo"} which includes the following components or a pair of plotted facing phylogenies with links between tips as specified in \code{assoc}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{cophyloplot}}, \code{\link{plotSimmap}}
-}
-\examples{
-## load data from Lopez-Vaamonde et al. (2001)
-data(wasp.trees)
-data(wasp.data)
-## create co-phylogenetic object
-wasp.cophylo<-cophylo(wasp.trees[[1]],wasp.trees[[2]],
- assoc=wasp.data)
-## plot co-phylogenies
-plot(wasp.cophylo,link.type="curved",link.lwd=4,
- link.lty="solid",link.col=make.transparent("red",
- 0.25))
-par(mar=c(5.1,4.1,4.1,2.1))
-}
-\keyword{phylogenetics}
-\keyword{plotting}
-\keyword{diversification}
-\keyword{co-phylogenetics}
+\name{cophylo}
+\alias{cophylo}
+\alias{plot.cophylo}
+\alias{cotangleplot}
+\title{Creates a co-phylogenetic plot}
+\usage{
+cophylo(tr1, tr2, assoc=NULL, rotate=TRUE, ...)
+\method{plot}{cophylo}(x, ...)
+cotangleplot(tr1, tr2, type=c("cladogram","phylogram"),
+ use.edge.length=TRUE, tangle=c("both","tree1","tree2"), ...)
+}
+\arguments{
+ \item{tr1}{object of class \code{"phylo"}.}
+ \item{tr2}{object of class \code{"phylo"}.}
+ \item{assoc}{matrix containing the tip labels in \code{tr1} to match to the tip labels in \code{tr2}. Note that not all labels in either tree need to be included; and, furthermore, one label in \code{tr1} can be matched with more than one label in \code{tr2}, or vice versa.}
+ \item{rotate}{logical argument indicating whether nodes on both trees should be rotated to attempt to match in vertical position.}
+ \item{x}{in the case of \code{plot.cophylo}, an object of class \code{"cophylo"} to be plotted.}
+ \item{type}{for \code{cotangleplot}, the tree plotting style.}
+ \item{use.edge.length}{for \code{cotangleplot}, a logical value indicating whether or not to plot trees with edge lengths.}
+ \item{tangle}{for \code{cotangleplot}, whether to tangle the left tree, the right tree, or both.}
+ \item{...}{optional arguments to be passed to \code{\link{tipRotate}}, or, in the case of \code{plot.cophylo}, to the internally used tree plotting function, \code{phylogram}. \code{phylogram} takes similar arguments to \code{\link{plotSimmap}}, such as \code{fsize}, \code{ftype}, \code{lwd}, and \code{pts}, though not all options from \code{plotSimmap} and \code{plotTree} are available. If \code{fsize} is supplied as a vector, different size fonts for the left & right facing trees may be used. In addition, the optional argument \code{scale.bar}, which should be a vector containing the lengths of the scale bars desired for the right & left trees, will add scale bars to the plot when supplied to \code{plot.cophylo}. If either tree contains polytomies, the \code{cophylo} argument \code{rotate.multi} should be set to \code{TRUE}. If curved linking lines are desired, the \code{plot.cophylo} argument \code{link.type} should be set to \code{"curved"}. Other arguments for the \code{plot} method include \code{link.col}, \code{link.lty}, and \code{link.lwd}, which can be supplied as a scalar or a vector in which the order of the elements corresponds to the order of the associations in \code{assoc}. Finally, \code{edge.col}, a list consisting of two vectors (\code{left} and \code{right}) can be used to specify the edge colors of the two left & right plotted trees. Note that the edge order is the same as in the \emph{rotated} trees, assuming that a rotation has been performed on \code{x}.}
+}
+\description{
+ Visualize co-phylogenetic trees by multiple methods.
+}
+\details{
+ \code{cophylo} an object of class \code{"cophylo"} or, in the case of \code{plot.cophylo}, plots that object. The function can (optionally) first attempt to rotate the nodes of both trees to optimize vertical matching of tips.
+
+ If no matrix of associations, \code{assoc}, is provided, then \code{cophylo} will look for exact matches of tip labels between trees.
+
+ \code{cotangleplot} creates a co-phylogenetic plot in which the edges of the matched trees are crossing and is designed to be used \emph{only} on phylogenies with matching tip labels.
+}
+\value{
+ An object of class \code{"cophylo"} which includes the following components or a pair of plotted facing phylogenies with links between tips as specified in \code{assoc}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{cophyloplot}}, \code{\link{plotSimmap}}
+}
+\examples{
+## load data from Lopez-Vaamonde et al. (2001)
+data(wasp.trees)
+data(wasp.data)
+## create co-phylogenetic object
+wasp.cophylo<-cophylo(wasp.trees[[1]],wasp.trees[[2]],
+ assoc=wasp.data)
+## plot co-phylogenies
+plot(wasp.cophylo,link.type="curved",link.lwd=4,
+ link.lty="solid",link.col=make.transparent("red",
+ 0.25))
+par(mar=c(5.1,4.1,4.1,2.1))
+}
+\keyword{phylogenetics}
+\keyword{plotting}
+\keyword{diversification}
+\keyword{co-phylogenetics}
diff --git a/man/cospeciation.Rd b/man/cospeciation.Rd
index 27b25d5..873a17e 100644
--- a/man/cospeciation.Rd
+++ b/man/cospeciation.Rd
@@ -1,56 +1,56 @@
-\name{cospeciation}
-\alias{cospeciation}
-\alias{plot.cospeciation}
-\alias{print.cospeciation}
-\title{Conducts a statistical test of cospeciation between two trees}
-\usage{
-cospeciation(t1, t2, distance=c("RF","SPR"),
- method=c("simulation","permutation"), assoc=NULL,
- nsim=100, ...)
-\method{plot}{cospeciation}(x, ...)
-\method{print}{cospeciation}(x, ...)
-}
-\arguments{
- \item{t1}{object of class \code{"phylo"}.}
- \item{t2}{object of class \code{"phylo"}.}
- \item{distance}{distance method to compare trees.}
- \item{method}{method to use (simulation of pure-birth trees, or permutation of tip labels on a fixed tree) to obtain a null distribution of tree distances via \code{distance}.}
- \item{assoc}{matrix containing the tip labels in \code{t1} to match to the tip labels in \code{t2}. Note that not all labels in either tree need to be included; however, unlike \code{cophylo}, one label in \code{t1} cannot be matched with more than one label in \code{t2}, nor vice versa. If \code{NULL} then an exact match of tip labels will be sought.}
- \item{nsim}{number of simulations or permutations.}
- \item{x}{for \code{plot} and \code{print} methods, an object of class \code{"cospeciation"}.}
- \item{...}{optional arguments.}
-}
-\description{
- Test for cospeciation based on tree distance.
-}
-\details{
- This function conducts a test for cospeciation based on tree distance, applying a distance metric selected by the user.
-
- Note that this method should be prone to be quite liberal as the null hypothesis is \emph{no similarity whatsover} between the two trees!
-}
-\value{
- An object of class \code{"cospeciation"}, which includes the test-statistic, the null distribution, and a p-value for the test of the null hypothesis of no topological similarity between the two trees.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{cophylo}}
-}
-\examples{
-## load data from Lopez-Vaamonde et al. (2001)
-data(wasp.trees)
-data(wasp.data)
-## test for cospeciation
-wasp.cosp<-cospeciation(wasp.trees[[1]],wasp.trees[[2]],
- assoc=wasp.data)
-print(wasp.cosp)
-plot(wasp.cosp)
-title(main=paste("Simulated distribution of RF distances\n",
- "between unassociated trees"),font.main=3)
-}
-\keyword{phylogenetics}
-\keyword{plotting}
-\keyword{diversification}
-\keyword{co-phylogenetics}
+\name{cospeciation}
+\alias{cospeciation}
+\alias{plot.cospeciation}
+\alias{print.cospeciation}
+\title{Conducts a statistical test of cospeciation between two trees}
+\usage{
+cospeciation(t1, t2, distance=c("RF","SPR"),
+ method=c("simulation","permutation"), assoc=NULL,
+ nsim=100, ...)
+\method{plot}{cospeciation}(x, ...)
+\method{print}{cospeciation}(x, ...)
+}
+\arguments{
+ \item{t1}{object of class \code{"phylo"}.}
+ \item{t2}{object of class \code{"phylo"}.}
+ \item{distance}{distance method to compare trees.}
+ \item{method}{method to use (simulation of pure-birth trees, or permutation of tip labels on a fixed tree) to obtain a null distribution of tree distances via \code{distance}.}
+ \item{assoc}{matrix containing the tip labels in \code{t1} to match to the tip labels in \code{t2}. Note that not all labels in either tree need to be included; however, unlike \code{cophylo}, one label in \code{t1} cannot be matched with more than one label in \code{t2}, nor vice versa. If \code{NULL} then an exact match of tip labels will be sought.}
+ \item{nsim}{number of simulations or permutations.}
+ \item{x}{for \code{plot} and \code{print} methods, an object of class \code{"cospeciation"}.}
+ \item{...}{optional arguments.}
+}
+\description{
+ Test for cospeciation based on tree distance.
+}
+\details{
+ This function conducts a test for cospeciation based on tree distance, applying a distance metric selected by the user.
+
+ Note that this method should be prone to be quite liberal as the null hypothesis is \emph{no similarity whatsover} between the two trees!
+}
+\value{
+ An object of class \code{"cospeciation"}, which includes the test-statistic, the null distribution, and a p-value for the test of the null hypothesis of no topological similarity between the two trees.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{cophylo}}
+}
+\examples{
+## load data from Lopez-Vaamonde et al. (2001)
+data(wasp.trees)
+data(wasp.data)
+## test for cospeciation
+wasp.cosp<-cospeciation(wasp.trees[[1]],wasp.trees[[2]],
+ assoc=wasp.data)
+print(wasp.cosp)
+plot(wasp.cosp)
+title(main=paste("Simulated distribution of RF distances\n",
+ "between unassociated trees"),font.main=3)
+}
+\keyword{phylogenetics}
+\keyword{plotting}
+\keyword{diversification}
+\keyword{co-phylogenetics}
diff --git a/man/countSimmap.Rd b/man/countSimmap.Rd
index b44384e..d271a37 100644
--- a/man/countSimmap.Rd
+++ b/man/countSimmap.Rd
@@ -1,34 +1,34 @@
-\name{countSimmap}
-\alias{countSimmap}
-\title{Counts the number of character changes on a object of class "simmap" or "multiSimmap"}
-\usage{
-countSimmap(tree, states=NULL, message=TRUE)
-}
-\arguments{
- \item{tree}{an object of class \code{"simmap"} or \code{"multiSimmap"}.}
- \item{states}{optional argument with the states for the mapped character. If not provided, these will be computed from the tree. This is useful if averaging across many trees, some of which may lack certain states.}
- \item{message}{optional logical argument indicating whether or not to return an informative message about the function output.}
-}
-\description{
- Count the number of changes of different types on a stochastically mapped trees or set of trees (objects of class \code{"simmap"} or \code{"multiSimmap"}).
-}
-\details{
- This function takes a tree or a set of trees with a mapped discrete character (that is, an object of class \code{"simmap"} or \code{"multiSimmap"}), and computes the total number of character changes as well as the number of character changes between all states.
-}
-\value{
- A list with up to three elements: \code{N} is an integer value giving the total number of character changes on the tree; \code{Tr} gives the number of of transitions between row and column states (or a matrix containing both \code{N} and the transitions between states, in rows, for an object of class \code{"multiPhylo"}); and (optionally) \code{message} contains an explanatory message about the function output.
-}
-\examples{
-## load data from Revell & Collar (2009)
-data(anoletree)
-anoletree
-countSimmap(anoletree)
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{ancestral states}
-\keyword{phylogenetics}
-\keyword{utilities}
-\keyword{discrete character}
+\name{countSimmap}
+\alias{countSimmap}
+\title{Counts the number of character changes on a object of class "simmap" or "multiSimmap"}
+\usage{
+countSimmap(tree, states=NULL, message=TRUE)
+}
+\arguments{
+ \item{tree}{an object of class \code{"simmap"} or \code{"multiSimmap"}.}
+ \item{states}{optional argument with the states for the mapped character. If not provided, these will be computed from the tree. This is useful if averaging across many trees, some of which may lack certain states.}
+ \item{message}{optional logical argument indicating whether or not to return an informative message about the function output.}
+}
+\description{
+ Count the number of changes of different types on a stochastically mapped trees or set of trees (objects of class \code{"simmap"} or \code{"multiSimmap"}).
+}
+\details{
+ This function takes a tree or a set of trees with a mapped discrete character (that is, an object of class \code{"simmap"} or \code{"multiSimmap"}), and computes the total number of character changes as well as the number of character changes between all states.
+}
+\value{
+ A list with up to three elements: \code{N} is an integer value giving the total number of character changes on the tree; \code{Tr} gives the number of of transitions between row and column states (or a matrix containing both \code{N} and the transitions between states, in rows, for an object of class \code{"multiPhylo"}); and (optionally) \code{message} contains an explanatory message about the function output.
+}
+\examples{
+## load data from Revell & Collar (2009)
+data(anoletree)
+anoletree
+countSimmap(anoletree)
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{ancestral states}
+\keyword{phylogenetics}
+\keyword{utilities}
+\keyword{discrete character}
diff --git a/man/ctt.Rd b/man/ctt.Rd
index 7a14abd..7fecf69 100644
--- a/man/ctt.Rd
+++ b/man/ctt.Rd
@@ -1,41 +1,41 @@
-\name{ctt}
-\alias{ctt}
-\alias{sim.ctt}
-\alias{sim.multiCtt}
-\title{Generates (or simulates) a 'changes through time' plot from a set of stochastic map character histories}
-\usage{
-ctt(trees, segments=20, ...)
-sim.ctt(tree, Q, anc=NULL, nmaps=100, ...)
-sim.multiCtt(tree, Q, anc=NULL, nmaps=100, nsim=100, ...)
-}
-\arguments{
- \item{trees}{an object of class \code{"multiSimmap"}.}
- \item{segments}{number of segments to break up the history of the tree.}
- \item{tree}{for \code{sim.ctt}, an object of class \code{"phylo"}.}
- \item{Q}{for \code{sim.ctt}, a transition matrix to use for simulation.}
- \item{anc}{ancestral state at the root node for simulation.}
- \item{nmaps}{number of stochastic maps per simulation.}
- \item{nsim}{for \code{sim.multiCtt} only, the number of simulations to run.}
- \item{...}{optional arguments.}
-}
-\description{
- Create a 'changes through time' plot from a \code{"multiSimmap"} object.
-}
-\details{
- This function generates a 'changes through time' plot in the style of a lineage-through-time (LTT) plot. It shows the mean rate or the mean number of changes per unit time from a set of stochastic character map trees.
-}
-\value{
- An object of class \code{"ctt"} or \code{"multiCtt"}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{ltt}}
-}
-\keyword{ancestral states}
-\keyword{comparative method}
-\keyword{discrete character}
-\keyword{phylogenetics}
-\keyword{plotting}
+\name{ctt}
+\alias{ctt}
+\alias{sim.ctt}
+\alias{sim.multiCtt}
+\title{Generates (or simulates) a 'changes through time' plot from a set of stochastic map character histories}
+\usage{
+ctt(trees, segments=20, ...)
+sim.ctt(tree, Q, anc=NULL, nmaps=100, ...)
+sim.multiCtt(tree, Q, anc=NULL, nmaps=100, nsim=100, ...)
+}
+\arguments{
+ \item{trees}{an object of class \code{"multiSimmap"}.}
+ \item{segments}{number of segments to break up the history of the tree.}
+ \item{tree}{for \code{sim.ctt}, an object of class \code{"phylo"}.}
+ \item{Q}{for \code{sim.ctt}, a transition matrix to use for simulation.}
+ \item{anc}{ancestral state at the root node for simulation.}
+ \item{nmaps}{number of stochastic maps per simulation.}
+ \item{nsim}{for \code{sim.multiCtt} only, the number of simulations to run.}
+ \item{...}{optional arguments.}
+}
+\description{
+ Create a 'changes through time' plot from a \code{"multiSimmap"} object.
+}
+\details{
+ This function generates a 'changes through time' plot in the style of a lineage-through-time (LTT) plot. It shows the mean rate or the mean number of changes per unit time from a set of stochastic character map trees.
+}
+\value{
+ An object of class \code{"ctt"} or \code{"multiCtt"}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{ltt}}
+}
+\keyword{ancestral states}
+\keyword{comparative method}
+\keyword{discrete character}
+\keyword{phylogenetics}
+\keyword{plotting}
diff --git a/man/density.multiSimmap.Rd b/man/density.multiSimmap.Rd
index fe42594..6e9e529 100644
--- a/man/density.multiSimmap.Rd
+++ b/man/density.multiSimmap.Rd
@@ -1,42 +1,42 @@
-\name{density.multiSimmap}
-\alias{density.multiSimmap}
-\alias{plot.changesMap}
-\title{Computes a posterior distribution for the number and types of changes on the tree}
-\usage{
-\method{density}{multiSimmap}(x, ...)
-\method{plot}{changesMap}(x, ...)
-}
-\arguments{
- \item{x}{object of class \code{"multiSimmap"} (see \code{\link{make.simmap}}), or, in the case \code{plot.changesMap}, an object of class \code{"changesMap"} produced via a call to \code{density.multiSimmap}.}
- \item{...}{optional arguments. For \code{density.multiSimmap} these consist of \code{bw} (bandwidth) & \code{method} (\code{"changes"}, \code{"densityMap"}, or \code{"timings"}).}
-}
-\details{
- \code{density.multiSimmap} \code{method="changes"} (the default) results in a posterior distribution of the number & types of changes on the tree.
-
- If the package \pkg{coda} has been installed, then the function \code{HPD.interval} is used to compute a 95\% high probability density interval for the number of changes of each type on the tree. Otherwise, the central 95\% of the posterior sample is returned as an estimate of the 95\% HPD interval for each change type.
-
- The method also computes the full posterior density for each change type using a bandwidth specified by the user.
-
- \code{method="densityMap"} computes a standard \code{"\link{densityMap}"} object, and thus only permits binary characters.
-
- \code{plot.changesMap} plots the posterior density returned by \code{density.multiSimmap} for \code{method=} \code{"changes"}.
-}
-\description{
- S3 methods to summarize the results of one or more stochastic maps.
-}
-\value{
- For \code{method="changes"} \code{density.multiSimmap} returns an object of class \code{"changesMap"}.
-
- For \code{method="densityMap"} \code{density.multiSimmap} returns an object of class \code{"\link{densityMap}"}.
-
- \code{plot.changesMap} generates a plot.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{ancestral states}
-\keyword{comparative method}
-\keyword{phylogenetics}
-\keyword{utilities}
-\keyword{discrete character}
+\name{density.multiSimmap}
+\alias{density.multiSimmap}
+\alias{plot.changesMap}
+\title{Computes a posterior distribution for the number and types of changes on the tree}
+\usage{
+\method{density}{multiSimmap}(x, ...)
+\method{plot}{changesMap}(x, ...)
+}
+\arguments{
+ \item{x}{object of class \code{"multiSimmap"} (see \code{\link{make.simmap}}), or, in the case \code{plot.changesMap}, an object of class \code{"changesMap"} produced via a call to \code{density.multiSimmap}.}
+ \item{...}{optional arguments. For \code{density.multiSimmap} these consist of \code{bw} (bandwidth) & \code{method} (\code{"changes"}, \code{"densityMap"}, or \code{"timings"}).}
+}
+\details{
+ \code{density.multiSimmap} \code{method="changes"} (the default) results in a posterior distribution of the number & types of changes on the tree.
+
+ If the package \pkg{coda} has been installed, then the function \code{HPD.interval} is used to compute a 95\% high probability density interval for the number of changes of each type on the tree. Otherwise, the central 95\% of the posterior sample is returned as an estimate of the 95\% HPD interval for each change type.
+
+ The method also computes the full posterior density for each change type using a bandwidth specified by the user.
+
+ \code{method="densityMap"} computes a standard \code{"\link{densityMap}"} object, and thus only permits binary characters.
+
+ \code{plot.changesMap} plots the posterior density returned by \code{density.multiSimmap} for \code{method=} \code{"changes"}.
+}
+\description{
+ S3 methods to summarize the results of one or more stochastic maps.
+}
+\value{
+ For \code{method="changes"} \code{density.multiSimmap} returns an object of class \code{"changesMap"}.
+
+ For \code{method="densityMap"} \code{density.multiSimmap} returns an object of class \code{"\link{densityMap}"}.
+
+ \code{plot.changesMap} generates a plot.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{ancestral states}
+\keyword{comparative method}
+\keyword{phylogenetics}
+\keyword{utilities}
+\keyword{discrete character}
diff --git a/man/densityMap.Rd b/man/densityMap.Rd
index f7d4c71..770bf3b 100644
--- a/man/densityMap.Rd
+++ b/man/densityMap.Rd
@@ -1,70 +1,70 @@
-\name{densityMap}
-\alias{densityMap}
-\alias{plot.densityMap}
-\title{Plot posterior density of stochastic mapping on a tree}
-\usage{
-densityMap(trees, res=100, fsize=NULL, ftype=NULL, lwd=3, check=FALSE,
- legend=NULL, outline=FALSE, type="phylogram", direction="rightwards",
- plot=TRUE, ...)
-\method{plot}{densityMap}(x, ...)
-}
-\arguments{
- \item{trees}{set of phylogenetic trees in a modified \code{"multiPhylo"} object. Values for a two-state discrete character are mapped on the tree. See \code{\link{make.simmap}} and \code{\link{read.simmap}} for details.}
- \item{res}{resolution for gradient plotting. Larger numbers indicate a finer (smoother) gradient.}
- \item{fsize}{relative font size - can be a vector with the second element giving the font size for the legend.}
- \item{ftype}{font type - see options in \code{\link{plotSimmap}}. As with \code{fsize}, can be a vector with the second element giving font type for the legend.}
- \item{lwd}{line width for branches. If a vector of two elements is supplied, the second element will be taken to be the desired width of the legend bar.}
- \item{check}{check to make sure that the topology and branch lengths of all phylogenies in \code{trees} are equal.}
- \item{legend}{if \code{FALSE} no legend is plotted; if a numeric value, it gives the length of the legend in units of branch length. Default is 0.5 times the total tree length.}
- \item{outline}{logical value indicating whether or not to outline the branches of the tree in black.}
- \item{type}{type of plot desired. Options are \code{"phylogram"} for a rightward square phylogram; and \code{"fan"} for a circular phylogram.}
- \item{plot}{logical value indicating whether or not to plot the tree. If \code{plot=FALSE} then an object of class \code{"densityMap"} will be returned without plotting.}
- \item{direction}{plotting direction for \code{type="phylogram"}.}
- \item{x}{for \code{plot.densityMap}, an object of class \code{"densityMap"}.}
- \item{...}{optional arguments for \code{plot.densityMap}. These include all the arguments of \code{densityMap} except \code{trees} and \code{res}. Additional optional arguments include \code{mar} (margins), \code{offset} (tip label offset: in units of the edge length or character widths, as in \code{\link{plotSimmap}}), and \code{hold} (whether or not to use \code{dev.hold} to hold output to graphical device before plotting; defaults to \code{hold=TRUE}). Also, the argument \code{states} can be used to 'order' the states on the probability axis (that is, which state should correspond to a posterior probability of 0 or 1). Some other plotting arguments, such as \code{xlim} and \code{ylim}, may also work.}
-}
-\description{
- Visualize posterior probability density from stochastic mapping using a color gradient on the tree.
-}
-\details{
- Function plots a tree with the posterior density for a mapped character from stochastic character mapping on the tree. Since the mapped value is the probability of being in state "1", only binary [0,1] characters are allowed.
-}
-\value{
- Plots a tree and returns an object of class \code{"densityMap"} invisibly.
-}
-\references{
- Bollback, J. P. 2006. Stochastic character mapping of discrete traits on phylogenies. \emph{BMC Bioinformatics}, \bold{7}, 88.
-
- Huelsenbeck, J. P., R. Neilsen, and J. P. Bollback. 2003. Stochastic mapping of morphological characters. \emph{Systematic Biology}, \bold{52}, 131-138.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-
- Revell, L. J. 2013. Two new graphical methods for mapping trait evolution on phylogenies. \emph{Methods in Ecology and Evolution}, \bold{4}, 754-759.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{make.simmap}}, \code{\link{plotSimmap}}, \code{\link{read.simmap}}
-}
-\examples{
-\dontrun{
-## load tree and data from Revell & Collar (2009)
-data(sunfish.tree)
-data(sunfish.data)
-## extract discrete character (feeding mode)
-fmode<-setNames(sunfish.data$feeding.mode,
- rownames(sunfish.data))
-## do stochastic mapping
-smap.trees<-make.simmap(sunfish.tree,fmode,model="ER",
- nsim=100)
-## compute "densityMap" object
-sunfish.dmap<-densityMap(smap.trees,plot=FALSE,
- res=50) ## res should be higher
-## plot density map
-plot(sunfish.dmap,lwd=5,outline=TRUE)
-par(mar=c(5.1,4.1,4.1,2.1)) ## reset margins to default}
-}
-\keyword{ancestral states}
-\keyword{phylogenetics}
-\keyword{plotting}
-\keyword{comparative method}
-\keyword{discrete character}
+\name{densityMap}
+\alias{densityMap}
+\alias{plot.densityMap}
+\title{Plot posterior density of stochastic mapping on a tree}
+\usage{
+densityMap(trees, res=100, fsize=NULL, ftype=NULL, lwd=3, check=FALSE,
+ legend=NULL, outline=FALSE, type="phylogram", direction="rightwards",
+ plot=TRUE, ...)
+\method{plot}{densityMap}(x, ...)
+}
+\arguments{
+ \item{trees}{set of phylogenetic trees in a modified \code{"multiPhylo"} object. Values for a two-state discrete character are mapped on the tree. See \code{\link{make.simmap}} and \code{\link{read.simmap}} for details.}
+ \item{res}{resolution for gradient plotting. Larger numbers indicate a finer (smoother) gradient.}
+ \item{fsize}{relative font size - can be a vector with the second element giving the font size for the legend.}
+ \item{ftype}{font type - see options in \code{\link{plotSimmap}}. As with \code{fsize}, can be a vector with the second element giving font type for the legend.}
+ \item{lwd}{line width for branches. If a vector of two elements is supplied, the second element will be taken to be the desired width of the legend bar.}
+ \item{check}{check to make sure that the topology and branch lengths of all phylogenies in \code{trees} are equal.}
+ \item{legend}{if \code{FALSE} no legend is plotted; if a numeric value, it gives the length of the legend in units of branch length. Default is 0.5 times the total tree length.}
+ \item{outline}{logical value indicating whether or not to outline the branches of the tree in black.}
+ \item{type}{type of plot desired. Options are \code{"phylogram"} for a rightward square phylogram; and \code{"fan"} for a circular phylogram.}
+ \item{plot}{logical value indicating whether or not to plot the tree. If \code{plot=FALSE} then an object of class \code{"densityMap"} will be returned without plotting.}
+ \item{direction}{plotting direction for \code{type="phylogram"}.}
+ \item{x}{for \code{plot.densityMap}, an object of class \code{"densityMap"}.}
+ \item{...}{optional arguments for \code{plot.densityMap}. These include all the arguments of \code{densityMap} except \code{trees} and \code{res}. Additional optional arguments include \code{mar} (margins), \code{offset} (tip label offset: in units of the edge length or character widths, as in \code{\link{plotSimmap}}), and \code{hold} (whether or not to use \code{dev.hold} to hold output to graphical device before plotting; defaults to \code{hold=TRUE}). Also, the argument \code{states} can be used to 'order' the states on the probability axis (that is, which state should correspond to a posterior probability of 0 or 1). Some other plotting arguments, such as \code{xlim} and \code{ylim}, may also work.}
+}
+\description{
+ Visualize posterior probability density from stochastic mapping using a color gradient on the tree.
+}
+\details{
+ Function plots a tree with the posterior density for a mapped character from stochastic character mapping on the tree. Since the mapped value is the probability of being in state "1", only binary [0,1] characters are allowed.
+}
+\value{
+ Plots a tree and returns an object of class \code{"densityMap"} invisibly.
+}
+\references{
+ Bollback, J. P. 2006. Stochastic character mapping of discrete traits on phylogenies. \emph{BMC Bioinformatics}, \bold{7}, 88.
+
+ Huelsenbeck, J. P., R. Neilsen, and J. P. Bollback. 2003. Stochastic mapping of morphological characters. \emph{Systematic Biology}, \bold{52}, 131-138.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+
+ Revell, L. J. 2013. Two new graphical methods for mapping trait evolution on phylogenies. \emph{Methods in Ecology and Evolution}, \bold{4}, 754-759.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{make.simmap}}, \code{\link{plotSimmap}}, \code{\link{read.simmap}}
+}
+\examples{
+\dontrun{
+## load tree and data from Revell & Collar (2009)
+data(sunfish.tree)
+data(sunfish.data)
+## extract discrete character (feeding mode)
+fmode<-setNames(sunfish.data$feeding.mode,
+ rownames(sunfish.data))
+## do stochastic mapping
+smap.trees<-make.simmap(sunfish.tree,fmode,model="ER",
+ nsim=100)
+## compute "densityMap" object
+sunfish.dmap<-densityMap(smap.trees,plot=FALSE,
+ res=50) ## res should be higher
+## plot density map
+plot(sunfish.dmap,lwd=5,outline=TRUE)
+par(mar=c(5.1,4.1,4.1,2.1)) ## reset margins to default}
+}
+\keyword{ancestral states}
+\keyword{phylogenetics}
+\keyword{plotting}
+\keyword{comparative method}
+\keyword{discrete character}
diff --git a/man/densityTree.Rd b/man/densityTree.Rd
index 242b316..aaa1c2b 100644
--- a/man/densityTree.Rd
+++ b/man/densityTree.Rd
@@ -1,37 +1,37 @@
-\name{densityTree}
-\alias{densityTree}
-\alias{make.transparent}
-\title{Plots a posterior sample of trees}
-\usage{
-densityTree(trees, colors="blue", alpha=NULL, method="plotTree",
- fix.depth=FALSE, use.edge.length=TRUE, compute.consensus=TRUE,
- use.gradient=FALSE, show.axis=TRUE, ...)
-make.transparent(color, alpha)
-}
-\arguments{
- \item{trees}{an object of class \code{"multiPhylo"} or \code{"multiSimmap"}.}
- \item{colors}{a color or a named vector of colors in which names correspond to mapped states in an object of class \code{"multiSimmap"}.}
- \item{alpha}{transparency level for plotted trees which is passed to internally used function, \code{make.transparent}. (\code{0} is fully transparent, which \code{1} is fully opaque.) By default will be one divided by the number of trees.}
- \item{method}{plotting method to be used internally. Can be \code{"plotTree"} or \code{"plotSimmap"}.}
- \item{fix.depth}{logical value indicating whether or not to plot trees with a fixed depth or to permit plotted trees to have different depths.}
- \item{use.edge.length}{logical value indicating whether to use the edge lengths of the input tree. Defaults to \code{use.edge.length=TRUE} unless any input tree edge lengths are \code{NULL}.}
- \item{compute.consensus}{logical value indicating whether or not to use the tip order from a consensus tree. (Defaults to \code{compute.consensus=TRUE} Defaulted to \code{FALSE} in earlier version of this function.)}
- \item{use.gradient}{logical value indicating whether to plot all trees slightly offset using a rainbow color gradient. (Defaults to \code{use.gradient=FALSE}.)}
- \item{show.axis}{logical value indicating whether or not to include a horizontal axis in the plot.}
- \item{...}{arguments to be passed to \code{plotTree} or \code{plotSimmap}. Some may be ignored if they are incompatible with the method.}
- \item{color}{in \code{make.transparent}, the color (or colors in a vector) to render transparent.}
-}
-\description{
- Functions plots a posterior sample of trees, including with mapped discrete characters.
-
- \code{make.transparent} is used internally and converts a color to transparent with a certain user-specified \code{alpha} level.
-}
-\value{
- Function creates a plot.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{phylogenetics}
-\keyword{plotting}
+\name{densityTree}
+\alias{densityTree}
+\alias{make.transparent}
+\title{Plots a posterior sample of trees}
+\usage{
+densityTree(trees, colors="blue", alpha=NULL, method="plotTree",
+ fix.depth=FALSE, use.edge.length=TRUE, compute.consensus=TRUE,
+ use.gradient=FALSE, show.axis=TRUE, ...)
+make.transparent(color, alpha)
+}
+\arguments{
+ \item{trees}{an object of class \code{"multiPhylo"} or \code{"multiSimmap"}.}
+ \item{colors}{a color or a named vector of colors in which names correspond to mapped states in an object of class \code{"multiSimmap"}.}
+ \item{alpha}{transparency level for plotted trees which is passed to internally used function, \code{make.transparent}. (\code{0} is fully transparent, which \code{1} is fully opaque.) By default will be one divided by the number of trees.}
+ \item{method}{plotting method to be used internally. Can be \code{"plotTree"} or \code{"plotSimmap"}.}
+ \item{fix.depth}{logical value indicating whether or not to plot trees with a fixed depth or to permit plotted trees to have different depths.}
+ \item{use.edge.length}{logical value indicating whether to use the edge lengths of the input tree. Defaults to \code{use.edge.length=TRUE} unless any input tree edge lengths are \code{NULL}.}
+ \item{compute.consensus}{logical value indicating whether or not to use the tip order from a consensus tree. (Defaults to \code{compute.consensus=TRUE} Defaulted to \code{FALSE} in earlier version of this function.)}
+ \item{use.gradient}{logical value indicating whether to plot all trees slightly offset using a rainbow color gradient. (Defaults to \code{use.gradient=FALSE}.)}
+ \item{show.axis}{logical value indicating whether or not to include a horizontal axis in the plot.}
+ \item{...}{arguments to be passed to \code{plotTree} or \code{plotSimmap}. Some may be ignored if they are incompatible with the method.}
+ \item{color}{in \code{make.transparent}, the color (or colors in a vector) to render transparent.}
+}
+\description{
+ Functions plots a posterior sample of trees, including with mapped discrete characters.
+
+ \code{make.transparent} is used internally and converts a color to transparent with a certain user-specified \code{alpha} level.
+}
+\value{
+ Function creates a plot.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{phylogenetics}
+\keyword{plotting}
diff --git a/man/describe.simmap.Rd b/man/describe.simmap.Rd
index 3edc5b6..936e714 100644
--- a/man/describe.simmap.Rd
+++ b/man/describe.simmap.Rd
@@ -1,38 +1,38 @@
-\name{describe.simmap}
-\alias{describe.simmap}
-\alias{summary.simmap}
-\alias{summary.multiSimmap}
-\alias{plot.describe.simmap}
-\title{Summarizes a stochastic mapped tree or set of trees}
-\usage{
-describe.simmap(tree, ...)
-\method{summary}{simmap}(object, ...)
-\method{summary}{multiSimmap}(object, ...)
-\method{plot}{describe.simmap}(x, ...)
-}
-\arguments{
- \item{tree}{a single tree or a set of trees as an object of class \code{"simmap"} or \code{"multiSimmap"}, respectively.}
- \item{object}{object of class \code{"simmap"} or \code{"multiSimmap"}.}
- \item{x}{for S3 \code{plot} method, an object of class \code{"describe.simmap"}.}
- \item{...}{optional arguments which include: \code{plot}, a logical value indicating whether or not to plot the posterior probabilities at nodes (default is \code{plot=FALSE}); \code{check.equal}, a logical value indicating whether or not to check if all trees are equal using \code{\link{all.equal.phylo}} (default is \code{check.equal=FALSE}); and \code{message}, a logical indicating whether or not to print an informative message to the screen (default is \code{message=TRUE}).}
-}
-\description{
- Summarizes the result of one or more stochastic maps.
-}
-\value{
- An object of class \code{"describe.simmap"} with the following elements:
- \item{count}{a matrix containing the number and types of transitions for each tree, if \code{tree} is an object of class \code{"multiSimmap"}.}
- \item{times}{a matrix containg the times spend in each state on each tree.}
- \item{ace}{the posterior probabilities of each node being in each state, if \code{tree} is an object of class \code{"multiSimmap"}.}
- \item{legend}{a vector containing the plot legend, if \code{plot=TRUE}.}
- if \code{class(tree)="simmap"} then the function simply returns the results of \code{\link{countSimmap}} combined with the states at each node of the tree and a matrix containing the total and relative times spent in each state on the tree.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{ancestral states}
-\keyword{comparative method}
-\keyword{phylogenetics}
-\keyword{utilities}
-\keyword{discrete character}
+\name{describe.simmap}
+\alias{describe.simmap}
+\alias{summary.simmap}
+\alias{summary.multiSimmap}
+\alias{plot.describe.simmap}
+\title{Summarizes a stochastic mapped tree or set of trees}
+\usage{
+describe.simmap(tree, ...)
+\method{summary}{simmap}(object, ...)
+\method{summary}{multiSimmap}(object, ...)
+\method{plot}{describe.simmap}(x, ...)
+}
+\arguments{
+ \item{tree}{a single tree or a set of trees as an object of class \code{"simmap"} or \code{"multiSimmap"}, respectively.}
+ \item{object}{object of class \code{"simmap"} or \code{"multiSimmap"}.}
+ \item{x}{for S3 \code{plot} method, an object of class \code{"describe.simmap"}.}
+ \item{...}{optional arguments which include: \code{plot}, a logical value indicating whether or not to plot the posterior probabilities at nodes (default is \code{plot=FALSE}); \code{check.equal}, a logical value indicating whether or not to check if all trees are equal using \code{\link{all.equal.phylo}} (default is \code{check.equal=FALSE}); and \code{message}, a logical indicating whether or not to print an informative message to the screen (default is \code{message=TRUE}).}
+}
+\description{
+ Summarizes the result of one or more stochastic maps.
+}
+\value{
+ An object of class \code{"describe.simmap"} with the following elements:
+ \item{count}{a matrix containing the number and types of transitions for each tree, if \code{tree} is an object of class \code{"multiSimmap"}.}
+ \item{times}{a matrix containg the times spend in each state on each tree.}
+ \item{ace}{the posterior probabilities of each node being in each state, if \code{tree} is an object of class \code{"multiSimmap"}.}
+ \item{legend}{a vector containing the plot legend, if \code{plot=TRUE}.}
+ if \code{class(tree)="simmap"} then the function simply returns the results of \code{\link{countSimmap}} combined with the states at each node of the tree and a matrix containing the total and relative times spent in each state on the tree.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{ancestral states}
+\keyword{comparative method}
+\keyword{phylogenetics}
+\keyword{utilities}
+\keyword{discrete character}
diff --git a/man/di2multi.simmap.Rd b/man/di2multi.simmap.Rd
index d970510..6858b71 100644
--- a/man/di2multi.simmap.Rd
+++ b/man/di2multi.simmap.Rd
@@ -1,47 +1,47 @@
-\name{di2multi.simmap}
-\alias{di2multi.simmap}
-\alias{multi2di.simmap}
-\alias{di2multi.multiSimmap}
-\alias{multi2di.multiSimmap}
-\alias{di2multi.contMap}
-\alias{multi2di.contMap}
-\alias{di2multi.densityMap}
-\alias{multi2di.densityMap}
-\title{Collapse or resolve polytomies in a tree with a character painted on the edges}
-\usage{
-\method{di2multi}{simmap}(phy, ...)
-\method{multi2di}{simmap}(phy, ...)
-\method{di2multi}{multiSimmap}(phy, ...)
-\method{multi2di}{multiSimmap}(phy, ...)
-\method{di2multi}{contMap}(phy, ...)
-\method{multi2di}{contMap}(phy, ...)
-\method{di2multi}{densityMap}(phy, ...)
-\method{multi2di}{densityMap}(phy, ...)
-}
-\arguments{
- \item{phy}{object of class \code{"simmap"}, \code{"multiSimmap"}, \code{"contMap"}, or \code{"densityMap"} containing a character mapped onto the edges of a tree or set of trees.}
- \item{...}{optional arguments: \code{tol}, length below which edges should be treated as having zero length; and \code{random}, specifying whether to resolve polytomies randomly (if \code{TRUE}) or in the order in which they are encountered.}
-}
-\description{
- Collapses or resolves polytomies in special types of phylogenetic trees. (See \code{\link{di2multi}} and \code{\link{multi2di}}.)
-}
-\details{
- The method \code{di2multi} collapses branches of zero length (or, more specifically, branches with length shorter than \code{tol}) to create a polytomy in a tree or set of trees.
-
- The method \code{multi2di} resolves polytomies by adding branches of zero length (while preserving the mappings) in a tree or set of trees.
-
- This methods should theoretically behave similarly to \code{\link{di2multi}} and \code{\link{multi2di}} from the \pkg{ape} package.
-}
-\value{
- An object of class \code{"simmap"}, \code{"multiSimmap"}, \code{"contMap"}, or \code{"densityMap"}, depending on the class of \code{phy}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{contMap}}, \code{\link{densityMap}}, \code{\link{di2multi}}, \code{\link{make.simmap}}, \code{\link{multi2di}}, \code{\link{read.simmap}}
-}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{utilities}
+\name{di2multi.simmap}
+\alias{di2multi.simmap}
+\alias{multi2di.simmap}
+\alias{di2multi.multiSimmap}
+\alias{multi2di.multiSimmap}
+\alias{di2multi.contMap}
+\alias{multi2di.contMap}
+\alias{di2multi.densityMap}
+\alias{multi2di.densityMap}
+\title{Collapse or resolve polytomies in a tree with a character painted on the edges}
+\usage{
+\method{di2multi}{simmap}(phy, ...)
+\method{multi2di}{simmap}(phy, ...)
+\method{di2multi}{multiSimmap}(phy, ...)
+\method{multi2di}{multiSimmap}(phy, ...)
+\method{di2multi}{contMap}(phy, ...)
+\method{multi2di}{contMap}(phy, ...)
+\method{di2multi}{densityMap}(phy, ...)
+\method{multi2di}{densityMap}(phy, ...)
+}
+\arguments{
+ \item{phy}{object of class \code{"simmap"}, \code{"multiSimmap"}, \code{"contMap"}, or \code{"densityMap"} containing a character mapped onto the edges of a tree or set of trees.}
+ \item{...}{optional arguments: \code{tol}, length below which edges should be treated as having zero length; and \code{random}, specifying whether to resolve polytomies randomly (if \code{TRUE}) or in the order in which they are encountered.}
+}
+\description{
+ Collapses or resolves polytomies in special types of phylogenetic trees. (See \code{\link{di2multi}} and \code{\link{multi2di}}.)
+}
+\details{
+ The method \code{di2multi} collapses branches of zero length (or, more specifically, branches with length shorter than \code{tol}) to create a polytomy in a tree or set of trees.
+
+ The method \code{multi2di} resolves polytomies by adding branches of zero length (while preserving the mappings) in a tree or set of trees.
+
+ This methods should theoretically behave similarly to \code{\link{di2multi}} and \code{\link{multi2di}} from the \pkg{ape} package.
+}
+\value{
+ An object of class \code{"simmap"}, \code{"multiSimmap"}, \code{"contMap"}, or \code{"densityMap"}, depending on the class of \code{phy}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{contMap}}, \code{\link{densityMap}}, \code{\link{di2multi}}, \code{\link{make.simmap}}, \code{\link{multi2di}}, \code{\link{read.simmap}}
+}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{utilities}
diff --git a/man/dotTree.Rd b/man/dotTree.Rd
index ab09ab0..635e95a 100644
--- a/man/dotTree.Rd
+++ b/man/dotTree.Rd
@@ -1,48 +1,48 @@
-\name{dotTree}
-\alias{dotTree}
-\alias{dot.legend}
-\title{Creates a phylogenetic dot plot}
-\usage{
-dotTree(tree, x, legend=TRUE, method="plotTree", standardize=FALSE, ...)
-dot.legend(x, y, min, max, Ntip, length=5, prompt=FALSE, method="plotTree",
- ...)
-}
-\arguments{
- \item{tree}{an object of class \code{"phylo"}.}
- \item{x}{vector of trait values; or a matrix. If \code{x} is a vector it must have names that correspond to the tip labels of \code{tree}. If \code{x} is a matrix (and it probably should be a \emph{matrix}, not a data frame) then the row names of the matrix should correspond to the tip labels of the phylogeny. In the case of \code{dot.legend}, the \emph{x} coordinate of the legend.}
- \item{legend}{logical value indicating whether or not a legend should be plotted.}
- \item{method}{tree plotting method to be used internally. Will switch to \code{method="phylogram"} if the number of traits is greater than one. For \code{dot.legend}, it should be the method that was used for the plot.}
- \item{standardize}{a logical value indicating whether or not to standardize \code{x}, or each column of \code{x}, to have a mean of zero & variance of one prior to analysis.}
- \item{y}{\emph{y} coordinate of the legend.}
- \item{min}{minimum value for \code{dot.legend}.}
- \item{max}{maximum value for \code{dot.legend}.}
- \item{Ntip}{number of tips in the plotted tree for \code{dot.legend}.}
- \item{length}{length of legend.}
- \item{prompt}{logical value indicating whether or not to prompt for legend position.}
- \item{...}{optional arguments. In the case of \code{dotTree}, these will be passed to \code{\link{plotTree}} or a different internally used plotting function for \code{method="phylogram"}. See \code{\link{phylo.heatmap}} for more detail on these arguments. Other option for \code{dotTree} also include \code{data.type} (\code{"continuous"} or \code{"discrete"}), \code{colors}, \code{length}, for data type \code{"continuous"} the length of the legend in terms of plotted circles, \code{x.space}, the spacing of the columns in the plotted data matrix, and \code{leg.space}, the spacing of the legend dots (again, for \code{data.type="continuous"} only).}
-}
-\description{
- Creates a plot in which different sized dots/circles represent different tip values for a quantitative trait.
-}
-\value{
- Function creates a plot.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\examples{
-## load data from Garland et al. (1992)
-data(mammal.tree)
-data(mammal.data)
-## log-transform trait data
-log.mammal<-log(mammal.data)
-## plot dotTree
-dotTree(mammal.tree,log.mammal,fsize=0.7,
- standardize=TRUE,length=10)
-par(mar=c(5.1,4.1,4.1,2.1)) ## reset margins to default
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{phylogenetics}
-\keyword{plotting}
-\keyword{continuous character}
-\keyword{discrete character}
+\name{dotTree}
+\alias{dotTree}
+\alias{dot.legend}
+\title{Creates a phylogenetic dot plot}
+\usage{
+dotTree(tree, x, legend=TRUE, method="plotTree", standardize=FALSE, ...)
+dot.legend(x, y, min, max, Ntip, length=5, prompt=FALSE, method="plotTree",
+ ...)
+}
+\arguments{
+ \item{tree}{an object of class \code{"phylo"}.}
+ \item{x}{vector of trait values; or a matrix. If \code{x} is a vector it must have names that correspond to the tip labels of \code{tree}. If \code{x} is a matrix (and it probably should be a \emph{matrix}, not a data frame) then the row names of the matrix should correspond to the tip labels of the phylogeny. In the case of \code{dot.legend}, the \emph{x} coordinate of the legend.}
+ \item{legend}{logical value indicating whether or not a legend should be plotted.}
+ \item{method}{tree plotting method to be used internally. Will switch to \code{method="phylogram"} if the number of traits is greater than one. For \code{dot.legend}, it should be the method that was used for the plot.}
+ \item{standardize}{a logical value indicating whether or not to standardize \code{x}, or each column of \code{x}, to have a mean of zero & variance of one prior to analysis.}
+ \item{y}{\emph{y} coordinate of the legend.}
+ \item{min}{minimum value for \code{dot.legend}.}
+ \item{max}{maximum value for \code{dot.legend}.}
+ \item{Ntip}{number of tips in the plotted tree for \code{dot.legend}.}
+ \item{length}{length of legend.}
+ \item{prompt}{logical value indicating whether or not to prompt for legend position.}
+ \item{...}{optional arguments. In the case of \code{dotTree}, these will be passed to \code{\link{plotTree}} or a different internally used plotting function for \code{method="phylogram"}. See \code{\link{phylo.heatmap}} for more detail on these arguments. Other option for \code{dotTree} also include \code{data.type} (\code{"continuous"} or \code{"discrete"}), \code{colors}, \code{length}, for data type \code{"continuous"} the length of the legend in terms of plotted circles, \code{x.space}, the spacing of the columns in the plotted data matrix, and \code{leg.space}, the spacing of the legend dots (again, for \code{data.type="continuous"} only).}
+}
+\description{
+ Creates a plot in which different sized dots/circles represent different tip values for a quantitative trait.
+}
+\value{
+ Function creates a plot.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\examples{
+## load data from Garland et al. (1992)
+data(mammal.tree)
+data(mammal.data)
+## log-transform trait data
+log.mammal<-log(mammal.data)
+## plot dotTree
+dotTree(mammal.tree,log.mammal,fsize=0.7,
+ standardize=TRUE,length=10)
+par(mar=c(5.1,4.1,4.1,2.1)) ## reset margins to default
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{phylogenetics}
+\keyword{plotting}
+\keyword{continuous character}
+\keyword{discrete character}
diff --git a/man/drop.clade.Rd b/man/drop.clade.Rd
index 83da1fb..64f7617 100644
--- a/man/drop.clade.Rd
+++ b/man/drop.clade.Rd
@@ -1,27 +1,27 @@
-\name{drop.clade}
-\alias{drop.clade}
-\title{Drop a clade from a tree}
-\usage{
-drop.clade(tree, tip)
-}
-\arguments{
- \item{tree}{object of class \code{"phylo"}.}
- \item{tip}{set of tips in a clade.}
-}
-\description{
- Internal function for \code{\link{posterior.evolrate}}.
-}
-\details{
- Function drops the clade containing the species in \code{tip}.
-
- Probably should not use unless you know what you're doing.
-}
-\value{
- An object of class \code{"phylo"}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{phylogenetics}
-\keyword{utilities}
+\name{drop.clade}
+\alias{drop.clade}
+\title{Drop a clade from a tree}
+\usage{
+drop.clade(tree, tip)
+}
+\arguments{
+ \item{tree}{object of class \code{"phylo"}.}
+ \item{tip}{set of tips in a clade.}
+}
+\description{
+ Internal function for \code{\link{posterior.evolrate}}.
+}
+\details{
+ Function drops the clade containing the species in \code{tip}.
+
+ Probably should not use unless you know what you're doing.
+}
+\value{
+ An object of class \code{"phylo"}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{phylogenetics}
+\keyword{utilities}
diff --git a/man/drop.leaves.Rd b/man/drop.leaves.Rd
index c1b08df..39bf4a3 100644
--- a/man/drop.leaves.Rd
+++ b/man/drop.leaves.Rd
@@ -1,22 +1,22 @@
-\name{drop.leaves}
-\alias{drop.leaves}
-\title{Drop all the leaves (tips) from a tree}
-\usage{
-drop.leaves(tree, ...)
-}
-\arguments{
- \item{tree}{object of class \code{"phylo"}.}
- \item{...}{optional arguments. Presently includes only the logical value \code{keep.tip.labels} which tells the function how to labels the tips on the reduced tree.}
-}
-\description{
- Drops all the leaves from a tree, leaving behind only the structure leading to internal nodes.
-}
-\value{
- An object of class \code{"phylo"}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{phylogenetics}
-\keyword{utilities}
+\name{drop.leaves}
+\alias{drop.leaves}
+\title{Drop all the leaves (tips) from a tree}
+\usage{
+drop.leaves(tree, ...)
+}
+\arguments{
+ \item{tree}{object of class \code{"phylo"}.}
+ \item{...}{optional arguments. Presently includes only the logical value \code{keep.tip.labels} which tells the function how to labels the tips on the reduced tree.}
+}
+\description{
+ Drops all the leaves from a tree, leaving behind only the structure leading to internal nodes.
+}
+\value{
+ An object of class \code{"phylo"}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{phylogenetics}
+\keyword{utilities}
diff --git a/man/drop.tip.contMap.Rd b/man/drop.tip.contMap.Rd
index d4418a4..c8ac7a3 100644
--- a/man/drop.tip.contMap.Rd
+++ b/man/drop.tip.contMap.Rd
@@ -1,37 +1,37 @@
-\name{drop.tip.contMap}
-\alias{drop.tip.contMap}
-\alias{drop.tip.densityMap}
-\alias{keep.tip.contMap}
-\alias{keep.tip.densityMap}
-\title{Drop tip or tips from an object of class "contMap" or "densityMap"}
-\usage{
-\method{drop.tip}{contMap}(phy, tip, ...)
-\method{drop.tip}{densityMap}(phy, tip, ...)
-\method{keep.tip}{contMap}(phy, tip, ...)
-\method{keep.tip}{densityMap}(phy, tip, ...)
-}
-\arguments{
- \item{phy}{an object of class \code{"contMap"} or \code{"densityMap"}.}
- \item{tip}{name or names of species to be dropped or kept.}
- \item{...}{optional arguments to be passed to \code{\link{drop.tip.simmap}}.}
-}
-\description{
- Drops one or multiple tips from an object of class \code{"contMap"} or \code{"densityMap"}.
-}
-\details{
- These functions are equivalent to \code{\link{drop.tip}} and \code{\link{keep.tip}} in the \pkg{ape} package, but for objects of class \code{"contMap"} and \code{"densityMap"}.
-
- For more information about objects of class \code{"contMap"} or \code{"densityMap"}, please refer to the documentation pages for \code{\link{contMap}} or \code{\link{densityMap}}, respectively.
-}
-\value{
- An object of class \code{"contMap"} or \code{"densityMap"}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{contMap}}, \code{\link{densityMap}}, \code{\link{drop.tip}}, \code{\link{drop.tip.simmap}}, \code{\link{keep.tip}}
-}
-\keyword{phylogenetics}
-\keyword{utilities}
+\name{drop.tip.contMap}
+\alias{drop.tip.contMap}
+\alias{drop.tip.densityMap}
+\alias{keep.tip.contMap}
+\alias{keep.tip.densityMap}
+\title{Drop tip or tips from an object of class "contMap" or "densityMap"}
+\usage{
+\method{drop.tip}{contMap}(phy, tip, ...)
+\method{drop.tip}{densityMap}(phy, tip, ...)
+\method{keep.tip}{contMap}(phy, tip, ...)
+\method{keep.tip}{densityMap}(phy, tip, ...)
+}
+\arguments{
+ \item{phy}{an object of class \code{"contMap"} or \code{"densityMap"}.}
+ \item{tip}{name or names of species to be dropped or kept.}
+ \item{...}{optional arguments to be passed to \code{\link{drop.tip.simmap}}.}
+}
+\description{
+ Drops one or multiple tips from an object of class \code{"contMap"} or \code{"densityMap"}.
+}
+\details{
+ These functions are equivalent to \code{\link{drop.tip}} and \code{\link{keep.tip}} in the \pkg{ape} package, but for objects of class \code{"contMap"} and \code{"densityMap"}.
+
+ For more information about objects of class \code{"contMap"} or \code{"densityMap"}, please refer to the documentation pages for \code{\link{contMap}} or \code{\link{densityMap}}, respectively.
+}
+\value{
+ An object of class \code{"contMap"} or \code{"densityMap"}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{contMap}}, \code{\link{densityMap}}, \code{\link{drop.tip}}, \code{\link{drop.tip.simmap}}, \code{\link{keep.tip}}
+}
+\keyword{phylogenetics}
+\keyword{utilities}
diff --git a/man/drop.tip.multiSimmap.Rd b/man/drop.tip.multiSimmap.Rd
index 30a9c87..ef684ef 100644
--- a/man/drop.tip.multiSimmap.Rd
+++ b/man/drop.tip.multiSimmap.Rd
@@ -1,33 +1,33 @@
-\name{drop.tip.multiSimmap}
-\alias{drop.tip.multiSimmap}
-\alias{keep.tip.multiSimmap}
-\title{Drop or keep tip or tips from an object of class "multiSimmap"}
-\usage{
-\method{drop.tip}{multiSimmap}(phy, tip, ...)
-\method{keep.tip}{multiSimmap}(phy, tip, ...)
-}
-\arguments{
- \item{phy}{an object of class \code{"multiSimmap"}.}
- \item{tip}{name or names of species to be dropped, in a vector.}
- \item{...}{optional arguments to be passed to \code{\link{drop.tip.simmap}}. Most optional arguments work, with the exception of \code{interactive=TRUE} which will return an error.}
-}
-\description{
- This function drops or keeps one or multiple tips from all the trees of an object of class \code{"multiSimmap"}.
-}
-\details{
- Equivalent to \code{\link{drop.tip}} and \code{\link{keep.tip}} in \pkg{ape}.
-
- This function merely wraps \code{\link{drop.tip.simmap}}.
-}
-\value{
- An object of class \code{"multiSimmap"}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{drop.tip}}, \code{\link{drop.tip.multiPhylo}}, \code{\link{drop.tip.simmap}}
-}
-\keyword{phylogenetics}
-\keyword{utilities}
+\name{drop.tip.multiSimmap}
+\alias{drop.tip.multiSimmap}
+\alias{keep.tip.multiSimmap}
+\title{Drop or keep tip or tips from an object of class "multiSimmap"}
+\usage{
+\method{drop.tip}{multiSimmap}(phy, tip, ...)
+\method{keep.tip}{multiSimmap}(phy, tip, ...)
+}
+\arguments{
+ \item{phy}{an object of class \code{"multiSimmap"}.}
+ \item{tip}{name or names of species to be dropped, in a vector.}
+ \item{...}{optional arguments to be passed to \code{\link{drop.tip.simmap}}. Most optional arguments work, with the exception of \code{interactive=TRUE} which will return an error.}
+}
+\description{
+ This function drops or keeps one or multiple tips from all the trees of an object of class \code{"multiSimmap"}.
+}
+\details{
+ Equivalent to \code{\link{drop.tip}} and \code{\link{keep.tip}} in \pkg{ape}.
+
+ This function merely wraps \code{\link{drop.tip.simmap}}.
+}
+\value{
+ An object of class \code{"multiSimmap"}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{drop.tip}}, \code{\link{drop.tip.multiPhylo}}, \code{\link{drop.tip.simmap}}
+}
+\keyword{phylogenetics}
+\keyword{utilities}
diff --git a/man/drop.tip.simmap.Rd b/man/drop.tip.simmap.Rd
index 6705f90..9f8287a 100644
--- a/man/drop.tip.simmap.Rd
+++ b/man/drop.tip.simmap.Rd
@@ -1,37 +1,37 @@
-\name{drop.tip.simmap}
-\alias{drop.tip.simmap}
-\alias{keep.tip.simmap}
-\alias{extract.clade.simmap}
-\title{Drop tips or extract clade from tree with mapped discrete character}
-\usage{
-\method{drop.tip}{simmap}(phy, tip, ...)
-\method{keep.tip}{simmap}(phy, tip, ...)
-extract.clade.simmap(tree, node)
-}
-\arguments{
- \item{phy}{an object of class \code{"simmap"}.}
- \item{tip}{name or names of species to be dropped (or kept).}
- \item{node}{node number for the root node of the clade to be extracted.}
- \item{...}{optional arguments. Currently the logical argument \code{untangle} which if set to \code{TRUE} will call \code{\link{untangle}} before returning the \code{"simmap"} object to the user.}
- \item{tree}{for \code{extract.clade.simmap}, an object of class \code{"simmap"}.}
-}
-\description{
- This function drops one or multiple tips from an object of class \code{"simmap"}.
-}
-\details{
- Equivalent to \code{\link{drop.tip}} and \code{\link{keep.tip}} but for a tree with a mapped discrete character.
-
- \code{extract.clade.simmap} is functionally equivalent to \code{\link{extract.clade}} but preserves discrete character mappings on the tree.
-}
-\value{
- A modified object of class \code{"phylo"} containing the elements \code{maps} and \code{$mapped.edge} with the time spent in each state along each edge of the tree.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{brownie.lite}}, \code{\link{drop.tip}}, \code{\link{extract.clade}}, \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{sim.history}}
-}
-\keyword{phylogenetics}
-\keyword{utilities}
+\name{drop.tip.simmap}
+\alias{drop.tip.simmap}
+\alias{keep.tip.simmap}
+\alias{extract.clade.simmap}
+\title{Drop tips or extract clade from tree with mapped discrete character}
+\usage{
+\method{drop.tip}{simmap}(phy, tip, ...)
+\method{keep.tip}{simmap}(phy, tip, ...)
+extract.clade.simmap(tree, node)
+}
+\arguments{
+ \item{phy}{an object of class \code{"simmap"}.}
+ \item{tip}{name or names of species to be dropped (or kept).}
+ \item{node}{node number for the root node of the clade to be extracted.}
+ \item{...}{optional arguments. Currently the logical argument \code{untangle} which if set to \code{TRUE} will call \code{\link{untangle}} before returning the \code{"simmap"} object to the user.}
+ \item{tree}{for \code{extract.clade.simmap}, an object of class \code{"simmap"}.}
+}
+\description{
+ This function drops one or multiple tips from an object of class \code{"simmap"}.
+}
+\details{
+ Equivalent to \code{\link{drop.tip}} and \code{\link{keep.tip}} but for a tree with a mapped discrete character.
+
+ \code{extract.clade.simmap} is functionally equivalent to \code{\link{extract.clade}} but preserves discrete character mappings on the tree.
+}
+\value{
+ A modified object of class \code{"phylo"} containing the elements \code{maps} and \code{$mapped.edge} with the time spent in each state along each edge of the tree.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{brownie.lite}}, \code{\link{drop.tip}}, \code{\link{extract.clade}}, \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{sim.history}}
+}
+\keyword{phylogenetics}
+\keyword{utilities}
diff --git a/man/edge.widthMap.Rd b/man/edge.widthMap.Rd
index a46063d..30b5353 100644
--- a/man/edge.widthMap.Rd
+++ b/man/edge.widthMap.Rd
@@ -1,50 +1,50 @@
-\name{edge.widthMap}
-\alias{edge.widthMap}
-\alias{plot.edge.widthMap}
-\title{Map continuous trait evolution on the tree}
-\usage{
-edge.widthMap(tree, x, ...)
-\method{plot}{edge.widthMap}(x, max.width=0.9, legend="trait value", ...)
-}
-\arguments{
- \item{tree}{object of class \code{"phylo"}.}
- \item{x}{a numerical vector of phenotypic trait values for species. \code{names(x)} should contain the species names and match \code{tree$tip.label}. Or, for \code{plot.edge.widthMap}, an object of class \code{"edge.widthMap"}.}
- \item{max.width}{maximum edge width in plot units.}
- \item{legend}{label for the plot legend.}
- \item{...}{optional arguments - especially for the \code{plot} method. Perhaps the most important of these is \code{min.width}, which defaults to \code{0} but could probably be increased for many datasets and graphical devices. Other arguments are passed internally to \code{\link{plotTree}}.}
-}
-\description{
- Maps a discrete character onto the edges of the tree using variable edge widths.
-}
-\value{
- \code{edge.widthMap} returns an object of class \code{"edge.widthMap"}.
-
- \code{plot.edge.widthMap} can be used to plot this object.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{contMap}}, \code{\link{fastAnc}}
-}
-\examples{
-## load data from Garland et al. (1992)
-data(mammal.tree)
-data(mammal.data)
-## extract character of interest
-ln.bodyMass<-log(setNames(mammal.data$bodyMass,
- rownames(mammal.data)))
-## create "edge.widthMap" object
-mammal.ewMap<-edge.widthMap(mammal.tree,ln.bodyMass,
- min.width=0.05)
-## plot it
-plot(mammal.ewMap,legend="log(body mass)")
-par(mar=c(5.1,4.1,4.1,2.1)) ## reset margins to default
-}
-\keyword{ancestral states}
-\keyword{phylogenetics}
-\keyword{plotting}
-\keyword{comparative method}
-\keyword{continuous character}
-\keyword{maximum likelihood}
+\name{edge.widthMap}
+\alias{edge.widthMap}
+\alias{plot.edge.widthMap}
+\title{Map continuous trait evolution on the tree}
+\usage{
+edge.widthMap(tree, x, ...)
+\method{plot}{edge.widthMap}(x, max.width=0.9, legend="trait value", ...)
+}
+\arguments{
+ \item{tree}{object of class \code{"phylo"}.}
+ \item{x}{a numerical vector of phenotypic trait values for species. \code{names(x)} should contain the species names and match \code{tree$tip.label}. Or, for \code{plot.edge.widthMap}, an object of class \code{"edge.widthMap"}.}
+ \item{max.width}{maximum edge width in plot units.}
+ \item{legend}{label for the plot legend.}
+ \item{...}{optional arguments - especially for the \code{plot} method. Perhaps the most important of these is \code{min.width}, which defaults to \code{0} but could probably be increased for many datasets and graphical devices. Other arguments are passed internally to \code{\link{plotTree}}.}
+}
+\description{
+ Maps a discrete character onto the edges of the tree using variable edge widths.
+}
+\value{
+ \code{edge.widthMap} returns an object of class \code{"edge.widthMap"}.
+
+ \code{plot.edge.widthMap} can be used to plot this object.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{contMap}}, \code{\link{fastAnc}}
+}
+\examples{
+## load data from Garland et al. (1992)
+data(mammal.tree)
+data(mammal.data)
+## extract character of interest
+ln.bodyMass<-log(setNames(mammal.data$bodyMass,
+ rownames(mammal.data)))
+## create "edge.widthMap" object
+mammal.ewMap<-edge.widthMap(mammal.tree,ln.bodyMass,
+ min.width=0.05)
+## plot it
+plot(mammal.ewMap,legend="log(body mass)")
+par(mar=c(5.1,4.1,4.1,2.1)) ## reset margins to default
+}
+\keyword{ancestral states}
+\keyword{phylogenetics}
+\keyword{plotting}
+\keyword{comparative method}
+\keyword{continuous character}
+\keyword{maximum likelihood}
diff --git a/man/edgeProbs.Rd b/man/edgeProbs.Rd
index 5295f3a..fd8dbfb 100644
--- a/man/edgeProbs.Rd
+++ b/man/edgeProbs.Rd
@@ -1,31 +1,31 @@
-\name{edgeProbs}
-\alias{edgeProbs}
-\title{Compute the relative frequencies of state changes along edges}
-\usage{
-edgeProbs(trees)
-}
-\arguments{
- \item{trees}{an object of class \code{"multiSimmap"} containing a sample of trees that are identical in topology & branch lengths with different stochastically mapped character histories.}
-}
-\description{
- Computes the relative frequencies of character state changes along edges from a sample of stochastically mapped character histories.
-}
-\details{
- The function assumes that all trees in the sample differ only in their mapped histories & not at all in topology or branch lengths.
-
- Note that \code{edgeProbs} only asks whether the starting and ending states of the edge \emph{differ} in a particular way, and thus ignores multiple-hits along a single edge.
-}
-\value{
- The object that is returned is a matrix with the state changes & the relative frequency of each state change. Rows are in the order of the matrix \code{edge} for any of the mapped trees.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{plotSimmap}}
-}
-\keyword{ancestral states}
-\keyword{phylogenetics}
-\keyword{plotting}
-\keyword{discrete character}
+\name{edgeProbs}
+\alias{edgeProbs}
+\title{Compute the relative frequencies of state changes along edges}
+\usage{
+edgeProbs(trees)
+}
+\arguments{
+ \item{trees}{an object of class \code{"multiSimmap"} containing a sample of trees that are identical in topology & branch lengths with different stochastically mapped character histories.}
+}
+\description{
+ Computes the relative frequencies of character state changes along edges from a sample of stochastically mapped character histories.
+}
+\details{
+ The function assumes that all trees in the sample differ only in their mapped histories & not at all in topology or branch lengths.
+
+ Note that \code{edgeProbs} only asks whether the starting and ending states of the edge \emph{differ} in a particular way, and thus ignores multiple-hits along a single edge.
+}
+\value{
+ The object that is returned is a matrix with the state changes & the relative frequency of each state change. Rows are in the order of the matrix \code{edge} for any of the mapped trees.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{plotSimmap}}
+}
+\keyword{ancestral states}
+\keyword{phylogenetics}
+\keyword{plotting}
+\keyword{discrete character}
diff --git a/man/estDiversity.Rd b/man/estDiversity.Rd
index 5a39045..0fa8856 100644
--- a/man/estDiversity.Rd
+++ b/man/estDiversity.Rd
@@ -1,44 +1,44 @@
-\name{estDiversity}
-\alias{estDiversity}
-\title{Estimate diversity at each node of the tree}
-\usage{
-estDiversity(tree, x, method=c("asr","simulation"), model="ER", ...)
-}
-\arguments{
- \item{tree}{is a phylogenetic tree in \code{"phylo"} format.}
- \item{x}{a vector containing the biogeographic area for each of the tip taxa.}
- \item{method}{method for reconstructing ancestral biogeography.}
- \item{model}{model for ancestral character estimation. In theory, any model from \code{\link{ace}}; however only symmetric models permitted for \code{method="asr"}.}
- \item{...}{optional arguments. So far, this includes only \code{nsim}, the number of stochastic mappings to conduct using \code{\link{make.simmap}} for \code{method="simulation"}.}
-}
-\description{
- Estimates the lineage density at each node in the tree based on a biogeographic model (similar to Mahler et al. 2010).
-}
-\details{
- Two different methods are implemented in the current version.
-
- For \code{method="asr"} the state at the current node, and at each position along each co-extant internal edge, is computed as the marginal (empirical Bayesian) ancestral state reconstruction using the re-rooting method of Yang (2006). The lineage density is then computed as the sum of the marginal reconstructions (posterior probabilities) times the summed marginal ancestral reconstructions across co-extant edges.
-
- For \code{method="simulation"}, stochastic character mapping is used to generate optional argument \code{nsim} stochastic maps of ancestral biogeography. Then the lineage density at each node is computed as the number of co-existing lineages with the same biogeography as the focal node, averaged acrossed stochastic maps.
-
- The importance of this distinction may depend on the degree to which reconstructions at internal nodes are independent, which relates to the distinction between marginal and joint reconstruction (e.g., see Yang 2006).
-}
-\value{
- A vector containing the estimated lineage density at each node
-}
-\references{
- Mahler, D. L, L. J. Revell, R. E. Glor, and J. B. Losos. (2010) Ecological opportunity and the rate of morphological evolution in the diversification of Greater Antillean anoles. \emph{Evolution}, \bold{64}, 2731-2745.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-
- Yang, Z. (2006) \emph{Computational Molecular Evolution}. Oxford University Press.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{fitDiversityModel}}
-}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{maximum likelihood}
-\keyword{continuous character}
-\keyword{diversification}
+\name{estDiversity}
+\alias{estDiversity}
+\title{Estimate diversity at each node of the tree}
+\usage{
+estDiversity(tree, x, method=c("asr","simulation"), model="ER", ...)
+}
+\arguments{
+ \item{tree}{is a phylogenetic tree in \code{"phylo"} format.}
+ \item{x}{a vector containing the biogeographic area for each of the tip taxa.}
+ \item{method}{method for reconstructing ancestral biogeography.}
+ \item{model}{model for ancestral character estimation. In theory, any model from \code{\link{ace}}; however only symmetric models permitted for \code{method="asr"}.}
+ \item{...}{optional arguments. So far, this includes only \code{nsim}, the number of stochastic mappings to conduct using \code{\link{make.simmap}} for \code{method="simulation"}.}
+}
+\description{
+ Estimates the lineage density at each node in the tree based on a biogeographic model (similar to Mahler et al. 2010).
+}
+\details{
+ Two different methods are implemented in the current version.
+
+ For \code{method="asr"} the state at the current node, and at each position along each co-extant internal edge, is computed as the marginal (empirical Bayesian) ancestral state reconstruction using the re-rooting method of Yang (2006). The lineage density is then computed as the sum of the marginal reconstructions (posterior probabilities) times the summed marginal ancestral reconstructions across co-extant edges.
+
+ For \code{method="simulation"}, stochastic character mapping is used to generate optional argument \code{nsim} stochastic maps of ancestral biogeography. Then the lineage density at each node is computed as the number of co-existing lineages with the same biogeography as the focal node, averaged acrossed stochastic maps.
+
+ The importance of this distinction may depend on the degree to which reconstructions at internal nodes are independent, which relates to the distinction between marginal and joint reconstruction (e.g., see Yang 2006).
+}
+\value{
+ A vector containing the estimated lineage density at each node
+}
+\references{
+ Mahler, D. L, L. J. Revell, R. E. Glor, and J. B. Losos. (2010) Ecological opportunity and the rate of morphological evolution in the diversification of Greater Antillean anoles. \emph{Evolution}, \bold{64}, 2731-2745.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+
+ Yang, Z. (2006) \emph{Computational Molecular Evolution}. Oxford University Press.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{fitDiversityModel}}
+}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{maximum likelihood}
+\keyword{continuous character}
+\keyword{diversification}
diff --git a/man/evol.rate.mcmc.Rd b/man/evol.rate.mcmc.Rd
index 9df69cb..1d7071c 100644
--- a/man/evol.rate.mcmc.Rd
+++ b/man/evol.rate.mcmc.Rd
@@ -1,48 +1,48 @@
-\name{evol.rate.mcmc}
-\alias{evol.rate.mcmc}
-\alias{print.evol.rate.mcmc}
-\alias{summary.evol.rate.mcmc}
-\alias{print.summary.evol.rate.mcmc}
-\alias{plot.summary.evol.rate.mcmc}
-\title{Bayesian MCMC method for identifying exceptional phenotypic diversification in a phylogeny}
-\usage{
-evol.rate.mcmc(tree, x, ngen=10000, control=list(), ...)
-\method{print}{evol.rate.mcmc}(x, ...)
-\method{summary}{evol.rate.mcmc}(object, ...)
-\method{print}{summary.evol.rate.mcmc}(x, ...)
-\method{plot}{summary.evol.rate.mcmc}(x, ...)
-}
-\arguments{
- \item{tree}{an object of class \code{"phylo"} (a phylogenetic tree).}
- \item{x}{a vector of tip values for species in which \code{names(x)} contains the species names of \code{tree}, an object of class \code{"evol.rate.mcmc"}, or (in the case of the S3 \code{summary} method) an object of class \code{"summary.evol.rate.mcmc"}.}
- \item{ngen}{an integer value indicating the number of generations for the MCMC.}
- \item{control}{a list of control parameters containing the following elements: \code{sig1}: starting value for \eqn{\sigma_1^2}; \code{sig2}: starting value for \eqn{\sigma_2^2}; \code{a}: starting value for a; \code{sd1}: standard deviation for the normal proposal distribution for \eqn{\sigma_1^2}; \code{sd2}: standard deviation for the normal proposal distribution for \eqn{\sigma_2^2}; \code{kloc}: scaling parameter for tree move proposals - \eqn{1/\lambda} for the reflected exponential distribution; \code{sdlnr}: standard deviation on the log-normal prior on \eqn{\sigma_1^2/\sigma_2^2}; \code{rand.shift}: probability of proposing a random shift in the tree (improves mixing); \code{print}: print frequency for the MCMC; \code{sample}: sample frequency.}
- \item{object}{for the S3 \code{summary} method, an object of class \code{"evol.rate.mcmc"}.}
- \item{...}{other optional arguments.}
-}
-\description{
- Estimates the phylogenetic location of a \emph{single} rate shift on the tree using Bayesian MCMC (as described in Revell et al., 2012b).
-}
-\details{
- This function takes a phylogenetic tree and data for a single continuously valued character and uses a Bayesian MCMC approach to identify the phylogenetic location of a shift in the evolutionary rate through time.
-
- Default values of \code{control} are given in Revell et al. (2012b).
-}
-\value{
- An object of class \code{"evol.rate.mcmc"} consisting of at least the following elements:
- \item{mcmc}{results from the MCMC run.}
- \item{tips}{list of stips in rate \eqn{\sigma_1^2} for each sampled generation of MCMC (to polarize the rate shift).}
-}
-\references{
- Revell, L. J. (2012a) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-
- Revell, L. J., D. L. Mahler, P. Peres-Neto, and B. D. Redelings. (2012b) A new method for identifying exceptional phenotypic diversification. \emph{Evolution}, \bold{66}, 135-146.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{anc.Bayes}}, \code{\link{brownie.lite}}, \code{\link{evol.vcv}}, \code{\link{minSplit}}, \code{\link{posterior.evolrate}}
-}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{bayesian}
-\keyword{continuous character}
+\name{evol.rate.mcmc}
+\alias{evol.rate.mcmc}
+\alias{print.evol.rate.mcmc}
+\alias{summary.evol.rate.mcmc}
+\alias{print.summary.evol.rate.mcmc}
+\alias{plot.summary.evol.rate.mcmc}
+\title{Bayesian MCMC method for identifying exceptional phenotypic diversification in a phylogeny}
+\usage{
+evol.rate.mcmc(tree, x, ngen=10000, control=list(), ...)
+\method{print}{evol.rate.mcmc}(x, ...)
+\method{summary}{evol.rate.mcmc}(object, ...)
+\method{print}{summary.evol.rate.mcmc}(x, ...)
+\method{plot}{summary.evol.rate.mcmc}(x, ...)
+}
+\arguments{
+ \item{tree}{an object of class \code{"phylo"} (a phylogenetic tree).}
+ \item{x}{a vector of tip values for species in which \code{names(x)} contains the species names of \code{tree}, an object of class \code{"evol.rate.mcmc"}, or (in the case of the S3 \code{summary} method) an object of class \code{"summary.evol.rate.mcmc"}.}
+ \item{ngen}{an integer value indicating the number of generations for the MCMC.}
+ \item{control}{a list of control parameters containing the following elements: \code{sig1}: starting value for \eqn{\sigma_1^2}; \code{sig2}: starting value for \eqn{\sigma_2^2}; \code{a}: starting value for a; \code{sd1}: standard deviation for the normal proposal distribution for \eqn{\sigma_1^2}; \code{sd2}: standard deviation for the normal proposal distribution for \eqn{\sigma_2^2}; \code{kloc}: scaling parameter for tree move proposals - \eqn{1/\lambda} for the reflected exponential distribution; \code{sdlnr}: standard deviation on the log-normal prior on \eqn{\sigma_1^2/\sigma_2^2}; \code{rand.shift}: probability of proposing a random shift in the tree (improves mixing); \code{print}: print frequency for the MCMC; \code{sample}: sample frequency.}
+ \item{object}{for the S3 \code{summary} method, an object of class \code{"evol.rate.mcmc"}.}
+ \item{...}{other optional arguments.}
+}
+\description{
+ Estimates the phylogenetic location of a \emph{single} rate shift on the tree using Bayesian MCMC (as described in Revell et al., 2012b).
+}
+\details{
+ This function takes a phylogenetic tree and data for a single continuously valued character and uses a Bayesian MCMC approach to identify the phylogenetic location of a shift in the evolutionary rate through time.
+
+ Default values of \code{control} are given in Revell et al. (2012b).
+}
+\value{
+ An object of class \code{"evol.rate.mcmc"} consisting of at least the following elements:
+ \item{mcmc}{results from the MCMC run.}
+ \item{tips}{list of stips in rate \eqn{\sigma_1^2} for each sampled generation of MCMC (to polarize the rate shift).}
+}
+\references{
+ Revell, L. J. (2012a) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+
+ Revell, L. J., D. L. Mahler, P. Peres-Neto, and B. D. Redelings. (2012b) A new method for identifying exceptional phenotypic diversification. \emph{Evolution}, \bold{66}, 135-146.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{anc.Bayes}}, \code{\link{brownie.lite}}, \code{\link{evol.vcv}}, \code{\link{minSplit}}, \code{\link{posterior.evolrate}}
+}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{bayesian}
+\keyword{continuous character}
diff --git a/man/evol.vcv.Rd b/man/evol.vcv.Rd
index b9c0cdb..27c1038 100644
--- a/man/evol.vcv.Rd
+++ b/man/evol.vcv.Rd
@@ -1,55 +1,55 @@
-\name{evol.vcv}
-\alias{evol.vcv}
-\title{Likelihood test for variation in the evolutionary variance-covariance matrix}
-\usage{
-evol.vcv(tree, X, maxit=2000, vars=FALSE, ...)
-}
-\arguments{
- \item{tree}{an object of class \code{"simmap"}. If \code{tree} is an object of class \code{"phylo"} then a simple multivariate Brownian motion model will be fit to the data in \code{X}.}
- \item{X}{an \code{n} x \code{m} matrix of tip values for \code{m} continuously valued traits in \code{n} species - row names should be species names. If \code{X} is supplied as a data frame it will be coerced into a matrix without warning.}
- \item{maxit}{an optional integer value indicating the maximum number of iterations for optimization. This quantity may need to be increased for difficult optimizations.}
- \item{vars}{an optional logical value indicating whether or not to estimate the variances of the parameter estimates from the Hessian matrix.}
- \item{...}{optional arguments. The most important optional argument at this time is \code{error_vcv} which should contain a list of matrices of sampling \emph{variances} and covariances for (and between) the means of each species. The sampling variance for the mean is just the square of the sampling error. Sampling covariances will tend to be zero (or close to zero) if error for different traits is uncorrelated, for instance, because different specimens were used to estimate the means for different traits, and non-zero otherwise.}
-}
-\description{
- Fits a multi-regime multivariate Brownian motion model following Revell & Collar (2009).
-}
-\details{
- The function takes an object of class \code{"simmap"} with a mapped binary or multistate trait and data for an arbitrary number of continuously valued character. It then fits the multiple evolutionary variance-covariance matrix (rate matrix) model of Revell & Collar (2009; \emph{Evolution}).
-
- \code{evol.vcv} performs optimization by maximizing the likelihood with respect to the Cholesky matrices using \code{\link{optim}}. Optimization is by \code{method="Nelder-Mead"}. Using box constraints does not make sense here as they would be applied to the Cholesky matrix rather than the target parameters. Users may have to increase \code{maxit} for large trees and/or more than two traits.
-}
-\value{
- An object of class \code{"evol.vcv"} with the following elements:
- \item{R.single}{vcv matrix for the single rate matrix model.}
- \item{vars.single}{optionally, a matrix containing the variances of the elements of \code{R.single}.}
- \item{logL1}{log-likelihood for single matrix model.}
- \item{k1}{number of parameters in the single marix model.}
- \item{R.multiple}{\code{m} x \code{m} x \code{p} array containing the \code{p} estimated vcv matrices for the \code{p} regimes painted on the tree.}
- \item{vars.multiple}{optionally, an array containing the variances of the parameter estimates in \code{R.multiple}.}
- \item{logL.multiple}{log-likelihood of the multi-matrix model.}
- \item{k2}{number of parameters estimated in this model.}
- \item{P.chisq}{P-value of the \eqn{\chi^2} test on the likelihood ratio.}
- \item{convergence}{logical value indicating whether or not the optimization has converged.}
-}
-\references{
- Revell, L. J., and D. C. Collar (2009) Phylogenetic analysis of the evolutionary correlation using likelihood. \emph{Evolution}, \bold{63}, 1090-1100.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{evol.rate.mcmc}}, \code{\link{brownie.lite}}
-}
-\examples{
-## load data from Revell & Collar (2009)
-data(sunfish.tree)
-data(sunfish.data)
-## fit multi-correlation model
-sunfish.fit<-evol.vcv(sunfish.tree,sunfish.data[,2:3])
-print(sunfish.fit)
-}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{maximum likelihood}
-\keyword{continuous character}
+\name{evol.vcv}
+\alias{evol.vcv}
+\title{Likelihood test for variation in the evolutionary variance-covariance matrix}
+\usage{
+evol.vcv(tree, X, maxit=2000, vars=FALSE, ...)
+}
+\arguments{
+ \item{tree}{an object of class \code{"simmap"}. If \code{tree} is an object of class \code{"phylo"} then a simple multivariate Brownian motion model will be fit to the data in \code{X}.}
+ \item{X}{an \code{n} x \code{m} matrix of tip values for \code{m} continuously valued traits in \code{n} species - row names should be species names. If \code{X} is supplied as a data frame it will be coerced into a matrix without warning.}
+ \item{maxit}{an optional integer value indicating the maximum number of iterations for optimization. This quantity may need to be increased for difficult optimizations.}
+ \item{vars}{an optional logical value indicating whether or not to estimate the variances of the parameter estimates from the Hessian matrix.}
+ \item{...}{optional arguments. The most important optional argument at this time is \code{error_vcv} which should contain a list of matrices of sampling \emph{variances} and covariances for (and between) the means of each species. The sampling variance for the mean is just the square of the sampling error. Sampling covariances will tend to be zero (or close to zero) if error for different traits is uncorrelated, for instance, because different specimens were used to estimate the means for different traits, and non-zero otherwise.}
+}
+\description{
+ Fits a multi-regime multivariate Brownian motion model following Revell & Collar (2009).
+}
+\details{
+ The function takes an object of class \code{"simmap"} with a mapped binary or multistate trait and data for an arbitrary number of continuously valued character. It then fits the multiple evolutionary variance-covariance matrix (rate matrix) model of Revell & Collar (2009; \emph{Evolution}).
+
+ \code{evol.vcv} performs optimization by maximizing the likelihood with respect to the Cholesky matrices using \code{\link{optim}}. Optimization is by \code{method="Nelder-Mead"}. Using box constraints does not make sense here as they would be applied to the Cholesky matrix rather than the target parameters. Users may have to increase \code{maxit} for large trees and/or more than two traits.
+}
+\value{
+ An object of class \code{"evol.vcv"} with the following elements:
+ \item{R.single}{vcv matrix for the single rate matrix model.}
+ \item{vars.single}{optionally, a matrix containing the variances of the elements of \code{R.single}.}
+ \item{logL1}{log-likelihood for single matrix model.}
+ \item{k1}{number of parameters in the single marix model.}
+ \item{R.multiple}{\code{m} x \code{m} x \code{p} array containing the \code{p} estimated vcv matrices for the \code{p} regimes painted on the tree.}
+ \item{vars.multiple}{optionally, an array containing the variances of the parameter estimates in \code{R.multiple}.}
+ \item{logL.multiple}{log-likelihood of the multi-matrix model.}
+ \item{k2}{number of parameters estimated in this model.}
+ \item{P.chisq}{P-value of the \eqn{\chi^2} test on the likelihood ratio.}
+ \item{convergence}{logical value indicating whether or not the optimization has converged.}
+}
+\references{
+ Revell, L. J., and D. C. Collar (2009) Phylogenetic analysis of the evolutionary correlation using likelihood. \emph{Evolution}, \bold{63}, 1090-1100.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{evol.rate.mcmc}}, \code{\link{brownie.lite}}
+}
+\examples{
+## load data from Revell & Collar (2009)
+data(sunfish.tree)
+data(sunfish.data)
+## fit multi-correlation model
+sunfish.fit<-evol.vcv(sunfish.tree,sunfish.data[,2:3])
+print(sunfish.fit)
+}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{maximum likelihood}
+\keyword{continuous character}
diff --git a/man/evolvcv.lite.Rd b/man/evolvcv.lite.Rd
index e74ee7f..0fbf083 100644
--- a/man/evolvcv.lite.Rd
+++ b/man/evolvcv.lite.Rd
@@ -1,59 +1,59 @@
-\name{evolvcv.lite}
-\alias{evolvcv.lite}
-\title{Likelihood test for a shift in the evolutionary correlation between traits}
-\usage{
-evolvcv.lite(tree, X, maxit=2000, tol=1e-10, ...)
-}
-\arguments{
- \item{tree}{an object of class \code{"simmap"}. If \code{tree} is an object of class \code{"phylo"} then a simple multivariate Brownian motion model will be fit to the data in \code{X}.}
- \item{X}{an \code{n} x \code{m} matrix of tip values for \code{m} continuously valued traits in \code{n} species - row names should be species names. If \code{X} is supplied as a data frame it will be coerced into a matrix without warning.}
- \item{maxit}{an optional integer value indicating the maximum number of iterations for optimization - may need to be increased for large trees.}
- \item{tol}{tolerance value for \code{"L-BFGS-B"} optimization.}
- \item{...}{other optional arguments. The most important optional argument is probably \code{models} which species the models to be fit. See \emph{Description} for more information. A second useful argument is \code{error_vcv} which should be supplied as a list of matrices of sampling \emph{variances} and covariances for (and between) the means of each species. The sampling variance for the mean is just the square of the sampling error. Sampling covariances will tend to be zero (or close to zero) if error for different traits is uncorrelated, for instance, because different specimens were used to estimate the means for different traits, and non-zero otherwise.}
-}
-\description{
- Fits a multi-regime model for differences in the evolutionary variance-covariance structure or correlation between two continuous traits, following Revell & Collar (2009) and Revell et al. (2022).
-}
-\details{
- This function takes an object of class \code{"simmap"} with a mapped binary or multistate trait and data for two and only two continuously valued character. It then fits (by default) four different evolutionary models: common rates and correlation; different rates, common correlation; different correlations, common rates; no common structure.
-
- In addition to the four default models specified above, \code{evolvcv.lite} now fits an additional four additional models.
-
- The set of models to be fit can be specified using the optional argument \code{models} in multiple ways.
-
- First, if left unspecified, then the four models listed above will be fit.
-
- Second, if \code{models} is set to \code{"all models"} than eight models will be fit.
-
- Lastly, one or more (up to all eight) models can be fit by encoding the models to be fit into a single vector containing a subset or all of the following elements: \code{"1"}, \code{"2"}, \code{"2b"}, \code{"3"}, \code{"3b"}, \code{"3c"}, and \code{"4"}. These codes correspond to the following eight models: 1. common rates, common correlation; 2. different rates, common correlation; 2b. different rates for trait 1 only, common correlation; 2c. different rates for trait 2 only, common correlation; 3. common rates, different correlations; 3b. different rates for trait 1 only, different correlations; 3c. different rates for trait 2 only, different correlation; and 4. no common structure.
-}
-\value{
- A list with the results summarized for each model.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-
- Revell, L. J., and D. C. Collar (2009) Phylogenetic analysis of the evolutionary correlation using likelihood. \emph{Evolution}, \bold{63}, 1090-1100.
-
- Revell, L. J., K. S. Toyama, and D. L. Mahler (2022) A simple hierarchical model for heterogeneity in the evolutionary correlation on a phylogenetic tree. \emph{PeerJ}, \bold{10}, e13910.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{brownie.lite}}, \code{\link{evol.vcv}}
-}
-\examples{
-## load data from Revell & Collar (2009)
-data(sunfish.tree)
-data(sunfish.data)
-## fit heirarchical common-structure models
-sunfish.fit<-evolvcv.lite(sunfish.tree,
- sunfish.data[,2:3],models="all models")
-## print fitted models
-print(sunfish.fit)
-## compare models
-anova(sunfish.fit)
-}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{maximum likelihood}
-\keyword{continuous character}
+\name{evolvcv.lite}
+\alias{evolvcv.lite}
+\title{Likelihood test for a shift in the evolutionary correlation between traits}
+\usage{
+evolvcv.lite(tree, X, maxit=2000, tol=1e-10, ...)
+}
+\arguments{
+ \item{tree}{an object of class \code{"simmap"}. If \code{tree} is an object of class \code{"phylo"} then a simple multivariate Brownian motion model will be fit to the data in \code{X}.}
+ \item{X}{an \code{n} x \code{m} matrix of tip values for \code{m} continuously valued traits in \code{n} species - row names should be species names. If \code{X} is supplied as a data frame it will be coerced into a matrix without warning.}
+ \item{maxit}{an optional integer value indicating the maximum number of iterations for optimization - may need to be increased for large trees.}
+ \item{tol}{tolerance value for \code{"L-BFGS-B"} optimization.}
+ \item{...}{other optional arguments. The most important optional argument is probably \code{models} which species the models to be fit. See \emph{Description} for more information. A second useful argument is \code{error_vcv} which should be supplied as a list of matrices of sampling \emph{variances} and covariances for (and between) the means of each species. The sampling variance for the mean is just the square of the sampling error. Sampling covariances will tend to be zero (or close to zero) if error for different traits is uncorrelated, for instance, because different specimens were used to estimate the means for different traits, and non-zero otherwise.}
+}
+\description{
+ Fits a multi-regime model for differences in the evolutionary variance-covariance structure or correlation between two continuous traits, following Revell & Collar (2009) and Revell et al. (2022).
+}
+\details{
+ This function takes an object of class \code{"simmap"} with a mapped binary or multistate trait and data for two and only two continuously valued character. It then fits (by default) four different evolutionary models: common rates and correlation; different rates, common correlation; different correlations, common rates; no common structure.
+
+ In addition to the four default models specified above, \code{evolvcv.lite} now fits an additional four additional models.
+
+ The set of models to be fit can be specified using the optional argument \code{models} in multiple ways.
+
+ First, if left unspecified, then the four models listed above will be fit.
+
+ Second, if \code{models} is set to \code{"all models"} than eight models will be fit.
+
+ Lastly, one or more (up to all eight) models can be fit by encoding the models to be fit into a single vector containing a subset or all of the following elements: \code{"1"}, \code{"2"}, \code{"2b"}, \code{"3"}, \code{"3b"}, \code{"3c"}, and \code{"4"}. These codes correspond to the following eight models: 1. common rates, common correlation; 2. different rates, common correlation; 2b. different rates for trait 1 only, common correlation; 2c. different rates for trait 2 only, common correlation; 3. common rates, different correlations; 3b. different rates for trait 1 only, different correlations; 3c. different rates for trait 2 only, different correlation; and 4. no common structure.
+}
+\value{
+ A list with the results summarized for each model.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+
+ Revell, L. J., and D. C. Collar (2009) Phylogenetic analysis of the evolutionary correlation using likelihood. \emph{Evolution}, \bold{63}, 1090-1100.
+
+ Revell, L. J., K. S. Toyama, and D. L. Mahler (2022) A simple hierarchical model for heterogeneity in the evolutionary correlation on a phylogenetic tree. \emph{PeerJ}, \bold{10}, e13910.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{brownie.lite}}, \code{\link{evol.vcv}}
+}
+\examples{
+## load data from Revell & Collar (2009)
+data(sunfish.tree)
+data(sunfish.data)
+## fit heirarchical common-structure models
+sunfish.fit<-evolvcv.lite(sunfish.tree,
+ sunfish.data[,2:3],models="all models")
+## print fitted models
+print(sunfish.fit)
+## compare models
+anova(sunfish.fit)
+}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{maximum likelihood}
+\keyword{continuous character}
diff --git a/man/exhaustiveMP.Rd b/man/exhaustiveMP.Rd
index a91ee14..cf23e83 100644
--- a/man/exhaustiveMP.Rd
+++ b/man/exhaustiveMP.Rd
@@ -1,34 +1,34 @@
-\name{exhaustiveMP}
-\alias{exhaustiveMP}
-\title{Exhaustive and branch & bound MP optimization}
-\usage{
-exhaustiveMP(data, tree=NULL, method="branch.and.bound")
-}
-\arguments{
- \item{data}{is a \code{\link{phyDat}} (Schliep 2011) object containing DNA or other data.}
- \item{tree}{an optional input tree (used only with \code{method="branch.and.bound"}).}
- \item{method}{an optional string indicatingn method to use: \code{"branch.and.bound"}, implementing a branch-and-bound search (obviously), or \code{"exhaustive"}.}
-}
-\description{
- This function does exhaustive and branch & bound MP searches.
-}
-\details{
- Should probably not be used for more than about 8 species (and definitely not more than 10 species). Performs parsimony calculations using \code{\link{parsimony}} in the \pkg{phangorn} package (Schliep, 2011).
-}
-\value{
- A \code{"phylo"} or \code{"multiPhylo"} object that is the MP tree or set of MP trees. It also returns the parsimony scores in \code{attr(trees,"pscore")} or \code{attr(trees[[i]],"pscore")} for the ith tree.
-}
-\references{
- Felsenstein, J. (2004) \emph{Inferring Phylogenies}. Sinauer.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-
- Schliep, K. P. (2011) phangorn: phylogenetic analysis in R. \emph{Bioinformatics}, \bold{27}, 592-593.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{mrp.supertree}}, \code{\link{optim.parsimony}}, \code{\link{pratchet}}
-}
-\keyword{phylogenetics}
-\keyword{phylogeny inference}
-\keyword{parsimony}
+\name{exhaustiveMP}
+\alias{exhaustiveMP}
+\title{Exhaustive and branch & bound MP optimization}
+\usage{
+exhaustiveMP(data, tree=NULL, method="branch.and.bound")
+}
+\arguments{
+ \item{data}{is a \code{\link{phyDat}} (Schliep 2011) object containing DNA or other data.}
+ \item{tree}{an optional input tree (used only with \code{method="branch.and.bound"}).}
+ \item{method}{an optional string indicatingn method to use: \code{"branch.and.bound"}, implementing a branch-and-bound search (obviously), or \code{"exhaustive"}.}
+}
+\description{
+ This function does exhaustive and branch & bound MP searches.
+}
+\details{
+ Should probably not be used for more than about 8 species (and definitely not more than 10 species). Performs parsimony calculations using \code{\link{parsimony}} in the \pkg{phangorn} package (Schliep, 2011).
+}
+\value{
+ A \code{"phylo"} or \code{"multiPhylo"} object that is the MP tree or set of MP trees. It also returns the parsimony scores in \code{attr(trees,"pscore")} or \code{attr(trees[[i]],"pscore")} for the ith tree.
+}
+\references{
+ Felsenstein, J. (2004) \emph{Inferring Phylogenies}. Sinauer.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+
+ Schliep, K. P. (2011) phangorn: phylogenetic analysis in R. \emph{Bioinformatics}, \bold{27}, 592-593.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{mrp.supertree}}, \code{\link{optim.parsimony}}, \code{\link{pratchet}}
+}
+\keyword{phylogenetics}
+\keyword{phylogeny inference}
+\keyword{parsimony}
diff --git a/man/expand.clade.Rd b/man/expand.clade.Rd
index 69cd784..10c6332 100644
--- a/man/expand.clade.Rd
+++ b/man/expand.clade.Rd
@@ -1,33 +1,33 @@
-\name{expand.clade}
-\alias{expand.clade}
-\alias{plot.expand.clade}
-\title{Expands (or contracts) the tip-spacing of a given clade or clades}
-\usage{
-expand.clade(tree, node, factor=5)
-\method{plot}{expand.clade}(x, ...)
-}
-\arguments{
- \item{tree}{tree an object of class \code{"phylo"} or \code{"simmap"}.}
- \item{node}{node index or vector of node indices.}
- \item{factor}{expansion factor for the tip-spacing of the taxa descended from node or nodes in \code{node}.}
- \item{x}{for \code{plot} method, an object of class \code{"expand.clade"}.}
- \item{...}{optional arguments to be passed to \code{plotTree} or \code{plotSimmap}, depending on the class of \code{x$tree}.}
-}
-\description{
- Modify the tip-spacing of a plotted tree.
-}
-\details{
- The purpose of this function is to compute a custom tip-spacing for users who want to expand or contract the tip-spacing of the descendant taxa from a given node or nodes.
-}
-\value{
- The function returns an object of class \code{"expand.clade"} which consists of the (possibly re-ordered) tree and a numerical vector with the calculated tip spacing based on the expansion factor specified by the user.
-
- This object can be plotted using the S3 \code{plot} method for the object class; or it can be plotted simplying by calling a standard plotting function on the tree & tip spacings.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{phylogenetics}
-\keyword{plotting}
-\keyword{utilities}
+\name{expand.clade}
+\alias{expand.clade}
+\alias{plot.expand.clade}
+\title{Expands (or contracts) the tip-spacing of a given clade or clades}
+\usage{
+expand.clade(tree, node, factor=5)
+\method{plot}{expand.clade}(x, ...)
+}
+\arguments{
+ \item{tree}{tree an object of class \code{"phylo"} or \code{"simmap"}.}
+ \item{node}{node index or vector of node indices.}
+ \item{factor}{expansion factor for the tip-spacing of the taxa descended from node or nodes in \code{node}.}
+ \item{x}{for \code{plot} method, an object of class \code{"expand.clade"}.}
+ \item{...}{optional arguments to be passed to \code{plotTree} or \code{plotSimmap}, depending on the class of \code{x$tree}.}
+}
+\description{
+ Modify the tip-spacing of a plotted tree.
+}
+\details{
+ The purpose of this function is to compute a custom tip-spacing for users who want to expand or contract the tip-spacing of the descendant taxa from a given node or nodes.
+}
+\value{
+ The function returns an object of class \code{"expand.clade"} which consists of the (possibly re-ordered) tree and a numerical vector with the calculated tip spacing based on the expansion factor specified by the user.
+
+ This object can be plotted using the S3 \code{plot} method for the object class; or it can be plotted simplying by calling a standard plotting function on the tree & tip spacings.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{phylogenetics}
+\keyword{plotting}
+\keyword{utilities}
diff --git a/man/export.as.xml.Rd b/man/export.as.xml.Rd
index 5190cff..0651dc2 100644
--- a/man/export.as.xml.Rd
+++ b/man/export.as.xml.Rd
@@ -1,31 +1,31 @@
-\name{export.as.xml}
-\alias{export.as.xml}
-\title{Export trees & data in XML format}
-\usage{
-export.as.xml(file, trees, X)
-}
-\arguments{
- \item{file}{filename for export.}
- \item{trees}{a phylogenetic tree or trees in \code{"phylo"} or \code{"multiPhylo"} format.}
- \item{X}{a matrix of class \code{"DNAbin"} or a matrix with discretely valued non-DNA character data.}
-}
-\description{
- Exports trees & character data in XML format.
-}
-\details{
- Can be used to create input file for the program SIMMAP v1.5 (Bollback 2006).
-}
-\value{
- A file.
-}
-\references{
- Bollback, J. P. (2006) Stochastic character mapping of discrete traits on phylogenies. \emph{BMC Bioinformatics}, \bold{7}, 88.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{make.simmap}}, \code{\link{read.nexus}}, \code{\link{read.simmap}}, \code{\link{write.simmap}}
-}
-\keyword{phylogenetics}
-\keyword{utilities}
+\name{export.as.xml}
+\alias{export.as.xml}
+\title{Export trees & data in XML format}
+\usage{
+export.as.xml(file, trees, X)
+}
+\arguments{
+ \item{file}{filename for export.}
+ \item{trees}{a phylogenetic tree or trees in \code{"phylo"} or \code{"multiPhylo"} format.}
+ \item{X}{a matrix of class \code{"DNAbin"} or a matrix with discretely valued non-DNA character data.}
+}
+\description{
+ Exports trees & character data in XML format.
+}
+\details{
+ Can be used to create input file for the program SIMMAP v1.5 (Bollback 2006).
+}
+\value{
+ A file.
+}
+\references{
+ Bollback, J. P. (2006) Stochastic character mapping of discrete traits on phylogenies. \emph{BMC Bioinformatics}, \bold{7}, 88.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{make.simmap}}, \code{\link{read.nexus}}, \code{\link{read.simmap}}, \code{\link{write.simmap}}
+}
+\keyword{phylogenetics}
+\keyword{utilities}
diff --git a/man/fancyTree.Rd b/man/fancyTree.Rd
index e20ecd0..336f751 100644
--- a/man/fancyTree.Rd
+++ b/man/fancyTree.Rd
@@ -1,91 +1,91 @@
-\name{fancyTree}
-\alias{fancyTree}
-\alias{phyloScattergram}
-\alias{phenogram95}
-\title{Plots special types of phylogenetic trees}
-\usage{
-fancyTree(tree, type=c("extinction","traitgram3d","droptip","densitymap",
- "contmap","phenogram95","scattergram"), ..., control=list())
-phyloScattergram(tree, X=NULL, ...)
-phenogram95(tree, x=NULL, ...)
-}
-\arguments{
- \item{tree}{an object of class \code{"phylo"}.}
- \item{type}{the type of special plot to create. See Description.}
- \item{...}{arguments to be passed to different methods. See Description.}
- \item{control}{a list of control parameters, depending on \code{type}.}
- \item{X}{in \code{phyloScattergram}, a matrix of continuous trait values. Row names in the matrix should correspond to species names in the tree.}
- \item{x}{in \code{phenogram95}, a named vector with values for a continuously distributed trait.}
-}
-\description{
- Plots phylogenies (or phylogenetic trees and comparative data) in a variety of different styles.
-}
-\details{
- This function plots a phylogeny or phylogenetic tree and comparative data in a variety of different styles, depending on the value of \code{type}. In some instances, \code{fancyTree} is now just a wrappe for other \pkg{phytools} functions, such as \code{\link{contMap}} and \code{\link{densityMap}}.
-
- If \code{type="extinction"} (or any unambiguous abbreviation) the function will plot a tree in which branches preceding the MRCA of all extant taxa and branches leading only to extnct lineages are plotted with dashed red lines.
-
- If \code{type="traitgram3d"} the function will plot a three dimensional traitgram (that is, a projection of the tree into three dimensional morphospace where two dimensions are the phenotypic trait and the third axis is time since the root). In this case, the additional argument \code{X}, a matrix containing the tip values of all species (with species IDs as row names) should be supplied. Optionally, the user can also supply the matrix \code{A}, which contains the ancestral states in the tree with rows labeled by node number.
-
- If \code{type="droptip"} the function will create a two panel figure in which the first panel is the tree with lineages to be pruned highlighted; and the second panel is the pruned tree. In this case, the additional argument \code{tip}, the tip name or vector of tip names to be dropped, must be supplied.
-
- If \code{type="densitymap"}, a posterior probability density "heat-map" is created based on a set of trees in a \code{"multiSimmap"} object containing a binary [0,1] mapped character. (See \code{\link{densityMap}} for additional optional arguments if \code{type="densitymap"}.)
-
- If \code{type="contmap"}, reconstructed continuous trait evolution is mapped on the tree. Again, see \code{\link{contMap}} for additional arguments if \code{type="contmap"}.
-
- If \code{type="phenogram95"} a 95\% phenogram is plotted using transparency to visualize uncertainty at ancestral nodes and along branches. Most of the options of \code{\link{phenogram}} are available.
-
- Finally, if \code{type="scattergram"} a phylogenetic scatter plot matrix containing \code{\link{contMap}} style trees on the diagonal and \code{\link{phylomorphospace}} plots in non-diagonal panels is produced. For this type a trait matrix \code{X} must also be supplied. The only additional arguments available for this type are \code{ftype}, \code{fsize}, \code{colors}, and \code{label}. (See \code{\link{phylomorphospace}} for details on how these arguments should be used.) This function calls \code{\link{phyloScattergram}} (which is also now exported to the name space) internally. In addition to creating a plot, \code{phyloScattergram} also returns an object of class \code{"phyloScattergram"} which can be replotted using different options if desired.
-
- Presently only \code{type="traitgram3d"} uses the list \code{control} which can be supplied the same set of control parameters as \code{\link{phylomorphospace3d}}, as well as the control parameter \code{maxit} which will be passed to \code{\link{anc.ML}}.
-
- Finally, the optional argument \code{hold} will be passed to multiple methods if supplied. It is a logical value that indicates whether or not the output to the graphical device should be held using \code{\link{dev.hold}} before plotting (defaults to \code{hold=TRUE}).
-}
-\value{
- This function plots different types of phylogenetic trees. For \code{type="droptip"} the function also returns the pruned tree.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{contMap}}, \code{\link{densityMap}}, \code{\link{drop.tip}}, \code{\link{phenogram}}, \code{\link{phylomorphospace3d}}, \code{\link{plot.phylo}}, \code{\link{plotSimmap}}
-}
-\examples{
-## plot tree with extinction
-set.seed(10)
-tree<-pbtree(b=1,d=0.4,t=4)
-fancyTree(tree,type="extinction")
-
-\dontrun{
-## plot 3D traitgram
-tree<-pbtree(n=50,scale=10)
-Y<-sim.corrs(tree,vcv=matrix(c(1,0.75,0.75,1),2,2))
-fancyTree(tree,type="traitgram3d",X=Y,
- control=list(spin=FALSE))
-
-## plot with internal nodes from simulation
-Y<-sim.corrs(tree,vcv=matrix(c(1,0.75,0.75,1),
- 2,2),internal=TRUE)
-B<-Y[length(tree$tip)+1:tree$Nnode,]
-Y<-Y[1:length(tree$tip),]
-fancyTree(tree,type="traitgram3d",X=Y,A=B,
- control=list(simple.axes=TRUE,spin=FALSE))}
-
-## plot with dropped tips
-tree<-pbtree(n=30)
-tips<-sample(tree$tip.label)[1:10]
-pruned<-fancyTree(tree,type="droptip",tip=tips)
-par(mfrow=c(1,1)) ## reset mfrow to default
-
-\dontrun{
-## plot 95-percent CI phenogram
-tree<-pbtree(n=30)
-x<-fastBM(tree)
-fancyTree(tree,type="phenogram95",x=x)}
-
-par(mar=c(5.1,4.1,4.1,2.1)) ## reset mar to defaults
-}
-\keyword{phylogenetics}
-\keyword{plotting}
-\keyword{comparative method}
+\name{fancyTree}
+\alias{fancyTree}
+\alias{phyloScattergram}
+\alias{phenogram95}
+\title{Plots special types of phylogenetic trees}
+\usage{
+fancyTree(tree, type=c("extinction","traitgram3d","droptip","densitymap",
+ "contmap","phenogram95","scattergram"), ..., control=list())
+phyloScattergram(tree, X=NULL, ...)
+phenogram95(tree, x=NULL, ...)
+}
+\arguments{
+ \item{tree}{an object of class \code{"phylo"}.}
+ \item{type}{the type of special plot to create. See Description.}
+ \item{...}{arguments to be passed to different methods. See Description.}
+ \item{control}{a list of control parameters, depending on \code{type}.}
+ \item{X}{in \code{phyloScattergram}, a matrix of continuous trait values. Row names in the matrix should correspond to species names in the tree.}
+ \item{x}{in \code{phenogram95}, a named vector with values for a continuously distributed trait.}
+}
+\description{
+ Plots phylogenies (or phylogenetic trees and comparative data) in a variety of different styles.
+}
+\details{
+ This function plots a phylogeny or phylogenetic tree and comparative data in a variety of different styles, depending on the value of \code{type}. In some instances, \code{fancyTree} is now just a wrappe for other \pkg{phytools} functions, such as \code{\link{contMap}} and \code{\link{densityMap}}.
+
+ If \code{type="extinction"} (or any unambiguous abbreviation) the function will plot a tree in which branches preceding the MRCA of all extant taxa and branches leading only to extnct lineages are plotted with dashed red lines.
+
+ If \code{type="traitgram3d"} the function will plot a three dimensional traitgram (that is, a projection of the tree into three dimensional morphospace where two dimensions are the phenotypic trait and the third axis is time since the root). In this case, the additional argument \code{X}, a matrix containing the tip values of all species (with species IDs as row names) should be supplied. Optionally, the user can also supply the matrix \code{A}, which contains the ancestral states in the tree with rows labeled by node number.
+
+ If \code{type="droptip"} the function will create a two panel figure in which the first panel is the tree with lineages to be pruned highlighted; and the second panel is the pruned tree. In this case, the additional argument \code{tip}, the tip name or vector of tip names to be dropped, must be supplied.
+
+ If \code{type="densitymap"}, a posterior probability density "heat-map" is created based on a set of trees in a \code{"multiSimmap"} object containing a binary [0,1] mapped character. (See \code{\link{densityMap}} for additional optional arguments if \code{type="densitymap"}.)
+
+ If \code{type="contmap"}, reconstructed continuous trait evolution is mapped on the tree. Again, see \code{\link{contMap}} for additional arguments if \code{type="contmap"}.
+
+ If \code{type="phenogram95"} a 95\% phenogram is plotted using transparency to visualize uncertainty at ancestral nodes and along branches. Most of the options of \code{\link{phenogram}} are available.
+
+ Finally, if \code{type="scattergram"} a phylogenetic scatter plot matrix containing \code{\link{contMap}} style trees on the diagonal and \code{\link{phylomorphospace}} plots in non-diagonal panels is produced. For this type a trait matrix \code{X} must also be supplied. The only additional arguments available for this type are \code{ftype}, \code{fsize}, \code{colors}, and \code{label}. (See \code{\link{phylomorphospace}} for details on how these arguments should be used.) This function calls \code{\link{phyloScattergram}} (which is also now exported to the name space) internally. In addition to creating a plot, \code{phyloScattergram} also returns an object of class \code{"phyloScattergram"} which can be replotted using different options if desired.
+
+ Presently only \code{type="traitgram3d"} uses the list \code{control} which can be supplied the same set of control parameters as \code{\link{phylomorphospace3d}}, as well as the control parameter \code{maxit} which will be passed to \code{\link{anc.ML}}.
+
+ Finally, the optional argument \code{hold} will be passed to multiple methods if supplied. It is a logical value that indicates whether or not the output to the graphical device should be held using \code{\link{dev.hold}} before plotting (defaults to \code{hold=TRUE}).
+}
+\value{
+ This function plots different types of phylogenetic trees. For \code{type="droptip"} the function also returns the pruned tree.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{contMap}}, \code{\link{densityMap}}, \code{\link{drop.tip}}, \code{\link{phenogram}}, \code{\link{phylomorphospace3d}}, \code{\link{plot.phylo}}, \code{\link{plotSimmap}}
+}
+\examples{
+## plot tree with extinction
+set.seed(10)
+tree<-pbtree(b=1,d=0.4,t=4)
+fancyTree(tree,type="extinction")
+
+\dontrun{
+## plot 3D traitgram
+tree<-pbtree(n=50,scale=10)
+Y<-sim.corrs(tree,vcv=matrix(c(1,0.75,0.75,1),2,2))
+fancyTree(tree,type="traitgram3d",X=Y,
+ control=list(spin=FALSE))
+
+## plot with internal nodes from simulation
+Y<-sim.corrs(tree,vcv=matrix(c(1,0.75,0.75,1),
+ 2,2),internal=TRUE)
+B<-Y[length(tree$tip)+1:tree$Nnode,]
+Y<-Y[1:length(tree$tip),]
+fancyTree(tree,type="traitgram3d",X=Y,A=B,
+ control=list(simple.axes=TRUE,spin=FALSE))}
+
+## plot with dropped tips
+tree<-pbtree(n=30)
+tips<-sample(tree$tip.label)[1:10]
+pruned<-fancyTree(tree,type="droptip",tip=tips)
+par(mfrow=c(1,1)) ## reset mfrow to default
+
+\dontrun{
+## plot 95-percent CI phenogram
+tree<-pbtree(n=30)
+x<-fastBM(tree)
+fancyTree(tree,type="phenogram95",x=x)}
+
+par(mar=c(5.1,4.1,4.1,2.1)) ## reset mar to defaults
+}
+\keyword{phylogenetics}
+\keyword{plotting}
+\keyword{comparative method}
diff --git a/man/fastAnc.Rd b/man/fastAnc.Rd
index 6356e07..5d13580 100644
--- a/man/fastAnc.Rd
+++ b/man/fastAnc.Rd
@@ -1,47 +1,47 @@
-\name{fastAnc}
-\alias{fastAnc}
-\title{(Reasonably) fast estimation of ML ancestral states}
-\usage{
-fastAnc(tree, x, vars=FALSE, CI=FALSE, ...)
-}
-\arguments{
- \item{tree}{an object of class \code{"phylo"}.}
- \item{x}{a vector of tip values for species; \code{names(x)} should be the species names.}
- \item{vars}{a logical value indicating whether or not to compute variances on the ancestral state estimates. Variances are based on Equation (6) of Rohlf (2001).}
- \item{CI}{a logical value indicating whether or not to compute 95\% confidence intervals on state estimates.}
- \item{...}{optional arguments. Presently this consists of \code{anc.states}, a named vector containing ancestral states to fix. Names should correspond to node numbers in the input tree.}
-}
-\description{
- Estimates ancestral states for a continuous character under maximum likelihood.
-}
-\details{
- This function performs (reasonably) fast estimation of the ML ancestral states for a continuous trait by taking advantage of the fact that the state computed for the root node of the tree during Felsenstein's (1985) contrasts algorithm is also the MLE of the root node. Thus, the function re-roots the tree at all internal nodes and computes the contrasts state at the root each time.
-
- The function can also (optionally) compute variances or 95\% confidence intervals on the estimates.
-}
-\value{
- An object of class \code{"fastAnc"} consisting of either: a named vector containing the states at internal nodes - names are node numbers; or a list containing ancestral state estimates (\code{ace}), variances on the estimates (\code{var}), and/or 95\% confidence intervals (\code{CI95}).
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{ace}}, \code{\link{anc.Bayes}}, \code{\link{anc.ML}}, \code{\link{pic}}
-}
-\examples{
-## load data from Garland et al. (1992)
-data(mammal.tree)
-data(mammal.data)
-## extract character of interest
-ln.bodyMass<-log(setNames(mammal.data$bodyMass,
- rownames(mammal.data)))
-## estimate ancestral body sizes
-fit.BM<-fastAnc(mammal.tree,ln.bodyMass,CI=TRUE)
-print(fit.BM,printlen=10)
-}
-\keyword{ancestral states}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{maximum likelihood}
-\keyword{continuous character}
+\name{fastAnc}
+\alias{fastAnc}
+\title{(Reasonably) fast estimation of ML ancestral states}
+\usage{
+fastAnc(tree, x, vars=FALSE, CI=FALSE, ...)
+}
+\arguments{
+ \item{tree}{an object of class \code{"phylo"}.}
+ \item{x}{a vector of tip values for species; \code{names(x)} should be the species names.}
+ \item{vars}{a logical value indicating whether or not to compute variances on the ancestral state estimates. Variances are based on Equation (6) of Rohlf (2001).}
+ \item{CI}{a logical value indicating whether or not to compute 95\% confidence intervals on state estimates.}
+ \item{...}{optional arguments. Presently this consists of \code{anc.states}, a named vector containing ancestral states to fix. Names should correspond to node numbers in the input tree.}
+}
+\description{
+ Estimates ancestral states for a continuous character under maximum likelihood.
+}
+\details{
+ This function performs (reasonably) fast estimation of the ML ancestral states for a continuous trait by taking advantage of the fact that the state computed for the root node of the tree during Felsenstein's (1985) contrasts algorithm is also the MLE of the root node. Thus, the function re-roots the tree at all internal nodes and computes the contrasts state at the root each time.
+
+ The function can also (optionally) compute variances or 95\% confidence intervals on the estimates.
+}
+\value{
+ An object of class \code{"fastAnc"} consisting of either: a named vector containing the states at internal nodes - names are node numbers; or a list containing ancestral state estimates (\code{ace}), variances on the estimates (\code{var}), and/or 95\% confidence intervals (\code{CI95}).
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{ace}}, \code{\link{anc.Bayes}}, \code{\link{anc.ML}}, \code{\link{pic}}
+}
+\examples{
+## load data from Garland et al. (1992)
+data(mammal.tree)
+data(mammal.data)
+## extract character of interest
+ln.bodyMass<-log(setNames(mammal.data$bodyMass,
+ rownames(mammal.data)))
+## estimate ancestral body sizes
+fit.BM<-fastAnc(mammal.tree,ln.bodyMass,CI=TRUE)
+print(fit.BM,printlen=10)
+}
+\keyword{ancestral states}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{maximum likelihood}
+\keyword{continuous character}
diff --git a/man/fastBM.Rd b/man/fastBM.Rd
index 16f12eb..ee1cdc5 100644
--- a/man/fastBM.Rd
+++ b/man/fastBM.Rd
@@ -1,43 +1,43 @@
-\name{fastBM}
-\alias{fastBM}
-\title{(Reasonably) fast quantitative trait simulation on phylogenies}
-\usage{
-fastBM(tree, a=0, mu=0, sig2=1, bounds=c(-Inf,Inf), internal=FALSE, nsim=1,
- ...)
-}
-\arguments{
- \item{tree}{is a phylogenetic tree in \code{"phylo"} format.}
- \item{a}{a value for ancestral state at the root node.}
- \item{mu}{an optional value for the mean of random normal changes along branches of the tree - can be used to simulate a trend if \code{mu!=0}.}
- \item{sig2}{instantaneous variance of the BM process, \eqn{\sigma^2}.}
- \item{bounds}{a vector with the lower and upper bounds (respectively) for bounded Brownian simulation - by default simulation is unbounded.}
- \item{internal}{logical value indicating whether or not to return states for internal nodes.}
- \item{nsim}{number of simulations.}
- \item{...}{optional arguments \code{alpha} and \code{theta} used for OU simulation. If \code{alpha} is set then \code{mu} and \code{bounds} are ignored with a warning.}
-}
-\description{
- Simulates one or multiple continuous traits on the tree under various evolutionary models.
-}
-\details{
- This function conducts (reasonably) fast quantitative trait simulation on a phylogeny under several different models: Brownian motion (default), BM with a trend (for \code{mu!=0}), bounds (for \code{bounds!=c(-Inf,} \code{Inf)}), and OU.
-}
-\value{
- A vector (for \code{nsim=1}) or matrix containing the tip states for the \code{n} species in the tree, and (optionally) the ancestral states for internal nodes.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{sim.corrs}}
-}
-\examples{
-## simulate 10 characters on the Anolis tree
-## under Brownian motion
-data(anoletree)
-X<-fastBM(anoletree,nsim=10)
-head(X)
-}
-\keyword{phylogenetics}
-\keyword{simulation}
-\keyword{continuous character}
+\name{fastBM}
+\alias{fastBM}
+\title{(Reasonably) fast quantitative trait simulation on phylogenies}
+\usage{
+fastBM(tree, a=0, mu=0, sig2=1, bounds=c(-Inf,Inf), internal=FALSE, nsim=1,
+ ...)
+}
+\arguments{
+ \item{tree}{is a phylogenetic tree in \code{"phylo"} format.}
+ \item{a}{a value for ancestral state at the root node.}
+ \item{mu}{an optional value for the mean of random normal changes along branches of the tree - can be used to simulate a trend if \code{mu!=0}.}
+ \item{sig2}{instantaneous variance of the BM process, \eqn{\sigma^2}.}
+ \item{bounds}{a vector with the lower and upper bounds (respectively) for bounded Brownian simulation - by default simulation is unbounded.}
+ \item{internal}{logical value indicating whether or not to return states for internal nodes.}
+ \item{nsim}{number of simulations.}
+ \item{...}{optional arguments \code{alpha} and \code{theta} used for OU simulation. If \code{alpha} is set then \code{mu} and \code{bounds} are ignored with a warning.}
+}
+\description{
+ Simulates one or multiple continuous traits on the tree under various evolutionary models.
+}
+\details{
+ This function conducts (reasonably) fast quantitative trait simulation on a phylogeny under several different models: Brownian motion (default), BM with a trend (for \code{mu!=0}), bounds (for \code{bounds!=c(-Inf,} \code{Inf)}), and OU.
+}
+\value{
+ A vector (for \code{nsim=1}) or matrix containing the tip states for the \code{n} species in the tree, and (optionally) the ancestral states for internal nodes.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{sim.corrs}}
+}
+\examples{
+## simulate 10 characters on the Anolis tree
+## under Brownian motion
+data(anoletree)
+X<-fastBM(anoletree,nsim=10)
+head(X)
+}
+\keyword{phylogenetics}
+\keyword{simulation}
+\keyword{continuous character}
diff --git a/man/fastMRCA.Rd b/man/fastMRCA.Rd
index 1dcb60c..6b0628b 100644
--- a/man/fastMRCA.Rd
+++ b/man/fastMRCA.Rd
@@ -1,41 +1,41 @@
-\name{fastMRCA}
-\alias{fastMRCA}
-\alias{fastHeight}
-\alias{fastDist}
-\title{Get the MRCA (or height above the root of the MRCA) of a pair of tip taxa}
-\usage{
-fastMRCA(tree, sp1, sp2)
-fastHeight(tree, sp1, sp2)
-fastDist(tree, sp1, sp2)
-}
-\arguments{
- \item{tree}{an object of class \code{"phylo"}.}
- \item{sp1}{species one name.}
- \item{sp2}{species two name.}
-}
-\description{
- Finds the most recent common ancestor (MRCA) for a pair of tip taxa.
-}
-\details{
- Function (\code{fastMRCA}) returns the most recent common ancestor (node number) for a pair of taxa; or, in the case of \code{fastHeight}, the height above the root of the MRCA of a pair of taxa; or, in the case of \code{fastDist}, the patristic distance between a pair of taxa.
-
- This function is mostly redundant with \code{\link{findMRCA}} (or \code{findMRCA(...,type="height")} in the case of \code{fastHeight}), but for very large trees will be considerably faster.
-
- (Also see \code{\link{getMRCA}} in the \pkg{ape} package.)
-}
-\value{
- The node number of the MRCA, the height above the root (for \code{fastHeight}), or the patristic distance between two taxa (for \code{fastDist}).
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{getMRCA}}, \code{\link{findMRCA}}, \code{\link{mrca}}
-}
-\examples{
-tree<-pbtree(n=2000)
-anc<-fastMRCA(tree,"t1","t15")
-}
-\keyword{phylogenetics}
-\keyword{utilities}
+\name{fastMRCA}
+\alias{fastMRCA}
+\alias{fastHeight}
+\alias{fastDist}
+\title{Get the MRCA (or height above the root of the MRCA) of a pair of tip taxa}
+\usage{
+fastMRCA(tree, sp1, sp2)
+fastHeight(tree, sp1, sp2)
+fastDist(tree, sp1, sp2)
+}
+\arguments{
+ \item{tree}{an object of class \code{"phylo"}.}
+ \item{sp1}{species one name.}
+ \item{sp2}{species two name.}
+}
+\description{
+ Finds the most recent common ancestor (MRCA) for a pair of tip taxa.
+}
+\details{
+ Function (\code{fastMRCA}) returns the most recent common ancestor (node number) for a pair of taxa; or, in the case of \code{fastHeight}, the height above the root of the MRCA of a pair of taxa; or, in the case of \code{fastDist}, the patristic distance between a pair of taxa.
+
+ This function is mostly redundant with \code{\link{findMRCA}} (or \code{findMRCA(...,type="height")} in the case of \code{fastHeight}), but for very large trees will be considerably faster.
+
+ (Also see \code{\link{getMRCA}} in the \pkg{ape} package.)
+}
+\value{
+ The node number of the MRCA, the height above the root (for \code{fastHeight}), or the patristic distance between two taxa (for \code{fastDist}).
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{getMRCA}}, \code{\link{findMRCA}}, \code{\link{mrca}}
+}
+\examples{
+tree<-pbtree(n=2000)
+anc<-fastMRCA(tree,"t1","t15")
+}
+\keyword{phylogenetics}
+\keyword{utilities}
diff --git a/man/findMRCA.Rd b/man/findMRCA.Rd
index 47c2ba7..43288c1 100644
--- a/man/findMRCA.Rd
+++ b/man/findMRCA.Rd
@@ -1,46 +1,46 @@
-\name{findMRCA}
-\alias{findMRCA}
-\title{Get the MRCA of a set of taxa}
-\usage{
-findMRCA(tree, tips=NULL, type=c("node","height"))
-}
-\arguments{
- \item{tree}{a phylogenetic tree as an object of class \code{"phylo"}.}
- \item{tips}{a vector containing a set of tip labels.}
- \item{type}{either \code{"node"} to return the node of the MRCA; or \code{"height"} to return the height above the root of the MRCA of \code{tips}.}
-}
-\description{
- Finds the most recent common ancestor (MRCA) of a set of tips.
-}
-\details{
- This function returns node number of the most recent common ancestor of a set of taxa.
-
- If \code{tips==NULL} and \code{type="node"} (the default) it will return the result of a normal function call to \code{\link{mrca}}.
-
- If \code{tips=NULL} and \code{type="height"} it will return a matrix equal to that produced by \code{\link{vcv.phylo}}.
-
- From \pkg{phytools} 0.5-66 forward, \code{findMRCA} uses \code{\link{getMRCA}} in the \pkg{ape} package internally, which results in a big speed-up. Even though the two functions are thus totally redundant I have left \code{findMRCA} in the package namespace to ensure backward compatibility.
-}
-\value{
- The node number of the MRCA, or a matrix of node numbers (if \code{tips==NULL}) - for \code{type="node"}; or the height of the MRCA, or a matrix of heights (if \code{tips==NULL}) - for \code{type="height"}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{findMRCA}}, \code{\link{mrca}}
-}
-\examples{
-data(anoletree)
-anc<-findMRCA(anoletree,c("cristatellus","cooki",
- "gundlachi"))
-plotTree(anoletree,type="fan",fsize=0.7,lwd=1)
-nodelabels(node=anc,frame="circle",pch=21,cex=1.5,
- bg="blue")
-legend("topleft","common ancestor of\nPuerto Rican TG anoles",
- pch=21,pt.cex=1.5,pt.bg="blue",cex=0.7,bty="n")
-par(mar=c(5.1,4.1,4.1,2.1)) ## reset margin to default
-}
-\keyword{phylogenetics}
-\keyword{utilities}
+\name{findMRCA}
+\alias{findMRCA}
+\title{Get the MRCA of a set of taxa}
+\usage{
+findMRCA(tree, tips=NULL, type=c("node","height"))
+}
+\arguments{
+ \item{tree}{a phylogenetic tree as an object of class \code{"phylo"}.}
+ \item{tips}{a vector containing a set of tip labels.}
+ \item{type}{either \code{"node"} to return the node of the MRCA; or \code{"height"} to return the height above the root of the MRCA of \code{tips}.}
+}
+\description{
+ Finds the most recent common ancestor (MRCA) of a set of tips.
+}
+\details{
+ This function returns node number of the most recent common ancestor of a set of taxa.
+
+ If \code{tips==NULL} and \code{type="node"} (the default) it will return the result of a normal function call to \code{\link{mrca}}.
+
+ If \code{tips=NULL} and \code{type="height"} it will return a matrix equal to that produced by \code{\link{vcv.phylo}}.
+
+ From \pkg{phytools} 0.5-66 forward, \code{findMRCA} uses \code{\link{getMRCA}} in the \pkg{ape} package internally, which results in a big speed-up. Even though the two functions are thus totally redundant I have left \code{findMRCA} in the package namespace to ensure backward compatibility.
+}
+\value{
+ The node number of the MRCA, or a matrix of node numbers (if \code{tips==NULL}) - for \code{type="node"}; or the height of the MRCA, or a matrix of heights (if \code{tips==NULL}) - for \code{type="height"}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{findMRCA}}, \code{\link{mrca}}
+}
+\examples{
+data(anoletree)
+anc<-findMRCA(anoletree,c("cristatellus","cooki",
+ "gundlachi"))
+plotTree(anoletree,type="fan",fsize=0.7,lwd=1)
+nodelabels(node=anc,frame="circle",pch=21,cex=1.5,
+ bg="blue")
+legend("topleft","common ancestor of\nPuerto Rican TG anoles",
+ pch=21,pt.cex=1.5,pt.bg="blue",cex=0.7,bty="n")
+par(mar=c(5.1,4.1,4.1,2.1)) ## reset margin to default
+}
+\keyword{phylogenetics}
+\keyword{utilities}
diff --git a/man/fit.bd.Rd b/man/fit.bd.Rd
index 1dda8db..1b94bba 100644
--- a/man/fit.bd.Rd
+++ b/man/fit.bd.Rd
@@ -1,82 +1,82 @@
-\name{fit.bd}
-\alias{fit.bd}
-\alias{fit.yule}
-\alias{lik.bd}
-\alias{print.fit.bd}
-\title{Fits birth-death (speciation/extinction) model to reconstructed phylogeny}
-\usage{
-fit.bd(tree, b=NULL, d=NULL, rho=1, ...)
-fit.yule(tree, b=NULL, d=NULL, rho=1, ...)
-lik.bd(theta, t, rho=1, N=NULL)
-\method{print}{fit.bd}(x, ...)
-}
-\arguments{
- \item{tree}{object of class \code{"phylo"}.}
- \item{b}{birth (speciation) rate. Presently doesn't do anything as the rate cannot be fixed.}
- \item{d}{death (extinction) rate. Presently doesn't do anything as the rate cannot be fixed.}
- \item{rho}{sampling fraction.}
- \item{theta}{vector of \code{b} and \code{d} for likelihood function.}
- \item{t}{branching times for calculation of the likelihood.}
- \item{N}{number of tips in the tree.}
- \item{x}{object of class \code{"fit.bd"} for \code{print} method.}
- \item{...}{optional arguments.}
-}
-\description{
- Fits a birth-death (\code{fit.bd}) or pure-birth (\code{fit.yule}) model to a reconstructed phylogenetic tree with branch lengths.
-}
-\details{
- The function \code{fit.bd} fits a birth-death model to a phylogenetic tree with edge lengths and a (potentially) incomplete sampling fraction.
-
- The function \code{fit.yule} fits a pure-birth model with a (potentially) incomplete sampling fraction.
-
- The function \code{lik.bd} computes the likelihood of a set of birth & death rates given the set of branching times computed for a tree and a sampling fraction.
-}
-\value{
- \code{fit.bd} returns an object of class \code{"fit.bd"} which can be printed. This object is a list containing the fitted model parameters, likelihood, optimization conditions, a summary of the optimization, and a likelihood function.
-
- \code{fit.yule} returns an object of class \code{"fit.yule"}. This object is a list containing the fitted model parameter, likelihood, optimization conditions, a summary of the optimization, and a likelihood function.
-}
-\references{
- Nee, S., May, R. M. and Harvey, P. H. (1994) The reconstructed evolutionary process. \emph{Philosophical Transactions of the Royal Society of London B}, \bold{344}, 305-311.
-
- Stadler, T. (2012) How can we improve the accuracy of macroevolutionary rate estimates? \emph{Systematic Biology}, \bold{62}, 321-329.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{birthdeath}}
-}
-\examples{
-data(salamanders)
-## compute sampling fraction based on 55 species of Plethodon
-sampling.f<-Ntip(salamanders)/55
-## fit birth-death model
-bd.fit<-fit.bd(salamanders,rho=sampling.f)
-print(bd.fit)
-## fit Yule model
-yule.fit<-fit.yule(salamanders,rho=sampling.f)
-print(yule.fit)
-## compare b-d and yule models
-anova(yule.fit,bd.fit)
-## create a likelihood surface for b-d model
-ngrid<-100
-b<-seq(0.01,0.06,length.out=ngrid)
-d<-seq(0.005,0.03,length.out=ngrid)
-logL<-sapply(d,function(d,b) sapply(b,function(b,d)
- bd.fit$lik(c(b,d)),d=d),b=b)
-contour(x=b,y=d,logL,nlevels=100,
- xlab=expression(lambda),
- ylab=expression(mu),bty="l")
-title(main="Likelihood surface for plethodontid diversification",
- font.main=3)
-points(bd.fit$b,bd.fit$d,cex=1.5,pch=4,
- col="blue",lwd=2)
-legend("bottomright","ML solution",pch=4,col="blue",
- bg="white",pt.cex=1.5,pt.lwd=2)
-}
-\keyword{comparative methods}
-\keyword{diversification}
-\keyword{phylogenetics}
-\keyword{diversification}
-\keyword{maximum likelihood}
+\name{fit.bd}
+\alias{fit.bd}
+\alias{fit.yule}
+\alias{lik.bd}
+\alias{print.fit.bd}
+\title{Fits birth-death (speciation/extinction) model to reconstructed phylogeny}
+\usage{
+fit.bd(tree, b=NULL, d=NULL, rho=1, ...)
+fit.yule(tree, b=NULL, d=NULL, rho=1, ...)
+lik.bd(theta, t, rho=1, N=NULL)
+\method{print}{fit.bd}(x, ...)
+}
+\arguments{
+ \item{tree}{object of class \code{"phylo"}.}
+ \item{b}{birth (speciation) rate. Presently doesn't do anything as the rate cannot be fixed.}
+ \item{d}{death (extinction) rate. Presently doesn't do anything as the rate cannot be fixed.}
+ \item{rho}{sampling fraction.}
+ \item{theta}{vector of \code{b} and \code{d} for likelihood function.}
+ \item{t}{branching times for calculation of the likelihood.}
+ \item{N}{number of tips in the tree.}
+ \item{x}{object of class \code{"fit.bd"} for \code{print} method.}
+ \item{...}{optional arguments.}
+}
+\description{
+ Fits a birth-death (\code{fit.bd}) or pure-birth (\code{fit.yule}) model to a reconstructed phylogenetic tree with branch lengths.
+}
+\details{
+ The function \code{fit.bd} fits a birth-death model to a phylogenetic tree with edge lengths and a (potentially) incomplete sampling fraction.
+
+ The function \code{fit.yule} fits a pure-birth model with a (potentially) incomplete sampling fraction.
+
+ The function \code{lik.bd} computes the likelihood of a set of birth & death rates given the set of branching times computed for a tree and a sampling fraction.
+}
+\value{
+ \code{fit.bd} returns an object of class \code{"fit.bd"} which can be printed. This object is a list containing the fitted model parameters, likelihood, optimization conditions, a summary of the optimization, and a likelihood function.
+
+ \code{fit.yule} returns an object of class \code{"fit.yule"}. This object is a list containing the fitted model parameter, likelihood, optimization conditions, a summary of the optimization, and a likelihood function.
+}
+\references{
+ Nee, S., May, R. M. and Harvey, P. H. (1994) The reconstructed evolutionary process. \emph{Philosophical Transactions of the Royal Society of London B}, \bold{344}, 305-311.
+
+ Stadler, T. (2012) How can we improve the accuracy of macroevolutionary rate estimates? \emph{Systematic Biology}, \bold{62}, 321-329.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{birthdeath}}
+}
+\examples{
+data(salamanders)
+## compute sampling fraction based on 55 species of Plethodon
+sampling.f<-Ntip(salamanders)/55
+## fit birth-death model
+bd.fit<-fit.bd(salamanders,rho=sampling.f)
+print(bd.fit)
+## fit Yule model
+yule.fit<-fit.yule(salamanders,rho=sampling.f)
+print(yule.fit)
+## compare b-d and yule models
+anova(yule.fit,bd.fit)
+## create a likelihood surface for b-d model
+ngrid<-100
+b<-seq(0.01,0.06,length.out=ngrid)
+d<-seq(0.005,0.03,length.out=ngrid)
+logL<-sapply(d,function(d,b) sapply(b,function(b,d)
+ bd.fit$lik(c(b,d)),d=d),b=b)
+contour(x=b,y=d,logL,nlevels=100,
+ xlab=expression(lambda),
+ ylab=expression(mu),bty="l")
+title(main="Likelihood surface for plethodontid diversification",
+ font.main=3)
+points(bd.fit$b,bd.fit$d,cex=1.5,pch=4,
+ col="blue",lwd=2)
+legend("bottomright","ML solution",pch=4,col="blue",
+ bg="white",pt.cex=1.5,pt.lwd=2)
+}
+\keyword{comparative methods}
+\keyword{diversification}
+\keyword{phylogenetics}
+\keyword{diversification}
+\keyword{maximum likelihood}
diff --git a/man/fitBayes.Rd b/man/fitBayes.Rd
index eabe1c2..522ef23 100644
--- a/man/fitBayes.Rd
+++ b/man/fitBayes.Rd
@@ -1,35 +1,35 @@
-\name{fitBayes}
-\alias{fitBayes}
-\title{Evolutionary model fitting with intraspecific variability using Bayesian MCMC}
-\usage{
-fitBayes(tree, x, ngen=10000, model="BM", method="reduced", control=list())
-}
-\arguments{
- \item{tree}{an object of class \code{"phylo"}.}
- \item{x}{a vector of phenotypic values for individuals; \code{names(x)} should contain the species names (not individual IDs).}
- \item{ngen}{a integer indicating the number of generations for the MCMC.}
- \item{model}{an evolutionary model: either \code{"BM"} or \code{"lambda"}.}
- \item{method}{a method: either \code{"reduced"} or \code{"full"}.}
- \item{control}{a list of control parameters containing the following elements: \code{sig2}: starting value for \eqn{\sigma^2} (BM rate); \code{lambda}: starting value for the \eqn{\lambda} parameter; \code{a}: starting for the state at the root node; \code{xbar}: starting values for the states at the tips; \code{intV}: starting value for the intraspecific variance (reduced method); or \code{v}: starting value for the vector of intraspecific variances for all species (full method); \code{pr.mean}: means for the prior distributions in the following order - \code{sig2}, \code{lambda} (if applicable), \code{a}, \code{xbar}, \code{intV} or \code{v} (if applicable), note that the prior probability distribution is exponential for \code{sig2} and normal for \code{a} and \code{y}; \code{pr.var}: variances on the prior distributions, same order as \code{pr.mean}.}
-}
-\description{
- \code{fitBayes} uses Bayesian MCMC to sample terminal states (species means) as well as the parameters of an evolutionary model from their joint posterior distribution, following Revell & Reynolds (2012).
-}
-\value{
- An object of class \code{"fitBayes"} that includes a matrix (\code{mcmc}) with a number of rows \code{ngen/control$sample+1} containing the posterior sample and likelihoods.
-
- Matrix columns are labeled by species (for species means and variances), or by the corresponding evolutionary parameter.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-
- Revell, L. J. and R. G. Reynolds. (2012) A new Bayesian method for fitting evolutionary models to comparative data with intraspecific variation. \emph{Evolution}, 66, 2697-2707.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{anc.Bayes}}, \code{\link{brownie.lite}}, \code{\link{evol.rate.mcmc}}
-}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{bayesian}
-\keyword{continuous character}
+\name{fitBayes}
+\alias{fitBayes}
+\title{Evolutionary model fitting with intraspecific variability using Bayesian MCMC}
+\usage{
+fitBayes(tree, x, ngen=10000, model="BM", method="reduced", control=list())
+}
+\arguments{
+ \item{tree}{an object of class \code{"phylo"}.}
+ \item{x}{a vector of phenotypic values for individuals; \code{names(x)} should contain the species names (not individual IDs).}
+ \item{ngen}{a integer indicating the number of generations for the MCMC.}
+ \item{model}{an evolutionary model: either \code{"BM"} or \code{"lambda"}.}
+ \item{method}{a method: either \code{"reduced"} or \code{"full"}.}
+ \item{control}{a list of control parameters containing the following elements: \code{sig2}: starting value for \eqn{\sigma^2} (BM rate); \code{lambda}: starting value for the \eqn{\lambda} parameter; \code{a}: starting for the state at the root node; \code{xbar}: starting values for the states at the tips; \code{intV}: starting value for the intraspecific variance (reduced method); or \code{v}: starting value for the vector of intraspecific variances for all species (full method); \code{pr.mean}: means for the prior distributions in the following order - \code{sig2}, \code{lambda} (if applicable), \code{a}, \code{xbar}, \code{intV} or \code{v} (if applicable), note that the prior probability distribution is exponential for \code{sig2} and normal for \code{a} and \code{y}; \code{pr.var}: variances on the prior distributions, same order as \code{pr.mean}.}
+}
+\description{
+ \code{fitBayes} uses Bayesian MCMC to sample terminal states (species means) as well as the parameters of an evolutionary model from their joint posterior distribution, following Revell & Reynolds (2012).
+}
+\value{
+ An object of class \code{"fitBayes"} that includes a matrix (\code{mcmc}) with a number of rows \code{ngen/control$sample+1} containing the posterior sample and likelihoods.
+
+ Matrix columns are labeled by species (for species means and variances), or by the corresponding evolutionary parameter.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+
+ Revell, L. J. and R. G. Reynolds. (2012) A new Bayesian method for fitting evolutionary models to comparative data with intraspecific variation. \emph{Evolution}, 66, 2697-2707.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{anc.Bayes}}, \code{\link{brownie.lite}}, \code{\link{evol.rate.mcmc}}
+}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{bayesian}
+\keyword{continuous character}
diff --git a/man/fitDiversityModel.Rd b/man/fitDiversityModel.Rd
index 98bf99b..87c9097 100644
--- a/man/fitDiversityModel.Rd
+++ b/man/fitDiversityModel.Rd
@@ -1,43 +1,43 @@
-\name{fitDiversityModel}
-\alias{fitDiversityModel}
-\alias{logLik.fitDiversityModel}
-\alias{print.fitDiversityModel}
-\title{Fit diversity-dependent phenotypic evolution model}
-\usage{
-fitDiversityModel(tree, x, d=NULL, showTree=TRUE, tol=1e-6)
-\method{logLik}{fitDiversityModel}(object, ...)
-\method{print}{fitDiversityModel}(x, ...)
-}
-\arguments{
- \item{tree}{an object of class \code{"phylo"}.}
- \item{x}{a vector with tip values for a continuously distributed trait. For \code{print} method, an object of class \code{"fitDiversityModel"}.}
- \item{d}{a vector containing the inferred historical diversity at each node in the tree - if \code{d=NULL} (the default) function will treat the diversification as if it occurred in a single geographic area.}
- \item{showTree}{optional logical value indicating whether to plot the tree transformation implied by the model.}
- \item{tol}{some small value by which \code{d} is incremented during rescaling of \code{psi} for optimization. If R thinks your matrices are singular during optimization, try increasing \code{tol} slightly.}
- \item{object}{for \code{logLik} method, an object of class \code{"fitDiversityModel"}.}
- \item{...}{optional arguments for \code{logLik} and \code{print} methods. Note that for the \code{logLik} method the number of fitted parameters (\code{"df"}) is assumed to be 3 for the diversity dependent model (that is, if \code{psi} is estimated) and 2 for the diversity independent model, unless otherwise specified (using the argument \code{df}).}
-}
-\description{
- Fits a diversity-dependent phenotypic evolution model (similar to Mahler et al. 2010).
-}
-\value{
- An object of class \code{"fitDiversityModel"} consisting of the following elements:
- \item{logL}{log-likelihood of the fitted model.}
- \item{sig0}{estimated starting value for the rate at the root of the tree, \eqn{\sigma_0^2}.}
- \item{psi}{the estimated rate of change in the rate associated with the addition of a lineage.}
- \item{vcv}{a matrix with the variances and covariance of the estimated parameters (from the Hessian).}
-}
-\references{
- Mahler, D. L, L. J. Revell, R. E. Glor, and J. B. Losos. 2010. Ecological opportunity and the rate of morphological evolution in the diversification of Greater Antillean anoles. \emph{Evolution}, \bold{64}, 2731-2745.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{brownie.lite}}, \code{\link{estDiversity}}, \code{\link{evol.rate.mcmc}}
-}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{maximum likelihood}
-\keyword{continuous character}
-\keyword{diversification}
+\name{fitDiversityModel}
+\alias{fitDiversityModel}
+\alias{logLik.fitDiversityModel}
+\alias{print.fitDiversityModel}
+\title{Fit diversity-dependent phenotypic evolution model}
+\usage{
+fitDiversityModel(tree, x, d=NULL, showTree=TRUE, tol=1e-6)
+\method{logLik}{fitDiversityModel}(object, ...)
+\method{print}{fitDiversityModel}(x, ...)
+}
+\arguments{
+ \item{tree}{an object of class \code{"phylo"}.}
+ \item{x}{a vector with tip values for a continuously distributed trait. For \code{print} method, an object of class \code{"fitDiversityModel"}.}
+ \item{d}{a vector containing the inferred historical diversity at each node in the tree - if \code{d=NULL} (the default) function will treat the diversification as if it occurred in a single geographic area.}
+ \item{showTree}{optional logical value indicating whether to plot the tree transformation implied by the model.}
+ \item{tol}{some small value by which \code{d} is incremented during rescaling of \code{psi} for optimization. If R thinks your matrices are singular during optimization, try increasing \code{tol} slightly.}
+ \item{object}{for \code{logLik} method, an object of class \code{"fitDiversityModel"}.}
+ \item{...}{optional arguments for \code{logLik} and \code{print} methods. Note that for the \code{logLik} method the number of fitted parameters (\code{"df"}) is assumed to be 3 for the diversity dependent model (that is, if \code{psi} is estimated) and 2 for the diversity independent model, unless otherwise specified (using the argument \code{df}).}
+}
+\description{
+ Fits a diversity-dependent phenotypic evolution model (similar to Mahler et al. 2010).
+}
+\value{
+ An object of class \code{"fitDiversityModel"} consisting of the following elements:
+ \item{logL}{log-likelihood of the fitted model.}
+ \item{sig0}{estimated starting value for the rate at the root of the tree, \eqn{\sigma_0^2}.}
+ \item{psi}{the estimated rate of change in the rate associated with the addition of a lineage.}
+ \item{vcv}{a matrix with the variances and covariance of the estimated parameters (from the Hessian).}
+}
+\references{
+ Mahler, D. L, L. J. Revell, R. E. Glor, and J. B. Losos. 2010. Ecological opportunity and the rate of morphological evolution in the diversification of Greater Antillean anoles. \emph{Evolution}, \bold{64}, 2731-2745.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{brownie.lite}}, \code{\link{estDiversity}}, \code{\link{evol.rate.mcmc}}
+}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{maximum likelihood}
+\keyword{continuous character}
+\keyword{diversification}
diff --git a/man/fitMk.Rd b/man/fitMk.Rd
index 1cc0d4b..ad1ae22 100644
--- a/man/fitMk.Rd
+++ b/man/fitMk.Rd
@@ -1,128 +1,128 @@
-\name{fitMk}
-\alias{fitMk}
-\alias{plot.fitMk}
-\alias{plot.gfit}
-\alias{fitmultiMk}
-\alias{fitpolyMk}
-\alias{graph.polyMk}
-\alias{plot.fitpolyMk}
-\alias{mcmcMk}
-\alias{plot.mcmcMk}
-\alias{density.mcmcMk}
-\alias{plot.density.mcmcMk}
-\alias{fitHRM}
-\alias{plot.fitHRM}
-\alias{fitMk.parallel}
-\title{Fits extended M\emph{k} model for discrete character evolution}
-\usage{
-fitMk(tree, x, model="SYM", fixedQ=NULL, ...)
-\method{plot}{fitMk}(x, ...)
-\method{plot}{gfit}(x, ...)
-fitmultiMk(tree, x, model="ER", ...)
-fitpolyMk(tree, x, model="SYM", ordered=FALSE, ...)
-graph.polyMk(k=2, model="SYM", ordered=FALSE, ...)
-\method{plot}{fitpolyMk}(x, ...)
-mcmcMk(tree, x, model="ER", ngen=10000, ...)
-\method{plot}{mcmcMk}(x, ...)
-\method{density}{mcmcMk}(x, ...)
-\method{plot}{density.mcmcMk}(x, ...)
-fitHRM(tree, x, model="ARD", ncat=2, ...)
-\method{plot}{fitHRM}(x, ...)
-fitMk.parallel(tree, x, model="SYM", ncores=1, ...)
-}
-\arguments{
- \item{tree}{an object of class \code{"phylo"}. In the case of \code{fitmultiMk} an object of class \code{"simmap"} with a mapped discrete character.}
- \item{x}{a vector of tip values for species; \code{names(x)} should be the species names. In the case of \code{plot} and \code{density} methods, an object of the appropriate class.}
- \item{model}{model. See \code{make.simmap} or \code{ace} for details.}
- \item{fixedQ}{fixed value of transition matrix \code{Q}, if one is desired.}
- \item{ordered}{for \code{fitpolyMk}, a logical value indicating whether or not the character should be treated as ordered. For now the function assumes alphanumerical order (i.e., numbers sorted by their initial and then successive digits followed by characters or character strings in alphabetical order).}
- \item{k}{For \code{graph.polyMk}, the number of monomorphic states for the discrete trait.}
- \item{ngen}{number of generations of MCMC for \code{mcmcMk}.}
- \item{ncat}{number of rate categories (per level of the discrete trait) in the hidden-rate model.}
- \item{ncores}{number of cores for \code{fitMk.parallel}.}
- \item{...}{optional arguments, including \code{pi}, the prior distribution at the root node (defaults to \code{pi="equal"}). Other options for \code{pi} include \code{pi="fitzjohn"} (which implements the prior distribution of Fitzjohn et al. 2009), \code{pi="estimated"} (which finds the stationary distribution of state frequencies and sets that as the prior), or an arbitrary prior distribution specified by the user. For \code{plot} method optional arguments include (but may not be limited to): \code{signif}, the number of digits for the rates to be plotted; \code{main}, a character vector of length two with the headings for each subplot; \code{cex.main}, \code{cex.traits}, and \code{cex.rates}, font sizes for the various text elements of the plot; and \code{show.zeros}, a logical argument specifying whether or not to plot arrows with the ML estimated transition rate is not different from zero (with tolerance specified by the optional argument \code{tol}). Finally, for \code{fitpolyMk}, both \code{order} (an evolutionary sequence for the monomorphic condition) and \code{max.poly} can be set for the \code{ordered=TRUE} model. If not set, \code{order} defaults to alphanumeric order, and \code{max.poly} defaults to the highest level of polymorphism observed in the data.}
-}
-\description{
- The functions \code{fitMk}, \code{fitmultiMk}, \code{fitpolyMk}, \code{fitHRM}, \code{fitMk.parallel}, and \code{mcmcMk} fit various flavors of the extended M\emph{k} model (Lewis, 2001) for discrete character evolution on a reconstructed phylogeny.
-}
-\details{
- The function \code{fitMk} fits a so-called extended M\emph{k} model for discrete character evolution (Lewis, 2001).
-
- \code{plot.fitMk} plots an object of class \code{"fitMk"} returned by \code{fitMk}. \code{plot.gfit} plots an object of class \code{"gfit"} from \pkg{geiger}'s \code{fitDiscrete} function. Both plots portray the fitted model using a graph of arrows connecting states.
-
- The function \code{fitmultiMk} fits an M\emph{k} model in which the transition rates between character states are allowed to vary depending on the mapped state of a discrete character on the tree. It can be combined with, for example, \code{\link{paintSubTree}} to test hypotheses about how the process of discrete character evolution for \code{x} varies between different parts of the tree.
-
- The function \code{fitpolyMk} fits an M\emph{k} model to data for a discrete character with intraspecific polymorphism. Polymorphic species should be coded with the name of the two or more states recorded for the species separated by a plus sign \code{+} (e.g., \code{A+B} would indicate that both states \code{A} and \code{B} are found in the corresponding taxon). Invariably it's assumed that transitions between states must occur through a polymorphic condition, whereas transitions \emph{cannot} occur directly between two incompatible polymorphic conditions. For instance, a transition between \code{A+B} and \code{B+C} would have to occur through the monomorphic state \code{B}. At time of writing, this function permits the models \code{"ER"} (equal rates for all permitted transitions), \code{"SYM"} (symmetric backward & forward rates for all permitted transitions), \code{"ARD"} (all-rates-different for permitted transitions), and a new model called \code{"transient"} in which the acquisition of polymorphism (e.g., \code{A -> A+B}) is assumed to occur at a different rate than its loss (e.g., \code{A+B -> B}). The method \code{plot.fitpolyMk} plots the fitted M\emph{k} model with intraspecific polymorphism.
-
- The function \code{mcmcMk} runs a Bayesian MCMC version of \code{fitMk}. The shape of the prior distribution of the transition rates is \eqn{\Gamma}, with \eqn{\alpha} and \eqn{\beta} via the argument \code{prior}, which takes the form of a list. The default value of \eqn{\alpha} is 0.1, and \eqn{\beta} defaults to a value such tha \eqn{\alpha/\beta} is equal to the parsimony score for \code{x} divided by the sum of the edge lengths of the tree. The shape of the proposal distribution is normal, with mean zero and a variance that can be controlled by the user via the optional argument \code{prior.var}. The argument \code{auto.tune}, if \code{TRUE} or \code{FALSE}, indicates whether or not to 'tune' the proposal variance up or down to target a particular acceptance rate (defaults to 0.5). \code{auto.tune} can also be a numeric value between 0 and 1, in which case this value will be the target acceptance ratio. The argument \code{plot} indicates whether the progress of the MCMC should be plotted (defaults to \code{TRUE}, but runs much faster when set to \code{FALSE}).
-
- The method \code{plot.mcmcMk} plots a log-likelihood trace and a trace of the rate parameters from the MCMC. (This the same graph that is created by setting \code{plot=TRUE} in \code{mcmcMk}.) The method \code{density.mcmcMk} computes a posterior density on the transition rates in the model from the posterior sample obtained in the MCMC, will import the package \pkg{coda} if it is available, and returns an object of class \code{"density.mcmcMk"}. Finally, the method \code{plot.density.mcmcMk} creates a plot of the posterior density (or a set of plots) for the transition rates between states.
-
- Finally, the function \code{fitHRM} fits a hidden-rate M\emph{k} model following Beaulieu et al. (2013). For the hidden-rate model we need to specify a number of rate categories for each level of the trait - and this can be a vector of different values for each trait. We can also choose a model (\code{"ER"}, \code{"SYM"}, or \code{"ARD"}), as well as whether or not to treat the character as a 'threshold' trait (\code{umbral=TRUE}, defaults to \code{FALSE}). This latter model is basically one that allows absorbing conditions for some hidden states. Since this can be a difficult optimization problem, the optional argument \code{niter} sets the number of optimization iterations to be run. \code{niter} defaults to \code{niter=10}.
-
- Note that both \code{fitMk} and \code{fitmultiMk} recycle code from \code{\link{ace}} in the \pkg{ape} package for computing the likelihood. \code{fitpolyMk}, \code{mcmcMk}, and \code{fitHRM} use \code{fitMk} internally to compute the likelihood.
-}
-\value{
- An object of class \code{"fitMk"}, \code{"fitmultiMk"}, \code{"fitpolyMk"}, \code{"mcmcMk"}, or \code{"fitHRM"}. In the case of \code{density.mcmcMk} an object of class \code{"density.mcmcMk"}.
-
- \code{plot.fitMk}, \code{plot.gfit}, and \code{plot.HRM} invisibly return the coordinates of vertices of the plotted \bold{Q}-matrix.
-}
-\references{
- Beaulieu, J. M., B. C. O'Meara, and M. J. Donoghue (2013) Identifying hidden rate changes in the evolution of a binary morphological character: The evolution of plant habit in campanulid angiosperms. \emph{Systematic Biology}, \bold{62}, 725-737.
-
- Fitzjohn, R. G., W. P. Maddison, and S. P. Otto (2009) Estimating trait-dependent speciation and extinction rates from incompletely resolved phylogenies. \emph{Systematic Biology}, \bold{58}, 595-611.
-
- Lewis, P. O. (2001) A likelihood approach to estimating phylogeny from discrete morphological character data. \emph{Systematic Biology}, \bold{50}, 913-925.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{ace}}, \code{\link{make.simmap}}
-}
-\examples{
-## load tree and data from Revell & Collar (2009)
-data(sunfish.tree)
-data(sunfish.data)
-## extract discrete character (feeding mode)
-fmode<-setNames(sunfish.data$feeding.mode,
- rownames(sunfish.data))
-## fit "ER" model
-fit.ER<-fitMk(sunfish.tree,fmode,model="ER")
-print(fit.ER)
-## fit "ARD" model
-fit.ARD<-fitMk(sunfish.tree,fmode,model="ARD")
-print(fit.ARD)
-## compare the models
-AIC(fit.ER,fit.ARD)
-
-## load tree and data from Benitez-Alvarez et al. (2000)
-data(flatworm.data)
-data(flatworm.tree)
-## extract discrete character (habitat)
-habitat<-setNames(flatworm.data$Habitat,
- rownames(flatworm.data))
-## fit polymorphic models "ER" and "transient"
-fitpoly.ER<-fitpolyMk(flatworm.tree,habitat,
- model="ER")
-fitpoly.transient<-fitpolyMk(flatworm.tree,habitat,
- model="transient")
-## print fitted models
-print(fitpoly.ER)
-print(fitpoly.transient)
-## compare model
-AIC(fitpoly.ER,fitpoly.transient)
-## plot models
-par(mfrow=c(2,1))
-plot(fitpoly.ER)
-mtext("a) ER polymorphic model",adj=0,line=1)
-plot(fitpoly.transient)
-mtext("b) Transient polymorphic model",adj=0,
- line=1)
-par(mfrow=c(1,1))
-}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{maximum likelihood}
-\keyword{bayesian}
-\keyword{discrete character}
+\name{fitMk}
+\alias{fitMk}
+\alias{plot.fitMk}
+\alias{plot.gfit}
+\alias{fitmultiMk}
+\alias{fitpolyMk}
+\alias{graph.polyMk}
+\alias{plot.fitpolyMk}
+\alias{mcmcMk}
+\alias{plot.mcmcMk}
+\alias{density.mcmcMk}
+\alias{plot.density.mcmcMk}
+\alias{fitHRM}
+\alias{plot.fitHRM}
+\alias{fitMk.parallel}
+\title{Fits extended M\emph{k} model for discrete character evolution}
+\usage{
+fitMk(tree, x, model="SYM", fixedQ=NULL, ...)
+\method{plot}{fitMk}(x, ...)
+\method{plot}{gfit}(x, ...)
+fitmultiMk(tree, x, model="ER", ...)
+fitpolyMk(tree, x, model="SYM", ordered=FALSE, ...)
+graph.polyMk(k=2, model="SYM", ordered=FALSE, ...)
+\method{plot}{fitpolyMk}(x, ...)
+mcmcMk(tree, x, model="ER", ngen=10000, ...)
+\method{plot}{mcmcMk}(x, ...)
+\method{density}{mcmcMk}(x, ...)
+\method{plot}{density.mcmcMk}(x, ...)
+fitHRM(tree, x, model="ARD", ncat=2, ...)
+\method{plot}{fitHRM}(x, ...)
+fitMk.parallel(tree, x, model="SYM", ncores=1, ...)
+}
+\arguments{
+ \item{tree}{an object of class \code{"phylo"}. In the case of \code{fitmultiMk} an object of class \code{"simmap"} with a mapped discrete character.}
+ \item{x}{a vector of tip values for species; \code{names(x)} should be the species names. In the case of \code{plot} and \code{density} methods, an object of the appropriate class.}
+ \item{model}{model. See \code{make.simmap} or \code{ace} for details.}
+ \item{fixedQ}{fixed value of transition matrix \code{Q}, if one is desired.}
+ \item{ordered}{for \code{fitpolyMk}, a logical value indicating whether or not the character should be treated as ordered. For now the function assumes alphanumerical order (i.e., numbers sorted by their initial and then successive digits followed by characters or character strings in alphabetical order).}
+ \item{k}{For \code{graph.polyMk}, the number of monomorphic states for the discrete trait.}
+ \item{ngen}{number of generations of MCMC for \code{mcmcMk}.}
+ \item{ncat}{number of rate categories (per level of the discrete trait) in the hidden-rate model.}
+ \item{ncores}{number of cores for \code{fitMk.parallel}.}
+ \item{...}{optional arguments, including \code{pi}, the prior distribution at the root node (defaults to \code{pi="equal"}). Other options for \code{pi} include \code{pi="fitzjohn"} (which implements the prior distribution of Fitzjohn et al. 2009), \code{pi="estimated"} (which finds the stationary distribution of state frequencies and sets that as the prior), or an arbitrary prior distribution specified by the user. For \code{plot} method optional arguments include (but may not be limited to): \code{signif}, the number of digits for the rates to be plotted; \code{main}, a character vector of length two with the headings for each subplot; \code{cex.main}, \code{cex.traits}, and \code{cex.rates}, font sizes for the various text elements of the plot; and \code{show.zeros}, a logical argument specifying whether or not to plot arrows with the ML estimated transition rate is not different from zero (with tolerance specified by the optional argument \code{tol}). Finally, for \code{fitpolyMk}, both \code{order} (an evolutionary sequence for the monomorphic condition) and \code{max.poly} can be set for the \code{ordered=TRUE} model. If not set, \code{order} defaults to alphanumeric order, and \code{max.poly} defaults to the highest level of polymorphism observed in the data.}
+}
+\description{
+ The functions \code{fitMk}, \code{fitmultiMk}, \code{fitpolyMk}, \code{fitHRM}, \code{fitMk.parallel}, and \code{mcmcMk} fit various flavors of the extended M\emph{k} model (Lewis, 2001) for discrete character evolution on a reconstructed phylogeny.
+}
+\details{
+ The function \code{fitMk} fits a so-called extended M\emph{k} model for discrete character evolution (Lewis, 2001).
+
+ \code{plot.fitMk} plots an object of class \code{"fitMk"} returned by \code{fitMk}. \code{plot.gfit} plots an object of class \code{"gfit"} from \pkg{geiger}'s \code{fitDiscrete} function. Both plots portray the fitted model using a graph of arrows connecting states.
+
+ The function \code{fitmultiMk} fits an M\emph{k} model in which the transition rates between character states are allowed to vary depending on the mapped state of a discrete character on the tree. It can be combined with, for example, \code{\link{paintSubTree}} to test hypotheses about how the process of discrete character evolution for \code{x} varies between different parts of the tree.
+
+ The function \code{fitpolyMk} fits an M\emph{k} model to data for a discrete character with intraspecific polymorphism. Polymorphic species should be coded with the name of the two or more states recorded for the species separated by a plus sign \code{+} (e.g., \code{A+B} would indicate that both states \code{A} and \code{B} are found in the corresponding taxon). Invariably it's assumed that transitions between states must occur through a polymorphic condition, whereas transitions \emph{cannot} occur directly between two incompatible polymorphic conditions. For instance, a transition between \code{A+B} and \code{B+C} would have to occur through the monomorphic state \code{B}. At time of writing, this function permits the models \code{"ER"} (equal rates for all permitted transitions), \code{"SYM"} (symmetric backward & forward rates for all permitted transitions), \code{"ARD"} (all-rates-different for permitted transitions), and a new model called \code{"transient"} in which the acquisition of polymorphism (e.g., \code{A -> A+B}) is assumed to occur at a different rate than its loss (e.g., \code{A+B -> B}). The method \code{plot.fitpolyMk} plots the fitted M\emph{k} model with intraspecific polymorphism.
+
+ The function \code{mcmcMk} runs a Bayesian MCMC version of \code{fitMk}. The shape of the prior distribution of the transition rates is \eqn{\Gamma}, with \eqn{\alpha} and \eqn{\beta} via the argument \code{prior}, which takes the form of a list. The default value of \eqn{\alpha} is 0.1, and \eqn{\beta} defaults to a value such tha \eqn{\alpha/\beta} is equal to the parsimony score for \code{x} divided by the sum of the edge lengths of the tree. The shape of the proposal distribution is normal, with mean zero and a variance that can be controlled by the user via the optional argument \code{prior.var}. The argument \code{auto.tune}, if \code{TRUE} or \code{FALSE}, indicates whether or not to 'tune' the proposal variance up or down to target a particular acceptance rate (defaults to 0.5). \code{auto.tune} can also be a numeric value between 0 and 1, in which case this value will be the target acceptance ratio. The argument \code{plot} indicates whether the progress of the MCMC should be plotted (defaults to \code{TRUE}, but runs much faster when set to \code{FALSE}).
+
+ The method \code{plot.mcmcMk} plots a log-likelihood trace and a trace of the rate parameters from the MCMC. (This the same graph that is created by setting \code{plot=TRUE} in \code{mcmcMk}.) The method \code{density.mcmcMk} computes a posterior density on the transition rates in the model from the posterior sample obtained in the MCMC, will import the package \pkg{coda} if it is available, and returns an object of class \code{"density.mcmcMk"}. Finally, the method \code{plot.density.mcmcMk} creates a plot of the posterior density (or a set of plots) for the transition rates between states.
+
+ Finally, the function \code{fitHRM} fits a hidden-rate M\emph{k} model following Beaulieu et al. (2013). For the hidden-rate model we need to specify a number of rate categories for each level of the trait - and this can be a vector of different values for each trait. We can also choose a model (\code{"ER"}, \code{"SYM"}, or \code{"ARD"}), as well as whether or not to treat the character as a 'threshold' trait (\code{umbral=TRUE}, defaults to \code{FALSE}). This latter model is basically one that allows absorbing conditions for some hidden states. Since this can be a difficult optimization problem, the optional argument \code{niter} sets the number of optimization iterations to be run. \code{niter} defaults to \code{niter=10}.
+
+ Note that both \code{fitMk} and \code{fitmultiMk} recycle code from \code{\link{ace}} in the \pkg{ape} package for computing the likelihood. \code{fitpolyMk}, \code{mcmcMk}, and \code{fitHRM} use \code{fitMk} internally to compute the likelihood.
+}
+\value{
+ An object of class \code{"fitMk"}, \code{"fitmultiMk"}, \code{"fitpolyMk"}, \code{"mcmcMk"}, or \code{"fitHRM"}. In the case of \code{density.mcmcMk} an object of class \code{"density.mcmcMk"}.
+
+ \code{plot.fitMk}, \code{plot.gfit}, and \code{plot.HRM} invisibly return the coordinates of vertices of the plotted \bold{Q}-matrix.
+}
+\references{
+ Beaulieu, J. M., B. C. O'Meara, and M. J. Donoghue (2013) Identifying hidden rate changes in the evolution of a binary morphological character: The evolution of plant habit in campanulid angiosperms. \emph{Systematic Biology}, \bold{62}, 725-737.
+
+ Fitzjohn, R. G., W. P. Maddison, and S. P. Otto (2009) Estimating trait-dependent speciation and extinction rates from incompletely resolved phylogenies. \emph{Systematic Biology}, \bold{58}, 595-611.
+
+ Lewis, P. O. (2001) A likelihood approach to estimating phylogeny from discrete morphological character data. \emph{Systematic Biology}, \bold{50}, 913-925.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{ace}}, \code{\link{make.simmap}}
+}
+\examples{
+## load tree and data from Revell & Collar (2009)
+data(sunfish.tree)
+data(sunfish.data)
+## extract discrete character (feeding mode)
+fmode<-setNames(sunfish.data$feeding.mode,
+ rownames(sunfish.data))
+## fit "ER" model
+fit.ER<-fitMk(sunfish.tree,fmode,model="ER")
+print(fit.ER)
+## fit "ARD" model
+fit.ARD<-fitMk(sunfish.tree,fmode,model="ARD")
+print(fit.ARD)
+## compare the models
+AIC(fit.ER,fit.ARD)
+
+## load tree and data from Benitez-Alvarez et al. (2000)
+data(flatworm.data)
+data(flatworm.tree)
+## extract discrete character (habitat)
+habitat<-setNames(flatworm.data$Habitat,
+ rownames(flatworm.data))
+## fit polymorphic models "ER" and "transient"
+fitpoly.ER<-fitpolyMk(flatworm.tree,habitat,
+ model="ER")
+fitpoly.transient<-fitpolyMk(flatworm.tree,habitat,
+ model="transient")
+## print fitted models
+print(fitpoly.ER)
+print(fitpoly.transient)
+## compare model
+AIC(fitpoly.ER,fitpoly.transient)
+## plot models
+par(mfrow=c(2,1))
+plot(fitpoly.ER)
+mtext("a) ER polymorphic model",adj=0,line=1)
+plot(fitpoly.transient)
+mtext("b) Transient polymorphic model",adj=0,
+ line=1)
+par(mfrow=c(1,1))
+}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{maximum likelihood}
+\keyword{bayesian}
+\keyword{discrete character}
diff --git a/man/fitPagel.Rd b/man/fitPagel.Rd
index a988a00..85cb2fb 100644
--- a/man/fitPagel.Rd
+++ b/man/fitPagel.Rd
@@ -1,65 +1,65 @@
-\name{fitPagel}
-\alias{fitPagel}
-\alias{plot.fitPagel}
-\title{Function to test for correlated evolution of binary traits}
-\usage{
-fitPagel(tree, x, y, method="fitMk", model="ARD", dep.var="xy", ...)
-\method{plot}{fitPagel}(x, ...)
-}
-\arguments{
- \item{tree}{an object of class \code{"phylo"}.}
- \item{x}{a vector of phenotypic values for a binary trait for the species in \code{tree}; or a matrix in which the rows of \code{x} give the probability of being in each column state. (The latter option is only supported for \code{method="fitMk"}.) For S3 \code{plot} method, an object of class \code{"fitPagel"}.}
- \item{y}{a second binary character for the species in \code{tree}; or a matrix in which the rows give the probability of being in each column state.}
- \item{method}{function to use for optimization (defaults to \code{method="fitMk"}). Other options are \code{"ace"} to use the \code{\link{ace}} function in \pkg{ape} for optimization, or to \code{"fitDiscrete"} (if the \pkg{geiger} package is installed) to use \pkg{geiger}'s \code{fitDiscrete} for optimization.}
- \item{model}{model of evolution for the individual characters. Can be \code{model="ER"}, \code{"SYM"} (equivalent to \code{"ER"} in this case),
- and \code{"ARD"}.}
- \item{dep.var}{dependent variable. If \code{dep.var="xy"} than the rate of subsitution in \code{x} depends on \code{y} & vice versa. If \code{dep.var="x"} than the substitution rate in \code{x} depends on \code{y}, but not the converse. Finally, if \code{dep.var="y"} than the rate of substitution in \code{y} depends on \code{x}, but not the converse.}
- \item{...}{optional arguments to be passed to \code{\link{fitMk}}, \code{\link{ace}}, or \code{fitDiscrete}. For \code{plot} method optional arguments include (but may not be limited to): \code{signif}, the number of digits for the rates to be plotted; \code{main}, a character vector of length two with the headings for each subplot; \code{cex.main}, \code{cex.sub}, \code{cex.traits}, and \code{cex.rates}, font sizes for the various text elements of the plot; and \code{lwd.by.rate}, a logical argument specifying whether or not to scale arrow line widths in proportion to the estimated rates.}
-}
-\description{
- Fits Pagel's (1994) model for the correlated evolution of two binary characters.
-}
-\details{
- \code{fitPagel} fits both an independent evolution model, as well as Pagel's (1994) binary dependent model, and compares them with a likelihood-ratio test.
-
- \code{plot.fitPagel} plots the fitted models using arrows.
-}
-\value{
- An object of class \code{"fitPagel"} which contains the optimized matrices under an independence & a dependence model, log-likelihoods, a likelihood ratio, and a P-value for the independence model based on a chi-squared test.
-
- \code{plot.fitPagel} creates a plot showing the different fitted models with arrows.
-}
-\references{
- Pagel, M. (1994) Detecting correlated evolution on phylogenies: A general method for the comparative analysis fo discrete characters. \emph{Proceedings of the Royal Society B}, \bold{255}, 37-45.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{ace}}, \code{\link{fitMk}}, \code{\link{make.simmap}}
-}
-\examples{
-\dontrun{
-## load data
-data(bonyfish.tree)
-data(bonyfish.data)
-## extract discrete characters
-spawning_mode<-setNames(bonyfish.data$spawning_mode,
- rownames(bonyfish.data))
-paternal_care<-setNames(bonyfish.data$paternal_care,
- rownames(bonyfish.data))
-## fit correlational model
-bonyfish.pagel<-fitPagel(bonyfish.tree,paternal_care,
- spawning_mode)
-## test for a difference between models
-anova(bonyfish.pagel)
-## plot fitted models
-plot(bonyfish.pagel,lwd.by.rate=TRUE)
-## reset par
-par(mar=c(5.1,4.1,4.1,2.1),
- mfrow=c(1,1))}
-}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{discrete character}
-\keyword{maximum likelihood}
+\name{fitPagel}
+\alias{fitPagel}
+\alias{plot.fitPagel}
+\title{Function to test for correlated evolution of binary traits}
+\usage{
+fitPagel(tree, x, y, method="fitMk", model="ARD", dep.var="xy", ...)
+\method{plot}{fitPagel}(x, ...)
+}
+\arguments{
+ \item{tree}{an object of class \code{"phylo"}.}
+ \item{x}{a vector of phenotypic values for a binary trait for the species in \code{tree}; or a matrix in which the rows of \code{x} give the probability of being in each column state. (The latter option is only supported for \code{method="fitMk"}.) For S3 \code{plot} method, an object of class \code{"fitPagel"}.}
+ \item{y}{a second binary character for the species in \code{tree}; or a matrix in which the rows give the probability of being in each column state.}
+ \item{method}{function to use for optimization (defaults to \code{method="fitMk"}). Other options are \code{"ace"} to use the \code{\link{ace}} function in \pkg{ape} for optimization, or to \code{"fitDiscrete"} (if the \pkg{geiger} package is installed) to use \pkg{geiger}'s \code{fitDiscrete} for optimization.}
+ \item{model}{model of evolution for the individual characters. Can be \code{model="ER"}, \code{"SYM"} (equivalent to \code{"ER"} in this case),
+ and \code{"ARD"}.}
+ \item{dep.var}{dependent variable. If \code{dep.var="xy"} than the rate of subsitution in \code{x} depends on \code{y} & vice versa. If \code{dep.var="x"} than the substitution rate in \code{x} depends on \code{y}, but not the converse. Finally, if \code{dep.var="y"} than the rate of substitution in \code{y} depends on \code{x}, but not the converse.}
+ \item{...}{optional arguments to be passed to \code{\link{fitMk}}, \code{\link{ace}}, or \code{fitDiscrete}. For \code{plot} method optional arguments include (but may not be limited to): \code{signif}, the number of digits for the rates to be plotted; \code{main}, a character vector of length two with the headings for each subplot; \code{cex.main}, \code{cex.sub}, \code{cex.traits}, and \code{cex.rates}, font sizes for the various text elements of the plot; and \code{lwd.by.rate}, a logical argument specifying whether or not to scale arrow line widths in proportion to the estimated rates.}
+}
+\description{
+ Fits Pagel's (1994) model for the correlated evolution of two binary characters.
+}
+\details{
+ \code{fitPagel} fits both an independent evolution model, as well as Pagel's (1994) binary dependent model, and compares them with a likelihood-ratio test.
+
+ \code{plot.fitPagel} plots the fitted models using arrows.
+}
+\value{
+ An object of class \code{"fitPagel"} which contains the optimized matrices under an independence & a dependence model, log-likelihoods, a likelihood ratio, and a P-value for the independence model based on a chi-squared test.
+
+ \code{plot.fitPagel} creates a plot showing the different fitted models with arrows.
+}
+\references{
+ Pagel, M. (1994) Detecting correlated evolution on phylogenies: A general method for the comparative analysis fo discrete characters. \emph{Proceedings of the Royal Society B}, \bold{255}, 37-45.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{ace}}, \code{\link{fitMk}}, \code{\link{make.simmap}}
+}
+\examples{
+\dontrun{
+## load data
+data(bonyfish.tree)
+data(bonyfish.data)
+## extract discrete characters
+spawning_mode<-setNames(bonyfish.data$spawning_mode,
+ rownames(bonyfish.data))
+paternal_care<-setNames(bonyfish.data$paternal_care,
+ rownames(bonyfish.data))
+## fit correlational model
+bonyfish.pagel<-fitPagel(bonyfish.tree,paternal_care,
+ spawning_mode)
+## test for a difference between models
+anova(bonyfish.pagel)
+## plot fitted models
+plot(bonyfish.pagel,lwd.by.rate=TRUE)
+## reset par
+par(mar=c(5.1,4.1,4.1,2.1),
+ mfrow=c(1,1))}
+}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{discrete character}
+\keyword{maximum likelihood}
diff --git a/man/force.ultrametric.Rd b/man/force.ultrametric.Rd
index fe7d703..4206894 100644
--- a/man/force.ultrametric.Rd
+++ b/man/force.ultrametric.Rd
@@ -1,33 +1,33 @@
-\name{force.ultrametric}
-\alias{force.ultrametric}
-\title{Coerces a phylogenetic tree to be ultrametric}
-\usage{
-force.ultrametric(tree, method=c("nnls","extend"), ...)
-}
-\arguments{
- \item{tree}{an object of class \code{"phylo"}.}
- \item{method}{the method to use to force the tree to be ultrametric. Options are \code{"nnls"} (which uses the \pkg{phangorn} function \code{\link{nnls.tree}} internally), or \code{"extend"}.}
- \item{...}{optional arguments: principally, \code{message}. This argument (if set to \code{FALSE}) can be used to suppress the default warning message that \code{force.ultrametric} \emph{should not} be used as a formal statistical method to ultrametricize a tree.}
-}
-\description{
- Coerces an object of class \code{"phylo"} to be ultrametric.
-}
-\details{
- \code{force.ultrametric} coerces a non-ultrametric tree to be ultrametric.
-
- This is achieved either by using \code{\link{nnls.tree}} from the \pkg{phangorn} package to compute the set of edge lengths that result in a minimized sum-of-squares distance between the patristic distance of the output and input trees (\code{method="nnls"}); or by simply extending all the external edges of the tree to match the external edge with the greatest total height (\code{method="extend"}).
-
- Note that neither of these should be treated as formal statistical methods for inferring an ultrametric tree. Rather, this method can be deployed when a genuinely ultrametric tree read from file fails \code{\link{is.ultrametric}} for reasons of numerical precision.
-}
-\value{
- An ultrametric tree in an object of class \code{"phylo"}.
-}
-\seealso{
- \code{\link{is.ultrametric}}, \code{\link{nnls.tree}}
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{statistics}
-\keyword{utilities}
+\name{force.ultrametric}
+\alias{force.ultrametric}
+\title{Coerces a phylogenetic tree to be ultrametric}
+\usage{
+force.ultrametric(tree, method=c("nnls","extend"), ...)
+}
+\arguments{
+ \item{tree}{an object of class \code{"phylo"}.}
+ \item{method}{the method to use to force the tree to be ultrametric. Options are \code{"nnls"} (which uses the \pkg{phangorn} function \code{\link{nnls.tree}} internally), or \code{"extend"}.}
+ \item{...}{optional arguments: principally, \code{message}. This argument (if set to \code{FALSE}) can be used to suppress the default warning message that \code{force.ultrametric} \emph{should not} be used as a formal statistical method to ultrametricize a tree.}
+}
+\description{
+ Coerces an object of class \code{"phylo"} to be ultrametric.
+}
+\details{
+ \code{force.ultrametric} coerces a non-ultrametric tree to be ultrametric.
+
+ This is achieved either by using \code{\link{nnls.tree}} from the \pkg{phangorn} package to compute the set of edge lengths that result in a minimized sum-of-squares distance between the patristic distance of the output and input trees (\code{method="nnls"}); or by simply extending all the external edges of the tree to match the external edge with the greatest total height (\code{method="extend"}).
+
+ Note that neither of these should be treated as formal statistical methods for inferring an ultrametric tree. Rather, this method can be deployed when a genuinely ultrametric tree read from file fails \code{\link{is.ultrametric}} for reasons of numerical precision.
+}
+\value{
+ An ultrametric tree in an object of class \code{"phylo"}.
+}
+\seealso{
+ \code{\link{is.ultrametric}}, \code{\link{nnls.tree}}
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{statistics}
+\keyword{utilities}
diff --git a/man/gammatest.Rd b/man/gammatest.Rd
index f99d8cc..38f6d15 100644
--- a/man/gammatest.Rd
+++ b/man/gammatest.Rd
@@ -1,33 +1,33 @@
-\name{gammatest}
-\alias{gammatest}
-\title{Gamma test of Pybus & Harvey (2000)}
-\usage{
-gammatest(x)
-}
-\arguments{
- \item{x}{an object of class \code{"ltt"} resulting from a call of the function \code{\link{ltt}}.}
-}
-\description{
- Conducts \eqn{\gamma}-test of Pybus & Harvey (2000).
-}
-\value{
- A an object of class \code{"gammatest"} consisting of a list that contains:
- \item{gamma}{a value for the \eqn{\gamma}-statistic.}
- \item{p}{two-tailed P-value for the \eqn{\gamma}-test.}
-}
-\references{
- Pybus, O. G., and P. H. Harvey (2000) Testing macro-evolutionary models using incomplete molecular phylogenies. \emph{Proc. R. Soc. Lond. B}, \bold{267}, 2267-2272.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{ltt}}, \code{\link{mccr}}
-}
-\examples{
-tree<-pbtree(n=200)
-gammatest(ltt(tree,plot=FALSE))
-}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{diversification}
+\name{gammatest}
+\alias{gammatest}
+\title{Gamma test of Pybus & Harvey (2000)}
+\usage{
+gammatest(x)
+}
+\arguments{
+ \item{x}{an object of class \code{"ltt"} resulting from a call of the function \code{\link{ltt}}.}
+}
+\description{
+ Conducts \eqn{\gamma}-test of Pybus & Harvey (2000).
+}
+\value{
+ A an object of class \code{"gammatest"} consisting of a list that contains:
+ \item{gamma}{a value for the \eqn{\gamma}-statistic.}
+ \item{p}{two-tailed P-value for the \eqn{\gamma}-test.}
+}
+\references{
+ Pybus, O. G., and P. H. Harvey (2000) Testing macro-evolutionary models using incomplete molecular phylogenies. \emph{Proc. R. Soc. Lond. B}, \bold{267}, 2267-2272.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{ltt}}, \code{\link{mccr}}
+}
+\examples{
+tree<-pbtree(n=200)
+gammatest(ltt(tree,plot=FALSE))
+}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{diversification}
diff --git a/man/genSeq.Rd b/man/genSeq.Rd
index d100a15..e8fa589 100644
--- a/man/genSeq.Rd
+++ b/man/genSeq.Rd
@@ -1,38 +1,38 @@
-\name{genSeq}
-\alias{genSeq}
-\title{Simulate a DNA alignment on the tree under a model}
-\usage{
-genSeq(tree, l=1000, Q=NULL, rate=1, format="DNAbin", ...)
-}
-\arguments{
- \item{tree}{object of class \code{"phylo"}.}
- \item{l}{length of desired sequences.}
- \item{Q}{transition matrix for the simulation. Row and column names (\code{c("a","c","g","t")}, although not necessarily in that order) should be provided. If \code{NULL}, a single rate is assumed.}
- \item{rate}{multiplier for \code{Q}, or a vector for \eqn{\Gamma} rate heterogeneity.}
- \item{format}{format of the output object. Can be \code{"DNAbin"}, \code{"phyDat"}, or \code{"matrix"}.}
- \item{...}{optional arguments.}
-}
-\description{
- Simulates DNA sequence on \code{tree} under the specified model.
-}
-\details{
- Uses \code{\link{sim.Mk}} internally.
-}
-\value{
- An object of class \code{"DNAbin"} or \code{"phyDat"}, or a matrix of nucleotides.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\examples{
-data(mammal.tree)
-mammal.tree$edge.length<-mammal.tree$edge.length/
- max(nodeHeights(mammal.tree))*0.2 ## rescale tree
-## simulate gamma rate heterogeneity
-gg<-rgamma(n=100,shape=0.25,rate=0.25)
-dna<-genSeq(mammal.tree,l=100,rate=gg)
-}
-\keyword{phylogenetics}
-\keyword{simulation}
-\keyword{discrete character}
+\name{genSeq}
+\alias{genSeq}
+\title{Simulate a DNA alignment on the tree under a model}
+\usage{
+genSeq(tree, l=1000, Q=NULL, rate=1, format="DNAbin", ...)
+}
+\arguments{
+ \item{tree}{object of class \code{"phylo"}.}
+ \item{l}{length of desired sequences.}
+ \item{Q}{transition matrix for the simulation. Row and column names (\code{c("a","c","g","t")}, although not necessarily in that order) should be provided. If \code{NULL}, a single rate is assumed.}
+ \item{rate}{multiplier for \code{Q}, or a vector for \eqn{\Gamma} rate heterogeneity.}
+ \item{format}{format of the output object. Can be \code{"DNAbin"}, \code{"phyDat"}, or \code{"matrix"}.}
+ \item{...}{optional arguments.}
+}
+\description{
+ Simulates DNA sequence on \code{tree} under the specified model.
+}
+\details{
+ Uses \code{\link{sim.Mk}} internally.
+}
+\value{
+ An object of class \code{"DNAbin"} or \code{"phyDat"}, or a matrix of nucleotides.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\examples{
+data(mammal.tree)
+mammal.tree$edge.length<-mammal.tree$edge.length/
+ max(nodeHeights(mammal.tree))*0.2 ## rescale tree
+## simulate gamma rate heterogeneity
+gg<-rgamma(n=100,shape=0.25,rate=0.25)
+dna<-genSeq(mammal.tree,l=100,rate=gg)
+}
+\keyword{phylogenetics}
+\keyword{simulation}
+\keyword{discrete character}
diff --git a/man/geo.legend.Rd b/man/geo.legend.Rd
index c70734a..8140714 100644
--- a/man/geo.legend.Rd
+++ b/man/geo.legend.Rd
@@ -1,33 +1,33 @@
-\name{geo.legend}
-\alias{geo.legend}
-\alias{geo.palette}
-\title{Adds a geological (or other temporal) legend to a plotted tree}
-\usage{
-geo.legend(leg=NULL, colors=NULL, alpha=0.2, ...)
-geo.palette()
-}
-\arguments{
- \item{leg}{a matrix with the starting & ending point of each plotted era in rows, & names of the time periods as rownames.}
- \item{colors}{a vector of colors for the time periods of the rows in \code{leg}.}
- \item{alpha}{transparency level to apply to \code{colors}.}
- \item{...}{optional arguments.}
-}
-\description{
- Adds a geological legend to a plotted tree.
-}
-\details{
- The function \code{geo.legend} adds a geological (or other temporal) legend to a plotted tree.
-
- The function \code{geo.palette} returns a geological time color palette to the user.
-}
-\value{
- \code{geo.legend} adds a visual element to a plotted tree and invisible returns an object of class \code{geo.legend} containing the time periods and colors of the painted legend.
-
- \code{geo.palette} simply returns a geological timescale color palette as an object of class \code{"geo.palette"}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{phylogenetics}
-\keyword{plotting}
+\name{geo.legend}
+\alias{geo.legend}
+\alias{geo.palette}
+\title{Adds a geological (or other temporal) legend to a plotted tree}
+\usage{
+geo.legend(leg=NULL, colors=NULL, alpha=0.2, ...)
+geo.palette()
+}
+\arguments{
+ \item{leg}{a matrix with the starting & ending point of each plotted era in rows, & names of the time periods as rownames.}
+ \item{colors}{a vector of colors for the time periods of the rows in \code{leg}.}
+ \item{alpha}{transparency level to apply to \code{colors}.}
+ \item{...}{optional arguments.}
+}
+\description{
+ Adds a geological legend to a plotted tree.
+}
+\details{
+ The function \code{geo.legend} adds a geological (or other temporal) legend to a plotted tree.
+
+ The function \code{geo.palette} returns a geological time color palette to the user.
+}
+\value{
+ \code{geo.legend} adds a visual element to a plotted tree and invisible returns an object of class \code{geo.legend} containing the time periods and colors of the painted legend.
+
+ \code{geo.palette} simply returns a geological timescale color palette as an object of class \code{"geo.palette"}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{phylogenetics}
+\keyword{plotting}
diff --git a/man/get.treepos.Rd b/man/get.treepos.Rd
index c19a80b..35375ab 100644
--- a/man/get.treepos.Rd
+++ b/man/get.treepos.Rd
@@ -1,31 +1,31 @@
-\name{get.treepos}
-\alias{get.treepos}
-\alias{getnode}
-\title{Get position or node of a plotted tree interactively}
-\usage{
-get.treepos(message=TRUE, ...)
-getnode(...)
-}
-\arguments{
- \item{message}{for \code{get.treepos}, a logical value indicating whether or not to print an instructional message.}
- \item{...}{optional arguments.}
-}
-\description{
- Return the phylogenetic position of a mouse click on a plotted tree.
-}
-\details{
- Both \code{get.treepos} and \code{getnode} are primarily meant for internal use in other \pkg{phytools} functions.
-
- \code{get.treepos} returns the index of the node at the end of the selected edge, along with the branch distance to that node.
-
- \code{getnode} simply returns the closest node to the user mouse click.
-}
-\value{
- A list for \code{get.treepos} and a node number for \code{getnode}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{utilities}
-\keyword{plotting}
+\name{get.treepos}
+\alias{get.treepos}
+\alias{getnode}
+\title{Get position or node of a plotted tree interactively}
+\usage{
+get.treepos(message=TRUE, ...)
+getnode(...)
+}
+\arguments{
+ \item{message}{for \code{get.treepos}, a logical value indicating whether or not to print an instructional message.}
+ \item{...}{optional arguments.}
+}
+\description{
+ Return the phylogenetic position of a mouse click on a plotted tree.
+}
+\details{
+ Both \code{get.treepos} and \code{getnode} are primarily meant for internal use in other \pkg{phytools} functions.
+
+ \code{get.treepos} returns the index of the node at the end of the selected edge, along with the branch distance to that node.
+
+ \code{getnode} simply returns the closest node to the user mouse click.
+}
+\value{
+ A list for \code{get.treepos} and a node number for \code{getnode}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{utilities}
+\keyword{plotting}
diff --git a/man/getCladesofSize.Rd b/man/getCladesofSize.Rd
index 54e97f8..e52155f 100644
--- a/man/getCladesofSize.Rd
+++ b/man/getCladesofSize.Rd
@@ -1,25 +1,25 @@
-\name{getCladesofSize}
-\alias{getCladesofSize}
-\title{Get all subtrees larger than or equal to a specified size}
-\usage{
-getCladesofSize(tree, clade.size=2)
-}
-\arguments{
- \item{tree}{is an object of class \code{"phylo"}.}
- \item{clade.size}{subtree size.}
-}
-\description{
- This function gets all subtrees that cannot be further subdivided into two reciprocally monophyletic subtrees of size \code{>= clade.size}.
-}
-\value{
- An object of class \code{"multiPhylo"}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{extract.clade}}, \code{\link{getDescendants}}
-}
-\keyword{phylogenetics}
-\keyword{utilities}
+\name{getCladesofSize}
+\alias{getCladesofSize}
+\title{Get all subtrees larger than or equal to a specified size}
+\usage{
+getCladesofSize(tree, clade.size=2)
+}
+\arguments{
+ \item{tree}{is an object of class \code{"phylo"}.}
+ \item{clade.size}{subtree size.}
+}
+\description{
+ This function gets all subtrees that cannot be further subdivided into two reciprocally monophyletic subtrees of size \code{>= clade.size}.
+}
+\value{
+ An object of class \code{"multiPhylo"}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{extract.clade}}, \code{\link{getDescendants}}
+}
+\keyword{phylogenetics}
+\keyword{utilities}
diff --git a/man/getDescendants.Rd b/man/getDescendants.Rd
index 1a00e6a..c49da48 100644
--- a/man/getDescendants.Rd
+++ b/man/getDescendants.Rd
@@ -1,33 +1,33 @@
-\name{getDescendants}
-\alias{getDescendants}
-\alias{getParent}
-\title{Get descendant node numbers}
-\usage{
-getDescendants(tree, node, curr=NULL)
-getParent(tree, node)
-}
-\arguments{
- \item{tree}{a phylogenetic tree as an object of class \code{"phylo"}.}
- \item{node}{an integer specifying a node number in the tree.}
- \item{curr}{the set of previously stored node numbers - used in recursive function calls.}
-}
-\description{
- Returns the descendants or parent of a specified node.
-}
-\details{
- \code{getDescendants} returns the set of node & tip numbers descended from \code{node}.
-
- \code{getParent} returns the \emph{single} parent node of a specified node number (or \code{NULL} if \code{node} is already the root).
-}
-\value{
- The set of node and tip numbers for the nodes and tips descended from \code{node} in a vector, or for \code{getParent} the single node preceding \code{node} in the tree.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{Descendants}}, \code{\link{paintSubTree}}
-}
-\keyword{phylogenetics}
-\keyword{utilities}
+\name{getDescendants}
+\alias{getDescendants}
+\alias{getParent}
+\title{Get descendant node numbers}
+\usage{
+getDescendants(tree, node, curr=NULL)
+getParent(tree, node)
+}
+\arguments{
+ \item{tree}{a phylogenetic tree as an object of class \code{"phylo"}.}
+ \item{node}{an integer specifying a node number in the tree.}
+ \item{curr}{the set of previously stored node numbers - used in recursive function calls.}
+}
+\description{
+ Returns the descendants or parent of a specified node.
+}
+\details{
+ \code{getDescendants} returns the set of node & tip numbers descended from \code{node}.
+
+ \code{getParent} returns the \emph{single} parent node of a specified node number (or \code{NULL} if \code{node} is already the root).
+}
+\value{
+ The set of node and tip numbers for the nodes and tips descended from \code{node} in a vector, or for \code{getParent} the single node preceding \code{node} in the tree.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{Descendants}}, \code{\link{paintSubTree}}
+}
+\keyword{phylogenetics}
+\keyword{utilities}
diff --git a/man/getExtant.Rd b/man/getExtant.Rd
index bddd22d..35e56d5 100644
--- a/man/getExtant.Rd
+++ b/man/getExtant.Rd
@@ -1,32 +1,32 @@
-\name{getExtant}
-\alias{getExtant}
-\alias{getExtinct}
-\title{Returns a list of the extant or extinct lineages in a tree containing non-contemporaneous tips}
-\usage{
-getExtant(tree, tol=1e-8)
-getExtinct(tree, tol=1e-8)
-}
-\arguments{
- \item{tree}{a phylogeny stored as an object of class \code{"phylo"} with some tips that are non-contemporaneous (i.e., end before the present).}
- \item{tol}{a tolerance value to account for numerical imprecision.}
-}
-\description{
- Computes the set of extant or extinct tips from a phylogenetic tree.
-}
-\details{
- The function \code{getExtant} takes a tree as input and returns a vector containing the names of all the tips that have a height above the root that is equal (to a degree of numerical precision determined by \code{tol}) to the height of the highest tip. These tips are presumed to be "extant."
-
- \code{getExtinct} returns the complement.
-}
-\value{
- A vector with the tip names of extant or extinct species in the tree.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{nodeHeights}}
-}
-\keyword{phylogenetics}
-\keyword{utilities}
+\name{getExtant}
+\alias{getExtant}
+\alias{getExtinct}
+\title{Returns a list of the extant or extinct lineages in a tree containing non-contemporaneous tips}
+\usage{
+getExtant(tree, tol=1e-8)
+getExtinct(tree, tol=1e-8)
+}
+\arguments{
+ \item{tree}{a phylogeny stored as an object of class \code{"phylo"} with some tips that are non-contemporaneous (i.e., end before the present).}
+ \item{tol}{a tolerance value to account for numerical imprecision.}
+}
+\description{
+ Computes the set of extant or extinct tips from a phylogenetic tree.
+}
+\details{
+ The function \code{getExtant} takes a tree as input and returns a vector containing the names of all the tips that have a height above the root that is equal (to a degree of numerical precision determined by \code{tol}) to the height of the highest tip. These tips are presumed to be "extant."
+
+ \code{getExtinct} returns the complement.
+}
+\value{
+ A vector with the tip names of extant or extinct species in the tree.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{nodeHeights}}
+}
+\keyword{phylogenetics}
+\keyword{utilities}
diff --git a/man/getSisters.Rd b/man/getSisters.Rd
index a3d5dce..7b2c281 100644
--- a/man/getSisters.Rd
+++ b/man/getSisters.Rd
@@ -1,29 +1,29 @@
-\name{getSisters}
-\alias{getSisters}
-\title{Get the sister node number, label, or set of nodes for a node or tip}
-\usage{
-getSisters(tree, node, mode=c("number","label"))
-}
-\arguments{
- \item{tree}{object of class \code{"phylo"}.}
- \item{node}{a node number, tip number, node label, or tip label.}
- \item{mode}{an optional string indicating whether to return the node or tip number(s) or the node or tip label(s), if applicable.}
-}
-\description{
- Computes the sister taxon or node.
-}
-\details{
- This function takes a tree and node or tip number of label and returns the number or label of the sister or sisters to that node or tip.
-}
-\value{
- If \code{mode="number"} this function returns an integer or vector containing the node number of numbers of the sister node or tip. If \code{mode="label"} then this function returns a list containing up to two vectors: one for the node numbers of labels of sister nodes (if applicable); and the other containing the tip labels of the sister tips.
-}
-\seealso{
- \code{\link{getDescendants}}, \code{\link{Siblings}}
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{phylogenetics}
-\keyword{utilities}
+\name{getSisters}
+\alias{getSisters}
+\title{Get the sister node number, label, or set of nodes for a node or tip}
+\usage{
+getSisters(tree, node, mode=c("number","label"))
+}
+\arguments{
+ \item{tree}{object of class \code{"phylo"}.}
+ \item{node}{a node number, tip number, node label, or tip label.}
+ \item{mode}{an optional string indicating whether to return the node or tip number(s) or the node or tip label(s), if applicable.}
+}
+\description{
+ Computes the sister taxon or node.
+}
+\details{
+ This function takes a tree and node or tip number of label and returns the number or label of the sister or sisters to that node or tip.
+}
+\value{
+ If \code{mode="number"} this function returns an integer or vector containing the node number of numbers of the sister node or tip. If \code{mode="label"} then this function returns a list containing up to two vectors: one for the node numbers of labels of sister nodes (if applicable); and the other containing the tip labels of the sister tips.
+}
+\seealso{
+ \code{\link{getDescendants}}, \code{\link{Siblings}}
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{phylogenetics}
+\keyword{utilities}
diff --git a/man/getStates.Rd b/man/getStates.Rd
index 9dc92a0..e050e10 100644
--- a/man/getStates.Rd
+++ b/man/getStates.Rd
@@ -1,26 +1,26 @@
-\name{getStates}
-\alias{getStates}
-\title{Get the states at nodes or tips from a mapped tree}
-\usage{
-getStates(tree, type=c("nodes","tips","both"))
-}
-\arguments{
- \item{tree}{is a modified object of class \code{"phylo"} or \code{"multiPhylo"}.}
- \item{type}{mode indicating whether to get states at the nodes (\code{type="nodes"}) or the tips (\code{type="tips"}) of the tree.}
-}
-\description{
- Gets the states from the nodes or tips of a mapped tree (e.g., \code{\link{make.simmap}}).
-}
-\value{
- A named vector (for \code{"phylo"}) or matrix (for \code{"multiPhylo"}).
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{describe.simmap}}, \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{sim.history}}
-}
-\keyword{phylogenetics}
-\keyword{utilities}
-\keyword{discrete character}
+\name{getStates}
+\alias{getStates}
+\title{Get the states at nodes or tips from a mapped tree}
+\usage{
+getStates(tree, type=c("nodes","tips","both"))
+}
+\arguments{
+ \item{tree}{is a modified object of class \code{"phylo"} or \code{"multiPhylo"}.}
+ \item{type}{mode indicating whether to get states at the nodes (\code{type="nodes"}) or the tips (\code{type="tips"}) of the tree.}
+}
+\description{
+ Gets the states from the nodes or tips of a mapped tree (e.g., \code{\link{make.simmap}}).
+}
+\value{
+ A named vector (for \code{"phylo"}) or matrix (for \code{"multiPhylo"}).
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{describe.simmap}}, \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{sim.history}}
+}
+\keyword{phylogenetics}
+\keyword{utilities}
+\keyword{discrete character}
diff --git a/man/labelnodes.Rd b/man/labelnodes.Rd
index 5173977..b450c61 100644
--- a/man/labelnodes.Rd
+++ b/man/labelnodes.Rd
@@ -1,32 +1,32 @@
-\name{labelnodes}
-\alias{labelnodes}
-\title{Function to interactively label nodes of a plotted tree}
-\usage{
-labelnodes(text, node=NULL, interactive=TRUE, shape=c("circle","ellipse",
- "rect"), ...)
-}
-\arguments{
- \item{text}{text string or vector to be used as labels.}
- \item{node}{node numbers (indices) for the labels.}
- \item{interactive}{logical value indicating whether or not nodes should be supplied interactively. (I.e., by clicking on the nodes.)}
- \item{shape}{shape to plot around the plotted node label(s).}
- \item{...}{optional arguments.}
-}
-\description{
- Adds node labels to a plotted object of class \code{"phylo"}.
-}
-\details{
- The nodes to be labels can be selected interactively by the user (i.e., by clicking on the corresponding nodes of the plotted tree).
-}
-\value{
- Invisibly returns a vector of the node indices for the labeled nodes.
-}
-\seealso{
- \code{\link{cladelabels}}, \code{\link{nodelabels}}
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{plotting}
-\keyword{utilities}
+\name{labelnodes}
+\alias{labelnodes}
+\title{Function to interactively label nodes of a plotted tree}
+\usage{
+labelnodes(text, node=NULL, interactive=TRUE, shape=c("circle","ellipse",
+ "rect"), ...)
+}
+\arguments{
+ \item{text}{text string or vector to be used as labels.}
+ \item{node}{node numbers (indices) for the labels.}
+ \item{interactive}{logical value indicating whether or not nodes should be supplied interactively. (I.e., by clicking on the nodes.)}
+ \item{shape}{shape to plot around the plotted node label(s).}
+ \item{...}{optional arguments.}
+}
+\description{
+ Adds node labels to a plotted object of class \code{"phylo"}.
+}
+\details{
+ The nodes to be labels can be selected interactively by the user (i.e., by clicking on the corresponding nodes of the plotted tree).
+}
+\value{
+ Invisibly returns a vector of the node indices for the labeled nodes.
+}
+\seealso{
+ \code{\link{cladelabels}}, \code{\link{nodelabels}}
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{plotting}
+\keyword{utilities}
diff --git a/man/lambda.transform.Rd b/man/lambda.transform.Rd
index b67d165..82fcea8 100644
--- a/man/lambda.transform.Rd
+++ b/man/lambda.transform.Rd
@@ -1,27 +1,27 @@
-\name{lambda.transform}
-\alias{lambda.transform}
-\title{\eqn{\lambda} transformation of matrix}
-\usage{
-lambda.transform(lambda, C)
-}
-\arguments{
- \item{lambda}{scalar, usually (but not necessarily) on the interval 0,1.}
- \item{C}{matrix probably returned by \code{\link{vcv.phylo}}.}
-}
-\description{
- Internal function for \code{\link{phyl.pca}} and others.
-}
-\details{
- Multiplies the off-diagonals of a square matrix by \code{lambda} and returns the result.
-}
-\value{
- Typically an among-species phylogenetic variance covariance matrix (e.g., \code{\link{vcv.phylo}}) in which the off-diagonal elements have been multiplied by \code{lambda}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{phylogenetics}
-\keyword{math}
-\keyword{comparative method}
-\keyword{utilities}
+\name{lambda.transform}
+\alias{lambda.transform}
+\title{\eqn{\lambda} transformation of matrix}
+\usage{
+lambda.transform(lambda, C)
+}
+\arguments{
+ \item{lambda}{scalar, usually (but not necessarily) on the interval 0,1.}
+ \item{C}{matrix probably returned by \code{\link{vcv.phylo}}.}
+}
+\description{
+ Internal function for \code{\link{phyl.pca}} and others.
+}
+\details{
+ Multiplies the off-diagonals of a square matrix by \code{lambda} and returns the result.
+}
+\value{
+ Typically an among-species phylogenetic variance covariance matrix (e.g., \code{\link{vcv.phylo}}) in which the off-diagonal elements have been multiplied by \code{lambda}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{phylogenetics}
+\keyword{math}
+\keyword{comparative method}
+\keyword{utilities}
diff --git a/man/likMlambda.Rd b/man/likMlambda.Rd
index 596523f..547555a 100644
--- a/man/likMlambda.Rd
+++ b/man/likMlambda.Rd
@@ -1,29 +1,29 @@
-\name{likMlambda}
-\alias{likMlambda}
-\title{Likelihood for joint \eqn{\lambda}}
-\usage{
-likMlambda(lambda, X, C)
-}
-\arguments{
- \item{lambda}{scalar, usually on the interval 0,1 (although not required to be).}
- \item{X}{data for various continuous character, in the form of a matrix.}
- \item{C}{\emph{n} x \emph{n} matrix (for \emph{n} taxa) containing the height above the root for each pair of taxa in the tree (e.g., \code{\link{vcv.phylo}}).}
-}
-\description{
- Likelihood function for joint estimation of Pagel's \eqn{\lambda} parameter.
-}
-\details{
- Generally intended to be used internally by other methods that do joint optimization of \eqn{\lambda} (e.g., \code{\link{phyl.pca}}).
-}
-\value{
- The log-likelihood.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{phylogenetics}
-\keyword{math}
-\keyword{comparative method}
-\keyword{utilities}
-\keyword{maximum likelihood}
+\name{likMlambda}
+\alias{likMlambda}
+\title{Likelihood for joint \eqn{\lambda}}
+\usage{
+likMlambda(lambda, X, C)
+}
+\arguments{
+ \item{lambda}{scalar, usually on the interval 0,1 (although not required to be).}
+ \item{X}{data for various continuous character, in the form of a matrix.}
+ \item{C}{\emph{n} x \emph{n} matrix (for \emph{n} taxa) containing the height above the root for each pair of taxa in the tree (e.g., \code{\link{vcv.phylo}}).}
+}
+\description{
+ Likelihood function for joint estimation of Pagel's \eqn{\lambda} parameter.
+}
+\details{
+ Generally intended to be used internally by other methods that do joint optimization of \eqn{\lambda} (e.g., \code{\link{phyl.pca}}).
+}
+\value{
+ The log-likelihood.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{phylogenetics}
+\keyword{math}
+\keyword{comparative method}
+\keyword{utilities}
+\keyword{maximum likelihood}
diff --git a/man/linklabels.Rd b/man/linklabels.Rd
index f513ac6..50c803c 100644
--- a/man/linklabels.Rd
+++ b/man/linklabels.Rd
@@ -1,31 +1,31 @@
-\name{linklabels}
-\alias{linklabels}
-\title{Function to add tip labels to a plotted tree with linking lines}
-\usage{
-linklabels(text,tips,link.type=c("bent","curved","straight"),
- ...)
-}
-\arguments{
- \item{text}{text string or vector to be used as labels.}
- \item{tips}{node numbers (indices) for the tips to be labeled.}
- \item{link.type}{manner in which to draw the linking lines.}
- \item{...}{optional arguments, including \code{cex}, \code{lty}, \code{lwd}, and \code{col}.}
-}
-\description{
- Adds tip labels to a plotted tree by drawing curved, bent, or straight linking lines.
-}
-\details{
- The idea underlying this function is that the user should first plot the tree without tip labels, but set the area of the plotting device to be sufficient to accommodate the tip labels once they have been added. The function then can be called to add tip labels connected by linking lines to the tips of the plotted tree.
-}
-\value{
- This function annotates a plot.
-}
-\seealso{
- \code{\link{cladelabels}}, \code{\link{nodelabels}}, \code{\link{tiplabels}}
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{plotting}
-\keyword{utilities}
+\name{linklabels}
+\alias{linklabels}
+\title{Function to add tip labels to a plotted tree with linking lines}
+\usage{
+linklabels(text,tips,link.type=c("bent","curved","straight"),
+ ...)
+}
+\arguments{
+ \item{text}{text string or vector to be used as labels.}
+ \item{tips}{node numbers (indices) for the tips to be labeled.}
+ \item{link.type}{manner in which to draw the linking lines.}
+ \item{...}{optional arguments, including \code{cex}, \code{lty}, \code{lwd}, and \code{col}.}
+}
+\description{
+ Adds tip labels to a plotted tree by drawing curved, bent, or straight linking lines.
+}
+\details{
+ The idea underlying this function is that the user should first plot the tree without tip labels, but set the area of the plotting device to be sufficient to accommodate the tip labels once they have been added. The function then can be called to add tip labels connected by linking lines to the tips of the plotted tree.
+}
+\value{
+ This function annotates a plot.
+}
+\seealso{
+ \code{\link{cladelabels}}, \code{\link{nodelabels}}, \code{\link{tiplabels}}
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{plotting}
+\keyword{utilities}
diff --git a/man/locate.fossil.Rd b/man/locate.fossil.Rd
index 1febe7d..2e3e045 100644
--- a/man/locate.fossil.Rd
+++ b/man/locate.fossil.Rd
@@ -1,31 +1,31 @@
-\name{locate.fossil}
-\alias{locate.fossil}
-\title{Locate a fossil lineage in a tree using continuous characters}
-\usage{
-locate.fossil(tree, X, ...)
-}
-\arguments{
- \item{tree}{an object of class \code{"phylo"}.}
- \item{X}{a matrix with continuous character data.}
- \item{...}{optional arguments including \code{time.constraint} which can be a scalar (positive height above the root of the fossil or negative time before present) or a vector (age range of fossil, either positive or negative); \code{edge.constraint}, which is equivalent to \code{constraint} in \code{\link{locate.yeti}}; \code{plot}, \code{rotate}, and \code{quiet}, which have the same interpretation (and defaults) as the equivalent arguments in \code{\link{locate.yeti}}.}
-}
-\description{
- Uses ML to place a fossil lineage into a tree using continuous traits following Revell et al. (2015).
-}
-\value{
- Optimized tree as an object of class \code{"phylo"}.
-}
-\references{
- Felsenstein, J. (1981) Maximum likelihood estimation of evolutionary trees from continuous characters. \emph{American Journal of Human Genetics}, 25, 471-492.
-
- Felsenstein, J. (2002) Quantitative characters, phylogenies, and morphometrics. In: MacLeod, N. and P. Forey (Eds.) \emph{Morphology, Shape and Phylogeny} (pp. 27-44). Taylor and Francis, London.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-
- Revell, L. J., D. L. Mahler, R. G. Reynolds, and G. J. Slater. (2015) Placing cryptic, recently extinct, or hypothesized taxa into an ultrametric phylogeny using continuous, character data: A case study with the lizard \emph{Anolis roosevelti}. \emph{Evolution}, \bold{69}, 1027-1035.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{phylogenetics}
-\keyword{phylogeny inference}
-\keyword{maximum likelihood}
-\keyword{continuous character}
+\name{locate.fossil}
+\alias{locate.fossil}
+\title{Locate a fossil lineage in a tree using continuous characters}
+\usage{
+locate.fossil(tree, X, ...)
+}
+\arguments{
+ \item{tree}{an object of class \code{"phylo"}.}
+ \item{X}{a matrix with continuous character data.}
+ \item{...}{optional arguments including \code{time.constraint} which can be a scalar (positive height above the root of the fossil or negative time before present) or a vector (age range of fossil, either positive or negative); \code{edge.constraint}, which is equivalent to \code{constraint} in \code{\link{locate.yeti}}; \code{plot}, \code{rotate}, and \code{quiet}, which have the same interpretation (and defaults) as the equivalent arguments in \code{\link{locate.yeti}}.}
+}
+\description{
+ Uses ML to place a fossil lineage into a tree using continuous traits following Revell et al. (2015).
+}
+\value{
+ Optimized tree as an object of class \code{"phylo"}.
+}
+\references{
+ Felsenstein, J. (1981) Maximum likelihood estimation of evolutionary trees from continuous characters. \emph{American Journal of Human Genetics}, 25, 471-492.
+
+ Felsenstein, J. (2002) Quantitative characters, phylogenies, and morphometrics. In: MacLeod, N. and P. Forey (Eds.) \emph{Morphology, Shape and Phylogeny} (pp. 27-44). Taylor and Francis, London.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+
+ Revell, L. J., D. L. Mahler, R. G. Reynolds, and G. J. Slater. (2015) Placing cryptic, recently extinct, or hypothesized taxa into an ultrametric phylogeny using continuous, character data: A case study with the lizard \emph{Anolis roosevelti}. \emph{Evolution}, \bold{69}, 1027-1035.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{phylogenetics}
+\keyword{phylogeny inference}
+\keyword{maximum likelihood}
+\keyword{continuous character}
diff --git a/man/locate.yeti.Rd b/man/locate.yeti.Rd
index 002a152..14e495e 100644
--- a/man/locate.yeti.Rd
+++ b/man/locate.yeti.Rd
@@ -1,29 +1,29 @@
-\name{locate.yeti}
-\alias{locate.yeti}
-\title{Locate a cryptic, recently extinct, or missing taxon on a tree}
-\usage{
-locate.yeti(tree, X, ...)
-}
-\arguments{
- \item{tree}{an object of class \code{"phylo"}.}
- \item{X}{a matrix with continuous character data.}
- \item{...}{optional arguments including: \code{method} (\code{"ML"} or \code{"REML"}, defaults to \code{"ML"}); \code{search} (\code{"heuristic"} or \code{"exhaustive"}, defaults to \code{"heuristic"}); \code{constraint}, a vector containing the daughter node numbers from \code{tree$edge} for each edge to try; \code{plot} a logical argument specifying whether or not to plot the likelihood profile on edges (defaults to \code{FALSE}); \code{rotate} a logical indicating whether or not to rotate the data based on the input tree; and \code{quiet}, which is logical and has an obvious interpretation.}
-}
-\description{
- Uses ML (or REML) to place a recently extinct, cryptic, or missing taxon on an ultrametric (i.e., time-calibrated) phylogeny following Revell et al. (2015).
-}
-\value{
- Optimized tree as an object of class \code{"phylo"}.
-}
-\references{
- Felsenstein, J. (1981) Maximum likelihood estimation of evolutionary trees from continuous characters. \emph{American Journal of Human Genetics}, 25, 471-492.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-
- Revell, L. J., D. L. Mahler, R. G. Reynolds, and G. J. Slater. (2015) Placing cryptic, recently extinct, or hypothesized taxa into an ultrametric phylogeny using continuous, character data: A case study with the lizard \emph{Anolis roosevelti}. \emph{Evolution}, \bold{69}, 1027-1035.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{phylogenetics}
-\keyword{phylogeny inference}
-\keyword{maximum likelihood}
-\keyword{continuous character}
+\name{locate.yeti}
+\alias{locate.yeti}
+\title{Locate a cryptic, recently extinct, or missing taxon on a tree}
+\usage{
+locate.yeti(tree, X, ...)
+}
+\arguments{
+ \item{tree}{an object of class \code{"phylo"}.}
+ \item{X}{a matrix with continuous character data.}
+ \item{...}{optional arguments including: \code{method} (\code{"ML"} or \code{"REML"}, defaults to \code{"ML"}); \code{search} (\code{"heuristic"} or \code{"exhaustive"}, defaults to \code{"heuristic"}); \code{constraint}, a vector containing the daughter node numbers from \code{tree$edge} for each edge to try; \code{plot} a logical argument specifying whether or not to plot the likelihood profile on edges (defaults to \code{FALSE}); \code{rotate} a logical indicating whether or not to rotate the data based on the input tree; and \code{quiet}, which is logical and has an obvious interpretation.}
+}
+\description{
+ Uses ML (or REML) to place a recently extinct, cryptic, or missing taxon on an ultrametric (i.e., time-calibrated) phylogeny following Revell et al. (2015).
+}
+\value{
+ Optimized tree as an object of class \code{"phylo"}.
+}
+\references{
+ Felsenstein, J. (1981) Maximum likelihood estimation of evolutionary trees from continuous characters. \emph{American Journal of Human Genetics}, 25, 471-492.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+
+ Revell, L. J., D. L. Mahler, R. G. Reynolds, and G. J. Slater. (2015) Placing cryptic, recently extinct, or hypothesized taxa into an ultrametric phylogeny using continuous, character data: A case study with the lizard \emph{Anolis roosevelti}. \emph{Evolution}, \bold{69}, 1027-1035.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{phylogenetics}
+\keyword{phylogeny inference}
+\keyword{maximum likelihood}
+\keyword{continuous character}
diff --git a/man/ls.tree.Rd b/man/ls.tree.Rd
index 7fb31d2..051f743 100644
--- a/man/ls.tree.Rd
+++ b/man/ls.tree.Rd
@@ -1,27 +1,27 @@
-\name{ls.tree}
-\alias{ls.tree}
-\title{Least squares branch lengths for a given tree}
-\usage{
-ls.tree(tree, D)
-}
-\arguments{
- \item{tree}{phylogeny.}
- \item{D}{distance matrix.}
-}
-\description{
- Computes the least squares branch lengths conditioned on a topology and distance matrix.
-}
-\details{
- Generally intended as a function to be used internally by \code{\link{optim.phylo.ls}}.
-}
-\value{
- A tree with branch lengths.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{phylogenetics}
-\keyword{phylogeny inference}
-\keyword{least squares}
-\keyword{consensus tree}
+\name{ls.tree}
+\alias{ls.tree}
+\title{Least squares branch lengths for a given tree}
+\usage{
+ls.tree(tree, D)
+}
+\arguments{
+ \item{tree}{phylogeny.}
+ \item{D}{distance matrix.}
+}
+\description{
+ Computes the least squares branch lengths conditioned on a topology and distance matrix.
+}
+\details{
+ Generally intended as a function to be used internally by \code{\link{optim.phylo.ls}}.
+}
+\value{
+ A tree with branch lengths.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{phylogenetics}
+\keyword{phylogeny inference}
+\keyword{least squares}
+\keyword{consensus tree}
diff --git a/man/ltt.Rd b/man/ltt.Rd
index 4b17097..3e663a8 100644
--- a/man/ltt.Rd
+++ b/man/ltt.Rd
@@ -1,86 +1,86 @@
-\name{ltt}
-\alias{ltt}
-\alias{ltt.phylo}
-\alias{ltt.multiPhylo}
-\alias{ltt.simmap}
-\alias{ltt.multiSimmap}
-\alias{gtt}
-\alias{mccr}
-\title{Creates lineage-through-time plot (including extinct lineages)}
-\usage{
-ltt(tree, ...)
-\method{ltt}{phylo}(tree, plot=TRUE, drop.extinct=FALSE, log.lineages=TRUE, gamma=TRUE, ...)
-\method{ltt}{multiPhylo}(tree, drop.extinct=FALSE, gamma=TRUE, ...)
-\method{ltt}{simmap}(tree, plot=TRUE, log.lineages=FALSE, gamma=TRUE, ...)
-\method{ltt}{multiSimmap}(tree, gamma=TRUE, ...)
-gtt(tree, n=100, ...)
-mccr(obj, rho=1, nsim=100, ...)
-}
-\arguments{
- \item{tree}{is a phylogenetic tree in \code{"phylo"} format, or an object of class \code{"multiPhylo"} containing a list of phylogenetic trees.}
- \item{plot}{a logical value indicating whether or not to create LTT plot.}
- \item{drop.extinct}{logical value indicating whether or not to drop extinct tips from the tree.}
- \item{log.lineages}{logical value indicating whether LTT plot should be on log-linear (default) or linear-linear scale.}
- \item{gamma}{logical value indicating whether or not to compute \eqn{\gamma} from Pybus & Harvey (2000; \emph{Proc. Roy. Soc. B}).}
- \item{n}{for \code{gtt} the number of time intervals to use to track \eqn{\gamma} through time.}
- \item{obj}{for \code{mccr} an object of class \code{"ltt"}.}
- \item{rho}{for \code{mccr} sampling fraction.}
- \item{nsim}{for \code{mccr} number of simulations to use for the MCCR test.}
- \item{...}{other arguments to be passed to plotting methods. See \code{\link{plot.default}}.}
-}
-\description{
- Computes and visualizes a lineage through time (LTT) plot, and related measures.
-}
-\details{
- The function \code{ltt} computes LTT plot with extant and extinct lineages, and optionally conducts \eqn{\gamma}-test of Pybus & Harvey (2000). The object returned by \code{ltt} can be plotted or re-plotted using \code{\link{plot}}.
-
- The function \code{gtt} computes the value of Pybus & Harvey's \eqn{\gamma} statistic through time by slicing the tree at various points - by default in even intervals from the time above the root at which \emph{N} = 3 to the present day.
-
- The function \code{mccr} performs the MCCR test of Pybus & Harvey (2000) which takes into account incomplete taxon sampling in computing a P-value of the \eqn{\gamma} statistic.
-
- Although it is calculated here, it's unclear how to interpret the \eqn{\gamma}-statistic if not all the tips in the tree are contemporaneous.
-}
-\value{
- \code{ltt} returns an object of class \code{"ltt"} which includes the following elements:
- \item{times}{a vector of branching times.}
- \item{ltt}{a vector of linages.}
- \item{gamma}{optionally, a value for the \eqn{\gamma}-statistic.}
- \item{p}{two-tailed P-value for the \eqn{\gamma}-test.}
- If \code{tree} is an object of class \code{"multiPhylo"}, then an object of class \code{"multiLtt"} is returned consisting of a list of object of class \code{"ltt"}.
-
- \code{gtt} returns an object of class \code{"gtt"}.
-
- \code{mccr} returns of object of class \code{"mccr"}.
-}
-\references{
- Pybus, O. G., and P. H. Harvey (2000) Testing macro-evolutionary models using incomplete molecular phylogenies. \emph{Proc. R. Soc. Lond. B}, \bold{267}, 2267-2272.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{gammatest}}, \code{\link{ltt95}}
-}
-\examples{
-## LTT plots
-set.seed(99)
-trees<-pbtree(n=100,scale=100,nsim=10)
-obj<-ltt(trees,plot=FALSE)
-plot(obj,log="y",log.lineages=FALSE,
- bty="l")
-title(main="LTT plots for 10 pure-birth trees",
- font.main=3)
-tree<-pbtree(b=1,d=0.25,t=4)
-obj<-ltt(tree,gamma=FALSE,show.tree=TRUE,
- bty="l")
-title(main="LTT plot with superimposed tree",
- font.main=3)
-obj
-## GTT plot
-data(anoletree)
-anole.gtt<-gtt(anoletree,n=40)
-plot(anole.gtt)
-}
-\keyword{phylogenetics}
-\keyword{plotting}
-\keyword{diversification}
+\name{ltt}
+\alias{ltt}
+\alias{ltt.phylo}
+\alias{ltt.multiPhylo}
+\alias{ltt.simmap}
+\alias{ltt.multiSimmap}
+\alias{gtt}
+\alias{mccr}
+\title{Creates lineage-through-time plot (including extinct lineages)}
+\usage{
+ltt(tree, ...)
+\method{ltt}{phylo}(tree, plot=TRUE, drop.extinct=FALSE, log.lineages=TRUE, gamma=TRUE, ...)
+\method{ltt}{multiPhylo}(tree, drop.extinct=FALSE, gamma=TRUE, ...)
+\method{ltt}{simmap}(tree, plot=TRUE, log.lineages=FALSE, gamma=TRUE, ...)
+\method{ltt}{multiSimmap}(tree, gamma=TRUE, ...)
+gtt(tree, n=100, ...)
+mccr(obj, rho=1, nsim=100, ...)
+}
+\arguments{
+ \item{tree}{is a phylogenetic tree in \code{"phylo"} format, or an object of class \code{"multiPhylo"} containing a list of phylogenetic trees.}
+ \item{plot}{a logical value indicating whether or not to create LTT plot.}
+ \item{drop.extinct}{logical value indicating whether or not to drop extinct tips from the tree.}
+ \item{log.lineages}{logical value indicating whether LTT plot should be on log-linear (default) or linear-linear scale.}
+ \item{gamma}{logical value indicating whether or not to compute \eqn{\gamma} from Pybus & Harvey (2000; \emph{Proc. Roy. Soc. B}).}
+ \item{n}{for \code{gtt} the number of time intervals to use to track \eqn{\gamma} through time.}
+ \item{obj}{for \code{mccr} an object of class \code{"ltt"}.}
+ \item{rho}{for \code{mccr} sampling fraction.}
+ \item{nsim}{for \code{mccr} number of simulations to use for the MCCR test.}
+ \item{...}{other arguments to be passed to plotting methods. See \code{\link{plot.default}}.}
+}
+\description{
+ Computes and visualizes a lineage through time (LTT) plot, and related measures.
+}
+\details{
+ The function \code{ltt} computes LTT plot with extant and extinct lineages, and optionally conducts \eqn{\gamma}-test of Pybus & Harvey (2000). The object returned by \code{ltt} can be plotted or re-plotted using \code{\link{plot}}.
+
+ The function \code{gtt} computes the value of Pybus & Harvey's \eqn{\gamma} statistic through time by slicing the tree at various points - by default in even intervals from the time above the root at which \emph{N} = 3 to the present day.
+
+ The function \code{mccr} performs the MCCR test of Pybus & Harvey (2000) which takes into account incomplete taxon sampling in computing a P-value of the \eqn{\gamma} statistic.
+
+ Although it is calculated here, it's unclear how to interpret the \eqn{\gamma}-statistic if not all the tips in the tree are contemporaneous.
+}
+\value{
+ \code{ltt} returns an object of class \code{"ltt"} which includes the following elements:
+ \item{times}{a vector of branching times.}
+ \item{ltt}{a vector of linages.}
+ \item{gamma}{optionally, a value for the \eqn{\gamma}-statistic.}
+ \item{p}{two-tailed P-value for the \eqn{\gamma}-test.}
+ If \code{tree} is an object of class \code{"multiPhylo"}, then an object of class \code{"multiLtt"} is returned consisting of a list of object of class \code{"ltt"}.
+
+ \code{gtt} returns an object of class \code{"gtt"}.
+
+ \code{mccr} returns of object of class \code{"mccr"}.
+}
+\references{
+ Pybus, O. G., and P. H. Harvey (2000) Testing macro-evolutionary models using incomplete molecular phylogenies. \emph{Proc. R. Soc. Lond. B}, \bold{267}, 2267-2272.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{gammatest}}, \code{\link{ltt95}}
+}
+\examples{
+## LTT plots
+set.seed(99)
+trees<-pbtree(n=100,scale=100,nsim=10)
+obj<-ltt(trees,plot=FALSE)
+plot(obj,log="y",log.lineages=FALSE,
+ bty="l")
+title(main="LTT plots for 10 pure-birth trees",
+ font.main=3)
+tree<-pbtree(b=1,d=0.25,t=4)
+obj<-ltt(tree,gamma=FALSE,show.tree=TRUE,
+ bty="l")
+title(main="LTT plot with superimposed tree",
+ font.main=3)
+obj
+## GTT plot
+data(anoletree)
+anole.gtt<-gtt(anoletree,n=40)
+plot(anole.gtt)
+}
+\keyword{phylogenetics}
+\keyword{plotting}
+\keyword{diversification}
diff --git a/man/ltt95.Rd b/man/ltt95.Rd
index 52d47bc..cfaeb44 100644
--- a/man/ltt95.Rd
+++ b/man/ltt95.Rd
@@ -1,34 +1,34 @@
-\name{ltt95}
-\alias{ltt95}
-\alias{plot.ltt95}
-\title{Creates a (1-\eqn{\alpha})\% CI for a set of LTTs}
-\usage{
-ltt95(trees, alpha=0.05, log=FALSE, method=c("lineages","times"),
- mode=c("median","mean"), ...)
-\method{plot}{ltt95}(x, ...)
-}
-\arguments{
- \item{trees}{is an object of class \code{"multiPhylo"} containing a list of phylogenetic trees.}
- \item{alpha}{confidence level. Defaults to \code{alpha=0.05}. \code{alpha=0} will mean that the interval around \emph{all} trees in the set will be plotted.}
- \item{log}{logical value indicating whether or not to plot on the semi-log scale.}
- \item{method}{plot the CI on the number of lineages given time (\code{"lineages"}); or on times given a number of lineages (\code{"times"}).}
- \item{mode}{plot the median or mean LTT.}
- \item{x}{object of class \code{"ltt95"} for plotting method.}
- \item{...}{optional arguments to be used by \code{ltt95} or the plotting method. So far: \code{res} gives the number of time-steps (defaults to \code{res=100}); \code{xaxis} (\code{"standard"}, \code{"negative"}, or \code{"flipped"}) determines the scale (time from the root, time back from the present, or time from the present) of the x-axis of the plot; \code{lend} determines the line end type (as in \code{\link{par}}); \code{shaded} determines whether to plot the (1-\eqn{\alpha})\% CI using dotted lines (if \code{FALSE}) or shading (if \code{TRUE}); and \code{bg} is the background color for shading if \code{shaded=TRUE}.}
-}
-\description{
- This function computes LTT plots for a set of trees & plots a (1-\eqn{\alpha})\% CI by various methods. (See \code{\link{ltt}} for more details.)
-}
-\details{
- This function creates a plot and invisibly returns an object of class \code{"ltt95"}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{ltt}}
-}
-\keyword{phylogenetics}
-\keyword{plotting}
-\keyword{diversification}
+\name{ltt95}
+\alias{ltt95}
+\alias{plot.ltt95}
+\title{Creates a (1-\eqn{\alpha})\% CI for a set of LTTs}
+\usage{
+ltt95(trees, alpha=0.05, log=FALSE, method=c("lineages","times"),
+ mode=c("median","mean"), ...)
+\method{plot}{ltt95}(x, ...)
+}
+\arguments{
+ \item{trees}{is an object of class \code{"multiPhylo"} containing a list of phylogenetic trees.}
+ \item{alpha}{confidence level. Defaults to \code{alpha=0.05}. \code{alpha=0} will mean that the interval around \emph{all} trees in the set will be plotted.}
+ \item{log}{logical value indicating whether or not to plot on the semi-log scale.}
+ \item{method}{plot the CI on the number of lineages given time (\code{"lineages"}); or on times given a number of lineages (\code{"times"}).}
+ \item{mode}{plot the median or mean LTT.}
+ \item{x}{object of class \code{"ltt95"} for plotting method.}
+ \item{...}{optional arguments to be used by \code{ltt95} or the plotting method. So far: \code{res} gives the number of time-steps (defaults to \code{res=100}); \code{xaxis} (\code{"standard"}, \code{"negative"}, or \code{"flipped"}) determines the scale (time from the root, time back from the present, or time from the present) of the x-axis of the plot; \code{lend} determines the line end type (as in \code{\link{par}}); \code{shaded} determines whether to plot the (1-\eqn{\alpha})\% CI using dotted lines (if \code{FALSE}) or shading (if \code{TRUE}); and \code{bg} is the background color for shading if \code{shaded=TRUE}.}
+}
+\description{
+ This function computes LTT plots for a set of trees & plots a (1-\eqn{\alpha})\% CI by various methods. (See \code{\link{ltt}} for more details.)
+}
+\details{
+ This function creates a plot and invisibly returns an object of class \code{"ltt95"}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{ltt}}
+}
+\keyword{phylogenetics}
+\keyword{plotting}
+\keyword{diversification}
diff --git a/man/make.era.map.Rd b/man/make.era.map.Rd
index 14655d2..99637a0 100644
--- a/man/make.era.map.Rd
+++ b/man/make.era.map.Rd
@@ -1,34 +1,34 @@
-\name{make.era.map}
-\alias{make.era.map}
-\title{Create "era" map on a phylogenetic tree}
-\usage{
-make.era.map(tree, limits, ...)
-}
-\arguments{
- \item{tree}{an object of class \code{"phylo"}.}
- \item{limits}{a vector containing the temporal limits, in time since the root node of the tree, for the mappings. The first number should be \code{0}, and each subsequent number should be the start of each subsequent regime or era to be mapped on the tree.}
- \item{...}{optional arguments.}
-}
-\description{
- Creates a temporal map on the tree based on \code{limits} provided by the user.
-}
-\value{
- An object of class \code{"simmap"} with the specified eras mapped as different regimes.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{plotSimmap}}
-}
-\examples{
-tree<-pbtree(n=1000,scale=100)
-tree<-make.era.map(tree,c(0,25,50,75))
-plot(tree,ftype="off",lwd=1)
-par(mar=c(5.1,4.1,4.1,2.1)) ## reset margins to default
-}
-\keyword{phylogenetics}
-\keyword{comparative method}
-
-
+\name{make.era.map}
+\alias{make.era.map}
+\title{Create "era" map on a phylogenetic tree}
+\usage{
+make.era.map(tree, limits, ...)
+}
+\arguments{
+ \item{tree}{an object of class \code{"phylo"}.}
+ \item{limits}{a vector containing the temporal limits, in time since the root node of the tree, for the mappings. The first number should be \code{0}, and each subsequent number should be the start of each subsequent regime or era to be mapped on the tree.}
+ \item{...}{optional arguments.}
+}
+\description{
+ Creates a temporal map on the tree based on \code{limits} provided by the user.
+}
+\value{
+ An object of class \code{"simmap"} with the specified eras mapped as different regimes.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{plotSimmap}}
+}
+\examples{
+tree<-pbtree(n=1000,scale=100)
+tree<-make.era.map(tree,c(0,25,50,75))
+plot(tree,ftype="off",lwd=1)
+par(mar=c(5.1,4.1,4.1,2.1)) ## reset margins to default
+}
+\keyword{phylogenetics}
+\keyword{comparative method}
+
+
diff --git a/man/make.simmap.Rd b/man/make.simmap.Rd
index fb429f7..15196d2 100644
--- a/man/make.simmap.Rd
+++ b/man/make.simmap.Rd
@@ -1,83 +1,86 @@
-\name{make.simmap}
-\alias{make.simmap}
-\title{Simulate stochastic character maps on a phylogenetic tree or trees}
-\usage{
-make.simmap(tree, x, model="SYM", nsim=1, ...)
-}
-\arguments{
- \item{tree}{a phylogenetic tree as an object of class \code{"phylo"}, or a list of trees as an object of class \code{"multiPhylo"}.}
- \item{x}{a vector containing the tip states for a discretely valued character, or a matrix containing the prior probabilities of tip states in rows and character states as column names. The names (if \code{x} is a vector) or row names (if \code{x} is a matrix) should match the tip labels of the tree. The vector can be of class \code{"factor"}, \code{"character"}, or \code{"numeric"} (although in the lattermost case its content should obviously be only integer values).}
- \item{model}{a character string containing the model or a transition model specified in the form of a matrix. See \code{\link{ace}} for more details.}
- \item{nsim}{number of simulations. If \code{tree} is an object of class \code{"multiPhylo"}, then \code{nsim} simulations will be conducted \emph{per} input tree.}
- \item{...}{optional arguments. So far, \code{pi} gives the prior distribution on the root node of the tree. Acceptable values for \code{pi} are \code{"equal"}, \code{"estimated"}, or a vector with the frequencies. If \code{pi="estimated"} then the stationary distribution is estimated by numerically solving \code{pi*Q=0} for \code{pi}, and this is used as a prior on the root. If \code{pi="fitzjohn"}, then the Fitzjohn et al. (2009) root prior is used. Finally, if \code{pi} is a numeric vector then the root state will be sampled from this vector. The function defaults to \code{pi="equal"} which results in the root node being sampled from the conditional scaled likelihood distribution at the root. \code{message} tells whether or not to print a message containing the rate matrix, \emph{Q} and state frequencies. \code{message} defaults to \code{TRUE}. For optional argument \code{Q="mcmc"} (see below) the mean value of \code{Q} from the posterior sample is printed. \code{tol} gives the tolerance for zero elements in \code{Q}. (Elements less then \code{tol} will be reset to \code{tol}). Optional argument \code{Q} can be a string (\code{"empirical"} or \code{"mcmc"}), or a fixed value of the transition matrix, \emph{Q}. If \code{"empirical"} than a single value of \emph{Q}, the most likely value, is used for all simulations. If \code{"mcmc"}, then \code{nsim} values of \emph{Q} are first obtained from the posterior distribution for \emph{Q} using Bayesian MCMC, then a simulated stochastic character map is generated for each sampled value of \emph{Q}. Optional argument \code{vQ} can consist of a single numeric value or a vector containing the variances of the (normal) proposal distributions for the MCMC. The order of \code{vQ} is assumed to be in the order of the \code{index.matrix} in \code{\link{ace}} for the chosen model. \code{prior} is a list containing \code{alpha} and \code{beta} parameters for the \eqn{\Gamma} prior distribution on the transition rates in \emph{Q}. Note that \code{alpha} and \code{beta} can be single values or vectors, if different priors are desired for each value in the transition matrix \emph{Q}. As for \code{vQ}, the order of \code{prior} is assumed to correspond with the order of \code{index.matrix} as in \code{\link{ace}}. \code{prior} can also be given the optional logical value \code{use.empirical} which tells the function whether or not to give the prior distribution the empirical mean for \emph{Q}. If \code{TRUE} then only \code{prior$beta} is used and \code{prior$alpha} is set equal to \code{prior$beta} times the empirical mean of \emph{Q}. \code{burnin} and \code{samplefreq} are burn-in and sample frequency for the MCMC, respectively.}
-}
-\description{
- Performs stochastic character mapping (Huelsenbeck et al., 2003) using several different alternative methods.
-}
-\details{
- For \code{Q="empirical"}, \code{make.simmap} first fits a continuous-time reversible Markov model for the evolution of \code{x} and then simulates stochastic character histories using that model and the tip states on the tree. This is the same procedure that is described in Bollback (2006), except that simulation is performed using a fixed value of the transition matrix, \emph{Q}, instead of by sampling \emph{Q} from its posterior distribution.
-
- For \code{Q="mcmc"}, \code{make.simmap} first samples \emph{Q} \code{nsim} times from the posterior probability distribution of \emph{Q} using MCMC, then it simulates \code{nsim} stochastic maps conditioned on each sampled value of \emph{Q}.
-
- For \code{Q} set to a matrix, \code{make.simmap} samples stochastic mappings conditioned on the fixed input matrix.
-
- \code{make.simmap} uses code that has been adapted from \pkg{ape}'s function \code{\link{ace}} (by Paradis et al.) to perform Felsenstein's pruning algorithm to compute the likelihood.
-
- As of \pkg{phytools} >= 0.2-33 \code{x} can be a vector of states or a matrix containing the prior probabilities of tip states in rows. In this case the column names of \code{x} should contain the states, and the row names should contain the tip names.
-
- Note that there was a small (but potentially significant) bug in how node states were simulated by \code{make.simmap} in versions of \pkg{phytools} <= 0.2-26. Between \pkg{phytools} 0.2-26 and 0.2-36 there was also a bug for asymmetric models of character change (e.g., \code{model="ARD"}). Finally, between \pkg{phytools} 0.2-33 and \pkg{phytools} 0.2-47 there was an error in use of the conditional likelihoods for the root node, which caused the root node of the tree to be sampled incorrectly. Giorgio Bianchini pointed out that in \pkg{phytools} 1.0-1 (and probably prior recent versions) there was an error sampling the state at the root node of the tree based on the input prior (\code{pi}) supplied by a user -- except for \code{pi="equal"} (a flat prior, the default) or for a prior distribution in which one or another state was known to be the global root state (e.g., \code{pi=c(1,0)}, \code{pi=c(0,1)}, etc.). All of these issues should be fixed in the current and all later versions.
-
- If \code{tree} is an object of class \code{"multiPhylo"} then \code{nsim} stochastic maps are generated for each input tree.
-}
-\value{
- A object of class \code{"simmap"} or \code{"multiSimmap"} which consists of an object of class \code{"phylo"} (or a list of such objects with class \code{"multiPhylo"}), with the following additional elements:
- \item{maps}{a list of named vectors containing the times spent in each state on each branch, in the order in which they occur.}
- \item{mapped.edge}{a matrix containing the total time spent in each state along each edge of the tree.}
- \item{Q}{the assumed or sampled value of \code{Q}.}
- \item{logL}{the log-likelihood of the assumed or sampled \code{Q}.}
-}
-\references{
- Bollback, J. P. (2006) Stochastic character mapping of discrete traits on phylogenies. \emph{BMC Bioinformatics}, \bold{7}, 88.
-
- Fitzjohn, R. G., W. P. Maddison, and S. P. Otto (2009) Estimating trait-dependent speciation and extinction rates from incompletely resolved phylogenies. \emph{Systematic Biology}, \bold{58}, 595-611.
-
- Huelsenbeck, J. P., R. Neilsen, and J. P. Bollback (2003) Stochastic mapping of morphological characters. \emph{Systematic Biology}, \bold{52}, 131-138.
-
- Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{brownie.lite}}, \code{\link{brownieREML}}, \code{\link{countSimmap}}, \code{\link{describe.simmap}}, \code{\link{evol.vcv}}, \code{\link{plotSimmap}}, \code{\link{read.simmap}}, \code{\link{write.simmap}}
-}
-\examples{
-\dontrun{
-## load tree and data from Revell & Collar (2009)
-data(sunfish.tree)
-data(sunfish.data)
-## extract discrete character (feeding mode)
-fmode<-setNames(sunfish.data$feeding.mode,
- rownames(sunfish.data))
-## do stochastic mapping
-smap.trees<-make.simmap(sunfish.tree,fmode,model="ER",
- nsim=100)
-## print a summary of the stochastic mapping
-summary(smap.trees)
-## plot a posterior probabilities of ancestral states
-cols<-setNames(c("blue","red"),levels(fmode))
-plot(summary(smap.trees),colors=cols,ftype="i")
-legend("topleft",c("non-piscivorous","piscivorous"),
- pch=21,pt.bg=cols,pt.cex=2)
-par(mar=c(5.1,4.1,4.1,2.1))
-## plot posterior density on the number of changes
-plot(density(smap.trees),bty="l")
-title(main="Posterior distribution of changes of each type",
- font.main=3)}
-}
-\keyword{ancestral states}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{simulation}
-\keyword{bayesian}
-\keyword{discrete character}
+\name{make.simmap}
+\alias{make.simmap}
+\alias{simmap}
+\title{Simulate stochastic character maps on a phylogenetic tree or trees}
+\usage{
+make.simmap(tree, x, model="SYM", nsim=1, ...)
+simmap(object, ...)
+}
+\arguments{
+ \item{tree}{a phylogenetic tree as an object of class \code{"phylo"}, or a list of trees as an object of class \code{"multiPhylo"}.}
+ \item{x}{a vector containing the tip states for a discretely valued character, or a matrix containing the prior probabilities of tip states in rows and character states as column names. The names (if \code{x} is a vector) or row names (if \code{x} is a matrix) should match the tip labels of the tree. The vector can be of class \code{"factor"}, \code{"character"}, or \code{"numeric"} (although in the lattermost case its content should obviously be only integer values).}
+ \item{model}{a character string containing the model or a transition model specified in the form of a matrix. See \code{\link{ace}} for more details.}
+ \item{nsim}{number of simulations. If \code{tree} is an object of class \code{"multiPhylo"}, then \code{nsim} simulations will be conducted \emph{per} input tree.}
+ \item{...}{optional arguments. So far, \code{pi} gives the prior distribution on the root node of the tree. Acceptable values for \code{pi} are \code{"equal"}, \code{"estimated"}, or a vector with the frequencies. If \code{pi="estimated"} then the stationary distribution is estimated by numerically solving \code{pi*Q=0} for \code{pi}, and this is used as a prior on the root. If \code{pi="fitzjohn"}, then the Fitzjohn et al. (2009) root prior is used. Finally, if \code{pi} is a numeric vector then the root state will be sampled from this vector. The function defaults to \code{pi="equal"} which results in the root node being sampled from the conditional scaled likelihood distribution at the root. \code{message} tells whether or not to print a message containing the rate matrix, \emph{Q} and state frequencies. \code{message} defaults to \code{TRUE}. For optional argument \code{Q="mcmc"} (see below) the mean value of \code{Q} from the posterior sample is printed. \code{tol} gives the tolerance for zero elements in \code{Q}. (Elements less then \code{tol} will be reset to \code{tol}). Optional argument \code{Q} can be a string (\code{"empirical"} or \code{"mcmc"}), or a fixed value of the transition matrix, \emph{Q}. If \code{"empirical"} than a single value of \emph{Q}, the most likely value, is used for all simulations. If \code{"mcmc"}, then \code{nsim} values of \emph{Q} are first obtained from the posterior distribution for \emph{Q} using Bayesian MCMC, then a simulated stochastic character map is generated for each sampled value of \emph{Q}. Optional argument \code{vQ} can consist of a single numeric value or a vector containing the variances of the (normal) proposal distributions for the MCMC. The order of \code{vQ} is assumed to be in the order of the \code{index.matrix} in \code{\link{ace}} for the chosen model. \code{prior} is a list containing \code{alpha} and \code{beta} parameters for the \eqn{\Gamma} prior distribution on the transition rates in \emph{Q}. Note that \code{alpha} and \code{beta} can be single values or vectors, if different priors are desired for each value in the transition matrix \emph{Q}. As for \code{vQ}, the order of \code{prior} is assumed to correspond with the order of \code{index.matrix} as in \code{\link{ace}}. \code{prior} can also be given the optional logical value \code{use.empirical} which tells the function whether or not to give the prior distribution the empirical mean for \emph{Q}. If \code{TRUE} then only \code{prior$beta} is used and \code{prior$alpha} is set equal to \code{prior$beta} times the empirical mean of \emph{Q}. \code{burnin} and \code{samplefreq} are burn-in and sample frequency for the MCMC, respectively.}
+ \item{object}{for generic \code{simmap} method, object of various classes: for instance, an object of class \code{"fitMk"} from \code{\link{fitMk}}.}
+}
+\description{
+ Performs stochastic character mapping (Huelsenbeck et al., 2003) using several different alternative methods.
+}
+\details{
+ For \code{Q="empirical"}, \code{make.simmap} first fits a continuous-time reversible Markov model for the evolution of \code{x} and then simulates stochastic character histories using that model and the tip states on the tree. This is the same procedure that is described in Bollback (2006), except that simulation is performed using a fixed value of the transition matrix, \emph{Q}, instead of by sampling \emph{Q} from its posterior distribution.
+
+ For \code{Q="mcmc"}, \code{make.simmap} first samples \emph{Q} \code{nsim} times from the posterior probability distribution of \emph{Q} using MCMC, then it simulates \code{nsim} stochastic maps conditioned on each sampled value of \emph{Q}.
+
+ For \code{Q} set to a matrix, \code{make.simmap} samples stochastic mappings conditioned on the fixed input matrix.
+
+ \code{make.simmap} uses code that has been adapted from \pkg{ape}'s function \code{\link{ace}} (by Paradis et al.) to perform Felsenstein's pruning algorithm to compute the likelihood.
+
+ As of \pkg{phytools} >= 0.2-33 \code{x} can be a vector of states or a matrix containing the prior probabilities of tip states in rows. In this case the column names of \code{x} should contain the states, and the row names should contain the tip names.
+
+ Note that there was a small (but potentially significant) bug in how node states were simulated by \code{make.simmap} in versions of \pkg{phytools} <= 0.2-26. Between \pkg{phytools} 0.2-26 and 0.2-36 there was also a bug for asymmetric models of character change (e.g., \code{model="ARD"}). Finally, between \pkg{phytools} 0.2-33 and \pkg{phytools} 0.2-47 there was an error in use of the conditional likelihoods for the root node, which caused the root node of the tree to be sampled incorrectly. Giorgio Bianchini pointed out that in \pkg{phytools} 1.0-1 (and probably prior recent versions) there was an error sampling the state at the root node of the tree based on the input prior (\code{pi}) supplied by a user -- except for \code{pi="equal"} (a flat prior, the default) or for a prior distribution in which one or another state was known to be the global root state (e.g., \code{pi=c(1,0)}, \code{pi=c(0,1)}, etc.). All of these issues should be fixed in the current and all later versions.
+
+ If \code{tree} is an object of class \code{"multiPhylo"} then \code{nsim} stochastic maps are generated for each input tree.
+}
+\value{
+ A object of class \code{"simmap"} or \code{"multiSimmap"} which consists of an object of class \code{"phylo"} (or a list of such objects with class \code{"multiPhylo"}), with the following additional elements:
+ \item{maps}{a list of named vectors containing the times spent in each state on each branch, in the order in which they occur.}
+ \item{mapped.edge}{a matrix containing the total time spent in each state along each edge of the tree.}
+ \item{Q}{the assumed or sampled value of \code{Q}.}
+ \item{logL}{the log-likelihood of the assumed or sampled \code{Q}.}
+}
+\references{
+ Bollback, J. P. (2006) Stochastic character mapping of discrete traits on phylogenies. \emph{BMC Bioinformatics}, \bold{7}, 88.
+
+ Fitzjohn, R. G., W. P. Maddison, and S. P. Otto (2009) Estimating trait-dependent speciation and extinction rates from incompletely resolved phylogenies. \emph{Systematic Biology}, \bold{58}, 595-611.
+
+ Huelsenbeck, J. P., R. Neilsen, and J. P. Bollback (2003) Stochastic mapping of morphological characters. \emph{Systematic Biology}, \bold{52}, 131-138.
+
+ Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{brownie.lite}}, \code{\link{brownieREML}}, \code{\link{countSimmap}}, \code{\link{describe.simmap}}, \code{\link{evol.vcv}}, \code{\link{plotSimmap}}, \code{\link{read.simmap}}, \code{\link{write.simmap}}
+}
+\examples{
+\dontrun{
+## load tree and data from Revell & Collar (2009)
+data(sunfish.tree)
+data(sunfish.data)
+## extract discrete character (feeding mode)
+fmode<-setNames(sunfish.data$feeding.mode,
+ rownames(sunfish.data))
+## do stochastic mapping
+smap.trees<-make.simmap(sunfish.tree,fmode,model="ER",
+ nsim=100)
+## print a summary of the stochastic mapping
+summary(smap.trees)
+## plot a posterior probabilities of ancestral states
+cols<-setNames(c("blue","red"),levels(fmode))
+plot(summary(smap.trees),colors=cols,ftype="i")
+legend("topleft",c("non-piscivorous","piscivorous"),
+ pch=21,pt.bg=cols,pt.cex=2)
+par(mar=c(5.1,4.1,4.1,2.1))
+## plot posterior density on the number of changes
+plot(density(smap.trees),bty="l")
+title(main="Posterior distribution of changes of each type",
+ font.main=3)}
+}
+\keyword{ancestral states}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{simulation}
+\keyword{bayesian}
+\keyword{discrete character}
diff --git a/man/map.overlap.Rd b/man/map.overlap.Rd
index 14c62d0..ead7738 100644
--- a/man/map.overlap.Rd
+++ b/man/map.overlap.Rd
@@ -1,37 +1,37 @@
-\name{map.overlap}
-\alias{map.overlap}
-\alias{Map.Overlap}
-\title{Proportional overlap between two mapped character histories on a tree}
-\usage{
-map.overlap(tree1, tree2, tol=1e-6, ...)
-Map.Overlap(tree1, tree2, tol=1e-06, standardize=TRUE, ...)
-}
-\arguments{
- \item{tree1}{an object of class \code{"simmap"}.}
- \item{tree2}{an object of class \code{"simmap"}.}
- \item{tol}{an optional tolerance value.}
- \item{standardize}{for \code{Map.Overlap}, a logical value indicating whether or not to standardize overlap by dividing by the summed branch length of the tree.}
- \item{...}{optional arguments, such as \code{check.equal}, a logical value indicating whether or not to check if \code{tree1} and \code{tree2} match in underlying topology and branch lengths (they should). This value is \code{TRUE} by default, but can be set to \code{FALSE} if \code{tree1} and \code{tree2} are known to be equal to speed up calculation.}
-}
-\description{
- Calculates the similarity of two different stochastically mapped character histories.
-}
-\details{
- \code{map.overlap} computes a single quantity giving the overall similarity of the maps, consequently this measure only makes sense of some or all of the states are shared between the two mapped tress.
-
- In \code{Map.Overlap} what is computed instead is a matrix in which the rows correspond to the states observed in \code{tree1} and the columns give the states for \code{tree2}, with the numerical values of the matrix showing the total overlap between each pair of mapped states on the two trees.
-}
-\value{
- A numerical value on the interval (0, 1), for \code{map.overlap}; or a matrix whose elements should sum to 1.0 (\code{Map.Overlap}).
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{make.simmap}}, \code{\link{read.simmap}}
-}
-\keyword{ancestral states}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{discrete character}
+\name{map.overlap}
+\alias{map.overlap}
+\alias{Map.Overlap}
+\title{Proportional overlap between two mapped character histories on a tree}
+\usage{
+map.overlap(tree1, tree2, tol=1e-6, ...)
+Map.Overlap(tree1, tree2, tol=1e-06, standardize=TRUE, ...)
+}
+\arguments{
+ \item{tree1}{an object of class \code{"simmap"}.}
+ \item{tree2}{an object of class \code{"simmap"}.}
+ \item{tol}{an optional tolerance value.}
+ \item{standardize}{for \code{Map.Overlap}, a logical value indicating whether or not to standardize overlap by dividing by the summed branch length of the tree.}
+ \item{...}{optional arguments, such as \code{check.equal}, a logical value indicating whether or not to check if \code{tree1} and \code{tree2} match in underlying topology and branch lengths (they should). This value is \code{TRUE} by default, but can be set to \code{FALSE} if \code{tree1} and \code{tree2} are known to be equal to speed up calculation.}
+}
+\description{
+ Calculates the similarity of two different stochastically mapped character histories.
+}
+\details{
+ \code{map.overlap} computes a single quantity giving the overall similarity of the maps, consequently this measure only makes sense of some or all of the states are shared between the two mapped tress.
+
+ In \code{Map.Overlap} what is computed instead is a matrix in which the rows correspond to the states observed in \code{tree1} and the columns give the states for \code{tree2}, with the numerical values of the matrix showing the total overlap between each pair of mapped states on the two trees.
+}
+\value{
+ A numerical value on the interval (0, 1), for \code{map.overlap}; or a matrix whose elements should sum to 1.0 (\code{Map.Overlap}).
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{make.simmap}}, \code{\link{read.simmap}}
+}
+\keyword{ancestral states}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{discrete character}
diff --git a/man/map.to.singleton.Rd b/man/map.to.singleton.Rd
index 42932eb..20d0a5a 100644
--- a/man/map.to.singleton.Rd
+++ b/man/map.to.singleton.Rd
@@ -1,45 +1,45 @@
-\name{map.to.singleton}
-\alias{map.to.singleton}
-\alias{plotTree.singletons}
-\alias{drop.tip.singleton}
-\alias{rootedge.to.singleton}
-\title{Converts a tree without singletons to a tree with singleton nodes}
-\usage{
-map.to.singleton(tree)
-plotTree.singletons(tree)
-\method{drop.tip}{singleton}(phy, tip, ...)
-rootedge.to.singleton(tree)
-}
-\arguments{
- \item{tree}{an object of class \code{"simmap"} (for \code{map.to.singleton}, or a tree with one or more singleton nodes (for \code{plotTree.singletons}, \code{drop.tip.singleton}, and \code{rootedge.to.singleton}).}
- \item{phy}{for \code{drop.tip.singleton}, an object of class \code{"singleton"} or \code{"phylo"}.}
- \item{tip}{for \code{drop.tip.singleton}, a tip label or vector of tip labels.}
- \item{...}{optional arguments for \code{drop.tip.singleton}.}
-}
-\description{
- \code{map.to.singleton} takes an object of class \code{"simmap"} with a mapped discrete character and converts it to a tree with singleton nodes, in which edge has only one state.
-}
-\details{
- The states for each edge are stored in \code{names(tree$edge.length)}. In a sense this is just an alternative way to use the general structure of the \code{"phylo"} object to encode a tree with a mapped character.
-
- \code{plotTree.singletons} plots a tree with singleton nodes. Note that \code{\link{plotTree}} and \code{\link{plot.phylo}} now have no trouble graphing trees with singleton nodes - but they do this by just ignoring the singletons. \code{plotTree.singletons} marks the singletons as nodes on the plotted phylogeny.
-
- \code{drop.tip.singleton} drops tips from the tree leaving ancestral nodes for all remaining tips as singletons.
-
- Finally, \code{rootedge.to.singleton} converts a tree with a root edge to a tree with a singleton node instead.
-}
-\value{
- An object of class \code{"phylo"} with singleton nodes. \code{plotTree.singletons} graphs a tree in which the singleton nodes are shown.
-
- If \code{names(tree$edge.length)!=NULL} \code{plotTree.singletons} will use a different color from \code{\link{palette}} for each mapped state.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{collapse.singles}}, \code{\link{drop.tip}}, \code{\link{make.simmap}}
-}
-\keyword{phylogenetics}
-\keyword{utilities}
-\keyword{plotting}
+\name{map.to.singleton}
+\alias{map.to.singleton}
+\alias{plotTree.singletons}
+\alias{drop.tip.singleton}
+\alias{rootedge.to.singleton}
+\title{Converts a tree without singletons to a tree with singleton nodes}
+\usage{
+map.to.singleton(tree)
+plotTree.singletons(tree)
+\method{drop.tip}{singleton}(phy, tip, ...)
+rootedge.to.singleton(tree)
+}
+\arguments{
+ \item{tree}{an object of class \code{"simmap"} (for \code{map.to.singleton}, or a tree with one or more singleton nodes (for \code{plotTree.singletons}, \code{drop.tip.singleton}, and \code{rootedge.to.singleton}).}
+ \item{phy}{for \code{drop.tip.singleton}, an object of class \code{"singleton"} or \code{"phylo"}.}
+ \item{tip}{for \code{drop.tip.singleton}, a tip label or vector of tip labels.}
+ \item{...}{optional arguments for \code{drop.tip.singleton}.}
+}
+\description{
+ \code{map.to.singleton} takes an object of class \code{"simmap"} with a mapped discrete character and converts it to a tree with singleton nodes, in which edge has only one state.
+}
+\details{
+ The states for each edge are stored in \code{names(tree$edge.length)}. In a sense this is just an alternative way to use the general structure of the \code{"phylo"} object to encode a tree with a mapped character.
+
+ \code{plotTree.singletons} plots a tree with singleton nodes. Note that \code{\link{plotTree}} and \code{\link{plot.phylo}} now have no trouble graphing trees with singleton nodes - but they do this by just ignoring the singletons. \code{plotTree.singletons} marks the singletons as nodes on the plotted phylogeny.
+
+ \code{drop.tip.singleton} drops tips from the tree leaving ancestral nodes for all remaining tips as singletons.
+
+ Finally, \code{rootedge.to.singleton} converts a tree with a root edge to a tree with a singleton node instead.
+}
+\value{
+ An object of class \code{"phylo"} with singleton nodes. \code{plotTree.singletons} graphs a tree in which the singleton nodes are shown.
+
+ If \code{names(tree$edge.length)!=NULL} \code{plotTree.singletons} will use a different color from \code{\link{palette}} for each mapped state.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{collapse.singles}}, \code{\link{drop.tip}}, \code{\link{make.simmap}}
+}
+\keyword{phylogenetics}
+\keyword{utilities}
+\keyword{plotting}
diff --git a/man/mapped.states.Rd b/man/mapped.states.Rd
index 5ba1b28..e2e9e4c 100644
--- a/man/mapped.states.Rd
+++ b/man/mapped.states.Rd
@@ -1,23 +1,23 @@
-\name{mapped.states}
-\alias{mapped.states}
-\title{Returns a vector, matrix, or list of the mapped states on a tree or set of trees}
-\usage{
-mapped.states(tree, ...)
-}
-\arguments{
- \item{tree}{a single tree or a set of trees as an object of class \code{"simmap"} or \code{"multiSimmap"}, respectively.}
- \item{...}{optional arguments.}
-}
-\description{
- Computes and orders a vector, matrix, or list of the unique mapped states on a tree or state of trees of class \code{"simmap"} or \code{"multiSimmap"}.
-}
-\value{
- A vector, matrix, or list.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{comparative method}
-\keyword{phylogenetics}
-\keyword{utilities}
+\name{mapped.states}
+\alias{mapped.states}
+\title{Returns a vector, matrix, or list of the mapped states on a tree or set of trees}
+\usage{
+mapped.states(tree, ...)
+}
+\arguments{
+ \item{tree}{a single tree or a set of trees as an object of class \code{"simmap"} or \code{"multiSimmap"}, respectively.}
+ \item{...}{optional arguments.}
+}
+\description{
+ Computes and orders a vector, matrix, or list of the unique mapped states on a tree or state of trees of class \code{"simmap"} or \code{"multiSimmap"}.
+}
+\value{
+ A vector, matrix, or list.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{comparative method}
+\keyword{phylogenetics}
+\keyword{utilities}
diff --git a/man/markChanges.Rd b/man/markChanges.Rd
index 52c5899..583e8cd 100644
--- a/man/markChanges.Rd
+++ b/man/markChanges.Rd
@@ -1,31 +1,31 @@
-\name{markChanges}
-\alias{markChanges}
-\title{Add marked changes to a plotted tree with mapped discrete character}
-\usage{
-markChanges(tree, colors=NULL, cex=1, lwd=2, plot=TRUE)
-}
-\arguments{
- \item{tree}{an object of class \code{"simmap"}.}
- \item{colors}{a named vector of colors used to plot the stochastically mapped character on the tree.}
- \item{cex}{expansion factor for line height.}
- \item{lwd}{line width.}
- \item{plot}{logical value indicating whether the changes should be plotted or not.}
-}
-\description{
- Adds the reconstructed changes to a plotted tree with a stochastically mapped discrete character.
-}
-\value{
- This function returns (invisibly) a matrix containing the x & y coordinates of the marked changes on the plotted tree.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{plotSimmap}}
-}
-\keyword{ancestral states}
-\keyword{bayesian}
-\keyword{phylogenetics}
-\keyword{plotting}
-\keyword{discrete character}
+\name{markChanges}
+\alias{markChanges}
+\title{Add marked changes to a plotted tree with mapped discrete character}
+\usage{
+markChanges(tree, colors=NULL, cex=1, lwd=2, plot=TRUE)
+}
+\arguments{
+ \item{tree}{an object of class \code{"simmap"}.}
+ \item{colors}{a named vector of colors used to plot the stochastically mapped character on the tree.}
+ \item{cex}{expansion factor for line height.}
+ \item{lwd}{line width.}
+ \item{plot}{logical value indicating whether the changes should be plotted or not.}
+}
+\description{
+ Adds the reconstructed changes to a plotted tree with a stochastically mapped discrete character.
+}
+\value{
+ This function returns (invisibly) a matrix containing the x & y coordinates of the marked changes on the plotted tree.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{plotSimmap}}
+}
+\keyword{ancestral states}
+\keyword{bayesian}
+\keyword{phylogenetics}
+\keyword{plotting}
+\keyword{discrete character}
diff --git a/man/matchNodes.Rd b/man/matchNodes.Rd
index 3934cdf..95b610b 100644
--- a/man/matchNodes.Rd
+++ b/man/matchNodes.Rd
@@ -1,33 +1,33 @@
-\name{matchNodes}
-\alias{matchNodes}
-\alias{matchLabels}
-\title{Matches nodes between two trees}
-\usage{
-matchNodes(tr1, tr2, method=c("descendants","distances"), ...)
-matchLabels(tr1, tr2)
-}
-\arguments{
- \item{tr1}{first tree.}
- \item{tr2}{second tree.}
- \item{method}{method to use to match nodes between trees. \code{"descendants"} uses the tip species descended from each node; \code{"distances"} uses the distances from the nodes to the tips. Any umambiguous shortening of \code{"descendants"} or \code{"distances"} is also permitted.}
- \item{...}{optional arguments which may or may not be used depending on the value of \code{method}. \code{tol} is a tolerance value for the difference from exact matching that is allowed for \code{method="distances"}. \code{corr}, which is \code{FALSE} by default, indicates whether to match nodes under \code{method="distances"} using the correlation (\code{corr=TRUE}) or the absolute similarity of distances.}
-}
-\description{
- This function returns a matrix in which the first column contains \emph{all} of the internal nodes of \code{tr1} and the second column contains the matching nodes from \code{tr2}, inasmuch as they can be identified.
-}
-\details{
- For \code{method="descendants"}, pairs of matching nodes are defined by sharing all descendant leaves in common.
-
- For \code{method="distances"}, nodes are considered to matched if the share the same set of distances (or proportional distances, for optional argument \code{corr=TRUE}) to all tips.
-
- \code{matchLabels} is functionally equivalent but matches node (tip) indices based on identifying matching in the labels only.
-}
-\value{
- A matrix in which the first column contains the nodes of \code{tr1} with the second column containing matching nodes in \code{tr2}, with the criterion for matching defined by \code{method}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{phylogenetics}
-\keyword{utilities}
+\name{matchNodes}
+\alias{matchNodes}
+\alias{matchLabels}
+\title{Matches nodes between two trees}
+\usage{
+matchNodes(tr1, tr2, method=c("descendants","distances"), ...)
+matchLabels(tr1, tr2)
+}
+\arguments{
+ \item{tr1}{first tree.}
+ \item{tr2}{second tree.}
+ \item{method}{method to use to match nodes between trees. \code{"descendants"} uses the tip species descended from each node; \code{"distances"} uses the distances from the nodes to the tips. Any umambiguous shortening of \code{"descendants"} or \code{"distances"} is also permitted.}
+ \item{...}{optional arguments which may or may not be used depending on the value of \code{method}. \code{tol} is a tolerance value for the difference from exact matching that is allowed for \code{method="distances"}. \code{corr}, which is \code{FALSE} by default, indicates whether to match nodes under \code{method="distances"} using the correlation (\code{corr=TRUE}) or the absolute similarity of distances.}
+}
+\description{
+ This function returns a matrix in which the first column contains \emph{all} of the internal nodes of \code{tr1} and the second column contains the matching nodes from \code{tr2}, inasmuch as they can be identified.
+}
+\details{
+ For \code{method="descendants"}, pairs of matching nodes are defined by sharing all descendant leaves in common.
+
+ For \code{method="distances"}, nodes are considered to matched if the share the same set of distances (or proportional distances, for optional argument \code{corr=TRUE}) to all tips.
+
+ \code{matchLabels} is functionally equivalent but matches node (tip) indices based on identifying matching in the labels only.
+}
+\value{
+ A matrix in which the first column contains the nodes of \code{tr1} with the second column containing matching nodes in \code{tr2}, with the criterion for matching defined by \code{method}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{phylogenetics}
+\keyword{utilities}
diff --git a/man/mergeMappedStates.Rd b/man/mergeMappedStates.Rd
index 2f64525..1f78428 100644
--- a/man/mergeMappedStates.Rd
+++ b/man/mergeMappedStates.Rd
@@ -1,34 +1,34 @@
-\name{mergeMappedStates}
-\alias{mergeMappedStates}
-\title{Merge two or more mapped states into one state}
-\usage{
-mergeMappedStates(tree, old.states, new.state)
-}
-\arguments{
- \item{tree}{an object of class \code{"simmap"} or \code{"multiSimmap"} containing one or more phylogenetic trees with a mapped discrete character.}
- \item{old.states}{states to merge.}
- \item{new.state}{name for new state.}
-}
-\description{
- Merges two or mapped states on the tree to get one new state.
-}
-\details{
- \code{mergeMappedStates} can be used to merge two or more mapped states into a single, new state. For instance, one could merge the states \code{"C"}, \code{"G"}, and \code{"T"} and define the new the state \code{"not-A"}.
-}
-\value{
- An object of class \code{"simmap"} or \code{"multiSimmap"}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{make.simmap}}, \code{\link{read.simmap}}
-}
-\keyword{ancestral states}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{simulation}
-\keyword{bayesian}
-\keyword{utilities}
-\keyword{discrete character}
+\name{mergeMappedStates}
+\alias{mergeMappedStates}
+\title{Merge two or more mapped states into one state}
+\usage{
+mergeMappedStates(tree, old.states, new.state)
+}
+\arguments{
+ \item{tree}{an object of class \code{"simmap"} or \code{"multiSimmap"} containing one or more phylogenetic trees with a mapped discrete character.}
+ \item{old.states}{states to merge.}
+ \item{new.state}{name for new state.}
+}
+\description{
+ Merges two or mapped states on the tree to get one new state.
+}
+\details{
+ \code{mergeMappedStates} can be used to merge two or more mapped states into a single, new state. For instance, one could merge the states \code{"C"}, \code{"G"}, and \code{"T"} and define the new the state \code{"not-A"}.
+}
+\value{
+ An object of class \code{"simmap"} or \code{"multiSimmap"}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{make.simmap}}, \code{\link{read.simmap}}
+}
+\keyword{ancestral states}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{simulation}
+\keyword{bayesian}
+\keyword{utilities}
+\keyword{discrete character}
diff --git a/man/midpoint.root.Rd b/man/midpoint.root.Rd
index 117b345..c393051 100644
--- a/man/midpoint.root.Rd
+++ b/man/midpoint.root.Rd
@@ -1,34 +1,34 @@
-\name{midpoint.root}
-\alias{midpoint.root}
-\title{Midpoint root a phylogeny}
-\usage{
-midpoint.root(tree)
-}
-\arguments{
- \item{tree}{an object of class \code{"phylo"}.}
-}
-\description{
- This function midpoint roots a rooted or unrooted tree (Farris 1972).
-}
-\details{
- Midpoint rooting involves locating the midpoint of the longest path between any two tips and putting the root in that location.
-
- This function performs the same operation as \code{\link{midpoint}} in the \pkg{phangorn} package, but uses no \pkg{phangorn} code internally.
-}
-\value{
- An object of class \code{"phylo"} containing a rooted phylogenetic tree.
-}
-\references{
- Farris, J. (1972) Estimating phylogenetic trees from distance matrices. \emph{American Naturalist}, \bold{106}, 645-667.
-
- Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{midpoint}}, \code{\link{reroot}}, \code{\link{root}}
-}
-\keyword{phylogenetics}
-\keyword{utilities}
-\keyword{phylogeny inference}
+\name{midpoint.root}
+\alias{midpoint.root}
+\title{Midpoint root a phylogeny}
+\usage{
+midpoint.root(tree)
+}
+\arguments{
+ \item{tree}{an object of class \code{"phylo"}.}
+}
+\description{
+ This function midpoint roots a rooted or unrooted tree (Farris 1972).
+}
+\details{
+ Midpoint rooting involves locating the midpoint of the longest path between any two tips and putting the root in that location.
+
+ This function performs the same operation as \code{\link{midpoint}} in the \pkg{phangorn} package, but uses no \pkg{phangorn} code internally.
+}
+\value{
+ An object of class \code{"phylo"} containing a rooted phylogenetic tree.
+}
+\references{
+ Farris, J. (1972) Estimating phylogenetic trees from distance matrices. \emph{American Naturalist}, \bold{106}, 645-667.
+
+ Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{midpoint}}, \code{\link{reroot}}, \code{\link{root}}
+}
+\keyword{phylogenetics}
+\keyword{utilities}
+\keyword{phylogeny inference}
diff --git a/man/minRotate.Rd b/man/minRotate.Rd
index 67156db..850e56d 100644
--- a/man/minRotate.Rd
+++ b/man/minRotate.Rd
@@ -1,28 +1,28 @@
-\name{minRotate}
-\alias{minRotate}
-\alias{tipRotate}
-\title{Rotates all nodes of the tree to minimize the difference in order with a vector}
-\usage{
-minRotate(tree, x, ...)
-tipRotate(tree, x, ...)
-}
-\arguments{
- \item{tree}{tree.}
- \item{x}{numeric vector.}
- \item{...}{optional arguments to be used by \code{tipRotate}. Presently optional arguments can be \code{fn}, function to be used to compute the distance between the order of the tip labels in \code{tree} and the numeric vector \code{x} (presently \code{fn=function(x) x^2} by default); \code{methods}, the method or methods of tree traversal (can be \code{"pre"}, \code{"post"}, or \code{c("pre","post")}, for pre-, post-, or both pre- and post-order tree traversal); \code{rotate.multi}, whether to rotate multifurcations in all possible ways using \code{rotate.multi} (defaults to \code{FALSE}); and \code{print}, a logical argument specifying whether to print the search progress or to behave quietly. Only the option \code{print} is available for \code{minRotate}.}
-}
-\description{
- Rotates all the nodes of the tree to try and minimize the different between the order of the tips and the rank-order of a numeric vector \code{x} or (in the case of \code{tipRotate}) the actual integer vector, \code{x}.
-}
-\details{
- Both \code{minRotate} and \code{tipRotate} are designed primarily to be used internally by other \pkg{phytools} functions and particularly by \code{\link{phylo.to.map}} (in the case of \code{minRotate}) and by \code{\link{cophylo}} (in the case of \code{tipRotate}).
-}
-\value{
- A node-rotated object of class \code{"phylo"}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{phylogenetics}
-\keyword{utilities}
+\name{minRotate}
+\alias{minRotate}
+\alias{tipRotate}
+\title{Rotates all nodes of the tree to minimize the difference in order with a vector}
+\usage{
+minRotate(tree, x, ...)
+tipRotate(tree, x, ...)
+}
+\arguments{
+ \item{tree}{tree.}
+ \item{x}{numeric vector.}
+ \item{...}{optional arguments to be used by \code{tipRotate}. Presently optional arguments can be \code{fn}, function to be used to compute the distance between the order of the tip labels in \code{tree} and the numeric vector \code{x} (presently \code{fn=function(x) x^2} by default); \code{methods}, the method or methods of tree traversal (can be \code{"pre"}, \code{"post"}, or \code{c("pre","post")}, for pre-, post-, or both pre- and post-order tree traversal); \code{rotate.multi}, whether to rotate multifurcations in all possible ways using \code{rotate.multi} (defaults to \code{FALSE}); and \code{print}, a logical argument specifying whether to print the search progress or to behave quietly. Only the option \code{print} is available for \code{minRotate}.}
+}
+\description{
+ Rotates all the nodes of the tree to try and minimize the different between the order of the tips and the rank-order of a numeric vector \code{x} or (in the case of \code{tipRotate}) the actual integer vector, \code{x}.
+}
+\details{
+ Both \code{minRotate} and \code{tipRotate} are designed primarily to be used internally by other \pkg{phytools} functions and particularly by \code{\link{phylo.to.map}} (in the case of \code{minRotate}) and by \code{\link{cophylo}} (in the case of \code{tipRotate}).
+}
+\value{
+ A node-rotated object of class \code{"phylo"}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{phylogenetics}
+\keyword{utilities}
diff --git a/man/minSplit.Rd b/man/minSplit.Rd
index d3e9dca..94fbcfe 100644
--- a/man/minSplit.Rd
+++ b/man/minSplit.Rd
@@ -1,32 +1,32 @@
-\name{minSplit}
-\alias{minSplit}
-\title{Finding the minimum (median) split in the posterior sample}
-\usage{
-minSplit(tree, split.list, method="sum", printD=FALSE)
-}
-\arguments{
- \item{tree}{an object of class \code{"phylo"}.}
- \item{split.list}{either a matrix with two named columns, \code{"node"} and \code{"bp"}; a \code{$mcmc} matrix from \code{evol.rate.mcmc()}; or the entire raw output from \code{evol.rate.mcmc()}.}
- \item{method}{an optional string indicating the criterion to minimize: options are \code{"sum"} and \code{"sumsq"}.}
- \item{printD}{logical specifying whether to print distances to screen (\code{FALSE} by default).}
-}
-\description{
- This function takes a phylogenetic tree and a list of splits and identifies the split with the smallest summed or summed squared distances to all the other splits.
-}
-\value{
- A list with the following elements:
- \item{node}{node for the minimum split.}
- \item{bp}{location on the branch leading to \code{node} of the minimum split.}
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-
- Revell, L. J., D. L. Mahler, P. Peres-Neto, and B. D. Redelings (2012) A new method for identifying exceptional phenotypic diversification. \emph{Evolution}, \bold{66}, 135-146.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{evol.rate.mcmc}}, \code{\link{posterior.evolrate}}
-}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{bayesian}
+\name{minSplit}
+\alias{minSplit}
+\title{Finding the minimum (median) split in the posterior sample}
+\usage{
+minSplit(tree, split.list, method="sum", printD=FALSE)
+}
+\arguments{
+ \item{tree}{an object of class \code{"phylo"}.}
+ \item{split.list}{either a matrix with two named columns, \code{"node"} and \code{"bp"}; a \code{$mcmc} matrix from \code{evol.rate.mcmc()}; or the entire raw output from \code{evol.rate.mcmc()}.}
+ \item{method}{an optional string indicating the criterion to minimize: options are \code{"sum"} and \code{"sumsq"}.}
+ \item{printD}{logical specifying whether to print distances to screen (\code{FALSE} by default).}
+}
+\description{
+ This function takes a phylogenetic tree and a list of splits and identifies the split with the smallest summed or summed squared distances to all the other splits.
+}
+\value{
+ A list with the following elements:
+ \item{node}{node for the minimum split.}
+ \item{bp}{location on the branch leading to \code{node} of the minimum split.}
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+
+ Revell, L. J., D. L. Mahler, P. Peres-Neto, and B. D. Redelings (2012) A new method for identifying exceptional phenotypic diversification. \emph{Evolution}, \bold{66}, 135-146.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{evol.rate.mcmc}}, \code{\link{posterior.evolrate}}
+}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{bayesian}
diff --git a/man/modified.Grafen.Rd b/man/modified.Grafen.Rd
index 7539685..b26388b 100644
--- a/man/modified.Grafen.Rd
+++ b/man/modified.Grafen.Rd
@@ -1,35 +1,35 @@
-\name{modified.Grafen}
-\alias{modified.Grafen}
-\alias{node.paths}
-\title{Computes modified Grafen edge lengths}
-\usage{
-modified.Grafen(tree, power=2)
-node.paths(tree, node)
-}
-\arguments{
- \item{tree}{object of class \code{"phylo"}.}
- \item{power}{power to raise the depths of each node (in nodes).}
- \item{node}{node number for \code{node.paths}.}
-}
-\description{
- Computes modified Grafen (1989) edge lengths.
-}
-\details{
- This function computes modified Grafen edge lengths in which the length of the edge is determined not by the number of descendant leaves, but instead by the maximum number of node lengths in the path from the node to any leaf.
-
- \code{node.paths} is used internally by \code{modified.Grafen} and computes the set of paths from a node to all tips descended from that node.
-}
-\value{
- An object of class \code{"phylo"} with edge lengths.
-}
-\references{
- Grafen, A. (1989) The phylogenetic regression. \emph{Philosophical Transactions of the Royal Society of London. Series B. Biological Sciences}, \bold{326}, 119-157.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{compute.brlen}}
-}
-\keyword{phylogenetics}
-\keyword{utilities}
+\name{modified.Grafen}
+\alias{modified.Grafen}
+\alias{node.paths}
+\title{Computes modified Grafen edge lengths}
+\usage{
+modified.Grafen(tree, power=2)
+node.paths(tree, node)
+}
+\arguments{
+ \item{tree}{object of class \code{"phylo"}.}
+ \item{power}{power to raise the depths of each node (in nodes).}
+ \item{node}{node number for \code{node.paths}.}
+}
+\description{
+ Computes modified Grafen (1989) edge lengths.
+}
+\details{
+ This function computes modified Grafen edge lengths in which the length of the edge is determined not by the number of descendant leaves, but instead by the maximum number of node lengths in the path from the node to any leaf.
+
+ \code{node.paths} is used internally by \code{modified.Grafen} and computes the set of paths from a node to all tips descended from that node.
+}
+\value{
+ An object of class \code{"phylo"} with edge lengths.
+}
+\references{
+ Grafen, A. (1989) The phylogenetic regression. \emph{Philosophical Transactions of the Royal Society of London. Series B. Biological Sciences}, \bold{326}, 119-157.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{compute.brlen}}
+}
+\keyword{phylogenetics}
+\keyword{utilities}
diff --git a/man/mrp.supertree.Rd b/man/mrp.supertree.Rd
index 839a9fb..e80a8c4 100644
--- a/man/mrp.supertree.Rd
+++ b/man/mrp.supertree.Rd
@@ -1,51 +1,51 @@
-\name{mrp.supertree}
-\alias{mrp.supertree}
-\alias{compute.mr}
-\title{Matrix representation parsimony supertree estimation}
-\usage{
-mrp.supertree(trees, method=c("pratchet","optim.parsimony"), ...)
-compute.mr(trees, type=c("phyDat","matrix"))
-}
-\arguments{
- \item{trees}{an object of class \code{"multiPhylo"} that consists of a list of phylogenetic trees.}
- \item{method}{an argument specifying whether to optimize the tree using the \pkg{phangorn} parsimony optimizer \code{\link{pratchet}} or \code{\link{optim.parsimony}}.}
- \item{type}{for \code{compute.mr}, the type of object to return (e.g., \code{"phyDat"} or \code{"matrix"}).}
- \item{...}{optional arguments - mostly to be passed to \code{\link{pratchet}} or \code{\link{optim.parsimony}}.}
-}
-\description{
- This function estimates the MRP (matrix representation parsimony) supertree from a set of input trees (Baum 1992; Ragan 1992).
-}
-\details{
- \code{mrp.supertree} uses \code{\link{pratchet}} or \code{\link{optim.parsimony}} from the \pkg{phangorn} package (Schliep, 2011) for optimization, and \code{\link{prop.part}} from \pkg{ape} package (Paradis et al. 2004).
-
- See \code{\link{pratchet}} or \code{\link{optim.parsimony}} for optional arguments, which vary slightly depending on the method. All optional arguments of these methods are available to the user with one exception. The argument \code{tree} in \code{\link{optim.parsimony}} is supplied instead as \code{start}. In addition to being an object of class \code{"phylo"}, \code{start} can also be assigned the string values of \code{"NJ"} or \code{"random"}, in which case either a neighbor-joining or random tree will be used as the starting tree for optimization.
-
- The function \code{compute.mr} computes the matrix-representation matrix of the input trees. It is used internally by \code{mrp.supertree}, but can also be used to export an object that can be written to file if desired.
-}
-\value{
- An object of class \code{"phylo"} or \code{"multiPhylo"} that is the MP or set of MP MRP trees.
-
- In the case of \code{compute.mr}, an object of class \code{"phyDat"} or a matrix.
-}
-\references{
- Baum, B. R., (1992) Combining trees as a way of combining data sets for phylogenetic inference, and the desirability of combining gene trees. \emph{Taxon}, \bold{41}, 3-10.
-
- Felsenstein, J. (2004) \emph{Inferring Phylogenies}. Sinauer.
-
- Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290.
-
- Ragan, M. A. (1992) Phylogenetic inference based on matrix representation of trees. \emph{Molecular Phylogenetics and Evolution}, \emph{1}, 53-58.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-
- Schliep, K. P. (2011) phangorn: phylogenetic analysis in R. \emph{Bioinformatics}, \bold{27}, 592-593.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{exhaustiveMP}}, \code{\link{optim.parsimony}}, \code{\link{pratchet}}
-}
-\keyword{phylogenetics}
-\keyword{phylogeny inference}
-\keyword{parsimony}
-\keyword{supertree}
-\keyword{consensus tree}
+\name{mrp.supertree}
+\alias{mrp.supertree}
+\alias{compute.mr}
+\title{Matrix representation parsimony supertree estimation}
+\usage{
+mrp.supertree(trees, method=c("pratchet","optim.parsimony"), ...)
+compute.mr(trees, type=c("phyDat","matrix"))
+}
+\arguments{
+ \item{trees}{an object of class \code{"multiPhylo"} that consists of a list of phylogenetic trees.}
+ \item{method}{an argument specifying whether to optimize the tree using the \pkg{phangorn} parsimony optimizer \code{\link{pratchet}} or \code{\link{optim.parsimony}}.}
+ \item{type}{for \code{compute.mr}, the type of object to return (e.g., \code{"phyDat"} or \code{"matrix"}).}
+ \item{...}{optional arguments - mostly to be passed to \code{\link{pratchet}} or \code{\link{optim.parsimony}}.}
+}
+\description{
+ This function estimates the MRP (matrix representation parsimony) supertree from a set of input trees (Baum 1992; Ragan 1992).
+}
+\details{
+ \code{mrp.supertree} uses \code{\link{pratchet}} or \code{\link{optim.parsimony}} from the \pkg{phangorn} package (Schliep, 2011) for optimization, and \code{\link{prop.part}} from \pkg{ape} package (Paradis et al. 2004).
+
+ See \code{\link{pratchet}} or \code{\link{optim.parsimony}} for optional arguments, which vary slightly depending on the method. All optional arguments of these methods are available to the user with one exception. The argument \code{tree} in \code{\link{optim.parsimony}} is supplied instead as \code{start}. In addition to being an object of class \code{"phylo"}, \code{start} can also be assigned the string values of \code{"NJ"} or \code{"random"}, in which case either a neighbor-joining or random tree will be used as the starting tree for optimization.
+
+ The function \code{compute.mr} computes the matrix-representation matrix of the input trees. It is used internally by \code{mrp.supertree}, but can also be used to export an object that can be written to file if desired.
+}
+\value{
+ An object of class \code{"phylo"} or \code{"multiPhylo"} that is the MP or set of MP MRP trees.
+
+ In the case of \code{compute.mr}, an object of class \code{"phyDat"} or a matrix.
+}
+\references{
+ Baum, B. R., (1992) Combining trees as a way of combining data sets for phylogenetic inference, and the desirability of combining gene trees. \emph{Taxon}, \bold{41}, 3-10.
+
+ Felsenstein, J. (2004) \emph{Inferring Phylogenies}. Sinauer.
+
+ Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290.
+
+ Ragan, M. A. (1992) Phylogenetic inference based on matrix representation of trees. \emph{Molecular Phylogenetics and Evolution}, \emph{1}, 53-58.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+
+ Schliep, K. P. (2011) phangorn: phylogenetic analysis in R. \emph{Bioinformatics}, \bold{27}, 592-593.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{exhaustiveMP}}, \code{\link{optim.parsimony}}, \code{\link{pratchet}}
+}
+\keyword{phylogenetics}
+\keyword{phylogeny inference}
+\keyword{parsimony}
+\keyword{supertree}
+\keyword{consensus tree}
diff --git a/man/multi.mantel.Rd b/man/multi.mantel.Rd
index da447ee..15a8231 100644
--- a/man/multi.mantel.Rd
+++ b/man/multi.mantel.Rd
@@ -1,41 +1,41 @@
-\name{multi.mantel}
-\alias{multi.mantel}
-\title{Multiple matrix regression (partial Mantel test)}
-\usage{
-multi.mantel(Y, X, nperm=1000)
-}
-\arguments{
- \item{Y}{single "dependent" square matrix. Can be either a symmetric matrix of class \code{"matrix"} or a distance matrix of class \code{"dist"}.}
- \item{X}{a single independent matrix or multiple independent matrices in a list. As with \code{Y} can be a object of class \code{"matrix"} or class \code{"dist"}, or a list of such objects.}
- \item{nperm}{number of Mantel permutations to be used to compute a P-value of the test.}
-}
-\description{
- This function conducting a multiple matrix regression (partial Mantel test) and uses Mantel (1967) permutations to test the significance of the model and individual coefficients. It also returns the residual and predicted matrices.
-}
-\value{
- An object of class \code{"multi.mantel"} consisting of the following elements:
- \item{r.squared}{multiple R-squared.}
- \item{coefficients}{model coefficients, including intercept.}
- \item{tstatistic}{t-statistics for model coefficients.}
- \item{fstatistic}{F-statistic for the overall model.}
- \item{probt}{vector of probabilities, based on permutations, for \code{tstatistic}.}
- \item{probF}{probability of F, based on Mantel permutations.}
- \item{residuals}{matrix of residuals.}
- \item{predicted}{matrix of predicted values.}
- \item{nperm}{tne number of permutations used.}
-}
-\details{
- Printing the object to screen will result in a summary of the analysis similar to \code{summary.lm}, but with p-values derived from Mantel permutations.
-
- Methods \code{residuals} and \code{fitted} can be used to return residual and fitted matrices, respectively.
-}
-\references{
- Mantel, N. (1967) The detection of disease clustering and a generalized regression approach. \emph{Cancer Research}, \bold{27}, 209--220.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{comparative method}
-\keyword{statistics}
-\keyword{least squares}
-\keyword{distance matrix}
+\name{multi.mantel}
+\alias{multi.mantel}
+\title{Multiple matrix regression (partial Mantel test)}
+\usage{
+multi.mantel(Y, X, nperm=1000)
+}
+\arguments{
+ \item{Y}{single "dependent" square matrix. Can be either a symmetric matrix of class \code{"matrix"} or a distance matrix of class \code{"dist"}.}
+ \item{X}{a single independent matrix or multiple independent matrices in a list. As with \code{Y} can be a object of class \code{"matrix"} or class \code{"dist"}, or a list of such objects.}
+ \item{nperm}{number of Mantel permutations to be used to compute a P-value of the test.}
+}
+\description{
+ This function conducting a multiple matrix regression (partial Mantel test) and uses Mantel (1967) permutations to test the significance of the model and individual coefficients. It also returns the residual and predicted matrices.
+}
+\value{
+ An object of class \code{"multi.mantel"} consisting of the following elements:
+ \item{r.squared}{multiple R-squared.}
+ \item{coefficients}{model coefficients, including intercept.}
+ \item{tstatistic}{t-statistics for model coefficients.}
+ \item{fstatistic}{F-statistic for the overall model.}
+ \item{probt}{vector of probabilities, based on permutations, for \code{tstatistic}.}
+ \item{probF}{probability of F, based on Mantel permutations.}
+ \item{residuals}{matrix of residuals.}
+ \item{predicted}{matrix of predicted values.}
+ \item{nperm}{tne number of permutations used.}
+}
+\details{
+ Printing the object to screen will result in a summary of the analysis similar to \code{summary.lm}, but with p-values derived from Mantel permutations.
+
+ Methods \code{residuals} and \code{fitted} can be used to return residual and fitted matrices, respectively.
+}
+\references{
+ Mantel, N. (1967) The detection of disease clustering and a generalized regression approach. \emph{Cancer Research}, \bold{27}, 209--220.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{comparative method}
+\keyword{statistics}
+\keyword{least squares}
+\keyword{distance matrix}
diff --git a/man/multiRF.Rd b/man/multiRF.Rd
index d78e249..e97e589 100644
--- a/man/multiRF.Rd
+++ b/man/multiRF.Rd
@@ -1,29 +1,29 @@
-\name{multiRF}
-\alias{multiRF}
-\title{Computes Robinson-Foulds distance between a set of trees}
-\usage{
-multiRF(trees,quiet=FALSE,multi2di=FALSE)
-}
-\arguments{
- \item{trees}{object of class \code{"multiPhylo"} consisting of two or more fully bifurcating, unrooted trees. If trees are rooted, they will be unrooted.}
- \item{quiet}{logical argument indicating whether or not to run quietly. (Defaults to \code{FALSE}.)}
- \item{multi2di}{logical argumenet indicating whether or not to resolve multifurcating trees. (Defaults to \code{FALSE}.)}
-}
-\description{
- Computes the Robinson-Foulds (Robinson & Foulds 1981) distance between a set of trees in an object of class \code{"multiPhylo"}.
-}
-\details{
- Computes the Robinson-Foulds distance between all phylogenies in an object of class \code{"multiPhylo"}. Uses \code{\link{prop.part}} internally for most of the heavy lifting.
-}
-\value{
- A matrix containing distances.
-}
-\references{
- Robinson, D. R., Foulds, L. R. (1981) Comparison of phylogenetic trees. \emph{Mathematical Biosciences}, \bold{53}, 131-147.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{phylogenetics}
-\keyword{utilities}
-\keyword{phylogeny inference}
+\name{multiRF}
+\alias{multiRF}
+\title{Computes Robinson-Foulds distance between a set of trees}
+\usage{
+multiRF(trees,quiet=FALSE,multi2di=FALSE)
+}
+\arguments{
+ \item{trees}{object of class \code{"multiPhylo"} consisting of two or more fully bifurcating, unrooted trees. If trees are rooted, they will be unrooted.}
+ \item{quiet}{logical argument indicating whether or not to run quietly. (Defaults to \code{FALSE}.)}
+ \item{multi2di}{logical argumenet indicating whether or not to resolve multifurcating trees. (Defaults to \code{FALSE}.)}
+}
+\description{
+ Computes the Robinson-Foulds (Robinson & Foulds 1981) distance between a set of trees in an object of class \code{"multiPhylo"}.
+}
+\details{
+ Computes the Robinson-Foulds distance between all phylogenies in an object of class \code{"multiPhylo"}. Uses \code{\link{prop.part}} internally for most of the heavy lifting.
+}
+\value{
+ A matrix containing distances.
+}
+\references{
+ Robinson, D. R., Foulds, L. R. (1981) Comparison of phylogenetic trees. \emph{Mathematical Biosciences}, \bold{53}, 131-147.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{phylogenetics}
+\keyword{utilities}
+\keyword{phylogeny inference}
diff --git a/man/multirateBM.Rd b/man/multirateBM.Rd
index 938f46a..9bd4803 100644
--- a/man/multirateBM.Rd
+++ b/man/multirateBM.Rd
@@ -1,67 +1,67 @@
-\name{multirateBM}
-\alias{multirateBM}
-\title{Function to fit a multi-rate Brownian evolution model}
-\usage{
-multirateBM(tree, x, method=c("ML","REML"),
- optim=c("L-BFGS-B","Nelder-Mead","BFGS","CG"),
- maxit=NULL, n.iter=1, lambda=1, ...)
-}
-\arguments{
- \item{tree}{an object of class \code{"phylo"}.}
- \item{x}{a named numerical vector. Names should correspond to the species names of \code{tree}.}
- \item{method}{method of optimization. Currently only \code{method="ML"}.}
- \item{optim}{optimization routine to be used by \code{\link{optim}}. If more than one is specified and \code{n.iter>1} then they will be alternated. (This is recommended to improve optimization.)}
- \item{maxit}{to be passed to \code{optim}. If set to \code{maxit=NULL}, the default value of \code{maxit} will be used, depending on the optimization method.}
- \item{n.iter}{number of times to reiterate failed optimization.}
- \item{lambda}{lambda penalty term. High values of \code{lambda} correspond to high penalty for rate heterogeneity among edges. Low values of \code{lambda} correspond to low penalty.}
- \item{...}{optional arguments.}
-}
-\description{
- Fits a flexible multi-rate Brownian motion evolution model using penalized likelihood.
-}
-\details{
- This function fits a flexible Brownian multi-rate model using penalized likelihood.
-
- The model that is being fit is one in which the rate of Brownian motion evolution itself evolves from edge to edge in the tree under a process of geometric Brownian evolution (i.e., Brownian motion evolution on a log scale).
-
- The penalty term, \code{lambda}, determines the cost of variation in the rate of evolution from branch to branch. If lambda is \emph{high}, then the rate of evolution will vary relatively little between edges (and in the limiting case converge to the single-rate MLE estimate of the rate). By contrast, if the value of \code{lambda} is set to be low, then the rate of evolution can vary from edge to edge with relatively little penalty.
-
- Decreasing the penalty term, however, is not without cost. As \code{lambda} is decreased towards zero, estimated rates will tend to become less and less accurate.
-}
-\value{
- An object of class \code{"multirateBM"}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-
- Revell, L. J. (2021) A variable-rate quantitative trait evolution model using penalized-likelihood. \emph{PeerJ}, \bold{9}, e11997.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{brownie.lite}}, \code{\link{evol.rate.mcmc}}
-}
-\examples{
-\dontrun{
-## load data
-data(sunfish.tree)
-data(sunfish.data)
-## convert from "simmap" to "phylo"
-sunfish.tree<-as.phylo(sunfish.tree)
-## extract character of interest
-gw<-setNames(sunfish.data$gape.width,
- rownames(sunfish.data))
-## run penalized-likelihood optimization
-## lambda=0.1 is arbitrary
-fitBM<-multirateBM(sunfish.tree,gw,
- lambda=0.01)
-## print and plot the results
-print(fitBM)
-plot(fitBM,ftype="i",fsize=0.8,lwd=6,
- outline=TRUE)
-## reset par
-par(mar=c(5.1,4.1,4.1,2.1))}
-}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{continuous character}
-\keyword{maximum likelihood}
+\name{multirateBM}
+\alias{multirateBM}
+\title{Function to fit a multi-rate Brownian evolution model}
+\usage{
+multirateBM(tree, x, method=c("ML","REML"),
+ optim=c("L-BFGS-B","Nelder-Mead","BFGS","CG"),
+ maxit=NULL, n.iter=1, lambda=1, ...)
+}
+\arguments{
+ \item{tree}{an object of class \code{"phylo"}.}
+ \item{x}{a named numerical vector. Names should correspond to the species names of \code{tree}.}
+ \item{method}{method of optimization. Currently only \code{method="ML"}.}
+ \item{optim}{optimization routine to be used by \code{\link{optim}}. If more than one is specified and \code{n.iter>1} then they will be alternated. (This is recommended to improve optimization.)}
+ \item{maxit}{to be passed to \code{optim}. If set to \code{maxit=NULL}, the default value of \code{maxit} will be used, depending on the optimization method.}
+ \item{n.iter}{number of times to reiterate failed optimization.}
+ \item{lambda}{lambda penalty term. High values of \code{lambda} correspond to high penalty for rate heterogeneity among edges. Low values of \code{lambda} correspond to low penalty.}
+ \item{...}{optional arguments.}
+}
+\description{
+ Fits a flexible multi-rate Brownian motion evolution model using penalized likelihood.
+}
+\details{
+ This function fits a flexible Brownian multi-rate model using penalized likelihood.
+
+ The model that is being fit is one in which the rate of Brownian motion evolution itself evolves from edge to edge in the tree under a process of geometric Brownian evolution (i.e., Brownian motion evolution on a log scale).
+
+ The penalty term, \code{lambda}, determines the cost of variation in the rate of evolution from branch to branch. If lambda is \emph{high}, then the rate of evolution will vary relatively little between edges (and in the limiting case converge to the single-rate MLE estimate of the rate). By contrast, if the value of \code{lambda} is set to be low, then the rate of evolution can vary from edge to edge with relatively little penalty.
+
+ Decreasing the penalty term, however, is not without cost. As \code{lambda} is decreased towards zero, estimated rates will tend to become less and less accurate.
+}
+\value{
+ An object of class \code{"multirateBM"}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+
+ Revell, L. J. (2021) A variable-rate quantitative trait evolution model using penalized-likelihood. \emph{PeerJ}, \bold{9}, e11997.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{brownie.lite}}, \code{\link{evol.rate.mcmc}}
+}
+\examples{
+\dontrun{
+## load data
+data(sunfish.tree)
+data(sunfish.data)
+## convert from "simmap" to "phylo"
+sunfish.tree<-as.phylo(sunfish.tree)
+## extract character of interest
+gw<-setNames(sunfish.data$gape.width,
+ rownames(sunfish.data))
+## run penalized-likelihood optimization
+## lambda=0.1 is arbitrary
+fitBM<-multirateBM(sunfish.tree,gw,
+ lambda=0.01)
+## print and plot the results
+print(fitBM)
+plot(fitBM,ftype="i",fsize=0.8,lwd=6,
+ outline=TRUE)
+## reset par
+par(mar=c(5.1,4.1,4.1,2.1))}
+}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{continuous character}
+\keyword{maximum likelihood}
diff --git a/man/nodeHeights.Rd b/man/nodeHeights.Rd
index 205ddf2..e19ce69 100644
--- a/man/nodeHeights.Rd
+++ b/man/nodeHeights.Rd
@@ -1,43 +1,43 @@
-\name{nodeHeights}
-\alias{nodeHeights}
-\alias{nodeheight}
-\title{Compute the heights above the root of each node}
-\usage{
-nodeHeights(tree, ...)
-nodeheight(tree, node, ...)
-}
-\arguments{
- \item{tree}{a phylogeny as an object of class \code{"phylo"}.}
- \item{node}{for \code{nodeheight}, the node for which we want to compute a height above the root (or including the root edge, for \code{root.edge=TRUE}).}
- \item{...}{optional arguments - presently only \code{root.edge}, a logical value indicating whether or not to include the root edge length in the calculation of node heights.}
-}
-\description{
- \code{nodeHeights} computes the height above the root for all nodes in the tree. \code{nodeheight} computes the height above the root for a single node.
-}
-\details{
- The function \code{nodeHeights} also gives a handy way to get the total length of the tree from the root to the heighest tip which will be given by \code{max(nodeHeights(tree))}.
-
- Generally speaking, \code{nodeHeights} will be faster if the heights of all or a large proportion of nodes is needed, wherease \code{nodeheight} will be faster if the height of one or a small number of nodes are needed.
-}
-\value{
- Either a matrix of the same dimensions as \code{tree$edge} containing the height above the root of each node in \code{edge} (for \code{nodeHeights}); or a single positive number (for \code{nodeheight}).
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{vcvPhylo}}
-}
-\examples{
-## load tree
-data(vertebrate.tree)
-## compute height of all nodes
-H<-nodeHeights(vertebrate.tree)
-print(H)
-## compute total tree depth
-max(H)
-}
-\keyword{phylogenetics}
-\keyword{utilities}
-\keyword{comparative method}
+\name{nodeHeights}
+\alias{nodeHeights}
+\alias{nodeheight}
+\title{Compute the heights above the root of each node}
+\usage{
+nodeHeights(tree, ...)
+nodeheight(tree, node, ...)
+}
+\arguments{
+ \item{tree}{a phylogeny as an object of class \code{"phylo"}.}
+ \item{node}{for \code{nodeheight}, the node for which we want to compute a height above the root (or including the root edge, for \code{root.edge=TRUE}).}
+ \item{...}{optional arguments - presently only \code{root.edge}, a logical value indicating whether or not to include the root edge length in the calculation of node heights.}
+}
+\description{
+ \code{nodeHeights} computes the height above the root for all nodes in the tree. \code{nodeheight} computes the height above the root for a single node.
+}
+\details{
+ The function \code{nodeHeights} also gives a handy way to get the total length of the tree from the root to the heighest tip which will be given by \code{max(nodeHeights(tree))}.
+
+ Generally speaking, \code{nodeHeights} will be faster if the heights of all or a large proportion of nodes is needed, wherease \code{nodeheight} will be faster if the height of one or a small number of nodes are needed.
+}
+\value{
+ Either a matrix of the same dimensions as \code{tree$edge} containing the height above the root of each node in \code{edge} (for \code{nodeHeights}); or a single positive number (for \code{nodeheight}).
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{vcvPhylo}}
+}
+\examples{
+## load tree
+data(vertebrate.tree)
+## compute height of all nodes
+H<-nodeHeights(vertebrate.tree)
+print(H)
+## compute total tree depth
+max(H)
+}
+\keyword{phylogenetics}
+\keyword{utilities}
+\keyword{comparative method}
diff --git a/man/nodelabels.cophylo.Rd b/man/nodelabels.cophylo.Rd
index 874afa5..59dda82 100644
--- a/man/nodelabels.cophylo.Rd
+++ b/man/nodelabels.cophylo.Rd
@@ -1,31 +1,31 @@
-\name{nodelabels.cophylo}
-\alias{nodelabels.cophylo}
-\alias{tiplabels.cophylo}
-\alias{edgelabels.cophylo}
-\title{Add labels to a plotted "cophylo" object}
-\usage{
-nodelabels.cophylo(..., which=c("left","right"))
-edgelabels.cophylo(..., which=c("left","right"))
-tiplabels.cophylo(..., which=c("left","right"))
-}
-\arguments{
- \item{...}{arguments to be passed to \code{\link{nodelabels}}, \code{\link{edgelabels}}, or \code{\link{tiplabels}}.}
- \item{which}{argument indicated which of the two plotted trees (the \code{"left"} or \code{"right"} tree) to be used.}
-}
-\description{
- This function adds node, edge, or tip labels to the plotted trees of a \code{"cophylo"} object.
-}
-\details{
- Note that the order of tips, edges, and nodes may be different in the object of class \code{"cophylo"} than they are in the original input trees, particularly if \code{cophylo(...,rotate=TRUE)} was used.
-}
-\references{
- Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{cophylo}}, \code{\link{edgelabels}}, \code{\link{nodelabels}}, \code{\link{tiplabels}}
-}
-\keyword{phylogenetics}
-\keyword{utilities}
+\name{nodelabels.cophylo}
+\alias{nodelabels.cophylo}
+\alias{tiplabels.cophylo}
+\alias{edgelabels.cophylo}
+\title{Add labels to a plotted "cophylo" object}
+\usage{
+nodelabels.cophylo(..., which=c("left","right"))
+edgelabels.cophylo(..., which=c("left","right"))
+tiplabels.cophylo(..., which=c("left","right"))
+}
+\arguments{
+ \item{...}{arguments to be passed to \code{\link{nodelabels}}, \code{\link{edgelabels}}, or \code{\link{tiplabels}}.}
+ \item{which}{argument indicated which of the two plotted trees (the \code{"left"} or \code{"right"} tree) to be used.}
+}
+\description{
+ This function adds node, edge, or tip labels to the plotted trees of a \code{"cophylo"} object.
+}
+\details{
+ Note that the order of tips, edges, and nodes may be different in the object of class \code{"cophylo"} than they are in the original input trees, particularly if \code{cophylo(...,rotate=TRUE)} was used.
+}
+\references{
+ Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{cophylo}}, \code{\link{edgelabels}}, \code{\link{nodelabels}}, \code{\link{tiplabels}}
+}
+\keyword{phylogenetics}
+\keyword{utilities}
diff --git a/man/optim.phylo.ls.Rd b/man/optim.phylo.ls.Rd
index f84fac6..4377845 100644
--- a/man/optim.phylo.ls.Rd
+++ b/man/optim.phylo.ls.Rd
@@ -1,45 +1,45 @@
-\name{optim.phylo.ls}
-\alias{optim.phylo.ls}
-\title{Phylogeny inference using the least squares method}
-\usage{
-optim.phylo.ls(D, stree=NULL, set.neg.to.zero=TRUE, fixed=FALSE,
- tol=1e-10, collapse=TRUE)
-}
-\arguments{
- \item{D}{a distance matrix.}
- \item{stree}{an optional starting tree for the optimization.}
- \item{set.neg.to.zero}{a logical value indicating whether to set negative branch lengths to zero (default \code{TRUE}).}
- \item{fixed}{a logical value indicating whether to estimate the topology - if \code{TRUE} only the branch lengths will be computed.}
- \item{tol}{a tolerance value used to assess whether the optimization has converged.}
- \item{collapse}{ a logical indicating whether to collapse branches with zero length.}
-}
-\description{
- Phylogenetic inference using the method of least-squares (Cavalli-Sforza & Edwards, 1967).
-}
-\details{
- Function uses \code{\link{nni}} from the \pkg{phangorn} package (Schliep 2011) to conduct NNIs for topology estimation.
-
- Since topology optimization is performed using NNIs, convergence to the true least-squares topology is not guaranteed. It is consequently probably wise to start with a very good tree - such as a NJ tree.
-}
-\value{
- An object of class \code{"phylo"} that (may be) the least-squares tree with branch lengths; also returns the sum of squares in \code{attr(tree,"Q-score")}.
-}
-\references{
- Cavalli-Sforza, L. L., and A. W. F. Edwards. (1967) Phylogenetic analysis: Models and estimation procedures. \emph{American Journal of Human Genetics}, \bold{19}, 233-257.
-
- Felsenstein, J. (2004) \emph{Inferring Phylogenies}. Sinauer.
-
- Paradis, E., J. Claude, and K. Strimmer. (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-
- Schliep, K. P. (2011) phangorn: phylogenetic analysis in R. \emph{Bioinformatics}, \bold{27}, 592-593.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{exhaustiveMP}}, \code{\link{nni}}
-}
-\keyword{phylogenetics}
-\keyword{phylogeny inference}
-\keyword{distance matrix}
-\keyword{least squares}
+\name{optim.phylo.ls}
+\alias{optim.phylo.ls}
+\title{Phylogeny inference using the least squares method}
+\usage{
+optim.phylo.ls(D, stree=NULL, set.neg.to.zero=TRUE, fixed=FALSE,
+ tol=1e-10, collapse=TRUE)
+}
+\arguments{
+ \item{D}{a distance matrix.}
+ \item{stree}{an optional starting tree for the optimization.}
+ \item{set.neg.to.zero}{a logical value indicating whether to set negative branch lengths to zero (default \code{TRUE}).}
+ \item{fixed}{a logical value indicating whether to estimate the topology - if \code{TRUE} only the branch lengths will be computed.}
+ \item{tol}{a tolerance value used to assess whether the optimization has converged.}
+ \item{collapse}{ a logical indicating whether to collapse branches with zero length.}
+}
+\description{
+ Phylogenetic inference using the method of least-squares (Cavalli-Sforza & Edwards, 1967).
+}
+\details{
+ Function uses \code{\link{nni}} from the \pkg{phangorn} package (Schliep 2011) to conduct NNIs for topology estimation.
+
+ Since topology optimization is performed using NNIs, convergence to the true least-squares topology is not guaranteed. It is consequently probably wise to start with a very good tree - such as a NJ tree.
+}
+\value{
+ An object of class \code{"phylo"} that (may be) the least-squares tree with branch lengths; also returns the sum of squares in \code{attr(tree,"Q-score")}.
+}
+\references{
+ Cavalli-Sforza, L. L., and A. W. F. Edwards. (1967) Phylogenetic analysis: Models and estimation procedures. \emph{American Journal of Human Genetics}, \bold{19}, 233-257.
+
+ Felsenstein, J. (2004) \emph{Inferring Phylogenies}. Sinauer.
+
+ Paradis, E., J. Claude, and K. Strimmer. (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+
+ Schliep, K. P. (2011) phangorn: phylogenetic analysis in R. \emph{Bioinformatics}, \bold{27}, 592-593.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{exhaustiveMP}}, \code{\link{nni}}
+}
+\keyword{phylogenetics}
+\keyword{phylogeny inference}
+\keyword{distance matrix}
+\keyword{least squares}
diff --git a/man/orderMappedEdge.Rd b/man/orderMappedEdge.Rd
index 8d963da..4bc6ad9 100644
--- a/man/orderMappedEdge.Rd
+++ b/man/orderMappedEdge.Rd
@@ -1,27 +1,27 @@
-\name{orderMappedEdge}
-\alias{orderMappedEdge}
-\title{Order the columns of mapped.edge to match across trees}
-\usage{
-orderMappedEdge(trees, ordering=NULL)
-}
-\arguments{
- \item{trees}{object of class \code{"phylo"} or \code{"multiPhylo"}.}
- \item{ordering}{ordering for the columns of \code{$mapped.edge}. If \code{NULL}, then an alphabetical order is assumed. Options are \code{"alphabetical"}, \code{"numerical"}, or any specific ordering of the mapped traits (e.g., \code{c("A","B","C")}.}
-}
-\description{
- Orders the levels of a mapped character to match across trees in a \code{"multiSimmap"} object.
-}
-\details{
- This function takes a an object of class \code{"multiSimmap"} with a mapped discrete character (e.g., see \code{\link{make.simmap}} and sorts the columns of each \code{tree$mapped.edge} element to have the same state ordering.
-
- This is handy if we want to, for instance, run \code{brownie.lite} on a set of mapped trees, and then average the fitted parameter values across trees. The function also works for a single tree.
-}
-\value{
- An object of class \code{"simmap"} or (normally) \code{"multiSimmap"}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{phylogenetics}
-\keyword{utilities}
+\name{orderMappedEdge}
+\alias{orderMappedEdge}
+\title{Order the columns of mapped.edge to match across trees}
+\usage{
+orderMappedEdge(trees, ordering=NULL)
+}
+\arguments{
+ \item{trees}{object of class \code{"phylo"} or \code{"multiPhylo"}.}
+ \item{ordering}{ordering for the columns of \code{$mapped.edge}. If \code{NULL}, then an alphabetical order is assumed. Options are \code{"alphabetical"}, \code{"numerical"}, or any specific ordering of the mapped traits (e.g., \code{c("A","B","C")}.}
+}
+\description{
+ Orders the levels of a mapped character to match across trees in a \code{"multiSimmap"} object.
+}
+\details{
+ This function takes a an object of class \code{"multiSimmap"} with a mapped discrete character (e.g., see \code{\link{make.simmap}} and sorts the columns of each \code{tree$mapped.edge} element to have the same state ordering.
+
+ This is handy if we want to, for instance, run \code{brownie.lite} on a set of mapped trees, and then average the fitted parameter values across trees. The function also works for a single tree.
+}
+\value{
+ An object of class \code{"simmap"} or (normally) \code{"multiSimmap"}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{phylogenetics}
+\keyword{utilities}
diff --git a/man/paintSubTree.Rd b/man/paintSubTree.Rd
index ed6b70c..79416ea 100644
--- a/man/paintSubTree.Rd
+++ b/man/paintSubTree.Rd
@@ -1,37 +1,37 @@
-\name{paintSubTree}
-\alias{paintSubTree}
-\alias{paintBranches}
-\title{Paint sub-trees with a discrete character}
-\usage{
-paintSubTree(tree, node, state, anc.state="1", stem=FALSE)
-paintBranches(tree, edge, state, anc.state="1")
-}
-\arguments{
- \item{tree}{a phylogenetic tree as an object of class \code{"phylo"} or a modified object with mapped character traits.}
- \item{node}{an integer specifying the node number tipward of which the function should paint the derived state.}
- \item{edge}{an integer or vector of integers specifying the node or tip numbers of the edges that should be painted in \code{paintBranches}.}
- \item{state}{a string (or numeric value) specifying the state to paint on the tree tipward of \code{node}.}
- \item{anc.state}{the ancestral state to use; will only be applied if there are presently no character values mapped on the tree.}
- \item{stem}{logical or numeric value indicating whether to use the derived state on the stem leading to \code{node} (or not, if \code{stem=FALSE}), or, alternatively, what fraction of the stem should be assigned to the derived clade. Note that for tip clades \code{stem=FALSE} is not allowed.}
-}
-\description{
- Paints regimes on a tree to create an object of class \code{"simmap"} with mapped regimes.
-}
-\details{
- These functions map or "paint" arbitrary (i.e., user-specified) discrete character histories on the tree.
-
- \code{paintSubTree} paints the clade downstream of \code{node} with a particular state; whereas \code{paintBranches} paints only a specified branch.
-}
-\value{
- An object of class \code{"simmap"} that contains the specified paintings as a mapped discrete character.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{plotSimmap}}, \code{\link{sim.history}}
-}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{utilities}
+\name{paintSubTree}
+\alias{paintSubTree}
+\alias{paintBranches}
+\title{Paint sub-trees with a discrete character}
+\usage{
+paintSubTree(tree, node, state, anc.state="1", stem=FALSE)
+paintBranches(tree, edge, state, anc.state="1")
+}
+\arguments{
+ \item{tree}{a phylogenetic tree as an object of class \code{"phylo"} or a modified object with mapped character traits.}
+ \item{node}{an integer specifying the node number tipward of which the function should paint the derived state.}
+ \item{edge}{an integer or vector of integers specifying the node or tip numbers of the edges that should be painted in \code{paintBranches}.}
+ \item{state}{a string (or numeric value) specifying the state to paint on the tree tipward of \code{node}.}
+ \item{anc.state}{the ancestral state to use; will only be applied if there are presently no character values mapped on the tree.}
+ \item{stem}{logical or numeric value indicating whether to use the derived state on the stem leading to \code{node} (or not, if \code{stem=FALSE}), or, alternatively, what fraction of the stem should be assigned to the derived clade. Note that for tip clades \code{stem=FALSE} is not allowed.}
+}
+\description{
+ Paints regimes on a tree to create an object of class \code{"simmap"} with mapped regimes.
+}
+\details{
+ These functions map or "paint" arbitrary (i.e., user-specified) discrete character histories on the tree.
+
+ \code{paintSubTree} paints the clade downstream of \code{node} with a particular state; whereas \code{paintBranches} paints only a specified branch.
+}
+\value{
+ An object of class \code{"simmap"} that contains the specified paintings as a mapped discrete character.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{plotSimmap}}, \code{\link{sim.history}}
+}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{utilities}
diff --git a/man/paste.tree.Rd b/man/paste.tree.Rd
index b20e3fb..17c2e11 100644
--- a/man/paste.tree.Rd
+++ b/man/paste.tree.Rd
@@ -1,34 +1,34 @@
-\name{paste.tree}
-\alias{paste.tree}
-\title{Paste two trees together}
-\usage{
-paste.tree(tr1, tr2)
-}
-\arguments{
- \item{tr1}{receptor tree.}
- \item{tr2}{donor clade.}
-}
-\description{
- Internal function for \code{\link{posterior.evolrate}}.
-}
-\details{
- Primarily designed as an internal function for \code{\link{posterior.evolrate}}; however, can be used to graft a clade onto a receptor tree at the "sticky tip" labeled with \code{"NA"}.
-
- The donor clade needs to have a root edge, even if it is zero length.
-}
-\value{
- A tree.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\examples{
-tr1<-rtree(10)
-tr2<-rtree(10)
-tr1$tip.label[1]<-"NA"
-tr2$root.edge<-0
-tr3<-paste.tree(tr1,tr2)
-}
-\keyword{phylogenetics}
-\keyword{utilities}
+\name{paste.tree}
+\alias{paste.tree}
+\title{Paste two trees together}
+\usage{
+paste.tree(tr1, tr2)
+}
+\arguments{
+ \item{tr1}{receptor tree.}
+ \item{tr2}{donor clade.}
+}
+\description{
+ Internal function for \code{\link{posterior.evolrate}}.
+}
+\details{
+ Primarily designed as an internal function for \code{\link{posterior.evolrate}}; however, can be used to graft a clade onto a receptor tree at the "sticky tip" labeled with \code{"NA"}.
+
+ The donor clade needs to have a root edge, even if it is zero length.
+}
+\value{
+ A tree.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\examples{
+tr1<-rtree(10)
+tr2<-rtree(10)
+tr1$tip.label[1]<-"NA"
+tr2$root.edge<-0
+tr3<-paste.tree(tr1,tr2)
+}
+\keyword{phylogenetics}
+\keyword{utilities}
diff --git a/man/pbtree.Rd b/man/pbtree.Rd
index 814afcc..dcdcd32 100644
--- a/man/pbtree.Rd
+++ b/man/pbtree.Rd
@@ -1,51 +1,51 @@
-\name{pbtree}
-\alias{pbtree}
-\title{Simulate pure-birth or birth-death stochastic tree or trees}
-\usage{
-pbtree(b=1, d=0, n=NULL, t=NULL, scale=NULL, nsim=1, type=c("continuous",
- "discrete"), ...)
-}
-\arguments{
- \item{b}{birth rate or speciation rate for \code{type="continuous"}; the probability of speciating per time-step for \code{type="discrete"}.}
- \item{d}{death rate or extinction rate for \code{type="continuous"}; the probability of going extinct per time-step for \code{type="discrete"}.}
- \item{n}{desired number of species (i.e., taxa-stop criterion).}
- \item{t}{total time for simulation (i.e., time-stop criterion).}
- \item{scale}{if set, rescales tree to have total length \code{scale}.}
- \item{nsim}{number of simulated trees to return.}
- \item{type}{string to indicate whether to simulate trees in continuous or discrete time. If the former, then wait times between speciation events are drawn from an exponential distribution; whereas if the latter then wait times comes from a geometric distribution.}
- \item{...}{optional arguments including \code{ape}, a logical value indicating whether to return nodes in a 'ape' compatible ordering (default is \code{TRUE}); \code{extant.only} a logical value indicating whether or not to return only extant species (defaults to \code{FALSE}); \code{max.count} a numeric value indicating the maximum number of iterations to run is sampling conditioned on both \code{n} and \code{t} (defaults to \code{1e5}); \code{method} gives the method used for simultaneously conditioning on \code{n} and \code{t} - options are \code{"rejection"} and \code{"direct"}; \code{tip.label}, a vector of tip labels (only works for \code{n!=NULL}); and, finally, \code{quiet}, a logical value indicating whether or not to suppress certain message (defaults to \code{FALSE}).}
-}
-\details{
- Simulate stochastic birth-death trees.
-}
-\description{
- This function simulates stochastic birth-death trees.
-
- Simulation can be performed conditioning on \code{n}, on \code{t}, or on both simultaneously. If both, then (for optional argument \code{method="rejection"}) rejection sampling is performed whereby trees are simulated given \code{b} and \code{t} until a tree containing \code{n} taxa is found. The giving-up point can be set using the optional argument \code{max.count}.
-
- Simulations can also be performed in continuous time (the default) or discrete time; the difference being that wait times in the continous-time simulation come from the exponential distribution; whereas waiting times in discrete-time simulations come from the geometric distribution. In addition, discrete-time simulations allow for the possibility that multiple speciation events can occur at (exactly) the same time, so long as they are on separate branches. Finally, sometimes for stopping criterion \code{n} in discrete-time there will be a number of tips different from \code{n}. This indicates that the last event contained more than one speciation event, and a warning is printed.
-
- \code{method="direct"} is presently experimental. It does not really perform direct sampling; however waiting times & birth or death events are sampled first - with only wait-times consistent with \code{n} and \code{t} being retained. This rejection sampling occurs one layer earlier than for \code{method="rejection"}. This results in a significant (several-fold) speed-up of the code and enables sampling conditioned on \code{n} and \code{t} simultaneously for much higher \code{b} and \code{d}. At the present time, \code{extant.only=TRUE} does not work for this mode, nor does \code{type="discrete"}.
-
- Note that if \code{ape=FALSE}, then the function will run faster, and the tree is theoretically compatible with the ape \code{"phylo"} standard; however some downstream errors with functions such as \code{\link{bind.tree}} have been observed.
-
- Lastly, under the taxon number stopping criterion (\code{n}) for a non-zero extinction rate (\code{d>0}) sometimes a tree containing fewer than \code{n} extant tips is returned because it has gone completely extinct before the end of the simulation.
-}
-\value{
- A tree or set of trees as an object of class \code{"phylo"} or \code{"multiPhylo"}, respectively.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\examples{
-## simulate a pure-birth tree with 400 tips
-## scaled to a length of 1.0
-tree<-pbtree(n=400,scale=1)
-## simulate a pure-birth tree conditioning on n & t
-tt<-log(50)-log(2)
-tree<-pbtree(n=50,t=tt)
-}
-\keyword{phylogenetics}
-\keyword{simulation}
-\keyword{diversification}
+\name{pbtree}
+\alias{pbtree}
+\title{Simulate pure-birth or birth-death stochastic tree or trees}
+\usage{
+pbtree(b=1, d=0, n=NULL, t=NULL, scale=NULL, nsim=1, type=c("continuous",
+ "discrete"), ...)
+}
+\arguments{
+ \item{b}{birth rate or speciation rate for \code{type="continuous"}; the probability of speciating per time-step for \code{type="discrete"}.}
+ \item{d}{death rate or extinction rate for \code{type="continuous"}; the probability of going extinct per time-step for \code{type="discrete"}.}
+ \item{n}{desired number of species (i.e., taxa-stop criterion).}
+ \item{t}{total time for simulation (i.e., time-stop criterion).}
+ \item{scale}{if set, rescales tree to have total length \code{scale}.}
+ \item{nsim}{number of simulated trees to return.}
+ \item{type}{string to indicate whether to simulate trees in continuous or discrete time. If the former, then wait times between speciation events are drawn from an exponential distribution; whereas if the latter then wait times comes from a geometric distribution.}
+ \item{...}{optional arguments including \code{ape}, a logical value indicating whether to return nodes in a 'ape' compatible ordering (default is \code{TRUE}); \code{extant.only} a logical value indicating whether or not to return only extant species (defaults to \code{FALSE}); \code{max.count} a numeric value indicating the maximum number of iterations to run is sampling conditioned on both \code{n} and \code{t} (defaults to \code{1e5}); \code{method} gives the method used for simultaneously conditioning on \code{n} and \code{t} - options are \code{"rejection"} and \code{"direct"}; \code{tip.label}, a vector of tip labels (only works for \code{n!=NULL}); and, finally, \code{quiet}, a logical value indicating whether or not to suppress certain message (defaults to \code{FALSE}).}
+}
+\details{
+ Simulate stochastic birth-death trees.
+}
+\description{
+ This function simulates stochastic birth-death trees.
+
+ Simulation can be performed conditioning on \code{n}, on \code{t}, or on both simultaneously. If both, then (for optional argument \code{method="rejection"}) rejection sampling is performed whereby trees are simulated given \code{b} and \code{t} until a tree containing \code{n} taxa is found. The giving-up point can be set using the optional argument \code{max.count}.
+
+ Simulations can also be performed in continuous time (the default) or discrete time; the difference being that wait times in the continous-time simulation come from the exponential distribution; whereas waiting times in discrete-time simulations come from the geometric distribution. In addition, discrete-time simulations allow for the possibility that multiple speciation events can occur at (exactly) the same time, so long as they are on separate branches. Finally, sometimes for stopping criterion \code{n} in discrete-time there will be a number of tips different from \code{n}. This indicates that the last event contained more than one speciation event, and a warning is printed.
+
+ \code{method="direct"} is presently experimental. It does not really perform direct sampling; however waiting times & birth or death events are sampled first - with only wait-times consistent with \code{n} and \code{t} being retained. This rejection sampling occurs one layer earlier than for \code{method="rejection"}. This results in a significant (several-fold) speed-up of the code and enables sampling conditioned on \code{n} and \code{t} simultaneously for much higher \code{b} and \code{d}. At the present time, \code{extant.only=TRUE} does not work for this mode, nor does \code{type="discrete"}.
+
+ Note that if \code{ape=FALSE}, then the function will run faster, and the tree is theoretically compatible with the ape \code{"phylo"} standard; however some downstream errors with functions such as \code{\link{bind.tree}} have been observed.
+
+ Lastly, under the taxon number stopping criterion (\code{n}) for a non-zero extinction rate (\code{d>0}) sometimes a tree containing fewer than \code{n} extant tips is returned because it has gone completely extinct before the end of the simulation.
+}
+\value{
+ A tree or set of trees as an object of class \code{"phylo"} or \code{"multiPhylo"}, respectively.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\examples{
+## simulate a pure-birth tree with 400 tips
+## scaled to a length of 1.0
+tree<-pbtree(n=400,scale=1)
+## simulate a pure-birth tree conditioning on n & t
+tt<-log(50)-log(2)
+tree<-pbtree(n=50,t=tt)
+}
+\keyword{phylogenetics}
+\keyword{simulation}
+\keyword{diversification}
diff --git a/man/pgls.Ives.Rd b/man/pgls.Ives.Rd
index b69ad07..5f0a786 100644
--- a/man/pgls.Ives.Rd
+++ b/man/pgls.Ives.Rd
@@ -1,65 +1,65 @@
-\name{pgls.Ives}
-\alias{pgls.Ives}
-\alias{pgls.SEy}
-\title{Phylogenetic regression with intraspecific sampling error}
-\usage{
-pgls.Ives(tree, X, y, Vx=NULL, Vy=NULL, Cxy=NULL, lower=c(1e-8,1e-8),
- fixed.b1=NULL)
-pgls.SEy(model, data, corClass=corBrownian, tree,
- se=NULL, method=c("REML","ML"), interval=c(0,1000), ...)
-}
-\arguments{
- \item{tree}{a phylogeny as an object of class \code{"phylo"}.}
- \item{X}{a named vector containing a \emph{single} independent variable (multiple independent variables to be added in future). \code{X} can contain the species means, or a single long vector containing the sample of values for each species. In the latter case the \code{names(X)} will be repeating - all samples from the same species should have the same name.}
- \item{y}{vector the dependent variable. Can be species means or individual values, as for \code{X}.}
- \item{Vx}{sampling variances for \code{X}. If \code{NULL}, then the within-species variance is computed from the data assuming that individual samples, not species means, have been provided in \code{X}.}
- \item{Vy}{sampling variances for \code{y}. If \code{NULL}, then the within-species variance is computed from the data assuming that individual samples, not species means, have been provided in \code{y}.}
- \item{Cxy}{sampling covariances between \code{X} and \code{y}. This will also be computed from the data if \code{Cxy==NULL}. Note than in this case - but not for the calculation of \code{Vx} and \code{Vy}, the same number of observations and the same ordering must be provided for \code{X} and \code{y}. If this is not the case, then it is assumed that different individuals have been sampled for \code{X} and \code{y} and thus \code{Cxy} is assumed to be zero for all species.}
- \item{lower}{vector specifying the lower bounds for estimation for \eqn{\sigma_x^2} and \eqn{\sigma_y^2}, respectively. (Must be > 0.)}
- \item{fixed.b1}{fixed regression slope, \eqn{\beta}. Usually set to zero for null hypothesis testing.}
- \item{model}{model to fit. (For \code{pgls.SEy}.)}
- \item{data}{data frame. (For \code{pgls.SEy}.)}
- \item{corClass}{correlation structure. (For \code{pgls.SEy}.)}
- \item{se}{vector of standard errors in \emph{y}. (For \code{pgls.SEy}.)}
- \item{method}{optimization method. (For \code{pgls.SEy}.)}
- \item{interval}{interval over which to perform optimization. (For \code{pgls.SEy}.)}
- \item{...}{optional arguments. (For \code{pgls.SEy}.)}
-}
-\description{
- Phylogenetic regression with within-species sampling error following Ives et al. (2007).
-}
-\details{
- \code{pgls.Ives} fits the phylogenetic regression model with within-species sampling error following Ives et al. (2007).
-
- \code{pgls.SEy} fits a simpler model in which only sampling error in \code{y} is taken into account. This function uses \code{\link{gls}} from the nlme package internally for optimization and returns an object of class \code{"gls"} that is compatible with all methods for that object class.
-
- In the case of \code{pgls.Ives}, only the bivariate regression model is implemented. Note that some problems have been reported with the optimization algorithm for this model, which is simple and thus may fail to find the ML solution.
-
- In the case of \code{pgls.SEy} the user can (theoretically) specify any class of linear model permitted by \code{\link{gls}}.
-}
-\value{
- In the case of \code{pgls.Ives}, an object of class \code{"pgls.Ives"} with the following elements:
- \item{beta}{a vector or matrix of regression coefficients.}
- \item{sig2x}{fitted BM rate for \code{X}.}
- \item{sig2y}{fitted BM rate for \code{y}.}
- \item{a}{fitted ancestral states for \code{X} and \code{y}.}
- \item{logL}{log-likelihood.}
- \item{convergence}{a value for convergence. \code{convergence=0} is good; see \code{\link{optim}} for more details.}
- \item{message}{a message for convergence.}
-
- In the case of \code{pgls.SEy}, an object of class \code{"gls"}.
-}
-\references{
- Ives, A. R., P. E. Midford, and T. Garland Jr. (2007) Within-species measurement error in phylogenetic comparative methods. \emph{Systematic Biology}, \bold{56}, 252-270.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{brownie.lite}}, \code{\link{phylosig}}, \code{\link{phyl.resid}}
-}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{statistics}
-\keyword{least squares}
-\keyword{maximum likelihood}
+\name{pgls.Ives}
+\alias{pgls.Ives}
+\alias{pgls.SEy}
+\title{Phylogenetic regression with intraspecific sampling error}
+\usage{
+pgls.Ives(tree, X, y, Vx=NULL, Vy=NULL, Cxy=NULL, lower=c(1e-8,1e-8),
+ fixed.b1=NULL)
+pgls.SEy(model, data, corClass=corBrownian, tree,
+ se=NULL, method=c("REML","ML"), interval=c(0,1000), ...)
+}
+\arguments{
+ \item{tree}{a phylogeny as an object of class \code{"phylo"}.}
+ \item{X}{a named vector containing a \emph{single} independent variable (multiple independent variables to be added in future). \code{X} can contain the species means, or a single long vector containing the sample of values for each species. In the latter case the \code{names(X)} will be repeating - all samples from the same species should have the same name.}
+ \item{y}{vector the dependent variable. Can be species means or individual values, as for \code{X}.}
+ \item{Vx}{sampling variances for \code{X}. If \code{NULL}, then the within-species variance is computed from the data assuming that individual samples, not species means, have been provided in \code{X}.}
+ \item{Vy}{sampling variances for \code{y}. If \code{NULL}, then the within-species variance is computed from the data assuming that individual samples, not species means, have been provided in \code{y}.}
+ \item{Cxy}{sampling covariances between \code{X} and \code{y}. This will also be computed from the data if \code{Cxy==NULL}. Note than in this case - but not for the calculation of \code{Vx} and \code{Vy}, the same number of observations and the same ordering must be provided for \code{X} and \code{y}. If this is not the case, then it is assumed that different individuals have been sampled for \code{X} and \code{y} and thus \code{Cxy} is assumed to be zero for all species.}
+ \item{lower}{vector specifying the lower bounds for estimation for \eqn{\sigma_x^2} and \eqn{\sigma_y^2}, respectively. (Must be > 0.)}
+ \item{fixed.b1}{fixed regression slope, \eqn{\beta}. Usually set to zero for null hypothesis testing.}
+ \item{model}{model to fit. (For \code{pgls.SEy}.)}
+ \item{data}{data frame. (For \code{pgls.SEy}.)}
+ \item{corClass}{correlation structure. (For \code{pgls.SEy}.)}
+ \item{se}{vector of standard errors in \emph{y}. (For \code{pgls.SEy}.)}
+ \item{method}{optimization method. (For \code{pgls.SEy}.)}
+ \item{interval}{interval over which to perform optimization. (For \code{pgls.SEy}.)}
+ \item{...}{optional arguments. (For \code{pgls.SEy}.)}
+}
+\description{
+ Phylogenetic regression with within-species sampling error following Ives et al. (2007).
+}
+\details{
+ \code{pgls.Ives} fits the phylogenetic regression model with within-species sampling error following Ives et al. (2007).
+
+ \code{pgls.SEy} fits a simpler model in which only sampling error in \code{y} is taken into account. This function uses \code{\link{gls}} from the nlme package internally for optimization and returns an object of class \code{"gls"} that is compatible with all methods for that object class.
+
+ In the case of \code{pgls.Ives}, only the bivariate regression model is implemented. Note that some problems have been reported with the optimization algorithm for this model, which is simple and thus may fail to find the ML solution.
+
+ In the case of \code{pgls.SEy} the user can (theoretically) specify any class of linear model permitted by \code{\link{gls}}.
+}
+\value{
+ In the case of \code{pgls.Ives}, an object of class \code{"pgls.Ives"} with the following elements:
+ \item{beta}{a vector or matrix of regression coefficients.}
+ \item{sig2x}{fitted BM rate for \code{X}.}
+ \item{sig2y}{fitted BM rate for \code{y}.}
+ \item{a}{fitted ancestral states for \code{X} and \code{y}.}
+ \item{logL}{log-likelihood.}
+ \item{convergence}{a value for convergence. \code{convergence=0} is good; see \code{\link{optim}} for more details.}
+ \item{message}{a message for convergence.}
+
+ In the case of \code{pgls.SEy}, an object of class \code{"gls"}.
+}
+\references{
+ Ives, A. R., P. E. Midford, and T. Garland Jr. (2007) Within-species measurement error in phylogenetic comparative methods. \emph{Systematic Biology}, \bold{56}, 252-270.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{brownie.lite}}, \code{\link{phylosig}}, \code{\link{phyl.resid}}
+}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{statistics}
+\keyword{least squares}
+\keyword{maximum likelihood}
diff --git a/man/phenogram.Rd b/man/phenogram.Rd
index 465b214..9fceb3b 100644
--- a/man/phenogram.Rd
+++ b/man/phenogram.Rd
@@ -1,51 +1,51 @@
-\name{phenogram}
-\alias{phenogram}
-\title{Plot phenogram (traitgram)}
-\usage{
-phenogram(tree, x, fsize=1.0, ftype="reg", colors=NULL, axes=list(),
- add=FALSE, ...)
-}
-\arguments{
- \item{tree}{an object of class \code{"phylo"}, with or without a mapped discrete character.}
- \item{x}{a vector containing the states at the tips \emph{or} the states at all the tips and the internal nodes of the tree.}
- \item{fsize}{relative font size for tip labels.}
- \item{ftype}{font type - options are \code{"reg"}, \code{"i"} (italics), \code{"b"} (bold), or \code{"bi"} (bold-italics).}
- \item{colors}{colors for plotting the mapped character (if available) in \code{tree}. If no character is mapped on the tree, then a single color for all the branches of the tree can be provided.}
- \item{axes}{list of axis dimensions. Items are \code{time} and \code{trait}.}
- \item{add}{optional logical value indicating whether to add to an open plot. If \code{TRUE}, then new axes will not be plotted.}
- \item{...}{optional arguments including \code{xlim}, \code{ylim}, \code{log}, \code{main}, \code{sub}, \code{xlab}, \code{ylab}, \code{asp}, \code{type}, \code{lty}, \code{lwd}, \code{offset}, and \code{digits} are as in \code{\link{plot.default}} or \code{\link{par}}. Note that \code{axes} overrides \code{xlim} and \code{ylim}. \code{spread.labels} is a logical value indicating whether or not to minimize tip label overlap (default is \code{TRUE}); \code{spread.cost} is a numeric vector indicating the relative penalty to be used for label overlap and deviance, respectively (if \code{spread.labels=TRUE}); \code{spread.range} is the range over which to (potentially) spread the labels - note that if labels do not overlap, not all of that range will be used; finally, \code{link} is a numeric value by which to offset the tip labels, linking them to the tips with a dashed line (default is \code{0}, if \code{spread.labels=FALSE}, or 10\% of the total tree length otherwise). The optional argument \code{offsetFudge} "fudges" the computation of label offset in scaling \code{xlim}. It is 1.37, which is the correct fudge in the Windows R GUI, but this may need to be changed in other systems. \code{hold} indicates whether (or not) the output to the graphical device should be held using \code{\link{dev.hold}} before plotting (defaults to \code{hold=TRUE}). \code{quiet} suppresses some system messages if set to \code{quiet=TRUE}.}
-}
-\description{
- Plots a phylogenetic traitgram (Evans et al., 2009).
-}
-\details{
- Function plots a traitgram (Evans et al. 2009), that is, a projection of the phylogenetic tree in a space defined by phenotype (on the \emph{y} axis) and time (on the \emph{x}). If a discrete character is mapped on the tree this will also be plotted.
-
- For \code{spread.labels=TRUE} numerical optimization is performed to optimize the distribution of the labels vertically, where the solution depends on the vector \code{spread.cost} containing the cost of overlap (first) and the cost of deviation from the vertical position of the tip. Note that because this is done via numerical optimization, plotting may hang briefly while the best solution is found (especially for large trees).
-}
-\value{
- Plots a traitgram, optionally with a mapped discrete character, and (invisibly) returns a matrix containing the coordinates of the plotted tip labels.
-}
-\references{
- Evans, M. E. K., Smith, S. A., Flynn, R. S., Donoghue, M. J. (2009) Climate, niche evolution, and diversification of the "bird-cage" evening primroses (Oenothera, sections Anogra and Kleinia). \emph{American Naturalist}, \bold{173}, 225-240.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\examples{
-## load data from Garland et al. (1992)
-data(mammal.tree)
-data(mammal.data)
-## extract character of interest
-ln.bodyMass<-log(setNames(mammal.data$bodyMass,
- rownames(mammal.data)))
-## plot traitgram
-phenogram(mammal.tree,ln.bodyMass,ftype="i",
- spread.cost=c(1,0),fsize=0.7,xlab="time (ma)",
- ylab="log(body mass)")
-}
-\keyword{ancestral states}
-\keyword{phylogenetics}
-\keyword{plotting}
-\keyword{comparative method}
-\keyword{continuous character}
+\name{phenogram}
+\alias{phenogram}
+\title{Plot phenogram (traitgram)}
+\usage{
+phenogram(tree, x, fsize=1.0, ftype="reg", colors=NULL, axes=list(),
+ add=FALSE, ...)
+}
+\arguments{
+ \item{tree}{an object of class \code{"phylo"}, with or without a mapped discrete character.}
+ \item{x}{a vector containing the states at the tips \emph{or} the states at all the tips and the internal nodes of the tree.}
+ \item{fsize}{relative font size for tip labels.}
+ \item{ftype}{font type - options are \code{"reg"}, \code{"i"} (italics), \code{"b"} (bold), or \code{"bi"} (bold-italics).}
+ \item{colors}{colors for plotting the mapped character (if available) in \code{tree}. If no character is mapped on the tree, then a single color for all the branches of the tree can be provided.}
+ \item{axes}{list of axis dimensions. Items are \code{time} and \code{trait}.}
+ \item{add}{optional logical value indicating whether to add to an open plot. If \code{TRUE}, then new axes will not be plotted.}
+ \item{...}{optional arguments including \code{xlim}, \code{ylim}, \code{log}, \code{main}, \code{sub}, \code{xlab}, \code{ylab}, \code{asp}, \code{type}, \code{lty}, \code{lwd}, \code{offset}, and \code{digits} are as in \code{\link{plot.default}} or \code{\link{par}}. Note that \code{axes} overrides \code{xlim} and \code{ylim}. \code{spread.labels} is a logical value indicating whether or not to minimize tip label overlap (default is \code{TRUE}); \code{spread.cost} is a numeric vector indicating the relative penalty to be used for label overlap and deviance, respectively (if \code{spread.labels=TRUE}); \code{spread.range} is the range over which to (potentially) spread the labels - note that if labels do not overlap, not all of that range will be used; finally, \code{link} is a numeric value by which to offset the tip labels, linking them to the tips with a dashed line (default is \code{0}, if \code{spread.labels=FALSE}, or 10\% of the total tree length otherwise). The optional argument \code{offsetFudge} "fudges" the computation of label offset in scaling \code{xlim}. It is 1.37, which is the correct fudge in the Windows R GUI, but this may need to be changed in other systems. \code{hold} indicates whether (or not) the output to the graphical device should be held using \code{\link{dev.hold}} before plotting (defaults to \code{hold=TRUE}). \code{quiet} suppresses some system messages if set to \code{quiet=TRUE}.}
+}
+\description{
+ Plots a phylogenetic traitgram (Evans et al., 2009).
+}
+\details{
+ Function plots a traitgram (Evans et al. 2009), that is, a projection of the phylogenetic tree in a space defined by phenotype (on the \emph{y} axis) and time (on the \emph{x}). If a discrete character is mapped on the tree this will also be plotted.
+
+ For \code{spread.labels=TRUE} numerical optimization is performed to optimize the distribution of the labels vertically, where the solution depends on the vector \code{spread.cost} containing the cost of overlap (first) and the cost of deviation from the vertical position of the tip. Note that because this is done via numerical optimization, plotting may hang briefly while the best solution is found (especially for large trees).
+}
+\value{
+ Plots a traitgram, optionally with a mapped discrete character, and (invisibly) returns a matrix containing the coordinates of the plotted tip labels.
+}
+\references{
+ Evans, M. E. K., Smith, S. A., Flynn, R. S., Donoghue, M. J. (2009) Climate, niche evolution, and diversification of the "bird-cage" evening primroses (Oenothera, sections Anogra and Kleinia). \emph{American Naturalist}, \bold{173}, 225-240.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\examples{
+## load data from Garland et al. (1992)
+data(mammal.tree)
+data(mammal.data)
+## extract character of interest
+ln.bodyMass<-log(setNames(mammal.data$bodyMass,
+ rownames(mammal.data)))
+## plot traitgram
+phenogram(mammal.tree,ln.bodyMass,ftype="i",
+ spread.cost=c(1,0),fsize=0.7,xlab="time (ma)",
+ ylab="log(body mass)")
+}
+\keyword{ancestral states}
+\keyword{phylogenetics}
+\keyword{plotting}
+\keyword{comparative method}
+\keyword{continuous character}
diff --git a/man/phyl.RMA.Rd b/man/phyl.RMA.Rd
index 2d6356b..07136a6 100644
--- a/man/phyl.RMA.Rd
+++ b/man/phyl.RMA.Rd
@@ -1,69 +1,69 @@
-\name{phyl.RMA}
-\alias{phyl.RMA}
-\alias{coef.phyl.RMA}
-\alias{plot.phyl.RMA}
-\title{Phylogenetic reduced major axis (RMA) regression}
-\usage{
-phyl.RMA(x, y, tree, method="BM", lambda=NULL, fixed=FALSE, h0=1.0)
-\method{coef}{phyl.RMA}(object, ...)
-\method{plot}{phyl.RMA}(x, ...)
-}
-\arguments{
- \item{x}{vector with names. In the case of the S3 \code{plot} method \code{x} is an object of class \code{"phyl.RMA"}.}
- \item{y}{vector with names.}
- \item{tree}{a phylogenetic tree in \code{"phylo"} format.}
- \item{method}{method to obtain the correlation structure: can be \code{"BM"} or \code{"lambda"}.}
- \item{lambda}{value of \code{lambda} for fixed \eqn{\lambda}.}
- \item{fixed}{logical value indicating whether or not \eqn{\lambda} should be optimized using likelihood.}
- \item{h0}{null hypothesis for \eqn{\beta}. Defaults to 1.0. Note that a null hypothesis of 0.0 is not allowed.}
- \item{object}{for \code{coef} method, an object of class \code{"phyl.RMA"}.}
- \item{...}{optional arguments for S3 methods.}
-}
-\description{
- Phylogenetic reduced major axis (RMA) regression.
-}
-\details{
- Optionally jointly estimates \eqn{\lambda} if \code{method="lambda"}. Likelihood optimization of \eqn{\lambda} is performed using \code{\link{optimize}} on the interval (0,1).
-
- The statistical hypothesis testing is based on Clarke (1980; reviewed in McArdle 1988), which differs from some other implementations of non-phylogenetic major axis regression in R.
-
- Note that some statistician think there is \emph{never} a condition in which a reduced-major-axis regression is appropriate.
-}
-\value{
- An object of class \code{"phyl.RMA"} consisting of a list with the following elements:
- \item{RMA.beta}{a vector of RMA regression coefficients.}
- \item{V}{a VCV matrix for the traits.}
- \item{lambda}{fitted value of \eqn{\lambda} (\code{method="lambda"} only).}
- \item{logL}{log-likelihood (\code{method="lambda"} only).}
- \item{test}{a vector containing results for hypothesis tests on \eqn{\beta}.}
- \item{resid}{a vector of residuals for \code{y} given \code{x}.}
-}
-\references{
- Clarke, M. R. B. (1980) The reduced major axis of a bivariate sample. \emph{Biometrika}, \bold{67}, 441-446.
-
- McArdle, B. H. (1988) The structural relationship: Regression in biology. \emph{Can. J. Zool.}, \bold{66}, 2329-2339.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{phyl.cca}}, \code{\link{phyl.pca}}, \code{\link{phyl.resid}}
-}
-\examples{
-## load data from Garland et al. (1992)
-data(mammal.data)
-data(mammal.tree)
-## pull out & log transform variables
-lnBodyMass<-setNames(log(mammal.data$bodyMass),
- rownames(mammal.data))
-lnHomeRange<-setNames(log(mammal.data$homeRange),
- rownames(mammal.data))
-## fit RMA regression & print results
-fitted.rma<-phyl.RMA(lnBodyMass,lnHomeRange,
- mammal.tree)
-print(fitted.rma)
-}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{maximum likelihood}
-\keyword{statistics}
+\name{phyl.RMA}
+\alias{phyl.RMA}
+\alias{coef.phyl.RMA}
+\alias{plot.phyl.RMA}
+\title{Phylogenetic reduced major axis (RMA) regression}
+\usage{
+phyl.RMA(x, y, tree, method="BM", lambda=NULL, fixed=FALSE, h0=1.0)
+\method{coef}{phyl.RMA}(object, ...)
+\method{plot}{phyl.RMA}(x, ...)
+}
+\arguments{
+ \item{x}{vector with names. In the case of the S3 \code{plot} method \code{x} is an object of class \code{"phyl.RMA"}.}
+ \item{y}{vector with names.}
+ \item{tree}{a phylogenetic tree in \code{"phylo"} format.}
+ \item{method}{method to obtain the correlation structure: can be \code{"BM"} or \code{"lambda"}.}
+ \item{lambda}{value of \code{lambda} for fixed \eqn{\lambda}.}
+ \item{fixed}{logical value indicating whether or not \eqn{\lambda} should be optimized using likelihood.}
+ \item{h0}{null hypothesis for \eqn{\beta}. Defaults to 1.0. Note that a null hypothesis of 0.0 is not allowed.}
+ \item{object}{for \code{coef} method, an object of class \code{"phyl.RMA"}.}
+ \item{...}{optional arguments for S3 methods.}
+}
+\description{
+ Phylogenetic reduced major axis (RMA) regression.
+}
+\details{
+ Optionally jointly estimates \eqn{\lambda} if \code{method="lambda"}. Likelihood optimization of \eqn{\lambda} is performed using \code{\link{optimize}} on the interval (0,1).
+
+ The statistical hypothesis testing is based on Clarke (1980; reviewed in McArdle 1988), which differs from some other implementations of non-phylogenetic major axis regression in R.
+
+ Note that some statistician think there is \emph{never} a condition in which a reduced-major-axis regression is appropriate.
+}
+\value{
+ An object of class \code{"phyl.RMA"} consisting of a list with the following elements:
+ \item{RMA.beta}{a vector of RMA regression coefficients.}
+ \item{V}{a VCV matrix for the traits.}
+ \item{lambda}{fitted value of \eqn{\lambda} (\code{method="lambda"} only).}
+ \item{logL}{log-likelihood (\code{method="lambda"} only).}
+ \item{test}{a vector containing results for hypothesis tests on \eqn{\beta}.}
+ \item{resid}{a vector of residuals for \code{y} given \code{x}.}
+}
+\references{
+ Clarke, M. R. B. (1980) The reduced major axis of a bivariate sample. \emph{Biometrika}, \bold{67}, 441-446.
+
+ McArdle, B. H. (1988) The structural relationship: Regression in biology. \emph{Can. J. Zool.}, \bold{66}, 2329-2339.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{phyl.cca}}, \code{\link{phyl.pca}}, \code{\link{phyl.resid}}
+}
+\examples{
+## load data from Garland et al. (1992)
+data(mammal.data)
+data(mammal.tree)
+## pull out & log transform variables
+lnBodyMass<-setNames(log(mammal.data$bodyMass),
+ rownames(mammal.data))
+lnHomeRange<-setNames(log(mammal.data$homeRange),
+ rownames(mammal.data))
+## fit RMA regression & print results
+fitted.rma<-phyl.RMA(lnBodyMass,lnHomeRange,
+ mammal.tree)
+print(fitted.rma)
+}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{maximum likelihood}
+\keyword{statistics}
diff --git a/man/phyl.cca.Rd b/man/phyl.cca.Rd
index 914eb25..a0ea1af 100644
--- a/man/phyl.cca.Rd
+++ b/man/phyl.cca.Rd
@@ -1,42 +1,42 @@
-\name{phyl.cca}
-\alias{phyl.cca}
-\title{Phylogenetic canonical correlation analysis}
-\usage{
-phyl.cca(tree, X, Y, lambda=1.0, fixed=TRUE)
-}
-\arguments{
- \item{tree}{a phylogenetic tree in \code{"phylo"} format.}
- \item{X}{a data matrix with traits in columns.}
- \item{Y}{data matrix with traits in columns, to be correlated with \code{X}.}
- \item{lambda}{optionally, a (fixed) value for \eqn{\lambda}.}
- \item{fixed}{optionally, a logical value indicating whether or not to estimate \eqn{\lambda} using likelihood.}
-}
-\description{
- Phylogenetic canonical correlation analysis, following Revell & Harrison (2008).
-}
-\details{
- (Optional) joint optimization of \eqn{\lambda} is performed using \code{\link{optimize}} on the interval (0,1).
-}
-\value{
- An object of class \code{"phyl.cca"} containing the following elements:
- \item{cor}{canonical correlations.}
- \item{xcoef}{coefficients for the canonical variables for \code{X}.}
- \item{ycoef}{coefficients for the canonical variables for \code{Y}.}
- \item{xscores}{matrix with the canonical scores for \code{X}.}
- \item{yscores}{matrix with the canonical scores for \code{Y}.}
- \item{chisq}{vector of \eqn{\chi^2} values.}
- \item{p}{P-values for the hypothesis test that the \emph{i}th and all subsequent correlations are zero.}
-}
-\references{
- Revell, L. J., Harrison, A. S. (2008) PCCA: A program for phylogenetic canonical correlation analysis. \emph{Bioinformatics}, \bold{24}, 1018-1020.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{phyl.pca}}
-}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{statistics}
-\keyword{least squares}
+\name{phyl.cca}
+\alias{phyl.cca}
+\title{Phylogenetic canonical correlation analysis}
+\usage{
+phyl.cca(tree, X, Y, lambda=1.0, fixed=TRUE)
+}
+\arguments{
+ \item{tree}{a phylogenetic tree in \code{"phylo"} format.}
+ \item{X}{a data matrix with traits in columns.}
+ \item{Y}{data matrix with traits in columns, to be correlated with \code{X}.}
+ \item{lambda}{optionally, a (fixed) value for \eqn{\lambda}.}
+ \item{fixed}{optionally, a logical value indicating whether or not to estimate \eqn{\lambda} using likelihood.}
+}
+\description{
+ Phylogenetic canonical correlation analysis, following Revell & Harrison (2008).
+}
+\details{
+ (Optional) joint optimization of \eqn{\lambda} is performed using \code{\link{optimize}} on the interval (0,1).
+}
+\value{
+ An object of class \code{"phyl.cca"} containing the following elements:
+ \item{cor}{canonical correlations.}
+ \item{xcoef}{coefficients for the canonical variables for \code{X}.}
+ \item{ycoef}{coefficients for the canonical variables for \code{Y}.}
+ \item{xscores}{matrix with the canonical scores for \code{X}.}
+ \item{yscores}{matrix with the canonical scores for \code{Y}.}
+ \item{chisq}{vector of \eqn{\chi^2} values.}
+ \item{p}{P-values for the hypothesis test that the \emph{i}th and all subsequent correlations are zero.}
+}
+\references{
+ Revell, L. J., Harrison, A. S. (2008) PCCA: A program for phylogenetic canonical correlation analysis. \emph{Bioinformatics}, \bold{24}, 1018-1020.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{phyl.pca}}
+}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{statistics}
+\keyword{least squares}
diff --git a/man/phyl.pairedttest.Rd b/man/phyl.pairedttest.Rd
index ba54b7c..221b4cb 100644
--- a/man/phyl.pairedttest.Rd
+++ b/man/phyl.pairedttest.Rd
@@ -1,51 +1,51 @@
-\name{phyl.pairedttest}
-\alias{phyl.pairedttest}
-\title{Phylogenetic paired \emph{t}-test}
-\usage{
-phyl.pairedttest(tree, x1, x2=NULL, se1=NULL, se2=NULL, lambda=1.0, h0=0.0,
- fixed=FALSE, ...)
-}
-\arguments{
- \item{tree}{a phylogeny as an object of class \code{"phylo"}.}
- \item{x1}{data vector for first trait, or matrix with two traits in columns.}
- \item{x2}{data vector for second trait (or null if \code{x1} is a matrix).}
- \item{se1}{standard errors for \code{x1}.}
- \item{se2}{standard errors for \code{x2}.}
- \item{lambda}{starting value for Pagel's \ifelse{html}{\out{λ}}{\eqn{\lambda}{lambda}} (or fixed value, if \code{fixed=TRUE}).}
- \item{h0}{null hypothesis (to be tested) for the mean difference between \code{x1} and \code{x2}.}
- \item{fixed}{logical value specifying whether or not to optimize \ifelse{html}{\out{λ}}{\eqn{\lambda}{lambda}}.}
- \item{...}{optional arguments.}
-}
-\description{
- Phylogenetic paired \emph{t}-test following Lindenfors et al. (2010).
-}
-\details{
- This function conducts a phylogenetic paired \emph{t}-test, roughly following Lindenfors et al. (2010).
-
- This is \emph{not} a phylogenetic ANOVA, in which we want to compare the means of different sets of species on the tree. Instead, we are interested in the difference between two characters, or two measures of a character within a species, and we want to know if this difference is significantly different from zero controlling for the phylogenetic non-independence of species.
-
- Likelihood optimization is performed using \code{\link{optim}} with \code{method="L-BFGS-B"} with box constraints on \ifelse{html}{\out{λ}}{\eqn{\lambda}{lambda}} (0,1).
-}
-\value{
- An object of class \code{"phyl.pairedttest"} with the following elements:
- \item{dbar}{phylogenetic mean difference.}
- \item{se}{standard error of \code{dbar}.}
- \item{sig2}{estimated evolutionary variance (of the difference).}
- \item{lambda}{fitted (or fixed) value of \ifelse{html}{\out{λ}}{\eqn{\lambda}{lambda}}.}
- \item{logL}{log-likelihood of the fitted model.}
- \item{t.dbar}{t-value (\code{(dbar-h0)/se} where \code{se} is computed from the Hessian).}
- \item{P.dbar}{P-value.}
- \item{df}{the degrees of freedom.}
- \item{h0}{the null hypothesis that was tested.}
-}
-\references{
- Lindenfors, P., L. J. Revell, and C. L. Nunn (2010) Sexual dimorphism in primate aerobic capacity: A phylogenetic test. \emph{J. Evol. Biol.}, \bold{23}, 1183-1194.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{maximum likelihood}
-\keyword{statistics}
-\keyword{least squares}
+\name{phyl.pairedttest}
+\alias{phyl.pairedttest}
+\title{Phylogenetic paired \emph{t}-test}
+\usage{
+phyl.pairedttest(tree, x1, x2=NULL, se1=NULL, se2=NULL, lambda=1.0, h0=0.0,
+ fixed=FALSE, ...)
+}
+\arguments{
+ \item{tree}{a phylogeny as an object of class \code{"phylo"}.}
+ \item{x1}{data vector for first trait, or matrix with two traits in columns.}
+ \item{x2}{data vector for second trait (or null if \code{x1} is a matrix).}
+ \item{se1}{standard errors for \code{x1}.}
+ \item{se2}{standard errors for \code{x2}.}
+ \item{lambda}{starting value for Pagel's \ifelse{html}{\out{λ}}{\eqn{\lambda}{lambda}} (or fixed value, if \code{fixed=TRUE}).}
+ \item{h0}{null hypothesis (to be tested) for the mean difference between \code{x1} and \code{x2}.}
+ \item{fixed}{logical value specifying whether or not to optimize \ifelse{html}{\out{λ}}{\eqn{\lambda}{lambda}}.}
+ \item{...}{optional arguments.}
+}
+\description{
+ Phylogenetic paired \emph{t}-test following Lindenfors et al. (2010).
+}
+\details{
+ This function conducts a phylogenetic paired \emph{t}-test, roughly following Lindenfors et al. (2010).
+
+ This is \emph{not} a phylogenetic ANOVA, in which we want to compare the means of different sets of species on the tree. Instead, we are interested in the difference between two characters, or two measures of a character within a species, and we want to know if this difference is significantly different from zero controlling for the phylogenetic non-independence of species.
+
+ Likelihood optimization is performed using \code{\link{optim}} with \code{method="L-BFGS-B"} with box constraints on \ifelse{html}{\out{λ}}{\eqn{\lambda}{lambda}} (0,1).
+}
+\value{
+ An object of class \code{"phyl.pairedttest"} with the following elements:
+ \item{dbar}{phylogenetic mean difference.}
+ \item{se}{standard error of \code{dbar}.}
+ \item{sig2}{estimated evolutionary variance (of the difference).}
+ \item{lambda}{fitted (or fixed) value of \ifelse{html}{\out{λ}}{\eqn{\lambda}{lambda}}.}
+ \item{logL}{log-likelihood of the fitted model.}
+ \item{t.dbar}{t-value (\code{(dbar-h0)/se} where \code{se} is computed from the Hessian).}
+ \item{P.dbar}{P-value.}
+ \item{df}{the degrees of freedom.}
+ \item{h0}{the null hypothesis that was tested.}
+}
+\references{
+ Lindenfors, P., L. J. Revell, and C. L. Nunn (2010) Sexual dimorphism in primate aerobic capacity: A phylogenetic test. \emph{J. Evol. Biol.}, \bold{23}, 1183-1194.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{maximum likelihood}
+\keyword{statistics}
+\keyword{least squares}
diff --git a/man/phyl.pca.Rd b/man/phyl.pca.Rd
index 1fea563..2beae56 100644
--- a/man/phyl.pca.Rd
+++ b/man/phyl.pca.Rd
@@ -1,68 +1,68 @@
-\name{phyl.pca}
-\alias{phyl.pca}
-\alias{biplot.phyl.pca}
-\alias{scores}
-\alias{scores.phyl.pca}
-\alias{as.princomp}
-\alias{as.princomp.phyl.pca}
-\title{Phylogenetic principal components analysis}
-\usage{
-phyl.pca(tree, Y, method="BM", mode="cov", ...)
-\method{biplot}{phyl.pca}(x, ...)
-scores(object, ...)
-\method{scores}{phyl.pca}(object, ...)
-as.princomp(x, ...)
-\method{as.princomp}{phyl.pca}(x, ...)
-}
-\arguments{
- \item{tree}{phylogeny as an object of class \code{"phylo"}.}
- \item{Y}{data matrix with traits in columns.}
- \item{method}{method to obtain the correlation structure: can be \code{"BM"} or \code{"lambda"}.}
- \item{mode}{is the mode for the PCA: can be \code{"cov"} or \code{"corr"}.}
- \item{x}{object of class \code{"phyl.pca"} for \code{biplot} and \code{as.princomp} methods.}
- \item{object}{object of class \code{"phyl.pca"} for \code{scores} method.}
- \item{...}{for S3 plotting method \code{biplot.phyl.pca}, other arguments to be passed to \code{\link{biplot}}.}
-}
-\description{
- This function performs phylogenetic PCA following Revell (2009).
-}
-\details{
- If \code{method="lambda"} then \eqn{\lambda} will be optimized on the interval (0,1) using \code{\link{optimize}}. Optimization method can be set using the option \code{opt} which can take values \code{"ML"}, \code{"REML"}, or \code{"fixed"}. If the last of these is selected than the user should also specify a value of \eqn{\lambda} to use via the argument \code{lambda}.
-
- S3 methods (\code{print}, \code{summary}, and \code{biplot}) are modified from code provided by Joan Maspons and are based on the same methods for objects of class \code{"prcomp"}. Function \code{biplot} now permits the argument \code{choices} to be supplied, which should be a vector of length two indicated the two PC axes to be plotted.
-
- S3 method \code{scores} extracts or computes (for a matrix of \code{newdata}) PC scores given an object of class \code{"phyl.pca"}.
-}
-\value{
- An object of class \code{"phyl.pca"} consisting of a list with some or all of the following elements:
- \item{Eval}{diagonal matrix of eigenvalues.}
- \item{Evec}{matrix with eigenvectors in columns.}
- \item{S}{matrix with scores.}
- \item{L}{matrix with loadings.}
- \item{lambda}{fitted value of \eqn{\lambda} (\code{method="lambda"} only).}
- \item{logL}{log-likelihood for \eqn{\lambda} model (\code{method="logL"} only).}
-}
-\references{
- Revell, L. J. (2009) Size-correction and principal components for interspecific comparative studies. \emph{Evolution}, \bold{63}, 3258-3268.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}, Joan Maspons}
-\seealso{
- \code{\link{phyl.cca}}, \code{\link{phyl.resid}}
-}
-\examples{
-## load data from Mahler et al. (2010)
-data(anoletree)
-data(anole.data)
-## run phylogenetic PCA
-anole.pca<-phyl.pca(anoletree,anole.data)
-print(anole.pca)
-## plot results
-plot(anole.pca)
-biplot(anole.pca)
-}
-\keyword{phylogenetics}
-\keyword{maximum likelihood}
-\keyword{comparative method}
-\keyword{statistics}
+\name{phyl.pca}
+\alias{phyl.pca}
+\alias{biplot.phyl.pca}
+\alias{scores}
+\alias{scores.phyl.pca}
+\alias{as.princomp}
+\alias{as.princomp.phyl.pca}
+\title{Phylogenetic principal components analysis}
+\usage{
+phyl.pca(tree, Y, method="BM", mode="cov", ...)
+\method{biplot}{phyl.pca}(x, ...)
+scores(object, ...)
+\method{scores}{phyl.pca}(object, ...)
+as.princomp(x, ...)
+\method{as.princomp}{phyl.pca}(x, ...)
+}
+\arguments{
+ \item{tree}{phylogeny as an object of class \code{"phylo"}.}
+ \item{Y}{data matrix with traits in columns.}
+ \item{method}{method to obtain the correlation structure: can be \code{"BM"} or \code{"lambda"}.}
+ \item{mode}{is the mode for the PCA: can be \code{"cov"} or \code{"corr"}.}
+ \item{x}{object of class \code{"phyl.pca"} for \code{biplot} and \code{as.princomp} methods.}
+ \item{object}{object of class \code{"phyl.pca"} for \code{scores} method.}
+ \item{...}{for S3 plotting method \code{biplot.phyl.pca}, other arguments to be passed to \code{\link{biplot}}.}
+}
+\description{
+ This function performs phylogenetic PCA following Revell (2009).
+}
+\details{
+ If \code{method="lambda"} then \eqn{\lambda} will be optimized on the interval (0,1) using \code{\link{optimize}}. Optimization method can be set using the option \code{opt} which can take values \code{"ML"}, \code{"REML"}, or \code{"fixed"}. If the last of these is selected than the user should also specify a value of \eqn{\lambda} to use via the argument \code{lambda}.
+
+ S3 methods (\code{print}, \code{summary}, and \code{biplot}) are modified from code provided by Joan Maspons and are based on the same methods for objects of class \code{"prcomp"}. Function \code{biplot} now permits the argument \code{choices} to be supplied, which should be a vector of length two indicated the two PC axes to be plotted.
+
+ S3 method \code{scores} extracts or computes (for a matrix of \code{newdata}) PC scores given an object of class \code{"phyl.pca"}.
+}
+\value{
+ An object of class \code{"phyl.pca"} consisting of a list with some or all of the following elements:
+ \item{Eval}{diagonal matrix of eigenvalues.}
+ \item{Evec}{matrix with eigenvectors in columns.}
+ \item{S}{matrix with scores.}
+ \item{L}{matrix with loadings.}
+ \item{lambda}{fitted value of \eqn{\lambda} (\code{method="lambda"} only).}
+ \item{logL}{log-likelihood for \eqn{\lambda} model (\code{method="logL"} only).}
+}
+\references{
+ Revell, L. J. (2009) Size-correction and principal components for interspecific comparative studies. \emph{Evolution}, \bold{63}, 3258-3268.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}, Joan Maspons}
+\seealso{
+ \code{\link{phyl.cca}}, \code{\link{phyl.resid}}
+}
+\examples{
+## load data from Mahler et al. (2010)
+data(anoletree)
+data(anole.data)
+## run phylogenetic PCA
+anole.pca<-phyl.pca(anoletree,anole.data)
+print(anole.pca)
+## plot results
+plot(anole.pca)
+biplot(anole.pca)
+}
+\keyword{phylogenetics}
+\keyword{maximum likelihood}
+\keyword{comparative method}
+\keyword{statistics}
diff --git a/man/phyl.resid.Rd b/man/phyl.resid.Rd
index 8b5fd27..18b32ff 100644
--- a/man/phyl.resid.Rd
+++ b/man/phyl.resid.Rd
@@ -1,45 +1,45 @@
-\name{phyl.resid}
-\alias{phyl.resid}
-\title{Phylogenetic size-correction via GLS regression}
-\usage{
-phyl.resid(tree, x, Y, method="BM")
-}
-\arguments{
- \item{tree}{a phylogenetic tree in \code{"phylo"} format.}
- \item{x}{vector containing the single independent variable (e.g., size), or matrix with multiple independent variables in columns.}
- \item{Y}{vector or matrix with one or multiple dependent variables in columns.}
- \item{method}{method to obtain the correlation structure: can be \code{"BM"} or \code{"lambda"}.}
-}
-\description{
- Computes the residuals from the phylogenetic regression of multiple \emph{y} variables (in a matrix) on a single \emph{x}.
-}
-\details{
- This function fits one or multiple phylogenetic regressions (depending on the number of columns in \code{Y}) and computes the residuals. Designed for phylogenetic size correction using GLS regression (e.g., Revell 2009).
-
- Optionally fits \eqn{\lambda} for each regression model. Likelihood optimization of \eqn{\lambda} is performed for \code{method=} \code{"lambda"} using \code{\link{optimize}} on the interval (0,1).
-
- This function is theoretically redundant with \code{residuals} applied to a \code{"gls"} object class in which the correlation structure is based on \code{corBrownian} or \code{corPagel}; however some users may find this method simpler, and it provides a good way to cross-check your results & make sure that you are using \code{gls} correctly.
-}
-\value{
- A list with the following elements:
- \item{beta}{a vector or matrix of regression coefficients.}
- \item{resid}{a vector or matrix of residuals for species.}
- \item{lambda}{a vector of \eqn{\lambda} values (\code{method="lambda"} only).}
- \item{logL}{a vector of log-likelihoods (\code{method="lambda"} only).}
-}
-\references{
- Revell, L. J. (2009) Size-correction and principal components for interspecific comparative studies. \emph{Evolution}, \bold{63}, 3258-3268.
-
- Revell, L. J. (2010) Phylogenetic signal and linear regression on species data. \emph{Methods in Ecology and Evolution}, \bold{1}, 319-329.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{phyl.pca}}, \code{\link{gls}}
-}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{statistics}
-\keyword{least squares}
-\keyword{maximum likelihood}
+\name{phyl.resid}
+\alias{phyl.resid}
+\title{Phylogenetic size-correction via GLS regression}
+\usage{
+phyl.resid(tree, x, Y, method="BM")
+}
+\arguments{
+ \item{tree}{a phylogenetic tree in \code{"phylo"} format.}
+ \item{x}{vector containing the single independent variable (e.g., size), or matrix with multiple independent variables in columns.}
+ \item{Y}{vector or matrix with one or multiple dependent variables in columns.}
+ \item{method}{method to obtain the correlation structure: can be \code{"BM"} or \code{"lambda"}.}
+}
+\description{
+ Computes the residuals from the phylogenetic regression of multiple \emph{y} variables (in a matrix) on a single \emph{x}.
+}
+\details{
+ This function fits one or multiple phylogenetic regressions (depending on the number of columns in \code{Y}) and computes the residuals. Designed for phylogenetic size correction using GLS regression (e.g., Revell 2009).
+
+ Optionally fits \eqn{\lambda} for each regression model. Likelihood optimization of \eqn{\lambda} is performed for \code{method=} \code{"lambda"} using \code{\link{optimize}} on the interval (0,1).
+
+ This function is theoretically redundant with \code{residuals} applied to a \code{"gls"} object class in which the correlation structure is based on \code{corBrownian} or \code{corPagel}; however some users may find this method simpler, and it provides a good way to cross-check your results & make sure that you are using \code{gls} correctly.
+}
+\value{
+ A list with the following elements:
+ \item{beta}{a vector or matrix of regression coefficients.}
+ \item{resid}{a vector or matrix of residuals for species.}
+ \item{lambda}{a vector of \eqn{\lambda} values (\code{method="lambda"} only).}
+ \item{logL}{a vector of log-likelihoods (\code{method="lambda"} only).}
+}
+\references{
+ Revell, L. J. (2009) Size-correction and principal components for interspecific comparative studies. \emph{Evolution}, \bold{63}, 3258-3268.
+
+ Revell, L. J. (2010) Phylogenetic signal and linear regression on species data. \emph{Methods in Ecology and Evolution}, \bold{1}, 319-329.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{phyl.pca}}, \code{\link{gls}}
+}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{statistics}
+\keyword{least squares}
+\keyword{maximum likelihood}
diff --git a/man/phyl.vcv.Rd b/man/phyl.vcv.Rd
index 8b6fbda..7fdc576 100644
--- a/man/phyl.vcv.Rd
+++ b/man/phyl.vcv.Rd
@@ -1,29 +1,29 @@
-\name{phyl.vcv}
-\alias{phyl.vcv}
-\title{Compute evolutionary VCV matrix for a tree & dataset}
-\usage{
-phyl.vcv(X, C, lambda)
-}
-\arguments{
- \item{lambda}{value for \eqn{\lambda} transformation.}
- \item{X}{data matrix.}
- \item{C}{matrix containing the height above the root of each pair of species in the tree. Typically this will have been produced by calling \code{\link{vcv.phylo}}.}
-}
-\description{
- Internal function for \code{\link{phyl.pca}}.
-}
-\details{
- Primarily designed as an internal function for \code{\link{phyl.pca}}; \code{phyl.vcv} can be used to compute the phylogenetic trait variance-covariance matrix given a phylogenetic VCV, \eqn{\lambda}, and a data matrix.
-
- This function should not be confused with \code{\link{vcv.phylo}} in the \pkg{ape} package (although one of the objects returned is the output of \code{vcv.phylo}).
-}
-\value{
- A list containing three elements, as follows: \code{C}, the matrix \code{vcv.phylo} transformed by \code{lambda}; \code{R}, the among trait variance-covariance matrix for the data in \code{X}; and \code{alpha}, a vector of ancestral states at the root node of the tree.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{phylogenetics}
-\keyword{statistics}
-\keyword{utilities}
+\name{phyl.vcv}
+\alias{phyl.vcv}
+\title{Compute evolutionary VCV matrix for a tree & dataset}
+\usage{
+phyl.vcv(X, C, lambda)
+}
+\arguments{
+ \item{lambda}{value for \eqn{\lambda} transformation.}
+ \item{X}{data matrix.}
+ \item{C}{matrix containing the height above the root of each pair of species in the tree. Typically this will have been produced by calling \code{\link{vcv.phylo}}.}
+}
+\description{
+ Internal function for \code{\link{phyl.pca}}.
+}
+\details{
+ Primarily designed as an internal function for \code{\link{phyl.pca}}; \code{phyl.vcv} can be used to compute the phylogenetic trait variance-covariance matrix given a phylogenetic VCV, \eqn{\lambda}, and a data matrix.
+
+ This function should not be confused with \code{\link{vcv.phylo}} in the \pkg{ape} package (although one of the objects returned is the output of \code{vcv.phylo}).
+}
+\value{
+ A list containing three elements, as follows: \code{C}, the matrix \code{vcv.phylo} transformed by \code{lambda}; \code{R}, the among trait variance-covariance matrix for the data in \code{X}; and \code{alpha}, a vector of ancestral states at the root node of the tree.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{phylogenetics}
+\keyword{statistics}
+\keyword{utilities}
diff --git a/man/phylANOVA.Rd b/man/phylANOVA.Rd
index a9ae89c..4014be2 100644
--- a/man/phylANOVA.Rd
+++ b/man/phylANOVA.Rd
@@ -1,45 +1,45 @@
-\name{phylANOVA}
-\alias{phylANOVA}
-\title{Phylogenetic ANOVA and post-hoc tests}
-\usage{
-phylANOVA(tree, x, y, nsim=1000, posthoc=TRUE, p.adj="holm")
-}
-\arguments{
- \item{tree}{a phylogenetic tree in \code{"phylo"} format.}
- \item{x}{a vector containing the groups.}
- \item{y}{a vector containing the response variable (continuously valued).}
- \item{nsim}{an integer specifying the number of simulations (including the observed data).}
- \item{posthoc}{a logical value indicating whether or not to conduct posthoc tests to compare the mean among groups.}
- \item{p.adj}{method to adjust P-values for the posthoc tests to account for multiple testing. Options same as \code{\link{p.adjust}}.}
-}
-\description{
- Simulation based phylogenetic ANOVA following Garland et al. (1993), with post-hoc tests.
-}
-\details{
- This function performs the simulation-based phylogenetic ANOVA of Garland et al. (1993) and (optionally) conducts all posthoc comparisons of means among groups (also obtaining the P-values by phylogenetic simulation).
-
- This function uses a little bit of code from both \code{phy.anova} in the \pkg{geiger} package and \code{\link{pairwise.t.test}}.
-}
-\value{
- An object of class \code{"phylANOVA"} containing the following elements:
- \item{F}{F from observed data.}
- \item{Pf}{P-value for F from simulation.}
- \item{T}{matrix of t-values.}
- \item{Pt}{matrix of multiple test corrected P-values from posthoc t-tests.}
-}
-\references{
- Garland, T., Jr., A. W. Dickerman, C. M. Janis, & J. A. Jones. (1993) Phylogenetic analysis of covariance by computer simulation. \emph{Systematic Biology}, \bold{42}, 265-292.
-
- Harmon, L. J., J. T. Weir, C. D. Brock, R. E. Glor, W. Challenger. (2008) GEIGER: investigating evolutionary radiations. \emph{Bioinformatics}, 24, 129-131.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{anova}}, \code{\link{pairwise.t.test}}
-}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{statistics}
-\keyword{least squares}
-\keyword{simulation}
+\name{phylANOVA}
+\alias{phylANOVA}
+\title{Phylogenetic ANOVA and post-hoc tests}
+\usage{
+phylANOVA(tree, x, y, nsim=1000, posthoc=TRUE, p.adj="holm")
+}
+\arguments{
+ \item{tree}{a phylogenetic tree in \code{"phylo"} format.}
+ \item{x}{a vector containing the groups.}
+ \item{y}{a vector containing the response variable (continuously valued).}
+ \item{nsim}{an integer specifying the number of simulations (including the observed data).}
+ \item{posthoc}{a logical value indicating whether or not to conduct posthoc tests to compare the mean among groups.}
+ \item{p.adj}{method to adjust P-values for the posthoc tests to account for multiple testing. Options same as \code{\link{p.adjust}}.}
+}
+\description{
+ Simulation based phylogenetic ANOVA following Garland et al. (1993), with post-hoc tests.
+}
+\details{
+ This function performs the simulation-based phylogenetic ANOVA of Garland et al. (1993) and (optionally) conducts all posthoc comparisons of means among groups (also obtaining the P-values by phylogenetic simulation).
+
+ This function uses a little bit of code from both \code{phy.anova} in the \pkg{geiger} package and \code{\link{pairwise.t.test}}.
+}
+\value{
+ An object of class \code{"phylANOVA"} containing the following elements:
+ \item{F}{F from observed data.}
+ \item{Pf}{P-value for F from simulation.}
+ \item{T}{matrix of t-values.}
+ \item{Pt}{matrix of multiple test corrected P-values from posthoc t-tests.}
+}
+\references{
+ Garland, T., Jr., A. W. Dickerman, C. M. Janis, & J. A. Jones. (1993) Phylogenetic analysis of covariance by computer simulation. \emph{Systematic Biology}, \bold{42}, 265-292.
+
+ Harmon, L. J., J. T. Weir, C. D. Brock, R. E. Glor, W. Challenger. (2008) GEIGER: investigating evolutionary radiations. \emph{Bioinformatics}, 24, 129-131.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{anova}}, \code{\link{pairwise.t.test}}
+}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{statistics}
+\keyword{least squares}
+\keyword{simulation}
diff --git a/man/phylo.heatmap.Rd b/man/phylo.heatmap.Rd
index 98677f3..597b575 100644
--- a/man/phylo.heatmap.Rd
+++ b/man/phylo.heatmap.Rd
@@ -1,43 +1,43 @@
-\name{phylo.heatmap}
-\alias{phylo.heatmap}
-\title{Creates a phylogenetic heat map}
-\usage{
-phylo.heatmap(tree, X, fsize=1, colors=NULL, standardize=FALSE, ...)
-}
-\arguments{
- \item{tree}{an object of class \code{"phylo"}.}
- \item{X}{a matrix containing data for multiple continuous characters in which \code{rownames} correspond to the tip labels of the tree.}
- \item{fsize}{an integer or vector of length 3 containing the font size for the tip labels, the trait labels, and the legend text. (If a single integer is supplied, then the value will be recycled.)}
- \item{colors}{a vector of colors to be passed to \code{\link{image}}. Can be a function call (e.g., \code{heat.colors(n=} \code{200)[200:1]}).}
- \item{standardize}{a logical value indicating whether or not to standardize each column of \code{X} to have the same variance & mean prior to analysis.}
- \item{...}{optional arguments. So far these include: \code{legend}, a logical value indicating whether or not to plot a figure legend (defaults to \code{legend=TRUE}); \code{labels}, a logical value indicating whether or not to plot trait labels (defaults to \code{labels=TRUE}); \code{split}, a numeric vector indicating the fraction of the horizontal dimension to use for the tree & heatmap, respectively (defaults to \code{split=c(0.5,0.5)}); \code{xlim}, \code{ylim}, & \code{mar}, defined as in \code{\link{par}}; and \code{ftype}, \code{lwd}, and \code{pts} as defined in \code{\link{plotSimmap}}.}
-}
-\description{
- Multivariate phylogenetic \code{\link{heatmap}} plot.
-}
-\value{
- Function creates a plot.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\examples{
-## load data
-data(anoletree)
-data(anole.data)
-## compute phylogenetic residuals
-anole.data<-as.matrix(anole.data)
-anole.resids<-cbind(anole.data[,1],
- phyl.resid(anoletree,anole.data[,1,drop=FALSE],
- anole.data[,2:ncol(anole.data)])$resid)
-colnames(anole.resids)[1]<-"SVL"
-## plot phylogenetic heatmap
-phylo.heatmap(anoletree,anole.resids,
- split=c(0.7,0.3),fsize=c(0.4,0.8,0.8),
- standardize=TRUE)
-par(mar=c(5.1,4.1,4.1,2.1)) ## reset margins to default
-}
-\keyword{phylogenetics}
-\keyword{plotting}
-\keyword{continuous character}
+\name{phylo.heatmap}
+\alias{phylo.heatmap}
+\title{Creates a phylogenetic heat map}
+\usage{
+phylo.heatmap(tree, X, fsize=1, colors=NULL, standardize=FALSE, ...)
+}
+\arguments{
+ \item{tree}{an object of class \code{"phylo"}.}
+ \item{X}{a matrix containing data for multiple continuous characters in which \code{rownames} correspond to the tip labels of the tree.}
+ \item{fsize}{an integer or vector of length 3 containing the font size for the tip labels, the trait labels, and the legend text. (If a single integer is supplied, then the value will be recycled.)}
+ \item{colors}{a vector of colors to be passed to \code{\link{image}}. Can be a function call (e.g., \code{heat.colors(n=} \code{200)[200:1]}).}
+ \item{standardize}{a logical value indicating whether or not to standardize each column of \code{X} to have the same variance & mean prior to analysis.}
+ \item{...}{optional arguments. So far these include: \code{legend}, a logical value indicating whether or not to plot a figure legend (defaults to \code{legend=TRUE}); \code{labels}, a logical value indicating whether or not to plot trait labels (defaults to \code{labels=TRUE}); \code{split}, a numeric vector indicating the fraction of the horizontal dimension to use for the tree & heatmap, respectively (defaults to \code{split=c(0.5,0.5)}); \code{xlim}, \code{ylim}, & \code{mar}, defined as in \code{\link{par}}; and \code{ftype}, \code{lwd}, and \code{pts} as defined in \code{\link{plotSimmap}}.}
+}
+\description{
+ Multivariate phylogenetic \code{\link{heatmap}} plot.
+}
+\value{
+ Function creates a plot.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\examples{
+## load data
+data(anoletree)
+data(anole.data)
+## compute phylogenetic residuals
+anole.data<-as.matrix(anole.data)
+anole.resids<-cbind(anole.data[,1],
+ phyl.resid(anoletree,anole.data[,1,drop=FALSE],
+ anole.data[,2:ncol(anole.data)])$resid)
+colnames(anole.resids)[1]<-"SVL"
+## plot phylogenetic heatmap
+phylo.heatmap(anoletree,anole.resids,
+ split=c(0.7,0.3),fsize=c(0.4,0.8,0.8),
+ standardize=TRUE)
+par(mar=c(5.1,4.1,4.1,2.1)) ## reset margins to default
+}
+\keyword{phylogenetics}
+\keyword{plotting}
+\keyword{continuous character}
diff --git a/man/phylo.impute.Rd b/man/phylo.impute.Rd
index de0f56f..c1cd7a6 100644
--- a/man/phylo.impute.Rd
+++ b/man/phylo.impute.Rd
@@ -1,37 +1,37 @@
-\name{phylo.impute}
-\alias{phylo.impute}
-\title{Phylogenetic imputation for multivariate continuous character data}
-\usage{
-phylo.impute(tree, X, ...)
-}
-\arguments{
- \item{tree}{an object of class \code{"phylo"}.}
- \item{X}{data matrix with species names as row labels. Missing data to be imputed should be coded \code{NA}.}
- \item{...}{optional arguments.}
-}
-\description{
- This function performs phylogenetic multiple imputation using maximum likelihood.
-}
-\details{
- This function performs phylogenetic imputation in which the evolution of the characters in \code{X} is assumed to have occured by correlation multivariate Brownian motion.
-
- Missing values are imputed by maximizing their likelihood jointly with the parameters of the Brownian model. The function \code{\link{evol.vcv}} is used internally to compute the likelihood.
-
- Note that the \pkg{Rphylopars} package (\url{https://CRAN.R-project.org/package=Rphylopars}) also does phylogenetic imputation for multivariate trait data and it seems to be much faster.
-}
-\value{
- An object of class \code{"phylo.impute"} consisting of a complete data frame with missing values imputed.
-
- Since optimization is performed numerically using likelihood, a summary of the optimization can be seen by evaluating \code{attr(object,"optim")}, in which \code{object} is of class \code{"phylo.impute"}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{evol.vcv}}
-}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{continuous character}
-\keyword{statistics}
+\name{phylo.impute}
+\alias{phylo.impute}
+\title{Phylogenetic imputation for multivariate continuous character data}
+\usage{
+phylo.impute(tree, X, ...)
+}
+\arguments{
+ \item{tree}{an object of class \code{"phylo"}.}
+ \item{X}{data matrix with species names as row labels. Missing data to be imputed should be coded \code{NA}.}
+ \item{...}{optional arguments.}
+}
+\description{
+ This function performs phylogenetic multiple imputation using maximum likelihood.
+}
+\details{
+ This function performs phylogenetic imputation in which the evolution of the characters in \code{X} is assumed to have occured by correlation multivariate Brownian motion.
+
+ Missing values are imputed by maximizing their likelihood jointly with the parameters of the Brownian model. The function \code{\link{evol.vcv}} is used internally to compute the likelihood.
+
+ Note that the \pkg{Rphylopars} package (\url{https://CRAN.R-project.org/package=Rphylopars}) also does phylogenetic imputation for multivariate trait data and it seems to be much faster.
+}
+\value{
+ An object of class \code{"phylo.impute"} consisting of a complete data frame with missing values imputed.
+
+ Since optimization is performed numerically using likelihood, a summary of the optimization can be seen by evaluating \code{attr(object,"optim")}, in which \code{object} is of class \code{"phylo.impute"}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{evol.vcv}}
+}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{continuous character}
+\keyword{statistics}
diff --git a/man/phylo.to.map.Rd b/man/phylo.to.map.Rd
index a218ee5..338b47d 100644
--- a/man/phylo.to.map.Rd
+++ b/man/phylo.to.map.Rd
@@ -1,36 +1,36 @@
-\name{phylo.to.map}
-\alias{phylo.to.map}
-\alias{plot.phylo.to.map}
-\title{Plot tree with tips linked to geographic coordinates}
-\usage{
-phylo.to.map(tree, coords, rotate=TRUE, ...)
-\method{plot}{phylo.to.map}(x, type=c("phylogram","direct"), ...)
-}
-\arguments{
- \item{tree}{an object of class "phylo".}
- \item{coords}{a matrix containing the latitude (in column 1) and the longitude of all tip species in the tree. The row names should be the same as \code{tree$tip.label}; however, more than one set of coordinates per species can be supplied by duplicating some row names.}
- \item{rotate}{a logical value indicating whether or not to rotate nodes of the tree to better match longitudinal positions.}
- \item{x}{for \code{plot.phylo.to.map}, an object of class \code{"phylo.to.map"}.}
- \item{type}{a string indicating whether to map the tips of the tree onto a geographic map from a square phylogram (\code{type="phylogram"}) or to project the tree directly onto the map (\code{type="direct"}).}
- \item{...}{various optional arguments. For the function \code{phylo.to.map}, which first creates an object of the special class \code{"phylo.to.map"} and then (optionally) plots this object, arguments include: \code{database} and \code{regions} (see \code{\link{map}}), as well as any arguments that should be passed to \code{plot.phylo.to.map} internally. For \code{phylo.to.map}, optional arguments \code{xlim} and \code{ylim}, which control the plot area for the map; \code{fsize} for the font size of plot labels and \code{ftype} for the font type (following \code{\link{plotSimmap}}; \code{split} which controls the proportion of vertical (or horizontal) space for the tree (first) and map, in a vector; \code{psize} the size of the plotted points on the map - or \code{cex.points}, a vector contain the size of the tip points and geographic coordinate points, respectively; \code{from.tip} a logical value indicating whether to plot the linking lines from the tips (if \code{TRUE}) or from the end of the tip label, the default; \code{colors}, a single value or a vector of colors for the points and the linking lines; \code{pch} a single value or a vector of point types; \code{lwd} and \code{lty} for the linking lines; and \code{pts} a logical value indicating whether or not to plot points at the tips of the tree. \code{mar} and \code{asp} are as in \code{\link{par}}.}
-}
-\description{
- Project a phylogeny on a geographic map.
-}
-\details{
- \code{phylo.to.map} creates an object of class \code{"phylo.to.map"} and (optionally) plots that object.
-
- \code{plot.phylo.to.map} plots an object of class \code{"phylo.to.map"} in which the tips of the tree point to coordinates on a geographic map.
-}
-\value{
- \code{phylo.to.map} creates an object of class \code{"phylo.to.map"} and (if \code{plot=TRUE}) plots a phylogeny projected onto a geographic map.
-
- \code{plot.phylo.to.map} plots on object of class \code{"phylo.to.map"}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{phylogenetics}
-\keyword{plotting}
-\keyword{biogeography}
+\name{phylo.to.map}
+\alias{phylo.to.map}
+\alias{plot.phylo.to.map}
+\title{Plot tree with tips linked to geographic coordinates}
+\usage{
+phylo.to.map(tree, coords, rotate=TRUE, ...)
+\method{plot}{phylo.to.map}(x, type=c("phylogram","direct"), ...)
+}
+\arguments{
+ \item{tree}{an object of class "phylo".}
+ \item{coords}{a matrix containing the latitude (in column 1) and the longitude of all tip species in the tree. The row names should be the same as \code{tree$tip.label}; however, more than one set of coordinates per species can be supplied by duplicating some row names.}
+ \item{rotate}{a logical value indicating whether or not to rotate nodes of the tree to better match longitudinal positions.}
+ \item{x}{for \code{plot.phylo.to.map}, an object of class \code{"phylo.to.map"}.}
+ \item{type}{a string indicating whether to map the tips of the tree onto a geographic map from a square phylogram (\code{type="phylogram"}) or to project the tree directly onto the map (\code{type="direct"}).}
+ \item{...}{various optional arguments. For the function \code{phylo.to.map}, which first creates an object of the special class \code{"phylo.to.map"} and then (optionally) plots this object, arguments include: \code{database} and \code{regions} (see \code{\link{map}}), as well as any arguments that should be passed to \code{plot.phylo.to.map} internally. For \code{phylo.to.map}, optional arguments \code{xlim} and \code{ylim}, which control the plot area for the map; \code{fsize} for the font size of plot labels and \code{ftype} for the font type (following \code{\link{plotSimmap}}; \code{split} which controls the proportion of vertical (or horizontal) space for the tree (first) and map, in a vector; \code{psize} the size of the plotted points on the map - or \code{cex.points}, a vector contain the size of the tip points and geographic coordinate points, respectively; \code{from.tip} a logical value indicating whether to plot the linking lines from the tips (if \code{TRUE}) or from the end of the tip label, the default; \code{colors}, a single value or a vector of colors for the points and the linking lines; \code{pch} a single value or a vector of point types; \code{lwd} and \code{lty} for the linking lines; and \code{pts} a logical value indicating whether or not to plot points at the tips of the tree. \code{mar} and \code{asp} are as in \code{\link{par}}.}
+}
+\description{
+ Project a phylogeny on a geographic map.
+}
+\details{
+ \code{phylo.to.map} creates an object of class \code{"phylo.to.map"} and (optionally) plots that object.
+
+ \code{plot.phylo.to.map} plots an object of class \code{"phylo.to.map"} in which the tips of the tree point to coordinates on a geographic map.
+}
+\value{
+ \code{phylo.to.map} creates an object of class \code{"phylo.to.map"} and (if \code{plot=TRUE}) plots a phylogeny projected onto a geographic map.
+
+ \code{plot.phylo.to.map} plots on object of class \code{"phylo.to.map"}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{phylogenetics}
+\keyword{plotting}
+\keyword{biogeography}
diff --git a/man/phylo.toBackbone.Rd b/man/phylo.toBackbone.Rd
index 348b579..cf23f80 100644
--- a/man/phylo.toBackbone.Rd
+++ b/man/phylo.toBackbone.Rd
@@ -1,29 +1,29 @@
-\name{phylo.toBackbone}
-\alias{phylo.toBackbone}
-\alias{backbone.toPhylo}
-\title{Converts tree to backbone or vice versa}
-\usage{
-phylo.toBackbone(x, trans, ...)
-backbone.toPhylo(x)
-}
-\arguments{
- \item{x}{an object of class \code{"phylo"} (for the function \code{phylo.toBackbone}), or an object of the special class \code{"backbonePhylo"} (for \code{backbone.toPhylo}).}
- \item{trans}{data frame containing the attributes necessary to translate a backbone tree to an object of class \code{"backbonePhylo"}. The data frame should contain the following variables: \code{tip.label}: the tip labels in the input tree (not all need be included); \code{clade.label}: labels for the unobserved subtrees; \code{N}: number of species in each subtree; and \code{depth}: desired depth of each subtree. \code{depth} for each terminal taxon in \code{x} cannot be greater than the terminal edge length for that taxon.}
- \item{...}{optional arguments.}
-}
-\description{
- Converts between \code{"phylo"} and \code{"backbonePhylo"}.
-}
-\value{
- Either an object of class \code{"phylo"} or an object of class \code{"backbonePhylo"}, depending on the method.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{plot.backbonePhylo}}
-}
-\keyword{phylogenetics}
-\keyword{plotting}
-
+\name{phylo.toBackbone}
+\alias{phylo.toBackbone}
+\alias{backbone.toPhylo}
+\title{Converts tree to backbone or vice versa}
+\usage{
+phylo.toBackbone(x, trans, ...)
+backbone.toPhylo(x)
+}
+\arguments{
+ \item{x}{an object of class \code{"phylo"} (for the function \code{phylo.toBackbone}), or an object of the special class \code{"backbonePhylo"} (for \code{backbone.toPhylo}).}
+ \item{trans}{data frame containing the attributes necessary to translate a backbone tree to an object of class \code{"backbonePhylo"}. The data frame should contain the following variables: \code{tip.label}: the tip labels in the input tree (not all need be included); \code{clade.label}: labels for the unobserved subtrees; \code{N}: number of species in each subtree; and \code{depth}: desired depth of each subtree. \code{depth} for each terminal taxon in \code{x} cannot be greater than the terminal edge length for that taxon.}
+ \item{...}{optional arguments.}
+}
+\description{
+ Converts between \code{"phylo"} and \code{"backbonePhylo"}.
+}
+\value{
+ Either an object of class \code{"phylo"} or an object of class \code{"backbonePhylo"}, depending on the method.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{plot.backbonePhylo}}
+}
+\keyword{phylogenetics}
+\keyword{plotting}
+
diff --git a/man/phyloDesign.Rd b/man/phyloDesign.Rd
index f6e11f7..5093b5a 100644
--- a/man/phyloDesign.Rd
+++ b/man/phyloDesign.Rd
@@ -1,25 +1,25 @@
-\name{phyloDesign}
-\alias{phyloDesign}
-\title{Compute design matrix for least squares analyses}
-\usage{
-phyloDesign(tree)
-}
-\arguments{
- \item{tree}{phylogenetic tree.}
-}
-\description{
- Primarily an internal function for \code{\link{optim.phylo.ls}}, this function creates a design matrix for least squares phylogenetic analysis.
-}
-\details{
- This function returns a matrix containing the edges in the tree (in columns) and pairs of tip node numbers (in rows). Values in the matrix are either \code{1} if the edge is on the shortest path between the two tips; and \code{0} otherwise. Probably do not use unless you know what you're doing.
-}
-\value{
- A matrix.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{phylogenetics}
-\keyword{phylogeny inference}
-\keyword{least squares}
+\name{phyloDesign}
+\alias{phyloDesign}
+\title{Compute design matrix for least squares analyses}
+\usage{
+phyloDesign(tree)
+}
+\arguments{
+ \item{tree}{phylogenetic tree.}
+}
+\description{
+ Primarily an internal function for \code{\link{optim.phylo.ls}}, this function creates a design matrix for least squares phylogenetic analysis.
+}
+\details{
+ This function returns a matrix containing the edges in the tree (in columns) and pairs of tip node numbers (in rows). Values in the matrix are either \code{1} if the edge is on the shortest path between the two tips; and \code{0} otherwise. Probably do not use unless you know what you're doing.
+}
+\value{
+ A matrix.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{phylogenetics}
+\keyword{phylogeny inference}
+\keyword{least squares}
diff --git a/man/phylomorphospace.Rd b/man/phylomorphospace.Rd
index 4a770a0..a18a6f0 100644
--- a/man/phylomorphospace.Rd
+++ b/man/phylomorphospace.Rd
@@ -1,59 +1,59 @@
-\name{phylomorphospace}
-\alias{phylomorphospace}
-\alias{project.phylomorphospace}
-\title{Creates phylomorphospace plot}
-\usage{
-phylomorphospace(tree, X, A=NULL, label=c("radial","horizontal","off"),
- control=list(), ...)
-project.phylomorphospace(tree, X, nsteps=200, sleep=0,
- direction=c("to","from","both"), ...)
-}
-\arguments{
- \item{tree}{a phylogenetic tree in \code{"phylo"} format, or a modified \code{"phylo"} object with a mapped discrete character.}
- \item{X}{an \code{n} x 2 matrix of tip values for two characters in \code{n} species.}
- \item{A}{an optional \code{m} x 2 matrix (for \code{m} nodes) of values for two taits at internal nodes in the tree - if not supplied, these values will be estimated using \code{\link{fastAnc}}.}
- \item{label}{string indicating whether to plot the tip labels in the same direction as the terminal edge (\code{label="radial"}), horizontally \code{label="horizontal"}, or not at all \code{"off"}. \code{label=TRUE} and \code{label=FALSE} are also acceptable, for compatibility with phytools <= 0.3-03.}
- \item{control}{a list containing the following optional control parameters: \code{col.edge}: a vector of edge colors; and \code{col.node}: a vector of node colors.}
- \item{nsteps}{for \code{project.phylomorphospace} the number of frames in the animation between the phylogeny & the phylomorphospace or \emph{vice versa}.}
- \item{sleep}{for \code{project.phylomorphospace} the time between frames.}
- \item{direction}{for \code{project.phylomorphospace} whether to morph \code{"to"} a phylomorphospace, \code{"from"} a phylomorphospace, or there & back again (\code{"both"}).}
- \item{...}{optional arguments for plotting, including \code{xlim}, \code{ylim}, \code{xlab}, \code{ylab}, \code{lwd}, \code{colors}, \code{fsize}, and \code{node.by.map}. \code{colors} is only used when there is a mapped discrete character on the tree, in which case \code{control$col.edge} is ignored. \code{fsize} is relative to the default, which is \code{textxy(...,cx=0.75)}. \code{node.by.map} is a logical value (defaults to \code{FALSE} which tells the function whether or not to plot the node colors using the colors of the mapped discrete character. Setting this option to \code{TRUE} will cause \code{control$col.node} to be ignored. \code{node.size} is a vector containing the point size relative to the default (see \code{\link{par}} for plotted internal nodes and tips, respectively. Defaults to \code{node.size=c(1,1.3)}. If only one number is provided it will be recycled. \code{axes} is a logical value indicating whether or not axes should be plotted (see \code{\link{plot.default}}. Finally, \code{add} indicates whether to add the phylmorphospace to the current plot.}
-}
-\description{
- Project a phylogeny into morphospace.
-}
-\details{
- This function creates a phylomorphospace plot (a projection of the tree into morphospace) for two characters following Sidlauskas (2008; \emph{Evolution}). It will also plot a discrete character mapped on tree.
-
- \code{project.phylomorphospace} animates the phylomorphospace projection.
-}
-\value{
- This function creates a phylomorphospace plot
-}
-\references{
- Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-90.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-
- Sidlauskas, B. (2008) Continuous and arrested morphological diversification in sister clades of characiform fishes: A phylomorphospace approach. \emph{Evolution}, \bold{62}, 3135-3156.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\examples{
-## load tree & data from Revell & Collar (2009)
-data(sunfish.tree)
-data(sunfish.data)
-## set colors for mapped discrete character
-cols<-setNames(c("blue","red"),
- levels(sunfish.data$feeding.mode))
-phylomorphospace(sunfish.tree,sunfish.data[,3:2],
- colors=cols,bty="l",ftype="off",node.by.map=TRUE,
- node.size=c(0,1.2),xlab="relative buccal length",
- ylab="relative gape width")
-title(main="Phylomorphospace of buccal morphology in Centrarchidae",
- font.main=3)
-}
-\keyword{ancestral states}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{plotting}
-\keyword{continuous character}
+\name{phylomorphospace}
+\alias{phylomorphospace}
+\alias{project.phylomorphospace}
+\title{Creates phylomorphospace plot}
+\usage{
+phylomorphospace(tree, X, A=NULL, label=c("radial","horizontal","off"),
+ control=list(), ...)
+project.phylomorphospace(tree, X, nsteps=200, sleep=0,
+ direction=c("to","from","both"), ...)
+}
+\arguments{
+ \item{tree}{a phylogenetic tree in \code{"phylo"} format, or a modified \code{"phylo"} object with a mapped discrete character.}
+ \item{X}{an \code{n} x 2 matrix of tip values for two characters in \code{n} species.}
+ \item{A}{an optional \code{m} x 2 matrix (for \code{m} nodes) of values for two taits at internal nodes in the tree - if not supplied, these values will be estimated using \code{\link{fastAnc}}.}
+ \item{label}{string indicating whether to plot the tip labels in the same direction as the terminal edge (\code{label="radial"}), horizontally \code{label="horizontal"}, or not at all \code{"off"}. \code{label=TRUE} and \code{label=FALSE} are also acceptable, for compatibility with phytools <= 0.3-03.}
+ \item{control}{a list containing the following optional control parameters: \code{col.edge}: a vector of edge colors; and \code{col.node}: a vector of node colors.}
+ \item{nsteps}{for \code{project.phylomorphospace} the number of frames in the animation between the phylogeny & the phylomorphospace or \emph{vice versa}.}
+ \item{sleep}{for \code{project.phylomorphospace} the time between frames.}
+ \item{direction}{for \code{project.phylomorphospace} whether to morph \code{"to"} a phylomorphospace, \code{"from"} a phylomorphospace, or there & back again (\code{"both"}).}
+ \item{...}{optional arguments for plotting, including \code{xlim}, \code{ylim}, \code{xlab}, \code{ylab}, \code{lwd}, \code{colors}, \code{fsize}, and \code{node.by.map}. \code{colors} is only used when there is a mapped discrete character on the tree, in which case \code{control$col.edge} is ignored. \code{fsize} is relative to the default, which is \code{textxy(...,cx=0.75)}. \code{node.by.map} is a logical value (defaults to \code{FALSE} which tells the function whether or not to plot the node colors using the colors of the mapped discrete character. Setting this option to \code{TRUE} will cause \code{control$col.node} to be ignored. \code{node.size} is a vector containing the point size relative to the default (see \code{\link{par}} for plotted internal nodes and tips, respectively. Defaults to \code{node.size=c(1,1.3)}. If only one number is provided it will be recycled. \code{axes} is a logical value indicating whether or not axes should be plotted (see \code{\link{plot.default}}. Finally, \code{add} indicates whether to add the phylmorphospace to the current plot.}
+}
+\description{
+ Project a phylogeny into morphospace.
+}
+\details{
+ This function creates a phylomorphospace plot (a projection of the tree into morphospace) for two characters following Sidlauskas (2008; \emph{Evolution}). It will also plot a discrete character mapped on tree.
+
+ \code{project.phylomorphospace} animates the phylomorphospace projection.
+}
+\value{
+ This function creates a phylomorphospace plot
+}
+\references{
+ Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-90.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+
+ Sidlauskas, B. (2008) Continuous and arrested morphological diversification in sister clades of characiform fishes: A phylomorphospace approach. \emph{Evolution}, \bold{62}, 3135-3156.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\examples{
+## load tree & data from Revell & Collar (2009)
+data(sunfish.tree)
+data(sunfish.data)
+## set colors for mapped discrete character
+cols<-setNames(c("blue","red"),
+ levels(sunfish.data$feeding.mode))
+phylomorphospace(sunfish.tree,sunfish.data[,3:2],
+ colors=cols,bty="l",ftype="off",node.by.map=TRUE,
+ node.size=c(0,1.2),xlab="relative buccal length",
+ ylab="relative gape width")
+title(main="Phylomorphospace of buccal morphology in Centrarchidae",
+ font.main=3)
+}
+\keyword{ancestral states}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{plotting}
+\keyword{continuous character}
diff --git a/man/phylomorphospace3d.Rd b/man/phylomorphospace3d.Rd
index 2698d9d..29e9c82 100644
--- a/man/phylomorphospace3d.Rd
+++ b/man/phylomorphospace3d.Rd
@@ -1,52 +1,52 @@
-\name{phylomorphospace3d}
-\alias{phylomorphospace3d}
-\title{Creates tree-dimensional phylomorphospace plot}
-\usage{
-phylomorphospace3d(tree, X, A=NULL, label=TRUE, control=list(),
- method=c("dynamic","static"), ...)
-}
-\arguments{
- \item{tree}{a phylogenetic tree in \code{"phylo"} format.}
- \item{X}{an \code{n} x 3 matrix of tip values for two characters in \code{n} species.}
- \item{A}{an optional \code{m} x 3 matrix (for \code{m} nodes) of values for two taits at internal nodes in the tree - if not supplied, these values will be estimated using \code{\link{anc.ML}}.}
- \item{label}{logical value indicating whether to print tip labels next to terminal nodes in the plot (presently doesn't do anything, but labels can be dropped using \code{control}).}
- \item{control}{a list containing the following optional control parameters: \code{spin}: a logical value indicating whether to animate the plot when created; \code{axes}: a logical indicating whether to plot the axes; \code{box}: a logical value indicating whether to plot in box; \code{simple.axes}: logical value indicating whether to replace \code{box} and \code{axes} with simpler axes; \code{lwd}: line widths; \code{ftype}: font type ("off" turns off labels altogether); \code{col.edge} a vector of colors of length \code{nrow(tree$edge)}.}
- \item{method}{a string either \code{"dynamic"} for a dynamic (animated) plot created using \pkg{rgl}; or \code{"static"} for a flat 3D plot created using \code{scatterplot3d} and base graphics. The latter has the advantage of being very easy to export in standard format.}
- \item{...}{optional arguments to be passed to \code{scatterplot3d}. Most options not available. \code{angle} is an important option that does work here.}
-}
-\description{
- Creates a phylomorphospace plot in three dimensions.
-}
-\details{
- This function creates a phylomorphospace plot for three characters using the 3D visualization package, \pkg{rgl} (if available) or statically, by simulating 3D on a flat graphical device.
-}
-\value{
- This function creates a three dimensional phylomorphospace plot. The function returns a function from \code{spin3d} (for \code{method="dynamic"}); or a series of functions from \code{\link{scatterplot3d}} (for \code{method="static"}).
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-
- Sidlauskas, B. (2008) Continuous and arrested morphological diversification in sister clades of characiform fishes: A phylomorphospace approach. \emph{Evolution}, \bold{62}, 3135-3156.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\examples{
-data(anoletree)
-data(anole.data)
-anole.pca<-phyl.pca(anoletree,anole.data)
-\dontrun{
-phylomorphospace3d(anoletree,scores(anole.pca)[,1:3],
- control=list(spin=FALSE))}
-par(cex=0.5)
-phylomorphospace3d(anoletree,scores(anole.pca)[,1:3],
- method="static",angle=-30)
-par(cex=1)
-}
-\seealso{
- \code{\link{fancyTree}}, \code{\link{phenogram}}, \code{\link{phylomorphospace}}
-}
-\keyword{ancestral states}
-\keyword{animation}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{plotting}
-\keyword{continuous character}
+\name{phylomorphospace3d}
+\alias{phylomorphospace3d}
+\title{Creates tree-dimensional phylomorphospace plot}
+\usage{
+phylomorphospace3d(tree, X, A=NULL, label=TRUE, control=list(),
+ method=c("dynamic","static"), ...)
+}
+\arguments{
+ \item{tree}{a phylogenetic tree in \code{"phylo"} format.}
+ \item{X}{an \code{n} x 3 matrix of tip values for two characters in \code{n} species.}
+ \item{A}{an optional \code{m} x 3 matrix (for \code{m} nodes) of values for two taits at internal nodes in the tree - if not supplied, these values will be estimated using \code{\link{anc.ML}}.}
+ \item{label}{logical value indicating whether to print tip labels next to terminal nodes in the plot (presently doesn't do anything, but labels can be dropped using \code{control}).}
+ \item{control}{a list containing the following optional control parameters: \code{spin}: a logical value indicating whether to animate the plot when created; \code{axes}: a logical indicating whether to plot the axes; \code{box}: a logical value indicating whether to plot in box; \code{simple.axes}: logical value indicating whether to replace \code{box} and \code{axes} with simpler axes; \code{lwd}: line widths; \code{ftype}: font type ("off" turns off labels altogether); \code{col.edge} a vector of colors of length \code{nrow(tree$edge)}.}
+ \item{method}{a string either \code{"dynamic"} for a dynamic (animated) plot created using \pkg{rgl}; or \code{"static"} for a flat 3D plot created using \code{scatterplot3d} and base graphics. The latter has the advantage of being very easy to export in standard format.}
+ \item{...}{optional arguments to be passed to \code{scatterplot3d}. Most options not available. \code{angle} is an important option that does work here.}
+}
+\description{
+ Creates a phylomorphospace plot in three dimensions.
+}
+\details{
+ This function creates a phylomorphospace plot for three characters using the 3D visualization package, \pkg{rgl} (if available) or statically, by simulating 3D on a flat graphical device.
+}
+\value{
+ This function creates a three dimensional phylomorphospace plot. The function returns a function from \code{spin3d} (for \code{method="dynamic"}); or a series of functions from \code{\link{scatterplot3d}} (for \code{method="static"}).
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+
+ Sidlauskas, B. (2008) Continuous and arrested morphological diversification in sister clades of characiform fishes: A phylomorphospace approach. \emph{Evolution}, \bold{62}, 3135-3156.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\examples{
+data(anoletree)
+data(anole.data)
+anole.pca<-phyl.pca(anoletree,anole.data)
+\dontrun{
+phylomorphospace3d(anoletree,scores(anole.pca)[,1:3],
+ control=list(spin=FALSE))}
+par(cex=0.5)
+phylomorphospace3d(anoletree,scores(anole.pca)[,1:3],
+ method="static",angle=-30)
+par(cex=1)
+}
+\seealso{
+ \code{\link{fancyTree}}, \code{\link{phenogram}}, \code{\link{phylomorphospace}}
+}
+\keyword{ancestral states}
+\keyword{animation}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{plotting}
+\keyword{continuous character}
diff --git a/man/phylosig.Rd b/man/phylosig.Rd
index 604f8a9..94e5f4b 100644
--- a/man/phylosig.Rd
+++ b/man/phylosig.Rd
@@ -1,88 +1,88 @@
-\name{phylosig}
-\alias{phylosig}
-\alias{plot.phylosig}
-\title{Compute phylogenetic signal with two methods}
-\usage{
-phylosig(tree, x, method="K", test=FALSE, nsim=1000, se=NULL, start=NULL,
- control=list())
-\method{plot}{phylosig}(x, ...)
-}
-\arguments{
- \item{tree}{a phylogenetic tree in \code{"phylo"} format.}
- \item{x}{vector containing values for a single continuously distributed trait. In the case of the \code{plot} method, \code{x} is an object of class \code{"phylosig"}.}
- \item{method}{method to compute signal: can be \code{"K"} or \code{"lambda"}.}
- \item{test}{logical indicating whether or not to conduct a hypothesis test of \code{"K"} or \code{"lambda"}.}
- \item{nsim}{for \code{method="K"}, number of simulations in randomization test.}
- \item{se}{named vector containing the standard errors for each species.}
- \item{start}{vector of starting values for optimization of (respectively) \eqn{\sigma^2} and \eqn{\lambda}. Only used in \code{method="lambda"} and \code{se!=NULL}.}
- \item{control}{list of control parameters for multidimensional optimization, implemented in \code{\link{optim}}. Only used in \code{method="lambda"} and \code{se!=NULL}.}
- \item{...}{optional arguments for \code{plot} method.}
-}
-\description{
- Calculate phylogenetic signal using two different methods (Pagel, 1999; Blomberg et al., 2003).
-}
-\details{
- This function computes phylogenetic signal using two different methods. It can also conduct the hypothesis tests for significant phylogenetic signal, and estimate phylogenetic signal incorporating sampling error following Ives et al. (2007).
-
- \eqn{\lambda} optimization is performed using \code{\link{optimize}} with the range of \eqn{\lambda} set between 0 and the theoretical upper limit of \eqn{\lambda} (determined by the relative height of the most recent internal node on the tree).
-
- \code{plot.phylosig} creates either a plot of the null distribution of \emph{K} or a likelihood surface, depending on the value of \code{method}.
-}
-\value{
- The function returns an object of class \code{"phylosig"}. With default arguments (\code{method="K"}, \code{test=FALSE}, and \code{se=NULL}), this will be a single numeric value. Otherwise, if \code{(method="K")}, it will consist of a list with up to the following elements:
- \item{K}{value of the K-statistic.}
- \item{sig2}{rate of evolution, \eqn{\sigma^2}, for estimation with sampling error.}
- \item{logL}{log-likelihood, for estimation with sampling error.}
- \item{P}{optionally, the P-value from the randomization test.}
- If \code{(method="lambda")}, it will be a list with up to the following elements:
- \item{lambda}{fitted value of \eqn{\lambda}.}
- \item{sig2}{rate of evolution, \eqn{\sigma^2}, for estimation with sampling error.}
- \item{logL}{log-likelihood.}
- \item{logL0}{log-likelihood for \eqn{\lambda=0}.}
- \item{P}{P-value of the likelihood ratio test.}
- \item{convergence}{value for convergence, for estimation with sampling error only. (See \code{\link{optim}}).}
- \item{message}{message from \code{\link{optim}}, for estimation with sampling error only.}
-}
-\references{
- Blomberg, S. P., T. Garland Jr., A. R. Ives (2003) Testing for phylogenetic signal in comparative data: Behavioral traits are more labile. \emph{Evolution}, \bold{57}, 717-745.
-
- Ives, A. R., P. E. Midford, T. Garland Jr. (2007) Within-species variation and measurement error in phylogenetic comparative biology. \emph{Systematic Biology}, \bold{56}, 252-270.
-
- Pagel, M. (1999) Inferring the historical patterns of biological evolution. \emph{Nature}, \bold{401}, 877-884.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\examples{
-## load data from Garland et al. (1992)
-data(mammal.tree)
-data(mammal.data)
-## extract characters of interest
-ln.bodyMass<-log(setNames(mammal.data$bodyMass,
- rownames(mammal.data)))
-ln.homeRange<-log(setNames(mammal.data$homeRange,
- rownames(mammal.data)))
-## compute phylogenetic signal K
-K.bodyMass<-phylosig(mammal.tree,ln.bodyMass,
- test=TRUE)
-print(K.bodyMass)
-plot(K.bodyMass)
-K.homeRange<-phylosig(mammal.tree,ln.homeRange,
- test=TRUE)
-print(K.homeRange)
-plot(K.homeRange)
-## compute phylogenetic signal lambda
-lambda.bodyMass<-phylosig(mammal.tree,ln.bodyMass,
- method="lambda",test=TRUE)
-print(lambda.bodyMass)
-plot(lambda.bodyMass)
-lambda.homeRange<-phylosig(mammal.tree,ln.homeRange,
- method="lambda",test=TRUE)
-print(lambda.homeRange)
-plot(lambda.homeRange)
-}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{maximum likelihood}
-\keyword{simulation}
-\keyword{continuous character}
+\name{phylosig}
+\alias{phylosig}
+\alias{plot.phylosig}
+\title{Compute phylogenetic signal with two methods}
+\usage{
+phylosig(tree, x, method="K", test=FALSE, nsim=1000, se=NULL, start=NULL,
+ control=list())
+\method{plot}{phylosig}(x, ...)
+}
+\arguments{
+ \item{tree}{a phylogenetic tree in \code{"phylo"} format.}
+ \item{x}{vector containing values for a single continuously distributed trait. In the case of the \code{plot} method, \code{x} is an object of class \code{"phylosig"}.}
+ \item{method}{method to compute signal: can be \code{"K"} or \code{"lambda"}.}
+ \item{test}{logical indicating whether or not to conduct a hypothesis test of \code{"K"} or \code{"lambda"}.}
+ \item{nsim}{for \code{method="K"}, number of simulations in randomization test.}
+ \item{se}{named vector containing the standard errors for each species.}
+ \item{start}{vector of starting values for optimization of (respectively) \eqn{\sigma^2} and \eqn{\lambda}. Only used in \code{method="lambda"} and \code{se!=NULL}.}
+ \item{control}{list of control parameters for multidimensional optimization, implemented in \code{\link{optim}}. Only used in \code{method="lambda"} and \code{se!=NULL}.}
+ \item{...}{optional arguments for \code{plot} method.}
+}
+\description{
+ Calculate phylogenetic signal using two different methods (Pagel, 1999; Blomberg et al., 2003).
+}
+\details{
+ This function computes phylogenetic signal using two different methods. It can also conduct the hypothesis tests for significant phylogenetic signal, and estimate phylogenetic signal incorporating sampling error following Ives et al. (2007).
+
+ \eqn{\lambda} optimization is performed using \code{\link{optimize}} with the range of \eqn{\lambda} set between 0 and the theoretical upper limit of \eqn{\lambda} (determined by the relative height of the most recent internal node on the tree).
+
+ \code{plot.phylosig} creates either a plot of the null distribution of \emph{K} or a likelihood surface, depending on the value of \code{method}.
+}
+\value{
+ The function returns an object of class \code{"phylosig"}. With default arguments (\code{method="K"}, \code{test=FALSE}, and \code{se=NULL}), this will be a single numeric value. Otherwise, if \code{(method="K")}, it will consist of a list with up to the following elements:
+ \item{K}{value of the K-statistic.}
+ \item{sig2}{rate of evolution, \eqn{\sigma^2}, for estimation with sampling error.}
+ \item{logL}{log-likelihood, for estimation with sampling error.}
+ \item{P}{optionally, the P-value from the randomization test.}
+ If \code{(method="lambda")}, it will be a list with up to the following elements:
+ \item{lambda}{fitted value of \eqn{\lambda}.}
+ \item{sig2}{rate of evolution, \eqn{\sigma^2}, for estimation with sampling error.}
+ \item{logL}{log-likelihood.}
+ \item{logL0}{log-likelihood for \eqn{\lambda=0}.}
+ \item{P}{P-value of the likelihood ratio test.}
+ \item{convergence}{value for convergence, for estimation with sampling error only. (See \code{\link{optim}}).}
+ \item{message}{message from \code{\link{optim}}, for estimation with sampling error only.}
+}
+\references{
+ Blomberg, S. P., T. Garland Jr., A. R. Ives (2003) Testing for phylogenetic signal in comparative data: Behavioral traits are more labile. \emph{Evolution}, \bold{57}, 717-745.
+
+ Ives, A. R., P. E. Midford, T. Garland Jr. (2007) Within-species variation and measurement error in phylogenetic comparative biology. \emph{Systematic Biology}, \bold{56}, 252-270.
+
+ Pagel, M. (1999) Inferring the historical patterns of biological evolution. \emph{Nature}, \bold{401}, 877-884.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\examples{
+## load data from Garland et al. (1992)
+data(mammal.tree)
+data(mammal.data)
+## extract characters of interest
+ln.bodyMass<-log(setNames(mammal.data$bodyMass,
+ rownames(mammal.data)))
+ln.homeRange<-log(setNames(mammal.data$homeRange,
+ rownames(mammal.data)))
+## compute phylogenetic signal K
+K.bodyMass<-phylosig(mammal.tree,ln.bodyMass,
+ test=TRUE)
+print(K.bodyMass)
+plot(K.bodyMass)
+K.homeRange<-phylosig(mammal.tree,ln.homeRange,
+ test=TRUE)
+print(K.homeRange)
+plot(K.homeRange)
+## compute phylogenetic signal lambda
+lambda.bodyMass<-phylosig(mammal.tree,ln.bodyMass,
+ method="lambda",test=TRUE)
+print(lambda.bodyMass)
+plot(lambda.bodyMass)
+lambda.homeRange<-phylosig(mammal.tree,ln.homeRange,
+ method="lambda",test=TRUE)
+print(lambda.homeRange)
+plot(lambda.homeRange)
+}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{maximum likelihood}
+\keyword{simulation}
+\keyword{continuous character}
diff --git a/man/plot.backbonePhylo.Rd b/man/plot.backbonePhylo.Rd
index 1ccdcba..aae0f83 100644
--- a/man/plot.backbonePhylo.Rd
+++ b/man/plot.backbonePhylo.Rd
@@ -1,49 +1,49 @@
-\name{plot.backbonePhylo}
-\alias{plot.backbonePhylo}
-\title{Plots backbone tree with triangles as clades}
-\usage{
-\method{plot}{backbonePhylo}(x, ...)
-}
-\arguments{
- \item{x}{an object of class \code{"backbonePhylo"}.}
- \item{...}{optional arguments. Includes \code{vscale} (to rescale the vertical dimension in plotting), \code{fixed.height} (logical value to fix the plotted height of subtree triangles), \code{print.clade.size} (logical), \code{fixed.n1} (logical value indicating whether or not to use the fixed triangle height for subtrees containing only one taxon, or to plot as a leaf - defaults to \code{FALSE}), and \code{col} (a single value, or a vector with names, giving the clade colors), as well as \code{xlim}, \code{ylim}, and \code{lwd} (as well as perhaps other standard plotting arguments).}
-}
-\description{
- Plots a backbone tree (stored as an object of class \code{"backbonePhylo"}) with triangles as subtrees.
-}
-\value{
- Plots a tree.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{phylo.toBackbone}}
-}
-\examples{
-## first create our backbone tree with
-## random subtree diversities
-tree<-phytools:::lambdaTree(pbtree(n=10),lambda=0.5)
-## create a translation table
-## leaving a couple of single-taxon clades for fun
-tip.label<-sample(tree$tip.label,8)
-clade.label<-LETTERS[1:8]
-N<-ceiling(runif(n=8,min=1,max=20))
-## set crown node depth to 1/2 the maximum depth
-depth<-sapply(tip.label,function(x,y)
- 0.5*y$edge.length[which(tree$edge[,2]==
- which(y$tip.label==x))],y=tree)
-trans<-data.frame(tip.label,clade.label,N,depth)
-rownames(trans)<-NULL
-## here's what trans looks like
-print(trans)
-## convert
-obj<-phylo.toBackbone(tree,trans)
-## plot
-plot(obj)
-par(mar=c(5.1,4.1,4.1,2.1)) ## reset par
-}
-\keyword{phylogenetics}
-\keyword{plotting}
-
+\name{plot.backbonePhylo}
+\alias{plot.backbonePhylo}
+\title{Plots backbone tree with triangles as clades}
+\usage{
+\method{plot}{backbonePhylo}(x, ...)
+}
+\arguments{
+ \item{x}{an object of class \code{"backbonePhylo"}.}
+ \item{...}{optional arguments. Includes \code{vscale} (to rescale the vertical dimension in plotting), \code{fixed.height} (logical value to fix the plotted height of subtree triangles), \code{print.clade.size} (logical), \code{fixed.n1} (logical value indicating whether or not to use the fixed triangle height for subtrees containing only one taxon, or to plot as a leaf - defaults to \code{FALSE}), and \code{col} (a single value, or a vector with names, giving the clade colors), as well as \code{xlim}, \code{ylim}, and \code{lwd} (as well as perhaps other standard plotting arguments).}
+}
+\description{
+ Plots a backbone tree (stored as an object of class \code{"backbonePhylo"}) with triangles as subtrees.
+}
+\value{
+ Plots a tree.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{phylo.toBackbone}}
+}
+\examples{
+## first create our backbone tree with
+## random subtree diversities
+tree<-phytools:::lambdaTree(pbtree(n=10),lambda=0.5)
+## create a translation table
+## leaving a couple of single-taxon clades for fun
+tip.label<-sample(tree$tip.label,8)
+clade.label<-LETTERS[1:8]
+N<-ceiling(runif(n=8,min=1,max=20))
+## set crown node depth to 1/2 the maximum depth
+depth<-sapply(tip.label,function(x,y)
+ 0.5*y$edge.length[which(tree$edge[,2]==
+ which(y$tip.label==x))],y=tree)
+trans<-data.frame(tip.label,clade.label,N,depth)
+rownames(trans)<-NULL
+## here's what trans looks like
+print(trans)
+## convert
+obj<-phylo.toBackbone(tree,trans)
+## plot
+plot(obj)
+par(mar=c(5.1,4.1,4.1,2.1)) ## reset par
+}
+\keyword{phylogenetics}
+\keyword{plotting}
+
diff --git a/man/plotBranchbyTrait.Rd b/man/plotBranchbyTrait.Rd
index 47abd3c..bd52c3e 100644
--- a/man/plotBranchbyTrait.Rd
+++ b/man/plotBranchbyTrait.Rd
@@ -1,36 +1,36 @@
-\name{plotBranchbyTrait}
-\alias{plotBranchbyTrait}
-\title{Plot branch colors by a quantitative trait or value}
-\usage{
-plotBranchbyTrait(tree, x, mode=c("edges","tips","nodes"), palette="rainbow",
- legend=TRUE, xlims=NULL, ...)
-}
-\arguments{
- \item{tree}{an object of class "phylo".}
- \item{x}{either a vector of states for the edges, tips, or nodes of the tree (for \code{mode="edges"}, \code{"tips"}, and \code{"nodes"}, respectively).}
- \item{mode}{string indicating plotting mode. \code{mode="edges"}, the default, requires that the mapping state of each edge in the tree should be provided. \code{mode="tips"} takes the tip values and estimates the state at each internal node. The mapped character value along each branch is the average of the nodes subtending that branch. \code{mode="nodes"} similar to \code{"tips"}, except that the node values are provided instead of estimated.}
- \item{palette}{color palette to translate character values to color. Options are presently \code{"rainbow"} (the default), \code{"heat.colors"}, and \code{"gray"}. \code{palette} can also be a function produced by \code{\link{colorRampPalette}}.}
- \item{legend}{can be a logical value (\code{TRUE} or \code{FALSE}) or a numeric value greater than 0. In the latter case the numeric value gives the length of the plotted legend, which also acts as a scale bar for the branch lengths of the tree.}
- \item{xlims}{range for the translation map between trait values and the color map. Should be inclusive of all the values in \code{x}.}
- \item{...}{other optional arguments to be passed to \code{\link{plot.phylo}} - pretty much all arguments are available. In addition, there \code{plotBranchbyTrait} has the following additional optional arguments: \code{tol} a small tolerance value to be added to the range of \code{x}; \code{prompt} for \code{legend=TRUE}, a logical value indicating whether to prompt for the position of the legend (or not) - the default is to put the legend in the lower left hand size of the plot; \code{title} for \code{legend=TRUE}, the title of the legend; and \code{digits} for \code{legend=TRUE}, the number of digits in the quantitative scale of the legend. Finally, \code{cex} can be supplied as either a single numeric value, or as a vector of two different values. If the latter is true than the second element of \code{cex} will be passed internally to the function \code{\link{add.color.bar}}.}
-}
-\description{
- Function plots a tree with branches colored by the value for a quantitative trait or probability, by various methods.
-}
-\details{
- Unlike most other tree plotting functions in \pkg{phytools}, this function calls \code{\link{plot.phylo}} (not \code{plotSimmap}) internally.
-
- Note that if \code{prompt=TRUE}, the function will prompt for the position of the legend.
-}
-\value{
- Plots a phylogeny.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{ancestral states}
-\keyword{phylogenetics}
-\keyword{plotting}
-\keyword{comparative method}
-\keyword{continuous character}
+\name{plotBranchbyTrait}
+\alias{plotBranchbyTrait}
+\title{Plot branch colors by a quantitative trait or value}
+\usage{
+plotBranchbyTrait(tree, x, mode=c("edges","tips","nodes"), palette="rainbow",
+ legend=TRUE, xlims=NULL, ...)
+}
+\arguments{
+ \item{tree}{an object of class "phylo".}
+ \item{x}{either a vector of states for the edges, tips, or nodes of the tree (for \code{mode="edges"}, \code{"tips"}, and \code{"nodes"}, respectively).}
+ \item{mode}{string indicating plotting mode. \code{mode="edges"}, the default, requires that the mapping state of each edge in the tree should be provided. \code{mode="tips"} takes the tip values and estimates the state at each internal node. The mapped character value along each branch is the average of the nodes subtending that branch. \code{mode="nodes"} similar to \code{"tips"}, except that the node values are provided instead of estimated.}
+ \item{palette}{color palette to translate character values to color. Options are presently \code{"rainbow"} (the default), \code{"heat.colors"}, and \code{"gray"}. \code{palette} can also be a function produced by \code{\link{colorRampPalette}}.}
+ \item{legend}{can be a logical value (\code{TRUE} or \code{FALSE}) or a numeric value greater than 0. In the latter case the numeric value gives the length of the plotted legend, which also acts as a scale bar for the branch lengths of the tree.}
+ \item{xlims}{range for the translation map between trait values and the color map. Should be inclusive of all the values in \code{x}.}
+ \item{...}{other optional arguments to be passed to \code{\link{plot.phylo}} - pretty much all arguments are available. In addition, there \code{plotBranchbyTrait} has the following additional optional arguments: \code{tol} a small tolerance value to be added to the range of \code{x}; \code{prompt} for \code{legend=TRUE}, a logical value indicating whether to prompt for the position of the legend (or not) - the default is to put the legend in the lower left hand size of the plot; \code{title} for \code{legend=TRUE}, the title of the legend; and \code{digits} for \code{legend=TRUE}, the number of digits in the quantitative scale of the legend. Finally, \code{cex} can be supplied as either a single numeric value, or as a vector of two different values. If the latter is true than the second element of \code{cex} will be passed internally to the function \code{\link{add.color.bar}}.}
+}
+\description{
+ Function plots a tree with branches colored by the value for a quantitative trait or probability, by various methods.
+}
+\details{
+ Unlike most other tree plotting functions in \pkg{phytools}, this function calls \code{\link{plot.phylo}} (not \code{plotSimmap}) internally.
+
+ Note that if \code{prompt=TRUE}, the function will prompt for the position of the legend.
+}
+\value{
+ Plots a phylogeny.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{ancestral states}
+\keyword{phylogenetics}
+\keyword{plotting}
+\keyword{comparative method}
+\keyword{continuous character}
diff --git a/man/plotSimmap.Rd b/man/plotSimmap.Rd
index 0c17162..81f6553 100644
--- a/man/plotSimmap.Rd
+++ b/man/plotSimmap.Rd
@@ -1,83 +1,83 @@
-\name{plotSimmap}
-\alias{plotSimmap}
-\alias{plot.simmap}
-\alias{plot.multiSimmap}
-\title{Plot stochastic character mapped tree}
-\usage{
-plotSimmap(tree, colors=NULL, fsize=1.0, ftype="reg", lwd=2, pts=FALSE,
- node.numbers=FALSE, mar=NULL, add=FALSE, offset=NULL,
- direction="rightwards", type="phylogram", setEnv=TRUE, part=1.0,
- xlim=NULL, ylim=NULL, nodes="intermediate", tips=NULL, maxY=NULL,
- hold=TRUE, split.vertical=FALSE, lend=2, asp=NA, outline=FALSE,
- plot=TRUE, underscore=FALSE)
-\method{plot}{simmap}(x, ...)
-\method{plot}{multiSimmap}(x, ...)
-}
-\arguments{
- \item{tree}{a modified object of class "phylo" or "multiPhylo" containing a stochastic mapping or set of mappings (e.g., see \code{\link{read.simmap}} & \code{\link{make.simmap}}).}
- \item{colors}{a vector with names translating the mapped states to colors - see \code{Examples}.}
- \item{fsize}{relative font size for tip labels.}
- \item{ftype}{font type - options are \code{"reg"}, \code{"i"} (italics), \code{"b"} (bold), or \code{"bi"} (bold-italics).}
- \item{lwd}{line width for plotting.}
- \item{pts}{logical value indicating whether or not to plot filled circles at each vertex of the tree, as well as at transition points between mapped states. Default is \code{FALSE}.}
- \item{node.numbers}{a logical value indicating whether or not node numbers should be plotted.}
- \item{mar}{vector containing the margins for the plot to be passed to \code{\link{par}}. If not specified, the default margins are [0.1,0.1,0.1,0.1].}
- \item{add}{a logical value indicating whether or not to add the plotted tree to the current plot (\code{TRUE}) or create a new plot (\code{FALSE}, the default).}
- \item{offset}{offset for the tip labels in character widths.}
- \item{direction}{plotting direction. Options are \code{"rightwards"} (the default), \code{"leftwards"}, \code{"upwards"} or \code{"downwards"}. For \code{method="fan"} \code{direction} is ignored.}
- \item{type}{plot type. Can be \code{"phylogram"}, \code{"fan"}, or \code{"cladogram"}. Only a subset of options are presently available for \code{type="fan"}.}
- \item{setEnv}{logical value indicating whether or not to set the environment \code{.PlotPhyloEnv}. Setting this to \code{TRUE} (the default) will allow compatibility with \pkg{ape} labeling functions such as \code{\link{nodelabels}}.}
- \item{part}{value between 0 and 1 for \code{type="fan"} indicating what fraction of the full circular tree to use as plotting area. For instance, \code{part=0.5} will plot a half fan phylogeny. It also affects the axis scaling used.}
- \item{xlim}{x-limits for the plot.}
- \item{ylim}{y-limits for the plot.}
- \item{nodes}{node placement following Felsenstein (2004; pp. 574-576). Can be \code{"intermediate"}, \code{"centered"}, \code{"weighted"}, or \code{"inner"}. So far only works for \code{type="phylogram"}.}
- \item{tips}{labeled vector containing the vertical position of tips. Normally this will be \code{1:N} for \code{N} tips in the tree.}
- \item{maxY}{maximum value of y to use before rotating a tree into fan configuration. This will only make a difference if different from \code{Ntip(tree)}.}
- \item{hold}{logical argument indicating whether or not to hold the output to the graphical device before plotting. Defaults to \code{hold=TRUE}.}
- \item{split.vertical}{split the color of the vertically plotted edges by the state of the daughter edges. Only applies if the edge state changes exactly at a node.}
- \item{lend}{line end style. See \code{\link{par}}.}
- \item{asp}{aspect ratio. See \code{\link{plot.window}}.}
- \item{outline}{logical value indicating whether or not to draw a black outline around the plotted edges of the tree.}
- \item{plot}{logical value indicating whether or not to actually plot the tree. (See equivalent argument in \code{\link{plot.phylo}}.)}
- \item{underscore}{logical value indicating whether to plot the underscore character, \code{"_"} (if \code{underscore=TRUE}) or substitute for a space. Defaults to \code{underscore=FALSE}.}
- \item{x}{for S3 plotting method, object of class \code{"simmap"} or \code{"multiSimmap"}.}
- \item{...}{for S3 plotting method, other arguments to be passed to \code{\link{plotSimmap}}.}
-}
-\description{
- Plots one or multiple stochastic character mapped trees.
-}
-\value{
- Plots a tree.
-}
-\references{
- Bollback, J. P. (2006) Stochastic character mapping of discrete traits on phylogenies. \emph{BMC Bioinformatics}, \bold{7}, 88.
-
- Felsenstein, J. (2004) \emph{Inferring Phylogenies}. Sinauer.
-
- Huelsenbeck, J. P., R. Neilsen, and J. P. Bollback. (2003) Stochastic mapping of morphological characters. \emph{Systematic Biology}, \bold{52}, 131-138.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{densityMap}}, \code{\link{make.simmap}}, \code{\link{read.simmap}}
-}
-\examples{
-data(anoletree)
-cols<-setNames(c("green","#E4D96F","darkgreen",
- "brown","black","darkgrey"),
- c("CG","GB","TC","TG","Tr","Tw"))
-plot(anoletree,cols,fsize=0.5,ftype="i",outline=TRUE,
- lwd=3,ylim=c(0,Ntip(anoletree)),
- mar=c(0.1,0.1,1.1,0.1))
-add.simmap.legend(colors=cols,prompt=FALSE,x=0,y=-0.5,
- vertical=FALSE)
-title(main="Caribbean ecomorphs of anoles",font.main=3,
- line=0)
-par(mar=c(5.1,4.1,4.1,2.1)) ## reset margins to default
-}
-\keyword{ancestral states}
-\keyword{phylogenetics}
-\keyword{plotting}
-\keyword{comparative method}
-\keyword{discrete character}
+\name{plotSimmap}
+\alias{plotSimmap}
+\alias{plot.simmap}
+\alias{plot.multiSimmap}
+\title{Plot stochastic character mapped tree}
+\usage{
+plotSimmap(tree, colors=NULL, fsize=1.0, ftype="reg", lwd=2, pts=FALSE,
+ node.numbers=FALSE, mar=NULL, add=FALSE, offset=NULL,
+ direction="rightwards", type="phylogram", setEnv=TRUE, part=1.0,
+ xlim=NULL, ylim=NULL, nodes="intermediate", tips=NULL, maxY=NULL,
+ hold=TRUE, split.vertical=FALSE, lend=2, asp=NA, outline=FALSE,
+ plot=TRUE, underscore=FALSE)
+\method{plot}{simmap}(x, ...)
+\method{plot}{multiSimmap}(x, ...)
+}
+\arguments{
+ \item{tree}{a modified object of class "phylo" or "multiPhylo" containing a stochastic mapping or set of mappings (e.g., see \code{\link{read.simmap}} & \code{\link{make.simmap}}).}
+ \item{colors}{a vector with names translating the mapped states to colors - see \code{Examples}.}
+ \item{fsize}{relative font size for tip labels.}
+ \item{ftype}{font type - options are \code{"reg"}, \code{"i"} (italics), \code{"b"} (bold), or \code{"bi"} (bold-italics).}
+ \item{lwd}{line width for plotting.}
+ \item{pts}{logical value indicating whether or not to plot filled circles at each vertex of the tree, as well as at transition points between mapped states. Default is \code{FALSE}.}
+ \item{node.numbers}{a logical value indicating whether or not node numbers should be plotted.}
+ \item{mar}{vector containing the margins for the plot to be passed to \code{\link{par}}. If not specified, the default margins are [0.1,0.1,0.1,0.1].}
+ \item{add}{a logical value indicating whether or not to add the plotted tree to the current plot (\code{TRUE}) or create a new plot (\code{FALSE}, the default).}
+ \item{offset}{offset for the tip labels in character widths.}
+ \item{direction}{plotting direction. Options are \code{"rightwards"} (the default), \code{"leftwards"}, \code{"upwards"} or \code{"downwards"}. For \code{method="fan"} \code{direction} is ignored.}
+ \item{type}{plot type. Can be \code{"phylogram"}, \code{"fan"}, or \code{"cladogram"}. Only a subset of options are presently available for \code{type="fan"}.}
+ \item{setEnv}{logical value indicating whether or not to set the environment \code{.PlotPhyloEnv}. Setting this to \code{TRUE} (the default) will allow compatibility with \pkg{ape} labeling functions such as \code{\link{nodelabels}}.}
+ \item{part}{value between 0 and 1 for \code{type="fan"} indicating what fraction of the full circular tree to use as plotting area. For instance, \code{part=0.5} will plot a half fan phylogeny. It also affects the axis scaling used.}
+ \item{xlim}{x-limits for the plot.}
+ \item{ylim}{y-limits for the plot.}
+ \item{nodes}{node placement following Felsenstein (2004; pp. 574-576). Can be \code{"intermediate"}, \code{"centered"}, \code{"weighted"}, or \code{"inner"}. So far only works for \code{type="phylogram"}.}
+ \item{tips}{labeled vector containing the vertical position of tips. Normally this will be \code{1:N} for \code{N} tips in the tree.}
+ \item{maxY}{maximum value of y to use before rotating a tree into fan configuration. This will only make a difference if different from \code{Ntip(tree)}.}
+ \item{hold}{logical argument indicating whether or not to hold the output to the graphical device before plotting. Defaults to \code{hold=TRUE}.}
+ \item{split.vertical}{split the color of the vertically plotted edges by the state of the daughter edges. Only applies if the edge state changes exactly at a node.}
+ \item{lend}{line end style. See \code{\link{par}}.}
+ \item{asp}{aspect ratio. See \code{\link{plot.window}}.}
+ \item{outline}{logical value indicating whether or not to draw a black outline around the plotted edges of the tree.}
+ \item{plot}{logical value indicating whether or not to actually plot the tree. (See equivalent argument in \code{\link{plot.phylo}}.)}
+ \item{underscore}{logical value indicating whether to plot the underscore character, \code{"_"} (if \code{underscore=TRUE}) or substitute for a space. Defaults to \code{underscore=FALSE}.}
+ \item{x}{for S3 plotting method, object of class \code{"simmap"} or \code{"multiSimmap"}.}
+ \item{...}{for S3 plotting method, other arguments to be passed to \code{\link{plotSimmap}}.}
+}
+\description{
+ Plots one or multiple stochastic character mapped trees.
+}
+\value{
+ Plots a tree.
+}
+\references{
+ Bollback, J. P. (2006) Stochastic character mapping of discrete traits on phylogenies. \emph{BMC Bioinformatics}, \bold{7}, 88.
+
+ Felsenstein, J. (2004) \emph{Inferring Phylogenies}. Sinauer.
+
+ Huelsenbeck, J. P., R. Neilsen, and J. P. Bollback. (2003) Stochastic mapping of morphological characters. \emph{Systematic Biology}, \bold{52}, 131-138.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{densityMap}}, \code{\link{make.simmap}}, \code{\link{read.simmap}}
+}
+\examples{
+data(anoletree)
+cols<-setNames(c("green","#E4D96F","darkgreen",
+ "brown","black","darkgrey"),
+ c("CG","GB","TC","TG","Tr","Tw"))
+plot(anoletree,cols,fsize=0.5,ftype="i",outline=TRUE,
+ lwd=3,ylim=c(0,Ntip(anoletree)),
+ mar=c(0.1,0.1,1.1,0.1))
+add.simmap.legend(colors=cols,prompt=FALSE,x=0,y=-0.5,
+ vertical=FALSE)
+title(main="Caribbean ecomorphs of anoles",font.main=3,
+ line=0)
+par(mar=c(5.1,4.1,4.1,2.1)) ## reset margins to default
+}
+\keyword{ancestral states}
+\keyword{phylogenetics}
+\keyword{plotting}
+\keyword{comparative method}
+\keyword{discrete character}
diff --git a/man/plotThresh.Rd b/man/plotThresh.Rd
index b9d02fe..683741d 100644
--- a/man/plotThresh.Rd
+++ b/man/plotThresh.Rd
@@ -1,42 +1,42 @@
-\name{plotThresh}
-\alias{plotThresh}
-\title{Tree plotting with posterior probabilities of ancestral states from the threshold model}
-\usage{
-plotThresh(tree, x, mcmc, burnin=NULL, piecol, tipcol="input", legend=TRUE,
- ...)
-}
-\arguments{
- \item{tree}{phylogenetic tree.}
- \item{x}{a named vector containing discrete character states; or a matrix containing the tip species, in rows, and probabilities of being in each state, in columns.}
- \item{mcmc}{list object returned by \code{\link{ancThresh}}.}
- \item{burnin}{number of generations (not samples) to exclude as burn in; if \code{NULL} then 20\% of generations are excluded as burn-in.}
- \item{piecol}{a named vector containing the colors for the posterior probabilities plotted as pie charts at internal nodes.}
- \item{tipcol}{a string indicating whether the tip colors should be based on the input data (\code{"input"}) or sampled tip liabilities (\code{"estimated"}). These will only differ if there is uncertainty in the tip states.}
- \item{legend}{logical value or text to be plotted in the legend.}
- \item{...}{other arguments to be passed to \code{\link{plot.phylo}} - \code{label.offset} should be >0 so that tip labels and species names do not overlap.}
-}
-\description{
- Plots estimated posterior probabilities at nodes under the threshold model.
-}
-\details{
- This function uses the object returned by \code{\link{ancThresh}} to plot the posterior probabilities of ancestral states under the threshold model.
-
- It is also called internally by \code{\link{ancThresh}}.
-}
-\value{
- Plots a tree.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-
- Revell, L. J. (2014) Ancestral character estimation under the threshold model from quantitative genetics. \emph{Evolution}, bold{68}, 743-759.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{ancThresh}}, \code{\link{plot.phylo}}
-}
-\keyword{ancestral states}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{bayesian}
-\keyword{discrete character}
+\name{plotThresh}
+\alias{plotThresh}
+\title{Tree plotting with posterior probabilities of ancestral states from the threshold model}
+\usage{
+plotThresh(tree, x, mcmc, burnin=NULL, piecol, tipcol="input", legend=TRUE,
+ ...)
+}
+\arguments{
+ \item{tree}{phylogenetic tree.}
+ \item{x}{a named vector containing discrete character states; or a matrix containing the tip species, in rows, and probabilities of being in each state, in columns.}
+ \item{mcmc}{list object returned by \code{\link{ancThresh}}.}
+ \item{burnin}{number of generations (not samples) to exclude as burn in; if \code{NULL} then 20\% of generations are excluded as burn-in.}
+ \item{piecol}{a named vector containing the colors for the posterior probabilities plotted as pie charts at internal nodes.}
+ \item{tipcol}{a string indicating whether the tip colors should be based on the input data (\code{"input"}) or sampled tip liabilities (\code{"estimated"}). These will only differ if there is uncertainty in the tip states.}
+ \item{legend}{logical value or text to be plotted in the legend.}
+ \item{...}{other arguments to be passed to \code{\link{plot.phylo}} - \code{label.offset} should be >0 so that tip labels and species names do not overlap.}
+}
+\description{
+ Plots estimated posterior probabilities at nodes under the threshold model.
+}
+\details{
+ This function uses the object returned by \code{\link{ancThresh}} to plot the posterior probabilities of ancestral states under the threshold model.
+
+ It is also called internally by \code{\link{ancThresh}}.
+}
+\value{
+ Plots a tree.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+
+ Revell, L. J. (2014) Ancestral character estimation under the threshold model from quantitative genetics. \emph{Evolution}, bold{68}, 743-759.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{ancThresh}}, \code{\link{plot.phylo}}
+}
+\keyword{ancestral states}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{bayesian}
+\keyword{discrete character}
diff --git a/man/plotTree.Rd b/man/plotTree.Rd
index 49c2260..1b0b477 100644
--- a/man/plotTree.Rd
+++ b/man/plotTree.Rd
@@ -1,34 +1,34 @@
-\name{plotTree}
-\alias{plotTree}
-\title{Plots rooted phylogenetic tree}
-\usage{
-plotTree(tree, ...)
-}
-\arguments{
- \item{tree}{a phylogenetic tree in \code{"phylo"} format; or multiple trees as an object of class \code{"multiPhylo"}.}
- \item{...}{optional arguments.}
-}
-\details{
- Plots a rooted phylogram or cladogram.
-}
-\description{
- Essentially a wrapper for \code{\link{plotSimmap}}. Arguments in \code{...} are passed to \code{\link{plotSimmap}}, with the exception of optional argument \code{color} which is used to determine the plotted color of the branch lengths of the tree.
-}
-\value{
- This function plots a rooted phylogram or cladogram.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{plot.phylo}}, \code{\link{plotSimmap}}
-}
-\examples{
-data(vertebrate.tree)
-plotTree(vertebrate.tree,fsize=1.2,ftype="i")
-## reset margins
-par(mar=c(5.1,4.1,4.1,2.1))
-}
-\keyword{phylogenetics}
-\keyword{plotting}
+\name{plotTree}
+\alias{plotTree}
+\title{Plots rooted phylogenetic tree}
+\usage{
+plotTree(tree, ...)
+}
+\arguments{
+ \item{tree}{a phylogenetic tree in \code{"phylo"} format; or multiple trees as an object of class \code{"multiPhylo"}.}
+ \item{...}{optional arguments.}
+}
+\details{
+ Plots a rooted phylogram or cladogram.
+}
+\description{
+ Essentially a wrapper for \code{\link{plotSimmap}}. Arguments in \code{...} are passed to \code{\link{plotSimmap}}, with the exception of optional argument \code{color} which is used to determine the plotted color of the branch lengths of the tree.
+}
+\value{
+ This function plots a rooted phylogram or cladogram.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{plot.phylo}}, \code{\link{plotSimmap}}
+}
+\examples{
+data(vertebrate.tree)
+plotTree(vertebrate.tree,fsize=1.2,ftype="i")
+## reset margins
+par(mar=c(5.1,4.1,4.1,2.1))
+}
+\keyword{phylogenetics}
+\keyword{plotting}
diff --git a/man/plotTree.datamatrix.Rd b/man/plotTree.datamatrix.Rd
index d4382ed..13d54dd 100644
--- a/man/plotTree.datamatrix.Rd
+++ b/man/plotTree.datamatrix.Rd
@@ -1,28 +1,28 @@
-\name{plotTree.datamatrix}
-\alias{plotTree.datamatrix}
-\title{Plot a tree with a discrete character data matrix at the tips}
-\usage{
-plotTree.datamatrix(tree, X, ...)
-}
-\arguments{
- \item{tree}{an object of class \code{"phylo"}.}
- \item{X}{a data frame with columns as factors.}
- \item{...}{optional arguments.}
-}
-\description{
- Plots a phylogeny next to a matrix of discrete character data.
-}
-\value{
- Invisibly returns a list containing the font size, a list of the colors used for each column of the plotted data matrix, and the x-coordinate of the rightmost edge of the matrix.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{dotTree}}, \code{\link{phylo.heatmap}}
-}
-\keyword{phylogenetics}
-\keyword{plotting}
-\keyword{comparative method}
-\keyword{discrete character}
+\name{plotTree.datamatrix}
+\alias{plotTree.datamatrix}
+\title{Plot a tree with a discrete character data matrix at the tips}
+\usage{
+plotTree.datamatrix(tree, X, ...)
+}
+\arguments{
+ \item{tree}{an object of class \code{"phylo"}.}
+ \item{X}{a data frame with columns as factors.}
+ \item{...}{optional arguments.}
+}
+\description{
+ Plots a phylogeny next to a matrix of discrete character data.
+}
+\value{
+ Invisibly returns a list containing the font size, a list of the colors used for each column of the plotted data matrix, and the x-coordinate of the rightmost edge of the matrix.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{dotTree}}, \code{\link{phylo.heatmap}}
+}
+\keyword{phylogenetics}
+\keyword{plotting}
+\keyword{comparative method}
+\keyword{discrete character}
diff --git a/man/plotTree.errorbars.Rd b/man/plotTree.errorbars.Rd
index 926272f..48c053e 100644
--- a/man/plotTree.errorbars.Rd
+++ b/man/plotTree.errorbars.Rd
@@ -1,31 +1,31 @@
-\name{plotTree.errorbars}
-\alias{plotTree.errorbars}
-\title{Plot a tree with error bars around divergence dates}
-\usage{
-plotTree.errorbars(tree, CI, ...)
-}
-\arguments{
- \item{tree}{an object of class \code{"phylo"}.}
- \item{CI}{confidence intervals around internal nodes of the tree, measured in time since the present.}
- \item{...}{optional arguments to be passed to \code{\link{plotTree}}.}
-}
-\description{
- Plots a tree with error bars around divergence times (nodes).
-}
-\details{
- The matrix CI show contain (in rows) the lower & upper confidence bounds in time since the present.
-
- Optional arguments specific to the error bar plot include \code{gridlines}, \code{bar.lwd},\code{cex} (for the points plotted at nodes), and \code{bar.col}.
-}
-\value{
- Plots a tree with error bars around internal nodes..
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{ltt}}, \code{\link{plotTree}}
-}
-\keyword{phylogenetics}
-\keyword{plotting}
+\name{plotTree.errorbars}
+\alias{plotTree.errorbars}
+\title{Plot a tree with error bars around divergence dates}
+\usage{
+plotTree.errorbars(tree, CI, ...)
+}
+\arguments{
+ \item{tree}{an object of class \code{"phylo"}.}
+ \item{CI}{confidence intervals around internal nodes of the tree, measured in time since the present.}
+ \item{...}{optional arguments to be passed to \code{\link{plotTree}}.}
+}
+\description{
+ Plots a tree with error bars around divergence times (nodes).
+}
+\details{
+ The matrix CI show contain (in rows) the lower & upper confidence bounds in time since the present.
+
+ Optional arguments specific to the error bar plot include \code{gridlines}, \code{bar.lwd},\code{cex} (for the points plotted at nodes), and \code{bar.col}.
+}
+\value{
+ Plots a tree with error bars around internal nodes..
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{ltt}}, \code{\link{plotTree}}
+}
+\keyword{phylogenetics}
+\keyword{plotting}
diff --git a/man/plotTree.wBars.Rd b/man/plotTree.wBars.Rd
index 1149393..7b8022b 100644
--- a/man/plotTree.wBars.Rd
+++ b/man/plotTree.wBars.Rd
@@ -1,86 +1,86 @@
-\name{plotTree.wBars}
-\alias{plotTree.wBars}
-\alias{plotTree.barplot}
-\alias{plotTree.boxplot}
-\title{Plot a tree with bars at the tips}
-\usage{
-plotTree.wBars(tree, x, scale=NULL, width=NULL, type="phylogram",
- method="plotTree", tip.labels=FALSE, col="grey", border=NULL,
- ...)
-plotTree.barplot(tree, x, args.plotTree=list(), args.barplot=list(),
- ...)
-plotTree.boxplot(tree, x, args.plotTree=list(), args.boxplot=list(),
- ...)
-}
-\arguments{
- \item{tree}{an object of class \code{"phylo"}.}
- \item{x}{a named vector or matrix of trait values. For \code{plotTree.boxplot}, the names should repeat for multiple observations per species. For \code{plotTree.boxplot} \code{x} can also be supplied as a formula, though in that case the factor levels need to be provided in a valid cladewise order of the tips in \code{tree}. This order doesn't need to correspond with the current order of the tip labels. For \code{plotTree.barplot} \code{x} can be a matrix (or a data frame) in which columns are the values of multiple traits to be simultaneously plotted on the tree.}
- \item{scale}{scaling factor for the tip bars (relative to the total tree height). If left as \code{NULL} a reasonable scaling factor is computed automatically.}
- \item{width}{width of the tip bars.}
- \item{type}{plot type. Can be \code{"phylogram"} or \code{"fan"}.}
- \item{method}{plotting method to use. Can be \code{"plotTree"} (for \code{\link{plotTree}}) or \code{"plotSimmap"} (for \code{\link{plotSimmap}}).}
- \item{tip.labels}{argument indicating whether or not tip labels should be plotted. Defaults to \code{tip.labels=FALSE}.}
- \item{col}{colors of the plotted bars. Can be a single value or a vector with length equal to the number of tips in the tree.}
- \item{border}{single value specifying the color of the border for the plotted bars. Defaults to \code{border=NULL}, which means that black borders will be plotted.}
- \item{args.plotTree}{in \code{plotTree.barplot}, arguments to be passed to \code{\link{plotTree}}.}
- \item{args.barplot}{in \code{plotTree.barplot}, arguments to be passed to \code{\link{barplot}}.}
- \item{args.boxplot}{in \code{plotTree.boxplot}, arguments to be passed to \code{\link{boxplot}}.}
- \item{...}{optional arguments to be passed to \code{\link{plotTree}} or \code{\link{plotSimmap}} in the case of \code{plotTree.wBars}. For \code{plotTree.barplot}, the only optional arguments are \code{add} and \code{ylim}. Generally \code{add} should not be used; however it can be employed to tell the function to draw the tree & barplot, respectively, in the next two open plotting devices - rather than creating a table of figures in the current plotting device. \code{ylim} (which is also an optional argument for \code{plotTree.boxplot} should be supplied here rather than using \code{args.plotTree} or \code{args.boxplot}\\code{args.barplot} because \emph{y} axis limits must match exactly between the two plots.}
-}
-\description{
- Plots a phylogenetic tree with adjacent boxplot or barplot.
-}
-\details{
- \code{plotTree.wbars} plots a phylogeny in phylogram or fan style with bars at the tips representing the values for a phenotypic trait.
-
- \code{plotTree.barplot} creates a split plot in which a right-facing phylogram is on the left, and a bar plot is shown on the right.
-
- \code{plotTree.boxplot} creates a split plot in which a right-facing phylogram is on the left, and a box plot is shown on the right.
-}
-\value{
- Plots a tree with an associated bar plot for a continuously valued character at the tips.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{barplot}}, \code{\link{dotTree}}, \code{\link{plotSimmap}}, \code{\link{plotTree}}
-}
-\examples{
-## load data from Mahler et al. (2010)
-data(anoletree)
-data(anole.data)
-## extract overall body size (SVL)
-svl<-setNames(anole.data$SVL,rownames(anole.data))
-## plotTree.wBars
-plotTree.wBars(anoletree,svl,type="fan",scal=0.5)
-par(mar=c(5.1,4.1,4.1,2.1))
-## plotTree.barplot
-plotTree.barplot(anoletree,exp(svl),
- args.plotTree=list(fsize=0.5),
- args.barplot=list(xlab="SVL (mm)"))
-
-## load vertebrate tree and data
-data(vertebrate.tree)
-data(vertebrate.data)
-## plotTree.barplot
-options(scipen=4) ## change sci-notation
-par(cex.axis=0.8)
-plotTree.barplot(vertebrate.tree,
- setNames(vertebrate.data$Mass,
- rownames(vertebrate.data)),
- args.barplot=list(
- log="x",
- xlab="mass (kg)",
- xlim=c(0.01,500000),
- col=palette()[4]))
-options(scipen=0)
-
-## reset par to defaults
-par(mfrow=c(1,1),mar=c(5.1,4.1,4.1,2.1),cex.axis=1)
-}
-\keyword{phylogenetics}
-\keyword{plotting}
-\keyword{comparative method}
-\keyword{continuous character}
+\name{plotTree.wBars}
+\alias{plotTree.wBars}
+\alias{plotTree.barplot}
+\alias{plotTree.boxplot}
+\title{Plot a tree with bars at the tips}
+\usage{
+plotTree.wBars(tree, x, scale=NULL, width=NULL, type="phylogram",
+ method="plotTree", tip.labels=FALSE, col="grey", border=NULL,
+ ...)
+plotTree.barplot(tree, x, args.plotTree=list(), args.barplot=list(),
+ ...)
+plotTree.boxplot(tree, x, args.plotTree=list(), args.boxplot=list(),
+ ...)
+}
+\arguments{
+ \item{tree}{an object of class \code{"phylo"}.}
+ \item{x}{a named vector or matrix of trait values. For \code{plotTree.boxplot}, the names should repeat for multiple observations per species. For \code{plotTree.boxplot} \code{x} can also be supplied as a formula, though in that case the factor levels need to be provided in a valid cladewise order of the tips in \code{tree}. This order doesn't need to correspond with the current order of the tip labels. For \code{plotTree.barplot} \code{x} can be a matrix (or a data frame) in which columns are the values of multiple traits to be simultaneously plotted on the tree.}
+ \item{scale}{scaling factor for the tip bars (relative to the total tree height). If left as \code{NULL} a reasonable scaling factor is computed automatically.}
+ \item{width}{width of the tip bars.}
+ \item{type}{plot type. Can be \code{"phylogram"} or \code{"fan"}.}
+ \item{method}{plotting method to use. Can be \code{"plotTree"} (for \code{\link{plotTree}}) or \code{"plotSimmap"} (for \code{\link{plotSimmap}}).}
+ \item{tip.labels}{argument indicating whether or not tip labels should be plotted. Defaults to \code{tip.labels=FALSE}.}
+ \item{col}{colors of the plotted bars. Can be a single value or a vector with length equal to the number of tips in the tree.}
+ \item{border}{single value specifying the color of the border for the plotted bars. Defaults to \code{border=NULL}, which means that black borders will be plotted.}
+ \item{args.plotTree}{in \code{plotTree.barplot}, arguments to be passed to \code{\link{plotTree}}.}
+ \item{args.barplot}{in \code{plotTree.barplot}, arguments to be passed to \code{\link{barplot}}.}
+ \item{args.boxplot}{in \code{plotTree.boxplot}, arguments to be passed to \code{\link{boxplot}}.}
+ \item{...}{optional arguments to be passed to \code{\link{plotTree}} or \code{\link{plotSimmap}} in the case of \code{plotTree.wBars}. For \code{plotTree.barplot}, the only optional arguments are \code{add} and \code{ylim}. Generally \code{add} should not be used; however it can be employed to tell the function to draw the tree & barplot, respectively, in the next two open plotting devices - rather than creating a table of figures in the current plotting device. \code{ylim} (which is also an optional argument for \code{plotTree.boxplot} should be supplied here rather than using \code{args.plotTree} or \code{args.boxplot}\\code{args.barplot} because \emph{y} axis limits must match exactly between the two plots.}
+}
+\description{
+ Plots a phylogenetic tree with adjacent boxplot or barplot.
+}
+\details{
+ \code{plotTree.wbars} plots a phylogeny in phylogram or fan style with bars at the tips representing the values for a phenotypic trait.
+
+ \code{plotTree.barplot} creates a split plot in which a right-facing phylogram is on the left, and a bar plot is shown on the right.
+
+ \code{plotTree.boxplot} creates a split plot in which a right-facing phylogram is on the left, and a box plot is shown on the right.
+}
+\value{
+ Plots a tree with an associated bar plot for a continuously valued character at the tips.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{barplot}}, \code{\link{dotTree}}, \code{\link{plotSimmap}}, \code{\link{plotTree}}
+}
+\examples{
+## load data from Mahler et al. (2010)
+data(anoletree)
+data(anole.data)
+## extract overall body size (SVL)
+svl<-setNames(anole.data$SVL,rownames(anole.data))
+## plotTree.wBars
+plotTree.wBars(anoletree,svl,type="fan",scal=0.5)
+par(mar=c(5.1,4.1,4.1,2.1))
+## plotTree.barplot
+plotTree.barplot(anoletree,exp(svl),
+ args.plotTree=list(fsize=0.5),
+ args.barplot=list(xlab="SVL (mm)"))
+
+## load vertebrate tree and data
+data(vertebrate.tree)
+data(vertebrate.data)
+## plotTree.barplot
+options(scipen=4) ## change sci-notation
+par(cex.axis=0.8)
+plotTree.barplot(vertebrate.tree,
+ setNames(vertebrate.data$Mass,
+ rownames(vertebrate.data)),
+ args.barplot=list(
+ log="x",
+ xlab="mass (kg)",
+ xlim=c(0.01,500000),
+ col=palette()[4]))
+options(scipen=0)
+
+## reset par to defaults
+par(mfrow=c(1,1),mar=c(5.1,4.1,4.1,2.1),cex.axis=1)
+}
+\keyword{phylogenetics}
+\keyword{plotting}
+\keyword{comparative method}
+\keyword{continuous character}
diff --git a/man/posterior.evolrate.Rd b/man/posterior.evolrate.Rd
index 4b57b34..09a69f2 100644
--- a/man/posterior.evolrate.Rd
+++ b/man/posterior.evolrate.Rd
@@ -1,33 +1,33 @@
-\name{posterior.evolrate}
-\alias{posterior.evolrate}
-\title{Analysis of the posterior sample from evol.rate.mcmc}
-\usage{
-posterior.evolrate(tree, ave.shift, mcmc, tips, showTree=FALSE)
-}
-\arguments{
- \item{tree}{a phylogenetic tree in \code{"phylo"} format.}
- \item{ave.shift}{mean or median shift-point from the posterior sample (see \code{\link{minSplit}}.}
- \item{mcmc}{matrix \code{$mcmc} from \code{evol.rate.mcmc} (probably with burnin excluded).}
- \item{tips}{list of stips in state \eqn{\sigma_1^2} for each sampled generation of MCMC.}
- \item{showTree}{optional logical value indicating whether or not to plot the stretched and shrunken tree generated by the pre-processing algorithm implemented in this function (default is \code{FALSE}).}
-}
-\description{
- Analyzes posterior sample from \code{\link{evol.rate.mcmc}}.
-}
-\details{
- This function takes a phylogenetic tree, an average split position, and a raw MCMC output from \code{evol.rate.mcmc} and returns a posterior sample of evolutionary rates rootward (\eqn{\sigma_1^2}) and tipward (\eqn{\sigma_2^2}) from the average split.
-}
-\value{
- A matrix containing the posterior sample of evolutionary rates and shift-points between rates.
-}
-\references{
- Revell, L. J., D. L. Mahler, P. Peres-Neto, and B. D. Redelings (2012) A new method for identifying exceptional phenotypic diversification. \emph{Evolution}, \bold{66}, 135-146.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{evol.rate.mcmc}}, \code{\link{minSplit}}
-}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{bayesian}
-\keyword{continuous character}
+\name{posterior.evolrate}
+\alias{posterior.evolrate}
+\title{Analysis of the posterior sample from evol.rate.mcmc}
+\usage{
+posterior.evolrate(tree, ave.shift, mcmc, tips, showTree=FALSE)
+}
+\arguments{
+ \item{tree}{a phylogenetic tree in \code{"phylo"} format.}
+ \item{ave.shift}{mean or median shift-point from the posterior sample (see \code{\link{minSplit}}.}
+ \item{mcmc}{matrix \code{$mcmc} from \code{evol.rate.mcmc} (probably with burnin excluded).}
+ \item{tips}{list of stips in state \eqn{\sigma_1^2} for each sampled generation of MCMC.}
+ \item{showTree}{optional logical value indicating whether or not to plot the stretched and shrunken tree generated by the pre-processing algorithm implemented in this function (default is \code{FALSE}).}
+}
+\description{
+ Analyzes posterior sample from \code{\link{evol.rate.mcmc}}.
+}
+\details{
+ This function takes a phylogenetic tree, an average split position, and a raw MCMC output from \code{evol.rate.mcmc} and returns a posterior sample of evolutionary rates rootward (\eqn{\sigma_1^2}) and tipward (\eqn{\sigma_2^2}) from the average split.
+}
+\value{
+ A matrix containing the posterior sample of evolutionary rates and shift-points between rates.
+}
+\references{
+ Revell, L. J., D. L. Mahler, P. Peres-Neto, and B. D. Redelings (2012) A new method for identifying exceptional phenotypic diversification. \emph{Evolution}, \bold{66}, 135-146.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{evol.rate.mcmc}}, \code{\link{minSplit}}
+}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{bayesian}
+\keyword{continuous character}
diff --git a/man/posthoc.Rd b/man/posthoc.Rd
index 695166a..ec5a7de 100644
--- a/man/posthoc.Rd
+++ b/man/posthoc.Rd
@@ -1,24 +1,24 @@
-\name{posthoc}
-\alias{posthoc}
-\title{Generic post-hoc test}
-\usage{
-posthoc(x, ...)
-}
-\arguments{
- \item{x}{an object on which to conduct a post-hoc test.}
- \item{...}{optional arguments to be passed to method.}
-}
-\description{
- Conducts posthoc test.
-}
-\details{
- So far is only implemented for object class \code{"ratebytree"}.
-}
-\value{
- An object of the appropriate class containing the results of a posthoc test.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{ratebytree}}
-}
-\keyword{statistics}
+\name{posthoc}
+\alias{posthoc}
+\title{Generic post-hoc test}
+\usage{
+posthoc(x, ...)
+}
+\arguments{
+ \item{x}{an object on which to conduct a post-hoc test.}
+ \item{...}{optional arguments to be passed to method.}
+}
+\description{
+ Conducts posthoc test.
+}
+\details{
+ So far is only implemented for object class \code{"ratebytree"}.
+}
+\value{
+ An object of the appropriate class containing the results of a posthoc test.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{ratebytree}}
+}
+\keyword{statistics}
diff --git a/man/print.backbonePhylo.Rd b/man/print.backbonePhylo.Rd
index ee81a81..4af92f4 100644
--- a/man/print.backbonePhylo.Rd
+++ b/man/print.backbonePhylo.Rd
@@ -1,26 +1,26 @@
-\name{print.backbonePhylo}
-\alias{print.backbonePhylo}
-\title{Print method for backbone phylogeny}
-\usage{
-\method{print}{backbonePhylo}(x, ...)
-}
-\arguments{
- \item{x}{an object of class \code{"backbonePhylo"}.}
- \item{...}{optional arguments.}
-}
-\description{
- Print method for an object of class \code{"backbonePhylo"}.
-}
-\value{
- Prints to screen.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{phylo.toBackbone}}
-}
-\keyword{phylogenetics}
-\keyword{plotting}
-
+\name{print.backbonePhylo}
+\alias{print.backbonePhylo}
+\title{Print method for backbone phylogeny}
+\usage{
+\method{print}{backbonePhylo}(x, ...)
+}
+\arguments{
+ \item{x}{an object of class \code{"backbonePhylo"}.}
+ \item{...}{optional arguments.}
+}
+\description{
+ Print method for an object of class \code{"backbonePhylo"}.
+}
+\value{
+ Prints to screen.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{phylo.toBackbone}}
+}
+\keyword{phylogenetics}
+\keyword{plotting}
+
diff --git a/man/ratebystate.Rd b/man/ratebystate.Rd
index eb0845c..c57662f 100644
--- a/man/ratebystate.Rd
+++ b/man/ratebystate.Rd
@@ -1,38 +1,38 @@
-\name{ratebystate}
-\alias{ratebystate}
-\title{Method for investigating the rate of one trait as a function of the state of another}
-\usage{
-ratebystate(tree, x, y, nsim=100, corr=c("pearson","spearman"), ...)
-}
-\arguments{
- \item{tree}{phylogenetic tree.}
- \item{x}{a continuous character - the dependent variable in the model.}
- \item{y}{a second continuous trait - the response variable.}
- \item{nsim}{number of simulations for hypothesis testing.}
- \item{corr}{correlation method to use. Same as in \code{\link{cor}}.}
- \item{...}{optional arguments which include \code{sim.method} (\code{"fastBM"} or \code{"sim.corrs"}; see \code{\link{fastBM}} and \code{\link{sim.corrs}}); \code{method} (\code{"by.node"} or \code{"by.branch"} indicating whether to assume the rate varies as a function of the node state or the mean branch state); \code{message} - a logical value indicating whether or not to return \code{corr} and \code{method}; finally \code{logarithm} - indicating whether or not to fit a model in which the variance of Brownian evolution in \code{y} changes as a multiplicative function of \code{x}. The default is \code{logarithm=FALSE}.}
-}
-\description{
- Statistical test of whether the rate of a continuous character might be influenced by the state of another.
-}
-\details{
- This function attempts to ask if the rate of a continuous character, \code{y}, depends on the state of a separate continuous trait, \code{x}. This is accomplished by regressing the squared contrasts in \code{y} on the branch or node ancestral estimates of \code{x}.
-}
-\value{
- This function returns an object of class \code{"ratebystate"} with up to the following four elements:
- \item{beta}{value of the regression coefficient for square of the contrasts in \code{y} regressed on the ancestral or branch-wise estimated states for \code{x}.}
- \item{r}{correlation coefficient for \code{corr=corr}.}
- \item{corr}{string giving the value of \code{corr}.}
- \item{method}{string giving the value of \code{method}.}
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{fastAnc}}, \code{\link{pic}}
-}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{continuous character}
-\keyword{maximum likelihood}
+\name{ratebystate}
+\alias{ratebystate}
+\title{Method for investigating the rate of one trait as a function of the state of another}
+\usage{
+ratebystate(tree, x, y, nsim=100, corr=c("pearson","spearman"), ...)
+}
+\arguments{
+ \item{tree}{phylogenetic tree.}
+ \item{x}{a continuous character - the dependent variable in the model.}
+ \item{y}{a second continuous trait - the response variable.}
+ \item{nsim}{number of simulations for hypothesis testing.}
+ \item{corr}{correlation method to use. Same as in \code{\link{cor}}.}
+ \item{...}{optional arguments which include \code{sim.method} (\code{"fastBM"} or \code{"sim.corrs"}; see \code{\link{fastBM}} and \code{\link{sim.corrs}}); \code{method} (\code{"by.node"} or \code{"by.branch"} indicating whether to assume the rate varies as a function of the node state or the mean branch state); \code{message} - a logical value indicating whether or not to return \code{corr} and \code{method}; finally \code{logarithm} - indicating whether or not to fit a model in which the variance of Brownian evolution in \code{y} changes as a multiplicative function of \code{x}. The default is \code{logarithm=FALSE}.}
+}
+\description{
+ Statistical test of whether the rate of a continuous character might be influenced by the state of another.
+}
+\details{
+ This function attempts to ask if the rate of a continuous character, \code{y}, depends on the state of a separate continuous trait, \code{x}. This is accomplished by regressing the squared contrasts in \code{y} on the branch or node ancestral estimates of \code{x}.
+}
+\value{
+ This function returns an object of class \code{"ratebystate"} with up to the following four elements:
+ \item{beta}{value of the regression coefficient for square of the contrasts in \code{y} regressed on the ancestral or branch-wise estimated states for \code{x}.}
+ \item{r}{correlation coefficient for \code{corr=corr}.}
+ \item{corr}{string giving the value of \code{corr}.}
+ \item{method}{string giving the value of \code{method}.}
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{fastAnc}}, \code{\link{pic}}
+}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{continuous character}
+\keyword{maximum likelihood}
diff --git a/man/ratebytree.Rd b/man/ratebytree.Rd
index a1592d6..0fbcd0f 100644
--- a/man/ratebytree.Rd
+++ b/man/ratebytree.Rd
@@ -1,72 +1,72 @@
-\name{ratebytree}
-\alias{ratebytree}
-\alias{posthoc.ratebytree}
-\title{Likelihood test for rate variation among trees, clades, or traits}
-\usage{
-ratebytree(trees, x, ...)
-\method{posthoc}{ratebytree}(x, ...)
-}
-\arguments{
- \item{trees}{an object of class \code{"multiPhylo"}. If \code{x} consists of a list of different traits to be compared, then \code{trees} could also be a simple set of duplicates of the same tree, e.g., \code{rep(tree,length(x))}.}
- \item{x}{a list of trait vectors for a continuous trait in which the names of each vectors correspond to the tip labels of \code{trees}. This is not used if \code{type="diversification"}. In the case of \code{posthoc.ratebytree}, an object of class \code{"ratebytree"}.}
- \item{...}{optional arguments, including the argument \code{type} (\code{"continuous"}, \code{"discrete"}, or \code{"diversification"}), which, if not specified, the function will attempt to ascertain. See \code{Details} for more information.}
-}
-\description{
- Multiple methods for comparing the rate or process of evolution between trees.
-}
-\details{
- This function essentially implements three different methods for comparing the rate or process of evolution between trees: one for continuously-valued traits, a second for discrete characters, and a third for the rate of diversification (speciation & extinction).
-
- In all cases, the function takes an object of class \code{"multiPhylo"} containing two or more phylogenies (\code{trees}), and (for the first two analyses) a list of trait vectors (\code{x}).
-
- For continuous traits, the function then proceeds to fit two models: one in which the rate (or regime, for models \code{"OU"} and \code{"EB"}) of trait evolution is equal among all trees; and a second in which the rates or regimes can differ between trees.
-
- The latter model corresponds to an extension of the \emph{censored} approach of O'Meara et al. (2006; Revell et al. 2018) and should also be related to the method of Adams (2012) for comparing rates among traits. See \code{\link{brownie.lite}} for a different implementation of the \emph{noncensored} approach of O'Meara et al. (2006).
-
- For discrete traits, the function instead proceeds to fit two variants of the M\emph{k} model (Lewis 2001): one in which the parameters values (transition rates) of the process are free to vary between trees, and a second in which they are fixed to be the same.
-
- For diversification alone, the function fits two different diversification (speciation & extinction) models (Nee et al. 1994; Stadler 2012): one in which the birth (speciation) and death (extinction) rates are identical between the trees, and a second in which they are permitted to differ in various ways depending on the value of \code{"model"} (Revell 2018).
-
- The method \code{posthoc} conducts a post-hoc comparison of parameter estimates between trees in the multi-rate or multi-process model. The parameter that is compared depends on the fitted model. For instance, in \code{model="BM"} posthoc comparison is made of \code{sig2}; if \code{model="OU"} fitted values of \code{alpha} are compared; and so on. The argument \code{p.adjust.method} can be used to specify a method for adjusting P-values for multiple tests following \code{p.adjust} (defaults to \code{p.adjust.method="none"}.
-
- At present it is not possible to specify different models to fit for the different trees - although if (for instance) character evolution on tree 1 proceeded by a strong \emph{OU} process while character evolution on tree 2 was by \emph{BM}, we would probably reject a constant-process model and tree 2 should show a very low value of \code{alpha}.
-
- To compute the standard errors for each fitted paramater value, the function computes the negative inverse of the Hessian matrix at the MLEs; however, if this matrix is computationally singular the generalized inverse (\code{\link{ginv}}) will be used instead without warning.
-
- The function also conducts a likelihood-ratio test to compare the two models.
-
- For continuous character, optional arguments presently include the following: \code{model}, the model of continuous trait evolution (options are \code{"BM"}, the default, \code{"OU"}, and \code{"EB"}). \code{tol}, used as a minimum value for the fitting rates, to prevent problems in optimization. \code{trace}, a logical value indicating whether or not to report progress in the optimization. \code{test}, the method for hypothesis testing (options are \code{"chisq"} and \code{"simulation"}). \code{quiet}, a logical value indicating whether or not to run perfectly quietly. Finally, \code{se}, a list of vectors containing the standard errors for each value of \code{x}.
-
- For \code{type="discrete"} the optional arguments are slightly different. The argument \code{model} can be used, but it must assume the values \code{"ER"}, \code{"SYM"}, \code{"ARD"}, or a numeric matrix following \code{\link{ace}}.
-
- Finally, for \code{type= "diversification"} models are so far \code{"birth-death"}, \code{"equal-extinction"}, and \code{"equal-specation"}, and \code{"Yule"}. It is also important to consider supplying the sampling fractions, \code{rho}, which is a vector of values between 0 and 1 of the same length as \code{trees}. If not provided the method will assume a sampling fraction of 1.0 for all trees - which is seldom true of empirical studies.
-}
-\value{
- An object of class \code{"ratebytree"} or an object of class \code{"posthoc.ratebytree"} in the case of the method \code{posthoc}.
-}
-\references{
- Adams, D. C. (2012) Comparing evolutionary rates for different phenotypic traits on a phylogeny using likelihood. \emph{Syst. Biol.}, \bold{62}, 181-192.
-
- Lewis, P. O. (2001) A likelihood approach to estimating phylogeny from discrete morphological character data. \emph{Systematic Biology}, \bold{50}, 913-925.
-
- Nee, S., May, R. M. and Harvey, P. H. (1994) The reconstructed evolutionary process. \emph{Philosophical Transactions of the Royal Society of London B}, \bold{344}, 305-311.
-
- O'Meara, B. C., C. Ane, M. J. Sanderson, and P. C. Wainwright. (2006) Testing for different rates of continuous trait evolution using likelihood. \emph{Evolution}, \bold{60}, 922-933.
-
- Stadler, T. (2012) How can we improve the accuracy of macroevolutionary rate estimates? \emph{Systematic Biology}, \bold{62}, 321-329.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-
- Revell, L. J. (2018) Comparing the rates of speciation and extinction between phylogenetic trees. emph{Ecology and Evolution}, \bold{8}, 5303-5312.
-
- Revell, L. J., Gonzalez-Valenzuela, L. E., Alfonso, A., Castellanos-Garcia, L. A., Guarnizo, C. E., and Crawford, A. J. (2018) Comparing evolutionary rates between trees, clades, & traits. \emph{Methods Ecol. Evol.}, \bold{9}, 994-1005.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{brownie.lite}}, \code{\link{fitMk}}
-}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{maximum likelihood}
-\keyword{continuous character}
-\keyword{discrete character}
+\name{ratebytree}
+\alias{ratebytree}
+\alias{posthoc.ratebytree}
+\title{Likelihood test for rate variation among trees, clades, or traits}
+\usage{
+ratebytree(trees, x, ...)
+\method{posthoc}{ratebytree}(x, ...)
+}
+\arguments{
+ \item{trees}{an object of class \code{"multiPhylo"}. If \code{x} consists of a list of different traits to be compared, then \code{trees} could also be a simple set of duplicates of the same tree, e.g., \code{rep(tree,length(x))}.}
+ \item{x}{a list of trait vectors for a continuous trait in which the names of each vectors correspond to the tip labels of \code{trees}. This is not used if \code{type="diversification"}. In the case of \code{posthoc.ratebytree}, an object of class \code{"ratebytree"}.}
+ \item{...}{optional arguments, including the argument \code{type} (\code{"continuous"}, \code{"discrete"}, or \code{"diversification"}), which, if not specified, the function will attempt to ascertain. See \code{Details} for more information.}
+}
+\description{
+ Multiple methods for comparing the rate or process of evolution between trees.
+}
+\details{
+ This function essentially implements three different methods for comparing the rate or process of evolution between trees: one for continuously-valued traits, a second for discrete characters, and a third for the rate of diversification (speciation & extinction).
+
+ In all cases, the function takes an object of class \code{"multiPhylo"} containing two or more phylogenies (\code{trees}), and (for the first two analyses) a list of trait vectors (\code{x}).
+
+ For continuous traits, the function then proceeds to fit two models: one in which the rate (or regime, for models \code{"OU"} and \code{"EB"}) of trait evolution is equal among all trees; and a second in which the rates or regimes can differ between trees.
+
+ The latter model corresponds to an extension of the \emph{censored} approach of O'Meara et al. (2006; Revell et al. 2018) and should also be related to the method of Adams (2012) for comparing rates among traits. See \code{\link{brownie.lite}} for a different implementation of the \emph{noncensored} approach of O'Meara et al. (2006).
+
+ For discrete traits, the function instead proceeds to fit two variants of the M\emph{k} model (Lewis 2001): one in which the parameters values (transition rates) of the process are free to vary between trees, and a second in which they are fixed to be the same.
+
+ For diversification alone, the function fits two different diversification (speciation & extinction) models (Nee et al. 1994; Stadler 2012): one in which the birth (speciation) and death (extinction) rates are identical between the trees, and a second in which they are permitted to differ in various ways depending on the value of \code{"model"} (Revell 2018).
+
+ The method \code{posthoc} conducts a post-hoc comparison of parameter estimates between trees in the multi-rate or multi-process model. The parameter that is compared depends on the fitted model. For instance, in \code{model="BM"} posthoc comparison is made of \code{sig2}; if \code{model="OU"} fitted values of \code{alpha} are compared; and so on. The argument \code{p.adjust.method} can be used to specify a method for adjusting P-values for multiple tests following \code{p.adjust} (defaults to \code{p.adjust.method="none"}.
+
+ At present it is not possible to specify different models to fit for the different trees - although if (for instance) character evolution on tree 1 proceeded by a strong \emph{OU} process while character evolution on tree 2 was by \emph{BM}, we would probably reject a constant-process model and tree 2 should show a very low value of \code{alpha}.
+
+ To compute the standard errors for each fitted paramater value, the function computes the negative inverse of the Hessian matrix at the MLEs; however, if this matrix is computationally singular the generalized inverse (\code{\link{ginv}}) will be used instead without warning.
+
+ The function also conducts a likelihood-ratio test to compare the two models.
+
+ For continuous character, optional arguments presently include the following: \code{model}, the model of continuous trait evolution (options are \code{"BM"}, the default, \code{"OU"}, and \code{"EB"}). \code{tol}, used as a minimum value for the fitting rates, to prevent problems in optimization. \code{trace}, a logical value indicating whether or not to report progress in the optimization. \code{test}, the method for hypothesis testing (options are \code{"chisq"} and \code{"simulation"}). \code{quiet}, a logical value indicating whether or not to run perfectly quietly. Finally, \code{se}, a list of vectors containing the standard errors for each value of \code{x}.
+
+ For \code{type="discrete"} the optional arguments are slightly different. The argument \code{model} can be used, but it must assume the values \code{"ER"}, \code{"SYM"}, \code{"ARD"}, or a numeric matrix following \code{\link{ace}}.
+
+ Finally, for \code{type= "diversification"} models are so far \code{"birth-death"}, \code{"equal-extinction"}, and \code{"equal-specation"}, and \code{"Yule"}. It is also important to consider supplying the sampling fractions, \code{rho}, which is a vector of values between 0 and 1 of the same length as \code{trees}. If not provided the method will assume a sampling fraction of 1.0 for all trees - which is seldom true of empirical studies.
+}
+\value{
+ An object of class \code{"ratebytree"} or an object of class \code{"posthoc.ratebytree"} in the case of the method \code{posthoc}.
+}
+\references{
+ Adams, D. C. (2012) Comparing evolutionary rates for different phenotypic traits on a phylogeny using likelihood. \emph{Syst. Biol.}, \bold{62}, 181-192.
+
+ Lewis, P. O. (2001) A likelihood approach to estimating phylogeny from discrete morphological character data. \emph{Systematic Biology}, \bold{50}, 913-925.
+
+ Nee, S., May, R. M. and Harvey, P. H. (1994) The reconstructed evolutionary process. \emph{Philosophical Transactions of the Royal Society of London B}, \bold{344}, 305-311.
+
+ O'Meara, B. C., C. Ane, M. J. Sanderson, and P. C. Wainwright. (2006) Testing for different rates of continuous trait evolution using likelihood. \emph{Evolution}, \bold{60}, 922-933.
+
+ Stadler, T. (2012) How can we improve the accuracy of macroevolutionary rate estimates? \emph{Systematic Biology}, \bold{62}, 321-329.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+
+ Revell, L. J. (2018) Comparing the rates of speciation and extinction between phylogenetic trees. emph{Ecology and Evolution}, \bold{8}, 5303-5312.
+
+ Revell, L. J., Gonzalez-Valenzuela, L. E., Alfonso, A., Castellanos-Garcia, L. A., Guarnizo, C. E., and Crawford, A. J. (2018) Comparing evolutionary rates between trees, clades, & traits. \emph{Methods Ecol. Evol.}, \bold{9}, 994-1005.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{brownie.lite}}, \code{\link{fitMk}}
+}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{maximum likelihood}
+\keyword{continuous character}
+\keyword{discrete character}
diff --git a/man/rateshift.Rd b/man/rateshift.Rd
index afc181d..5fc6ed5 100644
--- a/man/rateshift.Rd
+++ b/man/rateshift.Rd
@@ -1,44 +1,44 @@
-\name{rateshift}
-\alias{rateshift}
-\alias{plot.rateshift}
-\alias{likSurface.rateshift}
-\title{Find the temporal position of one or more rate shifts}
-\usage{
-rateshift(tree, x, nrates=1, niter=10, method="ML", ...)
-\method{plot}{rateshift}(x, ...)
-likSurface.rateshift(tree, x, nrates=2, shift.range=NULL,
- density=20, plot=TRUE, ...)
-}
-\arguments{
- \item{tree}{object of class \code{"phylo"}.}
- \item{x}{vector of phenotypic trait values for species. \code{names(x)} should contain the species names and match \code{tree$tip.label}. For \code{plot} method, \code{x} is an object of class \code{"rateshift"}.}
- \item{nrates}{number of rates.}
- \item{niter}{number of iterations of optimization routine to ensure convergence.}
- \item{method}{optimization method. Can be \code{"ML"} (maximum likelihood) or \code{"REML"} (restricted maximum likelihood).}
- \item{...}{optional arguments. In the case of the \code{plot} method, these will be passed to \code{\link{plotSimmap}}. For \code{rateshift}, optional arguments include: \code{tol}, tolerance; \code{plot} & \code{print}, logical values indicating whether to plot or print the progress of the optimization (default to \code{FALSE}); \code{quiet}, logical argument indicating whether to suppress all notifications (defaults to \code{FALSE}); \code{minL}, numeric value; and \code{fixed.shift}, either a vector of fixed shift points, or a logical value.}
- \item{shift.range}{for \code{likSurface.rateshift}.}
- \item{density}{for \code{likSurface.rateshift}.}
- \item{plot}{logical argument for \code{likSurface.rateshift}. If \code{plot=FALSE} then the surface is returned.}
-}
-\description{
- Fits a model with one or more temporal rate shifts for a continuous trait on the tree.
-}
-\details{
- \code{rateshift} attempts to find the location of one or more rate shifts. This model is quite easy to compute the likelihood for, but quite difficult to optimize as the likelihood surface is often rugged.
-
- \code{likSurface.rateshift} plots the likelihood surface.
-}
-\value{
- A fitted object of class \code{"rateshift"}, or, in the case of \code{likSurface.rateshift}, a likelihood surface for the shift points.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{brownie.lite}}
-}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{continuous character}
-\keyword{maximum likelihood}
+\name{rateshift}
+\alias{rateshift}
+\alias{plot.rateshift}
+\alias{likSurface.rateshift}
+\title{Find the temporal position of one or more rate shifts}
+\usage{
+rateshift(tree, x, nrates=1, niter=10, method="ML", ...)
+\method{plot}{rateshift}(x, ...)
+likSurface.rateshift(tree, x, nrates=2, shift.range=NULL,
+ density=20, plot=TRUE, ...)
+}
+\arguments{
+ \item{tree}{object of class \code{"phylo"}.}
+ \item{x}{vector of phenotypic trait values for species. \code{names(x)} should contain the species names and match \code{tree$tip.label}. For \code{plot} method, \code{x} is an object of class \code{"rateshift"}.}
+ \item{nrates}{number of rates.}
+ \item{niter}{number of iterations of optimization routine to ensure convergence.}
+ \item{method}{optimization method. Can be \code{"ML"} (maximum likelihood) or \code{"REML"} (restricted maximum likelihood).}
+ \item{...}{optional arguments. In the case of the \code{plot} method, these will be passed to \code{\link{plotSimmap}}. For \code{rateshift}, optional arguments include: \code{tol}, tolerance; \code{plot} & \code{print}, logical values indicating whether to plot or print the progress of the optimization (default to \code{FALSE}); \code{quiet}, logical argument indicating whether to suppress all notifications (defaults to \code{FALSE}); \code{minL}, numeric value; and \code{fixed.shift}, either a vector of fixed shift points, or a logical value.}
+ \item{shift.range}{for \code{likSurface.rateshift}.}
+ \item{density}{for \code{likSurface.rateshift}.}
+ \item{plot}{logical argument for \code{likSurface.rateshift}. If \code{plot=FALSE} then the surface is returned.}
+}
+\description{
+ Fits a model with one or more temporal rate shifts for a continuous trait on the tree.
+}
+\details{
+ \code{rateshift} attempts to find the location of one or more rate shifts. This model is quite easy to compute the likelihood for, but quite difficult to optimize as the likelihood surface is often rugged.
+
+ \code{likSurface.rateshift} plots the likelihood surface.
+}
+\value{
+ A fitted object of class \code{"rateshift"}, or, in the case of \code{likSurface.rateshift}, a likelihood surface for the shift points.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{brownie.lite}}
+}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{continuous character}
+\keyword{maximum likelihood}
diff --git a/man/read.newick.Rd b/man/read.newick.Rd
index f41a510..f646fd5 100644
--- a/man/read.newick.Rd
+++ b/man/read.newick.Rd
@@ -1,38 +1,38 @@
-\name{read.newick}
-\alias{read.newick}
-\alias{readNexus}
-\title{Newick or Nexus style tree reader}
-\usage{
-read.newick(file="", text, ...)
-readNexus(file="", format=c("standard","raxml"))
-}
-\arguments{
- \item{file}{name of text file with single Newick style tree or multiple trees, one per line. For \code{readNexus} this should be a Nexus format tree.}
- \item{text}{character string containing tree.}
- \item{format}{file format (source) for \code{readNexus}. In the case of \code{format="standard"}, \code{\link{read.nexus}} from \pkg{ape} will be used internally. For \code{format="raxml"}, the parser assumes that bootstrap values have been stored as node labels in the format \code{[&label=bootstrap]}.}
- \item{...}{optional arguments to be passed to \code{\link{scan}}. Note that if the arguments \code{sep} or \code{what} are supplied this could generate an error. Useful optional arguments might include \code{skip} (number of lines to skip) and \code{nlines} (number of lines to read).}
-}
-\description{
- Reads a phylogenetic tree from file.
-}
-\details{
- The function \code{read.newick} reads a simple Newick style tree from file. This function is now almost completely redundant with \code{\link{read.tree}}. At the time of development, however, it was more 'robust' than \code{read.tree} in that it didn't fail if the tree contained so-called 'singles' (nodes with only one descendant); however, \code{read.tree} can now handle singleton nodes without difficulty.
-
- The function \code{readNexus} reads a Nexus formatted tree, optionally with bootstrap values as node labels. This function can read a simple Nexus formatted tree from file (like \code{\link{read.nexus}}); however, it can also parse the node labels as bootstrap values. This is the output format from the software \emph{RAxML}. For Nexus tree files with complex node labels (e.g., from the software \emph{MrBayes}) it will probably fail to parse node labels correctly, if at all.
-}
-\value{
- An object of class \code{"phylo"}, possibly containing singletons (see \code{\link{collapse.singles}}); or an object of class \code{"multiPhylo"}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{read.tree}}, \code{\link{read.nexus}}
-}
-\examples{
-tree<-"((Human,Chimp),Gorilla),Monkey);"
-phy<-read.newick(text=tree)
-}
-\keyword{phylogenetics}
-\keyword{input/output}
+\name{read.newick}
+\alias{read.newick}
+\alias{readNexus}
+\title{Newick or Nexus style tree reader}
+\usage{
+read.newick(file="", text, ...)
+readNexus(file="", format=c("standard","raxml"))
+}
+\arguments{
+ \item{file}{name of text file with single Newick style tree or multiple trees, one per line. For \code{readNexus} this should be a Nexus format tree.}
+ \item{text}{character string containing tree.}
+ \item{format}{file format (source) for \code{readNexus}. In the case of \code{format="standard"}, \code{\link{read.nexus}} from \pkg{ape} will be used internally. For \code{format="raxml"}, the parser assumes that bootstrap values have been stored as node labels in the format \code{[&label=bootstrap]}.}
+ \item{...}{optional arguments to be passed to \code{\link{scan}}. Note that if the arguments \code{sep} or \code{what} are supplied this could generate an error. Useful optional arguments might include \code{skip} (number of lines to skip) and \code{nlines} (number of lines to read).}
+}
+\description{
+ Reads a phylogenetic tree from file.
+}
+\details{
+ The function \code{read.newick} reads a simple Newick style tree from file. This function is now almost completely redundant with \code{\link{read.tree}}. At the time of development, however, it was more 'robust' than \code{read.tree} in that it didn't fail if the tree contained so-called 'singles' (nodes with only one descendant); however, \code{read.tree} can now handle singleton nodes without difficulty.
+
+ The function \code{readNexus} reads a Nexus formatted tree, optionally with bootstrap values as node labels. This function can read a simple Nexus formatted tree from file (like \code{\link{read.nexus}}); however, it can also parse the node labels as bootstrap values. This is the output format from the software \emph{RAxML}. For Nexus tree files with complex node labels (e.g., from the software \emph{MrBayes}) it will probably fail to parse node labels correctly, if at all.
+}
+\value{
+ An object of class \code{"phylo"}, possibly containing singletons (see \code{\link{collapse.singles}}); or an object of class \code{"multiPhylo"}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{read.tree}}, \code{\link{read.nexus}}
+}
+\examples{
+tree<-"((Human,Chimp),Gorilla),Monkey);"
+phy<-read.newick(text=tree)
+}
+\keyword{phylogenetics}
+\keyword{input/output}
diff --git a/man/read.simmap.Rd b/man/read.simmap.Rd
index 3710d2d..d0ea4fe 100644
--- a/man/read.simmap.Rd
+++ b/man/read.simmap.Rd
@@ -1,41 +1,41 @@
-\name{read.simmap}
-\alias{read.simmap}
-\title{Read SIMMAP style trees from file}
-\usage{
-read.simmap(file="", text, format="nexus", rev.order=TRUE, version=1)
-}
-\arguments{
- \item{file}{name of text file with one or multiple SIMMAP v1.0 or v1.5 style trees containing the mapped history of a discrete character.}
- \item{text}{character string containing the tree. If \code{version=1.5} this argument is ignored. (This format tree can only be read from file in the present version.)}
- \item{format}{format of the trees: either \code{"phylip"} or \code{"nexus"} - the latter is the default output from SIMMAP. If \code{version=1.5} this argument is ignored.}
- \item{rev.order}{a logical value indicating whether the states and times along each branch is given (from root to tip) in right-to-left order (if TRUE) or in left-to-right order. If \code{version=1.5} this argument is ignored.}
- \item{version}{version of SIMMAP for input tree. If the tree(s) was/were simulated in SIMMAP v1.0 or written to file by \code{link{make.simmap}} then \code{version=1.0}; if the tree(s) was/were simulated using SIMMAP v1.5 then \code{version=1.5}.}
-}
-\description{
- This reads one or multiple SIMMAP style trees from file.
-}
-\details{
- This function now accepts trees in both SIMMAP v1.0 and SIMMAP v1.5 format. In addition, it can read a more flexible format than is produced by SIMMAP (for instance, multi-character mapped states and more than 7 mapped states).
-
- The function uses some modified code from \code{\link{read.nexus}} from the \pkg{ape} package to read the NEXUS block created by SIMMAP. Also creates the attribute \code{"map.order"} which indicates whether the stochastic map was read in from left to right or right to left. This attribute is used by default by \code{\link{write.simmap}} to write the tree in the same order.
-}
-\value{
- An object of class \code{"simmap"} (or list of such objects with class \code{"multiSimmap"}), consisting of a modified object of class \code{"phylo"} with at least the following additional elements:
- \item{maps}{a list of named vectors containing the times spent in each state on each branch, in the order in which they occur.}
- \item{mapped.edge}{a matrix containing the total time spent in each state along each edge of the tree.}
-}
-\references{
- Bollback, J. P. (2006) Stochastic character mapping of discrete traits on phylogenies. \emph{BMC Bioinformatics}, \bold{7}, 88.
-
- Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{brownie.lite}}, \code{\link{evol.vcv}}, \code{\link{read.tree}}, \code{\link{read.nexus}}
-}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{input/output}
-\keyword{discrete character}
+\name{read.simmap}
+\alias{read.simmap}
+\title{Read SIMMAP style trees from file}
+\usage{
+read.simmap(file="", text, format="nexus", rev.order=TRUE, version=1)
+}
+\arguments{
+ \item{file}{name of text file with one or multiple SIMMAP v1.0 or v1.5 style trees containing the mapped history of a discrete character.}
+ \item{text}{character string containing the tree. If \code{version=1.5} this argument is ignored. (This format tree can only be read from file in the present version.)}
+ \item{format}{format of the trees: either \code{"phylip"} or \code{"nexus"} - the latter is the default output from SIMMAP. If \code{version=1.5} this argument is ignored.}
+ \item{rev.order}{a logical value indicating whether the states and times along each branch is given (from root to tip) in right-to-left order (if TRUE) or in left-to-right order. If \code{version=1.5} this argument is ignored.}
+ \item{version}{version of SIMMAP for input tree. If the tree(s) was/were simulated in SIMMAP v1.0 or written to file by \code{link{make.simmap}} then \code{version=1.0}; if the tree(s) was/were simulated using SIMMAP v1.5 then \code{version=1.5}.}
+}
+\description{
+ This reads one or multiple SIMMAP style trees from file.
+}
+\details{
+ This function now accepts trees in both SIMMAP v1.0 and SIMMAP v1.5 format. In addition, it can read a more flexible format than is produced by SIMMAP (for instance, multi-character mapped states and more than 7 mapped states).
+
+ The function uses some modified code from \code{\link{read.nexus}} from the \pkg{ape} package to read the NEXUS block created by SIMMAP. Also creates the attribute \code{"map.order"} which indicates whether the stochastic map was read in from left to right or right to left. This attribute is used by default by \code{\link{write.simmap}} to write the tree in the same order.
+}
+\value{
+ An object of class \code{"simmap"} (or list of such objects with class \code{"multiSimmap"}), consisting of a modified object of class \code{"phylo"} with at least the following additional elements:
+ \item{maps}{a list of named vectors containing the times spent in each state on each branch, in the order in which they occur.}
+ \item{mapped.edge}{a matrix containing the total time spent in each state along each edge of the tree.}
+}
+\references{
+ Bollback, J. P. (2006) Stochastic character mapping of discrete traits on phylogenies. \emph{BMC Bioinformatics}, \bold{7}, 88.
+
+ Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{brownie.lite}}, \code{\link{evol.vcv}}, \code{\link{read.tree}}, \code{\link{read.nexus}}
+}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{input/output}
+\keyword{discrete character}
diff --git a/man/reorder.backbonePhylo.Rd b/man/reorder.backbonePhylo.Rd
index 6c6413a..1bc25a9 100644
--- a/man/reorder.backbonePhylo.Rd
+++ b/man/reorder.backbonePhylo.Rd
@@ -1,27 +1,27 @@
-\name{reorder.backbonePhylo}
-\alias{reorder.backbonePhylo}
-\title{Reorders a backbone phylogeny}
-\usage{
-\method{reorder}{backbonePhylo}(x, order="cladewise", ...)
-}
-\arguments{
- \item{x}{an object of class \code{"backbonePhylo"}.}
- \item{order}{order. See \code{\link{reorder.phylo}} for possible orderings.}
- \item{...}{optional arguments.}
-}
-\description{
- Function reorders an object of class \code{"backbonePhylo"}.
-}
-\value{
- An object of class \code{"backbonePhylo"}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{phylo.toBackbone}}
-}
-\keyword{phylogenetics}
-\keyword{plotting}
-\keyword{utilities}
+\name{reorder.backbonePhylo}
+\alias{reorder.backbonePhylo}
+\title{Reorders a backbone phylogeny}
+\usage{
+\method{reorder}{backbonePhylo}(x, order="cladewise", ...)
+}
+\arguments{
+ \item{x}{an object of class \code{"backbonePhylo"}.}
+ \item{order}{order. See \code{\link{reorder.phylo}} for possible orderings.}
+ \item{...}{optional arguments.}
+}
+\description{
+ Function reorders an object of class \code{"backbonePhylo"}.
+}
+\value{
+ An object of class \code{"backbonePhylo"}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{phylo.toBackbone}}
+}
+\keyword{phylogenetics}
+\keyword{plotting}
+\keyword{utilities}
diff --git a/man/reorderSimmap.Rd b/man/reorderSimmap.Rd
index 4ae7e2d..8d3da76 100644
--- a/man/reorderSimmap.Rd
+++ b/man/reorderSimmap.Rd
@@ -1,28 +1,28 @@
-\name{reorderSimmap}
-\alias{reorderSimmap}
-\title{Reorder edges of a simmap tree}
-\usage{
-reorderSimmap(tree, order="cladewise", index.only=FALSE, ...)
-}
-\arguments{
- \item{tree}{a modified object of class \code{"phylo"}.}
- \item{order}{\code{"cladewise"}, \code{"pruningwise"}, or any other allowable order permitted by \code{\link{reorder.phylo}}.}
- \item{index.only}{logical value indicating whether only an index should be returned.}
- \item{...}{other arguments.}
-}
-\description{
- Function returns a reordered modified \code{"phylo"} object by using \code{reorder.phylo} but then sorting the additional elements \code{$mapped.edge} and \code{$maps} to have the same order as \code{$edge}.
-}
-\value{
- A modified object of class \code{"phylo"}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{reorder.phylo}}, \code{\link{plotSimmap}}
-}
-\keyword{phylogenetics}
-\keyword{utilities}
-\keyword{comparative method}
+\name{reorderSimmap}
+\alias{reorderSimmap}
+\title{Reorder edges of a simmap tree}
+\usage{
+reorderSimmap(tree, order="cladewise", index.only=FALSE, ...)
+}
+\arguments{
+ \item{tree}{a modified object of class \code{"phylo"}.}
+ \item{order}{\code{"cladewise"}, \code{"pruningwise"}, or any other allowable order permitted by \code{\link{reorder.phylo}}.}
+ \item{index.only}{logical value indicating whether only an index should be returned.}
+ \item{...}{other arguments.}
+}
+\description{
+ Function returns a reordered modified \code{"phylo"} object by using \code{reorder.phylo} but then sorting the additional elements \code{$mapped.edge} and \code{$maps} to have the same order as \code{$edge}.
+}
+\value{
+ A modified object of class \code{"phylo"}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{reorder.phylo}}, \code{\link{plotSimmap}}
+}
+\keyword{phylogenetics}
+\keyword{utilities}
+\keyword{comparative method}
diff --git a/man/rep.phylo.Rd b/man/rep.phylo.Rd
index a2f0951..30ea3d5 100644
--- a/man/rep.phylo.Rd
+++ b/man/rep.phylo.Rd
@@ -1,38 +1,38 @@
-\name{rep.phylo}
-\alias{rep.phylo}
-\alias{rep.multiPhylo}
-\alias{repPhylo}
-\title{Replicate a tree or set of trees}
-\usage{
-\method{rep}{phylo}(x, ...)
-\method{rep}{multiPhylo}(x, ...)
-repPhylo(tree, times)
-}
-\arguments{
- \item{tree}{object of class \code{"phylo"}.}
- \item{times}{number of times to replicate tree.}
- \item{x}{for S3 method an object of class \code{"phylo"} or \code{"multiPhylo"}.}
- \item{...}{other arguments for \code{rep} (specifically, \code{times}).}
-}
-\description{
- \code{\link{rep}} method for object of class \code{"phylo"} or \code{"multiPhylo"}.
-}
-\details{
- \code{repPhylo} is just an alias for \code{rep.phylo} and \code{rep.multiPhylo}.
-}
-\value{
- An object of class \code{"multiPhylo"}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\examples{
-tree<-pbtree(n=100)
-trees<-rep(tree,100)
-}
-\seealso{
- \code{\link{c.phylo}}, \code{\link{rep}}
-}
-\keyword{phylogenetics}
-\keyword{utilities}
+\name{rep.phylo}
+\alias{rep.phylo}
+\alias{rep.multiPhylo}
+\alias{repPhylo}
+\title{Replicate a tree or set of trees}
+\usage{
+\method{rep}{phylo}(x, ...)
+\method{rep}{multiPhylo}(x, ...)
+repPhylo(tree, times)
+}
+\arguments{
+ \item{tree}{object of class \code{"phylo"}.}
+ \item{times}{number of times to replicate tree.}
+ \item{x}{for S3 method an object of class \code{"phylo"} or \code{"multiPhylo"}.}
+ \item{...}{other arguments for \code{rep} (specifically, \code{times}).}
+}
+\description{
+ \code{\link{rep}} method for object of class \code{"phylo"} or \code{"multiPhylo"}.
+}
+\details{
+ \code{repPhylo} is just an alias for \code{rep.phylo} and \code{rep.multiPhylo}.
+}
+\value{
+ An object of class \code{"multiPhylo"}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\examples{
+tree<-pbtree(n=100)
+trees<-rep(tree,100)
+}
+\seealso{
+ \code{\link{c.phylo}}, \code{\link{rep}}
+}
+\keyword{phylogenetics}
+\keyword{utilities}
diff --git a/man/reroot.Rd b/man/reroot.Rd
index b9dad8b..2a01ce7 100644
--- a/man/reroot.Rd
+++ b/man/reroot.Rd
@@ -1,33 +1,33 @@
-\name{reroot}
-\alias{reroot}
-\title{Re-root a tree along an edge}
-\usage{
-reroot(tree, node.number, position=NULL, interactive=FALSE, ...)
-}
-\arguments{
- \item{tree}{a phylogenetic tree in \code{"phylo"} format.}
- \item{node.number}{ number of the node descending from the target branch in \code{tree$edge} - this can also be a tip in which case the node number is the index number of the tip in \code{tree$tip.label}.}
- \item{position}{position along the target edge at which to re-root the tree. If not supplied, then the tree will be re-rooted \emph{at} the node or tip.}
- \item{interactive}{logical value indicating whether to use interactive mode (defaults to \code{interactive=} \code{FALSE}).}
- \item{...}{arguments to be passed to \code{plotTree} for \code{interactive=TRUE} only.}
-}
-\description{
- Re-roots a phylogenetic tree at an arbitrary position along an edge.
-}
-\details{
- This function had an error for rootings along edges descended from the root node for \pkg{phytools}<=0.2-47. This should be fixed in the present version. Now uses \code{\link{paste.tree}}, \code{\link{root}}, and \code{\link{splitTree}} internally. Earlier versions also had an error related to node labels. This should be fixed in \pkg{phytools}>=0.4-47.
-}
-\value{
- A phylogenetic tree in \code{"phylo"} format.
-}
-\references{
- Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{splitTree}}, \code{\link{paste.tree}}, \code{\link{root}}
-}
-\keyword{phylogenetics}
-\keyword{utilities}
+\name{reroot}
+\alias{reroot}
+\title{Re-root a tree along an edge}
+\usage{
+reroot(tree, node.number, position=NULL, interactive=FALSE, ...)
+}
+\arguments{
+ \item{tree}{a phylogenetic tree in \code{"phylo"} format.}
+ \item{node.number}{ number of the node descending from the target branch in \code{tree$edge} - this can also be a tip in which case the node number is the index number of the tip in \code{tree$tip.label}.}
+ \item{position}{position along the target edge at which to re-root the tree. If not supplied, then the tree will be re-rooted \emph{at} the node or tip.}
+ \item{interactive}{logical value indicating whether to use interactive mode (defaults to \code{interactive=} \code{FALSE}).}
+ \item{...}{arguments to be passed to \code{plotTree} for \code{interactive=TRUE} only.}
+}
+\description{
+ Re-roots a phylogenetic tree at an arbitrary position along an edge.
+}
+\details{
+ This function had an error for rootings along edges descended from the root node for \pkg{phytools}<=0.2-47. This should be fixed in the present version. Now uses \code{\link{paste.tree}}, \code{\link{root}}, and \code{\link{splitTree}} internally. Earlier versions also had an error related to node labels. This should be fixed in \pkg{phytools}>=0.4-47.
+}
+\value{
+ A phylogenetic tree in \code{"phylo"} format.
+}
+\references{
+ Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{splitTree}}, \code{\link{paste.tree}}, \code{\link{root}}
+}
+\keyword{phylogenetics}
+\keyword{utilities}
diff --git a/man/rerootingMethod.Rd b/man/rerootingMethod.Rd
index 088ad96..650c159 100644
--- a/man/rerootingMethod.Rd
+++ b/man/rerootingMethod.Rd
@@ -1,42 +1,42 @@
-\name{rerootingMethod}
-\alias{rerootingMethod}
-\title{Get marginal ancestral state reconstructions by re-rooting}
-\usage{
-rerootingMethod(tree, x, model=c("ER","SYM"), ...)
-}
-\arguments{
- \item{tree}{an object of class \code{"phylo"}.}
- \item{x}{a vector of tip values for species, or a matrix containing the prior probability that the tip is in each state. If \code{x} is a vector, then \code{names(x)} should be the species names. If \code{x} is a matrix of prior probabilities, then rownames should be species names, column names should be states for the discrete character, and rows of the matrix should sum to 1.0.}
- \item{model}{any revsersible model. \code{model=c("ER","SYM")} recommended.}
- \item{...}{optional arguments. Presently the logical argument \code{tips}. If \code{tips=TRUE}, then the function will also compute the empirical Bayes posterior probabilities of the tips following Yang (2006). Note that \code{...} is passed internally to \code{fitMk}, but should be used in this way with caution because any arguments that conflict with the default arguments of the method will cause the function execution to fail. The most practical use of this would be to force a particular value of the transition matrix, \code{Q}, via the argument \code{fixedQ}.}
-}
-\description{
- Computes marginal ancestral states for a discrete character using the re-rooting method of Yang et al. (1995).
-}
-\details{
- This function uses the re-rooting method of Yang et al. (1995) to get the marginal ancestral state estimates for each internal node of the tree using likelihood. This method get the conditional scaled likelihoods for the root node (which is the same as the marginal ancestral state reconstruction for that node) and successively moves the root to each node in the tree. The function can also return the posterior probabilities for the tip nodes of the tree.
-
- \code{rerootingMethod} calls \code{\link{fitMk}} internally. \code{fitMk} uses some code adapted from \code{ace} in the \pkg{ape} package.
-}
-\value{
- An object of class \code{"rerootingMethod"} containing at least the following elements:
- \item{loglik}{the log-likelihood.}
- \item{Q}{the fitted transition matrix between states.}
- \item{marginal.anc}{the marginal ancestral state reconstructions for each node (and, optionally, each tip).}
-}
-\references{
- Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-
- Yang, Z., Kumar, S., Nei, M. (1995) A new method of inference of ancestral nucleotide and amino acid sequences. \emph{Genetics}, \bold{141}, 1641-1650.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{ace}}, \code{\link{fitMk}}, \code{\link{make.simmap}}
-}
-\keyword{phylogenetics}
-\keyword{bayesian}
-\keyword{comparative method}
-\keyword{maximum likelihood}
-\keyword{ancestral states}
+\name{rerootingMethod}
+\alias{rerootingMethod}
+\title{Get marginal ancestral state reconstructions by re-rooting}
+\usage{
+rerootingMethod(tree, x, model=c("ER","SYM"), ...)
+}
+\arguments{
+ \item{tree}{an object of class \code{"phylo"}.}
+ \item{x}{a vector of tip values for species, or a matrix containing the prior probability that the tip is in each state. If \code{x} is a vector, then \code{names(x)} should be the species names. If \code{x} is a matrix of prior probabilities, then rownames should be species names, column names should be states for the discrete character, and rows of the matrix should sum to 1.0.}
+ \item{model}{any revsersible model. \code{model=c("ER","SYM")} recommended.}
+ \item{...}{optional arguments. Presently the logical argument \code{tips}. If \code{tips=TRUE}, then the function will also compute the empirical Bayes posterior probabilities of the tips following Yang (2006). Note that \code{...} is passed internally to \code{fitMk}, but should be used in this way with caution because any arguments that conflict with the default arguments of the method will cause the function execution to fail. The most practical use of this would be to force a particular value of the transition matrix, \code{Q}, via the argument \code{fixedQ}.}
+}
+\description{
+ Computes marginal ancestral states for a discrete character using the re-rooting method of Yang et al. (1995).
+}
+\details{
+ This function uses the re-rooting method of Yang et al. (1995) to get the marginal ancestral state estimates for each internal node of the tree using likelihood. This method get the conditional scaled likelihoods for the root node (which is the same as the marginal ancestral state reconstruction for that node) and successively moves the root to each node in the tree. The function can also return the posterior probabilities for the tip nodes of the tree.
+
+ \code{rerootingMethod} calls \code{\link{fitMk}} internally. \code{fitMk} uses some code adapted from \code{ace} in the \pkg{ape} package.
+}
+\value{
+ An object of class \code{"rerootingMethod"} containing at least the following elements:
+ \item{loglik}{the log-likelihood.}
+ \item{Q}{the fitted transition matrix between states.}
+ \item{marginal.anc}{the marginal ancestral state reconstructions for each node (and, optionally, each tip).}
+}
+\references{
+ Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+
+ Yang, Z., Kumar, S., Nei, M. (1995) A new method of inference of ancestral nucleotide and amino acid sequences. \emph{Genetics}, \bold{141}, 1641-1650.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{ace}}, \code{\link{fitMk}}, \code{\link{make.simmap}}
+}
+\keyword{phylogenetics}
+\keyword{bayesian}
+\keyword{comparative method}
+\keyword{maximum likelihood}
+\keyword{ancestral states}
diff --git a/man/rescale.Rd b/man/rescale.Rd
index 40e7415..59e8849 100644
--- a/man/rescale.Rd
+++ b/man/rescale.Rd
@@ -1,30 +1,30 @@
-\name{rescale}
-\alias{rescale}
-\title{Rescale phylogenetic objects of different types}
-\usage{
-rescale(x, ...)
-}
-\arguments{
- \item{x}{phylogenetic tree object to be rescaled: e.g., object of class \code{"phylo"} or \code{"simmap"}.}
- \item{...}{other arguments to be used in rescaling, dependending on the object class. (E.g., see \code{\link[geiger]{rescale.phylo}} in \pkg{geiger} and \code{\link{rescale.simmap}}.)}
-}
-\description{
- Generic method for rescaling different types of phylogenetic trees.
-}
-\details{
- See \code{\link[geiger]{rescale.phylo}} in \pkg{geiger} and \code{\link{rescale.simmap}} for details.
-}
-\value{
- A rescaled phylogenetic tree object.
-}
-\references{
- Pennell, M.W., J. M. Eastman, G. J. Slater, J. W. Brown, J. C. Uyeda, R. G. FitzJohn, M. E. Alfaro, and L. J. Harmon (2014) geiger v2.0: an expanded suite of methods for fitting macroevolutionary models to phylogenetic trees. \emph{Bioinformatics}, \bold{30}, 2216-2218.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link[geiger]{rescale.phylo}}, \code{\link{rescale.simmap}}
-}
-\keyword{phylogenetics}
-\keyword{utilities}
+\name{rescale}
+\alias{rescale}
+\title{Rescale phylogenetic objects of different types}
+\usage{
+rescale(x, ...)
+}
+\arguments{
+ \item{x}{phylogenetic tree object to be rescaled: e.g., object of class \code{"phylo"} or \code{"simmap"}.}
+ \item{...}{other arguments to be used in rescaling, dependending on the object class. (E.g., see \code{\link[geiger]{rescale.phylo}} in \pkg{geiger} and \code{\link{rescale.simmap}}.)}
+}
+\description{
+ Generic method for rescaling different types of phylogenetic trees.
+}
+\details{
+ See \code{\link[geiger]{rescale.phylo}} in \pkg{geiger} and \code{\link{rescale.simmap}} for details.
+}
+\value{
+ A rescaled phylogenetic tree object.
+}
+\references{
+ Pennell, M.W., J. M. Eastman, G. J. Slater, J. W. Brown, J. C. Uyeda, R. G. FitzJohn, M. E. Alfaro, and L. J. Harmon (2014) geiger v2.0: an expanded suite of methods for fitting macroevolutionary models to phylogenetic trees. \emph{Bioinformatics}, \bold{30}, 2216-2218.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link[geiger]{rescale.phylo}}, \code{\link{rescale.simmap}}
+}
+\keyword{phylogenetics}
+\keyword{utilities}
diff --git a/man/rescaleSimmap.Rd b/man/rescaleSimmap.Rd
index 4a260ea..a3f4586 100644
--- a/man/rescaleSimmap.Rd
+++ b/man/rescaleSimmap.Rd
@@ -1,45 +1,45 @@
-\name{rescale.simmap}
-\alias{rescale.simmap}
-\alias{rescale.multiSimmap}
-\alias{rescaleSimmap}
-\title{Rescale object of class \code{"simmap"}}
-\usage{
-\method{rescale}{simmap}(x, model="depth", ...)
-\method{rescale}{multiSimmap}(x, model="depth", ...)
-rescaleSimmap(tree, ...)
-}
-\arguments{
- \item{x}{object of class \code{"simmap"} or \code{"multiSimmap"} to be rescaled.}
- \item{model}{model to use to rescale the tree. Currently the only option is \code{"depth"}.}
- \item{...}{parameter of the model to use in rescaling. Currently the only parameter is \code{depth} for \code{model="depth"}.}
- \item{tree}{for \code{rescaleSimmap}, object of class \code{"simmap"} to be rescaled.}
-}
-\description{
- Scales a tree with a mapped discrete character (\code{"simmap"} object), or a set of such trees, to an arbitrary total height, preserving the relative time spent in each state along each edge.
-}
-\details{
- Replaces \code{rescaleTree} (now \code{rescale.phylo}) in the \pkg{geiger} package for the \code{"simmap"} object class. \code{rescaleSimmap} is now a redundant alias for the method \code{rescale.simmap}.
-}
-\value{
- An object of class \code{"simmap"} or \code{"multiSimmap"}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{make.simmap}}, \code{\link{read.simmap}}
-}
-\examples{
-## load anoletree
-data(anoletree)
-## rescale to have total depth of 50
-rescaled_anoletree<-rescale(anoletree,depth=50)
-## plot rescaled tree
-plot(rescaled_anoletree,ftype="i",fsize=0.6,
- mar=c(5.1,1.1,1.1,1.1))
-axis(1,at=seq(0,50,by=10))
-par(mar=c(5.1,4.1,4.1,2.1)) ## reset margin to default
-}
-\keyword{phylogenetics}
-\keyword{utilities}
+\name{rescale.simmap}
+\alias{rescale.simmap}
+\alias{rescale.multiSimmap}
+\alias{rescaleSimmap}
+\title{Rescale object of class \code{"simmap"}}
+\usage{
+\method{rescale}{simmap}(x, model="depth", ...)
+\method{rescale}{multiSimmap}(x, model="depth", ...)
+rescaleSimmap(tree, ...)
+}
+\arguments{
+ \item{x}{object of class \code{"simmap"} or \code{"multiSimmap"} to be rescaled.}
+ \item{model}{model to use to rescale the tree. Currently the only option is \code{"depth"}.}
+ \item{...}{parameter of the model to use in rescaling. Currently the only parameter is \code{depth} for \code{model="depth"}.}
+ \item{tree}{for \code{rescaleSimmap}, object of class \code{"simmap"} to be rescaled.}
+}
+\description{
+ Scales a tree with a mapped discrete character (\code{"simmap"} object), or a set of such trees, to an arbitrary total height, preserving the relative time spent in each state along each edge.
+}
+\details{
+ Replaces \code{rescaleTree} (now \code{rescale.phylo}) in the \pkg{geiger} package for the \code{"simmap"} object class. \code{rescaleSimmap} is now a redundant alias for the method \code{rescale.simmap}.
+}
+\value{
+ An object of class \code{"simmap"} or \code{"multiSimmap"}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{make.simmap}}, \code{\link{read.simmap}}
+}
+\examples{
+## load anoletree
+data(anoletree)
+## rescale to have total depth of 50
+rescaled_anoletree<-rescale(anoletree,depth=50)
+## plot rescaled tree
+plot(rescaled_anoletree,ftype="i",fsize=0.6,
+ mar=c(5.1,1.1,1.1,1.1))
+axis(1,at=seq(0,50,by=10))
+par(mar=c(5.1,4.1,4.1,2.1)) ## reset margin to default
+}
+\keyword{phylogenetics}
+\keyword{utilities}
diff --git a/man/resolveNode.Rd b/man/resolveNode.Rd
index 5c25bfc..7baf9d4 100644
--- a/man/resolveNode.Rd
+++ b/man/resolveNode.Rd
@@ -1,34 +1,34 @@
-\name{resolveNode}
-\alias{resolveNode}
-\alias{resolveAllNodes}
-\title{Compute all possible resolutions of a node or all nodes in a multifurcating tree}
-\usage{
-resolveNode(tree,node)
-resolveAllNodes(tree)
-}
-\arguments{
- \item{tree}{an object of class \code{"phylo"}.}
- \item{node}{for \code{resolveNode}, the node with a polytomy to resolve.}
-}
-\description{
- Resolves a single multifurcation or all multifuctions in all possible ways.
-}
-\details{
- This functions resolves a single multifurcation or all multifurcations in a tree in all possible ways. If the input tree has edge lengths, then the resolutions will use internal edges of zero length.
-
- For \code{resolveNode} applied to a multifurcation with \emph{n} descendants, the number of resolved trees will be equal to the number of possible rooted trees of \emph{n} taxa. (For instance, three for a trifurcation, 15 for a quadrifurcation, and so on.)
-
- For \code{resolveAllNodes} the number of fully resolved trees will be equal to the product of numbers for \code{resolveNode} applied to each multifurcation separately. (For instance, 45 for a tree containing one trifurcation and one quadrifurcation.)
-}
-\value{
- An object of class \code{"multiPhylo"} - or, if the input tree is already fully resolved, an object of class \code{"phylo"} indentical to \code{tree}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{multi2di}}
-}
-\keyword{phylogenetics}
-\keyword{utilities}
+\name{resolveNode}
+\alias{resolveNode}
+\alias{resolveAllNodes}
+\title{Compute all possible resolutions of a node or all nodes in a multifurcating tree}
+\usage{
+resolveNode(tree,node)
+resolveAllNodes(tree)
+}
+\arguments{
+ \item{tree}{an object of class \code{"phylo"}.}
+ \item{node}{for \code{resolveNode}, the node with a polytomy to resolve.}
+}
+\description{
+ Resolves a single multifurcation or all multifuctions in all possible ways.
+}
+\details{
+ This functions resolves a single multifurcation or all multifurcations in a tree in all possible ways. If the input tree has edge lengths, then the resolutions will use internal edges of zero length.
+
+ For \code{resolveNode} applied to a multifurcation with \emph{n} descendants, the number of resolved trees will be equal to the number of possible rooted trees of \emph{n} taxa. (For instance, three for a trifurcation, 15 for a quadrifurcation, and so on.)
+
+ For \code{resolveAllNodes} the number of fully resolved trees will be equal to the product of numbers for \code{resolveNode} applied to each multifurcation separately. (For instance, 45 for a tree containing one trifurcation and one quadrifurcation.)
+}
+\value{
+ An object of class \code{"multiPhylo"} - or, if the input tree is already fully resolved, an object of class \code{"phylo"} indentical to \code{tree}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{multi2di}}
+}
+\keyword{phylogenetics}
+\keyword{utilities}
diff --git a/man/rotateNodes.Rd b/man/rotateNodes.Rd
index 205478f..f669a3f 100644
--- a/man/rotateNodes.Rd
+++ b/man/rotateNodes.Rd
@@ -1,36 +1,36 @@
-\name{rotateNodes}
-\alias{rotateNodes}
-\alias{rotate.multi}
-\alias{allRotations}
-\title{Rotates a node or set of nodes in a phylogenetic tree}
-\usage{
-rotateNodes(tree, nodes, polytom=c(1,2), ...)
-rotate.multi(tree, node)
-allRotations(tree)
-}
-\arguments{
- \item{tree}{object of class \code{"phylo"}.}
- \item{nodes}{either a single node number to rotate, a vector of node numbers, or the string \code{"all"}.}
- \item{polytom}{a vector of mode numeric and length two specifying the two clades that should be exchanged in a polytomy (see \code{\link{rotate}}).}
- \item{node}{a single node to rotate (in the case of \code{rotate.multi}).}
- \item{...}{optional arguments.}
-}
-\description{
- The function \code{rotateNodes} is a simple wrapper for \code{\link{rotate}} which rotates a set of nodes or all nodes.
-
- The function \code{rotate.multi} finds all possible rotations around a multifurcating node, given by \code{node}. This will be an object of class \code{"multiPhylo"}, assuming that the node specified is indeed a multifurcation.
-
- The function \code{allRotations} computes all possible rotated trees for a given input phylogeny. For a binary tree, this is generally two raised to the power of the number of internal nodes (so a very large number, if \emph{N} is even modest in size).
-}
-\details{
- All three functions also address the problem that the product of multiple rotations from \code{\link{rotate}} can be non-compliant with the implicit \code{"phylo"} standard because the tip numbers in \code{tree$edge} are not in numerical order \code{1:n} for \code{n} tips.
-}
-\value{
- An object of class \code{"phylo"} (i.e., a phylogenetic tree), in the case of \code{rotateNodes}, or an object of class \code{"multiPhylo"} for \code{rotate.multi} or \code{allRotations}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{phylogenetics}
-\keyword{utilities}
+\name{rotateNodes}
+\alias{rotateNodes}
+\alias{rotate.multi}
+\alias{allRotations}
+\title{Rotates a node or set of nodes in a phylogenetic tree}
+\usage{
+rotateNodes(tree, nodes, polytom=c(1,2), ...)
+rotate.multi(tree, node)
+allRotations(tree)
+}
+\arguments{
+ \item{tree}{object of class \code{"phylo"}.}
+ \item{nodes}{either a single node number to rotate, a vector of node numbers, or the string \code{"all"}.}
+ \item{polytom}{a vector of mode numeric and length two specifying the two clades that should be exchanged in a polytomy (see \code{\link{rotate}}).}
+ \item{node}{a single node to rotate (in the case of \code{rotate.multi}).}
+ \item{...}{optional arguments.}
+}
+\description{
+ The function \code{rotateNodes} is a simple wrapper for \code{\link{rotate}} which rotates a set of nodes or all nodes.
+
+ The function \code{rotate.multi} finds all possible rotations around a multifurcating node, given by \code{node}. This will be an object of class \code{"multiPhylo"}, assuming that the node specified is indeed a multifurcation.
+
+ The function \code{allRotations} computes all possible rotated trees for a given input phylogeny. For a binary tree, this is generally two raised to the power of the number of internal nodes (so a very large number, if \emph{N} is even modest in size).
+}
+\details{
+ All three functions also address the problem that the product of multiple rotations from \code{\link{rotate}} can be non-compliant with the implicit \code{"phylo"} standard because the tip numbers in \code{tree$edge} are not in numerical order \code{1:n} for \code{n} tips.
+}
+\value{
+ An object of class \code{"phylo"} (i.e., a phylogenetic tree), in the case of \code{rotateNodes}, or an object of class \code{"multiPhylo"} for \code{rotate.multi} or \code{allRotations}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{phylogenetics}
+\keyword{utilities}
diff --git a/man/roundBranches.Rd b/man/roundBranches.Rd
index 73dd930..abfeb31 100644
--- a/man/roundBranches.Rd
+++ b/man/roundBranches.Rd
@@ -1,26 +1,26 @@
-\name{roundBranches}
-\alias{roundBranches}
-\title{Rounds the branch lengths of a tree}
-\usage{
-roundBranches(tree, digits)
-}
-\arguments{
- \item{tree}{an object of class \code{"phylo"}, \code{"multiPhylo"}, \code{"simmap"}, or \code{"multiSimmap"}.}
- \item{digits}{number of digits for rounding. Passed to \code{\link{round}}.}
-}
-\description{
- Rounds the branch lengths of a phylogenetic tree.
-
-}
-\details{
- This function rounds the branch lengths of a tree or trees to a precision indicated by \code{digits}, and reconciles any mappings for objects of class \code{"simmap"} or \code{"multiSimmap"}.
-}
-\value{
- An object of class \code{"phylo"}, \code{"multiPhylo"}, \code{"simmap"}, or \code{"multiSimmap"}, with rounded edge lengths.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{phylogenetics}
-\keyword{utilities}
+\name{roundBranches}
+\alias{roundBranches}
+\title{Rounds the branch lengths of a tree}
+\usage{
+roundBranches(tree, digits)
+}
+\arguments{
+ \item{tree}{an object of class \code{"phylo"}, \code{"multiPhylo"}, \code{"simmap"}, or \code{"multiSimmap"}.}
+ \item{digits}{number of digits for rounding. Passed to \code{\link{round}}.}
+}
+\description{
+ Rounds the branch lengths of a phylogenetic tree.
+
+}
+\details{
+ This function rounds the branch lengths of a tree or trees to a precision indicated by \code{digits}, and reconciles any mappings for objects of class \code{"simmap"} or \code{"multiSimmap"}.
+}
+\value{
+ An object of class \code{"phylo"}, \code{"multiPhylo"}, \code{"simmap"}, or \code{"multiSimmap"}, with rounded edge lengths.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{phylogenetics}
+\keyword{utilities}
diff --git a/man/roundPhylogram.Rd b/man/roundPhylogram.Rd
index a4b14f8..aac4b10 100644
--- a/man/roundPhylogram.Rd
+++ b/man/roundPhylogram.Rd
@@ -1,56 +1,56 @@
-\name{roundPhylogram}
-\alias{roundPhylogram}
-\alias{sigmoidPhylogram}
-\alias{splinePhylogram}
-\title{Plot a round, sigmoidal, or spline phylogram or cladogram}
-\usage{
-roundPhylogram(tree, fsize=1.0, ftype="reg", lwd=2, mar=NULL, offset=NULL,
- direction="rightwards", type="phylogram", xlim=NULL, ylim=NULL, ...)
-sigmoidPhylogram(tree, ...)
-splinePhylogram(tree, ...)
-}
-\arguments{
- \item{tree}{an object of class "phylo" or "multiPhylo" containing one or multiple phylogenies.}
- \item{fsize}{relative font size for tip labels.}
- \item{ftype}{font type - options are \code{"reg"}, \code{"i"} (italics), \code{"b"} (bold), or \code{"bi"} (bold-italics).}
- \item{lwd}{line width for plotting.}
- \item{mar}{vector containing the margins for the plot to be passed to \code{\link{par}}. If not specified, the default margins are [0.1,0.1,0.1,0.1].}
- \item{offset}{offset for the tip labels.}
- \item{direction}{plotting direction. Only the option \code{direction="rightwards"} is presently supported.}
- \item{type}{plot type. Can be \code{"phylogram"} or \code{"cladogram"}. If \code{type="cladogram"} then the branch lengths are not necessary (and, indeed, are not used).}
- \item{xlim}{x-limits for the plot.}
- \item{ylim}{y-limits for the plot.}
- \item{...}{optional arguments. In the case of \code{roundPhylogram}, these are mostly as in \code{\link{plotTree}} and \code{\link{plotSimmap}}.}
-}
-\description{
- Plots one or multiple round phylograms, a sigmoidal phylogram or cladogram, or a phylogram draw using cubic splines through the nodes.
-}
-\details{
- The underscore character \code{"_"} is automatically swapped for a space in tip labels, as in \code{\link{plotSimmap}}.
-}
-\value{
- Plots a tree.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{plotSimmap}}, \code{\link{plotTree}}
-}
-\examples{
-## load mammal.tree
-data(mammal.tree)
-## plot using roundPhylogram
-roundPhylogram(compute.brlen(mammal.tree),
- fsize=0.8,ftype="i")
-## load anoletree
-data(anoletree)
-## plot using sigmoidPhylogram
-sigmoidPhylogram(anoletree,fsize=0.6,
- ftype="i",direction="upwards")
-par(mar=c(5.1,4.1,4.1,2.1)) ## reset margin to default
-}
-\keyword{phylogenetics}
-\keyword{plotting}
-\keyword{comparative method}
+\name{roundPhylogram}
+\alias{roundPhylogram}
+\alias{sigmoidPhylogram}
+\alias{splinePhylogram}
+\title{Plot a round, sigmoidal, or spline phylogram or cladogram}
+\usage{
+roundPhylogram(tree, fsize=1.0, ftype="reg", lwd=2, mar=NULL, offset=NULL,
+ direction="rightwards", type="phylogram", xlim=NULL, ylim=NULL, ...)
+sigmoidPhylogram(tree, ...)
+splinePhylogram(tree, ...)
+}
+\arguments{
+ \item{tree}{an object of class "phylo" or "multiPhylo" containing one or multiple phylogenies.}
+ \item{fsize}{relative font size for tip labels.}
+ \item{ftype}{font type - options are \code{"reg"}, \code{"i"} (italics), \code{"b"} (bold), or \code{"bi"} (bold-italics).}
+ \item{lwd}{line width for plotting.}
+ \item{mar}{vector containing the margins for the plot to be passed to \code{\link{par}}. If not specified, the default margins are [0.1,0.1,0.1,0.1].}
+ \item{offset}{offset for the tip labels.}
+ \item{direction}{plotting direction. Only the option \code{direction="rightwards"} is presently supported.}
+ \item{type}{plot type. Can be \code{"phylogram"} or \code{"cladogram"}. If \code{type="cladogram"} then the branch lengths are not necessary (and, indeed, are not used).}
+ \item{xlim}{x-limits for the plot.}
+ \item{ylim}{y-limits for the plot.}
+ \item{...}{optional arguments. In the case of \code{roundPhylogram}, these are mostly as in \code{\link{plotTree}} and \code{\link{plotSimmap}}.}
+}
+\description{
+ Plots one or multiple round phylograms, a sigmoidal phylogram or cladogram, or a phylogram draw using cubic splines through the nodes.
+}
+\details{
+ The underscore character \code{"_"} is automatically swapped for a space in tip labels, as in \code{\link{plotSimmap}}.
+}
+\value{
+ Plots a tree.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{plotSimmap}}, \code{\link{plotTree}}
+}
+\examples{
+## load mammal.tree
+data(mammal.tree)
+## plot using roundPhylogram
+roundPhylogram(compute.brlen(mammal.tree),
+ fsize=0.8,ftype="i")
+## load anoletree
+data(anoletree)
+## plot using sigmoidPhylogram
+sigmoidPhylogram(anoletree,fsize=0.6,
+ ftype="i",direction="upwards")
+par(mar=c(5.1,4.1,4.1,2.1)) ## reset margin to default
+}
+\keyword{phylogenetics}
+\keyword{plotting}
+\keyword{comparative method}
diff --git a/man/rstate.Rd b/man/rstate.Rd
index 5b433e9..94bd640 100644
--- a/man/rstate.Rd
+++ b/man/rstate.Rd
@@ -1,27 +1,27 @@
-\name{rstate}
-\alias{rstate}
-\title{Pick a random state according to a vector of probabilities}
-\usage{
-rstate(y)
-}
-\arguments{
- \item{y}{vector of probabilities. Must have names & should probably add to \code{1.0}.}
-}
-\description{
- Internal function for \code{\link{make.simmap}}.
-}
-\details{
- This function picks a random element in a vector according to the probability assigned that element. It returns the name. Uses \code{\link{rmultinom}}.
-}
-\value{
- A character or string.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{math}
-\keyword{utilities}
-\keyword{statistics}
-\keyword{discrete character}
-\keyword{simulation}
+\name{rstate}
+\alias{rstate}
+\title{Pick a random state according to a vector of probabilities}
+\usage{
+rstate(y)
+}
+\arguments{
+ \item{y}{vector of probabilities. Must have names & should probably add to \code{1.0}.}
+}
+\description{
+ Internal function for \code{\link{make.simmap}}.
+}
+\details{
+ This function picks a random element in a vector according to the probability assigned that element. It returns the name. Uses \code{\link{rmultinom}}.
+}
+\value{
+ A character or string.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{math}
+\keyword{utilities}
+\keyword{statistics}
+\keyword{discrete character}
+\keyword{simulation}
diff --git a/man/sampleFrom.Rd b/man/sampleFrom.Rd
index 20a89b5..80b8585 100644
--- a/man/sampleFrom.Rd
+++ b/man/sampleFrom.Rd
@@ -1,26 +1,26 @@
-\name{sampleFrom}
-\alias{sampleFrom}
-\title{Sample from a set of distributions}
-\usage{
-sampleFrom(xbar=0, xvar=1, n=1, randn=NULL, type="norm")
-}
-\arguments{
- \item{xbar}{a named vector of means.}
- \item{xvar}{a named vector of variances.}
- \item{n}{a vector containing the sample sizes of each species.}
- \item{randn}{a range of sample sizes are to be random.}
- \item{type}{\code{"norm"} is the only distribution implemented so far.}
-}
-\description{
- Samples from a set of normal distributions with parameters given in \code{xbar} and \code{xvar}.
-}
-\value{
- A vector, with labels.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{phylogenetics}
-\keyword{statistics}
-\keyword{utilities}
+\name{sampleFrom}
+\alias{sampleFrom}
+\title{Sample from a set of distributions}
+\usage{
+sampleFrom(xbar=0, xvar=1, n=1, randn=NULL, type="norm")
+}
+\arguments{
+ \item{xbar}{a named vector of means.}
+ \item{xvar}{a named vector of variances.}
+ \item{n}{a vector containing the sample sizes of each species.}
+ \item{randn}{a range of sample sizes are to be random.}
+ \item{type}{\code{"norm"} is the only distribution implemented so far.}
+}
+\description{
+ Samples from a set of normal distributions with parameters given in \code{xbar} and \code{xvar}.
+}
+\value{
+ A vector, with labels.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{phylogenetics}
+\keyword{statistics}
+\keyword{utilities}
diff --git a/man/setMap.Rd b/man/setMap.Rd
index f386b11..5ed7519 100644
--- a/man/setMap.Rd
+++ b/man/setMap.Rd
@@ -1,36 +1,36 @@
-\name{setMap}
-\alias{setMap}
-\alias{setMap.contMap}
-\alias{setMap.densityMap}
-\alias{setMap.phyloScattergram}
-\alias{setMap.multirateBM_plot}
-\title{Set color map for various phylogenetic objects of classes}
-\usage{
-setMap(x, ...)
-\method{setMap}{contMap}(x, ...)
-\method{setMap}{densityMap}(x, ...)
-\method{setMap}{phyloScattergram}(x, ...)
-\method{setMap}{multirateBM_plot}(x, ...)
-}
-\arguments{
- \item{x}{an object of class \code{"contMap"}, \code{"densityMap"}, \code{"phyloScattergram"}, or \code{"multirateBM_plot"}.}
- \item{...}{arguments to be passed to \code{\link{colorRampPalette}}. Also, the argument \code{invert} which (if \code{invert=TRUE}) will just flip the current color ramp.}
-}
-\description{
- Changes the color map (ramp) in an object of class \code{"contMap"}, \code{"densityMap"}, \code{"phyloScattergram"}, or \code{"multirateBM_plot"}.
-}
-\value{
- An object of class \code{"contMap"}, \code{"densityMap"}, \code{"phyloScattergram"}, or \code{"multirateBM_plot"}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-
- Revell, L. J. 2013. Two new graphical methods for mapping trait evolution on phylogenies. \emph{Methods in Ecology and Evolution}, \bold{4}, 754-759.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{contMap}}, \code{\link{densityMap}}, \code{\link{multirateBM}}
-}
-\keyword{phylogenetics}
-\keyword{plotting}
-
+\name{setMap}
+\alias{setMap}
+\alias{setMap.contMap}
+\alias{setMap.densityMap}
+\alias{setMap.phyloScattergram}
+\alias{setMap.multirateBM_plot}
+\title{Set color map for various phylogenetic objects of classes}
+\usage{
+setMap(x, ...)
+\method{setMap}{contMap}(x, ...)
+\method{setMap}{densityMap}(x, ...)
+\method{setMap}{phyloScattergram}(x, ...)
+\method{setMap}{multirateBM_plot}(x, ...)
+}
+\arguments{
+ \item{x}{an object of class \code{"contMap"}, \code{"densityMap"}, \code{"phyloScattergram"}, or \code{"multirateBM_plot"}.}
+ \item{...}{arguments to be passed to \code{\link{colorRampPalette}}. Also, the argument \code{invert} which (if \code{invert=TRUE}) will just flip the current color ramp.}
+}
+\description{
+ Changes the color map (ramp) in an object of class \code{"contMap"}, \code{"densityMap"}, \code{"phyloScattergram"}, or \code{"multirateBM_plot"}.
+}
+\value{
+ An object of class \code{"contMap"}, \code{"densityMap"}, \code{"phyloScattergram"}, or \code{"multirateBM_plot"}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+
+ Revell, L. J. 2013. Two new graphical methods for mapping trait evolution on phylogenies. \emph{Methods in Ecology and Evolution}, \bold{4}, 754-759.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{contMap}}, \code{\link{densityMap}}, \code{\link{multirateBM}}
+}
+\keyword{phylogenetics}
+\keyword{plotting}
+
diff --git a/man/sim.corrs.Rd b/man/sim.corrs.Rd
index 542ca8f..65d3eeb 100644
--- a/man/sim.corrs.Rd
+++ b/man/sim.corrs.Rd
@@ -1,36 +1,36 @@
-\name{sim.corrs}
-\alias{sim.corrs}
-\title{Multivariate Brownian simulation with multiple correlations and rates}
-\usage{
-sim.corrs(tree, vcv, anc=NULL, internal=FALSE)
-}
-\arguments{
- \item{tree}{is a phylogenetic tree in 'phylo' format; or a modified 'phylo' tree with a mapped discrete character.}
- \item{vcv}{is a square covariance matrix or named list of matrices (one for each mapped state on the tree).}
- \item{anc}{optional vector of values for the root state.}
- \item{internal}{logical value indicating whether to return states at internal nodes.}
- }
-\description{
- Simulates multivariate Brownian motion evolution on a tree with multiple evolutionary correlation/covariance matrices.
-}
-\details{
- This function conducts BM simulation on a tree with multiple rates and/or multiple evolutionary correlations between characters.
-
- If \code{vcv} is a single matrix, instead of a list of matrices, \code{sim.corrs} will simulate multivariate BM with a single rate matrix.
-}
-\value{
- A matrix containing the multivariate tip states for the \code{n} species in the tree (and nodes if \code{internal=} \code{TRUE}).
-}
-\references{
- Revell, L. J., and D. C. Collar (2009) Phylogenetic analysis of the evolutionary correlation using likelihood. \emph{Evolution}, \bold{63}, 1090-1100.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{fastBM}}, \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{sim.history}}, \code{\link{sim.rates}}
-}
-\keyword{phylogenetics}
-\keyword{simulation}
-\keyword{comparative method}
-\keyword{continuous character}
+\name{sim.corrs}
+\alias{sim.corrs}
+\title{Multivariate Brownian simulation with multiple correlations and rates}
+\usage{
+sim.corrs(tree, vcv, anc=NULL, internal=FALSE)
+}
+\arguments{
+ \item{tree}{is a phylogenetic tree in 'phylo' format; or a modified 'phylo' tree with a mapped discrete character.}
+ \item{vcv}{is a square covariance matrix or named list of matrices (one for each mapped state on the tree).}
+ \item{anc}{optional vector of values for the root state.}
+ \item{internal}{logical value indicating whether to return states at internal nodes.}
+ }
+\description{
+ Simulates multivariate Brownian motion evolution on a tree with multiple evolutionary correlation/covariance matrices.
+}
+\details{
+ This function conducts BM simulation on a tree with multiple rates and/or multiple evolutionary correlations between characters.
+
+ If \code{vcv} is a single matrix, instead of a list of matrices, \code{sim.corrs} will simulate multivariate BM with a single rate matrix.
+}
+\value{
+ A matrix containing the multivariate tip states for the \code{n} species in the tree (and nodes if \code{internal=} \code{TRUE}).
+}
+\references{
+ Revell, L. J., and D. C. Collar (2009) Phylogenetic analysis of the evolutionary correlation using likelihood. \emph{Evolution}, \bold{63}, 1090-1100.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{fastBM}}, \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{sim.history}}, \code{\link{sim.rates}}
+}
+\keyword{phylogenetics}
+\keyword{simulation}
+\keyword{comparative method}
+\keyword{continuous character}
diff --git a/man/sim.history.Rd b/man/sim.history.Rd
index 7383395..94f2365 100644
--- a/man/sim.history.Rd
+++ b/man/sim.history.Rd
@@ -1,44 +1,44 @@
-\name{sim.history}
-\alias{sim.history}
-\alias{sim.Mk}
-\alias{sim.multiMk}
-\title{Simulate character history or a discrete character at the tips of the tree under some model}
-\usage{
-sim.history(tree, Q, anc=NULL, nsim=1,
- direction=c("column_to_row","row_to_column"), ...)
-sim.Mk(tree, Q, anc=NULL, nsim=1, ...)
-sim.multiMk(tree, Q, anc=NULL, nsim=1, ...)
-}
-\arguments{
- \item{tree}{a phylogenetic tree as an object of class \code{"phylo"}. For the case of \code{sim.multiMk} \code{tree} should be an object of class \code{"simmap"} in which the regimes for simulation have been mapped onto the tree.}
- \item{Q}{a matrix containing the instantaneous transition rates between states. Note that for \code{sim.history} \emph{by default} (i.e., when \code{direction="column_to_row"}, see below) normally this is the \emph{transpose} of the matrix produced by \code{fitDiscrete} in the \pkg{geiger} package or \code{\link{make.simmap}} in \pkg{phytools}; that is to say the transition rate from \code{i -> j} should be given by \code{Q[j,i]}. However, if your matrix is properly conformed (i.e., rows \emph{or} columns sum to 0), then \code{sim.history} will attempt to transpose your matrix correctly & will return an informative message (if \code{message=TRUE}, see below). For \code{sim.Mk} and \code{sim.multiMk} this matrix has the same conformation as in \code{fitContinuous} and \code{make.simmap}. For \code{sim.multiMk} \code{Q} should be a list of transition matrices with names that correspond to the states mapped onto the tree.}
- \item{anc}{an optional value for the state at the root node; if \code{NULL}, a random state will be assigned. \code{anc} can be a vector of states, in which one of the states will be chosen randomly for each simulation. For \code{sim.history} \code{anc} can be a vector of probabilities with names, in which case a state will be chosen in proportion to the given probabilities.}
- \item{nsim}{number of simulations.}
- \item{direction}{row/column direction of the input transition matrix, \code{Q}. \code{direction="column_to_row"} indicates that the transition rate from \code{i -> j} should be given by \code{Q[j,i]}, while \code{direction="row_to_column"} indicates the converse.}
- \item{...}{other optional arguments. Currently only \code{message}, a logical value indicating whether or not to turn on informational messages (defaults to \code{message=TRUE}).}
-}
-\description{
- Simulates discrete character evolution on a phylogenetic tree.
-}
-\details{
- The function \code{sim.history} simulates a stochastic character history for a discretely valued character trait on the tree. The resultant tree is stored as a modified \code{"phylo"} object in stochastic character map (e.g., \code{\link{make.simmap}}) format.
-
- The function \code{sim.Mk} simulates the states for a discrete character at the tips of the tree only.
-
- Finally, the function \code{sim.multiMk} is the same as \code{sim.Mk} except that it permits the user to simulate under different values of \code{Q} in different parts of the tree.
-}
-\value{
- \code{sim.history} returns an object of class \code{"simmap"} (a tree with a mapped discrete character) or \code{"multiSimmap"} for <code>nsim</code> greater than one.
-
- \code{sim.Mk} and \code{sim.multiMk} return a factor with the states of our discrete character at the tips of the tree only.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{fitMk}}, \code{\link{fitmultiMk}}, \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{plotSimmap}}, \code{\link{sim.rates}}
-}
-\keyword{phylogenetics}
-\keyword{simulation}
-\keyword{discrete character}
+\name{sim.history}
+\alias{sim.history}
+\alias{sim.Mk}
+\alias{sim.multiMk}
+\title{Simulate character history or a discrete character at the tips of the tree under some model}
+\usage{
+sim.history(tree, Q, anc=NULL, nsim=1,
+ direction=c("column_to_row","row_to_column"), ...)
+sim.Mk(tree, Q, anc=NULL, nsim=1, ...)
+sim.multiMk(tree, Q, anc=NULL, nsim=1, ...)
+}
+\arguments{
+ \item{tree}{a phylogenetic tree as an object of class \code{"phylo"}. For the case of \code{sim.multiMk} \code{tree} should be an object of class \code{"simmap"} in which the regimes for simulation have been mapped onto the tree.}
+ \item{Q}{a matrix containing the instantaneous transition rates between states. Note that for \code{sim.history} \emph{by default} (i.e., when \code{direction="column_to_row"}, see below) normally this is the \emph{transpose} of the matrix produced by \code{fitDiscrete} in the \pkg{geiger} package or \code{\link{make.simmap}} in \pkg{phytools}; that is to say the transition rate from \code{i -> j} should be given by \code{Q[j,i]}. However, if your matrix is properly conformed (i.e., rows \emph{or} columns sum to 0), then \code{sim.history} will attempt to transpose your matrix correctly & will return an informative message (if \code{message=TRUE}, see below). For \code{sim.Mk} and \code{sim.multiMk} this matrix has the same conformation as in \code{fitContinuous} and \code{make.simmap}. For \code{sim.multiMk} \code{Q} should be a list of transition matrices with names that correspond to the states mapped onto the tree.}
+ \item{anc}{an optional value for the state at the root node; if \code{NULL}, a random state will be assigned. \code{anc} can be a vector of states, in which one of the states will be chosen randomly for each simulation. For \code{sim.history} \code{anc} can be a vector of probabilities with names, in which case a state will be chosen in proportion to the given probabilities.}
+ \item{nsim}{number of simulations.}
+ \item{direction}{row/column direction of the input transition matrix, \code{Q}. \code{direction="column_to_row"} indicates that the transition rate from \code{i -> j} should be given by \code{Q[j,i]}, while \code{direction="row_to_column"} indicates the converse.}
+ \item{...}{other optional arguments. Currently only \code{message}, a logical value indicating whether or not to turn on informational messages (defaults to \code{message=TRUE}).}
+}
+\description{
+ Simulates discrete character evolution on a phylogenetic tree.
+}
+\details{
+ The function \code{sim.history} simulates a stochastic character history for a discretely valued character trait on the tree. The resultant tree is stored as a modified \code{"phylo"} object in stochastic character map (e.g., \code{\link{make.simmap}}) format.
+
+ The function \code{sim.Mk} simulates the states for a discrete character at the tips of the tree only.
+
+ Finally, the function \code{sim.multiMk} is the same as \code{sim.Mk} except that it permits the user to simulate under different values of \code{Q} in different parts of the tree.
+}
+\value{
+ \code{sim.history} returns an object of class \code{"simmap"} (a tree with a mapped discrete character) or \code{"multiSimmap"} for <code>nsim</code> greater than one.
+
+ \code{sim.Mk} and \code{sim.multiMk} return a factor with the states of our discrete character at the tips of the tree only.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{fitMk}}, \code{\link{fitmultiMk}}, \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{plotSimmap}}, \code{\link{sim.rates}}
+}
+\keyword{phylogenetics}
+\keyword{simulation}
+\keyword{discrete character}
diff --git a/man/sim.ratebystate.Rd b/man/sim.ratebystate.Rd
index 83d8d64..7b40803 100644
--- a/man/sim.ratebystate.Rd
+++ b/man/sim.ratebystate.Rd
@@ -1,35 +1,35 @@
-\name{sim.ratebystate}
-\alias{sim.ratebystate}
-\title{Conduct simulation of state dependent rate variation}
-\usage{
-sim.ratebystate(tree, sig2x=1, sig2y=1, beta=c(0,1), ...)
-}
-\arguments{
- \item{tree}{phylogenetic tree.}
- \item{sig2x}{variance of the Brownian process of evolution for \emph{x}, \eqn{\sigma_x^2}.}
- \item{sig2y}{variance of the Brownian process of evolution for \emph{y} when \code{x-min(x)==1} (for \code{logarithm=FALSE}) or \code{x==0} (for \code{logarithm=TRUE}).}
- \item{beta}{intercept and slope of the relationship between the value of \emph{x} and the Brownian rate in \emph{y}.}
- \item{...}{optional arguments which include \code{method} (\code{"by.node"} or \code{"by.branch"} indicating whether to assume the rate varies as a function of the node state or the mean branch state); \code{plot}, a logical value indicating whether or not to plot a phenogram with the branches used for simulation of \code{y} after rescaling by the state of \code{x}; and \code{logarithm}, a logical value indicating whether or not simulate changes in the variance of Brownian evolution for \code{y} as an additive \code{logarithm=FALSE} or multiplicative function of \code{x}. The default is \code{logarithm=FALSE}.}
-}
-\description{
- Simulates two characters under a model in which the rate of one depends on the state of the other.
-}
-\details{
- This function attempts to simulate two characters under a model in which the rate of evolution for the second (\emph{y}) depends on the states for the first (\emph{x}).
-
- See \code{\link{ratebystate}} for more details.
-}
-\value{
- This function returns a matrix.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{fastBM}}, \code{\link{ratebystate}}
-}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{simulation}
-\keyword{continuous character}
+\name{sim.ratebystate}
+\alias{sim.ratebystate}
+\title{Conduct simulation of state dependent rate variation}
+\usage{
+sim.ratebystate(tree, sig2x=1, sig2y=1, beta=c(0,1), ...)
+}
+\arguments{
+ \item{tree}{phylogenetic tree.}
+ \item{sig2x}{variance of the Brownian process of evolution for \emph{x}, \eqn{\sigma_x^2}.}
+ \item{sig2y}{variance of the Brownian process of evolution for \emph{y} when \code{x-min(x)==1} (for \code{logarithm=FALSE}) or \code{x==0} (for \code{logarithm=TRUE}).}
+ \item{beta}{intercept and slope of the relationship between the value of \emph{x} and the Brownian rate in \emph{y}.}
+ \item{...}{optional arguments which include \code{method} (\code{"by.node"} or \code{"by.branch"} indicating whether to assume the rate varies as a function of the node state or the mean branch state); \code{plot}, a logical value indicating whether or not to plot a phenogram with the branches used for simulation of \code{y} after rescaling by the state of \code{x}; and \code{logarithm}, a logical value indicating whether or not simulate changes in the variance of Brownian evolution for \code{y} as an additive \code{logarithm=FALSE} or multiplicative function of \code{x}. The default is \code{logarithm=FALSE}.}
+}
+\description{
+ Simulates two characters under a model in which the rate of one depends on the state of the other.
+}
+\details{
+ This function attempts to simulate two characters under a model in which the rate of evolution for the second (\emph{y}) depends on the states for the first (\emph{x}).
+
+ See \code{\link{ratebystate}} for more details.
+}
+\value{
+ This function returns a matrix.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{fastBM}}, \code{\link{ratebystate}}
+}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{simulation}
+\keyword{continuous character}
diff --git a/man/sim.rates.Rd b/man/sim.rates.Rd
index 14d5e0a..963b7fe 100644
--- a/man/sim.rates.Rd
+++ b/man/sim.rates.Rd
@@ -1,42 +1,42 @@
-\name{sim.rates}
-\alias{sim.rates}
-\alias{multiOU}
-\title{Brownian or OU simulation with multiple evolutionary regimes}
-\usage{
-sim.rates(tree, sig2, anc=0, nsim=1, internal=FALSE, plot=FALSE)
-multiOU(tree, alpha, sig2, theta=NULL, a0=NULL, nsim=1, internal=FALSE, ...)
-}
-\arguments{
- \item{tree}{is a stochastic map format phylogenetic tree in modified \code{"phylo"} format (e.g., see \code{\link{make.simmap}}).}
- \item{sig2}{a named vector containing the rates for each state; names should be states in \code{mtree}.}
- \item{anc}{optional value for the root state.}
- \item{nsim}{number of simulations.}
- \item{internal}{logical value indicating whether to return states at internal nodes.}
- \item{plot}{logical value indicating whether or not to visual the rate heterogeneity (default value is \code{FALSE}.}
- \item{alpha}{single value or vector of values of the OU \eqn{\alpha} parameter.}
- \item{theta}{single value or vector of values of the OU \eqn{\theta} parameter.}
- \item{a0}{optional value of the root state. Defaults to zero.}
- \item{...}{optional arguments.}
-}
-\description{
- Simulates multi-rate or multi-regime continuous trait evolution on a phylogeny.
-}
-\details{
- The function \code{sim.rates} conducts BM simulation on a tree with multiple rates.
-
- The function \code{multiOU} conducts multi-regime OU simulations on the tree under a range of conditions. \code{multiOU} uses a difference equation approximation of the OU process.
-}
-\value{
- A vector (for \code{nsim=1}) or matrix containing the tip states for the \code{n} species in the tree.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{fastBM}}, \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{sim.history}}
-}
-\keyword{phylogenetics}
-\keyword{simulation}
-\keyword{comparative method}
-\keyword{continuous character}
+\name{sim.rates}
+\alias{sim.rates}
+\alias{multiOU}
+\title{Brownian or OU simulation with multiple evolutionary regimes}
+\usage{
+sim.rates(tree, sig2, anc=0, nsim=1, internal=FALSE, plot=FALSE)
+multiOU(tree, alpha, sig2, theta=NULL, a0=NULL, nsim=1, internal=FALSE, ...)
+}
+\arguments{
+ \item{tree}{is a stochastic map format phylogenetic tree in modified \code{"phylo"} format (e.g., see \code{\link{make.simmap}}).}
+ \item{sig2}{a named vector containing the rates for each state; names should be states in \code{mtree}.}
+ \item{anc}{optional value for the root state.}
+ \item{nsim}{number of simulations.}
+ \item{internal}{logical value indicating whether to return states at internal nodes.}
+ \item{plot}{logical value indicating whether or not to visual the rate heterogeneity (default value is \code{FALSE}.}
+ \item{alpha}{single value or vector of values of the OU \eqn{\alpha} parameter.}
+ \item{theta}{single value or vector of values of the OU \eqn{\theta} parameter.}
+ \item{a0}{optional value of the root state. Defaults to zero.}
+ \item{...}{optional arguments.}
+}
+\description{
+ Simulates multi-rate or multi-regime continuous trait evolution on a phylogeny.
+}
+\details{
+ The function \code{sim.rates} conducts BM simulation on a tree with multiple rates.
+
+ The function \code{multiOU} conducts multi-regime OU simulations on the tree under a range of conditions. \code{multiOU} uses a difference equation approximation of the OU process.
+}
+\value{
+ A vector (for \code{nsim=1}) or matrix containing the tip states for the \code{n} species in the tree.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{fastBM}}, \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{sim.history}}
+}
+\keyword{phylogenetics}
+\keyword{simulation}
+\keyword{comparative method}
+\keyword{continuous character}
diff --git a/man/simBMphylo.Rd b/man/simBMphylo.Rd
index 194d171..14fb323 100644
--- a/man/simBMphylo.Rd
+++ b/man/simBMphylo.Rd
@@ -1,43 +1,43 @@
-\name{simBMphylo}
-\alias{simBMphylo}
-\alias{plot.simBMphylo}
-\title{Creates a graphical illustration of Brownian motion evolution on a phylogeny}
-\usage{
-simBMphylo(n, t, sig2, plot=TRUE, ...)
-\method{plot}{simBMphylo}(x, ...)
-}
-\arguments{
- \item{n}{number of taxa to simulate in the output tree.}
- \item{t}{total time for the simulation.}
- \item{sig2}{the rate of evolution under Brownian motion, \eqn{\sigma^2}, or a vector of rates. If the latter the length of the vector must exactly match \code{t}, otherwise the first element of \code{sig2} will just be duplicated \code{t} times.}
- \item{plot}{optional logical value indicating whether or not the simulated object should be plotted.}
- \item{...}{optional arguments to be passed to the \code{plot} method.}
- \item{x}{in \code{plot} method, object of class \code{"simBMphylo"}.}
-}
-\description{
- Simulates a discrete time phylogeny and Brownian motion trait, and generates a plot.
-}
-\details{
- The function simulates a discrete-time pure-birth phylogeny (for fixed \emph{N} and \emph{t} using rejection sampling) and then discrete-time Brownian motion on that tree. It then proceeds to generating a plot of the results.
-}
-\value{
- An object of class \code{"simBMphylo"} or a plot.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{bmPlot}}, \code{\link{fastBM}}, \code{\link{pbtree}}
-}
-\examples{
-set.seed(777)
-simBMphylo(n=6,t=100,sig2=0.01)
-## reset par to defaults
-par(mfrow=c(1,1))
-par(mar=c(5.1,4.1,4.1,2.1))
-}
-\keyword{comparative method}
-\keyword{phylogenetics}
-\keyword{plotting}
-\keyword{continuous character}
+\name{simBMphylo}
+\alias{simBMphylo}
+\alias{plot.simBMphylo}
+\title{Creates a graphical illustration of Brownian motion evolution on a phylogeny}
+\usage{
+simBMphylo(n, t, sig2, plot=TRUE, ...)
+\method{plot}{simBMphylo}(x, ...)
+}
+\arguments{
+ \item{n}{number of taxa to simulate in the output tree.}
+ \item{t}{total time for the simulation.}
+ \item{sig2}{the rate of evolution under Brownian motion, \eqn{\sigma^2}, or a vector of rates. If the latter the length of the vector must exactly match \code{t}, otherwise the first element of \code{sig2} will just be duplicated \code{t} times.}
+ \item{plot}{optional logical value indicating whether or not the simulated object should be plotted.}
+ \item{...}{optional arguments to be passed to the \code{plot} method.}
+ \item{x}{in \code{plot} method, object of class \code{"simBMphylo"}.}
+}
+\description{
+ Simulates a discrete time phylogeny and Brownian motion trait, and generates a plot.
+}
+\details{
+ The function simulates a discrete-time pure-birth phylogeny (for fixed \emph{N} and \emph{t} using rejection sampling) and then discrete-time Brownian motion on that tree. It then proceeds to generating a plot of the results.
+}
+\value{
+ An object of class \code{"simBMphylo"} or a plot.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{bmPlot}}, \code{\link{fastBM}}, \code{\link{pbtree}}
+}
+\examples{
+set.seed(777)
+simBMphylo(n=6,t=100,sig2=0.01)
+## reset par to defaults
+par(mfrow=c(1,1))
+par(mar=c(5.1,4.1,4.1,2.1))
+}
+\keyword{comparative method}
+\keyword{phylogenetics}
+\keyword{plotting}
+\keyword{continuous character}
diff --git a/man/skewers.Rd b/man/skewers.Rd
index 16340a3..a34704d 100644
--- a/man/skewers.Rd
+++ b/man/skewers.Rd
@@ -1,33 +1,33 @@
-\name{skewers}
-\alias{skewers}
-\title{Matrix comparison using the method of random skewers}
-\usage{
-skewers(X, Y, nsim=100, method=NULL)
-}
-\arguments{
- \item{X}{covariance matrix.}
- \item{Y}{covariance matrix.}
- \item{nsim}{number of random vectors.}
- \item{method}{method to generate a null distribution of the random skewers correlation between matrices. If \code{method=NULL} then the correlation will be compared to the correlation between random vectors; however this test has type I error substantially above the nominal level for ostensibly random matrices. Other values of \code{method} will be passed as \code{covMethod} to \code{genPositiveDefMat} for a more robust hypothesis test (see below). Recommended values include \code{"unifcorrmat"}.}
-}
-\description{
- Performs the random skewers matrix comparison method of Cheverud (1996).
-}
-\details{
- This function performs the random skewers matrix comparison method of Cheverud (1996; also see Cheverud & Marroig 2007 for more details). In addition, it includes a more robust hypothesis test in which random covariance matrices are simulated under a variety of models, and then the mean correlation between response vectors to random skewers are computed.
-}
-\value{
- A list with the following components:
- \item{r}{mean random skewers correlation.}
- \item{p}{p-value from simulation.}
-}
-\references{
- Cheverud, J. M. (1996) Quantitative genetic analysis of cranial morphology in the cotton-top (Saguinus oedipus) and saddle-back (S. fuscicollis) tamarins. \emph{J. Evol. Biol.}, \bold{9}, 5--42.
-
- Cheverud, J. M. & Marroig, G. (2007) Comparing covariance matrices: Random skewers method compared to the common principal components model. \emph{Genetics & Molecular Biology}, \bold{30}, 461--469.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{comparative method}
-\keyword{statistics}
+\name{skewers}
+\alias{skewers}
+\title{Matrix comparison using the method of random skewers}
+\usage{
+skewers(X, Y, nsim=100, method=NULL)
+}
+\arguments{
+ \item{X}{covariance matrix.}
+ \item{Y}{covariance matrix.}
+ \item{nsim}{number of random vectors.}
+ \item{method}{method to generate a null distribution of the random skewers correlation between matrices. If \code{method=NULL} then the correlation will be compared to the correlation between random vectors; however this test has type I error substantially above the nominal level for ostensibly random matrices. Other values of \code{method} will be passed as \code{covMethod} to \code{genPositiveDefMat} for a more robust hypothesis test (see below). Recommended values include \code{"unifcorrmat"}.}
+}
+\description{
+ Performs the random skewers matrix comparison method of Cheverud (1996).
+}
+\details{
+ This function performs the random skewers matrix comparison method of Cheverud (1996; also see Cheverud & Marroig 2007 for more details). In addition, it includes a more robust hypothesis test in which random covariance matrices are simulated under a variety of models, and then the mean correlation between response vectors to random skewers are computed.
+}
+\value{
+ A list with the following components:
+ \item{r}{mean random skewers correlation.}
+ \item{p}{p-value from simulation.}
+}
+\references{
+ Cheverud, J. M. (1996) Quantitative genetic analysis of cranial morphology in the cotton-top (Saguinus oedipus) and saddle-back (S. fuscicollis) tamarins. \emph{J. Evol. Biol.}, \bold{9}, 5--42.
+
+ Cheverud, J. M. & Marroig, G. (2007) Comparing covariance matrices: Random skewers method compared to the common principal components model. \emph{Genetics & Molecular Biology}, \bold{30}, 461--469.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{comparative method}
+\keyword{statistics}
diff --git a/man/splitTree.Rd b/man/splitTree.Rd
index 982cd4a..a88a292 100644
--- a/man/splitTree.Rd
+++ b/man/splitTree.Rd
@@ -1,27 +1,27 @@
-\name{splitTree}
-\alias{splitTree}
-\title{Split tree at a point}
-\usage{
-splitTree(tree, split)
-}
-\arguments{
- \item{tree}{phylogenetic tree.}
- \item{split}{split encoded as a list with two elements: \code{node}: the node number tipward of the split; and \code{bp}: the position along the branch to break the tree, measured from the rootward end of the edge.}
-}
-\description{
- Internal function for \code{\link{posterior.evolrate}}.
-}
-\details{
- This function splits the tree at a given point, and returns the two subtrees as an object of class \code{"multiPhylo"}.
-
- Probably do not use this unless you can figure out what you are doing.
-}
-\value{
- Two trees in a list.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{phylogenetics}
-\keyword{utilities}
+\name{splitTree}
+\alias{splitTree}
+\title{Split tree at a point}
+\usage{
+splitTree(tree, split)
+}
+\arguments{
+ \item{tree}{phylogenetic tree.}
+ \item{split}{split encoded as a list with two elements: \code{node}: the node number tipward of the split; and \code{bp}: the position along the branch to break the tree, measured from the rootward end of the edge.}
+}
+\description{
+ Internal function for \code{\link{posterior.evolrate}}.
+}
+\details{
+ This function splits the tree at a given point, and returns the two subtrees as an object of class \code{"multiPhylo"}.
+
+ Probably do not use this unless you can figure out what you are doing.
+}
+\value{
+ Two trees in a list.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{phylogenetics}
+\keyword{utilities}
diff --git a/man/splitplotTree.Rd b/man/splitplotTree.Rd
index 5241ae0..6375364 100644
--- a/man/splitplotTree.Rd
+++ b/man/splitplotTree.Rd
@@ -1,35 +1,35 @@
-\name{splitplotTree}
-\alias{splitplotTree}
-\alias{plotTree.splits}
-\title{Plots a phylogeny in two columns}
-\usage{
-splitplotTree(tree, fsize=1.0, ftype="reg", lwd=2, split=NULL, new.window=FALSE)
-plotTree.splits(tree, splits=NULL, file=NULL, fn=NULL, ...)
-}
-\arguments{
- \item{tree}{an object of class "phylo".}
- \item{fsize}{relative font size for tip labels.}
- \item{ftype}{font type - options are \code{"reg"}, \code{"i"} (italics), \code{"b"} (bold), or \code{"bi"} (bold-italics).}
- \item{lwd}{line width for plotting.}
- \item{split}{relative vertical position for splitting the tree (between 0 & 1).}
- \item{new.window}{whether or not to plot the split tree in a new window. If \code{FALSE} then the tree will be plotted in two columns within the same plotting window.}
- \item{splits}{for \code{plotTree.splits} relative positions (from 0 to 1) to split the tree across pages or devices.}
- \item{file}{filename if saving to a PDF file is desired. Otherwise will plot to the default plotting device.}
- \item{fn}{function to be executed on each plotted page. For instance, might be: \code{function()} \code{cladelabels()} if clade labels are desired.}
- \item{...}{other arguments to be passed to \code{\link{plotTree}}.}
-}
-\description{
- Plots a tree in two columns or windows.
-}
-\value{
- Plots a tree.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{plotTree}}, \code{\link{plotSimmap}}
-}
-\keyword{phylogenetics}
-\keyword{plotting}
+\name{splitplotTree}
+\alias{splitplotTree}
+\alias{plotTree.splits}
+\title{Plots a phylogeny in two columns}
+\usage{
+splitplotTree(tree, fsize=1.0, ftype="reg", lwd=2, split=NULL, new.window=FALSE)
+plotTree.splits(tree, splits=NULL, file=NULL, fn=NULL, ...)
+}
+\arguments{
+ \item{tree}{an object of class "phylo".}
+ \item{fsize}{relative font size for tip labels.}
+ \item{ftype}{font type - options are \code{"reg"}, \code{"i"} (italics), \code{"b"} (bold), or \code{"bi"} (bold-italics).}
+ \item{lwd}{line width for plotting.}
+ \item{split}{relative vertical position for splitting the tree (between 0 & 1).}
+ \item{new.window}{whether or not to plot the split tree in a new window. If \code{FALSE} then the tree will be plotted in two columns within the same plotting window.}
+ \item{splits}{for \code{plotTree.splits} relative positions (from 0 to 1) to split the tree across pages or devices.}
+ \item{file}{filename if saving to a PDF file is desired. Otherwise will plot to the default plotting device.}
+ \item{fn}{function to be executed on each plotted page. For instance, might be: \code{function()} \code{cladelabels()} if clade labels are desired.}
+ \item{...}{other arguments to be passed to \code{\link{plotTree}}.}
+}
+\description{
+ Plots a tree in two columns or windows.
+}
+\value{
+ Plots a tree.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{plotTree}}, \code{\link{plotSimmap}}
+}
+\keyword{phylogenetics}
+\keyword{plotting}
diff --git a/man/starTree.Rd b/man/starTree.Rd
index 46469cd..cac5226 100644
--- a/man/starTree.Rd
+++ b/man/starTree.Rd
@@ -1,28 +1,28 @@
-\name{starTree}
-\alias{starTree}
-\title{Create star phylogeny}
-\usage{
-starTree(species, branch.lengths=NULL)
-}
-\arguments{
- \item{species}{a list of species.}
- \item{branch.lengths}{an optional list of branch lengths in the same order as \code{species}.}
-}
-\description{
- Creates a star phylogeny.
-}
-\details{
- Creates a star phylogeny with (optionally) user specified branch lengths.
-}
-\value{
- An object of class \code{"phylo"}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{stree}}
-}
-\keyword{phylogenetics}
-\keyword{utilities}
+\name{starTree}
+\alias{starTree}
+\title{Create star phylogeny}
+\usage{
+starTree(species, branch.lengths=NULL)
+}
+\arguments{
+ \item{species}{a list of species.}
+ \item{branch.lengths}{an optional list of branch lengths in the same order as \code{species}.}
+}
+\description{
+ Creates a star phylogeny.
+}
+\details{
+ Creates a star phylogeny with (optionally) user specified branch lengths.
+}
+\value{
+ An object of class \code{"phylo"}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{stree}}
+}
+\keyword{phylogenetics}
+\keyword{utilities}
diff --git a/man/strahlerNumber.Rd b/man/strahlerNumber.Rd
index d5bdb5d..8dc2f92 100644
--- a/man/strahlerNumber.Rd
+++ b/man/strahlerNumber.Rd
@@ -1,28 +1,28 @@
-\name{strahlerNumber}
-\alias{strahlerNumber}
-\alias{extract.strahlerNumber}
-\title{Computes Strahler number for trees and nodes}
-\usage{
-strahlerNumber(tree, plot=TRUE)
-extract.strahlerNumber(tree, i, plot=TRUE)
-}
-\arguments{
- \item{tree}{an object of class \code{"phylo"}.}
- \item{i}{order of Strahler number to extract for \code{extract.strahlerNumber}.}
- \item{plot}{logical value indicating whether to plot the tree with Strahler numbers for node labels.}
-}
-\description{
- Computes the Strahler number of all nodes and tips in a phylogenetic tree.
-}
-\details{
- The function \code{strahlerNumber} computes the Strahler number of all nodes and tips in the tree. For more information about Strahler numbers see \url{https://en.wikipedia.org/wiki/Strahler_number}. The function \code{extract.strahlerNumber} extracts all of the most inclusive clades of Strahler number \code{i}.
-}
-\value{
- Either a vector with the Strahler number for each tip and internal node; or (for \code{extract.strahlerNumber} the set of (most inclusive) subtrees with Strahler number \code{i} as an object of class \code{"multiPhylo"}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{phylogenetics}
-\keyword{utilities}
+\name{strahlerNumber}
+\alias{strahlerNumber}
+\alias{extract.strahlerNumber}
+\title{Computes Strahler number for trees and nodes}
+\usage{
+strahlerNumber(tree, plot=TRUE)
+extract.strahlerNumber(tree, i, plot=TRUE)
+}
+\arguments{
+ \item{tree}{an object of class \code{"phylo"}.}
+ \item{i}{order of Strahler number to extract for \code{extract.strahlerNumber}.}
+ \item{plot}{logical value indicating whether to plot the tree with Strahler numbers for node labels.}
+}
+\description{
+ Computes the Strahler number of all nodes and tips in a phylogenetic tree.
+}
+\details{
+ The function \code{strahlerNumber} computes the Strahler number of all nodes and tips in the tree. For more information about Strahler numbers see \url{https://en.wikipedia.org/wiki/Strahler_number}. The function \code{extract.strahlerNumber} extracts all of the most inclusive clades of Strahler number \code{i}.
+}
+\value{
+ Either a vector with the Strahler number for each tip and internal node; or (for \code{extract.strahlerNumber} the set of (most inclusive) subtrees with Strahler number \code{i} as an object of class \code{"multiPhylo"}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{phylogenetics}
+\keyword{utilities}
diff --git a/man/threshBayes.Rd b/man/threshBayes.Rd
index ae9ec4c..7586546 100644
--- a/man/threshBayes.Rd
+++ b/man/threshBayes.Rd
@@ -1,60 +1,60 @@
-\name{threshBayes}
-\alias{threshBayes}
-\title{Threshold model using Bayesian MCMC}
-\usage{
-threshBayes(tree, X, types=NULL, ngen=10000, control=list(), ...)
-}
-\arguments{
- \item{tree}{an object of class \code{"phylo"}.}
- \item{X}{a matrix or data frame containing values for a discrete character and a continuous character; or two discrete characters. The row names of \code{X} should be species names.}
- \item{types}{a vector of length \code{ncol(X)} containing the data types for each column of \code{X}, for instance \code{c("discrete","continuous")}.}
- \item{ngen}{a integer indicating the number of generations for the MCMC.}
- \item{control}{a list of control parameters for the MCMC. Control parameters include: \code{sample}, the sampling interval for the MCMC; \code{propvar}, a vector containing (in this order) proposal variances for the two rates (if the type is \code{"discrete"} this will be ignored), the two ancestral states, and the correlation; \code{propliab}, a single proposal variance for the liabilities; \code{pr.mean}, a vector for the mean of the prior probability distributions for each parameter, in the same order as \code{propvar}; \code{pr.liab}, currently ignored; \code{pr.var}, a vector with variances for the prior densities for each parameter, in the same order as \code{pr.mean} - note that for the rates we use an exponential distribution so the first two means are currently ignored; and \code{pr.vliab} currently ignored.}
- \item{...}{other optional arguments. The argument \code{auto.tune} adjusts the proposal distribution to target an proposal acceptance rate (of 0.234, by default).}
-}
-\description{
- Fits the threshold model from quantitative genetics to data for two discrete characters or one discrete and one continuous trait, following Felsenstein (2012).
-}
-\value{
- This function returns an object of class \code{"threshBayes"} consisting of a list with at least the following two elements: \code{par} a matrix containing the posterior sample for the model parameters (evolutionary rates, ancestral states, and correlation); \code{liab} a matrix containing the posterior sample of the liabilities. For continuous characters, the liabilities are treated as known and so the posterior samples are just the observed values.
-}
-\details{
- This function uses Bayesian MCMC to fit the quantitative genetics threshold model (Felsenstein 2012) to data for two discrete characters or one discrete and one continuous character.
-
- The \code{plot} method for the object class can be used to generate a three panel plot showing the likelihood profile, the mean acceptance rates (using a sliding window), and a profile plot for the correlation coefficient, \emph{r}.
-
- The \code{density} method for the object can be used to plot a posterior density of the correlation coefficient, \emph{r}. This posterior density is of class \code{"density.threshBayes"} which can also be plotted using an \code{plot} method.
-
- Discrete characters must be binary, but can be coded as any factor.
-}
-\references{
- Felsenstein, J. (2012) A comparative method for both discrete and continuous characters using the threshold model. \emph{American Naturalist}, \bold{179}, 145-156.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-
- Revell, L. J. (2014) Ancestral character estimation under the threshold model from quantitative genetics. \emph{Evolution}, \bold{68}, 743-759.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{anc.Bayes}}, \code{\link{bmPlot}}, \code{\link{evol.rate.mcmc}}
-}
-\examples{
-\dontrun{
-## load data
-data(bonyfish.tree)
-data(bonyfish.data)
-## run MCMC
-mcmc<-threshBayes(bonyfish.tree,bonyfish.data,
- ngen=100000,plot=FALSE)
-## visualize summary of MCMC
-plot(mcmc)
-## reset par
-par(mfrow=c(1,1),mar=c(5.1,4.1,4.1,2.1))
-## graph posterior density of correlation
-plot(density(mcmc,bw=0.1))}
-}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{bayesian}
-\keyword{continuous character}
-\keyword{discrete character}
+\name{threshBayes}
+\alias{threshBayes}
+\title{Threshold model using Bayesian MCMC}
+\usage{
+threshBayes(tree, X, types=NULL, ngen=10000, control=list(), ...)
+}
+\arguments{
+ \item{tree}{an object of class \code{"phylo"}.}
+ \item{X}{a matrix or data frame containing values for a discrete character and a continuous character; or two discrete characters. The row names of \code{X} should be species names.}
+ \item{types}{a vector of length \code{ncol(X)} containing the data types for each column of \code{X}, for instance \code{c("discrete","continuous")}.}
+ \item{ngen}{a integer indicating the number of generations for the MCMC.}
+ \item{control}{a list of control parameters for the MCMC. Control parameters include: \code{sample}, the sampling interval for the MCMC; \code{propvar}, a vector containing (in this order) proposal variances for the two rates (if the type is \code{"discrete"} this will be ignored), the two ancestral states, and the correlation; \code{propliab}, a single proposal variance for the liabilities; \code{pr.mean}, a vector for the mean of the prior probability distributions for each parameter, in the same order as \code{propvar}; \code{pr.liab}, currently ignored; \code{pr.var}, a vector with variances for the prior densities for each parameter, in the same order as \code{pr.mean} - note that for the rates we use an exponential distribution so the first two means are currently ignored; and \code{pr.vliab} currently ignored.}
+ \item{...}{other optional arguments. The argument \code{auto.tune} adjusts the proposal distribution to target an proposal acceptance rate (of 0.234, by default).}
+}
+\description{
+ Fits the threshold model from quantitative genetics to data for two discrete characters or one discrete and one continuous trait, following Felsenstein (2012).
+}
+\value{
+ This function returns an object of class \code{"threshBayes"} consisting of a list with at least the following two elements: \code{par} a matrix containing the posterior sample for the model parameters (evolutionary rates, ancestral states, and correlation); \code{liab} a matrix containing the posterior sample of the liabilities. For continuous characters, the liabilities are treated as known and so the posterior samples are just the observed values.
+}
+\details{
+ This function uses Bayesian MCMC to fit the quantitative genetics threshold model (Felsenstein 2012) to data for two discrete characters or one discrete and one continuous character.
+
+ The \code{plot} method for the object class can be used to generate a three panel plot showing the likelihood profile, the mean acceptance rates (using a sliding window), and a profile plot for the correlation coefficient, \emph{r}.
+
+ The \code{density} method for the object can be used to plot a posterior density of the correlation coefficient, \emph{r}. This posterior density is of class \code{"density.threshBayes"} which can also be plotted using an \code{plot} method.
+
+ Discrete characters must be binary, but can be coded as any factor.
+}
+\references{
+ Felsenstein, J. (2012) A comparative method for both discrete and continuous characters using the threshold model. \emph{American Naturalist}, \bold{179}, 145-156.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+
+ Revell, L. J. (2014) Ancestral character estimation under the threshold model from quantitative genetics. \emph{Evolution}, \bold{68}, 743-759.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{anc.Bayes}}, \code{\link{bmPlot}}, \code{\link{evol.rate.mcmc}}
+}
+\examples{
+\dontrun{
+## load data
+data(bonyfish.tree)
+data(bonyfish.data)
+## run MCMC
+mcmc<-threshBayes(bonyfish.tree,bonyfish.data,
+ ngen=100000,plot=FALSE)
+## visualize summary of MCMC
+plot(mcmc)
+## reset par
+par(mfrow=c(1,1),mar=c(5.1,4.1,4.1,2.1))
+## graph posterior density of correlation
+plot(density(mcmc,bw=0.1))}
+}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{bayesian}
+\keyword{continuous character}
+\keyword{discrete character}
diff --git a/man/threshDIC.Rd b/man/threshDIC.Rd
index b4c23de..e35d880 100644
--- a/man/threshDIC.Rd
+++ b/man/threshDIC.Rd
@@ -1,37 +1,37 @@
-\name{threshDIC}
-\alias{threshDIC}
-\title{Deviance Information Criterion from the threshold model}
-\usage{
-threshDIC(tree, x, mcmc, burnin=NULL, sequence=NULL, method="pD")
-}
-\arguments{
- \item{tree}{phylogenetic tree.}
- \item{x}{a named vector containing discrete character states; or a matrix containing the tip species, in rows, and probabilities of being in each state, in columns.}
- \item{mcmc}{list object returned by \code{\link{ancThresh}}.}
- \item{burnin}{number of generations (not samples) to exclude as burn in; if not supplied then 20\% of generations are excluded.}
- \item{sequence}{assumed ordering of the discrete character state. If not supplied and \code{x} is a vector then numerical-alphabetical order is assumed; if not supplied and \code{x} is a matrix, then the column order of \code{x} is used.}
- \item{method}{method for computing the effective number of parameters (options are \code{"pD"} and \code{"pV"}).}
-}
-\description{
- Computes Deviance Information Criterion from the MCMC object returned by \code{\link{ancThresh}}.
-}
-\details{
- This function computes the Deviance Information Criterion from the MCMC object returned by \code{\link{ancThresh}}.
-}
-\value{
- A vector containing the mean deviance and deviance for the parameter means, the effective number of parameters, and the DIC.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-
- Revell, L. J. (2014) Ancestral character estimation under the threshold model from quantitative genetics. \emph{Evolution}, \bold{68}, 743-759.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{ancThresh}}
-}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{bayesian}
-\keyword{information criteria}
-\keyword{statistics}
+\name{threshDIC}
+\alias{threshDIC}
+\title{Deviance Information Criterion from the threshold model}
+\usage{
+threshDIC(tree, x, mcmc, burnin=NULL, sequence=NULL, method="pD")
+}
+\arguments{
+ \item{tree}{phylogenetic tree.}
+ \item{x}{a named vector containing discrete character states; or a matrix containing the tip species, in rows, and probabilities of being in each state, in columns.}
+ \item{mcmc}{list object returned by \code{\link{ancThresh}}.}
+ \item{burnin}{number of generations (not samples) to exclude as burn in; if not supplied then 20\% of generations are excluded.}
+ \item{sequence}{assumed ordering of the discrete character state. If not supplied and \code{x} is a vector then numerical-alphabetical order is assumed; if not supplied and \code{x} is a matrix, then the column order of \code{x} is used.}
+ \item{method}{method for computing the effective number of parameters (options are \code{"pD"} and \code{"pV"}).}
+}
+\description{
+ Computes Deviance Information Criterion from the MCMC object returned by \code{\link{ancThresh}}.
+}
+\details{
+ This function computes the Deviance Information Criterion from the MCMC object returned by \code{\link{ancThresh}}.
+}
+\value{
+ A vector containing the mean deviance and deviance for the parameter means, the effective number of parameters, and the DIC.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+
+ Revell, L. J. (2014) Ancestral character estimation under the threshold model from quantitative genetics. \emph{Evolution}, \bold{68}, 743-759.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{ancThresh}}
+}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{bayesian}
+\keyword{information criteria}
+\keyword{statistics}
diff --git a/man/threshState.Rd b/man/threshState.Rd
index bd7f244..89391a4 100644
--- a/man/threshState.Rd
+++ b/man/threshState.Rd
@@ -1,33 +1,33 @@
-\name{threshState}
-\alias{threshState}
-\title{Computes value for a threshold character from a liability and thresholds}
-\usage{
-threshState(x, thresholds)
-}
-\arguments{
- \item{x}{liability.}
- \item{thresholds}{a named vector containing the thresholds.}
-}
-\description{
- Internal function for \code{\link{ancThresh}}.
-}
-\details{
- \code{threshState} can also be used to simulate threshold traits.
-}
-\value{
- A discrete character value.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-
- Revell, L. J. (2014) Ancestral character estimation under the threshold model from quantitative genetics. \emph{Evolution}, \bold{68}, 743-759.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{ancThresh}}, \code{\link{threshDIC}}
-}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{simulation}
-\keyword{discrete character}
-\keyword{utilities}
+\name{threshState}
+\alias{threshState}
+\title{Computes value for a threshold character from a liability and thresholds}
+\usage{
+threshState(x, thresholds)
+}
+\arguments{
+ \item{x}{liability.}
+ \item{thresholds}{a named vector containing the thresholds.}
+}
+\description{
+ Internal function for \code{\link{ancThresh}}.
+}
+\details{
+ \code{threshState} can also be used to simulate threshold traits.
+}
+\value{
+ A discrete character value.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+
+ Revell, L. J. (2014) Ancestral character estimation under the threshold model from quantitative genetics. \emph{Evolution}, \bold{68}, 743-759.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{ancThresh}}, \code{\link{threshDIC}}
+}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{simulation}
+\keyword{discrete character}
+\keyword{utilities}
diff --git a/man/to.matrix.Rd b/man/to.matrix.Rd
index 39356d7..31f6c83 100644
--- a/man/to.matrix.Rd
+++ b/man/to.matrix.Rd
@@ -1,26 +1,26 @@
-\name{to.matrix}
-\alias{to.matrix}
-\title{Convert a character vector to a binary matrix}
-\usage{
-to.matrix(x, seq)
-}
-\arguments{
- \item{x}{a vector of characters.}
- \item{seq}{the sequence for the columns in the output matrix.}
-}
-\description{
- Creates a binary matrix, normally from a factor.
-}
-\details{
- This function takes a vector of characters or a factor and computes a binary matrix.
-
- Primarily designed to be used internally by \code{\link{make.simmap}} and \code{\link{rerootingMethod}}.
-}
-\value{
- A binary matrix of dimensions \code{length(x)} by \code{length(seq)}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{utilities}
+\name{to.matrix}
+\alias{to.matrix}
+\title{Convert a character vector to a binary matrix}
+\usage{
+to.matrix(x, seq)
+}
+\arguments{
+ \item{x}{a vector of characters.}
+ \item{seq}{the sequence for the columns in the output matrix.}
+}
+\description{
+ Creates a binary matrix, normally from a factor.
+}
+\details{
+ This function takes a vector of characters or a factor and computes a binary matrix.
+
+ Primarily designed to be used internally by \code{\link{make.simmap}} and \code{\link{rerootingMethod}}.
+}
+\value{
+ A binary matrix of dimensions \code{length(x)} by \code{length(seq)}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{utilities}
diff --git a/man/tree.grow.Rd b/man/tree.grow.Rd
index 633d97c..e420427 100644
--- a/man/tree.grow.Rd
+++ b/man/tree.grow.Rd
@@ -1,41 +1,41 @@
-\name{tree.grow}
-\alias{tree.grow}
-\title{Creates an animation of a tree growing from left-to-right or upwards}
-\usage{
-tree.grow(..., res=200, direction="rightwards", ladderize=TRUE)
-}
-\arguments{
- \item{...}{arguments to pass to \code{\link{pbtree}}.}
- \item{res}{number of steps (the resolution of the animation). This also corresponds to the number of frames that will be created if the animation is to be converted to a .gif file.}
- \item{direction}{the direction to plot the tree. Only \code{direction="rightwards"} (the default) and \code{direction="upwards"} are supported.}
- \item{ladderize}{logical value indicating whether or not to 'ladderize' the plotted tree. (Defaults to \code{TRUE}.)}
-}
-\description{
- Animates a birth-death tree simulation.
-}
-\details{
- This function simulates a birth-death tree under user-defined conditions and then creates an animation of that tree growing from left-to-right in the plotting device, or upwards.
-}
-\value{
- An object of class \code{"phylo"}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{pbtree}}
-}
-\examples{
-\dontrun{
-## to create a .gif with ImageMagick installed
-png(file="pbtree-%03d.png",width=1000,height=600,res=144)
-tree.grow(b=0.06,d=0.02,t=100)
-dev.off()
-system("ImageMagick convert -delay 5 -loop 0 *.png pbtree-anim.gif")}
-}
-\keyword{phylogenetics}
-\keyword{plotting}
-\keyword{comparative method}
-\keyword{simulation}
-\keyword{diversification}
+\name{tree.grow}
+\alias{tree.grow}
+\title{Creates an animation of a tree growing from left-to-right or upwards}
+\usage{
+tree.grow(..., res=200, direction="rightwards", ladderize=TRUE)
+}
+\arguments{
+ \item{...}{arguments to pass to \code{\link{pbtree}}.}
+ \item{res}{number of steps (the resolution of the animation). This also corresponds to the number of frames that will be created if the animation is to be converted to a .gif file.}
+ \item{direction}{the direction to plot the tree. Only \code{direction="rightwards"} (the default) and \code{direction="upwards"} are supported.}
+ \item{ladderize}{logical value indicating whether or not to 'ladderize' the plotted tree. (Defaults to \code{TRUE}.)}
+}
+\description{
+ Animates a birth-death tree simulation.
+}
+\details{
+ This function simulates a birth-death tree under user-defined conditions and then creates an animation of that tree growing from left-to-right in the plotting device, or upwards.
+}
+\value{
+ An object of class \code{"phylo"}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{pbtree}}
+}
+\examples{
+\dontrun{
+## to create a .gif with ImageMagick installed
+png(file="pbtree-%03d.png",width=1000,height=600,res=144)
+tree.grow(b=0.06,d=0.02,t=100)
+dev.off()
+system("ImageMagick convert -delay 5 -loop 0 *.png pbtree-anim.gif")}
+}
+\keyword{phylogenetics}
+\keyword{plotting}
+\keyword{comparative method}
+\keyword{simulation}
+\keyword{diversification}
diff --git a/man/treeSlice.Rd b/man/treeSlice.Rd
index 8b2e305..5842997 100644
--- a/man/treeSlice.Rd
+++ b/man/treeSlice.Rd
@@ -1,33 +1,33 @@
-\name{treeSlice}
-\alias{treeSlice}
-\title{Slices the tree at a particular point and returns all subtrees, or the tree rootward of the point}
-\usage{
-treeSlice(tree, slice, trivial=FALSE, prompt=FALSE, ...)
-}
-\arguments{
- \item{tree}{is a phylogenetic tree in \code{"phylo"} format.}
- \item{slice}{a real number indicating the height above the root at which to slice the tree.}
- \item{trivial}{a logical value indicating whether or not to return subtrees with a number of tips less than two (default is \code{FALSE}).}
- \item{prompt}{logical value indicating whether or not the height of the slice should be given interactively.}
- \item{...}{for \code{prompt=TRUE}, other arguments to be passed to \code{\link{plotTree}}. In addition, the argument \code{orientation} can be used to specify whether the \code{"tipwards"} subtrees or the \code{"rootwards"} phylogeny are/is to be returned by the function call (using those two argument values, respectively).}
-}
-\description{
- Cut (or slice) a phylogenetic tree at a particular time point.
-}
-\details{
- This function slices a tree at a particular height above the root and returns all subtrees or all non-trivial subtrees (i.e., subtrees with more than 1 taxon). Uses \code{\link{extract.clade}} in the \pkg{ape} package.
-
- \code{treeSlice} can also be used to crop the terminal fraction of a tree for \code{orientation="rootwards"}.
-}
-\value{
- An object of class \code{"phylo"} or \code{"multiPhylo"}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{extract.clade}}
-}
-\keyword{phylogenetics}
-\keyword{utilities}
+\name{treeSlice}
+\alias{treeSlice}
+\title{Slices the tree at a particular point and returns all subtrees, or the tree rootward of the point}
+\usage{
+treeSlice(tree, slice, trivial=FALSE, prompt=FALSE, ...)
+}
+\arguments{
+ \item{tree}{is a phylogenetic tree in \code{"phylo"} format.}
+ \item{slice}{a real number indicating the height above the root at which to slice the tree.}
+ \item{trivial}{a logical value indicating whether or not to return subtrees with a number of tips less than two (default is \code{FALSE}).}
+ \item{prompt}{logical value indicating whether or not the height of the slice should be given interactively.}
+ \item{...}{for \code{prompt=TRUE}, other arguments to be passed to \code{\link{plotTree}}. In addition, the argument \code{orientation} can be used to specify whether the \code{"tipwards"} subtrees or the \code{"rootwards"} phylogeny are/is to be returned by the function call (using those two argument values, respectively).}
+}
+\description{
+ Cut (or slice) a phylogenetic tree at a particular time point.
+}
+\details{
+ This function slices a tree at a particular height above the root and returns all subtrees or all non-trivial subtrees (i.e., subtrees with more than 1 taxon). Uses \code{\link{extract.clade}} in the \pkg{ape} package.
+
+ \code{treeSlice} can also be used to crop the terminal fraction of a tree for \code{orientation="rootwards"}.
+}
+\value{
+ An object of class \code{"phylo"} or \code{"multiPhylo"}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{extract.clade}}
+}
+\keyword{phylogenetics}
+\keyword{utilities}
diff --git a/man/untangle.Rd b/man/untangle.Rd
index 8441b21..43480f7 100644
--- a/man/untangle.Rd
+++ b/man/untangle.Rd
@@ -1,25 +1,25 @@
-\name{untangle}
-\alias{untangle}
-\title{Attempts to untangle crossing branches for plotting}
-\usage{
-untangle(tree, method=c("reorder","read.tree"))
-}
-\arguments{
- \item{tree}{tree as an object of class \code{"phylo"} or \code{"simmap"}.}
- \item{method}{method to use to attempt to untangle branches. \code{method="reorder"} uses two calls of \code{\link{reorder.phylo}} or \code{\link{reorderSimmap}}; \code{method="read.tree"} writes the tree to a text string and then reads it back into memory using \code{\link{read.tree}}.}
-}
-\description{
- Attempts to "untangle" the branches of a tree that are tangled when plotting with \code{\link{plot.phylo}}, \code{\link{plotTree}}, or \code{\link{plotSimmap}}.
-}
-\details{
- Generally speaking, this function is wraps several different internal functions that might be use to fix a badly conformed \code{"phylo"} or \code{"simmap"} object.
-}
-\value{
- An object of class \code{"phylo"} or \code{"simmap"}, depending on the class of \code{tree}.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{phylogenetics}
-\keyword{utilities}
+\name{untangle}
+\alias{untangle}
+\title{Attempts to untangle crossing branches for plotting}
+\usage{
+untangle(tree, method=c("reorder","read.tree"))
+}
+\arguments{
+ \item{tree}{tree as an object of class \code{"phylo"} or \code{"simmap"}.}
+ \item{method}{method to use to attempt to untangle branches. \code{method="reorder"} uses two calls of \code{\link{reorder.phylo}} or \code{\link{reorderSimmap}}; \code{method="read.tree"} writes the tree to a text string and then reads it back into memory using \code{\link{read.tree}}.}
+}
+\description{
+ Attempts to "untangle" the branches of a tree that are tangled when plotting with \code{\link{plot.phylo}}, \code{\link{plotTree}}, or \code{\link{plotSimmap}}.
+}
+\details{
+ Generally speaking, this function is wraps several different internal functions that might be use to fix a badly conformed \code{"phylo"} or \code{"simmap"} object.
+}
+\value{
+ An object of class \code{"phylo"} or \code{"simmap"}, depending on the class of \code{tree}.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{phylogenetics}
+\keyword{utilities}
diff --git a/man/vcvPhylo.Rd b/man/vcvPhylo.Rd
index 712953b..228b18b 100644
--- a/man/vcvPhylo.Rd
+++ b/man/vcvPhylo.Rd
@@ -1,29 +1,29 @@
-\name{vcvPhylo}
-\alias{vcvPhylo}
-\title{Calculates cophenetic (i.e., phylogenetic VCV) matrix}
-\usage{
-vcvPhylo(tree, anc.nodes=TRUE, ...)
-}
-\arguments{
- \item{tree}{object of class \code{"phylo"}.}
- \item{anc.nodes}{logical value indicating whether or not to include ancestral nodes.}
- \item{...}{optional arguments including \code{internal} (synonym of \code{anc.nodes}) and \code{model} (can be \code{"BM"}, \code{"OU"}, or \code{"lambda"}.}
-}
-\description{
- Computes a phylogenetic variance-covariance matrix.
-}
-\details{
- This function returns a so-called \emph{phylogenetic variance covariance matrix} (e.g., see \code{\link{vcv.phylo}}), but (optionally) including ancestral nodes, as well as under multiple evolutionary models.
-
- \code{vcvPhylo} is designed primarily for internal use by other \emph{phytools} functions.
-}
-\value{
- A matrix.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\keyword{phylogenetics}
-\keyword{statistics}
-\keyword{utilities}
+\name{vcvPhylo}
+\alias{vcvPhylo}
+\title{Calculates cophenetic (i.e., phylogenetic VCV) matrix}
+\usage{
+vcvPhylo(tree, anc.nodes=TRUE, ...)
+}
+\arguments{
+ \item{tree}{object of class \code{"phylo"}.}
+ \item{anc.nodes}{logical value indicating whether or not to include ancestral nodes.}
+ \item{...}{optional arguments including \code{internal} (synonym of \code{anc.nodes}) and \code{model} (can be \code{"BM"}, \code{"OU"}, or \code{"lambda"}.}
+}
+\description{
+ Computes a phylogenetic variance-covariance matrix.
+}
+\details{
+ This function returns a so-called \emph{phylogenetic variance covariance matrix} (e.g., see \code{\link{vcv.phylo}}), but (optionally) including ancestral nodes, as well as under multiple evolutionary models.
+
+ \code{vcvPhylo} is designed primarily for internal use by other \emph{phytools} functions.
+}
+\value{
+ A matrix.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\keyword{phylogenetics}
+\keyword{statistics}
+\keyword{utilities}
diff --git a/man/write.simmap.Rd b/man/write.simmap.Rd
index c4cabb3..f0b3d75 100644
--- a/man/write.simmap.Rd
+++ b/man/write.simmap.Rd
@@ -1,36 +1,36 @@
-\name{write.simmap}
-\alias{write.simmap}
-\title{Write a stochastic character mapped tree to file}
-\usage{
-write.simmap(tree, file=NULL, append=FALSE, map.order=NULL, quiet=FALSE,
- format="phylip", version=1.0)
-}
-\arguments{
- \item{tree}{an object of class \code{"simmap"} or \code{"multiSimmap"}.}
- \item{file}{an optional filename.}
- \item{append}{a logical value indicating whether to append to file.}
- \item{map.order}{a optional value specifying whether to write the map in left-to-right or right-to-left order. Acceptable values are "left-to-right" or "right-to-left" or some abbreviation of either. If not provided, \code{write.simmap} will use \code{attr(tree,"map.order")} if available.}
- \item{quiet}{logical value indicating whether or not to print a warning message when \code{map.order} is neither specified by a function argument or as an attribute of \code{tree}.}
- \item{format}{file format for output.}
- \item{version}{version of SIMMAP. Note that the options are \code{1.0} and \code{1.5}. \code{version=1.5} is generally recommended because in this format the tree can also be parsed by typical tree readers, but absent its mapped trait.}
-}
-\description{
- Writes one or multiple stochastic character mapped trees to file in several formats (following Bollback, 2006).
-}
-\value{
- A file.
-}
-\references{
- Bollback, J. P. (2006) Stochastic character mapping of discrete traits on phylogenies. \emph{BMC Bioinformatics}, \bold{7}, 88.
-
- Huelsenbeck, J. P., R. Neilsen, and J. P. Bollback (2003) Stochastic mapping of morphological characters. \emph{Systematic Biology}, \bold{52}, 131-138.
-
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{plotSimmap}}
-}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{input/output}
+\name{write.simmap}
+\alias{write.simmap}
+\title{Write a stochastic character mapped tree to file}
+\usage{
+write.simmap(tree, file=NULL, append=FALSE, map.order=NULL, quiet=FALSE,
+ format="phylip", version=1.0)
+}
+\arguments{
+ \item{tree}{an object of class \code{"simmap"} or \code{"multiSimmap"}.}
+ \item{file}{an optional filename.}
+ \item{append}{a logical value indicating whether to append to file.}
+ \item{map.order}{a optional value specifying whether to write the map in left-to-right or right-to-left order. Acceptable values are "left-to-right" or "right-to-left" or some abbreviation of either. If not provided, \code{write.simmap} will use \code{attr(tree,"map.order")} if available.}
+ \item{quiet}{logical value indicating whether or not to print a warning message when \code{map.order} is neither specified by a function argument or as an attribute of \code{tree}.}
+ \item{format}{file format for output.}
+ \item{version}{version of SIMMAP. Note that the options are \code{1.0} and \code{1.5}. \code{version=1.5} is generally recommended because in this format the tree can also be parsed by typical tree readers, but absent its mapped trait.}
+}
+\description{
+ Writes one or multiple stochastic character mapped trees to file in several formats (following Bollback, 2006).
+}
+\value{
+ A file.
+}
+\references{
+ Bollback, J. P. (2006) Stochastic character mapping of discrete traits on phylogenies. \emph{BMC Bioinformatics}, \bold{7}, 88.
+
+ Huelsenbeck, J. P., R. Neilsen, and J. P. Bollback (2003) Stochastic mapping of morphological characters. \emph{Systematic Biology}, \bold{52}, 131-138.
+
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{plotSimmap}}
+}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{input/output}
diff --git a/man/writeAncestors.Rd b/man/writeAncestors.Rd
index 70fef09..2a0cb3b 100644
--- a/man/writeAncestors.Rd
+++ b/man/writeAncestors.Rd
@@ -1,31 +1,31 @@
-\name{writeAncestors}
-\alias{writeAncestors}
-\title{Write a tree to file with ancestral states and (optionally) CIs at nodes}
-\usage{
-writeAncestors(tree, Anc=NULL, file="", digits=6, format=c("phylip","nexus"),
- ...)
-}
-\arguments{
- \item{tree}{a phylogenetic tree or set of trees as an object of class \code{"phylo"} or \code{"multiPhylo"}.}
- \item{Anc}{a vector of ancestral states, a list containing the ancestral states and 95\% confidence intervals (as from \code{\link{fastAnc}} or \code{\link{ace}}, or a list of such results.}
- \item{file}{an optional string with the filename for output.}
- \item{digits}{an integer indicating the number of digits to print for branch lengths and ancestral character values.}
- \item{format}{a string indicating whether to output the result in simple Newick (i.e., \code{"phylip"}) or Nexus format.}
- \item{...}{additional arguments including \code{x}: a vector of character values, in which case ancestral states are estimated internally using \code{fastAnc}; and \code{CI}: a logical value indicating whether or not to estimate 95\% confidence intervals.}
-}
-\description{
- This function writes a tree to file with ancestral character states and (optionally) 95\% confidence intervals stored as node value.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\value{
- A file, string, or vector of strings.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{ace}}, \code{\link{fastAnc}}, \code{\link{write.tree}}
-}
-\keyword{phylogenetics}
-\keyword{comparative method}
-\keyword{input/output}
+\name{writeAncestors}
+\alias{writeAncestors}
+\title{Write a tree to file with ancestral states and (optionally) CIs at nodes}
+\usage{
+writeAncestors(tree, Anc=NULL, file="", digits=6, format=c("phylip","nexus"),
+ ...)
+}
+\arguments{
+ \item{tree}{a phylogenetic tree or set of trees as an object of class \code{"phylo"} or \code{"multiPhylo"}.}
+ \item{Anc}{a vector of ancestral states, a list containing the ancestral states and 95\% confidence intervals (as from \code{\link{fastAnc}} or \code{\link{ace}}, or a list of such results.}
+ \item{file}{an optional string with the filename for output.}
+ \item{digits}{an integer indicating the number of digits to print for branch lengths and ancestral character values.}
+ \item{format}{a string indicating whether to output the result in simple Newick (i.e., \code{"phylip"}) or Nexus format.}
+ \item{...}{additional arguments including \code{x}: a vector of character values, in which case ancestral states are estimated internally using \code{fastAnc}; and \code{CI}: a logical value indicating whether or not to estimate 95\% confidence intervals.}
+}
+\description{
+ This function writes a tree to file with ancestral character states and (optionally) 95\% confidence intervals stored as node value.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\value{
+ A file, string, or vector of strings.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{ace}}, \code{\link{fastAnc}}, \code{\link{write.tree}}
+}
+\keyword{phylogenetics}
+\keyword{comparative method}
+\keyword{input/output}
diff --git a/man/writeNexus.Rd b/man/writeNexus.Rd
index 9ccfe9f..2c48e28 100644
--- a/man/writeNexus.Rd
+++ b/man/writeNexus.Rd
@@ -1,27 +1,27 @@
-\name{writeNexus}
-\alias{writeNexus}
-\title{Write a tree to file in Nexus format}
-\usage{
-writeNexus(tree, file="")
-}
-\arguments{
- \item{tree}{object of class \code{"phylo"} or \code{"multiPhylo"}.}
- \item{file}{file name for output.}
-}
-\description{
- Writes one or multiple phylogenetic trees to file in NEXUS format.
-
- Somewhat redundant with \code{\link{write.nexus}}.
-}
-\value{
- Trees written to file.
-}
-\references{
- Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
-}
-\author{Liam Revell \email{liam.revell@umb.edu}}
-\seealso{
- \code{\link{write.simmap}}, \code{\link{write.nexus}}
-}
-\keyword{phylogenetics}
-\keyword{input/output}
+\name{writeNexus}
+\alias{writeNexus}
+\title{Write a tree to file in Nexus format}
+\usage{
+writeNexus(tree, file="")
+}
+\arguments{
+ \item{tree}{object of class \code{"phylo"} or \code{"multiPhylo"}.}
+ \item{file}{file name for output.}
+}
+\description{
+ Writes one or multiple phylogenetic trees to file in NEXUS format.
+
+ Somewhat redundant with \code{\link{write.nexus}}.
+}
+\value{
+ Trees written to file.
+}
+\references{
+ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223.
+}
+\author{Liam Revell \email{liam.revell@umb.edu}}
+\seealso{
+ \code{\link{write.simmap}}, \code{\link{write.nexus}}
+}
+\keyword{phylogenetics}
+\keyword{input/output}
More details
Historical runs
- unsatisfied-apt-dependencies: Unsatisfied APT dependencies: r-cran-ape:amd64 (>= 5.7)
- bad-gateway: Failed to push result branch: Unexpected HTTP status 502 for https://janitor.debian.net/git/r-cran-phytools/info/refs?service=git-upload-pack: Unable to handle http code: Bad Gateway
- worker-timeout: No keepalives received in 11:08:31.859354.
- success: Merged new upstream version 1.2-0+git20220912.1.51d7f05
- unsatisfied-apt-dependencies: Unsatisfied APT dependencies: r-cran-optimparallel:amd64
- command-failed: Command 'SCHROOT=unstable-amd64-sbuild PYTHONPATH=/:/code:/code/breezy:/code/dulwich:/code/lintian-brush:/code/ognibuild:/code/silver-platter:/code/buildlog-consultant:/code/upstream-ontologist:/code/debmutate:/code/python-debian/lib:/usr/lib/python39.zip:/usr/lib/python3.9:/usr/lib/python3.9/lib-dynload:/usr/local/lib/python3.9/dist-packages:/usr/lib/python3/dist-packages /usr/bin/python3 -m janitor.dist --packaging=/tmp/janitors1qa78xh/r-cran-phytools/debian' returned non-zero exit status 1.
- command-failed: Command 'SCHROOT=unstable-amd64-sbuild PYTHONPATH=/:/code:/code/breezy:/code/dulwich:/code/lintian-brush:/code/ognibuild:/code/silver-platter:/code/buildlog-consultant:/code/upstream-ontologist:/code/debmutate:/code/python-debian/lib:/usr/lib/python39.zip:/usr/lib/python3.9:/usr/lib/python3.9/lib-dynload:/usr/local/lib/python3.9/dist-packages:/usr/lib/python3/dist-packages /usr/bin/python3 -m janitor.dist --packaging=/tmp/janitorqne3e3wq/r-cran-phytools/debian' returned non-zero exit status 1.