[med-svn] [r-cran-ape] 01/01: Imported Upstream version 3.1-1
Dylan Aïssi
bob.dybian-guest at moszumanska.debian.org
Sat May 3 14:43:59 UTC 2014
This is an automated email from the git hooks/post-receive script.
bob.dybian-guest pushed a commit to branch master
in repository r-cran-ape.
commit d28b0a882427a0dda206c210dcddcdcaa40d4a5a
Author: Dylan Aïssi <bob.dybian at gmail.com>
Date: Sat May 3 16:41:34 2014 +0200
Imported Upstream version 3.1-1
---
DESCRIPTION | 54 +
MD5 | 337 +++++
NAMESPACE | 142 ++
NEWS | 3005 ++++++++++++++++++++++++++++++++++++++++
R/CADM.global.R | 216 +++
R/CADM.post.R | 276 ++++
R/CDF.birth.death.R | 519 +++++++
R/Cheverud.R | 141 ++
R/DNA.R | 500 +++++++
R/MPR.R | 68 +
R/MoranI.R | 212 +++
R/PGLS.R | 282 ++++
R/SDM.R | 207 +++
R/SlowinskiGuyer.R | 101 ++
R/ace.R | 342 +++++
R/additive.R | 38 +
R/alex.R | 42 +
R/all.equal.phylo.R | 83 ++
R/as.bitsplits.R | 127 ++
R/as.matching.R | 66 +
R/as.phylo.R | 134 ++
R/as.phylo.formula.R | 51 +
R/balance.R | 32 +
R/bind.tree.R | 217 +++
R/biplot.pcoa.R | 49 +
R/birthdeath.R | 150 ++
R/branching.times.R | 31 +
R/cherry.R | 52 +
R/chronoMPL.R | 47 +
R/chronopl.R | 254 ++++
R/chronos.R | 476 +++++++
R/clustal.R | 78 ++
R/coalescent.intervals.R | 56 +
R/collapse.singles.R | 52 +
R/collapsed.intervals.R | 57 +
R/compar.gee.R | 169 +++
R/compar.lynch.R | 74 +
R/compar.ou.R | 79 ++
R/compute.brtime.R | 55 +
R/cophenetic.phylo.R | 32 +
R/cophyloplot.R | 174 +++
R/dbd.R | 117 ++
R/delta.plot.R | 39 +
R/dist.gene.R | 56 +
R/dist.topo.R | 361 +++++
R/diversi.gof.R | 65 +
R/diversi.time.R | 80 ++
R/drop.tip.R | 238 ++++
R/evonet.R | 103 ++
R/ewLasso.R | 28 +
R/extract.popsize.R | 95 ++
R/gammaStat.R | 21 +
R/howmanytrees.R | 44 +
R/identify.phylo.R | 44 +
R/is.binary.tree.R | 26 +
R/is.compatible.R | 36 +
R/is.monophyletic.R | 52 +
R/is.ultrametric.R | 36 +
R/ladderize.R | 41 +
R/lmorigin.R | 163 +++
R/ltt.plot.R | 150 ++
R/makeLabel.R | 117 ++
R/makeNodeLabel.R | 60 +
R/mantel.test.R | 42 +
R/matexpo.R | 18 +
R/mcmc.popsize.R | 440 ++++++
R/me.R | 66 +
R/mrca.R | 89 ++
R/mst.R | 90 ++
R/multi2di.R | 125 ++
R/mvr.R | 52 +
R/nj.R | 24 +
R/njs.R | 48 +
R/nodelabels.R | 296 ++++
R/parafit.R | 160 +++
R/pcoa.R | 170 +++
R/phydataplot.R | 130 ++
R/phymltest.R | 122 ++
R/pic.R | 170 +++
R/plot.phylo.R | 728 ++++++++++
R/plot.popsize.R | 64 +
R/plotPhyloCoor.R | 137 ++
R/print.lmorigin.R | 55 +
R/print.parafit.R | 18 +
R/rTrait.R | 174 +++
R/read.GenBank.R | 53 +
R/read.caic.R | 91 ++
R/read.dna.R | 132 ++
R/read.nexus.R | 253 ++++
R/read.nexus.data.R | 142 ++
R/read.tree.R | 169 +++
R/reorder.phylo.R | 82 ++
R/root.R | 342 +++++
R/rotate.R | 126 ++
R/rtree.R | 213 +++
R/scales.R | 130 ++
R/skyline.R | 149 ++
R/skylineplot.R | 73 +
R/speciesTree.R | 29 +
R/subtreeplot.R | 47 +
R/subtrees.R | 55 +
R/summary.phylo.R | 231 +++
R/treePop.R | 25 +
R/triangMtd.R | 40 +
R/unique.multiPhylo.R | 34 +
R/varcomp.R | 37 +
R/vcv.phylo.R | 72 +
R/which.edge.R | 67 +
R/write.dna.R | 131 ++
R/write.nexus.R | 73 +
R/write.nexus.data.R | 168 +++
R/write.tree.R | 131 ++
R/yule.R | 81 ++
R/yule.time.R | 71 +
R/zoom.R | 37 +
R/zzz.R | 10 +
build/vignette.rds | Bin 0 -> 192 bytes
data/HP.links.rda | Bin 0 -> 412 bytes
data/bird.families.rda | Bin 0 -> 2509 bytes
data/bird.orders.rda | Bin 0 -> 567 bytes
data/carnivora.csv.gz | Bin 0 -> 3544 bytes
data/chiroptera.rda | Bin 0 -> 11971 bytes
data/cynipids.rda | Bin 0 -> 721 bytes
data/gopher.D.rda | Bin 0 -> 1255 bytes
data/hivtree.newick.rda | Bin 0 -> 2189 bytes
data/hivtree.table.txt.gz | Bin 0 -> 1031 bytes
data/landplants.newick.rda | Bin 0 -> 574 bytes
data/lice.D.rda | Bin 0 -> 1544 bytes
data/lmorigin.ex1.rda | Bin 0 -> 979 bytes
data/lmorigin.ex2.rda | Bin 0 -> 455 bytes
data/mat3.RData | Bin 0 -> 714 bytes
data/mat5M3ID.RData | Bin 0 -> 49717 bytes
data/mat5Mrand.RData | Bin 0 -> 49548 bytes
data/opsin.newick.rda | Bin 0 -> 445 bytes
data/woodmouse.rda | Bin 0 -> 1160 bytes
inst/CITATION | 13 +
inst/doc/MoranI.R | 88 ++
inst/doc/MoranI.Rnw | 351 +++++
inst/doc/MoranI.pdf | Bin 0 -> 126448 bytes
man/CADM.global.Rd | 136 ++
man/DNAbin.Rd | 114 ++
man/Initialize.corPhyl.Rd | 24 +
man/LTT.Rd | 74 +
man/MPR.Rd | 69 +
man/MoranI.Rd | 79 ++
man/SDM.Rd | 39 +
man/ace.Rd | 207 +++
man/add.scale.bar.Rd | 51 +
man/additive.Rd | 26 +
man/alex.Rd | 44 +
man/all.equal.phylo.Rd | 67 +
man/ape-internal.Rd | 75 +
man/ape-package.Rd | 38 +
man/as.alignment.Rd | 63 +
man/as.bitsplits.Rd | 61 +
man/as.matching.Rd | 67 +
man/as.phylo.Rd | 110 ++
man/as.phylo.formula.Rd | 30 +
man/axisPhylo.Rd | 34 +
man/balance.Rd | 29 +
man/base.freq.Rd | 62 +
man/bd.ext.Rd | 77 +
man/bd.time.Rd | 87 ++
man/bind.tree.Rd | 115 ++
man/bionj.Rd | 49 +
man/bird.families.Rd | 40 +
man/bird.orders.Rd | 36 +
man/birthdeath.Rd | 66 +
man/boot.phylo.Rd | 155 +++
man/branching.times.Rd | 27 +
man/c.phylo.Rd | 55 +
man/carnivora.Rd | 49 +
man/cherry.Rd | 47 +
man/chiroptera.Rd | 32 +
man/chronoMPL.Rd | 75 +
man/chronopl.Rd | 118 ++
man/chronos.Rd | 137 ++
man/clustal.Rd | 87 ++
man/coalescent.intervals.Rd | 50 +
man/collapse.singles.Rd | 21 +
man/collapsed.intervals.Rd | 74 +
man/compar.cheverud.Rd | 74 +
man/compar.gee.Rd | 123 ++
man/compar.lynch.Rd | 67 +
man/compar.ou.Rd | 102 ++
man/compute.brlen.Rd | 60 +
man/compute.brtime.Rd | 47 +
man/consensus.Rd | 42 +
man/cophenetic.phylo.Rd | 30 +
man/cophyloplot.Rd | 71 +
man/corBlomberg.Rd | 47 +
man/corBrownian.Rd | 55 +
man/corClasses.Rd | 48 +
man/corGrafen.Rd | 53 +
man/corMartins.Rd | 53 +
man/corPagel.Rd | 50 +
man/correlogram.formula.Rd | 58 +
man/cynipids.Rd | 24 +
man/dbd.Rd | 107 ++
man/del.gaps.Rd | 31 +
man/delta.plot.Rd | 54 +
man/dist.dna.Rd | 208 +++
man/dist.gene.Rd | 52 +
man/dist.topo.Rd | 70 +
man/diversi.gof.Rd | 75 +
man/diversi.time.Rd | 58 +
man/diversity.contrast.test.Rd | 97 ++
man/drop.tip.Rd | 96 ++
man/edges.Rd | 50 +
man/evonet.Rd | 70 +
man/ewLasso.Rd | 48 +
man/fastme.Rd | 58 +
man/gammaStat.Rd | 41 +
man/hivtree.Rd | 56 +
man/howmanytrees.Rd | 66 +
man/identify.phylo.Rd | 62 +
man/image.DNAbin.Rd | 66 +
man/is.binary.tree.Rd | 35 +
man/is.compatible.Rd | 25 +
man/is.monophyletic.Rd | 59 +
man/is.ultrametric.Rd | 29 +
man/kronoviz.Rd | 33 +
man/ladderize.Rd | 29 +
man/landplants.Rd | 37 +
man/lmorigin.Rd | 83 ++
man/ltt.plot.Rd | 164 +++
man/makeLabel.Rd | 74 +
man/makeNodeLabel.Rd | 72 +
man/mantel.test.Rd | 68 +
man/mat3.Rd | 23 +
man/mat5M3ID.Rd | 19 +
man/mat5Mrand.Rd | 19 +
man/matexpo.Rd | 26 +
man/mcconwaysims.test.Rd | 56 +
man/mcmc.popsize.Rd | 116 ++
man/mixedFontLabel.Rd | 64 +
man/mrca.Rd | 36 +
man/mst.Rd | 76 +
man/multi2di.Rd | 47 +
man/multiphylo.Rd | 69 +
man/mvr.Rd | 45 +
man/nj.Rd | 49 +
man/njs.Rd | 45 +
man/node.depth.Rd | 46 +
man/nodelabels.Rd | 162 +++
man/opsin.Rd | 35 +
man/parafit.Rd | 77 +
man/pcoa.Rd | 119 ++
man/phydataplot.Rd | 116 ++
man/phymltest.Rd | 149 ++
man/pic.Rd | 71 +
man/pic.ortho.Rd | 59 +
man/plot.correlogram.Rd | 55 +
man/plot.phylo.Rd | 249 ++++
man/plot.varcomp.Rd | 22 +
man/print.phylo.Rd | 40 +
man/rTraitCont.Rd | 100 ++
man/rTraitDisc.Rd | 102 ++
man/rTraitMult.Rd | 60 +
man/read.GenBank.Rd | 70 +
man/read.caic.Rd | 43 +
man/read.dna.Rd | 146 ++
man/read.nexus.Rd | 56 +
man/read.nexus.data.Rd | 112 ++
man/read.tree.Rd | 116 ++
man/reorder.phylo.Rd | 59 +
man/richness.yule.test.Rd | 37 +
man/rlineage.Rd | 75 +
man/root.Rd | 81 ++
man/rotate.Rd | 108 ++
man/rtree.Rd | 68 +
man/seg.sites.Rd | 40 +
man/skyline.Rd | 150 ++
man/skylineplot.Rd | 93 ++
man/slowinskiguyer.test.Rd | 64 +
man/speciesTree.Rd | 57 +
man/stree.Rd | 45 +
man/subtreeplot.Rd | 41 +
man/subtrees.Rd | 41 +
man/summary.phylo.Rd | 53 +
man/treePop.Rd | 19 +
man/trex.Rd | 69 +
man/triangMtd.Rd | 32 +
man/unique.multiPhylo.Rd | 38 +
man/varCompPhylip.Rd | 68 +
man/varcomp.Rd | 35 +
man/vcv.phylo.Rd | 56 +
man/weight.taxo.Rd | 34 +
man/where.Rd | 35 +
man/which.edge.Rd | 31 +
man/woodmouse.Rd | 31 +
man/write.dna.Rd | 93 ++
man/write.nexus.Rd | 43 +
man/write.nexus.data.Rd | 78 ++
man/write.tree.Rd | 57 +
man/yule.Rd | 49 +
man/yule.cov.Rd | 99 ++
man/yule.time.Rd | 86 ++
man/zoom.Rd | 55 +
src/BIONJ.c | 341 +++++
src/Makevars | 1 +
src/NNI.c | 387 ++++++
src/SPR.c | 420 ++++++
src/TBR.c | 454 ++++++
src/additive.c | 66 +
src/ape.c | 139 ++
src/ape.h | 28 +
src/bNNI.c | 329 +++++
src/bionjs.c | 403 ++++++
src/bipartition.c | 213 +++
src/bitsplits.c | 268 ++++
src/delta_plot.c | 49 +
src/dist_dna.c | 1166 ++++++++++++++++
src/dist_nodes.c | 41 +
src/ewLasso.c | 239 ++++
src/heap.c | 112 ++
src/mat_expo.c | 61 +
src/me.c | 502 +++++++
src/me.h | 141 ++
src/me_balanced.c | 444 ++++++
src/me_ols.c | 641 +++++++++
src/mvr.c | 188 +++
src/mvrs.c | 399 ++++++
src/nj.c | 151 ++
src/njs.c | 681 +++++++++
src/pic.c | 37 +
src/plot_phylo.c | 105 ++
src/rTrait.c | 39 +
src/read_dna.c | 150 ++
src/reorder_phylo.c | 152 ++
src/treePop.c | 242 ++++
src/tree_build.c | 198 +++
src/tree_phylo.c | 79 ++
src/triangMtd.c | 357 +++++
src/triangMtds.c | 223 +++
src/ultrametric.c | 61 +
vignettes/MoranI.Rnw | 351 +++++
vignettes/ape.bib | 51 +
338 files changed, 38610 insertions(+)
diff --git a/DESCRIPTION b/DESCRIPTION
new file mode 100644
index 0000000..c51419d
--- /dev/null
+++ b/DESCRIPTION
@@ -0,0 +1,54 @@
+Package: ape
+Version: 3.1-1
+Date: 2014-03-06
+Title: Analyses of Phylogenetics and Evolution
+Authors at R: c(person("Emmanuel", "Paradis", role = c("aut", "cre", "cph"), email = "Emmanuel.Paradis at ird.fr"),
+ person("Ben", "Bolker", role = "aut"),
+ person("Julien", "Claude", role = "aut"),
+ person("Hoa Sien", "Cuong", role = "aut"),
+ person("Richard", "Desper", role = "aut"),
+ person("Benoit", "Durand", role = "aut"),
+ person("Julien", "Dutheil", role = "aut"),
+ person("Olivier", "Gascuel", role = "aut"),
+ person("Christoph", "Heibl", role = "aut"),
+ person("Daniel", "Lawson", role = "aut"),
+ person("Vincent", "Lefort", role = "aut"),
+ person("Pierre", "Legendre", role = "aut"),
+ person("Jim", "Lemon", role = "aut"),
+ person("Johan", "Nylander", role = "aut"),
+ person("Rainer", "Opgen-Rhein", role = "aut"),
+ person("Andrei-Alin", "Popescu", role = "aut"),
+ person("Klaus", "Schliep", role = "aut"),
+ person("Korbinian", "Strimmer", role = "aut"),
+ person("Damien", "de Vienne", role = "aut"))
+Depends: R (>= 3.0.0)
+Suggests: gee, expm
+Imports: nlme, lattice, graphics, stats, tools, utils
+ZipData: no
+Description: ape provides functions for reading, writing, plotting, and manipulating phylogenetic trees, analyses of comparative data in a phylogenetic framework, ancestral character analyses, analyses of diversification and macroevolution, computing distances from allelic and nucleotide data, reading and writing nucleotide sequences, and several tools such as Mantel's test, generalized skyline plots, graphical exploration of phylogenetic data (alex, trex, kronoviz), estimation of absolu [...]
+License: GPL (>= 2)
+URL: http://ape-package.ird.fr/
+Packaged: 2014-03-10 19:32:32 UTC; paradis
+Author: Emmanuel Paradis [aut, cre, cph],
+ Ben Bolker [aut],
+ Julien Claude [aut],
+ Hoa Sien Cuong [aut],
+ Richard Desper [aut],
+ Benoit Durand [aut],
+ Julien Dutheil [aut],
+ Olivier Gascuel [aut],
+ Christoph Heibl [aut],
+ Daniel Lawson [aut],
+ Vincent Lefort [aut],
+ Pierre Legendre [aut],
+ Jim Lemon [aut],
+ Johan Nylander [aut],
+ Rainer Opgen-Rhein [aut],
+ Andrei-Alin Popescu [aut],
+ Klaus Schliep [aut],
+ Korbinian Strimmer [aut],
+ Damien de Vienne [aut]
+Maintainer: Emmanuel Paradis <Emmanuel.Paradis at ird.fr>
+NeedsCompilation: yes
+Repository: CRAN
+Date/Publication: 2014-03-11 08:49:37
diff --git a/MD5 b/MD5
new file mode 100644
index 0000000..d0e1afe
--- /dev/null
+++ b/MD5
@@ -0,0 +1,337 @@
+6eca4e9713ddea6c8b8f10a0a91ee38e *DESCRIPTION
+1434ba4e31040404e8b049f75a705af5 *NAMESPACE
+8b12ae076e2ea8e6bf9b97f448e2ca65 *NEWS
+0c7bc9101516fd26fb3ddbedbe25b6a3 *R/CADM.global.R
+e042efca1d8a00d4178204f5f481b64d *R/CADM.post.R
+08df4be0f8ac832938928f93d66437bb *R/CDF.birth.death.R
+fdb9cfa0cbda82bda982b290693e44e3 *R/Cheverud.R
+5e7f355752302ea4822b62213ee3e3c0 *R/DNA.R
+0fbc7715dfdc8d54ded16d78ca3100f8 *R/MPR.R
+bb95af56d882b6162aa517a77140175e *R/MoranI.R
+dd2d159ad60c382ecc7331ddb10b3e5b *R/PGLS.R
+a683ed4e25ad199edc7d30e7b55181a6 *R/SDM.R
+0c8c5b7322f53936595f169f5fe1c65d *R/SlowinskiGuyer.R
+6f2c167948e151e900507bcacc30099e *R/ace.R
+4ce79cf3f3ff49bef989454d86d0c891 *R/additive.R
+9fca35b1005cce7b2a260b553dd971a3 *R/alex.R
+bac63a18722805eea425aec102e9e71c *R/all.equal.phylo.R
+73f08934c47e0dfb29c49a9d0885cdb3 *R/as.bitsplits.R
+c94018d5e792c72e20ce84085b2df9e7 *R/as.matching.R
+7989b47a70f6003ac477370d92e9655e *R/as.phylo.R
+1bb4dcfb44a7485710ec7f599d4b2ee8 *R/as.phylo.formula.R
+29efb767d4a207910c1da99c1eb6cb69 *R/balance.R
+76b5ca45b7210c85fdc20cd1579b33a2 *R/bind.tree.R
+a28930cdae07a271403e988e86a0c324 *R/biplot.pcoa.R
+92d9db6d7c1150d1a7c9443fd3d5cb04 *R/birthdeath.R
+4ee816e0dc69630d104fb5da4cc542c4 *R/branching.times.R
+e43b5dec7eae6d4bf9371e50117bf6ed *R/cherry.R
+02bdacc928572e8ab2d88380a075d7a8 *R/chronoMPL.R
+74e1019810b06458e808a447bb099a91 *R/chronopl.R
+f255979fbf13017c315569fc5e6ea8ca *R/chronos.R
+f6f25bb8f94f424dd6bbbab64eedb00d *R/clustal.R
+4f52fb37d822be586f0c5971295167dc *R/coalescent.intervals.R
+054bec70587f0056636b2cc52754c7f9 *R/collapse.singles.R
+338accc0accb8e67f31db5a90c033d2f *R/collapsed.intervals.R
+af76fbb797185c9738442161a2c923b4 *R/compar.gee.R
+89ce53eb1bb8c0fb36e95810cf7cd769 *R/compar.lynch.R
+207154a3a9b9ebbe5d7c29995565dc82 *R/compar.ou.R
+8d7c71929156744fd0e4fac370bf9456 *R/compute.brtime.R
+0092074917dc5631dc62fb9a3016145c *R/cophenetic.phylo.R
+d7db8dd1f147be51bcf4696c157d359a *R/cophyloplot.R
+d5ae510a60a962ca6420366e3bc9cb1a *R/dbd.R
+93480a5b64e0d37f5450891629557615 *R/delta.plot.R
+dfd5bb35f1cb1fd9154d023e0e4cfc2b *R/dist.gene.R
+811adaf272b8fd6a96fccf432f203099 *R/dist.topo.R
+b28ced504fedeb7f991f7eba10ad06df *R/diversi.gof.R
+8b2ec4004022afdc7e2cb42f2657b628 *R/diversi.time.R
+fd662cd4bbd6ce536ef379eca2e516ab *R/drop.tip.R
+1c4bdd6cf163aa4d605ed67249883ad4 *R/evonet.R
+fceafc86fae624fd9037403ad301d35a *R/ewLasso.R
+aa09abeb90ef891384128f978ffce843 *R/extract.popsize.R
+5c29d3ee785da587f4ad5288ec36b76a *R/gammaStat.R
+499b5f8596f40c32592fc85ee0e226ce *R/howmanytrees.R
+68d848281455c4c91e9b91f16170e2f7 *R/identify.phylo.R
+670971f4507c1138ca5d55cee936e4bc *R/is.binary.tree.R
+be075b35bb032eaca5946abd14ded1e3 *R/is.compatible.R
+35921387c705612d8f7c5baa06f9ab79 *R/is.monophyletic.R
+bea34df3719d1f2e1f772d813686af4b *R/is.ultrametric.R
+6133e277d2594d94345e6f10789a3a3a *R/ladderize.R
+65b2494ebd918c6f9a31c80e25370035 *R/lmorigin.R
+b4c7ccf40ec0c69a21da38965747d350 *R/ltt.plot.R
+5b4a31b11b83ea3371f75befcb42ea94 *R/makeLabel.R
+34069210fd7b12dda0979c45822e4d3a *R/makeNodeLabel.R
+a84000c0d7d2f53aec6a7105477f886a *R/mantel.test.R
+d2c16632492bfafd2ee18f2fe3d3d64a *R/matexpo.R
+566ed17c837a32977cb1546880d253b0 *R/mcmc.popsize.R
+61021f7af1175c46a743c7fee4cdc87e *R/me.R
+e1327a592199bac7ac8f670c3a068d46 *R/mrca.R
+a078728fb5907565f85b54b30e5bf83f *R/mst.R
+baf380fc68864e9a4c3d07f5158d3722 *R/multi2di.R
+0850fdd19c01d37ac632fc308632a463 *R/mvr.R
+282308c27ac1e78e330711d635d2e572 *R/nj.R
+e3f22d0f260c43be87a17b0ab091e2bb *R/njs.R
+1413a267f2ca08adce203e2ba44d74ad *R/nodelabels.R
+7425d422f7ca9b3966bb65a4e4336bbe *R/parafit.R
+fc0260f9e8e17fc1446117580bbc93cc *R/pcoa.R
+4999c85e82105ded85a214204321c3d1 *R/phydataplot.R
+2730f72b8b261609ae8a57a7f0c0bb8b *R/phymltest.R
+61d1360195bf4d5e6e2d8c30de335dc8 *R/pic.R
+8078e89cfb035143409212a78b99d07f *R/plot.phylo.R
+e579ec65c808c29e1ecaae1501784b37 *R/plot.popsize.R
+736506e2f67e90cf9326abead437d298 *R/plotPhyloCoor.R
+1e2485437566ca9af99d93b4580cbbc2 *R/print.lmorigin.R
+d0e8bd41d5acc217fdee3578adcf635b *R/print.parafit.R
+8c401518738b9cda403fa9f0eb382757 *R/rTrait.R
+ed6dc6a0298853c8a8eac2124f4ac288 *R/read.GenBank.R
+b13dfb8f455b1c9e74a364085f72dbce *R/read.caic.R
+0b661f16611ef934c60f0a003734d471 *R/read.dna.R
+399d7ecded9a81f64710dc3d705d46bb *R/read.nexus.R
+13ce7f5c7d1bcb7101469d12651e99c8 *R/read.nexus.data.R
+8aefdf68a66fc5ad148b4d5211a285ed *R/read.tree.R
+b1218f7862a66f566e4f3165f28fe47c *R/reorder.phylo.R
+cda4c985d8f4a51682c387c07bc6761b *R/root.R
+b31509f82422b3db2d2bc035bd3ad561 *R/rotate.R
+b7158b84c7ee7d9dcb2e0abeb6005cb0 *R/rtree.R
+cee88a7a00b3a858c18a3299eef49b79 *R/scales.R
+d2e06f8288af941a00c46248b586225a *R/skyline.R
+1f82059f740388b7430b2359e54a147f *R/skylineplot.R
+9c7b02a4625099f715700fb868226b0f *R/speciesTree.R
+28fce999b31a0c7d53816cec6916981f *R/subtreeplot.R
+bcc8f1fc8363728caba82129412d9e31 *R/subtrees.R
+fbbe3d3c1eec119690a296bfaff4b252 *R/summary.phylo.R
+8fbd1589f5d98d76b1154cffb8d4d1f5 *R/treePop.R
+b5081fca8758fe4458183c3e25e3e661 *R/triangMtd.R
+6e92716e8004feb088d5c093bad3828f *R/unique.multiPhylo.R
+2937379ad9e91e263b7956c264926466 *R/varcomp.R
+d2fef53445996fca1a2fca2d67f8dbb9 *R/vcv.phylo.R
+98260df0d86f094c3c9da02dbe1b27ac *R/which.edge.R
+aa484437bf64a39b737665b0769e320b *R/write.dna.R
+846c603fdb8bda22e5d3e2c81681221f *R/write.nexus.R
+2ac18a948dfca02a878b4ccf3a07b145 *R/write.nexus.data.R
+17d72a136a8131ea46ef9a20fcfd4d36 *R/write.tree.R
+a918c086a449bcca5ccbb04f7e6d50a9 *R/yule.R
+c8d3aa3fe64e75e61af07a1b11c74f3f *R/yule.time.R
+1eb44ff9e5a036eb845faa1598ce5009 *R/zoom.R
+3387c0d0c1f913f8471e1bb34bd2e516 *R/zzz.R
+cd2b040e90078a8a28a00223b7d0d458 *build/vignette.rds
+db9083e8750aff839d5ebf3ed982f1f1 *data/HP.links.rda
+9d9f9232839665422709ded1e541d038 *data/bird.families.rda
+a14a6df0f3a735ebc056065077788c90 *data/bird.orders.rda
+f74f9ed80c04756021cc093d40ca9ff9 *data/carnivora.csv.gz
+4eaf8cbaefa2e8f8d395a9b482ee9967 *data/chiroptera.rda
+1c74c3b99d08b0e17eea3ec1065c12d2 *data/cynipids.rda
+7fe760c2f3b4deba0554aae6138cb602 *data/gopher.D.rda
+7dd0f4cf4d6c445e72ca417e044365a8 *data/hivtree.newick.rda
+8d14f95319d0a5cdc8faa60a1d0085ce *data/hivtree.table.txt.gz
+cb4d7535f04a45685284beeb3c39b18b *data/landplants.newick.rda
+31be81fe3faca11f98d3e74c090bc59e *data/lice.D.rda
+38edbd84a0a067322c40db8d71fb1289 *data/lmorigin.ex1.rda
+e3ce9e3444182fea2e65df2e150ea0db *data/lmorigin.ex2.rda
+ce7a56faebdf286fdf5ba6c8c3699a79 *data/mat3.RData
+e2d1339025ed901009bfed58dc6505ff *data/mat5M3ID.RData
+101d0ab2e981b0987cde704a2dee1d8d *data/mat5Mrand.RData
+ea280638ed23f89ec89afc5464f368a5 *data/opsin.newick.rda
+39e4fece2bdc527d7a9d4d83d023a947 *data/woodmouse.rda
+828290996b613493f96e0fab024beebb *inst/CITATION
+3f54f3775bcf382e25df2a12228894f6 *inst/doc/MoranI.R
+abf2e3e84707634e32f3e7cc6a5ee7ae *inst/doc/MoranI.Rnw
+5980fdbb0b3f3e1f181f76072effaa88 *inst/doc/MoranI.pdf
+e6876b193a0df06697c788a8e48cf4bc *man/CADM.global.Rd
+060222d269ef45f0c7df76bb723e7d45 *man/DNAbin.Rd
+8b9bc214e32cde4c6e5970e48ff30c5f *man/Initialize.corPhyl.Rd
+4af2b7b7c40ed3ade258a0f08ddb16c0 *man/LTT.Rd
+ff05fd6fa0a2750b53abf025cdc021d3 *man/MPR.Rd
+e63ecbd9a4cf6de364e595d5999e3a2e *man/MoranI.Rd
+17486c0fd29fb6f4a752c53fe37142c4 *man/SDM.Rd
+24cdb97990ec1fde5482e5abb5972569 *man/ace.Rd
+60adac0f324c7b08a756d8f45c02b024 *man/add.scale.bar.Rd
+32d8ad6eeea971901aee33f1f654ae7c *man/additive.Rd
+0f37535a86413945bf3205b7a7b7c20b *man/alex.Rd
+9b59183f799d28e9a0f745ae7f098c48 *man/all.equal.phylo.Rd
+9d909782166d3e220550bdbb090c386f *man/ape-internal.Rd
+587cbd9d9a326b3990ed20bfe5016165 *man/ape-package.Rd
+e233fefd3f490b58b06f66886c8ee996 *man/as.alignment.Rd
+73c00aae390eaad1a86f3ede4a41e1a4 *man/as.bitsplits.Rd
+4f014cf2923e2eab6188acd48e8096fa *man/as.matching.Rd
+3a9546ce6447f5b6585b4bd58dc4c7f4 *man/as.phylo.Rd
+219cff7b94e167e18f4f9cd99cc8efc3 *man/as.phylo.formula.Rd
+42186fd973ac13c1d08f1e4d17023b87 *man/axisPhylo.Rd
+ad514b163e70bfbc11dfd34a450799f8 *man/balance.Rd
+868d03a447b2375bd9e99cde899cedea *man/base.freq.Rd
+524a1163eac56d1fc7f65bcd6c74a8d0 *man/bd.ext.Rd
+5f1e61abe5908708f503cb2626a1b5e6 *man/bd.time.Rd
+814a2437b237e083dfb91b404a8ede60 *man/bind.tree.Rd
+822558d4f7ee04257b2c903c53ec4344 *man/bionj.Rd
+71a008cfe65c4f524a5b66e68bbf81ab *man/bird.families.Rd
+0e41770e1e6d0b8d90c4cf51049213cb *man/bird.orders.Rd
+ef1c15d5d93410c21179997431112209 *man/birthdeath.Rd
+7569c1d30cd258f7ce414e2f42e7bc7a *man/boot.phylo.Rd
+5a64b90d3a6c7a8204946b00f45f4cfc *man/branching.times.Rd
+7dad9d632d914de8122f2455f0762546 *man/c.phylo.Rd
+9d3f9614732671a610cc8a37454885e2 *man/carnivora.Rd
+64c3996ca6bcc97d0d2e2cf3361f8f71 *man/cherry.Rd
+f82a24dc4bb17b5675ec7b422d575587 *man/chiroptera.Rd
+b40dd77fd2529626e983ee0300be6781 *man/chronoMPL.Rd
+c1f01c6200b2f1e2901d45d40daae404 *man/chronopl.Rd
+506d0332fb092ab87ca7674faef63ab7 *man/chronos.Rd
+cb0cdda41058b55d02b87df14c86f85e *man/clustal.Rd
+479f0a9817a0cfc257badeca23660ef0 *man/coalescent.intervals.Rd
+0841b19345d6f61e97852f6c810cccfd *man/collapse.singles.Rd
+08dfcbd8455de6b872a63883e38f5813 *man/collapsed.intervals.Rd
+301f271dc131de2efc3294d31f03afed *man/compar.cheverud.Rd
+4d8ee141d7b6b323ef5ee9446000ae32 *man/compar.gee.Rd
+9c81cd968fdee8f940dd8423506051a8 *man/compar.lynch.Rd
+8b079bc165c375f823c40074ad9106c6 *man/compar.ou.Rd
+70a4c1daab3326b147758128826248d6 *man/compute.brlen.Rd
+dbb4b5b1d5136bd32660699d9d4cc197 *man/compute.brtime.Rd
+cea3751e04bbda7eda58a8ca96466bac *man/consensus.Rd
+1e5b635a08fe0e1242801ff0caec9d0d *man/cophenetic.phylo.Rd
+1ca9ec0cb824468adc03884c940c7aa3 *man/cophyloplot.Rd
+b83a1aa72b6b94ccd7e519eaba7def04 *man/corBlomberg.Rd
+a210fe55aacb847936004458d4089b6d *man/corBrownian.Rd
+66548afbe896087e95ed8446397015a6 *man/corClasses.Rd
+673c9738c6ff3e237e11d35d62629bcc *man/corGrafen.Rd
+628a4d6339f82e7ef3debe96d19ffa02 *man/corMartins.Rd
+202f26f668a8fc7973d50696dcdd6cd4 *man/corPagel.Rd
+d7eb9b4fdf7036e82b5964bfd85e5e36 *man/correlogram.formula.Rd
+c199605f9d353b303acad4896f9b39a5 *man/cynipids.Rd
+34164e368efd0d5d961fe62e9ede75e8 *man/dbd.Rd
+e5fd45ae77e515b42d180a8c5369987d *man/del.gaps.Rd
+fbcd1d4bcf74e21fc93c195c7af3db98 *man/delta.plot.Rd
+d4dafdb3dcabdd4a984cb2bff4d987ad *man/dist.dna.Rd
+38011e81d28a120d88eead09e62c154a *man/dist.gene.Rd
+a93e4fe0f50b5b8ded1b47cb9c76ec1f *man/dist.topo.Rd
+883eb866baf7f1eb68b52ba5aa123c8e *man/diversi.gof.Rd
+d646ea0343999bd0e38e86dcf6c12018 *man/diversi.time.Rd
+0003bd93b9418ba7a7a4f89faf2f7338 *man/diversity.contrast.test.Rd
+55ed69cf42cb2fb768467870ef5e4c99 *man/drop.tip.Rd
+6ae02a689abea279f7e6650678aa7ae2 *man/edges.Rd
+7ad398603675bd4e0e1c5f5eeb1105bc *man/evonet.Rd
+28675cca1ce5738ba2cb3148d8e935cb *man/ewLasso.Rd
+fd760ac491d39a6c9bb32c95995e87b3 *man/fastme.Rd
+eea313e8ee32597b4cec120d23113642 *man/gammaStat.Rd
+3991fa7864e326579f1ab8b671095e4b *man/hivtree.Rd
+18012643a904f657fc5f5896f3d14054 *man/howmanytrees.Rd
+86c49d080fdffd614d8056021e91cc55 *man/identify.phylo.Rd
+1bfeb64b47a8d7ce253d5c6df6c18fc8 *man/image.DNAbin.Rd
+4bb168908d445690105ad4c00661b93b *man/is.binary.tree.Rd
+80a5a228a43679edf75903590253a875 *man/is.compatible.Rd
+d2de8fd9549ef01a1dddeb726dd77fcf *man/is.monophyletic.Rd
+9d09e72a00da6b7b3f967f76166077cd *man/is.ultrametric.Rd
+3f6ff8340b6c9770a1f4d2fed72a295d *man/kronoviz.Rd
+2afa6305e48e4c47a7d94d46401f85a3 *man/ladderize.Rd
+30290ed7800e405b5e82e23af384c6af *man/landplants.Rd
+4b86460e4e5d993abf13c99b9744dbd6 *man/lmorigin.Rd
+21bb31db5bcc8d8650467ef73fe0c0d3 *man/ltt.plot.Rd
+3d81c146cea3555ac60a7dede5fbb882 *man/makeLabel.Rd
+21a1880755f3dce16856f0987c3a25fd *man/makeNodeLabel.Rd
+817b23b342fe170de6500d13d9f54c82 *man/mantel.test.Rd
+97cf5ddb9352b0545ed225d16d750ffb *man/mat3.Rd
+f56f6f49c89c6bc850a7aee1bce5e0bd *man/mat5M3ID.Rd
+0d8eb60696c80de3cc9cc85ba66373a5 *man/mat5Mrand.Rd
+69ae0cb181240bb8ec168e69f1ba44bb *man/matexpo.Rd
+a8b9d6b04d35d75f43d1b283361a1642 *man/mcconwaysims.test.Rd
+d47c22d9e889ae5c878940c41c59d31f *man/mcmc.popsize.Rd
+a3180429a5f137f1749180084d984257 *man/mixedFontLabel.Rd
+dbcdc231c2f1f221818307bb33486159 *man/mrca.Rd
+dcee2d8c67b0a19c27aa3d833f33f83b *man/mst.Rd
+114f7834d51151cb6f92f8ed77becbcd *man/multi2di.Rd
+029b04adeafe89ea5edf9a1ab00cd154 *man/multiphylo.Rd
+00fb7ade93c2dd887be27e3dad8e2115 *man/mvr.Rd
+3df9e16b8a09df3f1dba5c4327a635fc *man/nj.Rd
+9ea7d5899a190171de4165e3240de62e *man/njs.Rd
+8f30d041ced38534477c2fac72fb1abf *man/node.depth.Rd
+a617a7e7ceacb8b2fd8a697de08b363c *man/nodelabels.Rd
+4f8b4cf2a725a8001e49390056181bef *man/opsin.Rd
+c2e2f35f4e233265c86b7967ec2d0630 *man/parafit.Rd
+89db814a5fc2e9fa5f0b9f4ad2f0d070 *man/pcoa.Rd
+1721a03534aaab0d59209197726d474b *man/phydataplot.Rd
+6dfa52711bab351bbcfe2624690eb730 *man/phymltest.Rd
+447941526b92322c52b5cfe367cb7088 *man/pic.Rd
+0363aa3fa3e86160934e2359c8ac5323 *man/pic.ortho.Rd
+265527313d479d3625df7680c7479cd1 *man/plot.correlogram.Rd
+e2440c324afa4a04836d72a93165839d *man/plot.phylo.Rd
+6bb1cf751772b9b6acf560b5f3c6f3c1 *man/plot.varcomp.Rd
+b24438c42cea969302ec6ba61002426e *man/print.phylo.Rd
+80bf68fd21b5e665329cf30b10a1655f *man/rTraitCont.Rd
+59e81eaae91dc77b4275c9a5b2910dda *man/rTraitDisc.Rd
+81f756fdf2ec4c968095595dece8338f *man/rTraitMult.Rd
+71b55f1d67b63610555f316ac454fb58 *man/read.GenBank.Rd
+9e31bccfa08c1d2da2180cd8f50ab250 *man/read.caic.Rd
+37d56f1aa48a2d9469d2e07d6dedc4d5 *man/read.dna.Rd
+5c9aed0b6f0a7e0f0fac9b5a59ac732f *man/read.nexus.Rd
+bc02e36c51d67074e661468993ed359b *man/read.nexus.data.Rd
+b1af1fd1362b66f6eae928bef96b38e8 *man/read.tree.Rd
+61e0bc86ae5a1f04ee6e88cdc92a2089 *man/reorder.phylo.Rd
+af19f262b468dfd7c12448d9d8085331 *man/richness.yule.test.Rd
+a3cf7db0d79645f61aa15634b21a5c92 *man/rlineage.Rd
+aa7d8a43e8456fe53480c023b7ef1648 *man/root.Rd
+6b97ea2fd96bf948fca764deab3a6e76 *man/rotate.Rd
+1a7314ee0aa76712737e76162df6cc74 *man/rtree.Rd
+2b2faabf81e29f320eff5adde7e6d75d *man/seg.sites.Rd
+ce6f293b22e9b0fd36f38c67b5f40e6e *man/skyline.Rd
+74d4e9d6fc374c26807825795dff1e0e *man/skylineplot.Rd
+0cede7cdef45fc9a8b993f938a32ce67 *man/slowinskiguyer.test.Rd
+a0db170675b1c265f1f4e7d56e88d7cb *man/speciesTree.Rd
+8fc51ff26614e7c713be2570d9af47b6 *man/stree.Rd
+1f1309e2ec6327974952d546241a6024 *man/subtreeplot.Rd
+ef8aa9721275f20ddd38612cddf8300c *man/subtrees.Rd
+0091fcdcb4aa48aa364da2512545f6c1 *man/summary.phylo.Rd
+3340a4f09c55010c15c0149a20b41c99 *man/treePop.Rd
+7749863f505076f2288c106eb465805e *man/trex.Rd
+dbb269e680caf8c722cf53c9b5ce7ace *man/triangMtd.Rd
+9e7d047e16ff821f3b7254b92d027bf0 *man/unique.multiPhylo.Rd
+3fc83bd5ac2be01f581d0aa5a1038b80 *man/varCompPhylip.Rd
+196c20c5aad9b231c4736375e50b3de3 *man/varcomp.Rd
+904af4ee107d88d1bd1b57bca4a8d535 *man/vcv.phylo.Rd
+a5d3cbf19df84d0f1e4e3a4650945cbf *man/weight.taxo.Rd
+19d511057993a6335549d8e84f6ef86a *man/where.Rd
+54579df63b905cb394dfabc5fc11843a *man/which.edge.Rd
+f569d0058bc598bb92c42ef99a58f272 *man/woodmouse.Rd
+510a3ad17baa847a3f581e9d1babb534 *man/write.dna.Rd
+b9fe1836be61c56a521386b00021fa67 *man/write.nexus.Rd
+be1c4b4bb84b892598b4ba87582622c8 *man/write.nexus.data.Rd
+b2302d65196726ab4cc573a22ee2d8e3 *man/write.tree.Rd
+2568c6529e40fae7effe88b6c73998a1 *man/yule.Rd
+7df89ac6996c82b52c4c9b3734807de1 *man/yule.cov.Rd
+8612123f3617699a8e29ddf0541dc9ee *man/yule.time.Rd
+a00006ae345bb9379312e81694de3885 *man/zoom.Rd
+225b45505001f9311e1d76f3a880cd70 *src/BIONJ.c
+2a6f9e9e044a78154d3cfda5936d6f48 *src/Makevars
+3174e9b61c83de87e8f14f428775d415 *src/NNI.c
+122ba51b574f7f7acd5ea4b6256cea5f *src/SPR.c
+d11fb19958f2953583a9c5876da82df9 *src/TBR.c
+9733c82cd67c4bd41aea44981f4ac8b8 *src/additive.c
+d343190ba59ef1feac9c96752f210687 *src/ape.c
+7eaffd3d85df9a1e4460905e9ca5eced *src/ape.h
+19b564aab62c464c092cdf2f0d5cf447 *src/bNNI.c
+e9b547980b563db2f6b062bdcf7c4abe *src/bionjs.c
+f782a97466ed8008d31afd7a3e9d4ea9 *src/bipartition.c
+a5d4f692aca36f6b50e123b443792fa1 *src/bitsplits.c
+81e4ad60b418966cdd09e608e074bb28 *src/delta_plot.c
+db663ebe2c21f6824447223b7322de59 *src/dist_dna.c
+2a6a59a3a220eb855a3c48bc73dc54ba *src/dist_nodes.c
+005ab69356525fbbc1b69950341308c2 *src/ewLasso.c
+afa27403972145d083d7f7f8b2536b98 *src/heap.c
+13eb779c3014478185f3a9d7a39765df *src/mat_expo.c
+d07550c1f789ea92d5dd7668e7521778 *src/me.c
+52c31d588a767b637b5a852fceeeb154 *src/me.h
+cc4c695b4b001305b83658df8075850e *src/me_balanced.c
+cf2bdcf9eda24eb6b572584c0ab79fb4 *src/me_ols.c
+8f25a7d4686c85b25862941c023e5974 *src/mvr.c
+b3da0884f49bb4564fa1109c3255aa38 *src/mvrs.c
+d3364013ad597425d01ac50ae4ee0b34 *src/nj.c
+1a4fa91d36ba25cf8d53d25683a2235e *src/njs.c
+7de13de6d828d870915c2efb6eb47ab6 *src/pic.c
+28ef72b2ccede817c0431afcb04e9c8c *src/plot_phylo.c
+aa8d9966da3b7e970879a49a40c05a07 *src/rTrait.c
+ab68729ab24b62eda61e1a2bd4a4481e *src/read_dna.c
+b5505d4f7c732c82bc54687d6fc37c0d *src/reorder_phylo.c
+d7d48424f600f5dad372a8c3ccfbbcad *src/treePop.c
+40d4ed144aba4b1acbc64d2807f33466 *src/tree_build.c
+42c108c79f26d1940f94b98fcbe271e1 *src/tree_phylo.c
+5937b5ba96d2ff5615badf55dff9ed5a *src/triangMtd.c
+ace51cbbe1e728d1e94e78ca99a6d019 *src/triangMtds.c
+72e04107c752568641219bf57b5731a8 *src/ultrametric.c
+abf2e3e84707634e32f3e7cc6a5ee7ae *vignettes/MoranI.Rnw
+70d5ed89ae0c78af85e1309702679087 *vignettes/ape.bib
diff --git a/NAMESPACE b/NAMESPACE
new file mode 100644
index 0000000..42e8faa
--- /dev/null
+++ b/NAMESPACE
@@ -0,0 +1,142 @@
+useDynLib(ape, .registration = TRUE)
+
+exportPattern("^[^\\.]")
+export(.compressTipLabel, .uncompressTipLabel, .PlotPhyloEnv)
+
+importFrom(graphics, arrows, identify, image.default, lines, plot,
+ plot.default, segments)
+importFrom(lattice, xyplot, panel.lines, panel.points)
+importFrom(nlme, corMatrix, Dim, getCovariate, getGroups,
+ getGroupsFormula, gls, Initialize)
+importFrom(stats, as.hclust, biplot, coef, cophenetic, drop1, hclust,
+ mahalanobis, reorder)
+importFrom(utils, setTxtProgressBar, txtProgressBar)
+
+## Methods for the classes defined in ape, including for the generics
+## defined in ape (see also below). Some methods are exported above.
+
+S3method(AIC, ace)
+S3method(anova, ace)
+S3method(deviance, ace)
+S3method(logLik, ace)
+S3method(print, ace)
+
+S3method(as.prop.part, bitsplits)
+S3method(is.compatible, bitsplits)
+S3method(print, bitsplits)
+
+S3method(drop1, compar.gee)
+S3method(predict, compar.gee)
+S3method(print, compar.gee)
+
+S3method("[", DNAbin)
+S3method(as.character, DNAbin)
+S3method(as.list, DNAbin)
+S3method(as.matrix, DNAbin)
+S3method(c, DNAbin)
+S3method(cbind, DNAbin)
+S3method(image, DNAbin)
+S3method(labels, DNAbin)
+S3method(makeLabel, DNAbin)
+S3method(print, DNAbin)
+S3method(rbind, DNAbin)
+
+S3method(as.phylo, evonet)
+S3method(plot, evonet)
+S3method(print, evonet)
+
+S3method("[", multiPhylo)
+S3method("[<-", multiPhylo)
+S3method("[[", multiPhylo)
+S3method("[[<-", multiPhylo)
+S3method("$", multiPhylo)
+S3method("$<-", multiPhylo)
+S3method(c, multiPhylo)
+S3method(makeLabel, multiPhylo)
+S3method(plot, multiPhylo)
+S3method(print, multiPhylo)
+S3method(str, multiPhylo)
+S3method(unique, multiPhylo)
+
+S3method("+", phylo)
+S3method(all.equal, phylo)
+S3method(as.hclust, phylo)
+S3method(as.matching, phylo)
+S3method(coalescent.intervals, phylo)
+S3method(c, phylo)
+S3method(cophenetic, phylo)
+S3method(identify, phylo)
+S3method(makeLabel, phylo)
+S3method(plot, phylo)
+S3method(print, phylo)
+S3method(reorder, phylo)
+S3method(skyline, phylo)
+S3method(summary, phylo)
+S3method(vcv, phylo)
+
+S3method(plot, phymltest)
+S3method(print, phymltest)
+S3method(summary, phymltest)
+
+S3method(lines, popsize)
+S3method(plot, popsize)
+
+S3method(as.bitsplits, prop.part)
+S3method(plot, prop.part)
+S3method(print, prop.part)
+S3method(summary, prop.part)
+
+S3method(lines, skyline)
+S3method(plot, skyline)
+
+## Methods for PGLS:
+
+## methods of coef() from stats:
+S3method(coef, corBlomberg)
+S3method(coef, corBrownian)
+S3method(coef, corGrafen)
+S3method(coef, corMartins)
+S3method(coef, corPagel)
+
+## methods to work with nlme:
+S3method(corMatrix, corBlomberg)
+S3method(corMatrix, corBrownian)
+S3method(corMatrix, corGrafen)
+S3method(corMatrix, corMartins)
+S3method(corMatrix, corPagel)
+S3method(Initialize, corPhyl)
+
+## Miscellaneous classes for which there is only one method:
+
+S3method(biplot, pcoa)
+
+S3method(plot, correlogram)
+S3method(plot, correlogramList)
+S3method(plot, mst)
+S3method(plot, varcomp)
+
+S3method(print, birthdeath)
+S3method(print, bitsplits)
+S3method(print, chronos)
+S3method(print, lmorigin)
+S3method(print, parafit)
+
+## Other methods of the generics defined in ape:
+
+S3method(as.DNAbin, alignment)
+S3method(as.DNAbin, character)
+S3method(as.DNAbin, list)
+
+S3method(as.phylo, formula)
+S3method(as.phylo, hclust)
+S3method(as.phylo, matching)
+S3method(as.phylo, phylog)
+
+S3method(coalescent.intervals, default)
+
+S3method(makeLabel, character)
+
+S3method(skyline, coalescentIntervals)
+S3method(skyline, collapsedIntervals)
+
+S3method(vcv, corPhyl)
diff --git a/NEWS b/NEWS
new file mode 100644
index 0000000..beb0b24
--- /dev/null
+++ b/NEWS
@@ -0,0 +1,3005 @@
+ CHANGES IN APE VERSION 3.1-1
+
+
+BUG FIXES
+
+ o rTraitCont: a bug was introduced in the previous release.
+
+
+
+ CHANGES IN APE VERSION 3.1
+
+
+NEW FEATURES
+
+ o Two new functions, bitsplits and countBipartitions, handle
+ bipartitions (aka splits) more efficiently.
+
+ o The new generic function as.prop.part helps to convert among
+ classes of bipartitions.
+
+ o Two new functions, phydataplot and ring, helps to graphically
+ annotate trees. The help page has many examples.
+
+ o The new function LLT draws the theoretical LTT-plot under
+ specified values of speciation and extinction rates together
+ with a prediction interval. The function has several options for
+ flexible plotting.
+
+ o predict.compar.gee() gains a new option, newdata, to predict
+ values from new observations of the predictors. This works like
+ most predict() methods.
+
+
+BUG FIXES
+
+ o root: the fix introduced in the previous version was not correct.
+
+ o compar.gee: using a user-defined link failed.
+
+ o plot.phylo: the tip labels were often outside the plotting area
+ with direction = "downward".
+
+ o unique.multiPhylo() did not work correctly with compressed lists.
+ This function now returns a vector of integers giving the
+ correspondance among similar trees.
+
+
+OTHER CHANGES
+
+ o add.scale.bar() now draws a longer bar by default.
+
+ o In boot.phylo(), the data 'x' must be a matrix-like object
+ (lists are no more accepted).
+
+ o boot.phylo() uses by default (ie, if rooted = FALSE) the new
+ function countBipartitions, and so should be much faster even
+ with small sample sizes and especially if the number of
+ bootstrap replicates is large.
+
+ o plot.phylo(, type = "fan") now colours the arcs in the same way
+ than the default type = "p".
+
+ o All instances of DUP=FALSE in calls of .C have been removed.
+
+
+
+ CHANGES IN APE VERSION 3.0-11
+
+
+BUG FIXES
+
+ o branching.times() now reorders the tree if needed.
+
+ o root(, resolved.root = TRUE) sometimes misplaced the root when
+ 'outgroup' was of length one.
+
+ o nodelabels() didn't work with versions of R older than 3.0.0.
+
+
+OTHER CHANGES
+
+ o The code of branching.times() is now ca. 3 times faster.
+
+
+
+ CHANGES IN APE VERSION 3.0-10
+
+
+NEW FEATURES
+
+ o The new function rotateConstr rotates internal branches given a
+ constraint on the order of the tips.
+
+ o plot.phylo() has a new option, node.depth, to specify the depths
+ of nodes when the tree is plotted without branch lengths.
+ node.depth() has a new option, method, with the same effect.
+
+ o ace() has a new option, use.eigen, used when type = "d" to avoid
+ computing matrix exponentials. With other coding improvements,
+ the function is now about five times faster.
+
+
+BUG FIXES
+
+ o node.height() and node.height.clado() returned wrong values.
+
+ o pie charts drawn by nodelabels(), and other functions, used to
+ draw a "3-o'clock" segment when only one proportion was equal to
+ one (fixed by Klaus).
+
+ o plot(phy, main = "title...") now works again.
+
+
+OTHER CHANGES
+
+ o Improved DESCRIPTION and NAMESPACE files.
+
+ o The C routines are now registered.
+
+ o The generic function as.igraph has been removed from ape as it
+ is now defined in the package igraph.
+
+ o node.height() has now an option 'clado.style' (FALSE by default).
+ node.height.clado() will be removed soon.
+
+ o The code of several functions has been improved.
+
+
+DEPRECATED & DEFUNCT
+
+ o mst() has been moved to pegas.
+
+
+
+ CHANGES IN APE VERSION 3.0-9
+
+
+NEW FEATURES
+
+ o getMRCA() is now documented.
+
+
+BUG FIXES
+
+ o ace(, type = "d") now checks for zero or negative branch lengths.
+
+ o ace(, type = "d") now catches the error if the SEs of the rates
+ cannot be calculated (usually due to a poor model fit).
+
+ o reorder.phylo() made R crash with badly conformed "phylo" trees.
+
+ o drop.tip(phy, interactive = TRUE) did not work.
+
+ o drop.tip() now returns NULL (with a warning) if all tips are
+ dropped.
+
+ o mixedFontLabel() failed when passed only one vector of
+ labels. It also failed when labels included - or '. In some
+ cases, spaces in labels were not treated correctly.
+
+ o root(, resolve.root = TRUE) wrongly placed the new root node
+ when the outgroup has more than one tip. This is fixed, and now
+ the root node is placed at the MRCA of the outgroup (and not of
+ the ingroup).
+
+ o where() failed with matrices.
+
+
+
+ CHANGES IN APE VERSION 3.0-8
+
+
+NEW FEATURES
+
+ o The new function ewLasso tests whether an incomplete set of
+ distances uniquely determines the edge weights of a given
+ unrooted topology using the 'Lasso' method by Dress et
+ al. (2012, J. Math. Biol. 65:77).
+
+ o ace() gains a new option 'use.expm' to use expm() from the
+ package of the same name in place of matexpo().
+
+
+BUG FIXES
+
+ o read.dna(, "fasta") may add '\r' in labels: this is fixed.
+
+ o prop.clades() returned wrong numbers when the tip labels of
+ 'phy' are not in the same order than the list of trees (thanks
+ to Rupert Collins for the report).
+
+ o CADM.post() displayed "1" on the diagonal of the matrix of
+ Mantel p-values. It now displays "NA" on the diagonal,
+ indicating that no test of significance is computed between a
+ distance matrix and itself.
+
+ o rtree(n, rooted = FALSE) returned trees with an 'edge' matrix
+ stored as doubles instead of integers for n > 4.
+
+
+OTHER CHANGES
+
+ o The files CDAM.global.R and CDAM.post.R have been renamed
+ CADM.global.R and CADM.post.R.
+
+ o ace() has a new default for its option 'method': this is "REML"
+ for continuous characters and "ML" for discrete ones.
+
+ o ape does not import gee anymore so the latter doesn't need to
+ be installed.
+
+
+
+ CHANGES IN APE VERSION 3.0-7
+
+
+NEW FEATURES
+
+ o The new function chronos estimates chronograms by penalised
+ likelihood and maximum likelihood with a completely reworked
+ code and interface. There is a new function makeChronosCalib to
+ set the calibration points easily. chronos() will eventually
+ replace chronopl().
+
+ o The new function 'where' searches patterns in DNA sequences.
+
+ o pic() gains an option 'rescaled.tree = FALSE' to return the tree
+ with its branch lengths rescaled for the PIC calculation.
+
+ o clustal(), muscle(), and tcoffee() gain an option
+ 'original.ordering = TRUE' to ease the comparisons of
+ alignments.
+
+ o plot.phylo() has a new option, open.angle, used when plotting
+ circular trees.
+
+ o The new function read.FASTA reads FASTA files much faster and
+ more efficiently. It is called internally by read.dna(, "fasta")
+ or can be called directly.
+
+
+BUG FIXES
+
+ o drop.tip() shuffled node labels on some trees.
+
+ o axisPhylo() now works correctly with circular trees, and gives a
+ sensible error message when type = "r" or "u".
+
+
+OTHER CHANGES
+
+ o .compressTipLabel() is 10 times faster thanks to Joseph Brown.
+
+ o base.freq() is now faster with lists.
+
+ o as.matrix.DNAbin() should be faster and more efficient with
+ lists; it now accepts vectors.
+
+
+
+ CHANGES IN APE VERSION 3.0-6
+
+
+NEW FEATURES
+
+ o reorder.phylo() has a new order, "postorder", and a new option
+ index.only = TRUE to return only the vector of indices (the tree
+ is unmodified, see ?reorder.phylo for details).
+
+ o The three new functions node.depth.edgelength, node.height, and
+ node.height.clado make some internal code available from R. See
+ ?node.depth (which was already documented) for details.
+
+
+BUG FIXES
+
+ o reorder(, "pruningwise") made R crash if the rows of the edge
+ matrix are in random order: this is now fixed.
+
+ o drop.tip() sometimes shuffled node labels (thanks to Rebecca
+ Best for the report).
+
+ o drop.tip(phy, "") returned a tree with zero-length tip labels:
+ it now returns the tree unchanged (thanks to Brian Anacker for
+ the report).
+
+ o plot.phylo() made R crash if the tree has zero-length tip
+ labels: it now returns NULL (thanks again to Brian Anacker).
+
+
+OTHER CHANGES
+
+ o dist.nodes() is now 6 to 10 times faster.
+
+ o reorder(, "cladewise") is now faster. The change is not very
+ visible for small trees (n < 1000) but this can be more than
+ 1000 faster for big trees (n >= 1e4).
+
+ o The attribute "order" of the objects of class "phylo" is now
+ strongly recommended, though not mandatory. Most functions in
+ ape should return a tree with this attribute correctly set.
+
+ o dbd() is now vectorized on both arguments 'x' (number of species
+ in clade) and 't' (clade age) to make likelihood calculations
+ easier and faster.
+
+
+
+ CHANGES IN APE VERSION 3.0-5
+
+
+BUG FIXES
+
+ o ace() should better catch errors when SEs cannot be computed.
+
+
+OTHER CHANGES
+
+ o write.dna(format = "fasta") now conforms more closely to the
+ FASTA standard thanks to Fran�ois Michonneau.
+
+ o print.DNAbin() does not print base compositions if there are more
+ than one million nucleotides.
+
+
+
+ CHANGES IN APE VERSION 3.0-4
+
+
+BUG FIXES
+
+ o read.dna() failed to read Phylip files if the first line used
+ tabulations instead of white spaces.
+
+ o read.dna() failed to read Phylip or Clustal files with less than
+ 10 nucleotides. (See other changes in this function below.)
+
+OTHER CHANGES
+
+ o read.dna() now requires at least one space (or tab) between the
+ taxa names and the sequences (whatever the length of taxa
+ names). write.dna() now follows the same rule.
+
+ o The option 'seq.names' of read.dna has been removed.
+
+ o The files ape-defunct.R and ape-defunct.Rd, which have not been
+ modified for almost two years, have been removed.
+
+ o The C code of bionj() has been reworked: it is more stable (by
+ avoiding passing character strings), slightly faster (by about
+ 20%), and numerically more accurate.
+
+ o The C code of fastme.*() has been slightly modified and should
+ be more stable by avoiding passing character strings (the
+ results are identical to the previous versions).
+
+ o The file src/newick.c has been removed.
+
+
+
+ CHANGES IN APE VERSION 3.0-3
+
+
+BUG FIXES
+
+ o birthdeath() now catches errors and warnings much better so that
+ a result is returned in most cases.
+
+
+OTHER CHANGES
+
+ o Because of problems with character string manipulation in C, the
+ examples in ?bionj and in ?fastme have been disallowed. In the
+ meantime, these functions might be unstable. This will be solved
+ for the next release.
+
+
+
+ CHANGES IN APE VERSION 3.0-2
+
+
+NEW FEATURES
+
+ o The new function alex (alignment explorator) zooms in a DNA
+ alignment and opens the result in a new window.
+
+
+BUG FIXES
+
+ o compute.brtime() did not completely randomized the order of the
+ branching times.
+
+ o write.nexus() did not work correctly with rooted trees (thanks
+ to Matt Johnson for the fix).
+
+ o mltt.plot(, backward = FALSE) did not set the x-axis correctly.
+
+ o A bug was introduced in prop.clades() with ape 3.0. The help page
+ has been clarified relative to the use of the option 'rooted'.
+
+ o mantel.test() printed a useless warning message.
+
+ o plot.phylo(, direction = "downward") ignored 'y.lim'.
+
+ o is.monophyletic() did not work correctly if 'tips' was not stored
+ as integers.
+
+ o prop.part() could make R crash if the first tree had many
+ multichotomies.
+
+ o njs(), bionjs(), and mvrs() now return an error if 'fs < 1'.
+
+ o SDM() did not work correctly. The code has also been generally
+ improved.
+
+
+OTHER CHANGES
+
+ o The DESCRIPTION file has been updated.
+
+ o The option 'original.data' of write.nexus() has been removed.
+
+ o The files bionjs.c, mvr.c, mvrs.c, njs.c, triangMtd.c, and
+ triangMtds.c have been improved which should fix some bugs in
+ the corresponding functions.
+
+ o dist.gene() now coerces input data frame as matrix resulting in
+ much faster calculations (thanks to a suggestion by Markus
+ Schlegel).
+
+
+
+ CHANGES IN APE VERSION 3.0-1
+
+
+NEW FEATURES
+
+ o dist.dna() has two new models: "indel" and "indelblock".
+
+ o bind.tree() now accepts 'position' > 0 when the trees have no
+ banch length permitting to create a node in 'x' when grafting
+ 'y' (see ?bind.tree for details).
+
+
+BUG FIXES
+
+ o cophyloplot( , rotate = TRUE) made R hanged after a few clicks.
+ Also the tree is no more plotted twice.
+
+ o read.GenBank() has been updated to work with EFetch 2.0.
+
+ o unroot() on trees in "pruningwise" order did not respect this
+ attribute.
+
+
+
+ CHANGES IN APE VERSION 3.0
+
+
+NEW FEATURES
+
+ o The three functions dyule, dbd, and dbdTime calculate the
+ density probability (i.e., the distribution of the number of
+ species) for the Yule, the constant and the time-dependent
+ birth-beath models, respectively. These probabilities can be
+ conditional on no extinction and/or on a log-scale.
+
+ o plot.phylo() has a new option 'rotate.tree' to rotate unrooted,
+ fan, or radial trees around the center of the plot.
+
+ o boot.phylo() and prop.clades() have a new option rooted =
+ FALSE. Note that the behaviour of prop.part() is unchanged.
+
+ o edgelabels() has a new option 'date' to place labels on edges of
+ chronograms using the time scale (suggestion by Rob Lanfear).
+
+
+BUG FIXES
+
+ o In chronopl(), the code setting the initial dates failed in
+ complicated settings (several dates known within intervals).
+ This has been generally improved and should result in faster
+ and more efficient convergence even in simple settings.
+
+ o mantel.test() sometimes returned P-values > 1 with the default
+ two-tailed test.
+
+ o extract.clade() sometimes shuffled some tip labels (thanks to
+ Ludovic Mallet and Mahendra Mariadassou for the fix).
+
+ o clustal() should now find by default the executable under Windows.
+
+
+OTHER CHANGES
+
+ o The code of yule() has been simplified and is now much faster for
+ big trees.
+
+ o The code of mantel.test() has been adjusted to be consistent
+ with common permutation tests.
+
+ o The C code of base.freq() has been improved and is now nearly 8
+ times faster.
+
+ o The option 'original.data' of write.nexus() is now deprecated and
+ will be removed in a future release.
+
+ o The code of is.ultrametric() has been improved and is now 3 times
+ faster.
+
+ o The code of vcv.phylo() has been improved and is now 10 or 30
+ times faster for 100 or 1000 tips, respectively. Consequently,
+ fitting models with PGLS will be faster overall.
+
+
+
+ CHANGES IN APE VERSION 2.8
+
+
+NEW FEATURES
+
+ o Twelve new functions have been written by Andrei-Alin Popescu:
+ additive, ultrametric, is.compatible, arecompatible, mvr, mvrs,
+ njs, bionjs, SDM, treePop, triangMtd, triangMtd*.
+
+ o A new class "bitsplits" has been created by Andrei-Alin Popescu
+ to code splits (aka, bipartition).
+
+ o There is a new generic function as.bitsplits with a method to
+ convert from the class "prop.part" to the class "bitsplits".
+
+ o The new function ltt.coplot plots on the same scales a tree and
+ the derived LTT plot.
+
+ o ltt.plot() has two new options: backward and tol. It can now
+ handle non-ultrametic trees and its internal coding has been
+ improved. The coordinates of the plot can now be computed with
+ the new function ltt.plot.coords.
+
+
+BUG FIXES
+
+ o prop.part() crashed if some trees had some multichotomies.
+
+
+
+ CHANGES IN APE VERSION 2.7-3
+
+
+NEW FEATURES
+
+ o The new function compute.brtime computes and sets branching times.
+
+ o mantel.test() has a new argument 'alternative' which is
+ "two-sided" by default. Previously, this test was one-tailed
+ with no possibility to change.
+
+ o ace() can now do REML estimation with continuous characters,
+ giving better estimates of the variance of the Brownian motion
+ process.
+
+
+BUG FIXES
+
+ o Branch lengths were wrongly updated with bind.tree(, where = <tip>,
+ position = 0). (Thanks to Liam Revell for digging this bug out.)
+
+ o Simulation of OU process with rTraitCont() did not work correctly.
+ This now uses formula from Gillespie (1996) reduced to a BM
+ process when alpha = 0 to avoid division by zero. The option
+ 'linear' has been removed.
+
+ o Cross-validation in chronopl() did not work when 'age.max' was
+ used.
+
+ o consensus(, p = 0.5) could return an incorrect tree if some
+ incompatible splits occur in 50% of the trees (especially with
+ small number of trees).
+
+ o c() with "multiPhylo" did not work correctly (thanks to Klaus
+ Schliep for the fix).
+
+ o root() failed in some cases with an outgroup made of several tips.
+ The help page has been clarified a bit.
+
+
+
+ CHANGES IN APE VERSION 2.7-2
+
+
+NEW FEATURES
+
+ o There is a new class "evonet" to code evolutionary networks, with
+ a constructor function evonet(), a print() and a plot() methods,
+ and four conversion methods to the classes "phylo", "networx",
+ "network", and "igraph".
+
+ o The new function rTraitMult does multivariate traits simulation
+ with user-defined models.
+
+ o plot.phylo() has a new option 'plot = TRUE'. If FALSE, the tree
+ is not plotted but the graphical device is set and the
+ coordinates are saved as usual.
+
+ o diversity.contrast.test() gains a fourth version of the test with
+ method = "logratio"; the literature citations have been clarified.
+
+ o add.scale.bar() has two new options, 'lwd' and 'lcol', to modify
+ the aspect of the bar.
+
+ o boot.phylo() now displays a progress bar by default (can be off
+ if 'quiet = TRUE').
+
+ o There is a new predict() method for compar.gee().
+
+
+BUG FIXES
+
+ o bionj() made R crash if distances were too large. It now returns
+ an error if at least one distance is greater than 100.
+
+ o drop.tip() returned a wrong tree if 'tip' was of zero length.
+
+ o read.nexus.data() failed with URLs.
+
+ o boot.phylo() returned overestimated support values in the
+ presence of identical or nearly identical sequences.
+
+
+OTHER CHANGES
+
+ o The data bird.families, bird.orders, cynipids, and woodmouse are
+ now provided as .rda files.
+
+
+
+ CHANGES IN APE VERSION 2.7-1
+
+
+NEW FEATURES
+
+ o The new function trex does tree exploration with multiple
+ graphical devices.
+
+ o The new function kronoviz plots several rooted (dated) trees on
+ the scale scale.
+
+ o identify.phylo() has a new option 'quiet' (FALSE by default).
+
+
+BUG FIXES
+
+ o A bug was introduced in read.nexus() in ape 2.7.
+
+ o image.DNAbin() did not colour correctly the bases if there were
+ some '-' and no 'N'.
+
+ o .compressTipLabel() failed with a list with a single tree.
+
+ o identify.phylo() returned a wrong answer when the x- and y-scales
+ are very different.
+
+ o write.nexus() failed with lists of trees with compressed labels.
+
+
+OTHER CHANGES
+
+ o identify.phylo() now returns NULL if the user right- (instead of
+ left-) clicks (an error was returned previously).
+
+ o read.nexus() should be robust to commands inserted in the TREES
+ block.
+
+
+
+ CHANGES IN APE VERSION 2.7
+
+
+NEW FEATURES
+
+ o There is a new image() method for "DNAbin" objects: it plots DNA
+ alignments in a flexible and efficient way.
+
+ o Two new functions as.network.phylo and as.igraph.phylo convert
+ trees of class "phylo" into these respective network classes
+ defined in the packages of the same names.
+
+ o The three new functions clustal, muscle, and tcoffee perform
+ nucleotide sequence alignment by calling the external programs
+ of the same names.
+
+ o Four new functions, diversity.contrast.test, mcconwaysims.test,
+ richness.yule.test, and slowinskiguyer.test, implement various
+ tests of diversification shifts using sister-clade comparisons.
+
+ o base.freq() gains an option 'all' to count all the possible bases
+ including the ambiguous ones (defaults to FALSE).
+
+ o write.nexus() now writes tree names in the NEXUS file if given a
+ list of trees with names.
+
+
+BUG FIXES
+
+ o prop.part() failed in some situations with unrooted trees.
+
+ o read.nexus() shuffled node labels when a TRANSLATE block was
+ present.
+
+ o varCompPhylip() did not work if 'exec' was specified.
+
+ o bind.tree() shuffled node labels when position > 0 and 'where'
+ was not the root.
+
+
+OTHER CHANGES
+
+ o BaseProportion in src/dist_dna.c has been modified.
+
+ o A number of functions in src/tree_build.c have been modified.
+
+ o The matching representation has now only two columns as the third
+ column was redundant.
+
+
+
+ CHANGES IN APE VERSION 2.6-3
+
+
+NEW FEATURES
+
+ o rTraitCont() and rTraitDisc() gains a '...' argument used with
+ user-defined models (suggestion by Gene Hunt).
+
+
+BUG FIXES
+
+ o as.hclust.phylo() now returns an error with unrooted trees.
+
+ o as.hclust.phylo() failed with trees with node labels (thanks to
+ Jinlong Zhang for pointing this bug out).
+
+ o read.dna(, "fasta") failed if sequences were not all of the same
+ length.
+
+ o plot.phylo() did not recycle values of 'font', 'cex' and
+ 'tip.color' correctly when type = "fan" or "radial".
+
+ o plot.phylo() ignored 'label.offset' when type = "radial", "fan", or
+ "unrooted" with lab4ut = "axial" (the placement of tip labels still
+ needs to be improved with lab4ut = "horizontal").
+
+
+OTHER CHANGES
+
+ o In drop.fossil() the default tol = 0 has been raised to 1e-8.
+
+ o The help command ?phylo now points to the man page of read.tree()
+ where this class is described. Similarly, ?matching points to the
+ man page of as.matching().
+
+
+
+ CHANGES IN APE VERSION 2.6-2
+
+
+NEW FEATURES
+
+ o Two new functions, pic.ortho and varCompPhylip, implements the
+ orthonormal contrasts of Felsenstein (2008, Am Nat, 171:713). The
+ second function requires Phylip to be installed on the computer.
+
+ o bd.ext() has a new option conditional = TRUE to use probabilities
+ conditioned on no extinction for the taxonomic data.
+
+
+BUG FIXES
+
+ o write.tree() failed to output correctly tree names.
+
+ o dist.nodes() returned duplicated column(s) with unrooted and/or
+ multichotomous trees.
+
+ o mcmc.popsize() terminated unexpectedly if the progress bar was
+ turned off.
+
+ o prop.part(x) made R frozen if 'x' is of class "multiPhylo".
+
+ o Compilation under Mandriva failed (thanks to Jos K�fer for the fix).
+
+ o drop.tip() shuffled tip labels with subtree = TRUE or trim.internal
+ = FALSE.
+
+ o Objects returned by as.hclust.phylo() failed when analysed with
+ cutree() or rect.hclust().
+
+ o write.tree() did not output correctly node labels (thanks to Naim
+ Matasci and Jeremy Beaulieu for the fix).
+
+ o ace(type = "discrete") has been improved thanks to Naim Marasci and
+ Jeremy Beaulieu.
+
+
+
+ CHANGES IN APE VERSION 2.6-1
+
+
+NEW FEATURES
+
+ o The new function speciesTree calculates the species tree from a set
+ of gene trees. Several methods are available including maximum tree
+ and shallowest divergence tree.
+
+
+BUG FIXES
+
+ o A bug introduced in write.tree() with ape 2.6 has been fixed.
+
+ o as.list.DNAbin() did not work correctly with vectors.
+
+ o as.hclust.phylo() failed with trees with node labels (thanks to
+ Filipe Vieira for the fix).
+
+
+
+ CHANGES IN APE VERSION 2.6
+
+
+NEW FEATURES
+
+ o The new functions rlineage and rbdtree simulate phylogenies under
+ any user-defined time-dependent speciation-extinction model. They
+ use continuous time algorithms.
+
+ o The new function drop.fossil removes the extinct species from a
+ phylogeny.
+
+ o The new function bd.time fits a user-defined time-dependent
+ birth-death model. It is a generalization of yule.time() taking
+ extinction into account.
+
+ o The new function MPR does most parsimonious reconstruction of
+ discrete characters.
+
+ o The new function Ftab computes the contingency table of base
+ frequencies from a pair of sequences.
+
+ o There is now an 'as.list' method for the class "DNAbin".
+
+ o dist.dna() can compute the number of transitions or transversions
+ with the option model = "Ts" or model = "Tv", respectively.
+
+ o [node|tip|edge]labels() gain three options with default values to
+ control the aspect of thermometers: horiz = TRUE, width = NULL,
+ and height = NULL.
+
+ o compar.gee() has been improved with the new option 'corStruct' as an
+ alternative to 'phy' to specify the correlation structure, and
+ calculation of the QIC (Pan 2001, Biometrics). The display of the
+ results has also been improved.
+
+ o read.GenBank() has a new option 'gene.names' to return the name of
+ the gene (FALSE by default).
+
+
+BUG FIXES
+
+ o extract.clade() sometimes shuffled the tip labels.
+
+ o plot.phylo(type = "unrooted") did not force asp = 1 (thanks to Klaus
+ Schliep for the fix)
+
+ o dist.dna(model = "logdet") used to divide distances by 4. The
+ documentation has been clarified on the formulae used.
+
+
+OTHER CHANGES
+
+ o rTraitCont(model = "OU") has an option 'linear = TRUE' to possibly
+ change the parameterisation (see ?rTraitCont for details).
+
+ o pic() now returns a vector with the node labels of the tree (if
+ available) as names.
+
+ o write.tree() and read.tree() have been substantially improved thanks
+ to contributions by Klaus Schliep.
+
+
+
+ CHANGES IN APE VERSION 2.5-3
+
+
+NEW FEATURES
+
+ o The new function mixedFontLabel helps to make labels with bits of
+ text to be plotted in different fonts.
+
+ o There are now replacement operators for [, [[, and $ for the class
+ "multiPhylo" (i.e., TREES[11:20] <- rmtree(10, 100)). They possibly
+ check that the tip labels are the same in all trees.
+
+ o Objects of class "multiPhylo" can be built with c(): there are
+ methods for the classes "phylo" and "multiPhylo".
+
+ o The internal functions .compressTipLabel and .uncompressTipLabel are
+ now documented.
+
+
+BUG FIXES
+
+ o bind.tree(x, y, where, position = 0) did not work correctly if 'y'
+ was a single-edge tree and 'where' was a tip.
+
+ o rTraitCont() did not use the square-root of branch lengths when
+ simulating a Brownian motion model.
+
+
+
+ CHANGES IN APE VERSION 2.5-2
+
+
+NEW FEATURES
+
+ o There is now a print method for results from ace().
+
+ o There is a labels() method for objects of class "DNAbin".
+
+ o read.dna() has a new option 'as.matrix' to possibly force sequences
+ in a FASTA file to be stored in a matrix (see ?read.dna for details).
+
+
+BUG FIXES
+
+ o as.phylo.hclust() used to multiply edge lengths by 2.
+
+ o A minor bug was fixed in rTraitDisc().
+
+ o ace() sometimes failed (parameter value was NaN and the optimisation
+ failed).
+
+
+DEPRECATED & DEFUNCT
+
+ o evolve.phylo() and plot.ancestral() have been removed.
+
+ o chronogram(), ratogram(), and NPRS.criterion() have been removed.
+
+
+OTHER CHANGES
+
+ o nj() has been improved and is now about 30% faster.
+
+ o The default option 'drop' of [.DNAbin has been changed to FALSE to
+ avoid dropping rownames when selecting a single sequence.
+
+ o print.DNAbin() has been changed to summary.DNAbin() which has been
+ removed.
+
+
+
+ CHANGES IN APE VERSION 2.5-1
+
+
+NEW FEATURES
+
+ o The new function stree generates trees with regular shapes.
+
+ o It is now possible to bind two trees with x + y (see ?bind.tree for
+ details).
+
+ o drop.tip(), extract.clade(), root(), and bind.tree() now have an
+ 'interactive' option to make the operation on a plotted tree.
+
+ o cophyloplot() gains two new arguments 'lwd' and 'lty' for the
+ association links; they are recycled like 'col' (which wasn't before).
+
+
+BUG FIXES
+
+ o rTraitDisc() did not use its 'freq' argument correctly (it was
+ multiplied with the rate matrix column-wise instead of row-wise).
+
+ o [node|tip|edge]labels(thermo = ) used to draw empty thermometers
+ with NA values. Nothing is drawn now like with 'text' or 'pch'.
+ The same bug occurred with the 'pie' option.
+
+ o A bug was fixed in compar.ou() and the help page was clarified.
+
+ o bind.tree() has been rewritten fixing several bugs and making it
+ more efficient.
+
+ o plot.phylo(type = "p") sometimes failed to colour correctly the
+ vertical lines representing the nodes.
+
+ o plot.phylo(direction = "l", x.lim = 30) failed to plot the branches
+ in the correct direction though the tip labels were displayed
+ correctly.
+
+
+OTHER CHANGES
+
+ o The c, cbind, and rbind methods for "DNAbin" objetcs now check that
+ the sequences are correctly stored (in a list for c, in a matrix
+ for the two other functions).
+
+
+
+ CHANGES IN APE VERSION 2.5
+
+
+NEW FEATURES
+
+ o The new function parafit by Pierre Legendre tests for the
+ coevolution between hosts and parasites. It has a companion
+ function, pcoa, that does principal coordinate decomposition.
+ The latter has a biplot method.
+
+ o The new function lmorigin by Pierre Legendre performs multiple
+ regression through the origin with testing by permutation.
+
+ o The new functions rTraitCont and rTraitDisc simulate continuous and
+ discrete traits under a wide range of evolutionary models.
+
+ o The new function delta.plot does a delta plot following Holland et
+ al. (2002, Mol. Biol. Evol. 12:2051).
+
+ o The new function edges draws additional branches between any nodes
+ and/or tips on a plotted tree.
+
+ o The new function fancyarrows enhances arrows from graphics with
+ triangle and harpoon heads; it can be called from edges().
+
+ o add.scale.bar() has a new option 'ask' to draw interactively.
+
+ o The branch length score replaces the geodesic distance in dist.topo.
+
+ o Three new data sets are included: the gopher-lice data (gopher.D),
+ SO2 air pollution in 41 US cities (lmorigin.ex1, from Sokal &
+ Rohlf 1995), and some host-parasite specificity data
+ (lmorigin.ex2, from Legendre & Desdevises 2009).
+
+
+BUG FIXES
+
+ o add.scale.bar() drew the bar outside the plotting region with the
+ default options with unrooted or radial trees.
+
+ o dist.topo() made R stuck when the trees had different sizes (thanks
+ to Otto Cordero for the fix).
+
+
+OTHER CHANGES
+
+ o The geodesic distance has been replaced by the branch length score
+ in dist.topo().
+
+
+
+ CHANGES IN APE VERSION 2.4-1
+
+
+NEW FEATURES
+
+ o rtree() and rcoal() now accept a numeric vector for the 'br'
+ argument.
+
+ o vcv() is a new generic function with methods for the classes "phylo"
+ and "corPhyl" so that it is possible to calculate the var-cov matrix
+ for "transformation models". vcv.phylo() can still be used for trees
+ of class "phylo"; its argument 'cor' has been renamed 'corr'.
+
+
+BUG FIXES
+
+ o bind.tree() failed when 'y' had no root edge.
+
+ o read.nexus() shuffled tip labels when the trees have no branch
+ lengths and there is a TRANSLATE block.
+
+ o read.nexus() does not try to translate node labels if there is a
+ translation table in the NEXUS file. See ?read.nexus for a
+ clarification on this behaviour.
+
+ o plot.multiPhylo() crashed R when plotting a list of trees with
+ compressed tip labels.
+
+ o write.nexus() did not translate the taxa names when asked for.
+
+ o plot.phylo(type = "fan") did not rotate the tip labels correctly
+ when the tree has branch lengths.
+
+ o ace(type = "continuous", method = "ML") now avoids sigma� being
+ negative (which resulted in an error).
+
+ o nj() crashed with NA/NaN in the distance matrix: an error in now
+ returned.
+
+
+
+ CHANGES IN APE VERSION 2.4
+
+
+NEW FEATURES
+
+ o base.freq() has a new option 'freq' to return the counts; the
+ default is still to return the proportions.
+
+
+BUG FIXES
+
+ o seg.sites() did not handle ambiguous nucleotides correctly: they
+ are now ignored.
+
+ o plot(phy, root.edge = TRUE) failed if there was no $root.edge in
+ the tree: the argument is now ignored.
+
+ o add.scale.bar() failed when 'x' and 'y' were given (thanks to Janet
+ Young for the fix).
+
+
+OTHER CHANGES
+
+ o Trying to plot a tree with a single tip now returns NULL with a
+ warning (it returned an error previously).
+
+ o The way lines representing nodes are coloured in phylograms has
+ been modified (as well as their widths and types) following some
+ users' request; this is only for dichotomous nodes.
+
+ o The argument 'adj' in [node][tip][edge]labels() now works when
+ using 'pie' or 'thermo'.
+
+ o A more informative message error is now returned by dist.dna() when
+ 'model' is badly specified (partial matching of this argument is
+ done now).
+
+ o Deprecated functions are now listed in a help page: see
+ help("ape-defunct") with the quotes.
+
+
+DEPRECATED & DEFUNCT
+
+ o The functions heterozygosity, nuc.div, theta.h, theta.k and
+ theta.s have been moved from ape to pegas.
+
+ o The functions mlphylo, DNAmodel and sh.test have been removed.
+
+
+
+ CHANGES IN APE VERSION 2.3-3
+
+
+BUG FIXES
+
+ o add.scale.bar() always drew a horizontal bar.
+
+ o zoom() shuffled tips with unrooted trees.
+
+ o write.nexus() failed to write correctly trees with a "TipLabel"
+ attribute.
+
+ o rcoal() failed to compute branch lengths with very large n.
+
+ o A small bug was fixed in compar.cheverud() (thanks to Michael
+ Phelan for the fix).
+
+ o seg.sites() failed when passing a vector.
+
+ o drop.tip() sometimes shuffled tip labels.
+
+ o root() shuffled node labels with 'resolve.root = TRUE'.
+
+
+
+ CHANGES IN APE VERSION 2.3-2
+
+
+BUG FIXES
+
+ o all.equal.phylo() did not compare unrooted trees correctly.
+
+ o dist.topo(... method = "PH85") did not treat unrooted trees
+ correctly (thanks to Tim Wallstrom for the fix).
+
+ o root() sometimes failed to test for the monophyly of the
+ outgroup correctly.
+
+ o extract.clade() sometimes included too many edges.
+
+ o vcv.phylo() did not work correctly when the tree is in
+ "pruningwise" order.
+
+ o nj() did not handle correctly distance matrices with many 0's.
+ The code has also been significantly improved: 7, 70, 160 times
+ faster with n = 100, 500, 1000, respectively.
+
+
+
+ CHANGES IN APE VERSION 2.3-1
+
+
+NEW FEATURES
+
+ o The new function is.monophyletic tests the monophyly of a group.
+
+ o There is now a c() method for lists of class "DNAbin".
+
+ o yule.cov() now fits the null model, and its help page has been
+ corrected with respect to this change.
+
+ o drop.tip() has a new option 'rooted' to force (or not) a tree
+ to be treated as (un)rooted.
+
+
+BUG FIXES
+
+ o dist.gene() failed on most occasions with the default
+ pairwise.deletion = FALSE.
+
+ o read.tree() failed to read correctly the tree name(s).
+
+ o boot.phylo() now treats correctly data frames.
+
+ o del.gaps() did not copy the rownames of a matrix.
+
+ o A small bug was fixed in CDAM.global().
+
+ o ace() failed with large data sets. Thanks to Rich FitzJohn for
+ the fix. With other improvements, this function is now about 6
+ times faster.
+
+ o write.tree() failed with objects of class "multiPhylo".
+
+ o drop.tip(, subtree = TRUE) sometimes shuffled tip labels.
+
+
+OTHER CHANGES
+
+ o [.multiPhylo and [.DNAbin now respect the original class.
+
+ o Instances of the form class(phy) == "phylo" have been replaced
+ by inherits(phy, "phylo").
+
+ o rcoal() is now faster.
+
+
+DEPRECATED & DEFUNCT
+
+ o klastorin() has been removed.
+
+
+
+ CHANGES IN APE VERSION 2.3
+
+
+NEW FEATURES
+
+ o The new functions CADM.global and CADM.post, contributed by
+ Pierre Legendre, test the congruence among several distance
+ matrices.
+
+ o The new function yule.time fits a user-defined time-dependent
+ Yule model by maximum likelihood.
+
+ o The new function makeNodeLabel creates and/or modifies node
+ labels in a flexible way.
+
+ o read.tree() and write.tree() have been modified so that they can
+ handle individual tree names.
+
+ o plot.phylo() has a new argument 'edge.lty' that specifies the
+ types of lines used for the edges (plain, dotted, dashed, ...)
+
+ o phymltest() has been updated to work with PhyML 3.0.1.
+
+
+BUG FIXES
+
+ o drop.tip() shuffled tip labels in some cases.
+
+ o drop.tip() did not handle node.label correctly.
+
+ o is.ultrametric() now checks the ordering of the edge matrix.
+
+ o ace() sometimes returned negative values of likelihoods of
+ ancestral states (thanks to Dan Rabosky for solving this long
+ lasting bug).
+
+
+OTHER CHANGES
+
+ o The data set xenarthra has been removed.
+
+
+
+ CHANGES IN APE VERSION 2.2-4
+
+BUG FIXES
+
+ o The bug fix in read.nexus() in version 2.2-3 was wrong: this is
+ now fixed. (Thanks to Peter Wragg for the fix!)
+
+ o A warning message occurred for no reason with ace(method="GLS").
+
+
+OTHER CHANGES
+
+ o There is now a general help page displayed with '?ape'.
+
+
+
+ CHANGES IN APE VERSION 2.2-3
+
+
+NEW FEATURES
+
+ o The new function extract.clade extracts a clade from a tree by
+ specifying a node number or label.
+
+ o fastme.bal() has two new options 'spr' and 'tbr' to perform tree
+ operations of the same names.
+
+ o dist.dna() can now return the number of site differences by
+ specifying model="N".
+
+
+BUG FIXES
+
+ o chronopl() did not work with CV = TRUE.
+
+ o read.nexus() did not work correctly in some situations (trees on
+ multiple lines with different numbers of lines and/or with
+ comments inserted within the trees).
+
+ o ltt.plot(), ltt.lines(), and mltt.plot() did not count correctly
+ the number of lineages with non-binary trees.
+
+
+OTHER CHANGES
+
+ o ape has now a namespace.
+
+ o drop.tip() has been improved: it should be much faster and work
+ better in some cases (e.g., see the example in ?zoom).
+
+
+
+ CHANGES IN APE VERSION 2.2-2
+
+
+NEW FEATURES
+
+ o dist.gene() has been substantially improved and gains an option
+ 'pairwise.deletion'.
+
+ o cbind.DNAbin() has a new option 'fill.with.gaps' and is now
+ more flexible.
+
+
+BUG FIXES
+
+ o prop.part() failed with a single tree with the default option
+ 'check.labels = TRUE'.
+
+ o summary.DNAbin() failed to display correctly the summary of
+ sequence lengths with lists of sequences of 10,000 bases or more
+ (because summary.default uses 4 significant digits by default).
+
+ o read.nexus() failed to read a file with a single tree with line
+ breaks in the Newick string.
+
+ o del.gaps() returned a list of empty sequences when there were no
+ gaps.
+
+
+OTHER CHANGES
+
+ o phymltest() has been updated for PhyML 3.0 and gains an option
+ 'append', whereas the option 'path2exec' has been removed.
+
+ o rbind.DNAbin() and cbind.DNAbin() now accept a single matrix
+ which is returned unchanged (instead of an error).
+
+ o The data sets bird.orders and bird.families are now stored as
+ Newick strings; i.e., the command data(bird.orders) calls
+ read.tree().
+
+
+
+ CHANGES IN APE VERSION 2.2-1
+
+
+NEW FEATURES
+
+ o The new function makeLabel() helps to modify labels of trees,
+ lists of trees, or DNA sequences, with several utilities to
+ truncate and/or make them unique, substituting some
+ characters, and so on.
+
+ o The new function del.gaps() removes insertion gaps ("-") in a
+ set of DNA sequences.
+
+ o read.dna() can now read Clustal files (*.aln).
+
+
+BUG FIXES
+
+ o root() failed with 'resolve.root = TRUE' when the root was
+ already the specified root.
+
+ o Several bugs were fixed in mlphylo().
+
+ o collapsed.singles() did not propagate the 'Nnode' and
+ 'node.labels' elements (thanks to Elizabeth Purdom for the fix).
+
+ o read.nexus() failed to remove correctly the comments within
+ trees.
+
+ o read.nexus() failed to read a file with a single tree and no
+ translation of tip labels.
+
+ o read.nexus() failed to place correctly tip labels when reading
+ a single tree with no edge lengths.
+
+ o A bug was fixed in sh.test().
+
+
+OTHER CHANGES
+
+ o unique.multiPhylo() is faster thanks to a suggestion by Vladimir
+ Minin.
+
+ o The option 'check.labels' of consensus() and prop.part() is now
+ TRUE by default.
+
+ o write.dna() now does not truncate names to 10 characters with
+ the Phylip formats.
+
+
+
+ CHANGES IN APE VERSION 2.2
+
+
+NEW FEATURES
+
+ o Four new functions have been written by Damien de Vienne for the
+ graphical exploration of large trees (cophyloplot, subtrees,
+ subtreeplot), and to return the graphical coordinates of tree
+ (without plotting).
+
+ o The new functions corPagel and corBlomberg implement the Pagel's
+ "lambda" and Blomberg et al.'s "ACDC" correlation structures.
+
+ o chronopl() has been improved and gains several options: see its
+ help page for details.
+
+ o boot.phylo() has now an option 'trees' to possibly return the
+ bootstraped trees (the default is FALSE).
+
+ o prop.part() has been improved and should now be faster in all
+ situations.
+
+
+BUG FIXES
+
+ o read.dna() failed if "?" occurred in the first 10 sites of the
+ first sequence.
+
+ o The x/y aspect of the plot is now respected when plotting a
+ circular tree (type = "r" or "f").
+
+ o Drawing the tip labels sometimes failed when plotting circular
+ trees.
+
+ o zoom() failed when tip labels were used instead of their numbers
+ (thanks to Yan Wong for the fix).
+
+ o drop.tip() failed with some trees (fixed by Yan Wong).
+
+ o seg.sites() failed with a list.
+
+ o consensus() failed in some cases. The function has been improved
+ as well and is faster.
+
+
+
+ CHANGES IN APE VERSION 2.1-3
+
+
+BUG FIXES
+
+ o A bug in read.nexus() made the Windows R-GUI crash.
+
+ o An error was fixed in the computation of ancestral character
+ states by generalized least squares in ace().
+
+ o di2multi() did not modify node labels correctly.
+
+ o multi2di() failed if the tree had its attribute "order" set to
+ "cladewise".
+
+
+
+ CHANGES IN APE VERSION 2.1-2
+
+
+NEW FEATURES
+
+ o There three new methods for the "multiPhylo" class: str, $,
+ and [[.
+
+ o root() gains the options 'node' and 'resolve.root'
+ (FALSE by default) as well as its code being improved.
+
+ o mltt.plot() has now an option 'log' used in the same way
+ than in plot.default().
+
+
+BUG FIXES
+
+ o mltt.plot() failed to display the legend with an unnamed
+ list of trees.
+
+ o nodelabels() with pies now correcly uses the argument
+ 'cex' to draw symbols of different sizes (which has
+ worked already for thermometers).
+
+ o read.nexus() generally failed to read very big files.
+
+
+OTHER CHANGES
+
+ o The argument 'family' of compar.gee() can now be a function
+ as well as a character string.
+
+ o read.tree() and read.nexus() now return an unnamed list if
+ 'tree.names = NULL'.
+
+ o read.nexus() now returns a modified object of class "multiPhylo"
+ when there is a TRANSLATE block in the NEXUS file: the individual
+ trees have no 'tip.label' vector, but the list has a 'TipLabel'
+ attribute. The new methods '$' and '[[' set these elements
+ correctly when extracting trees.
+
+
+
+ CHANGES IN APE VERSION 2.1-1
+
+
+NEW FEATURES
+
+ o The new function rmtree generates lists of random trees.
+
+ o rcoal() now generates a genuine coalescent tree by default
+ (thanks to Vladimir Minin for the code).
+
+
+BUG FIXES
+
+ o nuc.div() returned an incorrect value with the default
+ pairwise.deletion = FALSE.
+
+
+OTHER CHANGES
+
+ o The internal codes of bionj(), fastme.bal(), and fastme.ols()
+ have been improved so that they are stabler and faster.
+
+ o R packages used by ape are now loaded silently; lattice and gee
+ are loaded only when needed.
+
+
+
+ CHANGES IN APE VERSION 2.1
+
+
+NEW FEATURES
+
+ o The new function identify.phylo identifies clades on a plotted
+ tree using the mouse.
+
+ o It is now possible to subset a list of trees (object of class
+ "multiPhylo") with "[" while keeping its class correct.
+
+ o The new function as.DNAbin.alignment converts DNA sequences
+ stored in the "alignment" format of the package seqinr into
+ an object of class "DNAbin".
+
+ o The new function weight.taxo2 helps to build similarity matrices
+ given two taxonomic levels (usually called by other functions).
+
+ o write.tree() can now take a list of trees (class "multiPhylo")
+ as its main argument.
+
+ o plot.correlogram() and plot.correlogramList() have been
+ improved, and gain several options (see the help page for
+ details). A legend is now plotted by default.
+
+
+BUG FIXES
+
+ o dist.dna() returned some incorrect values with `model = "JC69"'
+ and `pairwise.deletion = TRUE'. This affected only the
+ distances involving sequences with missing values. (Thanks
+ to Bruno Toupance for digging this bug out.)
+
+ o write.tree() failed with some trees: this is fixed by removing
+ the `multi.line' option (trees are now always printed on a
+ single line).
+
+ o read.nexus() did not correctly detect trees with multiple root
+ edges (see OTHER CHANGES).
+
+
+OTHER CHANGES
+
+ o The code of mlphylo() has been almost entirely rewritten, and
+ should be much stabler. The options have been also greatly
+ simplified (see ?mlphylo and ?DNAmodel for details).
+
+ o The internal function nTips has been renamed klastorin_nTips.
+
+ o The code of is.ultrametric() contained redundancies and has
+ been cleaned-up.
+
+ o The code of Moran.I() and of correlogram.formula() have been
+ improved.
+
+ o read.tree() and read.nexus() now return an error when trying to
+ read a tree with multiple root edges (see BUG FIXES). The
+ correction applied in previous version did not work in all
+ situations.
+
+ o The class c("multi.tree", "phylo") has been renamed
+ "multiPhylo".
+
+
+DOCUMENTATION
+
+ o There is now a vignette in ape: see vignette("MoranI", "ape").
+
+
+DEPRECATED & DEFUNCT
+
+ o as.matching() and as.phylo.matching() do not support branch
+ lengths.
+
+ o correlogram.phylo() and discrete.dist() have been removed.
+
+
+
+ CHANGES IN APE VERSION 2.0-2
+
+
+NEW FEATURES
+
+ o The new function matexpo computes the exponential of a square
+ matrix.
+
+ o The new function unique.multi.tree removes duplicate trees from
+ a list.
+
+ o yule() has a new option `use.root.edge = FALSE' that specifies
+ to ignore, by default, the root edge of the tree if it exists.
+
+
+BUG FIXES
+
+ o which.edge() failed when the index of a single terminal edge was
+ looked for.
+
+ o In diversi.time(), the values returned for model C were
+ incorrect.
+
+ o A bug was fixed in yule() that affected the calculation of the
+ likelihood in the presence of ties in the branching times.
+
+ o There was a bug in the C function mat_expo4x4 affecting the
+ calculations of the transition probabilities for models HKY and
+ GTR in mlphylo().
+
+ o A small bug was fixed in as.matrix.DNAbin (thanks to James
+ Bullard).
+
+ o rtree() did not `shuffle' the tip labels by default, so only a
+ limited number of labelled topologies could be generated.
+
+
+
+ CHANGES IN APE VERSION 2.0-1
+
+
+NEW FEATURES
+
+ o The three new functions bionj, fastme.ols, and fastme.bal
+ perform phylogeny estimation by the BIONJ and fastME methods in
+ OLS and balanced versions. This is a port to R of previous
+ previous programs done by Vincent Lefort.
+
+ o The new function chronoMPL performs molecular dating with the
+ mean path lengths method of Britton et al. (2002, Mol. Phyl.
+ Evol. 24: 58).
+
+ o The new function rotate, contributed by Christoph Heibl, swaps
+ two clades connected to the same node. It works also with
+ multichotomous nodes.
+
+ o The new `method' as.matrix.DNAbin() may be used to convert
+ easily DNA sequences stored in a list into a matrix while
+ keeping the names and the class.
+
+
+BUG FIXES
+
+ o chronopl() failed when some branch lengths were equal to zero:
+ an error message is now returned.
+
+ o di2multi() failed when there was a series of consecutive edges
+ to remove.
+
+
+
+ CHANGES IN APE VERSION 1.10-2
+
+
+NEW FEATURES
+
+ o plot.phylo() can now plot circular trees: the option is type =
+ "fan" or type = "f" (to avoid the ambiguity with type = "c").
+
+ o prop.part() has a new option `check.labels = FALSE' which allows
+ to considerably speed-up the calculations of bipartitions. As a
+ consequence, calculations of bootstrap values with boot.phylo()
+ should be much faster.
+
+
+BUG FIXES
+
+ o read.GenBank() did not return correctly the list of species as
+ from ape 1.10: this is fixed in this version
+
+ o Applying as.phylo() on a tree of class "phylo" failed: the
+ object is now returned unchanged.
+
+
+
+ CHANGES IN APE VERSION 1.10-1
+
+
+NEW FEATURES
+
+ o The three new functions Ntip, Nnode, and Nedge return, for a
+ given tree, the number of tips, nodes, or edges, respectively.
+
+
+BUG FIXES
+
+ o read.nexus() did not set correctly the class of the returned
+ object when reading multiple trees.
+
+ o mllt.plot() failed with objects of class c("multi.tree",
+ "phylo").
+
+ o unroot() did not work correctly in most cases.
+
+ o reorder.phylo() made R freeze in some occasions.
+
+ o Plotting a tree in pruningwise order failed.
+
+ o When plotting an unrooted tree, the tip labels where not all
+ correctly positioned if the option `cex' was used.
+
+
+
+ CHANGES IN APE VERSION 1.10
+
+
+NEW FEATURES
+
+ o Five new `method' functions have been introduced to manipulate
+ DNA sequences in binary format (see below).
+
+ o Three new functions have been introduced to convert between the
+ new binary and the character formats.
+
+ o The new function as.alignment converts DNA sequences stored as
+ single characters into the class "alignment" used by the package
+ seqinr.
+
+ o read.dna() and read.GenBank() have a new argument `as.character'
+ controlling whether the sequences are returned in binary format
+ or as character.
+
+
+BUG FIXES
+
+ o root() failed when the tree had node labels: this is fixed.
+
+ o plot.phylo() did not correctly set the limits on the y-axis with
+ the default setting: this is fixed.
+
+ o dist.dna() returned a wrong result for the LogDet, paralinear,
+ and BH87 models with `pairwise.deletion = TRUE'.
+
+
+OTHER CHANGES
+
+ o DNA sequences are now internally stored in a binary format. See
+ the document "A Bit-Level Coding Scheme for Nucleotides" for the
+ details. Most functions analyzing DNA functions have been
+ modified accordingly and are now much faster (dist.dna is now
+ ca. 60 times faster).
+
+
+
+ CHANGES IN APE VERSION 1.9-4
+
+
+BUG FIXES
+
+ o A bug was fixed in edgelabels().
+
+ o as.phylo.hclust() did not work correctly when the object of
+ class "hclust" has its labels set to NULL: the returned tree has
+ now its tip labels set to "1", "2", ...
+
+ o consensus could fail if some tip labels are a subset of others
+ (e.g., "a" and "a_1"): this is now fixed.
+
+ o mlphylo() failed in most cases if some branch lengths of the
+ initial tree were greater than one: an error message is now
+ issued.
+
+ o mlphylo() failed in most cases when estimating the proportion of
+ invariants: this is fixed.
+
+
+
+ CHANGES IN APE VERSION 1.9-3
+
+
+NEW FEATURES
+
+ o The new function edgelabels adds labels on the edge of the tree
+ in the same way than nodelabels or tiplabels.
+
+
+BUG FIXES
+
+ o multi2di() did not handle correctly branch lengths with the
+ default option `random = TRUE': this is now fixed.
+
+ o A bug was fixed in nuc.div() when using pairwise deletions.
+
+ o A bug occurred in the analysis of bipartitions with large
+ numbers of large trees, with consequences on prop.part,
+ prop.clades, and boot.phylo.
+
+ o The calculation of the Billera-Holmes-Vogtmann distance in
+ dist.topo was wrong: this has been fixed.
+
+
+
+ CHANGES IN APE VERSION 1.9-2
+
+
+NEW FEATURES
+
+ o The new function ladderize reorganizes the internal structure of
+ a tree to plot them left- or right-ladderized.
+
+ o The new function dist.nodes computes the patristic distances
+ between all nodes, internal and terminal, of a tree. It replaces
+ the option `full = TRUE' of cophenetic.phylo (see below).
+
+
+BUG FIXES
+
+ o A bug was fixed in old2new.phylo().
+
+ o Some bugs were fixed in chronopl().
+
+ o The edge colours were not correctly displayed by plot.phylo
+ (thank you to Li-San Wang for the fix).
+
+ o cophenetic.phylo() failed with multichotomous trees: this is
+ fixed.
+
+
+OTHER CHANGES
+
+ o read.dna() now returns the sequences in a matrix if they are
+ aligned (interleaved or sequential format). Sequences in FASTA
+ format are still returned in a list.
+
+ o The option `full' of cophenetic.phylo() has been removed because
+ it could not be used from the generic.
+
+
+DEPRECATED & DEFUNCT
+
+ o rotate() has been removed; this function did not work correctly
+ since ape 1.9.
+
+
+
+ CHANGES IN APE VERSION 1.9-1
+
+
+BUG FIXES
+
+ o Trees with a single tip were not read correctly in R as the
+ element `Nnode' was not set: this is fixed.
+
+ o unroot() did not set correctly the number of nodes of the
+ unrooted tree in most cases.
+
+ o read.GenBank() failed when fetching very long sequences,
+ particularly of the BX-series.
+
+ o A bug was introduced in read.tree() with ape 1.9: it has been
+ fixed
+
+
+
+ CHANGES IN APE VERSION 1.9
+
+
+NEW FEATURES
+
+ o There are two new print `methods' for trees of class "phylo" and
+ lists of trees of class "multi.tree", so that they are now
+ displayed in a compact and informative way.
+
+ o There are two new functions, old2new.phylo and new2old.phylo,
+ for converting between the old and new coding of the class
+ "phylo".
+
+ o dist.dna() has three new models: Barry and Hartigan ("BH87"),
+ LogDet ("logdet"), and paralinear ("paralin").
+
+ o compute.brlen() has been extended: several methods are now
+ available to compute branch lengths.
+
+ o write.dna() can now handle matrices as well as lists.
+
+
+BUG FIXES
+
+ o cophenetic.phylo() sometimes returned a wrong result with
+ multichotomous trees: this is fixed.
+
+ o rotate() failed when a single tip was specified: the tree is now
+ returned unchanged.
+
+ o ace() did not return the correct index matrix with custom
+ models: this is fixed.
+
+ o multi2di() did not work correctly when resolving multichotomies
+ randomly: the topology was always the same, only the arrangement
+ of clades was randomized: this is fixed. This function now
+ accepts trees with no branch lengths.
+
+ o The output of diversi.gof() was blurred by useless prints when a
+ user distribution was specified. This has been corrected, and
+ the help page of this function has been expanded.
+
+
+OTHER CHANGES
+
+ o The internal structure of the class "phylo" has been changed:
+ see the document "Definition of Formats for Coding Phylogenetic
+ Trees in R" for the details. In addition, the code of most
+ functions has been improved.
+
+ o Several functions have been improved by replacing some R codes
+ by C codes: pic, plot.phylo, and reorder.phylo.
+
+ o There is now a citation information: see citation("ape") in R.
+
+ o write.tree() now does not add extra 0's to branch lengths so
+ that 1.23 is printed "1.23" by default, not "1.2300000000".
+
+ o The syntax of bind.tree() has been simplified. This function now
+ accepts trees with no branch lengths, and handles correctly node
+ labels.
+
+ o The option `as.numeric' of mrca() has been removed.
+
+ o The unused options `format' and `rooted' of read.tree() have
+ been removed.
+
+ o The unused option `format' of write.tree() has been removed.
+
+ o The use of node.depth() has been simplified.
+
+
+
+ CHANGES IN APE VERSION 1.8-5
+
+
+NEW FEATURES
+
+ o Two new functions read.nexus.data() and write.nexus.data(),
+ contributed by Johan Nylander, allow to read and write molecular
+ sequences in NEXUS files.
+
+ o The new function reorder.phylo() reorders the internal structure
+ of a tree of class "phylo". It is used as the generic, e.g.,
+ reorder(tr).
+
+ o read.tree() and read.nexus() can now read trees with a single
+ edge.
+
+ o The new data set `cynipids' supplies a set of protein sequences
+ in NEXUS format.
+
+
+BUG FIXES
+
+ o The code of all.equal.phylo() has been completely rewritten
+ (thanks to Beno�t Durand) which fixes several bugs.
+
+ o read.tree() and read.nexus() now checks the labels of the tree
+ to remove or substitute any characters that are illegal in the
+ Newick format (parentheses, etc.)
+
+ o A negative P-value could be returned by mantel.test(): this is
+ now fixed.
+
+
+
+ CHANGES IN APE VERSION 1.8-4
+
+
+NEW FEATURES
+
+ o The new function sh.test() computes the Shimodaira-
+ Hasegawa test.
+
+ o The new function collapse.singles() removes the nodes with a
+ single descendant from a tree.
+
+ o plot.phylo() has a new argument `tip.color' to specify the
+ colours of the tips.
+
+ o mlphylo() has now an option `quiet' to control the display of
+ the progress of the analysis (the default is FALSE).
+
+
+BUG FIXES
+
+ o read.dna() did not read correctly sequences in sequential format
+ with leading alignment gaps "-": this is fixed.
+
+ o ace() returned a list with no class so that the generic
+ functions (anova, logLik, ...) could not be used directly. This
+ is fixed as ace() now returns an object of class "ace".
+
+ o anova.ace() had a small bug when computing the number of degrees
+ of freedom: this is fixed.
+
+ o mlphylo() did not work when the sequences were in a matrix or
+ a data frame: this is fixed.
+
+ o rtree() did not work correctly when trying to simulate an
+ unrooted tree with two tips: an error message is now issued.
+
+
+OTHER CHANGES
+
+ o The algorithm of rtree() has been changed: it is now about 40,
+ 100, and 130 times faster for 10, 100, and 1000 tips,
+ respectively.
+
+
+
+ CHANGES IN APE VERSION 1.8-3
+
+
+NEW FEATURES
+
+ o There are four new `method' functions to be used with the
+ results of ace(): logLik(), deviance(), AIC(), and anova().
+
+ o The plot method of phymltest has two new arguments: `main' to
+ change the title, and `col' to control the colour of the
+ segments showing the AIC values.
+
+ o ace() has a new argument `ip' that gives the initial values used
+ in the ML estimation with discrete characters (see the examples
+ in ?ace). This function now returns a matrix giving the indices
+ of the estimated rates when analysing discrete characters.
+
+ o nodelabels() and tiplabels() have a new argument `pie' to
+ represent proportions, with any number of categories, as
+ piecharts. The use of the option `thermo' has been improved:
+ there is now no limitation on the number of categories.
+
+
+BUG FIXES
+
+ o mlphylo() did not work with more than two partitions: this is
+ fixed.
+
+ o root() failed if the proposed outgroup was already an outgroup
+ in the tree: this is fixed.
+
+ o The `col' argument in nodelabels() and tiplabels() was not
+ correctly passed when `text' was used: this is fixed.
+
+ o Two bugs were fixed in mlphylo(): parameters were not always
+ correctly output, and the estimation failed in some cases.
+
+ o plot.phylo() was stuck when given a tree with a single tip: this
+ is fixed and a message error is now returned.
+
+ o An error was corrected in the help page of gammaStat regarding
+ the calculation of P-values.
+
+ o Using gls() could crash R when the number of species in the tree
+ and in the variables were different: this is fixed.
+
+
+
+ CHANGES IN APE VERSION 1.8-2
+
+
+NEW FEATURES
+
+ o The new function mlphylo() fits a phylogenetic tree by maximum
+ likelihood from DNA sequences. Its companion function DNAmodel()
+ is used to define the substitution model which may include
+ partitioning. There are methods for logLik(), deviance(), and
+ AIC(), and the summary() method has been extended to display in
+ a friendly way the results of this model fitting. Currently, the
+ functionality is limited to estimating the substitution and
+ associated parameters and computing the likelihood.
+
+ o The new function drop1.compar.gee (used as, e.g., drop1(m))
+ tests for single effects in GEE-based comparative method. A
+ warning message is printed if there is not enough degrees of
+ freedom.
+
+
+BUG FIXES
+
+ o An error message was sometimes issued by plot.multi.tree(),
+ though with no consequence.
+
+
+
+ CHANGES IN APE VERSION 1.8-1
+
+
+NEW FEATURES
+
+ o There is a new plot method for lists of trees (objects of class
+ "multi.tree"): it calls plot.phylo() internally and is
+ documented on the same help page.
+
+
+BUG FIXES
+
+ o A bug was fixed in the C code that analyzes bipartitions: this
+ has impact on several functions like prop.part, prop.clades,
+ boot.phylo, or consensus.
+
+ o root() did not work correctly when the specified outgroup had
+ more than one element: this is fixed.
+
+ o dist.dna() sometimes returned a warning inappropriately: this
+ has been corrected.
+
+ o If the distance object given to nj() had no rownames, nj()
+ returned a tree with no tip labels: it now returns tips labelled
+ "1", "2", ..., corresponding to the row numbers.
+
+
+OTHER CHANGES
+
+ o nj() has been slightly changed so that tips with a zero distance
+ are first aggregated with zero-lengthed branches; the usual NJ
+ procedure is then performed on a distance matrix without 0's.
+
+
+
+ CHANGES IN APE VERSION 1.8
+
+
+NEW FEATURES
+
+ o The new function chronopl() estimates dates using the penalized
+ likelihood method by Sanderson (2002; Mol. Biol. Evol., 19:101).
+
+ o The new function consensus() calculates the consensus tree of a
+ list of trees.
+
+ o The new function evolve.phylo() simulates the evolution of
+ continuous characters along a phylogeny under a Brownian model.
+
+ o The new plot method for objects of class "ancestral" displays a
+ tree together with ancestral values, as returned by the above
+ function.
+
+ o The new function as.phylo.formula() returns a phylogeny from a
+ set of nested taxonomic variables given as a formula.
+
+ o The new function read.caic() reads trees in CAIC format.
+
+ o The new function tiplabels() allows to add labels to the tips
+ of a tree using text or plotting symbols in a flexible way.
+
+ o The new function unroot() unroots a phylogeny.
+
+ o multi2di() has a new option, `random', which specifies whether
+ to resolve the multichotomies randomly (the default) or not.
+
+ o prop.part() now returns an object of class "prop.part" for which
+ there are print (to display a partition in a more friendly way)
+ and summary (to extract the numbers) methods.
+
+ o plot.phylo() has a new option, `show.tip.label', specifying
+ whether to print the labels of the tips. The default is TRUE.
+
+ o The code of nj() has been replaced by a faster C code: it is now
+ about 10, 25, and 40 times faster for 50, 100, and 200 taxa,
+ respectively.
+
+ o write.nexus() now writes whether a tree is rooted or not.
+
+
+BUG FIXES
+
+ o Two bugs have been fixed in root(): unrooted trees are now
+ handled corretly, and node labels are now output normally.
+
+ o A bug was fixed in phymltest(): the executable couldn't be found
+ in some cases.
+
+ o Three bugs have been fixed in ace(): computing the likelihood of
+ ancestral states of discrete characters failed, custom models
+ did not work, and the function failed with a null gradient (a
+ warning message is now returned; this latter bug was also
+ present in yule.cov() as well and is now fixed).
+
+ o pic() hanged out when missing data were present: an error is now
+ returned.
+
+ o A small bug was fixed in dist.dna() where the gamma correction
+ was not always correctly dispatched.
+
+ o plot.phylo() plotted correctly the root edge only when the tree
+ was plotted rightwards: this works now for all directions.
+
+
+OTHER CHANGES
+
+ o dist.taxo() has been renamed as weight.taxo().
+
+ o dist.phylo() has been replaced by the method cophenetic.phylo().
+
+ o Various error and warning messages have been improved.
+
+
+
+ CHANGES IN APE VERSION 1.7
+NEW FEATURES
+
+ o The new function ace() estimates ancestral character states for
+ continuous characters (with ML, GLS, and contrasts methods), and
+ discrete characters (with ML only) for any number of states.
+
+ o The new function compar.ou() fits the Ornstein-Uhlenbeck model
+ of directional evolution for continuous characters. The user
+ specifies the node(s) of the tree where the character optimum
+ changes.
+
+ o The new function is.rooted() tests whether a tree (of class
+ "phylo") is rooted.
+
+ o The new function rcoal() generates random ultrametric trees with
+ the possibility to specify the function that generates the
+ inter-nodes distances.
+
+ o The new function mrca() gives for all pairs of tips in a tree
+ (and optionally nodes too) the most recent common ancestor.
+
+ o nodelabels() has a new option `thermo' to plot proportions (up
+ to three classes) on the nodes of a tree.
+
+ o rtree() has been improved: it can now generate rooted or
+ unrooted trees, and the mathematical function that generates the
+ branch lengths may be specified by the user. The tip labels may
+ be given directly in the call to rtree. The limit cases (n = 2,
+ 3) are now handled correctly.
+
+ o dist.topo() has a new argument `method' with two choices: "PH85"
+ for Penny and Henny's method (already available before and now
+ the default), and "BHV01" for the geometric distance by Billera
+ et al. (2001, Adv. Appl. Math. 27:733).
+
+ o write.tree() has a new option, `digits', which specifies the
+ number of digits to be printed in the Newick tree. By default
+ digits = 10. The numbers are now always printed in decimal form
+ (i.e., 1.0e-1 is now avoided).
+
+ o dist.dna() can now compute the raw distances between pairs of
+ DNA sequences by specifying model = "raw".
+
+ o dist.phylo() has a new option `full' to possibly compute the
+ distances among all tips and nodes of the tree. The default is
+ `full = FALSE'.
+
+
+BUG FIXES
+
+ o Several bugs were fixed in all.equal.phylo().
+
+ o dist.dna() did not handle correctly gaps ("-") in alignments:
+ they are now considered as missing data.
+
+ o rotate() did not work if the tips were not ordered: this is
+ fixed.
+
+ o mantel.test() returned NA in some special cases: this is fixed
+ and the function has been improved and is now faster.
+
+ o A bug was fixed in diversi.gof() where the calculation of A� was
+ incorrect.
+
+ o cherry() did not work correctly under some OSs (mainly Linux):
+ this is fixed.
+
+ o is.binary.tree() has been modified so that it works with both
+ rooted and unrooted trees.
+
+ o The documentation of theta.s() was not correct: this has been
+ fixed.
+
+ o plot.mst() did not work correctly: this is fixed.
+
+
+
+ CHANGES IN APE VERSION 1.6
+
+
+NEW FEATURES
+
+ o The new function dist.topo() computes the topological distances
+ between two trees.
+
+ o The new function boot.phylo() performs a bootstrap analysis on
+ phylogeny estimation.
+
+ o The new functions prop.part() and prop.clades() analyse
+ bipartitions from a series of trees.
+
+
+OTHER CHANGES
+
+ o read.GenBank() now uses the EFetch utility of NCBI instead of
+ the usual Web interface: it is now much faster (e.g., 12 times
+ faster to retrieve 8 sequences, 37 times for 60 sequences).
+
+
+BUG FIXES
+
+ o Several bugs were fixed in read.dna().
+
+ o Several bugs were fixed in diversi.time().
+
+ o is.binary.tree() did not work correctly if the tree has no edge
+ lengths: this is fixed.
+
+ o drop.tip() did not correctly propagated the `node.label' of a
+ tree: this is fixed.
+
+
+
+ CHANGES IN APE VERSION 1.5
+
+
+NEW FEATURES
+
+ o Two new functions, as.matching.phylo() and as.phylo.matching(),
+ convert objects between the classes "phylo" and "matching". The
+ latter implements the representation of binary trees introduced by
+ Diaconis and Holmes (1998; PNAS 95:14600). The generic function
+ as.matching() has been introduced as well.
+
+ o Two new functions, multi2di() and di2multi(), allow to resolve
+ and collapse multichotomies with branches of length zero.
+
+ o The new function nuc.div() computes the nucleotide diversity
+ from a sample a DNA sequences.
+
+ o dist.dna() has been completely rewritten with a much faster
+ (particularly for large data sets) C code. Eight models are
+ available: JC69, K80, F81, K81, F84, T92, TN93, and GG95 (the
+ option `method' has been renamed `model'). Computation of variance
+ is available for all models. A gamma-correction is possible for
+ JC69, K80, F81, and TN93. There is a new option, pairwise.deletion,
+ to remove sites with missing data on a pairwise basis. The option
+ `GCcontent' has been removed.
+
+ o read.GenBank() has a new option (species.names) which specifies
+ whether to return the species names of the organisms in addition
+ to the accession numbers of the sequences (this is the default
+ behaviour).
+
+ o write.nexus() can now write several trees in the same NEXUS file.
+
+ o drop.tip() has a new option `root.edge' that allows to specify the
+ new root edge if internal branches are trimmed.
+
+
+BUG FIXES
+
+ o as.phylo.hclust() failed if some labels had parentheses: this
+ is fixed.
+
+ o Several bugs were fixed in all.equal.phylo(). This function now
+ returns the logical TRUE if the trees are identical but with
+ different representations (a report was printed previously).
+
+ o read.GenBank() did not correctly handle ambiguous base codes:
+ this is fixed.
+
+
+OTHER CHANGES
+
+ o birthdeath() now returns an object of class "birthdeath" for
+ which there is a print method.
+
+
+
+ CHANGES IN APE VERSION 1.4
+
+
+NEW FEATURES
+
+ o The new function nj() performs phylogeny estimation with the
+ neighbor-joining method of Saitou and Nei (1987; Mol. Biol.
+ Evol., 4:406).
+
+ o The new function which.edge() identifies the edges of a tree
+ that belong to a group specified as a set of tips.
+
+ o The new function as.phylo.phylog() converts an object of class
+ "phylog" (from the package ade4) into an object of class
+ "phylo".
+
+ o The new function axisPhylo() draws axes on the side of a
+ phylogeny plot.
+
+ o The new function howmanytrees() calculates the number of trees
+ in different cases and giving a number of tips.
+
+ o write.tree() has a new option `multi.line' (TRUE by default) to
+ write a Newick tree on several lines rather than on a single
+ line.
+
+ o The functionalities of zoom() have been extended. Several
+ subtrees can be visualized at the same time, and they are marked
+ on the main tree with colors. The context of the subtrees can be
+ marked with the option `subtree' (see below).
+
+ o drop.tip() has a new option `subtree' (FALSE by default) which
+ specifies whether to output in the tree how many tips have been
+ deleted and where.
+
+ o The arguments of add.scale.bar() have been redefined and have
+ now default values (see ?add.scale.bar for details). This
+ function now works even if the plotted tree has no edge length.
+
+ o plot.phylo() can now plot radial trees, but this does not take
+ edge lengths into account.
+
+ o In plot.phylo() with `type = "phylogram"', if the values of
+ `edge.color' and `edge.width' are identical for sister-branches,
+ they are propagated to the vertical line that link them.
+
+
+BUG FIXES
+
+ o Repeated calls to as.phylo.hclust() or as.hclust.phylo() made R
+ crashing. This is fixed.
+
+ o In plot.phylo(), the options `edge.color' and `edge.width' are
+ now properly recycled; their default values are now "black" and
+ 1, respectively.
+
+ o A bug has been fixed in write.nexus().
+
+
+OTHER CHANGES
+
+ o The function node.depth.edgelength() has been removed and
+ replaced by a C code.
+
+
+
+ CHANGES IN APE VERSION 1.3-1
+
+
+NEW FEATURES
+
+ o The new function nodelabels() allows to add labels to the nodes
+ of a tree using text or plotting symbols in a flexible way.
+
+ o In plot.phylo() the arguments `x.lim' and `y.lim' can now be two
+ numeric values specifying the lower and upper limits on the x-
+ and y-axes. This allows to leave some space on any side of the
+ tree. If a single value is given, this is taken as the upper
+ limit (as before).
+
+
+
+ CHANGES IN APE VERSION 1.3
+
+
+NEW FEATURES
+
+ o The new function phymltest() calls the software PHYML and fits
+ 28 models of DNA sequence evolution. There are a print method to
+ display likelihood and AIC values, a summary method to compute
+ the hierarchical likelihood ratio tests, and a plot method to
+ display graphically the AIC values of each model.
+
+ o The new function yule.cov() fits the Yule model with covariates,
+ a model where the speciation rate is affected by several species
+ traits through a generalized linear model. The parameters are
+ estimated by maximum likelihood.
+
+ o Three new functions, corBrownian(), corGrafen(), and
+ corMartins(), compute the expected correlation structures among
+ species given a phylogeny under different models of evolution.
+ These can be used for GLS comparative phylogenetic methods (see
+ the examples). There are coef() and corMatrix() methods and an
+ Initialize.corPhyl() function associated.
+
+ o The new function compar.cheverud() implements Cheverud et al.'s
+ (1985; Evolution 39:1335) phylogenetic comparative method.
+
+ o The new function varcomp() estimates variance components; it has
+ a plot method.
+
+ o Two new functions, panel.superpose.correlogram() and
+ plot.correlogramList(), allow to plot several phylogenetic
+ correlograms.
+
+ o The new function node.leafnumber() computes the number of leaves
+ of a subtree defined by a particular node.
+
+ o The new function node.sons() gets all tags of son nodes from a
+ given parent node.
+
+ o The new function compute.brlen() computes the branch lengths of
+ a tree according to a specified method.
+
+ o plot.phylo() has three new options: "cex" controls the size of
+ the (tip and node) labels (thus it is no more needed to change
+ the global graphical parameter), "direction" which allows to
+ plot the tree rightwards, leftwards, upwards, or downwards, and
+ "y.lim" which sets the upper limit on the y-axis.
+
+
+BUG FIXES
+
+ o Some functions which try to match tip labels and names of
+ additional data (e.g. vector) are likely to fail if there are
+ typing or syntax errors. If both series of names do not perfectly
+ match, they are ignored and a warning message is now issued.
+ These functions are bd.ext, compar.gee, pic. Their help pages
+ have been clarified on this point.
+
+
+
+ CHANGES IN APE VERSION 1.2-7
+
+
+NEW FEATURES
+
+ o The new function root() reroots a phylogenetic tree with respect
+ to a specified outgroup.
+
+ o The new function rotate() rotates an internal branch of a tree.
+
+ o In plot.phylo(), the new argument "lab4ut" (labels for unrooted
+ trees) controls the display of the tip labels in unrooted trees.
+ This display has been greatly improved: the tip labels are now not
+ expected to overlap with the tree (particularly if lab4ut =
+ "axial"). In all cases, combining appropriate values of "lab4ut"
+ and the font size (via "par(cex = )") should result in readable
+ unrooted trees. See ?plot.phylo for some examples.
+
+ o In drop.tip(), the argument `tip' can now be numeric or character.
+
+
+BUG FIXES
+
+ o drop.tip() did not work correctly with trees with no branch
+ lengths: this is fixed.
+
+ o A bug in plot.phylo(..., type = "unrooted") made some trees being
+ plotted with some line crossings: this is now fixed.
+
+
+
+ CHANGES IN APE VERSION 1.2-6
+
+
+NEW FEATURES
+
+ o Six new functions (Moran.I, correlogram.formula, discrete.dist,
+ correlogram.phylo, dist.taxo, plot.correlogram) have been added
+ to implement comparative methods with an autocorrelation approach.
+
+ o A new data set describing some life history traits of Carnivores
+ has been included.
+
+
+BUG FIXES
+
+ o A fix was made on mcmc.popsize() to conform to R 2.0.0.
+
+
+OTHER CHANGES
+
+ o When plotting a tree with plot.phylo(), the new default of the
+ option `label.offset' is now 0, so the labels are always visible.
+
+
+
+ CHANGES IN APE VERSION 1.2-5
+
+
+NEW FEATURES
+
+ o The new function bd.ext() fits a birth-death model with combined
+ phylogenetic and taxonomic data, and estimates the corresponding
+ speciation and extinction rates.
+
+
+OTHER CHANGES
+
+ o The package gee is no more required by ape but only suggested
+ since only the function compar.gee() calls gee.
+
+
+
+ CHANGES IN APE VERSION 1.2-4
+
+
+NEW FEATURES
+
+ o Four new functions (mcmc.popsize, extract.popsize, plot.popsize,
+ and lines.popsize) implementing a new approach for inferring the
+ demographic history from genealogies using a reversible jump
+ MCMC have been introduced.
+
+ o The unit of time in the skyline plot and in the new plots can
+ now be chosen to be actual years, rather than substitutions.
+
+
+
+ CHANGES IN APE VERSION 1.2-3
+
+
+NEW FEATURES
+
+ o The new function rtree() generates a random binary tree with or
+ without branch lengths.
+
+ o Two new functions for drawing lineages-through-time (LTT) plots
+ are provided: ltt.lines() adds a LTT curve to an existing plot,
+ and mltt.plot() does a multiple LTT plot giving several trees as
+ arguments (see `?ltt.plot' for details).
+
+
+BUG FIXES
+
+ o Some taxon names made R crashing when calling as.phylo.hclust():
+ this is fixed.
+
+ o dist.dna() returned an error with two identical DNA sequences
+ (only using the Jukes-Cantor method returned 0): this is fixed.
+
+
+OTHER CHANGES
+
+ o The function dist.phylo() has been re-written using a different
+ algorithm: it is now about four times faster.
+
+ o The code of branching.times() has been improved: it is now about
+ twice faster.
+
+
+
+ CHANGES IN APE VERSION 1.2-2
+
+
+NEW FEATURES
+
+ o The new function seg.sites() finds the segregating sites in a
+ sample of DNA sequences.
+
+
+BUG FIXES
+
+ o A bug introduced in read.tree() and in read.nexus() with version
+ 1.2-1 was fixed.
+
+ o A few errors were corrected and a few examples were added in the
+ help pages.
+
+
+
+ CHANGES IN APE VERSION 1.2-1
+
+
+NEW FEATURES
+
+ o plot.phylo() can now draw the edge of the root of a tree if it
+ has one (see the new option `root.edge', its default is FALSE).
+
+
+BUG FIXES
+
+ o A bug was fixed in read.nexus(): files with semicolons inside
+ comment blocks were not read correctly.
+
+ o The behaviour of read.tree() and read.nexus() was corrected so
+ that tree files with badly represented root edges (e.g., with
+ an extra pair of parentheses, see the help pages for details)
+ are now correctly represented in the object of class "phylo";
+ a warning message is now issued.
+
+
+
+ CHANGES IN APE VERSION 1.2
+
+
+NEW FEATURES
+
+ o plot.phylo() has been completely re-written and offers several
+ new functionalities. Three types of trees can now be drawn:
+ phylogram (as previously), cladogram, and unrooted tree; in
+ all three types the branch lengths can be drawn using the edge
+ lengths of the phylogeny or not (e.g., if the latter is absent).
+ The vertical position of the nodes can be adjusted with two
+ choices (see option `node.pos'). The code has been re-structured,
+ and two new functions (potentially useful for developpers) are
+ documented separately: node.depth.edgelength() and node.depth();
+ see the respective help pages for details.
+
+ o The new function zoom() allows to explore very large trees by
+ focusing on a small portion of it.
+
+ o The new function yule() fits by maximum likelihood the Yule model
+ (birth-only process) to a phylogenetic tree.
+
+ o Support for writing DNA sequences in FASTA format has been
+ introduced in write.dna() (support for reading sequences in
+ this format was introduced in read.dna() in version 1.1-2).
+ The function has been completely re-written, fixing some bugs
+ (see below); the default behaviour is no more to display the
+ sequences on the standard output. Several options have been
+ introduced to control the sequence printing in a flexible
+ way. The help page has been extended.
+
+ o A new data set is included: a supertree of bats in NEXUS format.
+
+
+BUG FIXES
+
+ o In theta.s(), the default of the option `variance' has
+ been changed to `FALSE' (as was indicated in the help page).
+
+ o Several bugs were fixed in the code of all.equal.phylo().
+
+ o Several bugs were fixed in write.dna(), particularly this
+ function did not work with `format = "interleaved"'.
+
+ o Various errors were corrected in the help pages.
+
+
+OTHER CHANGES
+
+ o The argument names of as.hclust.phylo() have been changed
+ from "(phy)" to "(x, ...)" to conform to the definition of
+ the corresponding generic function.
+
+ o gamma.stat() has been renamed gammaStat() to avoid confusion
+ since gamma() is a generic function.
+
+
+
+ CHANGES IN APE VERSION 1.1-3
+
+
+BUG FIXES
+
+ o base.freq() previously did not return a value of 0 for
+ bases absent in the data (e.g., a vector of length 3 was
+ returned if one base was absent). This is now fixed (a
+ vector of length 4 is always returned).
+
+ o Several bugs were fixed in read.nexus(), including that this
+ function did not work in this absence of a "TRANSLATE"
+ command in the NEXUS file, and that the commands were
+ case-sensitive.
+
+
+
+ CHANGES IN APE VERSION 1.1-2
+
+
+NEW FEATURES
+
+ o The Tamura and Nei (1993) model of DNA distance is now implemented
+ in dist.dna(): five models are now available in this function.
+
+ o A new data set is included: a set of 15 sequences of the
+ cytochrome b mitochondrial gene of the woodmouse (Apodemus
+ sylvaticus).
+
+
+BUG FIXES
+
+ o A bug in read.nexus() was fixed.
+
+ o read.dna() previously did not work correctly in most cases.
+ The function has been completely re-written and its help page
+ has been considerably extended (see ?read.dna for details).
+ Underscores (_) in taxon names are no more replaced with
+ spaces (this behaviour was undocumented).
+
+ o A bug was fixed in write.dna().
+
+
+
+ CHANGES IN APE VERSION 1.1-1
+
+
+BUG FIXES
+
+ o A bug in read.tree() introduced in APE 1.1 was fixed.
+
+ o A bug in compar.gee() resulted in an error when trying to fit
+ a model with `family = "binomial"'. This is now fixed.
+
+
+
+ CHANGES IN APE VERSION 1.1
+
+
+NEW FEATURES
+
+ o The Klastorin (1982) method as suggested by Misawa and Tajima
+ (2000, Mol. Biol. Evol. 17:1879-1884) for classifying genes
+ on the basis of phylogenetic trees has been implemented (see
+ the function klastorin()).
+
+ o Functions have been added to convert APE's "phylo" objects in
+ "hclust" cluster objects and vice versa (see the help page of
+ as.phylo for details).
+
+ o Three new functions, ratogram(), chronogram() and NPRS.criterion(),
+ are introduced for the estimation of absolute evolutionary rates
+ (ratogram) and dated clock-like trees (chronogram) from
+ phylogenetic trees using the non-parametric rate smoothing approach
+ by MJ Sanderson (1997, Mol. Biol. Evol. 14:1218-1231).
+
+ o A summary method is now provided printing a summary information on a
+ phylogenetic tree with, for instance, `summary(tree)'.
+
+ o The behaviour of read.tree() was changed so that all spaces and
+ tabulations in tree files are now ignored. Consequently, spaces in tip
+ labels are no more allowed. Another side effect is that read.nexus()
+ now does not replace the underscores (_) in tip labels with spaces
+ (this behaviour was undocumented).
+
+ o The function plot.phylo() has a new option (`underscore') which
+ specifies whether the underscores in tip labels should be written on
+ the plot as such or replaced with spaces (the default).
+
+ o The function birthdeath() now computes 95% confidence intervals of
+ the estimated parameters using profile likelihood.
+
+ o Three new data sets are included: a gene tree estimated from 36
+ landplant rbcL sequences, a gene tree estimated from 32 opsin
+ sequences, and a gene tree for 50 BRCA1 mammalian sequences.
+
+
+BUG FIXES
+
+ o A bug was fixed in dist.gene() where nothing was returned.
+
+ o A bug in plot.mst() was fixed.
+
+ o A bug in vcv.phylo() resulted in false correlations when the
+ option `cor = TRUE' was used (now fixed).
+
+
+
+ CHANGES IN APE VERSION 1.0
+
+
+NEW FEATURES
+
+ o Two new functions, read.dna() and write.dna(), read/write in a file
+ DNA sequences in interleaved or in sequential format.
+
+ o Two new functions, read.nexus() and write.nexus(), read/write trees
+ in a NEXUS file.
+
+ o The new function bind.tree() allows to bind two trees together,
+ possibly handling root edges to give internal branches.
+
+ o The new function drop.tip() removes the tips in a phylogenetic tree,
+ and trims (or not) the corresponding internal branches.
+
+ o The new function is.ultrametric() tests if a tree is ultrametric.
+
+ o The function plot.phylo() has more functionalities such as drawing the
+ branches with different colours and/or different widths, showing the
+ node labels, controling the position and font of the labels, rotating
+ the labels, and controling the space around the plot.
+
+ o The function read.tree() can now read trees with no branch length,
+ such as "(a,b),c);". Consequently, the element `edge.length' in
+ objects of class "phylo" is now optional.
+
+ o The function write.tree() has a new default behaviour: if the default
+ for the option `file' is used (i.e. file = ""), then a variable of
+ mode character containing the tree in Newick format is returned which
+ can thus be assigned (e.g., tree <- write.tree(phy)).
+
+ o The function read.tree() has a new argument `text' which allows
+ to read the tree in a variable of mode character.
+
+ o A new data set is included: the phylogenetic relationships among
+ the orders of birds from Sibley and Ahlquist (1990).
+
+
+
+ CHANGES IN APE VERSION 0.2-1
+
+
+BUG FIXES
+
+ o Several bugs were fixed in the help pages.
+
+
+
+ CHANGES IN APE VERSION 0.2
+
+
+NEW FEATURES
+
+ o The function write.tree() writes phylogenetic trees (objects of class
+ "phylo") in an ASCII file using the Newick parenthetic format.
+
+ o The function birthdeath() fits a birth-death model to branching times
+ by maximum likelihood, and estimates the corresponding speciation and
+ extinction rates.
+
+ o The function scale.bar() adds a scale bar to a plot of a phylogenetic
+ tree.
+
+ o The function is.binary.tree() tests whether a phylogeny is binary.
+
+ o Two generic functions, coalescent.intervals() and collapsed.intervals(),
+ as well as some methods are introduced.
+
+ o Several functions, including some generics and methods, for computing
+ skyline plot estimates (classic and generalized) of effective
+ population size through time are introduced and replace the function
+ skyline.plot() in version 0.1.
+
+ o Two data sets are now included: the phylogenetic relationships among
+ the families of birds from Sibley and Ahlquist (1990), and an
+ estimated clock-like phylogeny of HIV sequences sampled in the
+ Democratic Republic of Congo.
+
+
+DEPRECATED & DEFUNCT
+
+ o The function skyline.plot() in ape 0.1 has been deprecated and
+ replaced by more elaborate functions (see above).
+
+
+BUG FIXES
+
+ o Two important bugs were fixed in plot.phylo(): phylogenies with
+ multichotomies not at the root or not with only terminal branches,
+ and phylogenies with a single node (i.e. only terminal branches)
+ did not plot. These trees should be plotted correctly now.
+
+ o Several bugs were fixed in diversi.time() in the computation of
+ AICs and LRTs.
+
+ o Various errors were corrected in the help pages.
diff --git a/R/CADM.global.R b/R/CADM.global.R
new file mode 100644
index 0000000..5644ca5
--- /dev/null
+++ b/R/CADM.global.R
@@ -0,0 +1,216 @@
+`CADM.global` <-
+ function(Dmat, nmat, n, nperm=99, make.sym=TRUE, weights=NULL, silent=FALSE)
+{
+### Function to test the overall significance of the congruence among
+### a group of distance matrices using Kendall's coefficient of concordance W.
+###
+### copyleft - Pierre Legendre, December 2008
+###
+### Reference -
+### Legendre, P. and F.-J. Lapointe. 2004. Assessing congruence among distance
+### matrices: single malt Scotch whiskies revisited. Australian and New Zealand
+### Journal of Statistics 46: 615-629.
+###
+### Parameters of the function --
+###
+### Dmat = A text file listing the distance matrices one after the other, with
+### or without blank lines.
+### Each matrix is in the form of a square distance matrix with 0's
+### on the diagonal.
+###
+### nmat = number of distance matrices in file Dmat.
+###
+### n = number of objects in each distance matrix. All matrices have same n.
+###
+### nperm = number of permutations for the tests.
+###
+### make.sym = TRUE: turn asymmetric matrices into symmetric matrices by
+### averaging the two triangular portions.
+### = FALSE: analyse asymmetric matrices as they are.
+###
+### weights = a vector of positive weights for the distance matrices.
+### Example: weights = c(1,2,3)
+### = NULL (default): all matrices have same weight in calculation of W.
+###
+### silent = TRUE: informative messages will not be printed, except stopping
+### messages. Option useful for simulation work.
+### = FALSE: informative messages will be printed.
+###
+################################################################################
+
+ if(nmat < 2)
+ stop("Analysis requested for a single D matrix: CADM is useless")
+
+ a <- system.time({
+
+ ## Check the input file
+ if(ncol(Dmat) != n)
+ stop("Error in the value of 'n' or in the D matrices themselves")
+ nmat2 <- nrow(Dmat)/n
+ if(nmat2 < nmat) # OK if 'nmat' < number of matrices in the input file
+ stop("Number of input D matrices = ",nmat2,"; this value is < nmat")
+
+ nd <- n*(n-1)/2
+ if(is.null(weights)) {
+ w <- rep(1,nmat)
+ } else {
+ if(length(weights) != nmat)
+ stop("Incorrect number of values in vector 'weights'")
+ if(length(which(weights < 0)) > 0)
+ stop("Negative weights are not permitted")
+ w <- weights*nmat/sum(weights)
+ if(!silent) cat("Normalized weights =",w,'\n')
+ }
+
+ ## Are asymmetric D matrices present?
+ asy <- rep(FALSE, nmat)
+ asymm <- FALSE
+ end <- 0
+ for(k in 1:nmat) {
+ begin <- end+1
+ end <- end+n
+ D.temp <- Dmat[begin:end,]
+ if(sum(abs(diag(as.matrix(D.temp)))) > 0)
+ stop("Diagonal not 0: matrix #",k," is not a distance matrix")
+ vec1 <- as.vector(as.dist(D.temp))
+ vec2 <- as.vector(as.dist(t(D.temp)))
+ if(sum(abs((vec1-vec2))) > 0) {
+ if(!silent) cat("Matrix #",k," is asymmetric",'\n')
+ asy[k] <- TRUE
+ asymm <- TRUE
+ }
+ }
+ D1 <- as.list(1:nmat)
+ if(asymm) {
+ if(make.sym) {
+ if(!silent) cat("\nAsymmetric matrices were transformed to be symmetric",'\n')
+ } else {
+ nd <- nd*2
+ if(!silent) cat("\nAnalysis carried out on asymmetric matrices",'\n')
+ D2 <- as.list(1:nmat)
+ }
+ } else {
+ if(!silent) cat("Analysis of symmetric matrices",'\n')
+ }
+ Y <- rep(NA,nd)
+
+ ## String out the distance matrices (vec) and assemble them as columns into matrix 'Y'
+ ## Construct also matrices of ranked distances D1[[k]] and D2[[k]] for permutation test
+ end <- 0
+ for(k in 1:nmat) {
+ begin <- end+1
+ end <- end+n
+ D.temp <- as.matrix(Dmat[begin:end,])
+ vec <- as.vector(as.dist(D.temp))
+ if(asymm) {
+ if(!make.sym) {
+ ## Analysis carried out on asymmetric matrices:
+ ## The ranks are computed on the whole matrix except the diagonal values.
+ ## The two halves are stored as symmetric matrices in D1[[k]] and D2[[k]]
+ vec <- c(vec, as.vector(as.dist(t(D.temp))))
+ diag(D.temp) <- NA
+ D.temp2 <- rank(D.temp)
+ diag(D.temp2) <- 0
+ # cat("nrow =",nrow(D.temp2)," ncol =",ncol(D.temp2),'\n')
+ # cat("Matrix ",k," min =",min(D.temp2)," max =",max(D.temp2),'\n')
+ # cat("Matrix ",k," max values #",which(D.temp2 == max(D.temp2)),'\n')
+ D1[[k]] <- as.matrix(as.dist(D.temp2))
+ D2[[k]] <- as.matrix(as.dist(t(D.temp2)))
+ } else {
+ ## Asymmetric matrices transformed to be symmetric, stored in D1[[k]]
+ vec <- (vec + as.vector(as.dist(t(D.temp)))) / 2
+ D.temp2 <- (D.temp + t(D.temp)) / 2
+ D.temp2 <- as.dist(D.temp2)
+ D.temp2[] <- rank(D.temp2)
+ D.temp2 <- as.matrix(D.temp2)
+ D1[[k]] <- D.temp2
+ }
+ } else {
+ ## Symmetric matrices are stored in D1[[k]]
+ D.temp2 <- as.dist(D.temp)
+ D.temp2[] <- rank(D.temp2)
+ D1[[k]] <- as.matrix(D.temp2)
+ }
+ Y <- cbind(Y, vec)
+ }
+ Y <- as.matrix(Y[,-1])
+ colnames(Y) <- colnames(Y,do.NULL = FALSE, prefix = "Dmat.")
+
+ ## Begin calculations for global test
+
+ ## Compute the reference values of the statistics: W and Chi2
+ ## Transform the distances to ranks, by column
+ Rmat <- apply(Y,2,rank)
+
+ ## Correction factors for tied ranks (eq. 3.3)
+ t.ranks <- apply(Rmat, 2, function(x) summary(as.factor(x), maxsum=nd))
+ TT <- sum(unlist(lapply(t.ranks, function(x) sum((x^3)-x))))
+ # if(!silent) cat("TT = ",TT,'\n')
+
+ ## Compute the S = Sum-of-Squares of the row-marginal sums of ranks (eq. 1a)
+ ## The ranks are weighted during the sum by the vector of matrix weights 'w'
+ ## Eq. 1b cannot be used with weights; see formula for W below
+ sumRanks <- as.vector(Rmat%*%w)
+ S <- (nd-1)*var(sumRanks)
+
+ ## Compute Kendall's W (eq. 2a)
+ ## Eq. 2b cannot be used with weights
+ ## because the sum of all ranks is not equal to m*n*(n+1)/2 in that case
+ W <- (12*S)/(((nmat^2)*((nd^3)-nd))-(nmat*TT))
+
+ ## Calculate Friedman's Chi-square (Kendall W paper, 2005, eq. 3.4)
+ Chi2 <- nmat*(nd-1)*W
+
+ ## Test the Chi2 statistic by permutation
+ counter <- 1
+ for(j in 1:nperm) { # Each matrix is permuted independently
+ # There is no need to permute the last matrix
+ Rmat.perm <- rep(NA,nd)
+ ##
+ if(asymm & !make.sym) {
+ ## For asymmetric matrices: permute the values within each triangular
+ ## portion, stored as square matrices in D1[[]] and D2[[]]
+ for(k in 1:(nmat-1)) {
+ order <- sample(n)
+ vec <- as.vector(as.dist(D1[[k]][order,order]))
+ vec <- c(vec, as.vector(as.dist(D2[[k]][order,order])))
+ Rmat.perm <- cbind(Rmat.perm, vec)
+ }
+ vec <- as.vector(as.dist(D1[[nmat]]))
+ vec <- c(vec, as.vector(as.dist(D2[[nmat]])))
+ Rmat.perm <- cbind(Rmat.perm, vec)
+ } else {
+ for(k in 1:(nmat-1)) {
+ order <- sample(n)
+ vec <- as.vector(as.dist(D1[[k]][order,order]))
+ Rmat.perm <- cbind(Rmat.perm, vec)
+ }
+ vec <- as.vector(as.dist(D1[[nmat]]))
+ Rmat.perm <- cbind(Rmat.perm, vec)
+ }
+ # Remove the first column of Rmat.perm containing NA
+ # The test is based on the comparison of S and S.perm instead of the comparison of
+ # Chi2 and Chi2.perm: it is faster that way.
+ # S, W, and Chi2 are equivalent statistics for permutation tests.
+ Rmat.perm <- as.matrix(Rmat.perm[,-1])
+ S.perm <- (nd-1)*var(as.vector(Rmat.perm%*%w))
+ if(S.perm >= S) counter <- counter+1
+ }
+ prob.perm.gr <- counter/(nperm+1)
+
+ table <- rbind(W, Chi2, prob.perm.gr)
+ colnames(table) <- "Statistics"
+ rownames(table) <- c("W", "Chi2", "Prob.perm")
+ })
+ a[3] <- sprintf("%2f",a[3])
+ if(!silent) cat("\nTime to compute global test =",a[3]," sec",'\n')
+#
+ # if(asymm & !make.sym) { out <- list(congruence_analysis=table, D1=D1, D2=D2)
+ # } else {
+ out <- list(congruence_analysis=table)
+ # }
+#
+ out$nperm <- nperm
+ class(out) <- "CADM.global"
+ out
+}
diff --git a/R/CADM.post.R b/R/CADM.post.R
new file mode 100644
index 0000000..d159c4b
--- /dev/null
+++ b/R/CADM.post.R
@@ -0,0 +1,276 @@
+`CADM.post` <-
+ function(Dmat, nmat, n, nperm=99, make.sym=TRUE, weights=NULL, mult="holm", mantel=FALSE, silent=FALSE)
+{
+### Function to carry out a posteriori tests of the contribution of individual
+### matrices to the congruence of a group of distance matrices.
+###
+### copyleft - Pierre Legendre, December 2008
+###
+### Reference -
+### Legendre, P. and F.-J. Lapointe. 2004. Assessing congruence among distance
+### matrices: single malt Scotch whiskies revisited. Australian and New Zealand
+### Journal of Statistics 46: 615-629.
+###
+### Parameters of the function --
+###
+### Dmat = A text file listing the distance matrices one after the other, with
+### or without blank lines.
+### Each matrix is in the form of a square distance matrix with 0's
+### on the diagonal.
+###
+### nmat = number of distance matrices in file Dmat.
+###
+### n = number of objects in each distance matrix. All matrices have same n.
+###
+### nperm = number of permutations for the tests.
+###
+### make.sym = TRUE: turn asymmetric matrices into symmetric matrices by
+### averaging the two triangular portions.
+### = FALSE: analyse asymmetric matrices as they are.
+###
+### weights = a vector of positive weights for the distance matrices.
+### Example: weights = c(1,2,3)
+### = NULL (default): all matrices have same weight in calculation of W.
+###
+### mult = method for correcting P-values due to multiple testing. The methods
+### are "holm" (default), "sidak", and "bonferroni". The Bonferroni
+### correction is overly conservative; it is not recommended. It is
+### included to allow comparisons with the other methods.
+###
+### mantel = TRUE: Mantel statistics are computed from ranked distances,
+### as well as permutational P-values.
+### = FALSE (default): Mantel statistics and tests are not computed.
+###
+### silent = TRUE: informative messages will not be printed, except stopping
+### messages. Option useful for simulation work.
+### = FALSE: informative messages will be printed.
+###
+################################################################################
+
+ mult <- match.arg(mult, c("sidak", "holm", "bonferroni"))
+ if(nmat < 2)
+ stop("Analysis requested for a single D matrix: CADM is useless")
+
+ a <- system.time({
+
+ ## Check the input file
+ if(ncol(Dmat) != n)
+ stop("Error in the value of 'n' or in the D matrices themselves")
+ nmat2 <- nrow(Dmat)/n
+ if(nmat2 < nmat) # OK if 'nmat' < number of matrices in the input file
+ stop("Number of input D matrices = ",nmat2,"; this value is < nmat")
+
+ nd <- n*(n-1)/2
+ if(is.null(weights)) {
+ w <- rep(1,nmat)
+ } else {
+ if(length(weights) != nmat)
+ stop("Incorrect number of values in vector 'weights'")
+ if(length(which(weights < 0)) > 0)
+ stop("Negative weights are not permitted")
+ w <- weights*nmat/sum(weights)
+ if(!silent) cat("Normalized weights =",w,'\n')
+ }
+
+ ## Are asymmetric D matrices present?
+ asy <- rep(FALSE, nmat)
+ asymm <- FALSE
+ end <- 0
+ for(k in 1:nmat) {
+ begin <- end+1
+ end <- end+n
+ D.temp <- Dmat[begin:end,]
+ if(sum(abs(diag(as.matrix(D.temp)))) > 0)
+ stop("Diagonal not 0: matrix #",k," is not a distance matrix")
+ vec1 <- as.vector(as.dist(D.temp))
+ vec2 <- as.vector(as.dist(t(D.temp)))
+ if(sum(abs((vec1-vec2))) > 0) {
+ if(!silent) cat("Matrix #",k," is asymmetric",'\n')
+ asy[k] <- TRUE
+ asymm <- TRUE
+ }
+ }
+ D1 <- as.list(1:nmat)
+ if(asymm) {
+ if(make.sym) {
+ if(!silent) cat("\nAsymmetric matrices were transformed to be symmetric",'\n')
+ } else {
+ nd <- nd*2
+ if(!silent) cat("\nAnalysis carried out on asymmetric matrices",'\n')
+ D2 <- as.list(1:nmat)
+ }
+ } else {
+ if(!silent) cat("Analysis of symmetric matrices",'\n')
+ }
+ Y <- rep(NA,nd)
+
+ ## String out the distance matrices (vec) and assemble them as columns into matrix 'Y'
+ ## Construct also matrices of ranked distances D1[[k]] and D2[[k]] for permutation test
+ end <- 0
+ for(k in 1:nmat) {
+ begin <- end+1
+ end <- end+n
+ D.temp <- as.matrix(Dmat[begin:end,])
+ vec <- as.vector(as.dist(D.temp))
+ if(asymm) {
+ if(!make.sym) {
+ ## Analysis carried out on asymmetric matrices:
+ ## The ranks are computed on the whole matrix except the diagonal values.
+ ## The two halves are stored as symmetric matrices in D1[[k]] and D2[[k]]
+ vec <- c(vec, as.vector(as.dist(t(D.temp))))
+ diag(D.temp) <- NA
+ D.temp2 <- rank(D.temp)
+ diag(D.temp2) <- 0
+ # cat("nrow =",nrow(D.temp2)," ncol =",ncol(D.temp2),'\n')
+ # cat("Matrix ",k," min =",min(D.temp2)," max =",max(D.temp2),'\n')
+ # cat("Matrix ",k," max values #",which(D.temp2 == max(D.temp2)),'\n')
+ D1[[k]] <- as.matrix(as.dist(D.temp2))
+ D2[[k]] <- as.matrix(as.dist(t(D.temp2)))
+ } else {
+ ## Asymmetric matrices transformed to be symmetric, stored in D1[[k]]
+ vec <- (vec + as.vector(as.dist(t(D.temp)))) / 2
+ D.temp2 <- (D.temp + t(D.temp)) / 2
+ D.temp2 <- as.dist(D.temp2)
+ D.temp2[] <- rank(D.temp2)
+ D.temp2 <- as.matrix(D.temp2)
+ D1[[k]] <- D.temp2
+ }
+ } else {
+ ## Symmetric matrices are stored in D1[[k]]
+ D.temp2 <- as.dist(D.temp)
+ D.temp2[] <- rank(D.temp2)
+ D1[[k]] <- as.matrix(D.temp2)
+ }
+ Y <- cbind(Y, vec)
+ }
+ Y <- as.matrix(Y[,-1])
+ colnames(Y) <- colnames(Y,do.NULL = FALSE, prefix = "Dmat.")
+
+ ## Begin calculations: compute reference value of S
+
+ ## Transform the distances to ranks, by column
+ Rmat <- apply(Y,2,rank)
+
+ ## Compute the S = Sum-of-Squares of the row-marginal sums of ranks (eq. 1a)
+ ## The ranks are weighted during the sum by the vector of matrix weights 'w'
+ sumRanks <- as.vector(Rmat%*%w)
+ S <- (nd-1)*var(sumRanks)
+
+ ## Begin a posteriori tests of individual matrices
+
+ ## Statistics displayed for each matrix: "Mantel.mean" and "W.per.matrix"
+ ## Calculate the mean of the Mantel correlations on ranks for each matrix
+ Mantel.cor <- cor(Rmat)
+ diag(Mantel.cor) <- 0
+ spear.mean <- as.vector(Mantel.cor%*%w)/(nmat-1)
+ ## Calculate Kendall's W for each variable
+ ## W.var <- ((nmat-1)*spear.mean+1)/nmat
+
+ ## P-value for each matrix: test of S, permuting values in matrix[[k]] only
+ ## as in program CADM.f (2004)
+ ## Initialize the counters
+ counter <- rep(1,nmat)
+
+ ## Test each matrix 'k' in turn
+ for(k in 1:nmat) {
+ ## Create a new Rmat table where the permuted column has been removed
+ Rmat.mod <- Rmat[,-k]
+
+ ## Permutation loop: string out permuted matrix 'k' only
+ for(j in 1:nperm) {
+ order <- sample(n)
+ if(asymm & !make.sym) {
+ ## For asymmetric matrices: permute the values within each triangular
+ ## portion, stored as square matrices in D1[[]] and D2[[]]
+ vec <- as.vector(as.dist(D1[[k]][order,order]))
+ vec <- c(vec, as.vector(as.dist(D2[[k]][order,order])))
+ } else {
+ vec <- as.vector(as.dist(D1[[k]][order,order]))
+ }
+ Rmat.perm <- cbind(Rmat.mod, vec)
+ S.perm <- (nd-1)*var(as.vector(Rmat.perm%*%w))
+ if(S.perm >= S) counter[k] <- counter[k]+1
+ }
+ }
+
+ ## Calculate P-values
+ counter <- counter/(nperm+1)
+
+ ## Correction to P-values for multiple testing
+ if(mult == "sidak") {
+ vec.corr = NA
+ for(i in 1:nmat) vec.corr = c(vec.corr, (1-(1-counter[i])^nmat))
+ vec.corr <- vec.corr[-1]
+ }
+ if(mult == "holm") vec.corr <- p.adjust(counter, method="holm")
+ if(mult == "bonferroni") vec.corr <- p.adjust(counter, method="bonferroni")
+
+ ## Create a data frame containing the results
+ # table <- rbind(spear.mean, W.var, counter, vec.corr)
+ # rownames(table) <- c("Mantel.mean", "W.per.matrix", "Prob", "Corrected prob")
+ table <- rbind(spear.mean, counter, vec.corr)
+ rownames(table) <- c("Mantel.mean", "Prob", "Corrected.prob")
+ colnames(table) <- colnames(table,do.NULL = FALSE, prefix = "Dmat.")
+
+ ## Mantel tests
+ if(mantel) {
+ diag(Mantel.cor) <- 1
+ rownames(Mantel.cor) <- colnames(table)
+ colnames(Mantel.cor) <- colnames(table)
+ Mantel.prob <- matrix(1,nmat,nmat)
+ rownames(Mantel.prob) <- colnames(table)
+ colnames(Mantel.prob) <- colnames(table)
+
+ for(j in 1:nperm) { # Each matrix is permuted independently
+ # There is no need to permute the last matrix
+ Rmat.perm <- rep(NA,nd)
+ ##
+ if(asymm & !make.sym) {
+ ## For asymmetric matrices: permute the values within each triangular
+ ## portion, stored as square matrices in D1[[]] and D2[[]]
+ for(k in 1:(nmat-1)) {
+ order <- sample(n)
+ vec <- as.vector(as.dist(D1[[k]][order,order]))
+ vec <- c(vec, as.vector(as.dist(D2[[k]][order,order])))
+ Rmat.perm <- cbind(Rmat.perm, vec)
+ }
+ vec <- as.vector(as.dist(D1[[nmat]]))
+ vec <- c(vec, as.vector(as.dist(D2[[nmat]])))
+ Rmat.perm <- cbind(Rmat.perm, vec)
+ } else {
+ for(k in 1:(nmat-1)) {
+ order <- sample(n)
+ vec <- as.vector(as.dist(D1[[k]][order,order]))
+ Rmat.perm <- cbind(Rmat.perm, vec)
+ }
+ vec <- as.vector(as.dist(D1[[nmat]]))
+ Rmat.perm <- cbind(Rmat.perm, vec)
+ }
+ # Remove the first column of Rmat.perm containing NA
+ Rmat.perm <- as.matrix(Rmat.perm[,-1])
+ # Compute Mantel correlations on ranks under permutation
+ Mantel.cor.perm <- cor(Rmat.perm)
+ for(j2 in 1:(nmat-1)) { # Compute prob in the upper tail
+ for(j1 in (j2+1):nmat) {
+ if(Mantel.cor.perm[j1,j2] >= Mantel.cor[j1,j2]) Mantel.prob[j1,j2] <- Mantel.prob[j1,j2]+1
+ }
+ }
+ }
+ Mantel.prob <- as.matrix(as.dist(Mantel.prob/(nperm+1)))
+ diag(Mantel.prob) <- NA # Corrected 08feb13
+ }
+
+ })
+ a[3] <- sprintf("%2f",a[3])
+ if(!silent) cat("Time to compute a posteriori tests (per matrix) =",a[3]," sec",'\n')
+
+ out <- list(A_posteriori_tests=table, Correction.type=mult)
+
+ if(mantel) {
+ out$Mantel.cor <- Mantel.cor
+ out$Mantel.prob <- Mantel.prob
+ }
+ out$nperm <- nperm
+ class(out) <- "CADM.post"
+ out
+}
diff --git a/R/CDF.birth.death.R b/R/CDF.birth.death.R
new file mode 100644
index 0000000..35b9028
--- /dev/null
+++ b/R/CDF.birth.death.R
@@ -0,0 +1,519 @@
+## CDF.birth.death.R (2014-03-03)
+
+## Functions to Simulate and Fit
+## Time-Dependent Birth-Death Models
+
+## Copyright 2010-2014 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+integrateTrapeze <- function(FUN, from, to, nint = 10)
+## compute an integral with a simple trapeze method
+## (apparently, Vectorize doesn't give faster calculation)
+{
+ x <- seq(from = from, to = to, length.out = nint + 1)
+ ## reorganized to minimize the calls to FUN:
+ out <- FUN(x[1]) + FUN(x[length(x)])
+ for (i in 2:nint) out <- out + 2 * FUN(x[i])
+ (x[2] - x[1]) * out/2 # (x[2] - x[1]) is the width of the trapezes
+}
+
+## case:
+## 1: birth and death rates constant
+## 2: no primitive available
+## 3: primitives are available
+## 4: death rate constant, no primitive available
+## 5: birth rate constant, no primitive available
+## 6: death rate constant, primitive available for birth(t)
+## 7: birth rate constant, primitive available for death(t)
+
+.getCase <- function(birth, death, BIRTH = NULL, DEATH = NULL)
+{
+ if (is.numeric(birth)) {
+ if (is.numeric(death)) 1 else {
+ if (is.null(DEATH)) 5 else 7
+ }
+ } else {
+ if (is.numeric(death)) {
+ if (is.null(BIRTH)) 4 else 6
+ } else if (is.null(BIRTH) || is.null(DEATH)) 2 else 3
+ }
+}
+
+if(getRversion() >= "2.15.1") utils::globalVariables("Tmax")
+
+.getRHOetINT <- function(birth, death, BIRTH = NULL, DEATH = NULL, case, fast)
+{
+ ## build the RHO(), \rho(t), and INT(), I(t), functions
+ switch (case,
+ { # case 1:
+ RHO <- function(t1, t2) (t2 - t1)*(death - birth)
+ INT <- function(t) {
+ rho <- death - birth
+ death*(exp(rho*(Tmax - t)) - 1)/rho
+ }
+ },{ # case 2:
+ if (fast) {
+ RHO <- function(t1, t2)
+ integrateTrapeze(function(t) death(t) - birth(t), t1, t2)
+ INT <- function(t) {
+ FOO <- function(u) exp(RHO(t, u)) * death(u)
+ integrateTrapeze(FOO, t, Tmax)
+ }
+ } else {
+ RHO <- function(t1, t2)
+ integrate(function(t) death(t) - birth(t), t1, t2)$value
+ INT <- function(t) {
+ FOO <- function(u) exp(RHO(t, u)) * death(u)
+ integrate(Vectorize(FOO), t, Tmax)$value # Vectorize required
+ }
+ }
+ },{ # case 3:
+ RHO <- function(t1, t2)
+ DEATH(t2) - BIRTH(t2) - DEATH(t1) + BIRTH(t1)
+ INT <- function(t) { # vectorized
+ FOO <- function(u) exp(RHO(tt, u)) * death(u)
+ out <- t
+ for (i in 1:length(t)) {
+ tt <- t[i]
+ out[i] <- integrate(FOO, tt, Tmax)$value
+ }
+ out
+ }
+ },{ # case 4:
+ if (fast) {
+ RHO <- function(t1, t2)
+ death * (t2 - t1) - integrateTrapeze(birth, t1, t2)
+ INT <- function(t) {
+ FOO <- function(u) exp(RHO(t, u)) * death
+ integrateTrapeze(Vectorize(FOO), t, Tmax)
+ }
+ } else {
+ RHO <- function(t1, t2)
+ death * (t2 - t1) - integrate(birth, t1, t2)$value
+ INT <- function(t) {
+ FOO <- function(u) exp(RHO(t, u)) * death
+ integrate(Vectorize(FOO), t, Tmax)$value
+ }
+ }
+ },{ # case 5:
+ RHO <- function(t1, t2)
+ integrate(death, t1, t2)$value - birth * (t2 - t1)
+ if (fast) {
+ INT <- function(t) {
+ FOO <- function(u) exp(RHO(t, u)) * death(u)
+ integrateTrapeze(FOO, t, Tmax)
+ }
+ } else {
+ INT <- function(t) {
+ FOO <- function(u) exp(RHO(t, u)) * death(u)
+ integrate(Vectorize(FOO), t, Tmax)$value
+ }
+ }
+ },{ # case 6:
+ RHO <- function(t1, t2) death * (t2 - t1) - BIRTH(t2) + BIRTH(t1)
+ INT <- function(t) { # vectorized
+ FOO <- function(u) exp(RHO(tt, u)) * death
+ out <- t
+ for (i in 1:length(t)) {
+ tt <- t[i]
+ out[i] <- integrate(FOO, tt, Tmax)$value
+ }
+ out
+ }
+ },{ # case 7:
+ RHO <- function(t1, t2) DEATH(t2) - DEATH(t1) - birth * (t2 - t1)
+ if (fast) {
+ INT <- function(t) {
+ FOO <- function(u) exp(RHO(t, u)) * death(u)
+ integrateTrapeze(FOO, t, Tmax)
+ }
+ } else {
+ INT <- function(t) {
+ FOO <- function(u) exp(RHO(t, u)) * death(u)
+ integrate(Vectorize(FOO), t, Tmax)$value
+ }
+ }
+ })
+ list(RHO, INT)
+}
+
+CDF.birth.death <-
+ function(birth, death, BIRTH = NULL, DEATH = NULL, Tmax, x, case, fast = FALSE)
+{
+ ff <- .getRHOetINT(birth, death, BIRTH, DEATH, case, fast)
+ RHO <- ff[[1]]
+ INT <- ff[[2]]
+ environment(INT) <- environment() # so that INT() can find Tmax
+ .CDF.birth.death2(RHO, INT, birth, death, BIRTH, DEATH,
+ Tmax, x, case, fast)
+}
+
+.CDF.birth.death2 <-
+ function(RHO, INT, birth, death, BIRTH, DEATH, Tmax, x, case, fast)
+{
+ Pi <- if (case %in% c(1, 5, 7))
+ function(t) (1/(1 + INT(t)))^2 * 2 * exp(-RHO(0, t)) * birth
+ else
+ function(t) (1/(1 + INT(t)))^2 * 2 * exp(-RHO(0, t)) * birth(t)
+
+ if (!case %in% c(1, 3, 6)) Pi <- Vectorize(Pi)
+
+ denom <-
+ if (fast) integrateTrapeze(Pi, 0, Tmax)
+ else integrate(Pi, 0, Tmax)$value
+ n <- length(x)
+ p <- numeric(n)
+ if (fast) {
+ for (i in 1:n) p[i] <- integrateTrapeze(Pi, 0, x[i])
+ } else {
+ for (i in 1:n) p[i] <- integrate(Pi, 0, x[i])$value
+ }
+ p/denom
+}
+
+.makePhylo <- function(edge, edge.length, i)
+{
+ NODES <- edge > 0
+ edge[NODES] <- edge[NODES] + i + 1L
+ edge[!NODES] <- 1:(i + 1L)
+
+ phy <- list(edge = edge, edge.length = edge.length,
+ tip.label = paste("t", 1:(i + 1), sep = ""), Nnode = i)
+ class(phy) <- "phylo"
+ attr(phy, "order") <- "cladewise"
+ phy
+}
+
+rlineage <-
+ function(birth, death, Tmax = 50, BIRTH = NULL, DEATH = NULL, eps = 1e-6)
+{
+ case <- .getCase(birth, death, BIRTH, DEATH)
+
+ rTimeToEvent <- function(t)
+ {
+ ## CDF of the times to event (speciation or extinction):
+ switch (case,
+ { # case 1:
+ Foo <- function(t, x)
+ 1 - exp(-(birth + death)*(x - t))
+ },{ # case 2:
+ Foo <- function(t, x) {
+ if (t == x) return(0)
+ 1 - exp(-integrate(function(t) birth(t) + death(t),
+ t, x)$value)
+ }
+ },{ # case 3:
+ Foo <- function(t, x) {
+ if (t == x) return(0)
+ 1 - exp(-(BIRTH(x) - BIRTH(t) + DEATH(x) - DEATH(t)))
+ }
+ },{ # case 4:
+ Foo <- function(t, x) {
+ if (t == x) return(0)
+ 1 - exp(-(integrate(function(t) birth(t), t, x)$value
+ + death*(x - t)))
+ }
+
+ },{ # case 5:
+ Foo <- function(t, x) {
+ if (t == x) return(0)
+ 1 - exp(-(birth*(x - t) +
+ integrate(function(t) death(t), t, x)$value))
+ }
+
+ },{ # case 6:
+ Foo <- function(t, x) {
+ if (t == x) return(0)
+ 1 - exp(-(BIRTH(x) - BIRTH(t) + death*(x - t)))
+ }
+
+ },{ # case 7:
+ Foo <- function(t, x) {
+ if (t == x) return(0)
+ 1 - exp(-(birth*(x - t) + DEATH(x) - DEATH(t) ))
+ }
+ })
+
+ ## generate a random time to event by the inverse method:
+ P <- runif(1)
+ ## in case speciation probability is so low
+ ## that time to speciation is infinite:
+ if (Foo(t, Tmax) < P) return(Tmax + 1)
+ inc <- 10
+ x <- t + inc
+ while (inc > eps) { # la pr�cision influe sur le temps de calcul
+ if (Foo(t, x) > P) {
+ x <- x - inc
+ inc <- inc/10
+ } else x <- x + inc
+ }
+ x - t
+ }
+
+ if (case == 1)
+ speORext <- function(t) birth/(birth + death)
+ if (case == 2 || case == 3)
+ speORext <- function(t) birth(t)/(birth(t) + death(t))
+ if (case == 4 || case == 6)
+ speORext <- function(t) birth(t)/(birth(t) + death)
+ if (case == 5 || case == 7)
+ speORext <- function(t) birth/(birth + death(t))
+
+ ## the recursive function implementing algorithm 1
+ foo <- function(node) {
+ for (k in 0:1) {
+ X <- rTimeToEvent(t[node])
+ tmp <- t[node] + X
+ ## is the event a speciation or an extinction?
+ if (tmp >= Tmax) {
+ Y <- 0
+ tmp <- Tmax
+ } else Y <- rbinom(1, size = 1, prob = speORext(tmp))
+ j <<- j + 1L
+ edge.length[j] <<- tmp - t[node]
+ if (Y) {
+ i <<- i + 1L
+ t[i] <<- tmp
+ ## set internal edge:
+ edge[j, ] <<- c(node, i)
+ foo(i)
+ } else
+ ## set terminal edge:
+ edge[j, ] <<- c(node, 0L)
+ }
+ }
+
+ edge <- matrix(0L, 1e5, 2)
+ edge.length <- numeric(1e5)
+ j <- 0L; i <- 1; t <- 0
+ foo(1L)
+ .makePhylo(edge[1:j, ], edge.length[1:j], i)
+}
+
+drop.fossil <- function(phy, tol = 1e-8)
+{
+ n <- Ntip(phy)
+ x <- dist.nodes(phy)[n + 1, ][1:n]
+ drop.tip(phy, which(x < max(x) - tol))
+}
+
+rbdtree <-
+ function(birth, death, Tmax = 50, BIRTH = NULL, DEATH = NULL, eps = 1e-6)
+{
+ case <- .getCase(birth, death, BIRTH, DEATH)
+ ff <- .getRHOetINT(birth, death, BIRTH, DEATH, case, FALSE)
+ RHO <- ff[[1]]
+ INT <- ff[[2]]
+ ## so that RHO() and INT() can find Tmax:
+ environment(RHO) <- environment(INT) <- environment()
+
+ rtimetospe <- function(t)
+ {
+ ## CDF of the times to speciation:
+ Foo <- if (case %in% c(1, 5, 7))
+ function(t, x) 1 - exp(-birth*(x - t))
+ else {
+ if (case %in% c(3, 6))
+ function(t, x) 1 - exp(-(BIRTH(x) - BIRTH(t)))
+ else {
+ function(t, x) {
+ if (t == x) return(0)
+ 1 - exp(-integrate(birth, t, x)$value)
+ }
+ }
+ }
+ ## generate a random time to speciation by the inverse method:
+ P <- runif(1)
+ ## in case speciation probability is so low
+ ## that time to speciation is infinite:
+ if (Foo(t, Tmax) < P) return(Tmax + 1)
+ inc <- 10
+ x <- t + inc
+ while (inc > eps) { # la pr�cision influe sur le temps de calcul
+ if (Foo(t, x) > P) {
+ x <- x - inc
+ inc <- inc/10
+ } else x <- x + inc
+ }
+ x - t
+ }
+
+ ## the recursive function implementing algorithm 2
+ foo <- function(node, start) {
+ node <- node # make a local copy
+ for (k in 0:1) {
+ tau <- start # because tau is changed below
+ NoDesc <- TRUE
+ X <- rtimetospe(tau)
+ while (X < Tmax - tau) {
+ tau <- tau + X
+ ## does the new lineage survive until Tmax?
+ Y <- rbinom(1, size = 1, prob = 1/(1 + INT(tau)))
+ if (Y) {
+ i <<- i + 1L
+ t[i] <<- tau
+ ## set internal edge:
+ j <<- j + 1L
+ edge[j, ] <<- c(node, i)
+ edge.length[j] <<- tau - t[node]
+ foo(i, t[i])
+ NoDesc <- FALSE
+ break
+ }
+ X <- rtimetospe(tau)
+ }
+ ## set terminal edge:
+ if (NoDesc) {
+ j <<- j + 1L
+ edge[j, 1] <<- node # the 2nd column is already set to 0
+ edge.length[j] <<- Tmax - t[node]
+ }
+ }
+ }
+
+ edge <- matrix(0L, 1e5, 2)
+ edge.length <- numeric(1e5)
+ j <- 0L; i <- 1L; t <- 0
+ foo(1L, 0)
+ .makePhylo(edge[1:j, ], edge.length[1:j], i)
+}
+
+bd.time <- function(phy, birth, death, BIRTH = NULL, DEATH = NULL,
+ ip, lower, upper, fast = FALSE, boot = 0, trace = 0)
+{
+ guess.bounds <- if (missing(lower)) TRUE else FALSE
+ BIG <- 1e10
+ PrNt <- function(t, T, x)
+ {
+ tmp <- exp(-RHO(t, T))
+ Wt <- tmp * (1 + INT(t))
+ out <- numeric(length(x))
+ zero <- x == 0
+ if (length(zero)) {
+ out[zero] <- 1 - tmp/Wt
+ out[!zero] <- (tmp/Wt^2)*(1 - 1/Wt)^(x[!zero] - 1)
+ } else out[] <- (tmp/Wt^2)*(1 - 1/Wt)^(x - 1)
+ out
+ }
+
+ case <- .getCase(birth, death, BIRTH, DEATH)
+
+ if (is.function(birth)) {
+ paranam <- names(formals(birth))
+ if (guess.bounds) {
+ upper <- rep(BIG, length(paranam))
+ lower <- -upper
+ }
+ formals(birth) <- alist(t=)
+ environment(birth) <- environment()
+ if (!is.null(BIRTH)) environment(BIRTH) <- environment()
+ } else {
+ paranam <- "birth"
+ if (guess.bounds) {
+ upper <- 1
+ lower <- 0
+ }
+ }
+
+ if (is.function(death)) {
+ tmp <- names(formals(death))
+ np2 <- length(tmp)
+ if (guess.bounds) {
+ upper <- c(upper, rep(BIG, np2))
+ lower <- c(lower, rep(-BIG, np2))
+ }
+ paranam <- c(paranam, tmp)
+ formals(death) <- alist(t=)
+ environment(death) <- environment()
+ if (!is.null(DEATH)) environment(DEATH) <- environment()
+ } else {
+ paranam <- c(paranam, "death")
+ if (guess.bounds) {
+ upper <- c(upper, .1)
+ lower <- c(lower, 0)
+ }
+ }
+
+ np <- length(paranam)
+
+ ff <- .getRHOetINT(birth, death, BIRTH, DEATH, case = case, fast = fast)
+ RHO <- ff[[1]]
+ INT <- ff[[2]]
+ environment(RHO) <- environment(INT) <- environment()
+
+ x <- branching.times(phy)
+ n <- length(x)
+ Tmax <- x[1]
+ x <- Tmax - x # change the time scale so the root is t=0
+ x <- sort(x)
+
+ foo <- function(para) {
+ for (i in 1:np)
+ assign(paranam[i], para[i], pos = sys.frame(1))
+ p <- CDF.birth.death(birth, death, BIRTH, DEATH, Tmax = Tmax,
+ x = x, case = case, fast = fast)
+ ## w is the probability of the observed tree size (= number of tips)
+ w <- PrNt(0, Tmax, Ntip(phy))
+ ## p is the expected CDF of branching times
+ ## ecdf(x)(x) is the observed CDF
+ sum((1:n/n - p)^2)/w # faster than sum((ecdf(x)(x) - p)^2)/w
+ }
+
+ if (missing(ip)) ip <- (upper - lower)/2
+
+ out <- nlminb(ip, foo, control = list(trace = trace, eval.max = 500),
+ upper = upper, lower = lower)
+
+ names(out$par) <- paranam
+ names(out)[2] <- "SS"
+
+ if (boot) { # nonparametric version
+ PAR <- matrix(NA, boot, np)
+ i <- 1L
+ while (i <= boot) {
+ cat("\rDoing bootstrap no.", i, "\n")
+ x <- sort(sample(x, replace = TRUE))
+ o <- try(nlminb(ip, foo, control = list(trace = 0, eval.max = 500),
+ upper = upper, lower = lower))
+ if (class(o) == "list") {
+ PAR[i, ] <- o$par
+ i <- i + 1L
+ }
+ }
+ out$boot <- PAR
+ }
+ out
+}
+
+LTT <- function(birth = 0.1, death = 0, N = 100, Tmax = 50, PI = 95,
+ scaled = TRUE, eps = 0.1, add = FALSE, backward = TRUE,
+ ltt.style = list("black", 1, 1),
+ pi.style = list("blue", 1, 2))
+{
+ case <- .getCase(birth, death, NULL, NULL)
+ Time <- seq(0, Tmax, eps)
+ F <- CDF.birth.death(birth, death, BIRTH = NULL, DEATH = NULL,
+ Tmax = Tmax, x = Time, case = case, fast = TRUE)
+ if (PI) {
+ i <- (1 - PI/100)/2
+ Flow <- qbinom(i, N - 2, F)
+ Fup <- qbinom(1 - i, N - 2, F)
+ if (scaled) {
+ Flow <- Flow/N
+ Fup <- Fup/N
+ }
+ }
+ if (!scaled) F <- F * N
+ if (backward) Time <- Time - Tmax
+ if (add)
+ lines(Time, F, "l", col = ltt.style[[1]], lwd = ltt.style[[2]],
+ lty = ltt.style[[3]])
+ else
+ plot(Time, F, "l", col = ltt.style[[1]], lwd = ltt.style[[2]],
+ lty = ltt.style[[3]], ylab = "Number of lineages")
+ if (PI)
+ lines(c(Time, NA, Time), c(Flow, NA, Fup),
+ col = pi.style[[1]], lwd = pi.style[[2]], lty = pi.style[[3]])
+}
diff --git a/R/Cheverud.R b/R/Cheverud.R
new file mode 100644
index 0000000..a2073d0
--- /dev/null
+++ b/R/Cheverud.R
@@ -0,0 +1,141 @@
+## Cheverud.R (2004-10-29)
+
+## Cheverud's 1985 Autoregression Model
+
+## Copyright 2004 Julien Dutheil
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+# This function is adapted from a MatLab code from
+# Rholf, F. J. (2001) Comparative Methods for the Analysis of Continuous Variables: Geometric Interpretations.
+# Evolution 55(11): 2143-2160
+compar.cheverud <- function(y, W, tolerance=1e-6, gold.tol=1e-4)
+{
+ ## fix by Michael Phelan
+ diag(W) <- 0 # ensure diagonal is zero
+ ## end of fix
+ y <- as.matrix(y)
+ if(dim(y)[2] != 1) stop("Error: y must be a single column vector.")
+ D <- solve(diag(apply(t(W),2,sum)))
+ Wnorm <- D %*% W #Row normalize W matrix
+ n <- dim(y)[1]
+ m <- dim(y)[2]
+ y <- y-matrix(rep(1, n)) %*% apply(y,2,mean) # Deviations from mean
+ Wy <- Wnorm %*% y
+
+ Wlam <- eigen(Wnorm)$values # eigenvalues of W
+
+ # Find distinct eigenvalues
+ sorted <- sort(Wlam)
+ # Check real:
+ for (ii in 1:n) {
+ if(abs(Im(sorted[ii])) > 1e-12) {
+ warning(paste("Complex eigenvalue coerced to real:", Im(sorted[ii])))
+ }
+ sorted[ii] <- Re(sorted[ii]) # Remove imaginary part
+ }
+ sorted <- as.double(sorted)
+
+ Distinct <- numeric(0)
+ Distinct[1] <- -Inf
+ Distinct[2] <- sorted[1]
+ nDistinct <- 2
+ for(ii in 2:n) {
+ if(sorted[ii] - Distinct[nDistinct] > tolerance) {
+ nDistinct <- nDistinct + 1
+ Distinct[nDistinct] <- sorted[ii]
+ }
+ }
+
+ # Search for minimum of LL
+
+ likelihood <- function(rhohat) {
+ DetProd <- 1
+ for(j in 1:n) {
+ prod <- 1 - rhohat * Wlam[j]
+ DetProd <- DetProd * prod
+ }
+ absValDet <- abs(DetProd) #[abs to allow rho > 1]
+ logDet <- log(absValDet)
+ LL <- log(t(y) %*% y - 2 * rhohat * t(y) %*% Wy + rhohat * rhohat * t(Wy) %*% Wy) - logDet*2/n
+ return(LL)
+ }
+
+ GoldenSearch <- function(ax, cx) {
+ # Golden section search over the interval ax to cx
+ # Return rhohat and likelihood value.
+ r <- 0.61803399
+ x0 <- ax
+ x3 <- cx
+ bx <- (ax + cx)/2
+ if(abs(cx - bx) > abs(bx - ax)) {
+ x1 <- bx
+ x2 <- bx + (1-r)*(cx - bx)
+ } else {
+ x2 <- bx
+ x1 <- bx - (1-r)*(bx - ax)
+ }
+ f1 <- likelihood(x1)
+ f2 <- likelihood(x2)
+ while(abs(x3 - x0) > gold.tol*(abs(x1) + abs(x2))) {
+ if(f2 < f1) {
+ x0 <- x1
+ x1 <- x2
+ x2 <- r * x1 + (1 - r) * x3
+ f1 <- f2
+ f2 <- likelihood(x2)
+ } else {
+ x3 <- x2
+ x2 <- x1
+ x1 <- r * x2 + (1 - r) * x0
+ f2 <- f1
+ f1 <- likelihood(x1)
+ }
+ }
+ if(f1 < f2) {
+ likelihood <- f1
+ xmin <- x1
+ } else {
+ likelihood <- f2
+ xmin <- x2
+ }
+ return(list(rho=xmin, LL=likelihood))
+ }
+
+ LL <- Inf
+ for(ii in 2:(nDistinct -1)) {# Search between pairs of roots
+ # [ constrain do not use positive roots < 1]
+ ax <- 1/Distinct[ii]
+ cx <- 1/Distinct[ii+1]
+ GS <- GoldenSearch(ax, cx)
+ if(GS$LL < LL) {
+ LL <- GS$LL
+ rho <- GS$rho
+ }
+ }
+ # Compute residuals:
+ res <- y - rho * Wy
+ return(list(rhohat=rho, Wnorm=Wnorm, residuals=res))
+}
+
+#For debugging:
+#W<- matrix(c(
+# 0,1,1,2,0,0,0,0,
+# 1,0,1,2,0,0,0,0,
+# 1,1,0,2,0,0,0,0,
+# 2,2,2,0,0,0,0,0,
+# 0,0,0,0,0,1,1,2,
+# 0,0,0,0,1,0,1,2,
+# 0,0,0,0,1,1,0,2,
+# 0,0,0,0,2,2,2,0
+#),8)
+#W <- 1/W
+#W[W == Inf] <- 0
+#y<-c(-0.12,0.36,-0.1,0.04,-0.15,0.29,-0.11,-0.06)
+#compar.cheverud(y,W)
+#
+#y<-c(10,8,3,4)
+#W <- matrix(c(1,1/6,1/6,1/6,1/6,1,1/2,1/2,1/6,1/2,1,1,1/6,1/2,1,1), 4)
+#compar.cheverud(y,W)
+
diff --git a/R/DNA.R b/R/DNA.R
new file mode 100644
index 0000000..de0c300
--- /dev/null
+++ b/R/DNA.R
@@ -0,0 +1,500 @@
+## DNA.R (2013-08-12)
+
+## Manipulations and Comparisons of DNA Sequences
+
+## Copyright 2002-2013 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+labels.DNAbin <- function(object, ...)
+{
+ if (is.list(object)) return(names(object))
+ if (is.matrix(object)) return(rownames(object))
+ NULL
+}
+
+del.gaps <- function(x)
+{
+ deleteGaps <- function(x) {
+ i <- which(x == 4)
+ if (length(i)) x[-i] else x
+ }
+
+ if (!inherits(x, "DNAbin")) x <- as.DNAbin(x)
+ if (is.matrix(x)) {
+ n <- dim(x)[1]
+ y <- vector("list", n)
+ for (i in 1:n) y[[i]] <- x[i, ]
+ names(y) <- rownames(x)
+ x <- y
+ rm(y)
+ }
+ if (!is.list(x)) return(deleteGaps(x))
+ x <- lapply(x, deleteGaps)
+ class(x) <- "DNAbin"
+ x
+}
+
+as.alignment <- function(x)
+{
+ if (is.list(x)) n <- length(x)
+ if (is.matrix(x)) n <- dim(x)[1]
+ seq <- character(n)
+ if (is.list(x)) {
+ nam <- names(x)
+ for (i in 1:n)
+ seq[i] <- paste(x[[i]], collapse = "")
+ }
+ if (is.matrix(x)) {
+ nam <- dimnames(x)[[1]]
+ for (i in 1:n)
+ seq[i] <- paste(x[i, ], collapse = "")
+ }
+ obj <- list(nb = n, seq = seq, nam = nam, com = NA)
+ class(obj) <- "alignment"
+ obj
+}
+
+"[.DNAbin" <- function(x, i, j, drop = FALSE)
+{
+ ans <- NextMethod("[", drop = drop)
+ class(ans) <- "DNAbin"
+ ans
+}
+
+as.matrix.DNAbin <- function(x, ...)
+{
+ if (is.matrix(x)) return(x)
+ if (is.vector(x)) {
+ dim(x) <- c(1, length(x))
+ return(x)
+ }
+ s <- unique(unlist(lapply(x, length)))
+ if (length(s) != 1)
+ stop("DNA sequences in list not of the same length.")
+ nms <- names(x)
+ n <- length(x)
+ y <- matrix(as.raw(0), n, s)
+ for (i in seq_len(n)) y[i, ] <- x[[i]]
+ rownames(y) <- nms
+ class(y) <- "DNAbin"
+ y
+}
+
+as.list.DNAbin <- function(x, ...)
+{
+ if (is.list(x)) return(x)
+ if (is.null(dim(x))) obj <- list(x) # cause is.vector() doesn't work
+ else { # matrix
+ n <- nrow(x)
+ obj <- vector("list", n)
+ for (i in 1:n) obj[[i]] <- x[i, ]
+ names(obj) <- rownames(x)
+ }
+ class(obj) <- "DNAbin"
+ obj
+}
+
+rbind.DNAbin <- function(...)
+### works only with matrices for the moment
+{
+ obj <- list(...)
+ n <- length(obj)
+ if (n == 1) return(obj[[1]])
+ for (i in 1:n)
+ if (!is.matrix(obj[[1]]))
+ stop("the 'rbind' method for \"DNAbin\" accepts only matrices")
+ NC <- unlist(lapply(obj, ncol))
+ if (length(unique(NC)) > 1)
+ stop("matrices do not have the same number of columns.")
+ for (i in 1:n) class(obj[[i]]) <- NULL
+ for (i in 2:n) obj[[1]] <- rbind(obj[[1]], obj[[i]])
+ structure(obj[[1]], class = "DNAbin")
+}
+
+cbind.DNAbin <-
+ function(..., check.names = TRUE, fill.with.gaps = FALSE,
+ quiet = FALSE)
+### works only with matrices for the moment
+{
+ obj <- list(...)
+ n <- length(obj)
+ if (n == 1) return(obj[[1]])
+ for (i in 1:n)
+ if (!is.matrix(obj[[1]]))
+ stop("the 'cbind' method for \"DNAbin\" accepts only matrices")
+ NR <- unlist(lapply(obj, nrow))
+ for (i in 1:n) class(obj[[i]]) <- NULL
+ if (check.names) {
+ nms <- unlist(lapply(obj, rownames))
+ if (fill.with.gaps) {
+ NC <- unlist(lapply(obj, ncol))
+ nms <- unique(nms)
+ ans <- matrix(as.raw(4), length(nms), sum(NC))
+ rownames(ans) <- nms
+ from <- 1
+ for (i in 1:n) {
+ to <- from + NC[i] - 1
+ tmp <- rownames(obj[[i]])
+ nmsi <- tmp[tmp %in% nms]
+ ans[nmsi, from:to] <- obj[[i]][nmsi, , drop = FALSE]
+ from <- to + 1
+ }
+ } else {
+ tab <- table(nms)
+ ubi <- tab == n
+ nms <- names(tab)[which(ubi)]
+ ans <- obj[[1]][nms, , drop = FALSE]
+ for (i in 2:n)
+ ans <- cbind(ans, obj[[i]][nms, , drop = FALSE])
+ if (!quiet && !all(ubi))
+ warning("some rows were dropped.")
+ }
+ } else {
+ if (length(unique(NR)) > 1)
+ stop("matrices do not have the same number of rows.")
+ ans <- matrix(unlist(obj), NR)
+ rownames(ans) <- rownames(obj[[1]])
+ }
+ class(ans) <- "DNAbin"
+ ans
+}
+
+c.DNAbin <- function(..., recursive = FALSE)
+{
+ if (!all(unlist(lapply(list(...), is.list))))
+ stop("the 'c' method for \"DNAbin\" accepts only lists")
+ structure(NextMethod("c"), class = "DNAbin")
+}
+
+print.DNAbin <- function(x, printlen = 6, digits = 3, ...)
+{
+ if (is.list(x)) {
+ n <- length(x)
+ nms <- names(x)
+ if (n == 1) {
+ cat("1 DNA sequence in binary format stored in a list.\n\n")
+ nTot <- length(x[[1]])
+ cat("Sequence length:", nTot, "\n\n")
+ cat("Label:", nms, "\n\n")
+ } else {
+ cat(n, "DNA sequences in binary format stored in a list.\n\n")
+ tmp <- unlist(lapply(x, length))
+ nTot <- sum(tmp)
+ mini <- range(tmp)
+ maxi <- mini[2]
+ mini <- mini[1]
+ if (mini == maxi)
+ cat("All sequences of same length:", maxi, "\n")
+ else {
+ cat("Mean sequence length:", round(mean(tmp), 3), "\n")
+ cat(" Shortest sequence:", mini, "\n")
+ cat(" Longest sequence:", maxi, "\n")
+ }
+ TAIL <- "\n\n"
+ if (printlen < n) {
+ nms <- nms[1:printlen]
+ TAIL <- "...\n\n"
+ }
+ cat("\nLabels:", paste(nms, collapse = " "), TAIL)
+ }
+ } else {
+ nTot <- length(x)
+ if (is.matrix(x)) {
+ nd <- dim(x)
+ nms <- rownames(x)
+ cat(nd[1], "DNA sequences in binary format stored in a matrix.\n\n")
+ cat("All sequences of same length:", nd[2], "\n")
+ TAIL <- "\n\n"
+ if (printlen < nd[1]) {
+ nms <- nms[1:printlen]
+ TAIL <- "...\n\n"
+ }
+ cat("\nLabels:", paste(nms, collapse = " "), TAIL)
+ } else {
+ cat("1 DNA sequence in binary format stored in a vector.\n\n")
+ cat("Sequence length:", nTot, "\n\n")
+ }
+ }
+ if (nTot <= 1e6) {
+ cat("Base composition:\n")
+ print(round(base.freq(x), digits))
+ } else cat("More than 1 million nucleotides: not printing base composition\n")
+}
+
+as.DNAbin <- function(x, ...) UseMethod("as.DNAbin")
+
+._cs_ <- c("a", "g", "c", "t", "r", "m", "w", "s", "k",
+ "y", "v", "h", "d", "b", "n", "-", "?")
+
+._bs_ <- c(136, 72, 40, 24, 192, 160, 144, 96, 80,
+ 48, 224, 176, 208, 112, 240, 4, 2)
+
+as.DNAbin.character <- function(x, ...)
+{
+ n <- length(x)
+ ans <- raw(n)
+ for (i in 1:15)
+ ans[which(x == ._cs_[i])] <- as.raw(._bs_[i])
+ ans[which(x == "-")] <- as.raw(4)
+ ans[which(x == "?")] <- as.raw(2)
+ if (is.matrix(x)) {
+ dim(ans) <- dim(x)
+ dimnames(ans) <- dimnames(x)
+ }
+ class(ans) <- "DNAbin"
+ ans
+}
+
+as.DNAbin.alignment <- function(x, ...)
+{
+ n <- x$nb
+ x$seq <- tolower(x$seq)
+ ans <- matrix("", n, nchar(x$seq[1]))
+ for (i in 1:n)
+ ans[i, ] <- strsplit(x$seq[i], "")[[1]]
+ rownames(ans) <- gsub(" +$", "", gsub("^ +", "", x$nam))
+ as.DNAbin.character(ans)
+}
+
+as.DNAbin.list <- function(x, ...)
+{
+ obj <- lapply(x, as.DNAbin)
+ class(obj) <- "DNAbin"
+ obj
+}
+
+as.character.DNAbin <- function(x, ...)
+{
+ f <- function(xx) {
+ ans <- character(length(xx))
+ for (i in 1:15)
+ ans[which(xx == ._bs_[i])] <- ._cs_[i]
+ ans[which(xx == 4)] <- "-"
+ ans[which(xx == 2)] <- "?"
+ if (is.matrix(xx)) {
+ dim(ans) <- dim(xx)
+ dimnames(ans) <- dimnames(xx)
+ }
+ ans
+ }
+ if (is.list(x)) lapply(x, f) else f(x)
+}
+
+base.freq <- function(x, freq = FALSE, all = FALSE)
+{
+ f <- function(x)
+ .C(BaseProportion, x, as.integer(length(x)), double(17),
+ NAOK = TRUE)[[3]]
+
+ if (is.list(x)) {
+ BF <- rowSums(sapply(x, f))
+ n <- sum(sapply(x, length))
+ } else {
+ n <- length(x)
+ BF <- .C(BaseProportion, x, as.integer(n), double(17),
+ NAOK = TRUE)[[3]]
+ }
+
+ names(BF) <- c("a", "c", "g", "t", "r", "m", "w", "s",
+ "k", "y", "v", "h", "d", "b", "n", "-", "?")
+ if (all) {
+ if (!freq) BF <- BF / n
+ } else {
+ BF <- BF[1:4]
+ if (!freq) BF <- BF / sum(BF)
+ }
+ BF
+}
+
+Ftab <- function(x, y = NULL)
+{
+ if (is.null(y)) {
+ if (is.list(x)) {
+ y <- x[[2]]
+ x <- x[[1]]
+ if (length(x) != length(y))
+ stop("'x' and 'y' not of the same length")
+ } else { # 'x' is a matrix
+ y <- x[2, , drop = TRUE]
+ x <- x[1, , drop = TRUE]
+ }
+ } else {
+ x <- as.vector(x)
+ y <- as.vector(y)
+ if (length(x) != length(y))
+ stop("'x' and 'y' not of the same length")
+ }
+ out <- matrix(0, 4, 4)
+ k <- c(136, 40, 72, 24)
+ for (i in 1:4) {
+ a <- x == k[i]
+ for (j in 1:4) {
+ b <- y == k[j]
+ out[i, j] <- sum(a & b)
+ }
+ }
+ dimnames(out)[1:2] <- list(c("a", "c", "g", "t"))
+ out
+}
+
+GC.content <- function(x) sum(base.freq(x)[2:3])
+
+seg.sites <- function(x)
+{
+ if (is.list(x)) x <- as.matrix(x)
+ if (is.vector(x)) n <- 1
+ else { # 'x' is a matrix
+ n <- dim(x)
+ s <- n[2]
+ n <- n[1]
+ }
+ if (n == 1) return(integer(0))
+ ans <- .C(SegSites, x, as.integer(n), as.integer(s),
+ integer(s), NAOK = TRUE)
+ which(as.logical(ans[[4]]))
+}
+
+dist.dna <- function(x, model = "K80", variance = FALSE, gamma = FALSE,
+ pairwise.deletion = FALSE, base.freq = NULL,
+ as.matrix = FALSE)
+{
+ MODELS <- c("RAW", "JC69", "K80", "F81", "K81", "F84", "T92", "TN93",
+ "GG95", "LOGDET", "BH87", "PARALIN", "N", "TS", "TV",
+ "INDEL", "INDELBLOCK")
+ imod <- pmatch(toupper(model), MODELS)
+ if (is.na(imod))
+ stop(paste("'model' must be one of:",
+ paste("\"", MODELS, "\"", sep = "", collapse = " ")))
+ if (imod == 11 && variance) {
+ warning("computing variance not available for model BH87")
+ variance <- FALSE
+ }
+ if (gamma && imod %in% c(1, 5:7, 9:17)) {
+ warning(paste("gamma-correction not available for model", model))
+ gamma <- FALSE
+ }
+ if (is.list(x)) x <- as.matrix(x)
+ nms <- dimnames(x)[[1]]
+ n <- dim(x)
+ s <- n[2]
+ n <- n[1]
+
+ if (imod %in% c(4, 6:8)) {
+ BF <- if (is.null(base.freq)) base.freq(x) else base.freq
+ } else BF <- 0
+
+ if (imod %in% 16:17) pairwise.deletion <- TRUE
+
+ if (!pairwise.deletion) {
+ keep <- .C(GlobalDeletionDNA, x, n, s, rep(1L, s))[[4]]
+ x <- x[, as.logical(keep)]
+ s <- dim(x)[2]
+ }
+ Ndist <- if (imod == 11) n*n else n*(n - 1)/2
+ var <- if (variance) double(Ndist) else 0
+ if (!gamma) gamma <- alpha <- 0
+ else {
+ alpha <- gamma
+ gamma <- 1
+ }
+ d <- .C(dist_dna, x, as.integer(n), as.integer(s), imod,
+ double(Ndist), BF, as.integer(pairwise.deletion),
+ as.integer(variance), var, as.integer(gamma),
+ alpha, NAOK = TRUE)
+ if (variance) var <- d[[9]]
+ d <- d[[5]]
+ if (imod == 11) {
+ dim(d) <- c(n, n)
+ dimnames(d) <- list(nms, nms)
+ } else {
+ attr(d, "Size") <- n
+ attr(d, "Labels") <- nms
+ attr(d, "Diag") <- attr(d, "Upper") <- FALSE
+ attr(d, "call") <- match.call()
+ attr(d, "method") <- model
+ class(d) <- "dist"
+ if (as.matrix) d <- as.matrix(d)
+ }
+ if (variance) attr(d, "variance") <- var
+ d
+}
+
+image.DNAbin <- function(x, what, col, bg = "white", xlab = "", ylab = "",
+ show.labels = TRUE, cex.lab = 1, legend = TRUE, ...)
+{
+ what <-
+ if (missing(what)) c("a", "g", "c", "t", "n", "-") else tolower(what)
+ if (missing(col))
+ col <- c("red", "yellow", "green", "blue", "grey", "black")
+ n <- (dx <- dim(x))[1] # number of sequences
+ s <- dx[2] # number of sites
+ y <- integer(N <- length(x))
+ ncl <- length(what)
+ col <- rep(col, length.out = ncl)
+ brks <- 0.5:(ncl + 0.5)
+ sm <- 0L
+ for (i in ncl:1) {
+ k <- ._bs_[._cs_ == what[i]]
+ sel <- which(x == k)
+ if (L <- length(sel)) {
+ y[sel] <- i
+ sm <- sm + L
+ } else {
+ what <- what[-i]
+ col <- col[-i]
+ brks <- brks[-i]
+ }
+ }
+ dim(y) <- dx
+ ## if there's no 0 in y, must drop 'bg' from the cols passed to image:
+ if (sm == N) {
+ leg.co <- co <- col
+ leg.txt <- toupper(what)
+ } else {
+ co <- c(bg, col)
+ leg.txt <- c(toupper(what), "others")
+ leg.co <- c(col, bg)
+ brks <- c(-0.5, brks)
+ }
+ yaxt <- if (show.labels) "n" else "s"
+ image.default(1:s, 1:n, t(y), col = co, xlab = xlab,
+ ylab = ylab, yaxt = yaxt, breaks = brks, ...)
+ if (show.labels)
+ mtext(rownames(x), side = 2, line = 0.1, at = 1:n,
+ cex = cex.lab, adj = 1, las = 1)
+ if (legend) {
+ psr <- par("usr")
+ xx <- psr[2]/2
+ yy <- psr[4] * (0.5 + 0.5/par("plt")[4])
+ legend(xx, yy, legend = leg.txt, pch = 22, pt.bg = leg.co,
+ pt.cex = 2, bty = "n", xjust = 0.5, yjust = 0.5,
+ horiz = TRUE, xpd = TRUE)
+ }
+}
+
+where <- function(x, pattern)
+{
+ pat <- as.DNAbin(strsplit(pattern, NULL)[[1]])
+ p <- as.integer(length(pat))
+
+ foo <- function(x, pat, p) {
+ s <- as.integer(length(x))
+ if (s < p) stop("sequence shorter than the pattern")
+ ans <- .C(C_where, x, pat, s, p, integer(s), 0L, NAOK = TRUE)
+ n <- ans[[6]]
+ if (n) ans[[5]][seq_len(n)] - p + 2L else integer()
+ }
+
+ if (is.list(x)) return(lapply(x, foo, pat = pat, p = p))
+ if (is.matrix(x)) {
+ n <- nrow(x)
+ res <- vector("list", n)
+ for (i in seq_len(n))
+ res[[i]] <- foo(x[i, , drop = TRUE], pat, p)
+ names(res) <- rownames(x)
+ return(res)
+ }
+ foo(x, pat, p) # if x is a vector
+}
diff --git a/R/MPR.R b/R/MPR.R
new file mode 100644
index 0000000..40cc41b
--- /dev/null
+++ b/R/MPR.R
@@ -0,0 +1,68 @@
+## MPR.R (2010-08-10)
+
+## Most Parsimonious Reconstruction
+
+## Copyright 2010 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+MPR <- function(x, phy, outgroup)
+{
+ if (is.rooted(phy))
+ stop("the tree must be unrooted")
+ if (!is.binary.tree(phy))
+ stop("the tree must be fully dichotomous")
+ if (length(outgroup) > 1L)
+ stop("outgroup must be a single tip")
+ if (is.character(outgroup))
+ outgroup <- which(phy$tip.label == outgroup)
+
+ if (!is.null(names(x))) {
+ if (all(names(x) %in% phy$tip.label))
+ x <- x[phy$tip.label]
+ else warning("the names of 'x' and the tip labels of the tree do not match: the former were ignored in the analysis.")
+ }
+
+ n <- length(phy$tip.label)
+ if (is.null(phy$node.label))
+ phy$node.label <- n + 1:(phy$Nnode)
+
+ phy <- drop.tip(root(phy, outgroup), outgroup)
+ n <- n - 1L
+ m <- phy$Nnode
+ phy <- reorder(phy, "postorder")
+
+ root.state <- x[outgroup]
+ I <- as.integer(x[-outgroup])
+ I[n + 1:m] <- NA
+ I <- cbind(I, I) # interval map
+
+ med <- function(x) {
+ i <- length(x)/2
+ sort(x)[c(i, i + 1L)]
+ }
+
+ ## 1st pass
+ s <- seq(from = 1, by = 2, length.out = m)
+ anc <- phy$edge[s, 1]
+ des <- matrix(phy$edge[, 2], ncol = 2, byrow = TRUE)
+ for (i in 1:m) I[anc[i], ] <- med(I[des[i, ], ])
+
+ ## 2nd pass
+ out <- matrix(NA, m, 2)
+ colnames(out) <- c("lower", "upper")
+ ## do the most basal node before looping
+ Iw <- as.vector(I[des[m, ], ]) # interval maps of the descendants
+ out[anc[m] - n, ] <- range(med(c(root.state, root.state, Iw)))
+ for (i in (m - 1):1) {
+ j <- anc[i]
+ Iw <- as.vector(I[des[i, ], ]) # interval maps of the descendants
+ k <- which(phy$edge[, 2] == j) # find the ancestor
+ tmp <- out[phy$edge[k, 1] - n, ]
+ out[j - n, 1] <- min(med(c(tmp[1], tmp[1], Iw)))
+ out[j - n, 2] <- max(med(c(tmp[2], tmp[2], Iw)))
+ }
+ rownames(out) <- phy$node.label
+ out
+}
diff --git a/R/MoranI.R b/R/MoranI.R
new file mode 100644
index 0000000..54297e6
--- /dev/null
+++ b/R/MoranI.R
@@ -0,0 +1,212 @@
+## MoranI.R (2008-01-14)
+
+## Moran's I Autocorrelation Index
+
+## Copyright 2004 Julien Dutheil, 2007-2008 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+## code cleaned-up by EP (Dec. 2007)
+
+Moran.I <- function(x, weight, scaled = FALSE, na.rm = FALSE,
+ alternative = "two.sided")
+{
+ if(dim(weight)[1] != dim(weight)[2])
+ stop("'weight' must be a square matrix")
+ n <- length(x)
+ if(dim(weight)[1] != n)
+ stop("'weight' must have as many rows as observations in 'x'")
+ ## Expected mean:
+ ei <- -1/(n - 1)
+
+ nas <- is.na(x)
+ if (any(nas)) {
+ if (na.rm) {
+ x <- x[!nas]
+ n <- length(x)
+ weight <- weight[!nas, !nas]
+ } else {
+ warning("'x' has missing values: maybe you wanted to set na.rm=TRUE?")
+ return(list(observed = NA, expected = ei, sd = NA, p.value = NA))
+ }
+ }
+
+ ## normaling the weights:
+ ## Note that we normalize after possibly removing the
+ ## missing data.
+ ROWSUM <- rowSums(weight)
+ ## the following is useful if an observation has no "neighbour":
+ ROWSUM[ROWSUM == 0] <- 1
+ weight <- weight/ROWSUM # ROWSUM is properly recycled
+
+ s <- sum(weight)
+ m <- mean(x)
+ y <- x - m # centre the x's
+ cv <- sum(weight * y %o% y)
+ v <- sum(y^2)
+ obs <- (n/s) * (cv/v)
+ ## Scaling:
+ if (scaled) {
+ i.max <- (n/s) * (sd(rowSums(weight) * y)/sqrt(v/(n - 1)))
+ obs <- obs/i.max
+ }
+ ## Expected sd:
+ S1 <- 0.5 * sum((weight + t(weight))^2)
+ S2 <- sum((apply(weight, 1, sum) + apply(weight, 2, sum))^2)
+ ## the above is the same than:
+ ##S2 <- 0
+ ##for (i in 1:n)
+ ## S2 <- S2 + (sum(weight[i, ]) + sum(weight[, i]))^2
+
+ s.sq <- s^2
+ k <- (sum(y^4)/n) / (v/n)^2
+ sdi <- sqrt((n*((n^2 - 3*n + 3)*S1 - n*S2 + 3*s.sq) -
+ k*(n*(n - 1)*S1 - 2*n*S2 + 6*s.sq))/
+ ((n - 1)*(n - 2)*(n - 3)*s.sq) - 1/((n - 1)^2))
+
+ alternative <- match.arg(alternative, c("two.sided", "less", "greater"))
+ pv <- pnorm(obs, mean = ei, sd = sdi)
+ if (alternative == "two.sided")
+ pv <- if (obs <= ei) 2*pv else 2*(1 - pv)
+ if (alternative == "greater") pv <- 1 - pv
+ list(observed = obs, expected = ei, sd = sdi, p.value = pv)
+}
+
+weight.taxo <- function(x)
+{
+ d <- outer(x, x, "==")
+ diag(d) <- 0 # implicitly converts 'd' into numeric
+ d
+}
+
+weight.taxo2 <- function(x, y)
+{
+ d <- outer(x, x, "==") & outer(y, y, "!=")
+ diag(d) <- 0
+ d
+}
+
+correlogram.formula <- function(formula, data = NULL, use = "all.obs")
+{
+ err <- 'formula must be of the form "y1+...+yn ~ x1/x2/../xn"'
+ use <- match.arg(use, c("all.obs", "complete.obs", "pairwise.complete.obs"))
+ if (formula[[1]] != "~") stop(err)
+
+ lhs <- formula[[2]]
+ y.nms <- if (length(lhs) > 1)
+ unlist(strsplit(as.character(as.expression(lhs)), " \\+ "))
+ else as.character(as.expression(lhs))
+
+ rhs <- formula[[3]]
+ gr.nms <- if (length(rhs) > 1)
+ rev(unlist(strsplit(as.character(as.expression(rhs)), "/")))
+ else as.character(as.expression(rhs))
+
+ if (is.null(data)) {
+ ## we 'get' the variables in the .GlobalEnv:
+ y <- as.data.frame(sapply(y.nms, get))
+ gr <- as.data.frame(sapply(gr.nms, get))
+ } else {
+ y <- data[y.nms]
+ gr <- data[gr.nms]
+ }
+ if (use == "all.obs") {
+ na.fail(y)
+ na.fail(gr)
+ }
+ if (use == "complete.obs") {
+ sel <- complete.cases(y, gr)
+ y <- y[sel]
+ gr <- gr[sel]
+ }
+ na.rm <- use == "pairwise.complete.obs"
+
+ foo <- function(x, gr, na.rm) {
+ res <- data.frame(obs = NA, p.values = NA, labels = colnames(gr))
+ for (i in 1:length(gr)) {
+ sel <- if (na.rm) !is.na(x) & !is.na(gr[, i]) else TRUE
+ xx <- x[sel]
+ g <- gr[sel, i]
+ w <- if (i > 1) weight.taxo2(g, gr[sel, i - 1]) else weight.taxo(g)
+ o <- Moran.I(xx, w, scaled = TRUE)
+ res[i, 1] <- o$observed
+ res[i, 2] <- o$p.value
+ }
+ ## We need to specify the two classes; if we specify
+ ## only "correlogram", 'res' is coerced as a list
+ ## (data frames are of class "data.frame" and mode "list")
+ structure(res, class = c("correlogram", "data.frame"))
+ }
+
+ if (length(y) == 1) foo(y[[1]], gr, na.rm)
+ else structure(lapply(y, foo, gr = gr, na.rm = na.rm),
+ names = y.nms, class = "correlogramList")
+}
+
+plot.correlogram <-
+ function(x, legend = TRUE, test.level = 0.05,
+ col = c("grey", "red"), type = "b", xlab = "",
+ ylab = "Moran's I", pch = 21, cex = 2, ...)
+{
+ BG <- col[(x$p.values < test.level) + 1]
+ if (pch > 20 && pch < 26) {
+ bg <- col
+ col <- CO <- "black"
+ } else {
+ CO <- BG
+ BG <- bg <- NULL
+ }
+ plot(1:length(x$obs), x$obs, type = type, xaxt = "n", xlab = xlab,
+ ylab = ylab, col = CO, bg = BG, pch = pch, cex = cex, ...)
+ axis(1, at = 1:length(x$obs), labels = x$labels)
+ if (legend)
+ legend("top", legend = paste(c("P >=", "P <"), test.level),
+ pch = pch, col = col, pt.bg = bg, pt.cex = cex, horiz = TRUE)
+}
+
+plot.correlogramList <-
+ function(x, lattice = TRUE, legend = TRUE,
+ test.level = 0.05, col = c("grey", "red"),
+ xlab = "", ylab = "Moran's I",
+ type = "b", pch = 21, cex = 2, ...)
+{
+ n <- length(x)
+ obs <- unlist(lapply(x, "[[", "obs"))
+ pval <- unlist(lapply(x, "[[", "p.values"))
+ gr <- factor(unlist(lapply(x, "[[", "labels")),
+ ordered = TRUE, levels = x[[1]]$labels)
+ vars <- gl(n, nlevels(gr), labels = names(x))
+ BG <- col[(pval < test.level) + 1]
+ if (lattice) {
+ ## trellis.par.set(list(plot.symbol=list(pch=19)))
+ xyplot(obs ~ gr | vars, xlab = xlab, ylab = ylab,
+ panel = function(x, y) {
+ panel.lines(x, y, lty = 2)
+ panel.points(x, y, cex = cex, pch = 19, col = BG)
+ ##lattice::panel.abline(h = 0, lty = 3)
+ })
+ } else {
+ if (pch > 20 && pch < 26) {
+ bg <- col
+ CO <- rep("black", length(obs))
+ col <- "black"
+ } else {
+ CO <- BG
+ BG <- bg <- NULL
+ }
+ plot(as.numeric(gr), obs, type = "n", xlab = xlab,
+ ylab = ylab, xaxt = "n")
+ for (i in 1:n) {
+ sel <- as.numeric(vars) == i
+ lines(as.numeric(gr[sel]), obs[sel], type = type, lty = i,
+ col = CO[sel], bg = BG[sel], pch = pch, cex = cex, ...)
+ }
+ axis(1, at = 1:length(x[[i]]$obs), labels = x[[i]]$labels)
+ if (legend) {
+ legend("topright", legend = names(x), lty = 1:n, bty = "n")
+ legend("top", legend = paste(c("P >=", "P <"), test.level),
+ pch = pch, col = col, pt.bg = bg, pt.cex = cex, horiz = TRUE)
+ }
+ }
+}
diff --git a/R/PGLS.R b/R/PGLS.R
new file mode 100644
index 0000000..ed7bc2b
--- /dev/null
+++ b/R/PGLS.R
@@ -0,0 +1,282 @@
+## PGLS.R (2012-02-09)
+
+## Phylogenetic Generalized Least Squares
+
+## Copyright 2004 Julien Dutheil, and 2006-2012 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+corBrownian <- function(value = 1, phy, form = ~1)
+{
+ if (!inherits(phy, "phylo"))
+ stop('object "phy" is not of class "phylo"')
+ attr(value, "formula") <- form
+ attr(value, "fixed") <- TRUE
+ attr(value, "tree") <- phy
+ class(value) <- c("corBrownian", "corPhyl", "corStruct")
+ value
+}
+
+corMartins <- function(value, phy, form = ~1, fixed = FALSE)
+{
+ if (length(value) > 1)
+ stop("only one parameter is allowed")
+ if (value < 0) stop("the parameter alpha must be positive")
+ if (!inherits(phy, "phylo"))
+ stop('object "phy" is not of class "phylo"')
+ attr(value, "formula") <- form
+ attr(value, "fixed") <- fixed
+ attr(value, "tree") <- phy
+ class(value) <- c("corMartins", "corPhyl", "corStruct")
+ value
+}
+
+corGrafen <- function(value, phy, form = ~1, fixed = FALSE)
+{
+ if (length(value) > 1)
+ stop("only one parameter is allowed")
+ if (value < 0) stop("parameter rho must be positive")
+ value <- log(value) # Optimization under constraint, use exponential transform.
+ if (!inherits(phy, "phylo"))
+ stop('object "phy" is not of class "phylo"')
+ attr(value, "formula") <- form
+ attr(value, "fixed") <- fixed
+ attr(value, "tree") <- phy
+ class(value) <- c("corGrafen", "corPhyl", "corStruct")
+ value
+}
+
+Initialize.corPhyl <- function(object, data, ...)
+{
+ ## The same as in Initialize corStruct:
+ form <- formula(object)
+ ## Obtaining the group information, if any
+ if (!is.null(getGroupsFormula(form))) {
+ attr(object, "groups") <- getGroups(object, form, data = data)
+ attr(object, "Dim") <- Dim(object, attr(object, "groups"))
+ } else { # no groups
+ attr(object, "Dim") <- Dim(object, as.factor(rep(1, nrow(data))))
+ }
+ ## Obtaining the covariate(s)
+ attr(object, "covariate") <- getCovariate(object, data = data)
+
+ ## Specific to corPhyl:
+ phy <- attr(object, "tree")
+ if (is.null(data)) data <- parent.frame()
+ ## Added by EP 29 May 2006:
+ if (nrow(data) != length(phy$tip.label))
+ stop("number of observations and number of tips in the tree are not equal.")
+ ## END
+ if (is.null(rownames(data))) {
+ warning("No rownames supplied in data frame, data taken to be in the same order than in tree")
+ attr(object, "index") <- 1:dim(data)[1]
+ } else {
+ index <- match(rownames(data), phy$tip.label)
+ if (any(is.na(index))) {
+ warning("Rownames in data frame do not match tree tip names; data taken to be in the same order as in tree")
+ attr(object, "index") <- 1:dim(data)[1]
+ } else {
+ attr(object, "index") <- index
+ }
+ }
+ object
+}
+
+corMatrix.corBrownian <-
+ function(object, covariate = getCovariate(object), corr = TRUE, ...)
+{
+ if (!("corBrownian" %in% class(object)))
+ stop('object is not of class "corBrownian"')
+ if (!any(attr(object, "index")))
+ stop("object has not been initialized.")
+ tree <- attr(object, "tree")
+ mat <- vcv.phylo(tree, corr = corr)
+ n <- dim(mat)[1]
+ ## reorder matrix:
+ index <- attr(object, "index")
+ mat[index, index]
+}
+
+corMatrix.corMartins <-
+ function(object, covariate = getCovariate(object), corr = TRUE, ...)
+{
+ if (!("corMartins" %in% class(object)))
+ stop('object is not of class "corMartins"')
+ if (!any(attr(object, "index")))
+ stop("object has not been initialized.")
+ tree <- attr(object, "tree")
+ dist <- cophenetic.phylo(tree)
+ mat <- exp(-object[1] * dist)
+ if (corr) mat <- cov2cor(mat)
+ n <- dim(mat)[1]
+ ## reorder matrix:
+ index <- attr(object, "index")
+ mat[index, index]
+}
+
+corMatrix.corGrafen <-
+ function(object, covariate = getCovariate(object), corr = TRUE, ...)
+{
+ if (!("corGrafen" %in% class(object)))
+ stop('object is not of class "corGrafen"')
+ if (!any(attr(object, "index")))
+ stop("object has not been initialized.")
+ tree <- compute.brlen(attr(object, "tree"),
+ method = "Grafen", power = exp(object[1]))
+ mat <- vcv.phylo(tree, corr = corr)
+ n <- dim(mat)[1]
+ ## reorder matrix:
+ index <- attr(object, "index")
+ mat[index, index]
+}
+
+coef.corBrownian <- function(object, unconstrained = TRUE, ...)
+{
+ if (!("corBrownian" %in% class(object)))
+ stop('object is not of class "corBrownian"')
+ numeric(0)
+}
+
+coef.corMartins <- function(object, unconstrained = TRUE, ...)
+{
+ if (!("corMartins" %in% class(object)))
+ stop('object is not of class "corMartins"')
+ if (unconstrained) {
+ if (attr(object, "fixed")) {
+ return(numeric(0))
+ } else {
+ return(as.vector(object))
+ }
+ }
+ aux <- as.vector(object)
+ names(aux) <- "alpha"
+ aux
+}
+
+coef.corGrafen <- function(object, unconstrained = TRUE, ...)
+{
+ if (!("corGrafen" %in% class(object)))
+ stop('object is not of class "corGrafen"')
+ if (unconstrained) {
+ if (attr(object, "fixed")) {
+ return(numeric(0))
+ } else {
+ return(as.vector(object))
+ }
+ }
+ aux <- exp(as.vector(object))
+ names(aux) <- "rho"
+ aux
+}
+
+### removed node.sons() and node.leafnumber() (2006-10-12)
+
+### changed by EP (2006-10-12):
+
+compute.brlen <- function(phy, method = "Grafen", power = 1, ...)
+{
+ if (!inherits(phy, "phylo"))
+ stop('object "phy" is not of class "phylo"')
+ Ntip <- length(phy$tip.label)
+ Nnode <- phy$Nnode
+ Nedge <- dim(phy$edge)[1]
+ if (is.numeric(method)) {
+ phy$edge.length <- rep(method, length.out = Nedge)
+ return(phy)
+ }
+ if (is.function(method)) {
+ phy$edge.length <- method(Nedge, ...)
+ return(phy)
+ }
+ if (is.character(method)) { # == "Grafen"
+ tr <- reorder(phy, "postorder")
+ xx <- .C(node_depth, as.integer(Ntip), as.integer(Nnode),
+ as.integer(tr$edge[, 1]), as.integer(tr$edge[, 2]),
+ as.integer(Nedge), double(Ntip + Nnode), 1L)[[6]] - 1
+ m <- Ntip - 1
+ phy$edge.length <-
+ (xx[phy$edge[, 1]]/m)^power - (xx[phy$edge[, 2]]/m)^power
+ return(phy)
+ }
+}
+
+## by EP:
+
+corPagel <- function(value, phy, form = ~1, fixed = FALSE)
+{
+ if (value < 0 || value > 1)
+ stop("the value of lambda must be between 0 and 1.")
+ if (!inherits(phy, "phylo"))
+ stop('object "phy" is not of class "phylo"')
+ attr(value, "formula") <- form
+ attr(value, "fixed") <- fixed
+ attr(value, "tree") <- phy
+ class(value) <- c("corPagel", "corPhyl", "corStruct")
+ value
+}
+
+corMatrix.corPagel <-
+ function(object, covariate = getCovariate(object), corr = TRUE, ...)
+{
+ if (!any(attr(object, "index")))
+ stop("object has not been initialized")
+ mat <- vcv.phylo(attr(object, "tree"), corr = corr)
+ index <- attr(object, "index")
+ mat <- mat[index, index]
+ tmp <- diag(mat)
+ mat <- object[1]*mat
+ diag(mat) <- tmp
+ mat
+}
+
+coef.corPagel <- function(object, unconstrained = TRUE, ...)
+{
+ if (unconstrained) {
+ if (attr(object, "fixed")) return(numeric(0))
+ else return(object[1])
+ }
+ aux <- object[1]
+ names(aux) <- "lambda"
+ aux
+}
+
+corBlomberg <- function(value, phy, form = ~1, fixed = FALSE)
+{
+ if (value <= 0)
+ stop("the value of g must be greater than 0.")
+ if (!inherits(phy, "phylo"))
+ stop('object "phy" is not of class "phylo"')
+ attr(value, "formula") <- form
+ attr(value, "fixed") <- fixed
+ attr(value, "tree") <- phy
+ class(value) <- c("corBlomberg", "corPhyl", "corStruct")
+ value
+}
+
+corMatrix.corBlomberg <-
+ function(object, covariate = getCovariate(object), corr = TRUE, ...)
+{
+ index <- attr(object, "index")
+ if (is.null(index))
+ stop("object has not been initialized")
+ if (object[1] <= 0)
+ stop("the optimization has reached a value <= 0 for parameter 'g':
+probably need to set 'fixed = TRUE' in corBlomberg().")
+ phy <- attr(object, "tree")
+ d <- (dist.nodes(phy)[length(phy$tip.label) + 1, ])^(1/object[1])
+ phy$edge.length <- d[phy$edge[, 2]] - d[phy$edge[, 1]]
+ mat <- vcv.phylo(phy, corr = corr)
+ mat[index, index]
+}
+
+coef.corBlomberg <- function(object, unconstrained = TRUE, ...)
+{
+ if (unconstrained) {
+ if (attr(object, "fixed")) return(numeric(0))
+ else return(object[1])
+ }
+ aux <- object[1]
+ names(aux) <- "g"
+ aux
+}
diff --git a/R/SDM.R b/R/SDM.R
new file mode 100644
index 0000000..d2a6686
--- /dev/null
+++ b/R/SDM.R
@@ -0,0 +1,207 @@
+## SDM.R (2012-04-02)
+
+## Construction of Consensus Distance Matrix With SDM
+
+## Copyright 2011-2012 Andrei-Alin Popescu
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+SDM <- function(...)
+{
+ st <- list(...) # first half contains matrices, second half s_p
+ k <- length(st)/2
+ ONEtoK <- seq_len(k)
+
+ ## make sure we have only matrices:
+ for (i in ONEtoK) st[[i]] <- as.matrix(st[[i]])
+
+ ## store the rownames of each matrix in a list because they are often called:
+ ROWNAMES <- lapply(st[ONEtoK], rownames)
+
+ ## the number of rows of each matrix:
+ NROWS <- sapply(ROWNAMES, length)
+ tot <- sum(NROWS)
+
+ labels <- unique(unlist(ROWNAMES))
+ sp <- unlist(st[k + ONEtoK])
+
+ astart <- numeric(tot) # start of aip, astart[p] is start of aip
+ astart[1] <- k
+ for (i in 2:k)
+ astart[i] <- astart[i - 1] + NROWS[i - 1]
+
+ ## apparently erased by the operation below so no need to initialize:
+ ## a <- mat.or.vec(1, k + tot + k + length(labels))
+
+ ## first k are alphas, subsequent ones aip
+ ## each matrix p starting at astart[p], next are
+ ## Lagrange multipliers, miu, niu, lambda in that order
+ n <- length(labels)
+ miustart <- k + tot
+ niustart <- miustart + n
+ lambstart <- niustart + k - 1
+
+ X <- matrix(0, n, n, dimnames = list(labels, labels))
+ V <- w <- X
+
+ tmp <- 2 * k + tot + n
+ col <- numeric(tmp) # free terms of system
+
+ for (i in 1:(n - 1)) {
+ for (j in (i + 1):n) {
+ for (p in ONEtoK) {
+ ## d <- st[[p]] # not needed anymore
+ if (is.element(labels[i], ROWNAMES[[p]]) && is.element(labels[j], ROWNAMES[[p]])) {
+ w[i, j] <- w[j, i] <- w[i, j] + sp[p]
+ }
+ }
+ }
+ }
+
+ ONEtoN <- seq_len(n)
+
+ Q <- matrix(0, tmp, tmp)
+ ## first decompose first sum in paper
+ for (p in ONEtoK) {
+ d_p <- st[[p]]
+ for (l in ONEtoK) { # first compute coefficients of alphas
+ d <- st[[l]]
+ sum <- 0
+ dijp <- -1
+ if (l == p) { # calculate alpha_p
+ for (i in ONEtoN) {
+ for (j in ONEtoN) { # check if {i,j}\subset L_l
+ if (i == j) next # make sure i != j
+ ## d <- st[[l]] # <- moved-up
+ pos <- match(labels[c(i, j)], ROWNAMES[[l]]) # <- returns NA if not in this matrix
+ if (all(!is.na(pos))) {
+ ipos <- pos[1L]
+ jpos <- pos[2L]
+ dij <- d[ipos, jpos]
+ sum <- sum + dij * dij - sp[l] * dij * dij / w[i,j]
+ tmp2 <- dij - sp[l] * dij / w[i,j]
+ Q[p, astart[l] + ipos] <- Q[p, astart[l] + ipos] + tmp2
+ Q[p, astart[l] + jpos] <- Q[p, astart[l] + jpos] + tmp2
+ }
+ }
+ }
+ } else {
+ for (i in ONEtoN) {
+ for (j in ONEtoN) { # check if {i,j}\subset L_l
+ if (i == j) next
+ ## d <- st[[l]] # <- moved-up
+ pos <- match(labels[c(i, j)], ROWNAMES[[l]])
+ posp <- match(labels[c(i, j)], ROWNAMES[[p]])
+ if (all(!is.na(pos)) && all(!is.na(posp))) {
+ ipos <- pos[1L]
+ jpos <- pos[2L]
+ dij <- d[ipos, jpos]
+ dijp <- d_p[posp[1L], posp[2L]]
+ sum <- sum - sp[l] * dij * dijp / w[i, j]
+ tmp2 <- sp[l] * dijp / w[i, j]
+ Q[p,astart[l] + ipos] <- Q[p, astart[l] + ipos] - tmp2
+ Q[p,astart[l] + jpos] <- Q[p, astart[l] + jpos] - tmp2
+ }
+ }
+ }
+ }
+ Q[p, l] <- sum
+ }
+ Q[p, lambstart + 1] <- 1
+ }
+
+ r <- k
+
+ for (p in ONEtoK) {
+ dp <- st[[p]]
+ for (i in ONEtoN) {
+ if (is.element(labels[i], ROWNAMES[[p]])) {
+ r <- r + 1
+ for (l in ONEtoK) {
+ d <- st[[l]]
+ if (l == p) {
+ ipos <- match(labels[i], ROWNAMES[[p]])
+ for (j in ONEtoN) {
+ if (i == j) next
+ jpos <- match(labels[j], ROWNAMES[[p]])
+ if (!is.na(jpos)) {
+ dij <- d[ipos, jpos]
+ Q[r, l] <- Q[r, l] + dij - sp[l] * dij / w[i, j]
+ tmp2 <- 1 - sp[l] / w[i, j]
+ Q[r, astart[l] + ipos] <- Q[r, astart[l] + ipos] + tmp2
+ Q[r, astart[l] + jpos] <- Q[r, astart[l] + jpos] + tmp2
+ }
+ }
+ } else {
+ for (j in ONEtoN) {
+ if (i == j) next
+ if (!is.element(labels[j], rownames(dp))) next
+ pos <- match(labels[c(i, j)], ROWNAMES[[l]])
+ if (all(!is.na(pos))) {
+ ipos <- pos[1L]
+ jpos <- pos[2L]
+ dij <- d[ipos, jpos]
+ Q[r, l] <- Q[r, l] - sp[l] * dij / w[i, j]
+ tmp2 <- sp[l]/w[i, j]
+ Q[r, astart[l] + ipos] <- Q[r, astart[l] + ipos] - tmp2
+ Q[r, astart[l] + jpos] <- Q[r, astart[l] + jpos] - tmp2
+ }
+ }
+ }
+ }
+ if (p < k) Q[r, ] <- Q[r, ] * sp[p]
+ Q[r, miustart + i] <- 1
+ if (p < k) Q[r, niustart + p] <- 1
+ }
+ }
+ }
+
+ r <- r + 1
+ col[r] <- k
+ Q[r, ONEtoK] <- 1
+ ## for (i in 1:k) Q[r, i] <- 1
+
+ for (i in ONEtoN) {
+ r <- r + 1
+ for (p in ONEtoK) {
+ ## d <- st[[p]] # not needed
+ ipos <- match(labels[i], ROWNAMES[[p]])
+ if (!is.na(ipos)) Q[r, astart[p] + ipos] <- 1
+ }
+ }
+
+ for (p in 1:(k - 1)) {
+ r <- r + 1
+ for (i in ONEtoN) {
+ ## d <- st[[p]]
+ ipos <- match(labels[i], ROWNAMES[[p]])
+ if (!is.na(ipos)) Q[r, astart[p] + ipos] <- 1
+ }
+ }
+ a <- solve(Q, col, 1e-19)
+ for (i in ONEtoN) {
+ for (j in ONEtoN) {
+ if (i == j) {
+ X[i, j] <- V[i, j] <- 0
+ next
+ }
+ sum <- 0
+ sumv <- 0
+ for (p in ONEtoK) {
+ d <- st[[p]]
+ pos <- match(labels[c(i, j)], ROWNAMES[[p]])
+ if (all(!is.na(pos))) {
+ ipos <- pos[1L]
+ jpos <- pos[2L]
+ dij <- d[ipos, jpos]
+ sum <- sum + sp[p] * (a[p] * dij + a[astart[p] + ipos] + a[astart[p] + jpos])
+ sumv <- sumv + sp[p] * (a[p] * dij)^2
+ }
+ }
+ X[i, j] <- sum / w[i, j]
+ V[i, j] <- sumv / (w[i, j])^2
+ }
+ }
+ list(X, V)
+}
diff --git a/R/SlowinskiGuyer.R b/R/SlowinskiGuyer.R
new file mode 100644
index 0000000..b0fc956
--- /dev/null
+++ b/R/SlowinskiGuyer.R
@@ -0,0 +1,101 @@
+## SlowinskiGuyer.R (2011-05-05)
+
+## Tests of Diversification Shifts with Sister-Clades
+
+## Copyright 2011 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+slowinskiguyer.test <- function(x, detail = FALSE)
+{
+ r <- x[, 1]
+ n <- x[, 1] + x[, 2]
+ pp <- (n - r)/(n - 1)
+ chi <- -2 * sum(log(pp))
+ df <- as.integer(2 * length(pp))
+ pval <- pchisq(chi, df, lower.tail = FALSE)
+ res <- data.frame("chisq" = chi, "df" = df, "P.val" = pval, row.names = "")
+ if (detail)
+ res <- list(res, individual_Pvalues = pp)
+ res
+}
+
+mcconwaysims.test <- function(x)
+{
+ LRTp <- function(x) {
+ f <- function(x) ifelse(x == 0, 0, x * log(x))
+ n1 <- x[1]
+ n2 <- x[2]
+ 1.629*(f(n1 - 1) - f(n1) + f(n2 - 1) - f(n2) - f(2) -
+ f(n1 + n2 - 2) + f(n1 + n2))
+ }
+ chi <- sum(apply(x, 1, LRTp))
+ pval <- pchisq(chi, df <- nrow(x), lower.tail = FALSE)
+ data.frame("chisq" = chi, "df" = df, "P.val" = pval, row.names = "")
+}
+
+richness.yule.test <- function(x, t)
+{
+ n1 <- x[, 1]
+ n2 <- x[, 2]
+ n <- c(n1, n2)
+ tb <- c(t, t)
+
+ ## taken from /home/paradis/data/Projets/FISHLOSS/BDfit.R:
+ .PrNt.Yule <- function(N, age, birth) {
+ tmp <- exp(-birth * age)
+ tmp * (1 - tmp)^(N - 1)
+ }
+
+ minusloglik0 <- function(l)
+ -sum(log(.PrNt.Yule(n, tb, l)))
+
+ minusloglika <- function(l)
+ -sum(log(.PrNt.Yule(n1, t, l[1]))) - sum(log(.PrNt.Yule(n2, t, l[2])))
+
+ out0 <- nlminb(0.01, minusloglik0, lower = 0, upper = 1)
+ outa <- nlminb(rep(out0$par, 2), minusloglika,
+ lower = c(0, 0), upper = c(1, 1))
+ chi <- 2 * (out0$objective - outa$objective)
+ pval <- pchisq(chi, 1, lower.tail = FALSE)
+ data.frame("chisq" = chi, "df" = 1, "P.val" = pval, row.names = "")
+}
+
+diversity.contrast.test <-
+ function(x, method = "ratiolog", alternative = "two.sided", nrep = 0, ...)
+{
+ method <- match.arg(method, c("ratiolog", "proportion",
+ "difference", "logratio"))
+ alternative <- match.arg(alternative, c("two.sided", "less", "greater"))
+
+ minmax <- t(apply(x, 1, sort)) # sort all rows
+ DIFF <- x[, 1] - x[, 2]
+ SIGN <- sign(DIFF)
+
+ CONTRAST <- switch(method,
+ "ratiolog" = {
+ if (any(minmax == 1))
+ minmax <- minmax + 1 # prevent division by 0
+ ## Note: if min = max, no need to set the contrast
+ ## to zero since this is done with sign()
+ log(minmax[, 2]) / log(minmax[, 1])
+ },
+ "proportion" = minmax[, 2] / (minmax[, 2] + minmax[, 1]),
+ "difference" = abs(DIFF),
+ "logratio" = log(minmax[, 1] / minmax[, 2]))
+
+ y <- SIGN * CONTRAST # the signed contrasts
+
+ if (nrep) {
+ n <- length(SIGN)
+ RND <-
+ replicate(nrep,
+ sum(sample(c(-1, 1), size = n, replace = TRUE) * CONTRAST))
+ cases <- switch(alternative,
+ "two.sided" = sum(abs(RND) > sum(y)),
+ "less" = sum(RND < sum(y)),
+ "greater" = sum(RND > sum(y)))
+ cases/nrep
+ } else wilcox.test(x = y, alternative = alternative, ...)$p.value
+}
diff --git a/R/ace.R b/R/ace.R
new file mode 100644
index 0000000..e2b8c8f
--- /dev/null
+++ b/R/ace.R
@@ -0,0 +1,342 @@
+## ace.R (2013-08-14)
+
+## Ancestral Character Estimation
+
+## Copyright 2005-2013 Emmanuel Paradis and Ben Bolker
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+.getSEs <- function(out)
+{
+ h <- out$hessian
+ if (any(diag(h) == 0)) {
+ warning("The likelihood gradient seems flat in at least one dimension (gradient null):\ncannot compute the standard-errors of the transition rates.\n")
+ se <- rep(NaN, nrow(h))
+ } else {
+ se <- sqrt(diag(solve(h)))
+ }
+ se
+}
+
+ace <-
+ function(x, phy, type = "continuous",
+ method = if (type == "continuous") "REML" else "ML",
+ CI = TRUE, model = if (type == "continuous") "BM" else "ER",
+ scaled = TRUE, kappa = 1, corStruct = NULL, ip = 0.1,
+ use.expm = FALSE, use.eigen = TRUE)
+{
+ if (!inherits(phy, "phylo"))
+ stop('object "phy" is not of class "phylo"')
+ if (is.null(phy$edge.length))
+ stop("tree has no branch lengths")
+ type <- match.arg(type, c("continuous", "discrete"))
+ nb.tip <- length(phy$tip.label)
+ nb.node <- phy$Nnode
+ if (nb.node != nb.tip - 1)
+ stop('"phy" is not rooted AND fully dichotomous.')
+ if (length(x) != nb.tip)
+ stop("length of phenotypic and of phylogenetic data do not match.")
+ if (!is.null(names(x))) {
+ if(all(names(x) %in% phy$tip.label))
+ x <- x[phy$tip.label]
+ else warning("the names of 'x' and the tip labels of the tree do not match: the former were ignored in the analysis.")
+ }
+ obj <- list()
+ if (kappa != 1) phy$edge.length <- phy$edge.length^kappa
+ if (type == "continuous") {
+ switch(method, "REML" = {
+ minusLogLik <- function(sig2) {
+ if (sig2 < 0) return(1e100)
+ V <- sig2 * vcv(phy)
+ ## next three lines borrowed from dmvnorm() in 'mvtnorm'
+ distval <- mahalanobis(x, center = mu, cov = V)
+ logdet <- sum(log(eigen(V, symmetric = TRUE, only.values = TRUE)$values))
+ (nb.tip * log(2 * pi) + logdet + distval)/2
+ }
+ mu <- rep(ace(x, phy, method="pic")$ace[1], nb.tip)
+ out <- nlm(minusLogLik, 1, hessian = TRUE)
+ sigma2 <- out$estimate
+ se_sgi2 <- sqrt(1/out$hessian)
+ tip <- phy$edge[, 2] <= nb.tip
+ minus.REML.BM <- function(p) {
+ x1 <- p[phy$edge[, 1] - nb.tip]
+ x2 <- numeric(length(x1))
+ x2[tip] <- x[phy$edge[tip, 2]]
+ x2[!tip] <- p[phy$edge[!tip, 2] - nb.tip]
+ -(-sum((x1 - x2)^2/phy$edge.length)/(2 * sigma2) -
+ nb.node * log(sigma2))
+ }
+ out <- nlm(function(p) minus.REML.BM(p),
+ p = rep(mu[1], nb.node), hessian = TRUE)
+ obj$resloglik <- -out$minimum
+ obj$ace <- out$estimate
+ names(obj$ace) <- nb.tip + 1:nb.node
+ obj$sigma2 <- c(sigma2, se_sgi2)
+ if (CI) {
+ se <- .getSEs(out)
+ tmp <- se * qt(0.025, nb.node)
+ obj$CI95 <- cbind(obj$ace + tmp, obj$ace - tmp)
+ }
+ }, "pic" = {
+ if (model != "BM")
+ stop('the "pic" method can be used only with model = "BM".')
+ ## See pic.R for some annotations.
+ phy <- reorder(phy, "postorder")
+ phenotype <- numeric(nb.tip + nb.node)
+ phenotype[1:nb.tip] <- if (is.null(names(x))) x else x[phy$tip.label]
+ contr <- var.con <- numeric(nb.node)
+ ans <- .C(C_pic, as.integer(nb.tip), as.integer(nb.node),
+ as.integer(phy$edge[, 1]), as.integer(phy$edge[, 2]),
+ as.double(phy$edge.length), as.double(phenotype),
+ as.double(contr), as.double(var.con),
+ as.integer(CI), as.integer(scaled))
+ obj$ace <- ans[[6]][-(1:nb.tip)]
+ names(obj$ace) <- nb.tip + 1:nb.node
+ if (CI) {
+ se <- sqrt(ans[[8]])
+ tmp <- se * qnorm(0.025)
+ obj$CI95 <- cbind(obj$ace + tmp, obj$ace - tmp)
+ }
+ }, "ML" = {
+ if (model == "BM") {
+ tip <- phy$edge[, 2] <= nb.tip
+ dev.BM <- function(p) {
+ if (p[1] < 0) return(1e100) # in case sigma^2 is negative
+ x1 <- p[-1][phy$edge[, 1] - nb.tip]
+ x2 <- numeric(length(x1))
+ x2[tip] <- x[phy$edge[tip, 2]]
+ x2[!tip] <- p[-1][phy$edge[!tip, 2] - nb.tip]
+ -2 * (-sum((x1 - x2)^2/phy$edge.length)/(2*p[1]) -
+ nb.node * log(p[1]))
+ }
+ out <- nlm(function(p) dev.BM(p),
+ p = c(1, rep(mean(x), nb.node)), hessian = TRUE)
+ obj$loglik <- -out$minimum / 2
+ obj$ace <- out$estimate[-1]
+ names(obj$ace) <- (nb.tip + 1):(nb.tip + nb.node)
+ se <- .getSEs(out)
+ obj$sigma2 <- c(out$estimate[1], se[1])
+ if (CI) {
+ tmp <- se[-1] * qt(0.025, nb.node)
+ obj$CI95 <- cbind(obj$ace + tmp, obj$ace - tmp)
+ }
+ }
+ }, "GLS" = {
+ if (is.null(corStruct))
+ stop('you must give a correlation structure if method = "GLS".')
+ if (class(corStruct)[1] == "corMartins")
+ M <- corStruct[1] * dist.nodes(phy)
+ if (class(corStruct)[1] == "corGrafen")
+ phy <- compute.brlen(attr(corStruct, "tree"),
+ method = "Grafen",
+ power = exp(corStruct[1]))
+ if (class(corStruct)[1] %in% c("corBrownian", "corGrafen")) {
+ dis <- dist.nodes(attr(corStruct, "tree"))
+ MRCA <- mrca(attr(corStruct, "tree"), full = TRUE)
+ M <- dis[as.character(nb.tip + 1), MRCA]
+ dim(M) <- rep(sqrt(length(M)), 2)
+ }
+ varAY <- M[-(1:nb.tip), 1:nb.tip]
+ varA <- M[-(1:nb.tip), -(1:nb.tip)]
+ V <- corMatrix(Initialize(corStruct, data.frame(x)),
+ corr = FALSE)
+ invV <- solve(V)
+ o <- gls(x ~ 1, data.frame(x), correlation = corStruct)
+ GM <- o$coefficients
+ obj$ace <- drop(varAY %*% invV %*% (x - GM) + GM)
+ names(obj$ace) <- (nb.tip + 1):(nb.tip + nb.node)
+ if (CI) {
+ se <- sqrt((varA - varAY %*% invV %*% t(varAY))[cbind(1:nb.node, 1:nb.node)])
+ tmp <- se * qnorm(0.025)
+ obj$CI95 <- cbind(obj$ace + tmp, obj$ace - tmp)
+ }
+ })
+ } else { # type == "discrete"
+ if (method != "ML")
+ stop("only ML estimation is possible for discrete characters.")
+ if (any(phy$edge.length <= 0))
+ stop("some branches have length zero or negative")
+ if (!is.factor(x)) x <- factor(x)
+ nl <- nlevels(x)
+ lvls <- levels(x)
+ x <- as.integer(x)
+ if (is.character(model)) {
+ rate <- matrix(NA, nl, nl)
+ switch(model,
+ "ER" = np <- rate[] <- 1,
+ "ARD" = {
+ np <- nl*(nl - 1)
+ rate[col(rate) != row(rate)] <- 1:np
+ },
+ "SYM" = {
+ np <- nl * (nl - 1)/2
+ sel <- col(rate) < row(rate)
+ rate[sel] <- 1:np
+ rate <- t(rate)
+ rate[sel] <- 1:np
+ })
+ } else {
+ if (ncol(model) != nrow(model))
+ stop("the matrix given as 'model' is not square")
+ if (ncol(model) != nl)
+ stop("the matrix 'model' must have as many rows as the number of categories in 'x'")
+ rate <- model
+ np <- max(rate)
+ }
+ index.matrix <- rate
+ tmp <- cbind(1:nl, 1:nl)
+ index.matrix[tmp] <- NA
+ rate[tmp] <- 0
+ rate[rate == 0] <- np + 1 # to avoid 0's since we will use this as numeric indexing
+
+ liks <- matrix(0, nb.tip + nb.node, nl)
+ TIPS <- 1:nb.tip
+ liks[cbind(TIPS, x)] <- 1
+ phy <- reorder(phy, "postorder")
+
+ Q <- matrix(0, nl, nl)
+
+ e1 <- phy$edge[, 1]
+ e2 <- phy$edge[, 2]
+ EL <- phy$edge.length
+
+ if (use.eigen) {
+ dev <- function(p, output.liks = FALSE) {
+ if (any(is.nan(p)) || any(is.infinite(p))) return(1e+50)
+ comp <- numeric(nb.tip + nb.node)
+ Q[] <- c(p, 0)[rate]
+ diag(Q) <- -rowSums(Q)
+ decompo <- eigen(Q)
+ lambda <- decompo$values
+ GAMMA <- decompo$vectors
+ invGAMMA <- solve(GAMMA)
+ for (i in seq(from = 1, by = 2, length.out = nb.node)) {
+ j <- i + 1L
+ anc <- e1[i]
+ des1 <- e2[i]
+ des2 <- e2[j]
+ v.l <- GAMMA %*% diag(exp(lambda * EL[i])) %*% invGAMMA %*% liks[des1, ]
+ v.r <- GAMMA %*% diag(exp(lambda * EL[j])) %*% invGAMMA %*% liks[des2, ]
+ v <- v.l * v.r
+ comp[anc] <- sum(v)
+ liks[anc, ] <- v/comp[anc]
+ }
+ if (output.liks) return(liks[-TIPS, ])
+ dev <- -2 * sum(log(comp[-TIPS]))
+ if (is.na(dev)) Inf else dev
+ }
+ } else {
+ E <- if (use.expm) {
+ library(expm)
+ get("expm", "package:expm") # to avoid Matrix::expm
+ } else matexpo
+ dev <- function(p, output.liks = FALSE) {
+ if (any(is.nan(p)) || any(is.infinite(p))) return(1e50)
+ ## from Rich FitzJohn:
+ comp <- numeric(nb.tip + nb.node) # Storage...
+ Q[] <- c(p, 0)[rate]
+ diag(Q) <- -rowSums(Q)
+ for (i in seq(from = 1, by = 2, length.out = nb.node)) {
+ j <- i + 1L
+ anc <- e1[i]
+ des1 <- e2[i]
+ des2 <- e2[j]
+ v.l <- E(Q * EL[i]) %*% liks[des1, ]
+ v.r <- E(Q * EL[j]) %*% liks[des2, ]
+ v <- v.l * v.r
+ comp[anc] <- sum(v)
+ liks[anc, ] <- v/comp[anc]
+ }
+ if (output.liks) return(liks[-TIPS, ])
+ dev <- -2 * sum(log(comp[-TIPS]))
+ if (is.na(dev)) Inf else dev
+ }
+ }
+
+ out <- nlminb(rep(ip, length.out = np), function(p) dev(p),
+ lower = rep(0, np), upper = rep(1e50, np))
+ obj$loglik <- -out$objective/2
+ obj$rates <- out$par
+ oldwarn <- options("warn")
+ options(warn = -1)
+ out.nlm <- try(nlm(function(p) dev(p), p = obj$rates, iterlim = 1,
+ stepmax = 0, hessian = TRUE), silent = TRUE)
+ options(oldwarn)
+ obj$se <- if (class(out.nlm) == "try-error") {
+ warning("model fit suspicious: gradients apparently non-finite")
+ rep(NaN, np)
+ } else .getSEs(out.nlm)
+ obj$index.matrix <- index.matrix
+ if (CI) {
+ obj$lik.anc <- dev(obj$rates, TRUE)
+ colnames(obj$lik.anc) <- lvls
+ }
+ }
+ obj$call <- match.call()
+ class(obj) <- "ace"
+ obj
+}
+
+logLik.ace <- function(object, ...) object$loglik
+
+deviance.ace <- function(object, ...) -2*object$loglik
+
+AIC.ace <- function(object, ..., k = 2)
+{
+ if (is.null(object$loglik)) return(NULL)
+ ## Trivial test of "type"; may need to be improved
+ ## if other models are included in ace(type = "c")
+ np <- if (!is.null(object$sigma2)) 1 else length(object$rates)
+ -2*object$loglik + np*k
+}
+
+### by BB:
+anova.ace <- function(object, ...)
+{
+ X <- c(list(object), list(...))
+ df <- sapply(lapply(X, "[[", "rates"), length)
+ ll <- sapply(X, "[[", "loglik")
+ ## check if models are in correct order?
+ dev <- c(NA, 2*diff(ll))
+ ddf <- c(NA, diff(df))
+ table <- data.frame(ll, df, ddf, dev,
+ pchisq(dev, ddf, lower.tail = FALSE))
+ dimnames(table) <- list(1:length(X), c("Log lik.", "Df",
+ "Df change", "Resid. Dev",
+ "Pr(>|Chi|)"))
+ structure(table, heading = "Likelihood Ratio Test Table",
+ class = c("anova", "data.frame"))
+}
+
+print.ace <- function(x, digits = 4, ...)
+{
+ cat("\n Ancestral Character Estimation\n\n")
+ cat("Call: ")
+ print(x$call)
+ cat("\n")
+ if (!is.null(x$loglik))
+ cat(" Log-likelihood:", x$loglik, "\n\n")
+ if (!is.null(x$resloglik))
+ cat(" Residual log-likelihood:", x$resloglik, "\n\n")
+ ratemat <- x$index.matrix
+ if (is.null(ratemat)) { # to be improved
+ class(x) <- NULL
+ x$resloglik <- x$loglik <- x$call <- NULL
+ print(x)
+ } else {
+ dimnames(ratemat)[1:2] <- dimnames(x$lik.anc)[2]
+ cat("Rate index matrix:\n")
+ print(ratemat, na.print = ".")
+ cat("\n")
+ npar <- length(x$rates)
+ estim <- data.frame(1:npar, round(x$rates, digits), round(x$se, digits))
+ cat("Parameter estimates:\n")
+ names(estim) <- c("rate index", "estimate", "std-err")
+ print(estim, row.names = FALSE)
+ if (!is.null(x$lik.anc)) {
+ cat("\nScaled likelihoods at the root (type '...$lik.anc' to get them for all nodes):\n")
+ print(x$lik.anc[1, ])
+ }
+ }
+}
diff --git a/R/additive.R b/R/additive.R
new file mode 100644
index 0000000..ecd8f35
--- /dev/null
+++ b/R/additive.R
@@ -0,0 +1,38 @@
+## additive.R (2013-10-04)
+
+## Incomplete Distance Matrix Filling
+
+## Copyright 2011-2013 Andrei-Alin Popescu
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+additive <- function(X)
+{
+ if (is.matrix(X)) X <- as.dist(X)
+ X[is.na(X)] <- -1
+ X[X < 0] <- -1
+ X[is.nan(X)] <- -1
+ N <- attr(X, "Size")
+ labels <- attr(X, "Labels")
+ if (is.null(labels)) labels <- as.character(1:N)
+ m <- sum(X == -1)
+ ans <- .C(C_additive, as.double(X), as.integer(N),
+ as.integer(m), double(N*N))
+ matrix(ans[[4]], N, N)
+}
+
+ultrametric <- function(X)
+{
+ if (is.matrix(X)) X <- as.dist(X)
+ X[is.na(X)] <- -1
+ X[X < 0] <- -1
+ X[is.nan(X)] <- -1
+ N <- attr(X, "Size")
+ labels <- attr(X, "Labels")
+ if (is.null(labels)) labels <- as.character(1:N)
+ m <- sum(X == -1)
+ ans <- .C(C_ultrametric, as.double(X), as.integer(N),
+ as.integer(m), double(N*N))
+ matrix(ans[[4]], N, N)
+}
diff --git a/R/alex.R b/R/alex.R
new file mode 100644
index 0000000..ab846a7
--- /dev/null
+++ b/R/alex.R
@@ -0,0 +1,42 @@
+## alex.R (2012-03-27)
+
+## Alignment Explorer With Multiple Devices
+
+## Copyright 2012 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+alex <- function(x, ...)
+{
+ n <- nrow(x)
+ s <- ncol(x)
+ devmain <- dev.cur()
+ on.exit(dev.set(devmain))
+ NEW <- TRUE
+ cat("Click on two opposite corners of the zone you want to zoom-in.
+Right-click to exit.\n")
+ repeat {
+ xy <- locator(2)
+ if (is.null(xy)) break
+ xy <- lapply(xy, function(x) sort(round(x)))
+ i1 <- xy$y[1L]; i2 <- xy$y[2L]
+ j1 <- xy$x[1L]; j2 <- xy$x[2L]
+ if (i1 > n || j1 > s) cat("Try again!\n") else {
+ if (i1 <= 0) i1 <- 1L
+ if (j1 <= 0) j1 <- 1L
+ if (i2 > n) i2 <- n
+ if (j2 > s) j2 <- s
+ if (NEW) {
+ dev.new()
+ devsub <- dev.cur()
+ NEW <- FALSE
+ } else dev.set(devsub)
+ image(x[i1:i2, j1:j2], xaxt = "n", ...)
+ atx <- axTicks(1)
+ axis(1, atx, labels = (j1:j2)[atx])
+ title(sub = paste("From", sQuote(deparse(substitute(x)))))
+ dev.set(devmain)
+ }
+ }
+}
diff --git a/R/all.equal.phylo.R b/R/all.equal.phylo.R
new file mode 100644
index 0000000..79533d5
--- /dev/null
+++ b/R/all.equal.phylo.R
@@ -0,0 +1,83 @@
+## all.equal.phylo.R (2009-07-05)
+##
+## Global Comparison of two Phylogenies
+
+## Copyright 2006 Beno�t Durand
+## modified by EP for the new coding of "phylo" (2006-10-04)
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+## Recherche de la correspondance entre deux arbres
+## Parcours en profondeur et en parall�le des deux arbres (current et target)
+## current, target: les deux arbres � comparer
+## use.edge.length: faut-il comparer les longueurs de branches ?
+## use.tip.label: faut-il comparer les �tiquettes de feuilles ou seulement la
+## topologie des deux arbres ?
+## index.return: si TRUE, retourner la matrice de correspondance entre noeuds
+## et feuilles, une matrice � deux colonnes (current et target) avec pour
+## chaque ligne des paires d'identifiants de noeuds/feuilles, tels qu'ils
+## apparaissent dans l'attribut 'edge' des objets phylo
+## tolerance, scale: param�tres de comparaison des longueurs de branches
+## (voir 'all.equal')
+all.equal.phylo <- function(target, current,
+ use.edge.length = TRUE,
+ use.tip.label = TRUE,
+ index.return = FALSE,
+ tolerance = .Machine$double.eps ^ 0.5,
+ scale = NULL, ...) {
+
+ same.node <- function(i, j) {
+ # Comparaison de un noeud et une feuille
+ if (xor(i > Ntip1, j > Ntip2)) return(NULL)
+ # Comparaison de deux feuilles
+ if (i <= Ntip1) {
+ if (!use.tip.label) return(c(i, j))
+ if (current$tip.label[i] == target$tip.label[j])
+ return(c(i, j))
+ return(NULL)
+ }
+ # Comparaison de deux noeuds
+ i.children <- which(current$edge[, 1] == i)
+ j.children <- which(target$edge[, 1] == j)
+ if (length(i.children) != length(j.children)) return(NULL)
+ correspondance <- NULL
+ for (i.child in i.children) {
+ corresp <- NULL
+ for (j.child in j.children) {
+ if (!use.edge.length ||
+ isTRUE(all.equal(current$edge.length[i.child],
+ target$edge.length[j.child],
+ tolerance = tolerance,
+ scale = scale)))
+ corresp <- same.node(current$edge[i.child, 2],
+ target$edge[j.child, 2])
+ if (!is.null(corresp)) break
+ }
+ if (is.null(corresp)) return(NULL)
+ correspondance <- c(correspondance, i, j, corresp)
+ j.children <- j.children[j.children != j.child]
+ }
+ return(correspondance)
+ }
+
+ Ntip1 <- length(target$tip.label)
+ Ntip2 <- length(current$tip.label)
+ root1 <- Ntip1 + 1
+ root2 <- Ntip2 + 1
+ if (root1 != root2) return(FALSE)
+ ## Fix by EP so that unrooted trees are correctly compared:
+ if (!is.rooted(target) && !is.rooted(current)) {
+ outg <- target$tip.label[1]
+ if (! outg %in% current$tip.label) return(FALSE)
+ target <- root(target, outg)
+ current <- root(current, outg)
+ }
+ ## End
+ result <- same.node(root1, root2)
+ if (!isTRUE(index.return)) return(!is.null(result))
+ if (is.null(result)) return(result)
+ result <- t(matrix(result, nrow = 2))
+ colnames(result) = c('current', 'target')
+ return(result)
+}
diff --git a/R/as.bitsplits.R b/R/as.bitsplits.R
new file mode 100644
index 0000000..7201bd8
--- /dev/null
+++ b/R/as.bitsplits.R
@@ -0,0 +1,127 @@
+## as.bitsplits.R (2014-01-02)
+
+## Conversion Among Split Classes
+
+## Copyright 2011-2014 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+as.bitsplits <- function(x) UseMethod("as.bitsplits")
+
+as.bitsplits.prop.part <- function(x)
+{
+ foo <- function(vect, RAWVECT) {
+ res <- RAWVECT
+ for (y in vect) {
+ i <- ceiling(y/8)
+ res[i] <- res[i] | as.raw(2^(8 - ((y - 1) %% 8) - 1))
+ }
+ res
+ }
+
+ N <- length(x) # number of splits
+ n <- length(x[[1]]) # number of tips
+
+ nr <- ceiling(n/8)
+ mat <- raw(N * nr)
+ dim(mat) <- c(nr, N)
+
+ RAWVECT <- raw(nr)
+
+ for (i in 1:N) mat[, i] <- foo(x[[i]], RAWVECT)
+
+ ## add the n trivial splits of size 1... :
+ mat.bis <- raw(n * nr)
+ dim(mat.bis) <- c(nr, n)
+ for (i in 1:n) mat.bis[, i] <- foo(i, RAWVECT)
+
+ ## ... drop the trivial split of size n... :
+ mat <- cbind(mat.bis, mat[, -1, drop = FALSE])
+
+ ## ... update the split frequencies... :
+ freq <- attr(x, "number")
+ freq <- c(rep(freq[1L], n), freq[-1L])
+
+ ## ... and numbers:
+ N <- N + n - 1L
+
+ structure(list(matsplit = mat, labels = attr(x, "labels"),
+ freq = freq), class = "bitsplits")
+}
+
+print.bitsplits <- function(x, ...)
+{
+ cat('Object of class "bitsplits"\n')
+ cat(' ', length(x$labels), 'tips\n')
+ cat(' ', length(x$freq), 'partitions\n')
+}
+
+as.prop.part <- function(x) UseMethod("as.prop.part")
+
+as.prop.part.bitsplits <- function(x)
+{
+ decodeBitsplits <- function(x) {
+ f <- function(y) rev(rawToBits(y)) == as.raw(1)
+ which(unlist(lapply(x, f)))
+ }
+ res <- apply(x$matsplit, 2, decodeBitsplits)
+ attr(res, "number") <- x$freq
+ attr(res, "labels") <- x$labels
+ class(res) <- "prop.part"
+ res
+}
+
+bitsplits <- function(x)
+{
+ if (inherits(x, "phylo")) {
+ x <- reorder(x, "postorder")
+ labs <- x$tip.label
+ n <- length(labs)
+ m <- x$Nnode
+ N <- dim(x$edge)[1]
+ nr <- ceiling(n/8)
+ nc <- N - n # number of internal edges
+
+ o <- .C(bitsplits_phylo, as.integer(n), as.integer(m),
+ as.integer(x$edge), as.integer(N), as.integer(nr),
+ raw(nr * nc), NAOK = TRUE)[[6]]
+ freq <- rep(1L, nc)
+
+ } else {
+ if (!inherits(x, "multiPhylo"))
+ stop('x is not of class "phylo" or "multiPhylo"')
+ x <- .compressTipLabel(x)
+ labs <- attr(x, "TipLabel")
+ n <- length(labs)
+ nr <- ceiling(n/8)
+ ans <- .Call(bitsplits_multiPhylo, x, n, nr)
+ nc <- ans[[3]]
+ o <- ans[[1]][1:(nr * nc)]
+ freq <- ans[[2]][1:nc]
+ }
+
+ dim(o) <- c(nr, nc)
+ structure(list(matsplit = o, labels = labs, freq = freq),
+ class = "bitsplits")
+}
+
+countBipartitions <- function(phy, X)
+{
+ n <- Ntip(phy)
+ m <- phy$Nnode
+ N <- Nedge(phy)
+
+ SPLIT <- bitsplits(phy)
+ nr <- nrow(SPLIT$matsplit)
+ nc <- ncol(SPLIT$matsplit)
+ freq <- rep(0, nc)
+ for (tr in X) {
+ tr <- ape::reorder.phylo(tr, "postorder")
+ e <- tr$edge
+ freq <- .C(CountBipartitionsFromTrees, as.integer(n), as.integer(m),
+ as.integer(e), as.integer(N), as.integer(nr), as.integer(nc),
+ as.raw(SPLIT$matsplit), as.double(freq), NAOK = TRUE)[[8]]
+ }
+ freq
+}
diff --git a/R/as.matching.R b/R/as.matching.R
new file mode 100644
index 0000000..7a01fd1
--- /dev/null
+++ b/R/as.matching.R
@@ -0,0 +1,66 @@
+## as.matching.R (2011-02-26)
+
+## Conversion Between Phylo and Matching Objects
+
+## Copyright 2005-2011 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+as.matching <- function(x, ...) UseMethod("as.matching")
+
+as.matching.phylo <- function(x, labels = TRUE, ...)
+{
+ nb.tip <- length(x$tip.label)
+ nb.node <- x$Nnode
+ if (nb.tip != nb.node + 1)
+ stop("the tree must be dichotomous AND rooted.")
+ x <- reorder(x, "pruningwise") # cannot use "postorder" here!
+ mat <- matrix(x$edge[, 2], ncol = 2, byrow = TRUE)
+ nodes <- x$edge[seq(by = 2, length.out = nb.node), 1]
+ ## we can use match() becoz each node appears once in `mat'
+ O <- match(mat, nodes)
+ new.nodes <- 1:nb.node + nb.tip
+ sel <- !is.na(O)
+ mat[sel] <- new.nodes[O[sel]]
+ mat <- t(apply(mat, 1, sort))
+
+ obj <- list(matching = mat)
+ if (!is.null(x$edge.length))
+ warning("branch lengths have been ignored")
+ if (labels) {
+ obj$tip.label <- x$tip.label
+ if (!is.null(x$node.label))
+ obj$node.label <- x$node.label[match(new.nodes, nodes)]
+ }
+ class(obj) <- "matching"
+ obj
+}
+
+as.phylo.matching <- function(x, ...)
+{
+ nb.node <- dim(x$matching)[1]
+ nb.tip <- nb.node + 1
+ N <- 2 * nb.node
+ edge <- matrix(NA, N, 2)
+ new.nodes <- numeric(N + 1)
+ new.nodes[N + 1] <- nb.tip + 1
+ nextnode <- nb.tip + 2
+ j <- 1
+ for (i in nb.node:1) {
+ edge[j:(j + 1), 1] <- new.nodes[i + nb.tip]
+ for (k in 1:2) {
+ if (x$matching[i, k] > nb.tip) {
+ edge[j + k - 1, 2] <- new.nodes[x$matching[i, k]] <- nextnode
+ nextnode <- nextnode + 1
+ } else edge[j + k - 1, 2] <- x$matching[i, k]
+ }
+ j <- j + 2
+ }
+ obj <- list(edge = edge)
+ if (!is.null(x$tip.label)) obj$tip.label <- x$tip.label
+ else obj$tip.label <- as.character(1:nb.tip)
+ obj$Nnode <- nb.node
+ class(obj) <- "phylo"
+ read.tree(text = write.tree(obj))
+}
diff --git a/R/as.phylo.R b/R/as.phylo.R
new file mode 100644
index 0000000..b56e5c2
--- /dev/null
+++ b/R/as.phylo.R
@@ -0,0 +1,134 @@
+## as.phylo.R (2013-08-13)
+
+## Conversion Among Tree Objects
+
+## Copyright 2005-2013 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+old2new.phylo <- function(phy)
+{
+ mode(phy$edge) <- "numeric"
+ phy$Nnode <- -min(phy$edge)
+ n <- length(phy$tip.label)
+ NODES <- phy$edge < 0
+ phy$edge[NODES] <- n - phy$edge[NODES]
+ phy
+}
+
+new2old.phylo <- function(phy)
+{
+ NTIP <- length(phy$tip.label)
+ NODES <- phy$edge > NTIP
+ phy$edge[NODES] <- NTIP - phy$edge[NODES]
+ mode(phy$edge) <- "character"
+ phy$Nnode <- NULL
+ phy
+}
+
+as.phylo <- function (x, ...)
+{
+ if (length(class(x)) == 1 && class(x) == "phylo")
+ return(x)
+ UseMethod("as.phylo")
+}
+
+as.phylo.hclust <- function(x, ...)
+{
+ N <- dim(x$merge)[1]
+ edge <- matrix(0L, 2*N, 2)
+ edge.length <- numeric(2*N)
+ ## `node' gives the number of the node for the i-th row of x$merge
+ node <- integer(N)
+ node[N] <- N + 2L
+ cur.nod <- N + 3L
+ j <- 1L
+ for (i in N:1) {
+ edge[j:(j + 1), 1] <- node[i]
+ for (l in 1:2) {
+ k <- j + l - 1L
+ y <- x$merge[i, l]
+ if (y > 0) {
+ edge[k, 2] <- node[y] <- cur.nod
+ cur.nod <- cur.nod + 1L
+ edge.length[k] <- x$height[i] - x$height[y]
+ } else {
+ edge[k, 2] <- -y
+ edge.length[k] <- x$height[i]
+ }
+ }
+ j <- j + 2L
+ }
+ if (is.null(x$labels))
+ x$labels <- as.character(1:(N + 1))
+ obj <- list(edge = edge, edge.length = edge.length / 2,
+ tip.label = x$labels, Nnode = N)
+ class(obj) <- "phylo"
+ reorder(obj)
+}
+
+as.phylo.phylog <- function(x, ...)
+{
+ tr <- read.tree(text = x$tre)
+ n <- length(tr$tip.label)
+ edge.length <- numeric(dim(tr$edge)[1])
+ term <- which(tr$edge[, 2] <= n)
+ inte <- which(tr$edge[, 2] > n)
+ edge.length[term] <- x$leaves[tr$tip.label]
+ edge.length[inte] <- x$nodes[tr$node.label][-1]
+ tr$edge.length <- edge.length
+ if (x$nodes["Root"] != 0) {
+ tr$edge.root <- x$nodes["Root"]
+ names(tr$edge.root) <- NULL
+ }
+ tr
+}
+
+as.hclust.phylo <- function(x, ...)
+{
+ if (!is.ultrametric(x)) stop("the tree is not ultrametric")
+ if (!is.binary.tree(x)) stop("the tree is not binary")
+ if (!is.rooted(x)) stop("the tree is not rooted")
+ n <- length(x$tip.label)
+ x$node.label <- NULL # by Jinlong Zhang (2010-12-15)
+ bt <- sort(branching.times(x))
+ inode <- as.numeric(names(bt))
+ N <- n - 1L
+ nm <- numeric(N + n) # hash table
+ nm[inode] <- 1:N
+ merge <- matrix(NA, N, 2)
+ for (i in 1:N) {
+ ind <- which(x$edge[, 1] == inode[i])
+ for (k in 1:2) {
+ tmp <- x$edge[ind[k], 2]
+ merge[i, k] <- if (tmp <= n) -tmp else nm[tmp]
+ }
+ }
+ names(bt) <- NULL
+ obj <- list(merge = merge, height = bt, order = 1:n, labels = x$tip.label,
+ call = match.call(), method = "unknown")
+ class(obj) <- "hclust"
+ obj
+}
+
+if (getRversion() >= "2.15.1") utils::globalVariables(c("network", "network.vertex.names<-"))
+as.network.phylo <- function(x, directed = is.rooted(x), ...)
+{
+ if (is.null(x$node.label)) x <- makeNodeLabel(x)
+ res <- network(x$edge, directed = directed, ...)
+ network.vertex.names(res) <- c(x$tip.label, x$node.label)
+ res
+}
+
+if (getRversion() >= "2.15.1") utils::globalVariables("graph.edgelist")
+as.igraph.phylo <- function(x, directed = is.rooted(x), use.labels = TRUE, ...)
+{
+ ## local copy because x will be changed before evaluating is.rooted(x):
+ directed <- directed
+ if (use.labels) {
+ if (is.null(x$node.label)) x <- makeNodeLabel(x)
+ x$edge <- matrix(c(x$tip.label, x$node.label)[x$edge], ncol = 2)
+ } else x$edge <- x$edge - 1L
+ graph.edgelist(x$edge, directed = directed, ...)
+}
diff --git a/R/as.phylo.formula.R b/R/as.phylo.formula.R
new file mode 100644
index 0000000..050ac8b
--- /dev/null
+++ b/R/as.phylo.formula.R
@@ -0,0 +1,51 @@
+## as.phylo.formula.R (2005-12-10)
+
+## Conversion from Taxonomy Variables to Phylogenetic Trees
+
+## Copyright 2005 Julien Dutheil
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+as.phylo.formula <- function(x, data=parent.frame(), ...)
+{
+ # Testing formula syntax:
+ err <- "Formula must be of the kind \"~A1/A2/.../An\"."
+ if(length(x) != 2) stop(err)
+ if(x[[1]] != "~") stop(err)
+ f <- x[[2]]
+ taxo <- list()
+ while(length(f) == 3) {
+ if(f[[1]] != "/") stop(err)
+ if(!is.factor(data[[deparse(f[[3]])]])) stop(paste("Variable", deparse(f[[3]]), "must be a factor."))
+ taxo[[deparse(f[[3]])]] <- data[[deparse(f[[3]])]]
+ if(length(f) > 1) f <- f[[2]]
+ }
+ if(!is.factor(data[[deparse(f)]])) stop(paste("Variable", deparse(f), "must be a factor."))
+ taxo[[deparse(f)]] <- data[[deparse(f)]]
+ taxo.data <- as.data.frame(taxo)
+ leaves.names <- as.character(taxo.data[,1])
+ taxo.data[,1] <- 1:nrow(taxo.data)
+ # Now builds the phylogeny:
+
+ f.rec <- function(subtaxo) { # Recurrent utility function
+ u <- ncol(subtaxo)
+ levels <- unique(subtaxo[,u])
+ if(u == 1) {
+ if(length(levels) != nrow(subtaxo))
+ warning("Error, leaves names are not unique.")
+ return(as.character(subtaxo[,1]))
+ }
+ t <- character(length(levels))
+ for(l in 1:length(levels)) {
+ x <- f.rec(subtaxo[subtaxo[,u] == levels[l],][1:(u-1)])
+ if(length(x) == 1) t[l] <- x
+ else t[l] <- paste("(", paste(x, collapse=","), ")", sep="")
+ }
+ return(t)
+ }
+ string <- paste("(", paste(f.rec(taxo.data), collapse=","), ");", sep="")
+ phy<-read.tree(text=string)
+ phy$tip.label <- leaves.names[as.numeric(phy$tip.label)]
+ return(phy)
+}
diff --git a/R/balance.R b/R/balance.R
new file mode 100644
index 0000000..37b2671
--- /dev/null
+++ b/R/balance.R
@@ -0,0 +1,32 @@
+## balance.R (2009-05-10)
+
+## Balance of a Dichotomous Phylogenetic Tree
+
+## Copyright 2002-2009 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+balance <- function(phy)
+{
+### the tree must be in cladewise order
+ if (!inherits(phy, "phylo"))
+ stop('object "phy" is not of class "phylo"')
+ N <- length(phy$tip.label)
+ nb.node <- phy$Nnode
+ if (nb.node != N - 1)
+ stop('"phy" is not rooted and fully dichotomous')
+ ans <- matrix(NA, nb.node, 2)
+ foo <- function(node, n) {
+ s <- which(phy$edge[, 1] == node)
+ desc <- phy$edge[s, 2]
+ ans[node - N, 1] <<- n1 <- (s[2] - s[1] + 1)/2
+ ans[node - N, 2] <<- n2 <- n - n1
+ if (desc[1] > N) foo(desc[1], n1)
+ if (desc[2] > N) foo(desc[2], n2)
+ }
+ foo(N + 1, N)
+ rownames(ans) <-
+ if (is.null(phy$node.label)) N + 1:nb.node else phy$node.label
+ ans
+}
diff --git a/R/bind.tree.R b/R/bind.tree.R
new file mode 100644
index 0000000..b43ce90
--- /dev/null
+++ b/R/bind.tree.R
@@ -0,0 +1,217 @@
+## bind.tree.R (2012-02-13)
+
+## Bind Trees
+
+## Copyright 2003-2012 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+`+.phylo` <- function(x, y)
+{
+ p <- if (is.null(x$root.edge)) 0 else x$root.edge
+ bind.tree(x, y, position = p)
+}
+
+bind.tree <- function(x, y, where = "root", position = 0, interactive = FALSE)
+{
+ nx <- length(x$tip.label)
+ mx <- x$Nnode
+ ROOTx <- nx + 1L
+ ny <- length(y$tip.label)
+ my <- y$Nnode
+
+ if (interactive) {
+ lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv)
+ if (lastPP$type != "phylogram" || lastPP$direction != "rightwards")
+ stop("you must plot tree 'x' as a 'rightward phylogram'")
+ cat("Click where you want to graft tree 'y'...\n")
+ xy <- locator(1)
+ d <- abs(xy$y - lastPP$yy)
+ d[lastPP$xx - xy$x < 0] <- Inf
+ where <- which.min(d)
+ position <- lastPP$xx[where] - xy$x
+ if (position < 0) position <- 0
+ cat("The following parameters are used:\n")
+ cat(" where =", where, " position =", position, "\n")
+ } else {
+ if (where == 0 || where == "root") where <- ROOTx
+ if (position < 0) position <- 0
+ if (where > nx + mx)
+ stop("argument 'where' out of range for tree 'x'")
+ }
+
+ ## check whether both trees have branch lengths:
+ switch(is.null(x$edge.length) + is.null(y$edge.length) + 1L,
+ wbl <- TRUE, {
+ x$edge.length <- y$edge.length <- NULL
+ wbl <- FALSE
+ warning("one tree has no branch lengths, they have been ignored")
+ },
+ wbl <- FALSE)
+
+ yHasNoRootEdge <- is.null(y$root.edge)
+ xHasNoRootEdge <- is.null(x$root.edge)
+
+ ## find the row of 'where' before renumbering
+ if (where == ROOTx) case <- 1 else {
+ i <- which(x$edge[, 2] == where)
+ case <- if (where <= nx) 2 else 3
+ }
+ ## case = 1 -> y is bound on the root of x
+ ## case = 2 -> y is bound on a tip of x
+ ## case = 3 -> y is bound on a node of x
+
+ ## check that 'position' is correct
+ if (position && wbl) {
+### New in ape 3.0-1: this makes possible binding 'y' below
+### a node of 'x' thus creating a new node in 'x'
+### if (!wbl)
+### stop("'position' is non-null but trees have no branch lengths")
+ if (case == 1) {
+ if (xHasNoRootEdge)
+ stop("tree 'x' has no root edge")
+ if (position > x$root.edge)
+ stop("'position' is larger than x's root edge")
+ } else {
+ if (x$edge.length[i] < position)
+ stop("'position' is larger than the branch length")
+ }
+ }
+
+ ## the special case of substituting two tips:
+ if (case == 2 && ny == 1 && !position) {
+ x$tip.label[x$edge[i, 2]] <- y$tip.label
+ if (wbl)
+ x$edge.length[i] <- x$edge.length[i] + y$edge.length
+ return(x)
+ }
+
+ x <- reorder(x)
+ y <- reorder(y)
+
+### because in all situations internal nodes need to be
+### renumbered, they are changed to negatives first, and
+### nodes eventually added will be numbered sequentially
+
+ nodes <- x$edge > nx
+ x$edge[nodes] <- -(x$edge[nodes] - nx) # -1, ..., -mx
+ nodes <- y$edge > ny
+ y$edge[nodes] <- -(y$edge[nodes] - ny + mx) # -(mx+1), ..., -(mx+my)
+ ROOT <- -1L # may change later
+ next.node <- -(mx + my) - 1L
+
+ ## renumber now the tips in y:
+ new.nx <- if (where <= nx && !position) nx - 1L else nx
+ y$edge[!nodes] <- y$edge[!nodes] + new.nx
+
+ ## if 'y' as a root edge, use it:
+ if (!yHasNoRootEdge) {
+ y$edge <- rbind(c(0, y$edge[1]), y$edge)
+ ## ^ will be filled later
+ next.node <- next.node - 1L
+ if (wbl) y$edge.length <- c(y$root.edge, y$edge.length)
+ }
+
+ switch(case, { # case = 1
+ if (position) {
+ x$root.edge <- x$root.edge - position
+ x$edge <- rbind(c(next.node, x$edge[1]), x$edge)
+ ROOT <- next.node
+ if (wbl) x$edge.length <- c(position, x$edge.length)
+ }
+ if (yHasNoRootEdge) {
+ j <- which(y$edge[, 1] == y$edge[1])
+ y$edge[j, 1] <- ROOT
+ } else y$edge[1] <- ROOT
+ x$edge <- rbind(x$edge, y$edge)
+ if (wbl)
+ x$edge.length <- c(x$edge.length, y$edge.length)
+ }, { # case = 2
+ if (position) {
+ x$edge[i, 2] <- next.node
+ x$edge <- rbind(x$edge[1:i, ], c(next.node, where), x$edge[-(1:i), ])
+ if (wbl) {
+ x$edge.length[i] <- x$edge.length[i] - position
+ x$edge.length <- c(x$edge.length[1:i], position, x$edge.length[-(1:i)])
+ }
+ i <- i + 1L
+ if (yHasNoRootEdge) {
+ j <- which(y$edge[, 1] == y$edge[1])
+ y$edge[j, 1] <- x$edge[i, 1]
+ } else y$edge[1] <- x$edge[i, 1]
+ } else {
+ if (yHasNoRootEdge) x$edge[i, 2] <- y$edge[1]
+ else {
+ ## the root edge of y is fused with the terminal edge of x
+ if (wbl) y$edge.length[1] <- y$edge.length[1] + x$edge.length[i]
+ y$edge[1] <- x$edge[i, 1]
+ ## delete i-th edge in x:
+ x$edge <- x$edge[-i, ]
+ if (wbl) x$edge.length <- x$edge.length[-i]
+ i <- i - 1L
+ }
+ x$tip.label <- x$tip.label[-where]
+ ## renumber the tips that need to:
+ ii <- which(x$edge[, 2] > where & x$edge[, 2] <= nx)
+ x$edge[ii, 2] <- x$edge[ii, 2] - 1L
+ }
+ x$edge <- rbind(x$edge[1:i, ], y$edge, x$edge[-(1:i), ])
+ if (wbl)
+ x$edge.length <- c(x$edge.length[1:i], y$edge.length, x$edge.length[-(1:i)])
+ }, { # case = 3
+ if (position) {
+ if (yHasNoRootEdge) {
+ j <- which(y$edge[, 1] == y$edge[1])
+ y$edge[j, 1] <- next.node
+ } else y$edge[1] <- next.node
+ x$edge <- rbind(x$edge[1:i, ], c(next.node, x$edge[i, 2]), x$edge[-(1:i), ])
+ x$edge[i, 2] <- next.node
+ if (wbl) {
+ x$edge.length[i] <- x$edge.length[i] - position
+ x$edge.length <- c(x$edge.length[1:i], position, x$edge.length[-(1:i)])
+ }
+ i <- i + 1L
+ } else {
+ if (yHasNoRootEdge) {
+ j <- which(y$edge[, 1] == y$edge[1])
+ y$edge[j, 1] <- x$edge[i, 2]
+ } else y$edge[1] <- x$edge[i, 2]
+ }
+ x$edge <- rbind(x$edge[1:i, ], y$edge, x$edge[-(1:i), ])
+ if (wbl)
+ x$edge.length <- c(x$edge.length[1:i], y$edge.length, x$edge.length[-(1:i)])
+ })
+
+ x$tip.label <- c(x$tip.label, y$tip.label)
+
+ if (is.null(x$node.label)) {
+ if (!is.null(y$node.label))
+ x$node.label <- c(rep(NA, mx), y$node.label)
+ } else {
+ x$node.label <-
+ if (is.null(y$node.label)) c(x$node.label, rep(NA, my))
+ else c(x$node.label, y$node.label)
+ }
+
+ n <- length(x$tip.label)
+ x$Nnode <- dim(x$edge)[1] + 1L - n
+
+ ## update the node labels before renumbering (this adds NA for
+ ## the added nodes, and drops the label for those deleted)
+ if (!is.null(x$node.label))
+ x$node.label <- x$node.label[sort(-unique(x$edge[, 1]))]
+
+ ## renumber nodes:
+ newNb <- integer(x$Nnode)
+ newNb[-ROOT] <- n + 1L
+ sndcol <- x$edge[, 2] < 0
+ ## executed from right to left, so newNb is modified before x$edge:
+ x$edge[sndcol, 2] <- newNb[-x$edge[sndcol, 2]] <- n + 2:x$Nnode
+ x$edge[, 1] <- newNb[-x$edge[, 1]]
+
+ if (!is.null(x$node.label))
+ x$node.label <- x$node.label[order(newNb[newNb > 0])]
+
+ x
+}
diff --git a/R/biplot.pcoa.R b/R/biplot.pcoa.R
new file mode 100644
index 0000000..9ba8809
--- /dev/null
+++ b/R/biplot.pcoa.R
@@ -0,0 +1,49 @@
+'biplot.pcoa' <-
+ function(x, Y=NULL, plot.axes = c(1,2), dir.axis1=1, dir.axis2=1, rn=NULL, ...)
+# x = output object from function pcoa.R
+# Y = optional sites-by-variables data table
+# plot.axes = the two axes to be plotted
+# rn = an optional vector, length n, of object labels
+# dir.axis.1 = -1 to revert axis 1 for the projection of points and variables
+# dir.axis.2 = -1 to revert axis 2 for the projection of points and variables
+#
+# Author: Pierre Legendre, January 2009
+ {
+ k <- ncol(x$vectors)
+ if(k < 2) stop("There is a single eigenvalue. No plot can be produced.")
+ if(k < plot.axes[1]) stop("Axis",plot.axes[1],"does not exist.")
+ if(k < plot.axes[2]) stop("Axis",plot.axes[2],"does not exist.")
+
+ if(!is.null(rn)) rownames(x$vectors) <- rn
+ labels = colnames(x$vectors[,plot.axes])
+ diag.dir <- diag(c(dir.axis1,dir.axis2))
+ x$vectors[,plot.axes] <- x$vectors[,plot.axes] %*% diag.dir
+
+ if(is.null(Y)) {
+ limits <- apply(x$vectors[,plot.axes], 2, range)
+ ran.x <- limits[2,1] - limits[1,1]
+ ran.y <- limits[2,2] - limits[1,2]
+ xlim <- c((limits[1,1]-ran.x/10), (limits[2,1]+ran.x/5))
+ ylim <- c((limits[1,2]-ran.y/10), (limits[2,2]+ran.y/10))
+
+ par(mai = c(1.0, 1.0, 1.0, 0.5))
+ plot(x$vectors[,plot.axes], xlab=labels[1], ylab=labels[2], xlim=xlim, ylim=ylim, asp=1)
+ text(x$vectors[,plot.axes], labels=rownames(x$vectors), pos=4, cex=1, offset=0.5)
+ title(main = "PCoA ordination", line=2.5)
+
+ } else {
+ # Find positions of variables in biplot:
+ # construct U from covariance matrix between Y and standardized point vectors
+ # (equivalent to PCA scaling 1, since PCoA preserves distances among objects)
+ n <- nrow(Y)
+ points.stand <- scale(x$vectors[,plot.axes])
+ S <- cov(Y, points.stand)
+ U <- S %*% diag((x$values$Eigenvalues[plot.axes]/(n-1))^(-0.5))
+ colnames(U) <- colnames(x$vectors[,plot.axes])
+
+ par(mai = c(1, 0.5, 1.4, 0))
+ biplot(x$vectors[,plot.axes], U, xlab=labels[1], ylab=labels[2])
+ title(main = c("PCoA biplot","Response variables projected","as in PCA with scaling 1"), line=4)
+ }
+ invisible()
+}
diff --git a/R/birthdeath.R b/R/birthdeath.R
new file mode 100644
index 0000000..7d53fd2
--- /dev/null
+++ b/R/birthdeath.R
@@ -0,0 +1,150 @@
+## birthdeath.R (2012-04-20)
+
+## Estimation of Speciation and Extinction Rates
+## with Birth-Death Models
+
+## birthdeath: standard model
+## bd.ext: extended version
+
+## Copyright 2002-2012 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+birthdeath <- function(phy)
+{
+ if (!inherits(phy, "phylo")) stop('object "phy" is not of class "phylo"')
+ N <- length(phy$tip.label)
+ x <- c(NA, branching.times(phy))
+ dev <- function(a, r) {
+ if (r < 0 || a > 1) return(1e100)
+ -2 * (lfactorial(N - 1)
+ + (N - 2) * log(r)
+ + r * sum(x[3:N])
+ + N * log(1 - a)
+ - 2 * sum(log(exp(r * x[2:N]) - a)))
+ }
+ out <- nlm(function(p) dev(p[1], p[2]), c(0.1, 0.2), hessian = TRUE)
+ if (out$estimate[1] < 0) {
+ out <- nlm(function(p) dev(0, p), 0.2, hessian = TRUE)
+ para <- c(0, out$estimate)
+ inv.hessian <- try(solve(out$hessian))
+ se <-
+ if (class(inv.hessian) == "try-error") NA
+ else sqrt(diag(inv.hessian))
+ se <- c(0, se)
+ }
+ else {
+ para <- out$estimate
+ inv.hessian <- try(solve(out$hessian))
+ se <-
+ if (class(inv.hessian) == "try-error") c(NA, NA)
+ else sqrt(diag(inv.hessian))
+ }
+ Dev <- out$minimum
+
+ ## 95% profile likelihood CIs
+
+ ## which: index of the parameter (1 or 2)
+ ## s: sign of the increment (-1 or +1)
+ foo <- function(which, s) {
+ i <- 0.1
+
+ if (which == 1) {
+ p <- para[1] + s * i
+ bar <- function() dev(p, para[2])
+ } else { # which == 2
+ p <- para[2] + s * i
+ bar <- function() dev(para[1], p)
+ }
+
+ while (i > 1e-9) {
+ while (bar() < Dev + 3.84) p <- p + s * i
+ p <- p - s * i
+ i <- i / 10
+ }
+ p
+ }
+
+ CI <- mapply(foo, c(1, 2, 1, 2), c(-1, -1, 1, 1))
+ dim(CI) <- c(2, 2)
+
+ names(para) <- names(se) <- rownames(CI) <- c("d/b", "b-d")
+ colnames(CI) <- c("lo", "up")
+ obj <- list(tree = deparse(substitute(phy)), N = N,
+ dev = Dev, para = para, se = se, CI = CI)
+ class(obj) <- "birthdeath"
+ obj
+}
+
+print.birthdeath <- function(x, ...)
+{
+ cat("\nEstimation of Speciation and Extinction Rates\n")
+ cat(" with Birth-Death Models\n\n")
+ cat(" Phylogenetic tree:", x$tree, "\n")
+ cat(" Number of tips:", x$N, "\n")
+ cat(" Deviance:", x$dev, "\n")
+ cat(" Log-likelihood:", -(x$dev)/2, "\n")
+ cat(" Parameter estimates:\n")
+ cat(" d / b =", x$para[1], " StdErr =", x$se[1], "\n")
+ cat(" b - d =", x$para[2], " StdErr =", x$se[2], "\n")
+ cat(" (b: speciation rate, d: extinction rate)\n")
+ cat(" Profile likelihood 95% confidence intervals:\n")
+ cat(" d / b: [", x$CI[1, 1], ", ", x$CI[1, 2], "]", "\n", sep = "")
+ cat(" b - d: [", x$CI[2, 1], ", ", x$CI[2, 2], "]", "\n\n", sep = "")
+}
+
+bd.ext <- function(phy, S, conditional = TRUE)
+{
+ if (!inherits(phy, "phylo"))
+ stop('object "phy" is not of class "phylo"')
+ if (!is.null(names(S))) {
+ if (all(names(S) %in% phy$tip.label)) S <- S[phy$tip.label]
+ else warning('the names of argument "S" and the tip labels
+did not match: the former were ignored.')
+ }
+ N <- length(S)
+ x <- branching.times(phy)
+ x <- c(x[1], x)
+ trm.br <- phy$edge.length[phy$edge[, 2] <= N]
+ if (conditional) {
+ dev <- function(a, r) {
+ if (a >= 1 || a < 0 || r <= 0) return(1e50)
+ ert <- exp(r * trm.br)
+ zeta <- (ert - 1)/(ert - a)
+ -2 * (lfactorial(N - 1)
+ + (N - 2) * log(r)
+ + N * log(1 - a)
+ + 2 * r * sum(x[2:N])
+ - 2 * sum(log(exp(r * x[2:N]) - a))
+ + sum(log(1 - zeta) + (S - 1)*log(zeta)))
+ }
+ } else {
+ dev <- function(a, r) {
+ if (a >= 1 || a < 0 || r <= 0) return(1e50)
+ -2 * (lfactorial(N - 1)
+ + (N - 2) * log(r)
+ + (3 * N) * log(1 - a)
+ + 2 * r * sum(x[2:N])
+ - 2 * sum(log(exp(r * x[2:N]) - a))
+ + r * sum(trm.br)
+ + sum((S - 1) * log(exp(r * trm.br) - 1))
+ - sum((S + 1) * log(exp(r * trm.br) - a)))
+ }
+ }
+ out <- nlm(function(p) dev(p[1], p[2]), c(0.1, 0.2), hessian = TRUE)
+ para <- out$estimate
+ se <- sqrt(diag(solve(out$hessian)))
+ Dev <- out$minimum
+ cat("\nExtended Version of the Birth-Death Models to\n")
+ cat(" Estimate Speciation and Extinction Rates\n\n")
+ cat(" Data: phylogenetic:", deparse(substitute(phy)), "\n")
+ cat(" taxonomic:", deparse(substitute(S)), "\n")
+ cat(" Number of tips:", N, "\n")
+ cat(" Deviance:", Dev, "\n")
+ cat(" Log-likelihood:", -Dev/2, "\n")
+ cat(" Parameter estimates:\n")
+ cat(" d / b =", para[1], " StdErr =", se[1], "\n")
+ cat(" b - d =", para[2], " StdErr =", se[2], "\n")
+ cat(" (b: speciation rate, d: extinction rate)\n")
+}
diff --git a/R/branching.times.R b/R/branching.times.R
new file mode 100644
index 0000000..c10b34e
--- /dev/null
+++ b/R/branching.times.R
@@ -0,0 +1,31 @@
+## branching.times.R (2013-09-24)
+
+## Branching Times of a Phylogenetic Tree
+
+## Copyright 2002-2013 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+branching.times <- function(phy)
+{
+ if (!inherits(phy, "phylo"))
+ stop('object "phy" is not of class "phylo"')
+ phy <- reorder(phy)
+ n <- length(phy$tip.label)
+ e1 <- phy$edge[, 1]
+ e2 <- phy$edge[, 2]
+ EL <- phy$edge.length
+ N <- length(e1)
+ xx <- numeric(phy$Nnode)
+ interns <- which(e2 > n)
+ ## we loop only on the internal edges, this assumes
+ ## that `xx' is already set with 0
+ for (i in interns) xx[e2[i] - n] <- xx[e1[i] - n] + EL[i]
+ depth <- xx[e1[N] - n] + EL[N]
+ xx <- depth - xx
+ names(xx) <-
+ if (is.null(phy$node.label)) (n + 1):(n + phy$Nnode)
+ else phy$node.label
+ xx
+}
diff --git a/R/cherry.R b/R/cherry.R
new file mode 100644
index 0000000..347465c
--- /dev/null
+++ b/R/cherry.R
@@ -0,0 +1,52 @@
+## cherry.R (2009-05-10)
+
+## Number of Cherries and Null Models of Trees
+
+## Copyright 2002-2009 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+cherry <- function(phy)
+{
+ if (!inherits(phy, "phylo")) stop('object "phy" is not of class "phylo"')
+ n <- length(phy$tip.label)
+ nb.node <- phy$Nnode
+ if (nb.node != n - 1) stop('"phy" is not fully dichotomous')
+ if (n < 4) stop("not enough tips in your phylogeny for this analysis")
+ cherry <- sum(tabulate(phy$edge[, 1][phy$edge[, 2] <= n]) == 2)
+ small.n <- n < 20
+ if (small.n) {
+ P.yule <- f.cherry.yule(n, cherry)
+ P.uniform <- f.cherry.uniform(n, cherry)
+ }
+ else {
+ P.yule <- 2*(1 - pnorm(abs(cherry - n/3)/sqrt(2*n/45)))
+ mu.unif <- n*(n - 1)/(2*(2*n - 5))
+ sigma2.unif <- n*(n - 1)*(n - 4)*(n - 5)/(2*(2*n - 5)^2 * (2*n -7))
+ P.uniform <- 2*(1 - pnorm(abs(cherry - mu.unif)/sqrt(sigma2.unif)))
+ }
+ cat("\nAnalysis of the Number of Cherries in a Tree\n\n")
+ cat("Phylogenetic tree:", deparse(substitute(phy)), "\n")
+ cat("Number of tips:", n, "\n")
+ cat("Number of cherries:", cherry, "\n\n")
+ cat("Null hypothesis: Yule model\n")
+ cat(" P-value =", round(P.yule, 4), "\n\n")
+ cat("Null hypothesis: uniform model\n")
+ cat(" P-value =", round(P.uniform, 4), "\n\n")
+ if (!small.n) cat("(P-values were computed using normal approximations)\n")
+}
+
+f.cherry.yule <- function(n, k)
+{
+ if (k == 0 || k > floor(n/2)) 0 else if (n == 4) if (k == 1) 2/3 else if (k == 2) 1/3 else 0
+ else (1 - 2*(k - 1)/(n - 1))*f.cherry.yule(n - 1, k - 1) +
+ 2*k/(n - 1)*f.cherry.yule(n - 1, k)
+}
+
+f.cherry.uniform <- function(n, k)
+{
+ if (k == 0 || k > floor(n/2)) 0 else if (n == 4) if (k == 1) 4/5 else if (k == 2) 1/5 else 0
+ else if (k == 1) 0 else (gamma(n + 1)*gamma(n - 2 + 1)*gamma(n - 4 + 1) * 2^(n-2*k)) /
+ (gamma(n - 2*k + 1)*gamma(2*n - 4 + 1)*gamma(k + 1)*gamma(k - 2 + 1))
+}
diff --git a/R/chronoMPL.R b/R/chronoMPL.R
new file mode 100644
index 0000000..211a8d5
--- /dev/null
+++ b/R/chronoMPL.R
@@ -0,0 +1,47 @@
+## chronoMPL.R (2007-08-29)
+
+## Molecular Dating with Mean Path Lengths
+
+## Copyright 2007 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+chronoMPL <- function(phy, se = TRUE, test = TRUE)
+{
+ if (!is.binary.tree(phy)) stop("the tree is not dichotomous.")
+ n <- length(phy$tip.label)
+ m <- phy$Nnode
+ N <- dim(phy$edge)[1]
+ obj <- reorder(phy, "postorder")
+ ndesc <- .C(node_depth, as.integer(n), as.integer(m),
+ as.integer(obj$edge[, 1]), as.integer(obj$edge[, 2]),
+ as.integer(N), double(n + m), 1L)[[6]]
+ s <- numeric(n + m) # sum of path lengths
+ if (se) ss <- s
+ if (test) Pval <- numeric(m)
+ for (i in seq(1, N - 1, 2)) {
+ j <- i + 1
+ a <- obj$edge[i, 2]
+ b <- obj$edge[j, 2]
+ o <- obj$edge[i, 1]
+ A <- s[a] + ndesc[a]*obj$edge.length[i]
+ B <- s[b] + ndesc[b]*obj$edge.length[j]
+ s[o] <- A + B
+ if (se)
+ ss[o] <- ss[a] + ndesc[a]^2 * obj$edge.length[i] + ss[b] +
+ ndesc[b]^2 * obj$edge.length[j]
+ if (test) {
+ z <- abs(A/ndesc[a] - B/ndesc[b])
+ tmp <- (ss[a] + ndesc[a]^2 * obj$edge.length[i])/ndesc[a]^2
+ tmp <- tmp + (ss[b] + ndesc[b]^2 * obj$edge.length[j])/ndesc[b]^2
+ z <- z/sqrt(tmp)
+ Pval[o - n] <- 2*pnorm(z, lower.tail = FALSE)
+ }
+ }
+ node.age <- s/ndesc
+ phy$edge.length <- node.age[phy$edge[, 1]] - node.age[phy$edge[, 2]]
+ if (se) attr(phy, "stderr") <- sqrt(ss[-(1:n)]/ndesc[-(1:n)]^2)
+ if (test) attr(phy, "Pval") <- Pval
+ phy
+}
diff --git a/R/chronopl.R b/R/chronopl.R
new file mode 100644
index 0000000..98f27fb
--- /dev/null
+++ b/R/chronopl.R
@@ -0,0 +1,254 @@
+## chronopl.R (2012-02-09)
+
+## Molecular Dating With Penalized Likelihood
+
+## Copyright 2005-2012 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+chronopl <-
+ function(phy, lambda, age.min = 1, age.max = NULL,
+ node = "root", S = 1, tol = 1e-8,
+ CV = FALSE, eval.max = 500, iter.max = 500, ...)
+{
+ n <- length(phy$tip.label)
+ ROOT <- n + 1L
+ if (identical(node, "root")) node <- ROOT
+ if (any(node <= n))
+ stop("node numbers should be greater than the number of tips")
+ zerobl <- which(phy$edge.length <= 0)
+ if (length(zerobl)) {
+ if (any(phy$edge[zerobl, 2] <= n))
+ stop("at least one terminal branch is of length zero:
+ you should remove it to have a meaningful estimation.")
+ else {
+ warning("at least one internal branch is of length zero:
+ it was collapsed and some nodes have been deleted.")
+ if (length(node) == 1 && node == ROOT)
+ phy <- di2multi(phy)
+ else {
+ tmp <- FALSE
+ if (is.null(phy$node.label)) {
+ tmp <- !tmp
+ phy$node.label <- paste("node", 1:phy$Nnode)
+ }
+ node.lab <- phy$node.label[node - n]
+ phy <- di2multi(phy)
+ node <- match(node.lab, phy$node.label) + n
+ if (tmp) phy$node.label <- NULL
+ }
+ }
+ }
+ m <- phy$Nnode
+ el <- phy$edge.length
+ e1 <- phy$edge[, 1L]
+ e2 <- phy$edge[, 2L]
+ N <- length(e1)
+ TIPS <- 1:n
+ EDGES <- 1:N
+
+ ini.rate <- el
+ el <- el/S
+
+ ## `basal' contains the indices of the basal edges
+ ## (ie, linked to the root):
+ basal <- which(e1 == ROOT)
+ Nbasal <- length(basal)
+
+ ## `ind' contains in its 1st column the index of all nonbasal
+ ## edges, and in its second column the index of the edges
+ ## where these edges come from (ie, this matrix contains pairs
+ ## of contiguous edges), eg:
+
+ ## ___b___ ind:
+ ## | | | |
+ ## ___a___| | b | a |
+ ## | | c | a |
+ ## |___c___ | | |
+
+ ind <- matrix(0L, N - Nbasal, 2)
+ ind[, 1] <- EDGES[-basal]
+ ind[, 2] <- match(e1[EDGES[-basal]], e2)
+
+ age <- numeric(n + m)
+
+#############################################################################
+### This bit sets 'ini.time' and should result in no negative branch lengths
+
+ seq.nod <- .Call("seq_root2tip", phy$edge, n, phy$Nnode, PACKAGE = "ape")
+
+ ini.time <- age
+ ini.time[ROOT:(n + m)] <- NA
+ ini.time[node] <- if (is.null(age.max)) age.min else (age.min + age.max) / 2
+
+ ## if no age given for the root, find one approximately:
+ if (is.na(ini.time[ROOT]))
+ ini.time[ROOT] <- if (is.null(age.max)) 3 * max(age.min) else 3 * max(age.max)
+
+ ISnotNA.ALL <- unlist(lapply(seq.nod, function(x) sum(!is.na(ini.time[x]))))
+ o <- order(ISnotNA.ALL, decreasing = TRUE)
+
+ for (y in seq.nod[o]) {
+ ISNA <- is.na(ini.time[y])
+ if (any(ISNA)) {
+ i <- 2L # we know the 1st value is not NA, so we start at the 2nd one
+ while (i <= length(y)) {
+ if (ISNA[i]) { # we stop at the next NA
+ j <- i + 1L
+ while (ISNA[j]) j <- j + 1L # look for the next non-NA
+ nb.val <- j - i
+ by <- (ini.time[y[i - 1L]] - ini.time[y[j]]) / (nb.val + 1)
+ ini.time[y[i:(j - 1L)]] <- ini.time[y[i - 1L]] - by * seq_len(nb.val)
+ i <- j + 1L
+ } else i <- i + 1L
+ }
+ }
+ }
+
+ real.edge.length <- ini.time[e1] - ini.time[e2]
+
+ if (any(real.edge.length <= 0))
+ stop("some initial branch lengths are zero or negative;
+ maybe you need to adjust the given dates -- see '?chronopl' for details")
+#############################################################################
+
+ ## because if (!is.null(age.max)), 'node' is modified,
+ ## so we copy it in case CV = TRUE:
+ node.bak <- node
+
+ ## `unknown.ages' will contain the index of the nodes of unknown age:
+ unknown.ages <- n + 1:m
+
+ ## define the bounds for the node ages:
+ lower <- rep(tol, length(unknown.ages))
+ upper <- rep(1/tol, length(unknown.ages))
+
+ if (!is.null(age.max)) { # are some nodes known within some intervals?
+ lower[node - n] <- age.min
+ upper[node - n] <- age.max
+ ## find nodes known within an interval:
+ interv <- which(age.min != age.max)
+ ## drop them from the 'node' since they will be estimated:
+ node <- node[-interv]
+ if (length(node)) age[node] <- age.min[-interv] # update 'age'
+ } else age[node] <- age.min
+
+ if (length(node)) {
+ unknown.ages <- unknown.ages[n - node] # 'n - node' is simplification for '-(node - n)'
+ lower <- lower[n - node]
+ upper <- upper[n - node]
+ }
+
+ ## `known.ages' contains the index of all nodes (internal and
+ ## terminal) of known age:
+ known.ages <- c(TIPS, node)
+
+ ## concatenate the bounds for the rates:
+ lower <- c(rep(tol, N), lower)
+ upper <- c(rep(1 - tol, N), upper)
+
+ minusploglik.gr <- function(rate, node.time) {
+ grad <- numeric(N + length(unknown.ages))
+ age[unknown.ages] <- node.time
+ real.edge.length <- age[e1] - age[e2]
+ if (any(real.edge.length < 0)) {
+ grad[] <- 0
+ return(grad)
+ }
+ ## gradient for the rates:
+ ## the parametric part can be calculated without a loop:
+ grad[EDGES] <- real.edge.length - el/rate
+ if (Nbasal == 2) { # the simpler formulae if there's a basal dichotomy
+ grad[basal[1]] <-
+ grad[basal[1]] + lambda*(rate[basal[1]] - rate[basal[2]])
+ grad[basal[2]] <-
+ grad[basal[2]] + lambda*(rate[basal[2]] - rate[basal[1]])
+ } else { # the general case
+ for (i in 1:Nbasal)
+ grad[basal[i]] <- grad[basal[i]] +
+ lambda*(2*rate[basal[i]]*(1 - 1/Nbasal) -
+ 2*sum(rate[basal[-i]])/Nbasal)/(Nbasal - 1)
+ }
+
+ for (i in EDGES) {
+ ii <- c(which(e2 == e1[i]), which(e1 == e2[i]))
+ if (!length(ii)) next
+ grad[i] <- grad[i] + lambda*(2*length(ii)*rate[i] - 2*sum(rate[ii]))
+ }
+
+ ## gradient for the 'node times'
+ for (i in 1:length(unknown.ages)) {
+ nd <- unknown.ages[i]
+ ii <- which(e1 == nd)
+ grad[i + N] <-
+ sum(rate[ii] - el[ii]/real.edge.length[ii])#, na.rm = TRUE)
+ if (nd != ROOT) {
+ ii <- which(e2 == nd)
+ grad[i + N] <- grad[i + N] -
+ rate[ii] + el[ii]/real.edge.length[ii]
+ }
+ }
+ grad
+ }
+
+ minusploglik <- function(rate, node.time) {
+ age[unknown.ages] <- node.time
+ real.edge.length <- age[e1] - age[e2]
+ if (any(real.edge.length < 0)) return(1e50)
+ B <- rate*real.edge.length
+ loglik <- sum(-B + el*log(B) - lfactorial(el))
+ -(loglik - lambda*(sum((rate[ind[, 1]] - rate[ind[, 2]])^2)
+ + var(rate[basal])))
+ }
+
+ out <- nlminb(c(ini.rate, ini.time[unknown.ages]),
+ function(p) minusploglik(p[EDGES], p[-EDGES]),
+ function(p) minusploglik.gr(p[EDGES], p[-EDGES]),
+ control = list(eval.max = eval.max, iter.max = iter.max, ...),
+ lower = lower, upper = upper)
+
+ attr(phy, "ploglik") <- -out$objective
+ attr(phy, "rates") <- out$par[EDGES]
+ attr(phy, "message") <- out$message
+ age[unknown.ages] <- out$par[-EDGES]
+ if (CV) ophy <- phy
+ phy$edge.length <- age[e1] - age[e2]
+ if (CV) attr(phy, "D2") <-
+ chronopl.cv(ophy, lambda, age.min, age.max, node.bak,
+ n, S, tol, eval.max, iter.max, ...)
+ phy
+}
+
+chronopl.cv <- function(ophy, lambda, age.min, age.max, nodes,
+ n, S, tol, eval.max, iter.max, ...)
+### ophy: the original phylogeny
+### n: number of tips
+### Note that we assume here that the order of the nodes
+### in node.label are not modified by the drop.tip operation
+{
+ cat("Doing cross-validation\n")
+ BT <- branching.times(ophy)
+ D2 <- numeric(n)
+
+ for (i in 1:n) {
+ cat("\r dropping tip ", i, " / ", n, sep = "")
+ tr <- drop.tip(ophy, i)
+ j <- which(ophy$edge[, 2] == i)
+ if (ophy$edge[j, 1] %in% nodes) {
+ k <- which(nodes == ophy$edge[j, 1])
+ node <- nodes[-k]
+ agemin <- age.min[-k]
+ agemax <- age.max[-k]
+ } else node <- nodes
+ if (length(node)) {
+ chr <- chronopl(tr, lambda, age.min, age.max, node,
+ S, tol, FALSE, eval.max, iter.max, ...)
+ tmp <-
+ if (Nnode(chr) == Nnode(ophy)) BT else BT[-(ophy$edge[j, 1] - n)]
+ D2[i] <- sum((tmp - branching.times(chr))^2 / tmp)
+ } else D2[i] <- 0
+ }
+ cat("\n")
+ D2
+}
diff --git a/R/chronos.R b/R/chronos.R
new file mode 100644
index 0000000..115cd19
--- /dev/null
+++ b/R/chronos.R
@@ -0,0 +1,476 @@
+## chronos.R (2013-01-03)
+
+## Molecular Dating With Penalized and Maximum Likelihood
+
+## Copyright 2013 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+.chronos.ctrl <-
+ list(tol = 1e-8, iter.max = 1e4, eval.max = 1e4, nb.rate.cat = 10,
+ dual.iter.max = 20)
+
+makeChronosCalib <-
+ function(phy, node = "root", age.min = 1, age.max = age.min,
+ interactive = FALSE, soft.bounds = FALSE)
+{
+ n <- Ntip(phy)
+ if (interactive) {
+ plot(phy)
+ cat("Click close to a node and enter the ages (right-click to exit)\n\n")
+ node <- integer()
+ age.min <- age.max <- numeric()
+ repeat {
+ ans <- identify(phy, quiet = TRUE)
+ if (is.null(ans)) break
+ NODE <- ans$nodes
+ nodelabels(node = NODE, col = "white", bg = "blue")
+ cat("constraints for node ", NODE, sep = "")
+ cat("\n youngest age: ")
+ AGE.MIN <- as.numeric(readLines(n = 1))
+ cat(" oldest age (ENTER if not applicable): ")
+ AGE.MAX <- as.numeric(readLines(n = 1))
+ node <- c(node, NODE)
+ age.min <- c(age.min, AGE.MIN)
+ age.max <- c(age.max, AGE.MAX)
+ }
+ s <- is.na(age.max)
+ if (any(s)) age.max[s] <- age.min[s]
+ } else {
+ if (identical(node, "root")) node <- n + 1L
+ }
+
+ if (any(node <= n))
+ stop("node numbers should be greater than the number of tips")
+
+ diff.age <- which(age.max < age.min)
+ if (length(diff.age)) {
+ msg <- "'old age' less than 'young age' for node"
+ if (length(diff.age) > 1) msg <- paste(msg, "s", sep = "")
+ stop(paste(msg, paste(node[diff.age], collapse = ", ")))
+ }
+
+ data.frame(node, age.min, age.max, soft.bounds = soft.bounds)
+}
+
+chronos.control <- function(...)
+{
+ dots <- list(...)
+ x <- .chronos.ctrl
+ if (length(dots)) {
+ chk.nms <- names(dots) %in% names(x)
+ if (any(!chk.nms)) {
+ warning("some control parameter names do not match: they were ignored")
+ dots <- dots[chk.nms]
+ }
+ x[names(dots)] <- dots
+ }
+ x
+}
+
+chronos <-
+ function(phy, lambda = 1, model = "correlated", quiet = FALSE,
+ calibration = makeChronosCalib(phy),
+ control = chronos.control())
+{
+ model <- match.arg(tolower(model), c("correlated", "relaxed", "discrete"))
+ n <- Ntip(phy)
+ ROOT <- n + 1L
+ m <- phy$Nnode
+ el <- phy$edge.length
+ if (any(el < 0)) stop("some branch lengths are negative")
+ e1 <- phy$edge[, 1L]
+ e2 <- phy$edge[, 2L]
+ N <- length(e1)
+ TIPS <- 1:n
+ EDGES <- 1:N
+
+ tol <- control$tol
+
+ node <- calibration$node
+ age.min <- calibration$age.min
+ age.max <- calibration$age.max
+
+ if (model == "correlated") {
+### `basal' contains the indices of the basal edges
+### (ie, linked to the root):
+ basal <- which(e1 == ROOT)
+ Nbasal <- length(basal)
+
+### 'ind1' contains the index of all nonbasal edges, and 'ind2' the
+### index of the edges where these edges come from (ie, they contain
+### pairs of contiguous edges), eg:
+
+### ___b___ ind1 ind2
+### | | || |
+### ___a___| | b || a |
+### | | c || a |
+### |___c___ | || |
+
+ ind1 <- EDGES[-basal]
+ ind2 <- match(e1[EDGES[-basal]], e2)
+ }
+
+ age <- numeric(n + m)
+
+### This bit sets 'ini.time' and should result in no negative branch lengths
+
+ if (!quiet) cat("\nSetting initial dates...\n")
+ seq.nod <- .Call(seq_root2tip, phy$edge, n, phy$Nnode)
+
+ ii <- 1L
+ repeat {
+ ini.time <- age
+ ini.time[ROOT:(n + m)] <- NA
+
+ ini.time[node] <-
+ if (is.null(age.max)) age.min
+ else runif(length(node), age.min, age.max) # (age.min + age.max) / 2
+
+ ## if no age given for the root, find one approximately:
+ if (is.na(ini.time[ROOT]))
+ ini.time[ROOT] <- if (is.null(age.max)) 3 * max(age.min) else 3 * max(age.max)
+
+ ISnotNA.ALL <- unlist(lapply(seq.nod, function(x) sum(!is.na(ini.time[x]))))
+ o <- order(ISnotNA.ALL, decreasing = TRUE)
+
+ for (y in seq.nod[o]) {
+ ISNA <- is.na(ini.time[y])
+ if (any(ISNA)) {
+ i <- 2L # we know the 1st value is not NA, so we start at the 2nd one
+ while (i <= length(y)) {
+ if (ISNA[i]) { # we stop at the next NA
+ j <- i + 1L
+ while (ISNA[j]) j <- j + 1L # look for the next non-NA
+ nb.val <- j - i
+ by <- (ini.time[y[i - 1L]] - ini.time[y[j]]) / (nb.val + 1)
+ ini.time[y[i:(j - 1L)]] <- ini.time[y[i - 1L]] - by * seq_len(nb.val)
+ i <- j + 1L
+ } else i <- i + 1L
+ }
+ }
+ }
+ if (all(ini.time[e1] - ini.time[e2] >= 0)) break
+ ii <- ii + 1L
+ if (ii > 1000)
+ stop("cannot find reasonable starting dates after 1000 tries:
+maybe you need to adjust the calibration dates")
+ }
+### 'ini.time' set
+
+ #ini.time[ROOT:(n+m)] <- branching.times(chr.dis)
+ ## ini.time[ROOT:(n+m)] <- ini.time[ROOT:(n+m)] + rnorm(m, 0, 5)
+ #print(ini.time)
+
+
+### Setting 'ini.rate'
+ ini.rate <- el/(ini.time[e1] - ini.time[e2])
+
+ if (model == "discrete") {
+ Nb.rates <- control$nb.rate.cat
+ minmax <- range(ini.rate)
+ if (Nb.rates == 1) {
+ ini.rate <- sum(minmax)/2
+ } else {
+ inc <- diff(minmax)/Nb.rates
+ ini.rate <- seq(minmax[1] + inc/2, minmax[2] - inc/2, inc)
+ ini.freq <- rep(1/Nb.rates, Nb.rates - 1)
+ lower.freq <- rep(0, Nb.rates - 1)
+ upper.freq <- rep(1, Nb.rates - 1)
+ }
+ } else Nb.rates <- N
+## 'ini.rate' set
+
+### Setting bounds for the node ages
+
+ ## `unknown.ages' will contain the index of the nodes of unknown age:
+ unknown.ages <- 1:m + n
+
+ ## initialize vectors for all nodes:
+ lower.age <- rep(tol, m)
+ upper.age <- rep(1/tol, m)
+
+ lower.age[node - n] <- age.min
+ upper.age[node - n] <- age.max
+
+ ## find nodes known within an interval:
+ ii <- which(age.min != age.max)
+ ## drop them from 'node' since they will be estimated:
+ if (length(ii)) {
+ node <- node[-ii]
+ if (length(node))
+ age[node] <- age.min[-ii] # update 'age'
+ } else age[node] <- age.min
+
+ ## finally adjust the 3 vectors:
+ if (length(node)) {
+ unknown.ages <- unknown.ages[n - node] # 'n - node' is simplification for '-(node - n)'
+ lower.age <- lower.age[n - node]
+ upper.age <- upper.age[n - node]
+ }
+### Bounds for the node ages set
+
+ ## 'known.ages' contains the index of all nodes
+ ## (internal and terminal) of known age:
+ known.ages <- c(TIPS, node)
+
+ ## the bounds for the rates:
+ lower.rate <- rep(tol, Nb.rates)
+ upper.rate <- rep(100 - tol, Nb.rates) # needs to be adjusted to higher values?
+
+### Gradient
+ degree_node <- tabulate(phy$edge)
+ eta_i <- degree_node[e1]
+ eta_i[e2 <= n] <- 1L
+ ## eta_i[i] is the number of contiguous branches for branch 'i'
+
+ ## use of a list of indices is slightly faster than an incidence matrix
+ ## and takes much less memory (60 Kb vs. 8 Mb for n = 500)
+ X <- vector("list", N)
+ for (i in EDGES) {
+ j <- integer()
+ if (e1[i] != ROOT) j <- c(j, which(e2 == e1[i]))
+ if (e2[i] >= n) j <- c(j, which(e1 == e2[i]))
+ X[[i]] <- j
+ }
+ ## X is a list whose i-th element gives the indices of the branches
+ ## that are contiguous to branch 'i'
+
+ ## D_ki and A_ki are defined in the SI of the paper
+ D_ki <- match(unknown.ages, e2)
+ A_ki <- lapply(unknown.ages, function(x) which(x == e1))
+
+ gradient.poisson <- function(rate, node.time) {
+ age[unknown.ages] <- node.time
+ real.edge.length <- age[e1] - age[e2]
+ #if (any(real.edge.length < 0))
+ # return(numeric(N + length(unknown.ages)))
+ ## gradient for the rates:
+ gr <- el/rate - real.edge.length
+
+ ## gradient for the dates:
+ tmp <- el/real.edge.length - rate
+ gr.dates <- sapply(A_ki, function(x) sum(tmp[x])) - tmp[D_ki]
+
+ c(gr, gr.dates)
+ }
+
+ ## gradient of the penalized lik (must be multiplied by -1 before calling nlminb)
+ gradient <-
+ switch(model,
+ "correlated" =
+ function(rate, node.time) {
+ gr <- gradient.poisson(rate, node.time)
+ #if (all(gr == 0)) return(gr)
+
+ ## contribution of the penalty for the rates:
+ gr[RATE] <- gr[RATE] - lambda * 2 * (eta_i * rate - sapply(X, function(x) sum(rate[x])))
+ ## the contribution of the root variance term:
+ if (Nbasal == 2) { # the simpler formulae if there's a basal dichotomy
+ i <- basal[1]
+ j <- basal[2]
+ gr[i] <- gr[i] - lambda * (rate[i] - rate[j])
+ gr[j] <- gr[j] - lambda * (rate[j] - rate[i])
+ } else { # the general case
+ for (i in 1:Nbasal)
+ j <- basal[i]
+ gr[j] <- gr[j] -
+ lambda*2*(rate[j]*(1 - 1/Nbasal) - sum(rate[basal[-i]])/Nbasal)/(Nbasal - 1)
+ }
+ gr
+ },
+ "relaxed" =
+ function(rate, node.time) {
+ gr <- gradient.poisson(rate, node.time)
+ #if (all(gr == 0)) return(gr)
+
+ ## contribution of the penalty for the rates:
+ mean.rate <- mean(rate)
+ ## rank(rate)/Nb.rates is the same than ecdf(rate)(rate) but faster
+ gr[RATE] <- gr[RATE] + lambda*2*dgamma(rate, mean.rate)*(rank(rate)/Nb.rates - pgamma(rate, mean.rate))
+ gr
+ },
+ "discrete" = NULL)
+
+ log.lik.poisson <- function(rate, node.time) {
+ age[unknown.ages] <- node.time
+ real.edge.length <- age[e1] - age[e2]
+ if (isTRUE(any(real.edge.length < 0))) return(-1e100)
+ B <- rate * real.edge.length
+ sum(el * log(B) - B - lfactorial(el))
+ }
+
+### penalized log-likelihood
+ penal.loglik <-
+ switch(model,
+ "correlated" =
+ function(rate, node.time) {
+ loglik <- log.lik.poisson(rate, node.time)
+ if (!is.finite(loglik)) return(-1e100)
+ loglik - lambda * (sum((rate[ind1] - rate[ind2])^2)
+ + var(rate[basal]))
+ },
+ "relaxed" =
+ function(rate, node.time) {
+ loglik <- log.lik.poisson(rate, node.time)
+ if (!is.finite(loglik)) return(-1e100)
+ mu <- mean(rate)
+ ## loglik - lambda * sum((1:N/N - pbeta(sort(rate), mu/(1 + mu), 1))^2) # avec loi beta
+ ## loglik - lambda * sum((1:N/N - pcauchy(sort(rate)))^2) # avec loi Cauchy
+ loglik - lambda * sum((1:N/N - pgamma(sort(rate), mean(rate)))^2) # avec loi Gamma
+ },
+ "discrete" =
+ if (Nb.rates == 1)
+ function(rate, node.time) log.lik.poisson(rate, node.time)
+ else function(rate, node.time, freq) {
+ if (isTRUE(sum(freq) > 1)) return(-1e100)
+ rate.freq <- sum(c(freq, 1 - sum(freq)) * rate)
+ log.lik.poisson(rate.freq, node.time)
+ })
+
+ opt.ctrl <- list(eval.max = control$eval.max, iter.max = control$iter.max)
+
+ ## the following capitalized vectors give the indices of
+ ## the parameters once they are concatenated in 'p'
+ RATE <- 1:Nb.rates
+ AGE <- Nb.rates + 1:length(unknown.ages)
+
+ if (model == "discrete") {
+ if (Nb.rates == 1) {
+ start.para <- c(ini.rate, ini.time[unknown.ages])
+ f <- function(p) -penal.loglik(p[RATE], p[AGE])
+ g <- NULL
+ LOW <- c(lower.rate, lower.age)
+ UP <- c(upper.rate, upper.age)
+ } else {
+ FREQ <- length(RATE) + length(AGE) + 1:(Nb.rates - 1)
+ start.para <- c(ini.rate, ini.time[unknown.ages], ini.freq)
+ f <- function(p) -penal.loglik(p[RATE], p[AGE], p[FREQ])
+ g <- NULL
+ LOW <- c(lower.rate, lower.age, lower.freq)
+ UP <- c(upper.rate, upper.age, upper.freq)
+ }
+ } else {
+ start.para <- c(ini.rate, ini.time[unknown.ages])
+ f <- function(p) -penal.loglik(p[RATE], p[AGE])
+ g <- function(p) -gradient(p[RATE], p[AGE])
+ LOW <- c(lower.rate, lower.age)
+ UP <- c(upper.rate, upper.age)
+ }
+
+ k <- length(LOW) # number of free parameters
+
+ if (!quiet) cat("Fitting in progress... get a first set of estimates\n")
+
+ out <- nlminb(start.para, f, g,
+ control = opt.ctrl, lower = LOW, upper = UP)
+
+ if (model == "discrete") {
+ if (Nb.rates == 1) {
+ f.rates <- function(p) -penal.loglik(p, current.ages)
+ f.ages <- function(p) -penal.loglik(current.rates, p)
+ } else {
+ f.rates <- function(p) -penal.loglik(p, current.ages, current.freqs)
+ f.ages <- function(p) -penal.loglik(current.rates, p, current.freqs)
+ f.freqs <- function(p) -penal.loglik(current.rates, current.ages, p)
+ g.freqs <- NULL
+ }
+ g.rates <- NULL
+ g.ages <- NULL
+ } else {
+ f.rates <- function(p) -penal.loglik(p, current.ages)
+ g.rates <- function(p) -gradient(p, current.ages)[RATE]
+ f.ages <- function(p) -penal.loglik(current.rates, p)
+ g.ages <- function(p) -gradient(current.rates, p)[AGE]
+ }
+
+ current.ploglik <- -out$objective
+ current.rates <- out$par[RATE]
+ current.ages <- out$par[AGE]
+ if (model == "discrete" && Nb.rates > 1) current.freqs <- out$par[FREQ]
+
+ dual.iter.max <- control$dual.iter.max
+ i <- 0L
+
+ if (!quiet) cat(" Penalised log-lik =", current.ploglik, "\n")
+
+ repeat {
+ if (dual.iter.max < 1) break
+ if (!quiet) cat("Optimising rates...")
+ out.rates <- nlminb(current.rates, f.rates, g.rates,# h.rates,
+ control = list(eval.max = 1000, iter.max = 1000,
+ step.min = 1e-8, step.max = .1),
+ lower = lower.rate, upper = upper.rate)
+ new.rates <- out.rates$par
+ if (-out.rates$objective > current.ploglik)
+ current.rates <- new.rates
+
+ if (model == "discrete" && Nb.rates > 1) {
+ if (!quiet) cat(" frequencies...")
+ out.freqs <- nlminb(current.freqs, f.freqs,
+ control = list(eval.max = 1000, iter.max = 1000,
+ step.min = .001, step.max = .5),
+ lower = lower.freq, upper = upper.freq)
+ new.freqs <- out.freqs$par
+ }
+
+ if (!quiet) cat(" dates...")
+ out.ages <- nlminb(current.ages, f.ages, g.ages,# h.ages,
+ control = list(eval.max = 1000, iter.max = 1000,
+ step.min = .001, step.max = 100),
+ lower = lower.age, upper = upper.age)
+ new.ploglik <- -out.ages$objective
+
+ if (!quiet) cat("", current.ploglik, "\n")
+
+ if (new.ploglik - current.ploglik > 1e-6 && i <= dual.iter.max) {
+ current.ploglik <- new.ploglik
+ current.rates <- new.rates
+ current.ages <- out.ages$par
+ if (model == "discrete" && Nb.rates > 1) current.freqs <- new.freqs
+ out <- out.ages
+ i <- i + 1L
+ } else break
+ }
+
+ if (!quiet) cat("\nDone.\n")
+
+# browser()
+
+ if (model == "discrete") {
+ rate.freq <-
+ if (Nb.rates == 1) current.rates
+ else mean(c(current.freqs, 1 - sum(current.freqs)) * current.rates)
+ logLik <- log.lik.poisson(rate.freq, current.ages)
+ PHIIC <- list(logLik = logLik, k = k, PHIIC = - 2 * logLik + 2 * k)
+ } else {
+ logLik <- log.lik.poisson(current.rates, current.ages)
+ PHI <- switch(model,
+ "correlated" = (current.rates[ind1] - current.rates[ind2])^2 + var(current.rates[basal]),
+ "relaxed" = (1:N/N - pgamma(sort(current.rates), mean(current.rates)))^2) # avec loi Gamma
+ PHIIC <- list(logLik = logLik, k = k, lambda = lambda,
+ PHIIC = - 2 * logLik + 2 * k + lambda * svd(PHI)$d)
+ }
+
+ attr(phy, "call") <- match.call()
+ attr(phy, "ploglik") <- -out$objective
+ attr(phy, "rates") <- current.rates #out$par[EDGES]
+ if (model == "discrete" && Nb.rates > 1)
+ attr(phy, "frequencies") <- current.freqs
+ attr(phy, "message") <- out$message
+ attr(phy, "PHIIC") <- PHIIC
+ age[unknown.ages] <- current.ages #out$par[-EDGES]
+ phy$edge.length <- age[e1] - age[e2]
+ class(phy) <- c("chronos", class(phy))
+ phy
+}
+
+print.chronos <- function(x, ...)
+{
+ cat("\n Chronogram\n\n")
+ cat("Call: ")
+ print(attr(x, "call"))
+ cat("\n")
+ NextMethod("print")
+}
diff --git a/R/clustal.R b/R/clustal.R
new file mode 100644
index 0000000..c777945
--- /dev/null
+++ b/R/clustal.R
@@ -0,0 +1,78 @@
+## clustal.R (2012-11-28)
+
+## Multiple Sequence Alignment with External Applications
+
+## Copyright 2011-2012 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+clustal <- function(x, pw.gapopen = 10, pw.gapext = 0.1,
+ gapopen = 10, gapext = 0.2, exec = NULL,
+ MoreArgs = "", quiet = TRUE, original.ordering = TRUE)
+{
+ os <- Sys.info()[1]
+ if (is.null(exec)) {
+ if (os == "Linux") exec <- "clustalw"
+ if (os == "Darwin") exec <- "clustalw2"
+ if (os == "Windows") shortPathName("C:/Program Files/ClustalW2/clustalw2.exe")
+ }
+
+ if (missing(x)) {
+ system(paste(exec, "-help"))
+ return(invisible(NULL))
+ }
+
+ d <- tempdir()
+ inf <- paste(d, "input_clustal.fas", sep = "/")
+ outf <- paste(d, "input_clustal.aln", sep = "/")
+ write.dna(x, inf, "fasta")
+ prefix <- c("-INFILE", "-PWGAPOPEN", "-PWGAPEXT", "-GAPOPEN", "-GAPEXT")
+ suffix <- c(inf, pw.gapopen, pw.gapext, gapopen, gapext)
+ opts <- paste(prefix, suffix, sep = "=", collapse = " ")
+ opts <- paste(opts, MoreArgs)
+ system(paste(exec, opts), ignore.stdout = quiet)
+ res <- read.dna(outf, "clustal")
+ if (original.ordering) res <- res[labels(x), ]
+ res
+}
+
+muscle <- function(x, exec = "muscle", MoreArgs = "", quiet = TRUE, original.ordering = TRUE)
+{
+ if (missing(x)) {
+ system(exec)
+ return(invisible(NULL))
+ }
+
+ d <- tempdir()
+ inf <- paste(d, "input_muscle.fas", sep = "/")
+ outf <- paste(d, "output_muscle.fas", sep = "/")
+ write.dna(x, inf, "fasta")
+ opts <- paste("-in", inf, "-out", outf)
+ if (quiet) opts <- paste(opts, "-quiet")
+ opts <- paste(opts, MoreArgs)
+ system(paste(exec, opts))
+ res <- read.dna(outf, "fasta")
+ if (original.ordering) res <- res[labels(x), ]
+ res
+}
+
+tcoffee <- function(x, exec = "t_coffee", MoreArgs = "", quiet = TRUE, original.ordering = TRUE)
+{
+ if (missing(x)) {
+ system(exec)
+ return(invisible(NULL))
+ }
+
+ d <- tempdir()
+ od <- setwd(d)
+ on.exit(setwd(od))
+ inf <- "input_tcoffee.fas"
+ write.dna(x, inf, "fasta")
+ opts <- paste(inf, MoreArgs)
+ if (quiet) opts <- paste(opts, "-quiet=nothing")
+ system(paste(exec, opts))
+ res <- read.dna("input_tcoffee.aln", "clustal")
+ if (original.ordering) res <- res[labels(x), ]
+ res
+}
diff --git a/R/coalescent.intervals.R b/R/coalescent.intervals.R
new file mode 100644
index 0000000..d73bb76
--- /dev/null
+++ b/R/coalescent.intervals.R
@@ -0,0 +1,56 @@
+## coalescent.intervals.R (2002-09-12)
+
+## Constructs objects with information on coalescent intervals
+
+## Copyright 2002 Korbinian Strimmer
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+coalescent.intervals <- function(x) UseMethod("coalescent.intervals")
+
+# set up coalescent interval object (from NH tree)
+coalescent.intervals.phylo <- function(x)
+{
+ if (class(x) != "phylo") stop("object \"x\" is not of class \"phylo\"")
+
+ # ensure we have a BINARY tree
+ if (!is.binary.tree(x)) stop("object \"x\" is not a binary tree")
+ # ordered branching times
+ t <- sort(branching.times(x))
+ lt <- length(t)
+
+ # interval widths
+ w <- numeric(lt)
+ w[1] <- t[1]
+ for (i in 2:lt) w[i] <- t[i] - t[i - 1]
+
+ l <- (lt+1):2 # number of lineages
+
+ obj <- list(
+ lineages=l,
+ interval.length=w,
+ interval.count=lt,
+ total.depth =sum(w))
+ class(obj) <- "coalescentIntervals"
+ return(obj)
+}
+
+
+# set up coalescent interval object from vector of interval length
+coalescent.intervals.default <- function(x)
+{
+ if (!is.vector(x)) stop("argument \"x\" is not a vector of interval lengths")
+
+ # x = list of the widths of each interval
+ lt <- length(x)
+ l <- (lt+1):2 # number of lineages at the beginning of each interval
+
+ obj <- list(
+ lineages=l,
+ interval.length=x,
+ interval.count=lt,
+ total.depth =sum(x))
+ class(obj) <- "coalescentIntervals"
+ return(obj)
+}
diff --git a/R/collapse.singles.R b/R/collapse.singles.R
new file mode 100644
index 0000000..bbde0a1
--- /dev/null
+++ b/R/collapse.singles.R
@@ -0,0 +1,52 @@
+## collapse.singles.R (2010-07-23)
+
+## Collapse "Single" Nodes
+
+## Copyright 2006 Ben Bolker
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+collapse.singles <- function(tree)
+{
+ elen <- tree$edge.length
+ xmat <- tree$edge
+ ## added by Elizabeth Purdom (2008-06-19):
+ node.lab <- tree$node.label
+ nnode <- tree$Nnode
+ ntip <- length(tree$tip.label)
+ ## end
+ singles <- NA
+ while (length(singles) > 0) {
+ ## changed by EP to make it slightly more efficient:
+ ## tx <- table(xmat[xmat < 0])
+ ## singles <- as.numeric(names(tx)[tx < 3])
+ tx <- tabulate(xmat[, 1])
+ singles <- which(tx == 1)
+ ## END
+ if (length(singles) > 0) {
+ i <- singles[1]
+ prev.node <- which(xmat[, 2] == i)
+ next.node <- which(xmat[, 1] == i)
+ xmat[prev.node, 2] <- xmat[next.node, 2]
+ xmat <- xmat[xmat[, 1] != i, ] # drop
+ ## changed by EP for the new coding of "phylo" (2006-10-05):
+ ## xmat[xmat < i] <- xmat[xmat < i] + 1 ## adjust indices
+ xmat[xmat > i] <- xmat[xmat > i] - 1L ## adjust indices # changed '1' by '1L' (2010-07-23)
+ ## END
+ elen[prev.node] <- elen[prev.node] + elen[next.node]
+ ## added by Elizabeth Purdom (2008-06-19):
+ if (!is.null(node.lab)) node.lab <- node.lab[-c(i - ntip)]
+ nnode <- nnode - 1L
+ ## end
+ elen <- elen[-next.node]
+ }
+ }
+ tree$edge <- xmat
+ tree$edge.length <- elen
+ ## added by Elizabeth Purdom (2008-06-19):
+ tree$node.label <- node.lab
+ tree$Nnode <- nnode
+ ## end
+ tree
+}
diff --git a/R/collapsed.intervals.R b/R/collapsed.intervals.R
new file mode 100644
index 0000000..fdbacd7
--- /dev/null
+++ b/R/collapsed.intervals.R
@@ -0,0 +1,57 @@
+## collapsed.intervals.R (2002-09-12)
+
+## Collapsed coalescent intervals (e.g. for the skyline plot)
+
+## Copyright 2002 Korbinian Strimmer
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+# construct collapsed intervals from coalescent intervals
+collapsed.intervals <- function(ci, epsilon=0.0)
+{
+ if (class(ci) != "coalescentIntervals")
+ stop("object \"ci\" is not of class \"coalescentIntervals\"")
+
+ sz <- ci$interval.length
+ lsz <- length(sz)
+ idx <- c <- 1:lsz
+
+ p <- 1
+ w <- 0
+
+ # starting from tips collapes intervals
+ # until total size is >= epsilon
+ for (i in 1:lsz)
+ {
+ idx[[i]] <- p
+ w <- w + sz[[i]]
+ if (w >= epsilon)
+ {
+ p <- p+1
+ w <- 0
+ }
+ }
+
+ # if last interval is smaller than epsilon merge
+ # with second last interval
+ lastInterval <- idx==p
+ if ( sum(sz[lastInterval]) < epsilon )
+ {
+ p <- p-1
+ idx[lastInterval] <- p
+ }
+
+ obj <- list(
+ lineages=ci$lineages,
+ interval.length=ci$interval.length,
+ collapsed.interval=idx, # collapsed intervals (via reference)
+ interval.count=ci$interval.count,
+ collapsed.interval.count = idx[[ci$interval.count]],
+ total.depth =ci$total.depth,
+ epsilon = epsilon
+ )
+ class(obj) <- "collapsedIntervals"
+
+ return(obj)
+}
diff --git a/R/compar.gee.R b/R/compar.gee.R
new file mode 100644
index 0000000..5edec9b
--- /dev/null
+++ b/R/compar.gee.R
@@ -0,0 +1,169 @@
+## compar.gee.R (2013-12-19)
+
+## Comparative Analysis with GEEs
+
+## Copyright 2002-2013 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+compar.gee <-
+ function(formula, data = NULL, family = gaussian, phy,
+ corStruct, scale.fix = FALSE, scale.value = 1)
+{
+ library(gee)
+
+ if (!missing(corStruct)) {
+ if (!missing(phy))
+ warning("the phylogeny was ignored because you gave a 'corStruct' object")
+ R <- vcv(corStruct, corr = TRUE)
+ } else {
+ R <- vcv(phy, corr = TRUE)
+ }
+
+ if (is.null(data)) data <- parent.frame()
+ else {
+ nmsR <- rownames(R)
+ if (!identical(rownames(data), nmsR)) {
+ if (!any(is.na(match(rownames(data), nmsR))))
+ data <- data[nmsR, ]
+ else {
+ msg <- if (missing(corStruct))
+ "the tip labels of the tree" else "those of the correlation structure"
+ msg <- paste("the rownames of the data.frame and", msg,
+ "do not match: the former were ignored in the analysis")
+ warning(msg)
+ }
+ }
+ }
+
+ effect.assign <- attr(model.matrix(formula, data = data), "assign")
+
+ for (i in all.vars(formula)) {
+ if (any(is.na(eval(parse(text = i), envir = data))))
+ stop("the present method cannot be used with missing data: you may consider removing the species with missing data from your tree with the function 'drop.tip'.")
+ }
+
+ id <- rep(1, dim(R)[1])
+ geemod <- do.call("gee", list(formula, id, data = data, family = family, R = R,
+ corstr = "fixed", scale.fix = scale.fix,
+ scale.value = scale.value))
+ W <- geemod$naive.variance
+ fname <-
+ if (is.function(family)) deparse(substitute(family)) else if (is.list(family)) family$family else family
+ if (fname == "binomial")
+ W <- summary(glm(formula, family = quasibinomial, data = data))$cov.scaled
+ N <- geemod$nobs
+ ## <FIXME>
+ ## maybe need to refine below in case of non-Brownian corStruct
+ if (!missing(corStruct)) phy <- attr(corStruct, "tree")
+ dfP <- sum(phy$edge.length)*N / sum(diag(vcv(phy))) # need the variances
+ ## </FIXME>
+
+ ## compute QIC:
+ Y <- geemod$y
+ MU <- geemod$fitted.values
+ Qlik <- switch(fname,
+ "gaussian" = -sum((Y - MU)^2)/2,
+ "binomial" = sum(Y*log(MU/(1 - MU)) + log(1 - MU)),
+ "poisson" = sum(Y*log(MU) - MU),
+ "Gamma" = sum(Y/MU + log(MU)),
+ "inverse.gaussian" = sum(-Y/(2*MU^2) + 1/MU))
+ Ai <- do.call("gee", list(formula, id, data = data, family = family,
+ corstr = "independence", scale.fix = scale.fix,
+ scale.value = scale.value))$naive.variance
+ QIC <- -2*Qlik + 2*sum(diag(solve(Ai) %*% W))
+
+ obj <- list(call = match.call(),
+ effect.assign = effect.assign,
+ nobs = N,
+ QIC = QIC,
+ coefficients = geemod$coefficients,
+ residuals = geemod$residuals,
+ fitted.values = MU,
+ family = geemod$family$family,
+ link = geemod$family$link,
+ scale = geemod$scale,
+ W = W,
+ dfP = dfP)
+ class(obj) <- "compar.gee"
+ obj
+}
+
+print.compar.gee <- function(x, ...)
+{
+ nas <- is.na(x$coef)
+ coef <- x$coef[!nas]
+ cnames <- names(coef)
+ coef <- matrix(rep(coef, 4), ncol = 4)
+ dimnames(coef) <- list(cnames,
+ c("Estimate", "S.E.", "t", "Pr(T > |t|)"))
+ df <- x$dfP - dim(coef)[1]
+ coef[, 2] <- sqrt(diag(x$W))
+ coef[, 3] <- coef[, 1]/coef[, 2]
+ if (df < 0) {
+ warning("not enough degrees of freedom to compute P-values.")
+ coef[, 4] <- NA
+ } else coef[, 4] <- 2 * (1 - pt(abs(coef[, 3]), df))
+ residu <- quantile(as.vector(x$residuals))
+ names(residu) <- c("Min", "1Q", "Median", "3Q", "Max")
+ cat("Call: ")
+ print(x$call)
+ cat("Number of observations: ", x$nobs, "\n")
+ cat("Model:\n")
+ cat(" Link:", x$link, "\n")
+ cat(" Variance to Mean Relation:", x$family, "\n")
+ cat("\nQIC:", x$QIC, "\n")
+ cat("\nSummary of Residuals:\n")
+ print(residu)
+ if (any(nas))
+ cat("\n\nCoefficients: (", sum(nas), " not defined because of singularities)\n",
+ sep = "")
+ else cat("\n\nCoefficients:\n")
+ print(coef)
+ cat("\nEstimated Scale Parameter: ", x$scale)
+ cat("\n\"Phylogenetic\" df (dfP): ", x$dfP, "\n")
+}
+
+drop1.compar.gee <- function(object, scope, quiet = FALSE, ...)
+{
+ fm <- formula(object$call)
+ trm <- terms(fm)
+ z <- attr(trm, "term.labels")
+ ind <- object$effect.assign
+ n <- length(z)
+ ans <- matrix(NA, n, 3)
+ for (i in 1:n) {
+ wh <- which(ind == i)
+ ans[i, 1] <- length(wh)
+ ans[i, 2] <- t(object$coefficients[wh]) %*%
+ solve(object$W[wh, wh]) %*% object$coefficients[wh]
+ }
+ df <- object$dfP - length(object$coefficients)
+ if (df < 0) warning("not enough degrees of freedom to compute P-values.")
+ else ans[, 3] <- pf(ans[, 2], ans[, 1], df, lower.tail = FALSE)
+ colnames(ans) <- c("df", "F", "Pr(>F)")
+ rownames(ans) <- z
+ if (any(attr(trm, "order") > 1) && !quiet)
+ warning("there is at least one interaction term in your model:
+you should be careful when interpreting the significance of the main effects.")
+ class(ans) <- "anova"
+ attr(ans, "heading") <- paste("Single term deletions\n\n Model:",
+ as.character(as.expression(fm)), "\n")
+ ans
+}
+
+predict.compar.gee <-
+ function(object, newdata = NULL, type = c("link", "response"), ...)
+{
+ type <- match.arg(type)
+ pred <- if (is.null(newdata)) object$fitted.values else {
+ frm <- formula(object$call$formula)[-2]
+ X <- model.matrix(frm, data = newdata)
+ beta <- object$coefficients
+ X[, names(beta), drop = FALSE] %*% beta
+ }
+ if (type == "link") return(pred)
+ f <- match.fun(object$family)
+ f(link = object$link)$linkinv(pred)
+}
diff --git a/R/compar.lynch.R b/R/compar.lynch.R
new file mode 100644
index 0000000..39ba764
--- /dev/null
+++ b/R/compar.lynch.R
@@ -0,0 +1,74 @@
+## compar.lynch.R (2002-08-28)
+
+## Lynch's Comparative Method
+
+## Copyright 2002 Julien Claude
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+compar.lynch <- function(x, G, eps = 1e-4)
+{
+ if (is.vector(x) || is.data.frame(x)) x <- as.matrix(x)
+ alea <- runif(1, 0, 1)
+ z <- as.vector(x)
+ uz <- apply(x, 2, mean)
+ vcvz <- var(x)
+ vz <- diag(vcvz)
+ nsp <- nrow(x)
+ k <- ncol(x)
+ X1 <- matrix(0, k, k)
+ diag(X1) <- 1
+ I <- matrix(0, nsp, nsp)
+ diag(I) <- 1
+ vara <- trvare <- matrix(NA, k, k)
+ nsp1 <- rep(1, nsp)
+ X <- X1 %x% nsp1
+ compteur <- 0
+ vara <- A0 <- alea * vcvz
+ vare <- E0 <- (1 - alea) * vcvz
+ newu <- u0 <- uz
+ Ginv <- solve(G)
+ V0 <- vcvz %x% G
+ a0 <- e0 <- matrix(0, nsp, k)
+ a1 <- e1 <- matrix(1, nsp, k)
+ while (any(abs((rbind(a1, e1) - rbind(a0, e0))) > eps)) {
+ a1 <- a0
+ e1 <- e0
+ compteur <- compteur + 1
+ Rinv <- solve(E0 %x% I)
+ Dinv <- solve(A0 %x% G)
+ info <- solve(Rinv + Dinv)
+ newa <- solve(Rinv + Dinv) %*% Rinv %*% (z - X %*% u0)
+ newe <- z - X %*% u0 - newa
+ e0 <- mnewe <- matrix(newe, nsp, k)
+ a0 <- mnewa <- matrix(newa, nsp, k)
+
+ for (i in 1:k) {
+ for (j in 1:k) {
+ trvare[i, j] <- sum(diag(info[(((i - 1) * nsp) + 1):(i * nsp),
+ (((j - 1) * nsp) + 1):(j * nsp)]))}
+ }
+ vare <- ((nsp - 1) * var(mnewe) + trvare) / nsp
+
+ for (i in 1:k) {
+ for (j in 1:k) {
+ vara[i, j] <- (t(mnewa[, i]) %*% Ginv %*% mnewa[, j] +
+ sum(diag(Ginv %*%
+ info[(((i - 1) * nsp) + 1):(i * nsp),
+ (((j - 1) * nsp) + 1):(j * nsp)]))) / nsp
+ }
+ }
+
+ newu <- apply(x - mnewa, 2, mean)
+ V <- vara %x% G + vare %x% I
+
+ p <- (2 * pi)^(-nsp) * det(V)^(-0.5) *
+ exp(-0.5 * t(z - (X %*% newu)) %*% solve(V) %*% (z - (X %*% newu)))
+ E0 <- vare
+ A0 <- vara
+ u0 <- newu
+ }
+ dimnames(vare) <- dimnames(vara)
+ list(vare = vare, vara = vara, A = mnewa, E = mnewe, u = newu, lik = log(p))
+}
diff --git a/R/compar.ou.R b/R/compar.ou.R
new file mode 100644
index 0000000..ed3f38b
--- /dev/null
+++ b/R/compar.ou.R
@@ -0,0 +1,79 @@
+## compar.ou.R (2010-11-04)
+
+## Ornstein--Uhlenbeck Model for Continuous Characters
+
+## Copyright 2005-2010 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+compar.ou <- function(x, phy, node = NULL, alpha = NULL)
+{
+ if (!inherits(phy, "phylo"))
+ stop('object "phy" is not of class "phylo".')
+ if (!is.numeric(x)) stop("'x' must be numeric.")
+ if (!is.null(names(x))) {
+ if (all(names(x) %in% phy$tip.label)) x <- x[phy$tip.label]
+ else warning('the names of argument "x" and the tip labels of the tree did not match: the former were ignored in the analysis.')
+ }
+ n <- length(phy$tip.label)
+ root <- n + 1L
+ if (is.null(node)) node <- numeric(0)
+ if (is.character(node)) {
+ if (is.null(phy$node.label))
+ stop("argument 'node' is character but 'phy' has no node labels")
+ node <- match(node, phy$node.label) + n
+ phy$node.label <- NULL
+ }
+ if (root %in% node) node <- node[-1]
+ bt <- branching.times(phy)
+ Tmax <- bt[1]
+ Wend <- matrix(0, n, length(node) + 1)
+ colnames(Wend) <- c(names(sort(bt[node - n])), as.character(root))
+ Wstart <- Wend
+ Wstart[, ncol(Wstart)] <- Tmax
+ root2tip <- .Call(seq_root2tip, phy$edge, n, phy$Nnode)
+ for (i in 1:n) {
+ last.change <- names(Tmax)
+ for (j in root2tip[[i]]) {
+ if (j %in% node) {
+ jb <- as.character(j)
+ Wend[i, last.change] <- Wstart[i, jb] <- bt[jb]
+ last.change <- jb
+ }
+ }
+ }
+ W <- cophenetic.phylo(phy)
+ dev <- function(p) {
+ alpha <- p[1]
+ sigma2 <- p[2]
+ if (sigma2 <= 0) return(1e100)
+ theta <- p[-(1:2)]
+ ## fixed a bug below: must be '%*% theta' instead of '* theta' (2010-03-15)
+ M <- rowSums((exp(-alpha * Wend) - exp(-alpha * Wstart)) %*% theta)
+ V <- exp(-alpha * W) * (1 - exp(-2 * alpha * (Tmax - W/2)))
+ R <- chol(V) # correction by Cecile Ane (2010-11-04)
+ n * log(2 * pi * sigma2) + 2 * sum(log(diag(R))) +
+ (t(x - M) %*% chol2inv(R) %*% (x - M)) / sigma2
+ }
+
+ out <- if (is.null(alpha))
+ nlm(function(p) dev(p),
+ p = c(0.1, 1, rep(mean(x), ncol(Wstart))), hessian = TRUE)
+ else nlm(function(p) dev(c(alpha, p)),
+ p = c(1, rep(mean(x), ncol(Wstart))), hessian = TRUE)
+
+ ## if alpha is estimated it may be that the Hessian matrix has the
+ ## corresponding column and row filled with 0, making solve() fail
+ se <- if (is.null(alpha) && all(out$hessian[1, ] == 0))
+ c(NA, sqrt(diag(solve(out$hessian[-1, -1]))))
+ else sqrt(diag(solve(out$hessian)))
+
+ para <- cbind(out$estimate, se)
+ nms <- c("sigma2", paste("theta", 1:ncol(Wstart), sep = ""))
+ if (is.null(alpha)) nms <- c("alpha", nms)
+ dimnames(para) <- list(nms, c("estimate", "stderr"))
+ obj <- list(deviance = out$minimum, para = para, call = match.call())
+ class(obj) <- "compar.ou"
+ obj
+}
diff --git a/R/compute.brtime.R b/R/compute.brtime.R
new file mode 100644
index 0000000..e3df84d
--- /dev/null
+++ b/R/compute.brtime.R
@@ -0,0 +1,55 @@
+## compute.brtime.R (2012-03-02)
+
+## Compute and Set Branching Times
+
+## Copyright 2011-2012 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+compute.brtime <-
+ function(phy, method = "coalescent", force.positive = NULL)
+{
+ if (!inherits(phy, "phylo"))
+ stop('object "phy" is not of class "phylo"')
+ n <- length(phy$tip.label)
+ m <- phy$Nnode
+ N <- Nedge(phy)
+
+ ## x: branching times (aka, node ages, depths, or heights)
+
+ if (identical(method, "coalescent")) { # the default
+ x <- 2 * rexp(m)/(as.double((m + 1):2) * as.double(m:1))
+ ## x <- 2 * rexp(n - 1)/(as.double(n:2) * as.double((n - 1):1))
+ if (is.null(force.positive)) force.positive <- TRUE
+ } else if (is.numeric(method)) {
+ x <- as.vector(method)
+ if (length(x) != m)
+ stop("number of branching times given is not equal to the number of nodes")
+ if (is.null(force.positive))
+ force.positive <- FALSE
+ }
+
+ y <- c(rep(0, n), x) # for all nodes (terminal and internal)
+
+ e1 <- phy$edge[, 1L] # local copies of the pointers
+ e2 <- phy$edge[, 2L] #
+
+ if (force.positive) {
+ o <- .Call(seq_root2tip, phy$edge, n, m)
+ list.nodes <- list(n + 1L)
+ i <- 2L
+ repeat {
+ z <- sapply(o, "[", i)
+ z <- unique(z[!(z <= n | is.na(z))])
+ if (!length(z)) break
+ list.nodes[[i]] <- z
+ i <- i + 1L
+ }
+ nodes <- unlist(lapply(list.nodes, function(x) x[sample(length(x))]))
+ y[nodes] <- sort(x, decreasing = TRUE)
+ }
+
+ phy$edge.length <- y[e1] - y[e2]
+ phy
+}
diff --git a/R/cophenetic.phylo.R b/R/cophenetic.phylo.R
new file mode 100644
index 0000000..2a4a892
--- /dev/null
+++ b/R/cophenetic.phylo.R
@@ -0,0 +1,32 @@
+## cophenetic.phylo.R (2012-08-14)
+
+## Pairwise Distances from a Phylogenetic Tree
+
+## Copyright 2006-2012 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+dist.nodes <- function(x)
+{
+ x <- reorder(x) # required for the C code
+ n <- Ntip(x)
+ m <- x$Nnode
+ nm <- n + m
+
+ d <- .C(dist_nodes, as.integer(n), as.integer(m),
+ as.integer(x$edge[, 1] - 1L), as.integer(x$edge[, 2] - 1L),
+ as.double(x$edge.length), as.integer(Nedge(x)),
+ double(nm * nm), NAOK = TRUE)[[7]]
+ dim(d) <- c(nm, nm)
+ dimnames(d) <- list(1:nm, 1:nm)
+ d
+}
+
+cophenetic.phylo <- function(x)
+{
+ n <- length(x$tip.label)
+ ans <- dist.nodes(x)[1:n, 1:n]
+ dimnames(ans)[1:2] <- list(x$tip.label)
+ ans
+}
diff --git a/R/cophyloplot.R b/R/cophyloplot.R
new file mode 100644
index 0000000..29e5b3c
--- /dev/null
+++ b/R/cophyloplot.R
@@ -0,0 +1,174 @@
+## cophyloplot.R (2012-02-14)
+
+## Plots two phylogenetic trees face to
+## face with the links between the tips
+
+## Copyright 2008-2010 Damien de Vienne
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+cophyloplot <-
+ function(x, y, assoc = NULL, use.edge.length = FALSE, space = 0,
+ length.line = 1, gap = 2, type = "phylogram", rotate = FALSE,
+ col = par("fg"), lwd = par("lwd"), lty = par("lty"),
+ show.tip.label = TRUE, font = 3, ...)
+{
+ if (is.null(assoc)) {
+ assoc <- matrix(ncol = 2)
+ print("No association matrix specified. Links will be omitted.")
+ }
+ if (rotate == TRUE) {
+ cat("\n Click on a node to rotate (right click to exit)\n\n")
+ repeat {
+ res <- plotCophylo2(x, y, assoc = assoc, use.edge.length = use.edge.length,
+ space = space, length.line = length.line, gap = gap,
+ type = type, return = TRUE, col = col, lwd=lwd, lty=lty, show.tip.label = show.tip.label,
+ font = font)
+ click <- identify(res$c[, 1], res$c[, 2], n = 1)
+ if (click < length(res$a[, 1]) + 1) {
+ if (click > res$N.tip.x)
+ x <- rotate(x, click)
+ } else if (click < length(res$c[, 1]) + 1) {
+ if (click > length(res$a[, 1]) + res$N.tip.y)
+ y <- rotate(y, click - length(res$a[, 1]))
+ }
+ }
+ on.exit(print("done"))
+ }
+ else plotCophylo2(x, y, assoc = assoc, use.edge.length = use.edge.length,
+ space = space, length.line = length.line, gap = gap,
+ type = type, return = FALSE, col = col, lwd=lwd, lty=lty, show.tip.label = show.tip.label, font = font)
+}
+
+plotCophylo2 <-
+ function(x, y, assoc = assoc, use.edge.length = use.edge.length,
+ space = space, length.line = length.line, gap = gap,
+ type = type, return = return, col = col, lwd=lwd, lty=lty,
+ show.tip.label = show.tip.label,
+ font = font, ...)
+{
+ res <- list()
+###choice of the minimum space between the trees
+ left <- max(nchar(x$tip.label, type = "width")) + length.line
+ right <- max(nchar(y$tip.label, type = "width")) + length.line
+ space.min <- left + right + gap * 2
+ if ((space <= 0) || (space < space.min)) space <- space.min
+ N.tip.x <- Ntip(x)
+ N.tip.y <- Ntip(y)
+ res$N.tip.x <- N.tip.x
+ res$N.tip.y <- N.tip.y
+ a <- plotPhyloCoor(x, use.edge.length = use.edge.length, type = type)
+ res$a <- a
+ b <- plotPhyloCoor(y, use.edge.length = use.edge.length,
+ direction = "leftwards", type = type)
+###for the two trees to have the extreme leaves at the same ordinate.
+ a[, 2] <- a[, 2] - min(a[, 2])
+ b[, 2] <- b[, 2] - min(b[, 2])
+ res$b <- b
+ b2 <- b
+ b2[, 1] <- b[1:nrow(b), 1] * (max(a[, 1])/max(b[, 1])) +
+ space + max(a[, 1])
+ b2[, 2] <- b[1:nrow(b), 2] * (max(a[, 2])/max(b[, 2]))
+ res$b2 <- b2
+ c <- matrix(ncol = 2, nrow = nrow(a) + nrow(b))
+ c[1:nrow(a), ] <- a[1:nrow(a), ]
+ c[nrow(a) + 1:nrow(b), 1] <- b2[, 1]
+ c[nrow(a) + 1:nrow(b), 2] <- b2[, 2]
+ res$c <- c
+ plot(c, type = "n", xlim = NULL, ylim = NULL, log = "", main = NULL,
+ sub = NULL, xlab = NULL, ylab = NULL, ann = FALSE, axes = FALSE,
+ frame.plot = FALSE)
+ ###segments for cladograms
+ if (type == "cladogram") {
+ for (i in 1:(nrow(a) - 1)) segments(a[x$edge[i, 1], 1],
+ a[x$edge[i, 1], 2], a[x$edge[i, 2], 1], a[x$edge[i,
+ 2], 2], col="red")
+ for (i in 1:(nrow(b) - 1))
+ segments(b2[y$edge[i, 1], 1], b2[y$edge[i, 1], 2],
+ b2[y$edge[i, 2], 1], b2[y$edge[i, 2], 2])
+ }
+###segments for phylograms
+ if (type == "phylogram") {
+ for (i in (N.tip.x + 1):nrow(a)) {
+ l <- length(x$edge[x$edge[, 1] == i, ][, 1])
+ for (j in 1:l) {
+ segments(a[x$edge[x$edge[, 1] == i, ][1, 1],
+ 1], a[x$edge[x$edge[, 1] == i, 2], 2][1], a[x$edge[x$edge[,
+ 1] == i, ][1, 1], 1], a[x$edge[x$edge[, 1] ==
+ i, 2], 2][j])
+ segments(a[x$edge[x$edge[, 1] == i, ][1, 1],
+ 1], a[x$edge[x$edge[, 1] == i, 2], 2][j], a[x$edge[x$edge[,
+ 1] == i, 2], 1][j], a[x$edge[x$edge[, 1] ==
+ i, 2], 2][j])
+ }
+ }
+ for (i in (N.tip.y + 1):nrow(b)) {
+ l <- length(y$edge[y$edge[, 1] == i, ][, 1])
+ for (j in 1:l) {
+ segments(b2[y$edge[y$edge[, 1] == i, ][1, 1],
+ 1], b2[y$edge[y$edge[, 1] == i, 2], 2][1],
+ b2[y$edge[y$edge[, 1] == i, ][1, 1], 1], b2[y$edge[y$edge[,
+ 1] == i, 2], 2][j])
+ segments(b2[y$edge[y$edge[, 1] == i, ][1, 1],
+ 1], b2[y$edge[y$edge[, 1] == i, 2], 2][j],
+ b2[y$edge[y$edge[, 1] == i, 2], 1][j], b2[y$edge[y$edge[,
+ 1] == i, 2], 2][j])
+ }
+ }
+ }
+ if (show.tip.label) {
+ text(a[1:N.tip.x, ], cex = 0, font = font, pos = 4,
+ labels = x$tip.label)
+ text(b2[1:N.tip.y, ], cex = 1, font = font, pos = 2,
+ labels = y$tip.label)
+ }
+###links between associated taxa. Takes into account the size of the character strings of the taxa names.
+ lsa <- 1:N.tip.x
+ lsb <- 1:N.tip.y
+ decx <- array(nrow(assoc))
+ decy <- array(nrow(assoc))
+
+ #colors
+ if (length(col)==1) colors<-c(rep(col, nrow(assoc)))
+ else if (length(col)>=nrow(assoc)) colors<-col
+ else colors<-c(rep(col, as.integer(nrow(assoc)/length(col))+1))
+
+ #lwd
+ if (length(lwd)==1) lwidths<-c(rep(lwd, nrow(assoc)))
+ else if (length(lwd)>=nrow(assoc)) lwidths<-lwd
+ else lwidths<-c(rep(lwd, as.integer(nrow(assoc)/length(lwd))+1))
+
+ #lty
+ if (length(lty) == 1) ltype <- c(rep(lty, nrow(assoc)))
+ else if (length(lty) >= nrow(assoc)) ltype <- lty
+ else ltype <- c(rep(lty, as.integer(nrow(assoc)/length(lty))+1))
+
+ for (i in 1:nrow(assoc)) {
+ if (show.tip.label) {
+ decx[i] <- strwidth(x$tip.label[lsa[x$tip.label == assoc[i, 1]]])
+ decy[i] <- strwidth(y$tip.label[lsb[y$tip.label == assoc[i, 2]]])
+ } else {
+ decx[i] <- decy[i] <- 0
+ }
+
+ segments(a[lsa[x$tip.label == assoc[i, 1]], 1] + decx[i] + gap,
+ a[lsa[x$tip.label == assoc[i, 1]], 2],
+ a[lsa[x$tip.label == assoc[i, 1]], 1] + gap + left,
+ a[lsa[x$tip.label == assoc[i, 1]], 2],
+ col = colors[i], lwd = lwidths[i], lty = ltype[i])
+
+ segments(b2[lsb[y$tip.label == assoc[i, 2]], 1] - (decy[i] + gap),
+ b2[lsb[y$tip.label == assoc[i, 2]], 2],
+ b2[lsb[y$tip.label == assoc[i, 2]], 1] - (gap + right),
+ b2[lsb[y$tip.label == assoc[i, 2]], 2],
+ col = colors[i], lwd = lwidths[i], lty = ltype[i])
+
+ segments(a[lsa[x$tip.label == assoc[i, 1]], 1] + gap + left,
+ a[lsa[x$tip.label == assoc[i, 1]], 2],
+ b2[lsb[y$tip.label == assoc[i, 2]], 1] - (gap + right),
+ b2[lsb[y$tip.label == assoc[i, 2]], 2],
+ col = colors[i], lwd = lwidths[i], lty = ltype[i])
+ }
+ if (return == TRUE) return(res)
+}
diff --git a/R/dbd.R b/R/dbd.R
new file mode 100644
index 0000000..b0beb7a
--- /dev/null
+++ b/R/dbd.R
@@ -0,0 +1,117 @@
+## dbd.R (2012-09-14)
+
+## Probability Density Under Birth--Death Models
+
+## Copyright 2012 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+dyule <- function(x, lambda = 0.1, t = 1, log = FALSE)
+{
+ tmp <- exp(-lambda * t)
+ res <- if (log) log(tmp) + (x - 1) * log(1 - tmp) else tmp * (1 - tmp)^(x - 1)
+ out.of.range <- x <= 0
+ if (any(out.of.range))
+ res[out.of.range] <- if (log) -Inf else 0
+ res
+}
+
+dbd <- function(x, lambda, mu, t, conditional = FALSE, log = FALSE)
+{
+ if (length(lambda) > 1) {
+ lambda <- lambda[1]
+ warning("only the first value of 'lambda' was considered")
+ }
+ if (length(mu) > 1) {
+ mu <- mu[1]
+ warning("only the first value of 'mu' was considered")
+ }
+
+ if (mu == 0) return(dyule(x, lambda, t, log))
+
+ ## for the unconditional case, we have to consider x=0 separately:
+ if (!conditional) {
+ zero <- x == 0
+ out.of.range <- x < 0
+ } else {
+ out.of.range <- x <= 0
+ }
+
+ res <- numeric(length(x))
+
+ ## the situation were speciation and extinction probabilities are equal:
+ if (lambda == mu) {
+ tmp <- lambda * t
+ eta <- tmp/(1 + tmp)
+ if (conditional) {
+ res[] <- if (log) log(1 - eta) + (x - 1) * log(eta) else (1 - eta) * eta^(x - 1)
+ } else { # the unconditional case:
+ if (length(zero)) {
+ res[zero] <- eta
+ res[!zero] <- (1 - eta)^2 * eta^(x[!zero] - 1)
+ } else res[] <- (1 - eta)^2 * eta^(x - 1)
+ }
+ } else { # the general case with lambda != mu
+
+ ## this expression is common to the conditional and unconditional cases:
+ Ent <- exp((lambda - mu) * t)
+
+ if (conditional) {
+ if (log) {
+ res[] <- log(lambda - mu) - log(lambda * Ent - mu) +
+ (x - 1) * (log(lambda) + log(Ent - 1) - log(lambda * Ent - mu))
+ } else {
+ eta <- lambda * (Ent - 1)/(lambda * Ent - mu)
+ res[] <- (1 - eta) * eta^(x - 1)
+ }
+ } else { # finally, the unconditional case:
+ eta <- lambda * (Ent - 1)/(lambda * Ent - mu)
+ if (length(zero)) {
+ res[zero] <- eta * mu / lambda
+ res[!zero] <- (1 - mu * eta / lambda) * (1 - eta) * eta^(x[!zero] - 1)
+ } else res[] <- (1 - mu * eta / lambda) * (1 - eta) * eta^(x - 1)
+ }
+ }
+
+ if (any(out.of.range))
+ res[out.of.range] <- if (log) -Inf else 0
+ res
+}
+
+dbdTime <- function(x, birth, death, t, conditional = FALSE,
+ BIRTH = NULL, DEATH = NULL, fast = FALSE)
+{
+ if (length(t) > 1) {
+ t <- t[1]
+ warning("only the first value of 't' was considered")
+ }
+
+ if (conditional) {
+ PrNt <- function(t, T, x) {
+ tmp <- exp(-RHO(t, T))
+ Wt <- tmp * (1 + INT(t))
+ (1/Wt)*(1 - 1/Wt)^(x - 1)
+ }
+ } else { # the unconditional case:
+ PrNt <- function(t, T, x)
+ {
+ tmp <- exp(-RHO(t, T))
+ Wt <- tmp * (1 + INT(t))
+ out <- numeric(length(x))
+ zero <- x == 0
+ if (length(zero)) {
+ out[zero] <- 1 - tmp/Wt
+ out[!zero] <- (tmp/Wt^2)*(1 - 1/Wt)^(x[!zero] - 1)
+ } else out[] <- (tmp/Wt^2)*(1 - 1/Wt)^(x - 1)
+ out
+ }
+ }
+ case <- .getCase(birth, death, BIRTH, DEATH)
+ ff <- .getRHOetINT(birth, death, BIRTH, DEATH, case = case, fast = fast)
+ RHO <- ff[[1]]
+ INT <- ff[[2]]
+ environment(RHO) <- environment(INT) <- environment()
+ Tmax <- t
+ PrNt(0, t, x)
+}
diff --git a/R/delta.plot.R b/R/delta.plot.R
new file mode 100644
index 0000000..fa4d6d3
--- /dev/null
+++ b/R/delta.plot.R
@@ -0,0 +1,39 @@
+## delta.plot.R (2010-01-12)
+
+## Delta Plots
+
+## Copyright 2010 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+delta.plot <- function(X, k = 20, plot = TRUE, which = 1:2)
+{
+ if (is.matrix(X)) X <- as.dist(X)
+ n <- attr(X, "Size")
+ if (n < 4) stop("need at least 4 observations")
+
+ ## add a category for the cases delta = 1
+ ans <- .C(delta_plot, as.double(X), as.integer(n),
+ as.integer(k), integer(k + 1), double(n),
+ NAOK = TRUE)
+ counts <- ans[[4]]
+ ## add the counts of delta=1 to the last category:
+ counts[k] <- counts[k] + counts[k + 1]
+ counts <- counts[-(k + 1)]
+
+ delta.bar <- ans[[5]]/choose(n - 1, 3)
+
+ if (plot) {
+ if (length(which) == 2) layout(matrix(1:2, 1, 2))
+ if (1 %in% which) {
+ barplot(counts, space = 0, xlab = expression(delta[q]))
+ a <- axTicks(1)
+ axis(1, at = a, labels = a/k)
+ }
+ if (2 %in% which)
+ plot(delta.bar, type = "h", ylab = expression(bar(delta)))
+ }
+
+ invisible(list(counts = counts, delta.bar = delta.bar))
+}
diff --git a/R/dist.gene.R b/R/dist.gene.R
new file mode 100644
index 0000000..516812a
--- /dev/null
+++ b/R/dist.gene.R
@@ -0,0 +1,56 @@
+## dist.gene.R (2012-04-02)
+
+## Pairwise Distances from Genetic Data
+
+## Copyright 2002-2012 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+dist.gene <-
+ function(x, method = "pairwise", pairwise.deletion = FALSE,
+ variance = FALSE)
+{
+ if (is.data.frame(x)) x <- as.matrix(x) else { # suggestion by Markus Schlegel
+ if (!is.matrix(x))
+ stop("'x' should be a matrix or a data.frame")
+ }
+ method <- match.arg(method, c("pairwise", "percentage"))
+
+ if (!pairwise.deletion) {
+ ## delete the columns with at least one NA:
+ del <- apply(x, 2, function(xx) any(is.na(xx)))
+ x <- x[, !del]
+ }
+ n <- dim(x)
+ L <- n[2]
+ n <- n[1]
+ D <- double(n * (n - 1)/2)
+ if (pairwise.deletion) L <- D
+ k <- 1L
+ for (i in 1:(n - 1)) {
+ for (j in (i + 1):n) {
+ y <- x[i, ] != x[j, ]
+ if (pairwise.deletion) L[k] <- sum(!is.na(y))
+ D[k] <- sum(y, na.rm = TRUE)
+ k <- k + 1L
+ }
+ }
+ ## L is either a single integer value if pairwise.deletion = FALSE,
+ ## or a vector of integers if pairwise.deletion = TRUE
+
+ if (method == "percentage") D <- D/L
+
+ attr(D, "Size") <- n
+ attr(D, "Labels") <- dimnames(x)[[1]]
+ attr(D, "Diag") <- attr(D, "Upper") <- FALSE
+ attr(D, "call") <- match.call()
+ attr(D, "method") <- method
+ class(D) <- "dist"
+
+ if (variance) {
+ y <- if (method == "pairwise") L else 1
+ attr(D, "variance") <- D * (y - D)/L
+ }
+ D
+}
diff --git a/R/dist.topo.R b/R/dist.topo.R
new file mode 100644
index 0000000..ce49a81
--- /dev/null
+++ b/R/dist.topo.R
@@ -0,0 +1,361 @@
+## dist.topo.R (2014-03-07)
+
+## Topological Distances, Tree Bipartitions,
+## Consensus Trees, and Bootstrapping Phylogenies
+
+## Copyright 2005-2014 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+dist.topo <- function(x, y, method = "PH85")
+{
+ if (method == "score" && (is.null(x$edge.length) || is.null(y$edge.length)))
+ stop("trees must have branch lengths for branch score distance.")
+ nx <- length(x$tip.label)
+ x <- unroot(x)
+ y <- unroot(y)
+ bp1 <- .Call(bipartition, x$edge, nx, x$Nnode)
+ bp1 <- lapply(bp1, function(xx) sort(x$tip.label[xx]))
+ ny <- length(y$tip.label) # fix by Otto Cordero
+ ## fix by Tim Wallstrom:
+ bp2.tmp <- .Call(bipartition, y$edge, ny, y$Nnode)
+ bp2 <- lapply(bp2.tmp, function(xx) sort(y$tip.label[xx]))
+ bp2.comp <- lapply(bp2.tmp, function(xx) setdiff(1:ny, xx))
+ bp2.comp <- lapply(bp2.comp, function(xx) sort(y$tip.label[xx]))
+ ## End
+ q1 <- length(bp1)
+ q2 <- length(bp2)
+ if (method == "PH85") {
+ p <- 0
+ for (i in 1:q1) {
+ for (j in 1:q2) {
+ if (identical(bp1[[i]], bp2[[j]]) | identical(bp1[[i]], bp2.comp[[j]])) {
+ p <- p + 1
+ break
+ }
+ }
+ }
+ dT <- q1 + q2 - 2 * p # same than:
+ ##dT <- if (q1 == q2) 2*(q1 - p) else 2*(min(q1, q2) - p) + abs(q1 - q2)
+ }
+ if (method == "score") {
+ dT <- 0
+ found1 <- FALSE
+ found2 <- logical(q2)
+ found2[1] <- TRUE
+ for (i in 2:q1) {
+ for (j in 2:q2) {
+ if (identical(bp1[[i]], bp2[[j]]) | identical(bp1[[i]], bp2.comp[[j]])) {
+ dT <- dT + (x$edge.length[which(x$edge[, 2] == nx + i)] -
+ y$edge.length[which(y$edge[, 2] == ny + j)])^2
+ found1 <- found2[j] <- TRUE
+ break
+ }
+ }
+ if (found1) found1 <- FALSE
+ else dT <- dT + (x$edge.length[which(x$edge[, 2] == nx + i)])^2
+ }
+ if (!all(found2))
+ dT <- dT + sum((y$edge.length[y$edge[, 2] %in% (ny + which(!found2))])^2)
+ dT <- sqrt(dT)
+ }
+ dT
+}
+
+.compressTipLabel <- function(x)
+{
+ ## 'x' is a list of objects of class "phylo" possibly with no class
+ if (!is.null(attr(x, "TipLabel"))) return(x)
+ ref <- x[[1]]$tip.label
+ n <- length(ref)
+ if (length(unique(ref)) != n)
+ stop("some tip labels are duplicated in tree no. 1")
+
+ ## serious improvement by Joseph W. Brown!
+ relabel <- function (y) {
+ label <- y$tip.label
+ if (!identical(label, ref)) {
+ if (length(label) != length(ref))
+ stop("one tree has a different number of tips")
+ ilab <- match(label, ref)
+ if (any(is.na(ilab)))
+ stop("one tree has different tip labels")
+ ie <- match(1:n, y$edge[, 2])
+ y$edge[ie, 2] <- ilab
+ }
+ y$tip.label <- NULL
+ y
+ }
+ x <- unclass(x) # another killer improvement by Tucson's hackathon (1/2/2013)
+ x <- lapply(x, relabel)
+ attr(x, "TipLabel") <- ref
+ class(x) <- "multiPhylo"
+ x
+}
+
+prop.part <- function(..., check.labels = TRUE)
+{
+ obj <- list(...)
+ if (length(obj) == 1 && class(obj[[1]]) != "phylo")
+ obj <- obj[[1]]
+ ntree <- length(obj)
+ if (ntree == 1) check.labels <- FALSE
+ if (check.labels) obj <- .compressTipLabel(obj) # fix by Klaus Schliep (2011-02-21)
+ class(obj) <- NULL # fix by Klaus Schliep (2014-03-06)
+ for (i in 1:ntree) storage.mode(obj[[i]]$Nnode) <- "integer"
+ class(obj) <- "multiPhylo"
+ obj <- .uncompressTipLabel(obj) # fix a bug (2010-11-18)
+ clades <- .Call(prop_part, obj, ntree, TRUE)
+ attr(clades, "number") <- attr(clades, "number")[1:length(clades)]
+ attr(clades, "labels") <- obj[[1]]$tip.label
+ class(clades) <- "prop.part"
+ clades
+}
+
+print.prop.part <- function(x, ...)
+{
+ if (is.null(attr(x, "labels"))) {
+ for (i in 1:length(x)) {
+ cat("==>", attr(x, "number")[i], "time(s):")
+ print(x[[i]], quote = FALSE)
+ }
+ } else {
+ for (i in 1:length(attr(x, "labels")))
+ cat(i, ": ", attr(x, "labels")[i], "\n", sep = "")
+ cat("\n")
+ for (i in 1:length(x)) {
+ cat("==>", attr(x, "number")[i], "time(s):")
+ print(x[[i]], quote = FALSE)
+ }
+ }
+}
+
+summary.prop.part <- function(object, ...) attr(object, "number")
+
+plot.prop.part <- function(x, barcol = "blue", leftmar = 4, ...)
+{
+ if (is.null(attr(x, "labels")))
+ stop("cannot plot this partition object; see ?prop.part for details.")
+ L <- length(x)
+ n <- length(attr(x, "labels"))
+ layout(matrix(1:2, 2, 1), heights = c(1, 3))
+ par(mar = c(0.1, leftmar, 0.1, 0.1))
+ plot(1:L, attr(x, "number"), type = "h", col = barcol, xlim = c(1, L),
+ xlab = "", ylab = "Frequency", xaxt = "n", bty = "n")
+ plot(0, type = "n", xlim = c(1, L), ylim = c(1, n),
+ xlab = "", ylab = "", xaxt = "n", yaxt = "n")
+ for (i in 1:L) points(rep(i, length(x[[i]])), x[[i]], ...)
+ mtext(attr(x, "labels"), side = 2, at = 1:n, las = 1)
+}
+
+prop.clades <- function(phy, ..., part = NULL, rooted = FALSE)
+{
+ if (is.null(part)) {
+ ## <FIXME>
+ ## Are we going to keep the '...' way of passing trees?
+ obj <- list(...)
+ if (length(obj) == 1 && class(obj[[1]]) != "phylo")
+ obj <- unlist(obj, recursive = FALSE)
+ ## </FIXME>
+ part <- prop.part(obj, check.labels = TRUE)
+ }
+
+ ## until ape 3.0-7 it was assumed implicitly that the labels in phy
+ ## are in the same order than in 'part' (bug report by Rupert Collins)
+ if (!identical(phy$tip.label, attr(part, "labels"))) {
+ i <- match(phy$tip.label, attr(part, "labels"))
+ j <- match(seq_len(Ntip(phy)), phy$edge[, 2])
+ phy$edge[j, 2] <- i
+ phy$tip.label <- attr(part, "labels")
+ }
+ bp <- prop.part(phy)
+ if (!rooted) {
+ bp <- postprocess.prop.part(bp)
+ part <- postprocess.prop.part(part) # fix by Klaus Schliep
+ ## actually the above line in not needed if called from boot.phylo()
+ }
+
+ n <- numeric(phy$Nnode)
+ for (i in seq_along(bp)) {
+ for (j in seq_along(part)) {
+ ## we rely on the fact the values returned by prop.part are
+ ## sorted and without attributes, so identical can be used:
+ if (identical(bp[[i]], part[[j]])) {
+ n[i] <- attr(part, "number")[j]
+ done <- TRUE
+ break
+ }
+ }
+ }
+ n
+}
+
+boot.phylo <- function(phy, x, FUN, B = 100, block = 1,
+ trees = FALSE, quiet = FALSE, rooted = FALSE)
+{
+ if (is.null(dim(x)) || length(dim(x)) != 2)
+ stop("the data 'x' must have two dimensions (e.g., a matrix or a data frame)")
+
+ boot.tree <- vector("list", B)
+
+ if (!quiet) # suggestion by Alastair Potts
+ progbar <- txtProgressBar(style = 3)
+
+ y <- nc <- ncol(x)
+
+ if (block > 1) {
+ a <- seq(1, nc - 1, block)
+ b <- seq(block, nc, block)
+ y <- mapply(":", a, b, SIMPLIFY = FALSE)
+ }
+
+ for (i in 1:B) {
+ boot.samp <- unlist(sample(y, replace = TRUE))
+ boot.tree[[i]] <- FUN(x[, boot.samp])
+ if (!quiet) setTxtProgressBar(progbar, i/B)
+ }
+ if (!quiet) close(progbar)
+
+ ## for (i in 1:B) storage.mode(boot.tree[[i]]$Nnode) <- "integer"
+ ## storage.mode(phy$Nnode) <- "integer"
+
+ if (!quiet) cat("Calculating bootstrap values...")
+
+ if (rooted) {
+ pp <- prop.part(boot.tree)
+ if (!rooted) pp <- postprocess.prop.part(pp)
+ ans <- prop.clades(phy, part = pp, rooted = rooted)
+ } else {
+ phy <- reorder(phy, "postorder")
+ ints <- phy$edge[, 2] > Ntip(phy)
+ ans <- countBipartitions(phy, boot.tree)
+ ans <- c(B, ans[order(phy$edge[ints, 2])])
+ }
+
+ if (trees) {
+ class(boot.tree) <- "multiPhylo"
+ ans <- list(BP = ans, trees = boot.tree)
+ }
+ if (!quiet) cat(" done.\n")
+ ans
+}
+
+### The next function transforms an object of class "prop.part" so
+### that the vectors which are identical in terms of split are aggregated.
+### For instance if n = 5 tips, 1:2 and 3:5 actually represent the same
+### split though they are different clades. The aggregation is done
+### arbitrarily. The call to ONEwise() insures that all splits include
+### the first tip.
+postprocess.prop.part <- function(x)
+{
+ n <- length(x[[1]])
+ N <- length(x)
+ w <- attr(x, "number")
+
+ drop <- logical(N)
+ V <- numeric(n)
+ for (i in 2:(N - 1)) {
+ if (drop[i]) next
+ A <- x[[i]]
+ for (j in (i + 1):N) {
+ if (drop[j]) next
+ B <- x[[j]]
+ if (length(A) + length(B) != n) next
+ V[] <- 0L
+ V[A] <- 1L
+ V[B] <- 1L
+ if (all(V == 1L)) {
+ drop[j] <- TRUE
+ w[i] <- w[i] + w[j]
+ }
+ }
+ }
+ if (any(drop)) {
+ labels <- attr(x, "labels")
+ x <- x[!drop]
+ w <- w[!drop]
+ attr(x, "number") <- w
+ attr(x, "labels") <- labels
+ class(x) <- "prop.part"
+ }
+ ONEwise(x)
+}
+
+### This function changes an object of class "prop.part" so that they
+### all include the first tip. For instance if n = 5 tips, 3:5 is
+### changed to 1:2.
+ONEwise <- function(x)
+{
+ n <- length(x[[1L]])
+ v <- 1:n
+ for (i in 2:length(x)) {
+ y <- x[[i]]
+ if (y[1] != 1) x[[i]] <- v[-y]
+ }
+ x
+}
+
+consensus <- function(..., p = 1, check.labels = TRUE)
+{
+ foo <- function(ic, node) {
+ ## ic: index of 'pp'
+ ## node: node number in the final tree
+ pool <- pp[[ic]]
+ if (ic < m) {
+ for (j in (ic + 1):m) {
+ wh <- match(pp[[j]], pool)
+ if (!any(is.na(wh))) {
+ edge[pos, 1] <<- node
+ pool <- pool[-wh]
+ edge[pos, 2] <<- nextnode <<- nextnode + 1L
+ pos <<- pos + 1L
+ foo(j, nextnode)
+ }
+ }
+ }
+ size <- length(pool)
+ if (size) {
+ ind <- pos:(pos + size - 1)
+ edge[ind, 1] <<- node
+ edge[ind, 2] <<- pool
+ pos <<- pos + size
+ }
+ }
+ obj <- list(...)
+ if (length(obj) == 1) {
+ ## better than unlist(obj, recursive = FALSE)
+ ## because "[[" keeps the class of 'obj':
+ obj <- obj[[1]]
+ if (class(obj) == "phylo") return(obj)
+ }
+ if (!is.null(attr(obj, "TipLabel")))
+ labels <- attr(obj, "TipLabel")
+ else {
+ labels <- obj[[1]]$tip.label
+ if (check.labels) obj <- .compressTipLabel(obj)
+ }
+ ntree <- length(obj)
+ ## Get all observed partitions and their frequencies:
+ pp <- prop.part(obj, check.labels = FALSE)
+ ## Drop the partitions whose frequency is less than 'p':
+ if (p == 0.5) p <- 0.5000001 # avoid incompatible splits
+ pp <- pp[attr(pp, "number") >= p * ntree]
+ ## Get the order of the remaining partitions by decreasing size:
+ ind <- sort(unlist(lapply(pp, length)), decreasing = TRUE,
+ index.return = TRUE)$ix
+ pp <- pp[ind]
+ n <- length(labels)
+ m <- length(pp)
+ edge <- matrix(0L, n + m - 1, 2)
+ if (m == 1) {
+ edge[, 1] <- n + 1L
+ edge[, 2] <- 1:n
+ } else {
+ nextnode <- n + 1L
+ pos <- 1L
+ foo(1, nextnode)
+ }
+ structure(list(edge = edge, tip.label = labels,
+ Nnode = m), class = "phylo")
+}
diff --git a/R/diversi.gof.R b/R/diversi.gof.R
new file mode 100644
index 0000000..1679e02
--- /dev/null
+++ b/R/diversi.gof.R
@@ -0,0 +1,65 @@
+## diversi.gof.R (2006-10-16)
+
+## Tests of Constant Diversification Rates
+
+## Copyright 2002-2006 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+diversi.gof <- function(x, null = "exponential", z = NULL)
+{
+ n <- length(x)
+ if (null == "exponential") {
+ delta <- n/sum(x)
+ z <- 1 - exp(-delta * sort(x))
+ }
+ else {
+ nmsz <- deparse(substitute(z))
+ z <- sort(z) # utile ???
+ }
+ i <- 1:n
+ W2 <- sum((z - (2*i - 1)/(2*n))^2) + 1/12*n
+ A2 <- -sum((2*i - 1)*(log(z) + log(1 - rev(z))))/n - n
+ if (null == "exponential") {
+ W2 <- W2*(1 - 0.16/n)
+ A2 <- A2*(1 + 0.6/n)
+ }
+ else W2 <- (W2 - 0.4/n + 0.6/n^2)/(1 + 1/n)
+ cat("\nTests of Constant Diversification Rates\n\n")
+ cat("Data:", deparse(substitute(x)), "\n")
+ cat("Number of branching times:", n, "\n")
+ cat("Null model: ")
+ if (null == "exponential") cat("exponential\n\n")
+ else cat(nmsz, "(user-specified)\n\n")
+ cat("Cramer-von Mises test: W2 =", round(W2, 3))
+ if (null == "exponential") {
+ if (W2 < 0.177) cat(" P > 0.1\n")
+ if (W2 >= 0.177 && W2 < 0.224) cat(" 0.05 < P < 0.1\n")
+ if (W2 >= 0.224 && W2 < 0.273) cat(" 0.025 < P < 0.05\n")
+ if (W2 >= 0.273 && W2 < 0.337) cat(" 0.01 < P < 0.025\n")
+ if (W2 > 0.337) cat(" P < 0.01\n")
+ }
+ else {
+ if (W2 < 0.347) cat(" P > 0.1\n")
+ if (W2 >= 0.347 && W2 < 0.461) cat(" 0.05 < P < 0.1\n")
+ if (W2 >= 0.461 && W2 < 0.581) cat(" 0.025 < P < 0.05\n")
+ if (W2 >= 0.581 && W2 < 0.743) cat(" 0.01 < P < 0.025\n")
+ if (W2 > 0.743) cat(" P < 0.01\n")
+ }
+ cat("Anderson-Darling test: A2 =", round(A2, 3))
+ if (null == "exponential") {
+ if (A2 < 1.078) cat(" P > 0.1\n")
+ if (A2 >= 1.078 && A2 < 1.341) cat(" 0.05 < P < 0.1\n")
+ if (A2 >= 1.341 && A2 < 1.606) cat(" 0.025 < P < 0.05\n")
+ if (A2 >= 1.606 && A2 < 1.957) cat(" 0.01 < P < 0.025\n")
+ if (A2 > 1.957) cat(" P < 0.01\n")
+ }
+ else {
+ if (A2 < 1.933) cat(" P > 0.1\n")
+ if (A2 >= 1.933 && A2 < 2.492) cat(" 0.05 < P < 0.1\n")
+ if (A2 >= 2.492 && A2 < 3.070) cat(" 0.025 < P < 0.05\n")
+ if (A2 >= 3.070 && A2 < 3.857) cat(" 0.01 < P < 0.025\n")
+ if (A2 > 3.857) cat(" P < 0.01\n")
+ }
+}
diff --git a/R/diversi.time.R b/R/diversi.time.R
new file mode 100644
index 0000000..2ed49b0
--- /dev/null
+++ b/R/diversi.time.R
@@ -0,0 +1,80 @@
+## diversi.time.R (2007-09-22)
+
+## Analysis of Diversification with Survival Models
+
+## Copyright 2002-2007 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+diversi.time <- function(x, census = NULL, censoring.codes = c(1, 0),
+ Tc = NULL)
+{
+ n <- length(x)
+ if (is.null(census)) {
+ k <- n
+ census <- rep(censoring.codes[1], n)
+ }
+ else k <- sum(census == censoring.codes[1])
+ u <- n - k
+ S <- sum(x)
+ delta <- k / S
+ var.delta <- delta^2 / k
+ loglik.A <- k * log(delta) - delta * S
+ tk <- x[census == censoring.codes[1]]
+ tu <- x[census == censoring.codes[2]]
+ fb <- function(b)
+ 1/b - sum(x^b * log(x))/sum(x^b) + sum(log(tk))/k
+ beta <- uniroot(fb, interval = c(1e-7, 10))$root
+ Sp <- sum(x^beta)
+ alpha <- (k / Sp)^(1/beta)
+ var.alpha <- 1/ ((k * beta / alpha^2) + beta * (beta - 1) * alpha^(beta - 2) * Sp)
+ ax <- alpha * x
+ var.beta <- 1 / (k / beta^2 + sum(ax^beta * log(ax)))
+ loglik.B <- k*(log(alpha) + log(beta)) +
+ (beta - 1)*(k*log(alpha) + sum(log(tk)))- Sp * alpha^beta
+ if (is.null(Tc)) Tc <- median(x)
+ tk1 <- tk[tk < Tc]
+ tk2 <- tk[tk >= Tc]
+ tu1 <- tu[tu < Tc]
+ tu2 <- tu[tu >= Tc]
+ k1 <- length(tk1)
+ k2 <- k - k1
+ u1 <- length(tu1)
+ u2 <- u - u1
+ tmp <- (k2 + u2) * Tc
+ delta1 <- k1 / (sum(tk1) + sum(tu1) + tmp)
+ delta2 <- k2 / (sum(tk2) + sum(tu2) - tmp)
+ var.delta1 <- delta1^2 / k1
+ var.delta2 <- delta2^2 / k2
+ tmp <- Tc * (delta2 - delta1)
+ loglik.C <- k1 * log(delta1) - delta1 * sum(tk1) + k2 * log(delta2) +
+ k2 * tmp - delta2 * sum(tk2) - delta1 * sum(tu1) +
+ u2 * tmp - delta2 * sum(tu2)
+ cat("\nAnalysis of Diversification with Survival Models\n\n")
+ cat("Data:", deparse(substitute(x)), "\n")
+ cat("Number of branching times:", n, "\n")
+ cat(" accurately known:", k, "\n")
+ cat(" censored:", u, "\n\n")
+ cat("Model A: constant diversification\n")
+ cat(" log-likelihood =", round(loglik.A, 3),
+ " AIC =", round(-2 * loglik.A + 2, 3), "\n")
+ cat(" delta =", round(delta, 6), " StdErr =", round(sqrt(var.delta), 6), "\n\n")
+ cat("Model B: diversification follows a Weibull law\n")
+ cat(" log-likelihood =", round(loglik.B, 3),
+ " AIC =", round(-2 * loglik.B + 4, 3), "\n")
+ cat(" alpha =", round(alpha, 6), " StdErr =", round(sqrt(var.alpha), 6), "\n")
+ cat(" beta =", round(beta, 6), " StdErr =", round(sqrt(var.beta), 6), "\n\n")
+ cat("Model C: diversification changes with a breakpoint at time =", Tc, "\n")
+ cat(" log-likelihood =", round(loglik.C, 3),
+ " AIC =", round(-2 * loglik.C + 4, 3), "\n")
+ cat(" delta1 =", round(delta1, 6), " StdErr =", round(sqrt(var.delta1), 6), "\n")
+ cat(" delta2 =", round(delta2, 6), " StdErr =", round(sqrt(var.delta2), 6), "\n\n")
+ cat("Likelihood ratio tests:\n")
+ c1 <- 2 * (loglik.B - loglik.A)
+ p1 <- round(1 - pchisq(c1, 1), 4)
+ c2 <- 2 * (loglik.C - loglik.A)
+ p2 <- round(1 - pchisq(c2, 1), 4)
+ cat(" Model A vs. Model B: chi^2 =", round(c1, 3), " df = 1, P =", p1, "\n")
+ cat(" Model A vs. Model C: chi^2 =", round(c2, 3), " df = 1, P =", p2, "\n")
+}
diff --git a/R/drop.tip.R b/R/drop.tip.R
new file mode 100644
index 0000000..8c0c1de
--- /dev/null
+++ b/R/drop.tip.R
@@ -0,0 +1,238 @@
+## drop.tip.R (2013-05-17)
+
+## Remove Tips in a Phylogenetic Tree
+
+## Copyright 2003-2013 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+extract.clade <- function(phy, node, root.edge = 0, interactive = FALSE)
+{
+ Ntip <- length(phy$tip.label)
+ ROOT <- Ntip + 1
+ Nedge <- dim(phy$edge)[1]
+ wbl <- !is.null(phy$edge.length)
+ if (interactive) node <- identify(phy)$nodes else {
+ if (length(node) > 1) {
+ node <- node[1]
+ warning("only the first value of 'node' has been considered")
+ }
+ if (is.character(node)) {
+ if (is.null(phy$node.label))
+ stop("the tree has no node labels")
+ node <- which(phy$node.label %in% node) + Ntip
+ }
+ if (node <= Ntip)
+ stop("node number must be greater than the number of tips")
+ }
+ if (node == ROOT) return(phy)
+ phy <- reorder(phy) # insure it is in cladewise order
+ root.node <- which(phy$edge[, 2] == node)
+ start <- root.node + 1 # start of the clade looked for
+ anc <- phy$edge[root.node, 1] # the ancestor of 'node'
+ next.anc <- which(phy$edge[-(1:start), 1] <= anc) # find the next occurence of 'anc' or an 'older' node
+
+ keep <- if (length(next.anc)) start + 0:(next.anc[1] - 1) else start:Nedge
+
+ if (root.edge) {
+ NewRootEdge <- phy$edge.length[root.node]
+ root.edge <- root.edge - 1
+ while (root.edge) {
+ if (anc == ROOT) break
+ i <- which(phy$edge[, 2] == anc)
+ NewRootEdge <- NewRootEdge + phy$edge.length[i]
+ root.edge <- root.edge - 1
+ anc <- phy$edge[i, 1]
+ }
+ if (root.edge && !is.null(phy$root.edge))
+ NewRootEdge <- NewRootEdge + phy$root.edge
+ phy$root.edge <- NewRootEdge
+ }
+
+ phy$edge <- phy$edge[keep, ]
+ if (wbl) phy$edge.length <- phy$edge.length[keep]
+ TIPS <- phy$edge[, 2] <= Ntip
+ tip <- phy$edge[TIPS, 2]
+ ## Fix by Ludovic Mallet and Mahendra Mariadassou (2011-11-21):
+ name <- vector("character", length(tip))
+ name[order(tip)] <- phy$tip.label[tip]
+ phy$tip.label <- name
+ ## End of fix
+ ## keep the ordering so no need to reorder tip.label:
+ phy$edge[TIPS, 2] <- order(tip)
+ if (!is.null(phy$node.label))
+ phy$node.label <- phy$node.label[sort(unique(phy$edge[, 1])) - Ntip]
+ Ntip <- length(phy$tip.label)
+ phy$Nnode <- dim(phy$edge)[1] - Ntip + 1L
+ ## The block below renumbers the nodes so that they conform
+ ## to the "phylo" format -- same as in root()
+ newNb <- integer(Ntip + phy$Nnode)
+ newNb[node] <- Ntip + 1L
+ sndcol <- phy$edge[, 2] > Ntip
+ ## executed from right to left, so newNb is modified before phy$edge:
+ phy$edge[sndcol, 2] <- newNb[phy$edge[sndcol, 2]] <-
+ (Ntip + 2):(Ntip + phy$Nnode)
+ phy$edge[, 1] <- newNb[phy$edge[, 1]]
+ phy
+}
+
+drop.tip <-
+ function(phy, tip, trim.internal = TRUE, subtree = FALSE,
+ root.edge = 0, rooted = is.rooted(phy), interactive = FALSE)
+{
+ if (!inherits(phy, "phylo"))
+ stop('object "phy" is not of class "phylo"')
+
+ Ntip <- length(phy$tip.label)
+ ## find the tips to drop:
+ if (interactive) {
+ cat("Left-click close to the tips you want to drop; right-click when finished...\n")
+ xy <- locator()
+ nToDrop <- length(xy$x)
+ tip <- integer(nToDrop)
+ lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv)
+ for (i in 1:nToDrop) {
+ d <- sqrt((xy$x[i] - lastPP$xx)^2 + (xy$y[i] - lastPP$yy)^2)
+ tip[i] <- which.min(d)
+ }
+ } else {
+ if (is.character(tip))
+ tip <- which(phy$tip.label %in% tip)
+ }
+
+ out.of.range <- tip > Ntip
+ if (any(out.of.range)) {
+ warning("some tip numbers were larger than the number of tips: they were ignored")
+ tip <- tip[!out.of.range]
+ }
+
+ if (!length(tip)) return(phy)
+
+ if (length(tip) == Ntip) {
+ warning("drop all tips of the tree: returning NULL")
+ return(NULL)
+ }
+
+ wbl <- !is.null(phy$edge.length)
+
+ if (!rooted && subtree) {
+ phy <- root(phy, (1:Ntip)[-tip][1])
+ root.edge <- 0
+ }
+
+ phy <- reorder(phy)
+ NEWROOT <- ROOT <- Ntip + 1
+ Nnode <- phy$Nnode
+ Nedge <- dim(phy$edge)[1]
+ if (subtree) {
+ trim.internal <- TRUE
+ tr <- reorder(phy, "postorder")
+ N <- .C(node_depth, as.integer(Ntip), as.integer(Nnode),
+ as.integer(tr$edge[, 1]), as.integer(tr$edge[, 2]),
+ as.integer(Nedge), double(Ntip + Nnode), 1L)[[6]]
+ }
+
+ edge1 <- phy$edge[, 1] # local copies
+ edge2 <- phy$edge[, 2] #
+ keep <- !logical(Nedge)
+
+ ## delete the terminal edges given by `tip':
+ keep[match(tip, edge2)] <- FALSE
+
+ if (trim.internal) {
+ ints <- edge2 > Ntip
+ ## delete the internal edges that do not have anymore
+ ## descendants (ie, they are in the 2nd col of `edge' but
+ ## not in the 1st one)
+ repeat {
+ sel <- !(edge2 %in% edge1[keep]) & ints & keep
+ if (!sum(sel)) break
+ keep[sel] <- FALSE
+ }
+ if (subtree) {
+ ## keep the subtending edge(s):
+ subt <- edge1 %in% edge1[keep] & edge1 %in% edge1[!keep]
+ keep[subt] <- TRUE
+ }
+ if (root.edge && wbl) {
+ degree <- tabulate(edge1[keep])
+ if (degree[ROOT] == 1) {
+ j <- integer(0) # will store the indices of the edges below the new root
+ repeat {
+ i <- which(edge1 == NEWROOT & keep)
+ j <- c(i, j)
+ NEWROOT <- edge2[i]
+ degree <- tabulate(edge1[keep])
+ if (degree[NEWROOT] > 1) break
+ }
+ keep[j] <- FALSE
+ if (length(j) > root.edge) j <- 1:root.edge
+ NewRootEdge <- sum(phy$edge.length[j])
+ if (length(j) < root.edge && !is.null(phy$root.edge))
+ NewRootEdge <- NewRootEdge + phy$root.edge
+ phy$root.edge <- NewRootEdge
+ }
+ }
+ }
+
+ if (!root.edge) phy$root.edge <- NULL
+
+ ## drop the edges
+ phy$edge <- phy$edge[keep, ]
+ if (wbl) phy$edge.length <- phy$edge.length[keep]
+
+ ## find the new terminal edges (works whatever 'subtree' and 'trim.internal'):
+ TERMS <- !(phy$edge[, 2] %in% phy$edge[, 1])
+
+ ## get the old No. of the nodes and tips that become tips:
+ oldNo.ofNewTips <- phy$edge[TERMS, 2]
+
+ ## in case some tips are dropped but kept because of 'subtree = TRUE':
+ if (subtree) {
+ i <- which(tip %in% oldNo.ofNewTips)
+ if (length(i)) {
+ phy$tip.label[tip[i]] <- "[1_tip]"
+ tip <- tip[-i]
+ }
+ }
+
+ n <- length(oldNo.ofNewTips) # the new number of tips in the tree
+
+ ## the tips may not be sorted in increasing order in the
+ ## 2nd col of edge, so no need to reorder $tip.label
+ phy$edge[TERMS, 2] <- rank(phy$edge[TERMS, 2])
+ phy$tip.label <- phy$tip.label[-tip]
+
+ ## make new tip labels if necessary:
+ if (subtree || !trim.internal) {
+ ## get the numbers of the nodes that become tips:
+ node2tip <- oldNo.ofNewTips[oldNo.ofNewTips > Ntip]
+ new.tip.label <- if (subtree) {
+ paste("[", N[node2tip], "_tips]", sep = "")
+ } else {
+ if (is.null(phy$node.label)) rep("NA", length(node2tip))
+ else phy$node.label[node2tip - Ntip]
+ }
+# if (!is.null(phy$node.label))
+# phy$node.label <- phy$node.label[-(node2tip - Ntip)]
+ phy$tip.label <- c(phy$tip.label, new.tip.label)
+ }
+
+ phy$Nnode <- dim(phy$edge)[1] - n + 1L # update phy$Nnode
+
+ ## The block below renumbers the nodes so that they conform
+ ## to the "phylo" format, same as in root()
+ newNb <- integer(Ntip + Nnode)
+ newNb[NEWROOT] <- n + 1L
+ sndcol <- phy$edge[, 2] > n
+ ## executed from right to left, so newNb is modified before phy$edge:
+ phy$edge[sndcol, 2] <- newNb[phy$edge[sndcol, 2]] <-
+ (n + 2):(n + phy$Nnode)
+ phy$edge[, 1] <- newNb[phy$edge[, 1]]
+ storage.mode(phy$edge) <- "integer"
+ if (!is.null(phy$node.label)) # update node.label if needed
+ phy$node.label <- phy$node.label[which(newNb > 0) - Ntip]
+ collapse.singles(phy)
+}
+
diff --git a/R/evonet.R b/R/evonet.R
new file mode 100644
index 0000000..e52571f
--- /dev/null
+++ b/R/evonet.R
@@ -0,0 +1,103 @@
+## evonet.R (2012-09-14)
+
+## Evolutionary Networks
+
+## Copyright 2011-2012 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+evonet <- function(phy, from, to = NULL)
+{
+ if (!inherits(phy, "phylo"))
+ stop('object "phy" is not of class "phylo".')
+ if (!is.rooted(phy))
+ warning("the tree is unrooted")
+ x <- phy
+
+ if (is.null(to)) {
+ if (is.data.frame(from))
+ from <- as.matrix(from)
+ if (!is.matrix(from))
+ stop("'from' must be a matrix or a data frame if 'to' is not given")
+ if (ncol(from) > 2) {
+ warning("'from' has more than two columns: only the first two will be used.")
+ ret <- from[, 1:2]
+ } else if (ncol(from) < 2) {
+ stop("'from' must have at least two columns")
+ } else ret <- from
+ } else {
+ from <- as.vector(from)
+ to <- as.vector(to)
+ if (length(from) != length(to))
+ stop("'from' and 'to' not of the same length after coercing as vectors")
+ ret <- cbind(from, to)
+ }
+
+ ## check that values are not out of range:
+ storage.mode(ret) <- "integer"
+ if (any(is.na(ret)))
+ stop("some values are NA's after coercing as integers")
+ if (any(ret < 0) || any(ret > Ntip(phy) + phy$Nnode))
+ stop("some values are out of range")
+
+ x$reticulation <- ret
+ class(x) <- c("evonet", "phylo")
+ x
+}
+
+as.phylo.evonet <- function(x, ...)
+{
+ x$reticulation <- NULL
+ class(x) <- "phylo"
+ x
+}
+
+plot.evonet <- function(x, col = "blue", lty = 1, lwd = 1, alpha = 0.5,
+ arrows = 0, arrow.type = "classical", ...)
+{
+ plot.phylo(as.phylo(x), ...)
+ edges(x$reticulation[, 1], x$reticulation[, 2],
+ col = rgb(t(col2rgb(col)), alpha = 255 * alpha,
+ maxColorValue = 255), lty = lty, lwd = lwd,
+ arrows = arrows, type = arrow.type)
+}
+
+as.networx.evonet <- function(x, weight = NA, ...)
+{
+ if (any(x$reticulation <= Ntip(x)))
+ stop("some tips are involved in reticulations: cannot convert to \"networx\"")
+ x <- reorder(x, "postorder")
+ ned <- Nedge(x)
+ nrt <- nrow(x$reticulation)
+ x$edge <- rbind(x$edge, x$reticulation)
+ colnames(x$edge) <- c("oldNodes", "newNodes")
+ x$reticulation <- NULL
+ x$edge.length <- c(x$edge.length, rep(weight, length.out = nrt))
+ x$split <- c(1:ned, 1:nrt)
+ class(x) <- c("networx", "phylo")
+ x
+}
+
+as.network.evonet <- function(x, directed = TRUE, ...)
+{
+ class(x) <- NULL
+ x$edge <- rbind(x$edge, x$reticulation)
+ as.network.phylo(x, directed = directed, ...)
+}
+
+as.igraph.evonet <- function(x, directed = TRUE, use.labels = TRUE, ...)
+{
+ class(x) <- NULL
+ x$edge <- rbind(x$edge, x$reticulation)
+ as.igraph.phylo(x, directed = directed, use.labels = use.labels, ...)
+}
+
+print.evonet <- function(x, ...)
+{
+ nr <- nrow(x$reticulation)
+ cat("\n Evolutionary network with", nr, "reticulation")
+ if (nr > 1) cat("s")
+ cat("\n\n --- Base tree ---")
+ print.phylo(as.phylo(x))
+}
diff --git a/R/ewLasso.R b/R/ewLasso.R
new file mode 100644
index 0000000..3790fd3
--- /dev/null
+++ b/R/ewLasso.R
@@ -0,0 +1,28 @@
+## ewLasso.R (2013-04-02)
+
+## Lasso Tree
+
+## Copyright 2013 Andrei-Alin Popescu
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+ewLasso <- function(X, phy)
+{
+ if (is.matrix(X)) X <- as.dist(X)
+ X[is.na(X)] <- -1
+ X[X < 0] <- -1
+ X[is.nan(X)] <- -1
+
+ if (is.rooted(phy)) {
+ phy <- unroot(phy)
+ warning("'phy' is rooted: it was unrooted for this operation")
+ }
+
+ N <- attr(X, "Size")
+ labels <- attr(X, "Labels")
+ if (is.null(labels)) labels <- as.character(1:N)
+ ans <- .C(C_ewLasso, as.double(X), as.integer(N),
+ as.integer(phy$edge[, 1]), as.integer(phy$edge[, 2]),
+ NAOK = TRUE)
+}
diff --git a/R/extract.popsize.R b/R/extract.popsize.R
new file mode 100644
index 0000000..71046e5
--- /dev/null
+++ b/R/extract.popsize.R
@@ -0,0 +1,95 @@
+## extract.popsize.R (2004-07-4)
+
+## Extract table with population size in dependence of time
+## from mcmc output generated by mcmc.popsize
+
+## Copyright 2004 Rainer Opgen-Rhein and Korbinian Strimmer
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+extract.popsize<-function(mcmc.out, credible.interval=0.95, time.points=200, thinning=1, burn.in=0)
+{
+
+ # construct a matrix with the positions of the jumps
+ b<-burn.in+1
+ i<-1
+ k<-array(dim=ceiling((length(mcmc.out$pos)-burn.in)/thinning))
+ while(i<=length(k)) {
+ k[i]<-length(mcmc.out$pos[[b]]);
+ (i<-i+1);
+ b<-b+thinning
+ }
+ o<-max(k)
+
+ b<-burn.in+1
+ i<-1
+ pos.m<-matrix(nrow=length(k), ncol=o)
+ while(i<=length(k)) {
+ pos.m[i,]<-c(mcmc.out$pos[[b]], array(dim=o-length(mcmc.out$pos[[b]])));
+ i<-i+1;
+ b<-b+thinning
+ }
+
+ # construct a matrix with the heights of the jumps
+ b<-burn.in+1
+ i<-1
+ h.m<-matrix(nrow=length(k), ncol=o)
+ while(i<=length(k)) {
+ h.m[i,]<-c(mcmc.out$h[[b]], array(dim=o-length(mcmc.out$h[[b]])));
+ i<-i+1;
+ b<-b+thinning
+ }
+ prep<-list("pos"=pos.m, "h"=h.m)
+
+####################
+
+ step <- (max(prep$pos, na.rm=TRUE)-min(prep$pos, na.rm=TRUE))/(time.points-1)
+ nr <- time.points
+
+ p<-min(prep$pos, na.rm=TRUE)
+ i<-1
+ me<-matrix(nrow=nr, ncol=5)
+
+ prep.l<-prep
+ prep.l$pos<-cbind(prep$pos,prep$pos[,length(prep$pos[1,])])
+ prep.l$h<-cbind(prep$h,prep$h[,length(prep$h[1,])])
+
+ while (p<=max(prep$pos, na.rm=TRUE))
+ {
+ #Vector with position of heights
+ l.prep<-prep$pos<=p
+ l.prep[is.na(l.prep)]<-FALSE
+ pos.of.h<-l.prep%*% array(data=1, dim=dim(prep$pos)[2])
+
+ #Vector with heights
+ z<-array(data=(1:dim(prep$pos)[1]), dim=dim(prep$pos)[1])
+ index.left<-cbind(z,pos.of.h)
+ index.right<-cbind(z, pos.of.h+1)
+
+ mixed.heights<-((((p-prep$pos[index.left])/(prep$pos[index.right]-prep$pos[index.left]))*
+ (prep$h[index.right]-prep$h[index.left]))+prep$h[index.left])
+
+ me[i,2]<-mean(mixed.heights)
+
+ #library(MASS)
+ #me[i,2]<-huber(mixed.heights)$mu
+
+ me[i,3]<-median(mixed.heights)
+ me[i,4]<-quantile(mixed.heights, probs=(1-credible.interval)/2, na.rm=TRUE)
+ me[i,5]<-quantile(mixed.heights, probs=(1+credible.interval)/2, na.rm=TRUE)
+ me[i,1]<-p
+ p<-p+step
+ i<-i+1
+ }
+
+ #av.jumps<-round((length(prep$pos)-sum(is.na(prep$pos)))/length(prep$pos[,1])-2,2)
+ #print("average jumps")
+
+ #print((length(prep$pos)-sum(is.na(prep$pos)))/length(prep$pos[,1])-2)
+
+ colnames(me) <- c("time", "mean", "median", "lower CI", "upper CI")
+ class(me) <- "popsize"
+
+ return(me)
+}
diff --git a/R/gammaStat.R b/R/gammaStat.R
new file mode 100644
index 0000000..8035a4d
--- /dev/null
+++ b/R/gammaStat.R
@@ -0,0 +1,21 @@
+## gammaStat.R (2009-05-10)
+
+## Gamma-Statistic of Pybus and Harvey
+
+## Copyright 2002-2009 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+gammaStat <- function(phy)
+{
+ if (!inherits(phy, "phylo")) stop('object "phy" is not of class "phylo"')
+ N <- length(phy$tip.label)
+ bt <- sort(branching.times(phy))
+ g <- rev(c(bt[1], diff(bt))) # internode intervals are from past to present
+ ST <- sum((2:N) * g)
+ stat <- sum(cumsum((2:(N - 1)) * g[-(N - 1)]))/(N - 2)
+ m <- ST/2
+ s <- ST * sqrt(1/(12 * (N - 2)))
+ (stat - m)/s
+}
diff --git a/R/howmanytrees.R b/R/howmanytrees.R
new file mode 100644
index 0000000..228c914
--- /dev/null
+++ b/R/howmanytrees.R
@@ -0,0 +1,44 @@
+## howmanytrees.R (2004-12-23)
+
+## Calculate Numbers of Phylogenetic Trees
+
+## Copyright 2004 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+howmanytrees <- function(n, rooted = TRUE, binary = TRUE,
+ labeled = TRUE, detail = FALSE)
+{
+ if (!labeled && !(rooted & binary))
+ stop("can compute number of unlabeled trees only for rooted binary cases.")
+ if (n < 3) N <- 1 else {
+ if (labeled) {
+ if (!rooted) n <- n - 1
+ if (binary) N <- prod(seq(1, (2*n - 3), by = 2))
+ else {
+ N <- matrix(0, n, n - 1)
+ N[1:n, 1] <- 1
+ for (i in 3:n)
+ for (j in 2:(i - 1))
+ N[i, j] <- (i + j - 2)*N[i - 1, j - 1] + j*N[i - 1, j]
+ if (detail) {
+ rownames(N) <- 1:n
+ colnames(N) <- 1:(n - 1)
+ } else N <- sum(N[n, ])
+ }
+ } else {
+ N <- numeric(n)
+ N[1] <- 1
+ for (i in 2:n)
+ if (i %% 2) N[i] <- sum(N[1:((i - 1)/2)]*N[(i - 1):((i + 1)/2)]) else {
+ x <- N[1:(i/2)]
+ y <- N[(i - 1):(i/2)]
+ y[length(y)] <- (y[length(y)] + 1)/2
+ N[i] <- sum(x*y)
+ }
+ if (detail) names(N) <- 1:n else N <- N[n]
+ }
+ }
+ N
+}
diff --git a/R/identify.phylo.R b/R/identify.phylo.R
new file mode 100644
index 0000000..64ecc38
--- /dev/null
+++ b/R/identify.phylo.R
@@ -0,0 +1,44 @@
+## identify.phylo.R (2011-03-23)
+
+## Graphical Identification of Nodes and Tips
+
+## Copyright 2008-2011 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+identify.phylo <- function(x, nodes = TRUE, tips = FALSE,
+ labels = FALSE, quiet = FALSE, ...)
+{
+ if (!quiet)
+ cat("Click close to a node of the tree...\n")
+ xy <- locator(1)
+ if (is.null(xy)) return(NULL)
+ lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv)
+ ## rescale the coordinates (especially if the x- and
+ ## y-scales are very different):
+ pin <- par("pin")
+ rescaleX <- pin[1]/max(lastPP$xx)
+ xx <- rescaleX * lastPP$xx
+ rescaleY <- pin[2]/max(lastPP$yy)
+ yy <- rescaleY * lastPP$yy
+ xy$x <- rescaleX * xy$x
+ xy$y <- rescaleY * xy$y
+ ## end of rescaling
+ d <- (xy$x - xx)^2 + (xy$y - yy)^2 # no need to sqrt()
+ NODE <- which.min(d)
+ res <- list()
+ if (NODE <= lastPP$Ntip) {
+ res$tips <- if (labels) x$tip.label[NODE] else NODE
+ return(res)
+ }
+ if (tips) {
+ TIPS <- prop.part(x)[[NODE - lastPP$Ntip]]
+ res$tips <- if (labels) x$tip.label[TIPS] else TIPS
+ }
+ if (nodes) {
+ if (is.null(x$node.label)) labels <- FALSE
+ res$nodes <- if (labels) x$node.label[NODE - lastPP$Ntip] else NODE
+ }
+ res
+}
diff --git a/R/is.binary.tree.R b/R/is.binary.tree.R
new file mode 100644
index 0000000..1bff336
--- /dev/null
+++ b/R/is.binary.tree.R
@@ -0,0 +1,26 @@
+## is.binary.tree.R (2002-09-12) [modified by EP 2005-05-31, 2005-08-18,
+## 2006-10-04, 2009-05-10]
+
+## Tests whether a given phylogenetic tree is binary
+
+## Copyright 2002 Korbinian Strimmer
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+is.binary.tree <- function(phy)
+{
+ if (!inherits(phy, "phylo")) stop('object "phy" is not of class "phylo"')
+ ## modified by EP so that it works without edge lengths too (2005-05-31):
+ nb.tip <- length(phy$tip.label)
+ nb.node <- phy$Nnode
+ ## modified by EP so that it works with both rooted and unrooted
+ ## trees (2005-08-18):
+ if (is.rooted(phy)) {
+ if (nb.tip - 1 == nb.node) return(TRUE)
+ else return(FALSE)
+ } else {
+ if (nb.tip - 2 == nb.node) return(TRUE)
+ else return(FALSE)
+ }
+}
diff --git a/R/is.compatible.R b/R/is.compatible.R
new file mode 100644
index 0000000..522e4f7
--- /dev/null
+++ b/R/is.compatible.R
@@ -0,0 +1,36 @@
+## is.compatible.R (2011-10-11)
+
+## Check Compatibility of Splits
+
+## Copyright 2011 Andrei-Alin Popescu
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+is.compatible <- function(obj) UseMethod("is.compatible")
+
+is.compatible.bitsplits <- function(obj)
+{
+ m <- obj$matsplit
+ n <- ncol(m)
+ ntaxa <- length(obj$labels)
+ for (i in 1:(n - 1))
+ for (j in (i + 1):n)
+ if (!arecompatible(m[, i], m[, j], ntaxa))
+ return(FALSE)
+ TRUE
+}
+
+arecompatible <-function(x, y, n)
+{
+ msk <- !as.raw(2^(8 - (n %% 8)) - 1)
+
+ foo <- function(v) {
+ lv <- length(v)
+ v[lv] <- v[lv] & msk
+ as.integer(all(v == as.raw(0)))
+ }
+
+ nE <- foo(x & y) + foo(x & !y) + foo(!x & y) + foo(!x & !y)
+ if (nE == 1) TRUE else FALSE
+}
diff --git a/R/is.monophyletic.R b/R/is.monophyletic.R
new file mode 100644
index 0000000..10dc6b5
--- /dev/null
+++ b/R/is.monophyletic.R
@@ -0,0 +1,52 @@
+## is.monophyletic.R (2012-03-23)
+
+## Test Monophyly
+
+## Copyright 2009-2012 Johan Nylander and Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+is.monophyletic <-
+ function(phy, tips, reroot = !is.rooted(phy), plot = FALSE, ...)
+{
+ if (!inherits(phy, "phylo"))
+ stop("object 'phy' is not of class 'phylo'")
+ n <- length(phy$tip.label)
+ if (length(tips) %in% c(1L, n)) return(TRUE)
+ ROOT <- n + 1L
+ if (is.numeric(tips)) {
+ if (any(tips > n))
+ stop("incorrect tip#: should not be greater than the number of tips")
+ tips <- sort(as.integer(tips))
+ }
+ if (is.character(tips))
+ tips <- which(phy$tip.label %in% tips)
+
+ if (reroot) {
+ outgrp <- phy$tip.label[-tips][1]
+ phy <- root(phy, outgroup = outgrp, resolve.root = TRUE)
+ rerooted <- TRUE
+ } else rerooted <- FALSE
+
+ phy <- reorder(phy)
+
+ seq.nod <- .Call(seq_root2tip, phy$edge, n, phy$Nnode)
+ sn <- seq.nod[tips]
+ newroot <- ROOT
+ i <- 2
+ repeat {
+ x <- unique(unlist(lapply(sn, "[", i)))
+ if (length(x) != 1) break
+ newroot <- x
+ i <- i + 1
+ }
+ desc <- which(unlist(lapply(seq.nod, function(x) any(x %in% newroot))))
+ if (plot) {
+ zoom(phy, tips, subtree = FALSE, ...)
+ if (rerooted)
+ mtext("Input tree arbitrarily rerooted", side = 1, cex = 0.9)
+ }
+ ## assuming that both vectors are sorted:
+ identical(tips, desc)
+}
diff --git a/R/is.ultrametric.R b/R/is.ultrametric.R
new file mode 100644
index 0000000..792684f
--- /dev/null
+++ b/R/is.ultrametric.R
@@ -0,0 +1,36 @@
+## is.ultrametric.R (2012-02-09)
+
+## Test if a Tree is Ultrametric
+
+## Copyright 2003-2012 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+is.ultrametric <- function(phy, tol = .Machine$double.eps^0.5)
+{
+ if (!inherits(phy, "phylo"))
+ stop('object "phy" is not of class "phylo"')
+ if (is.null(phy$edge.length))
+ stop("the tree has no branch lengths")
+
+ phy <- reorder(phy)
+ n <- length(phy$tip.label)
+ e1 <- phy$edge[, 1]
+ e2 <- phy$edge[, 2]
+ EL <- phy$edge.length
+
+ ## xx: vecteur donnant la distance d'un noeud
+ ## ou d'un tip � partir de la racine
+ xx <- numeric(n + phy$Nnode)
+
+ ## the following must start at the root and follow the
+ ## edges contiguously; so the tree must be either in cladewise
+ ## order (or in pruningwise but the for loop must start from
+ ## the bottom of the edge matrix)
+
+ for (i in seq_len(length(e1)))
+ xx[e2[i]] <- xx[e1[i]] + EL[i]
+
+ isTRUE(all.equal.numeric(var(xx[1:n]), 0, tolerance = tol))
+}
diff --git a/R/ladderize.R b/R/ladderize.R
new file mode 100644
index 0000000..30e71f0
--- /dev/null
+++ b/R/ladderize.R
@@ -0,0 +1,41 @@
+## ladderize.R (2007-01-04)
+
+## Ladderize a Tree
+
+## Copyright 2007 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+ladderize <- function(phy, right = TRUE)
+{
+ foo <- function(node, END, where) {
+ start <- which(phy$edge[, 1] == node)
+ end <- c(start[-1] - 1, END)
+ size <- end - start + 1
+ desc <- phy$edge[start, 2]
+ Nclade <- length(desc)
+ n <- N[desc]
+ o <- order(n, decreasing = right)
+ newpos <- c(0, cumsum(size[o][-Nclade])) + where
+ desc <- desc[o]
+ end <- end[o]
+ start <- start[o]
+ neworder[newpos] <<- start
+ for (i in 1:Nclade)
+ if (desc[i] > nb.tip) foo(desc[i], end[i], newpos[i] + 1)
+ }
+ nb.tip <- length(phy$tip.label)
+ nb.node <- phy$Nnode
+ nb.edge <- dim(phy$edge)[1]
+ tmp <- reorder(phy, "postorder")
+ N <- .C(node_depth, as.integer(nb.tip), as.integer(nb.node),
+ as.integer(tmp$edge[, 1]), as.integer(tmp$edge[, 2]),
+ as.integer(nb.edge), double(nb.tip + nb.node), 1L)[[6]]
+ neworder <- integer(nb.edge)
+ foo(nb.tip + 1, nb.edge, 1)
+ phy$edge <- phy$edge[neworder, ]
+ if (!is.null(phy$edge.length))
+ phy$edge.length <- phy$edge.length[neworder]
+ phy
+}
diff --git a/R/lmorigin.R b/R/lmorigin.R
new file mode 100644
index 0000000..8e1d890
--- /dev/null
+++ b/R/lmorigin.R
@@ -0,0 +1,163 @@
+'lmorigin' <-
+function(formula, data=NULL, origin=TRUE, nperm=999, method=NULL, silent=FALSE)
+#
+# This program computes a multiple linear regression and performs tests
+# of significance of the equation parameters using permutations.
+#
+# origin=TRUE: the regression line can be forced through the origin. Testing
+# the significance in that case requires a special permutation procedure.
+#
+# Permutation methods: raw data or residuals of full model
+# Default method in regression through the origin: raw data
+# Default method in ordinary multiple regression: residuals of full model
+# - In ordinary multiple regression when m = 1: raw data
+#
+# Pierre Legendre, March 2009
+{
+if(!is.null(method)) method <- match.arg(method, c("raw", "residuals"))
+if(is.null(method) & origin==TRUE) method <- "raw"
+if(is.null(method) & origin==FALSE) method <- "residuals"
+if(nperm < 0) stop("Incorrect value for 'nperm'")
+
+## From the formula, find the variables and the number of observations 'n'
+toto <- lm(formula, data)
+mf <- match.call(expand.dots = FALSE)
+m <- match(c("formula", "data", "offset"), names(mf), 0)
+mf <- mf[c(1, m)]
+mf$drop.unused.levels <- TRUE
+mf[[1]] <- as.name("model.frame")
+mf <- eval(mf, parent.frame())
+var.names = colnames(mf) # Noms des variables
+y <- as.matrix(mf[,1])
+colnames(y) <- var.names[1]
+X <- as.matrix(mf[,-1])
+n <- nrow(mf)
+m <- ncol(X)
+
+a <- system.time({
+mm<- m # No. regression coefficients, possibly including the intercept
+if(m == 1) method <- "raw"
+if(nrow(X) != n) stop("Unequal number of rows in y and X")
+
+if(origin) {
+ if(!silent) cat("Regression through the origin",'\n')
+ reg <- lm(y ~ 0 + X)
+ } else {
+ if(!silent) cat("Multiple regression with estimation of intercept",'\n')
+ reg <- lm(y ~ X)
+ mm <- mm+1
+ }
+
+if(!silent) {
+ if(nperm > 0) {
+ if(method == "raw") {
+ cat("Permutation method =",method,"data",'\n')
+ } else {
+ cat("Permutation method =",method,"of full model",'\n')
+ }
+ }
+ }
+t.vec <- summary(reg)$coefficients[,3]
+p.param.t <- summary(reg)$coefficients[,4]
+df1 <- summary(reg)$fstatistic[[2]]
+df2 <- summary(reg)$fstatistic[[3]]
+F <- summary(reg)$fstatistic[[1]]
+y.res <- summary(reg)$residuals
+# b.vec <- summary(reg)$coefficients[,1]
+# r.sq <- summary(reg)$r.squared
+# adj.r.sq <- summary(reg)$adj.r.squared
+# p.param.F <- pf(F, df1, df2, lower.tail=FALSE)
+
+if(df1 < m) stop("\nCollinearity among the X variables. Check using 'lm'")
+
+# Permutation tests
+if(nperm > 0) {
+
+ nGT.F <- 1
+ nGT1.t <- rep(1,mm)
+ nGT2.t <- rep(1,mm)
+ sign.t <- sign(t.vec)
+
+ for(i in 1:nperm) # Permute raw data. Always use this method for F-test
+ {
+ if(origin) { # Regression through the origin
+ dia.bin <- diag((rbinom(n,1,0.5)*2)-1)
+ y.perm <- dia.bin %*% sample(y)
+ reg.perm <- lm(y.perm ~ 0 + X)
+ } else { # Multiple linear regression
+ y.perm <- sample(y,n)
+ reg.perm <- lm(y.perm ~ X)
+ }
+
+ # Permutation test of the F-statistic
+ F.perm <- summary(reg.perm)$fstatistic[1]
+ if(F.perm >= F) nGT.F <- nGT.F+1
+
+ # Permutation tests of the t-statistics: permute raw data
+ if(method == "raw") {
+ t.perm <- summary(reg.perm)$coefficients[,3]
+ if(nperm <= 5) cat(t.perm,'\n')
+ for(j in 1:mm) {
+ # One-tailed test in direction of sign
+ if(t.perm[j]*sign.t[j] >= t.vec[j]*sign.t[j]) nGT1.t[j] <- nGT1.t[j]+1
+ # Two-tailed test
+ if( abs(t.perm[j]) >= abs(t.vec[j]) ) nGT2.t[j] <- nGT2.t[j]+1
+ }
+ }
+ }
+
+ if(method == "residuals") {
+ # Permute residuals of full model
+ for(i in 1:nperm) {
+ if(origin) { # Regression through the origin
+ dia.bin <- diag((rbinom(n,1,0.5)*2)-1)
+ y.perm <- dia.bin %*% sample(y.res)
+ reg.perm <- lm(y.perm ~ 0 + X)
+ } else { # Multiple linear regression
+ y.perm <- sample(y.res,n)
+ reg.perm <- lm(y.perm ~ X)
+ }
+
+ # Permutation tests of the t-statistics: permute residuals
+ t.perm <- summary(reg.perm)$coefficients[,3]
+ if(nperm <= 5) cat(t.perm,'\n')
+ for(j in 1:mm) {
+ # One-tailed test in direction of sign
+ if(t.perm[j]*sign.t[j] >= t.vec[j]*sign.t[j]) nGT1.t[j] <- nGT1.t[j]+1
+ # Two-tailed test
+ if( abs(t.perm[j]) >= abs(t.vec[j]) ) nGT2.t[j] <- nGT2.t[j]+1
+ }
+ }
+ }
+ # Compute the permutational probabilities
+ p.perm.F <- nGT.F/(nperm+1)
+ p.perm.t1 <- nGT1.t/(nperm+1)
+ p.perm.t2 <- nGT2.t/(nperm+1)
+
+ ### Do not test intercept by permutation of residuals in multiple regression
+ if(!origin & method=="residuals") {
+ if(silent) { # Note: silent==TRUE in simulation programs
+ p.perm.t1[1] <- p.perm.t2[1] <- 1
+ } else {
+ p.perm.t1[1] <- p.perm.t2[1] <- NA
+ }
+ }
+ }
+
+})
+a[3] <- sprintf("%2f",a[3])
+if(!silent) cat("Computation time =",a[3]," sec",'\n')
+#
+if(nperm == 0) {
+
+ out <- list(reg=reg, p.param.t.2tail=p.param.t, p.param.t.1tail=p.param.t/2, origin=origin, nperm=nperm, var.names=var.names, call=match.call())
+
+ } else {
+
+ out <- list(reg=reg, p.param.t.2tail=p.param.t, p.param.t.1tail=p.param.t/2, p.perm.t.2tail=p.perm.t2, p.perm.t.1tail=p.perm.t1, p.perm.F=p.perm.F, origin=origin, nperm=nperm, method=method, var.names=var.names, call=match.call())
+
+ }
+#
+class(out) <- "lmorigin"
+out
+}
diff --git a/R/ltt.plot.R b/R/ltt.plot.R
new file mode 100644
index 0000000..98f188d
--- /dev/null
+++ b/R/ltt.plot.R
@@ -0,0 +1,150 @@
+## ltt.plot.R (2012-03-05)
+
+## Lineages Through Time Plot
+
+## Copyright 2002-2012 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+ltt.plot.coords <- function(phy, backward = TRUE, tol = 1e-6)
+{
+ if (is.ultrametric(phy, tol)) {
+ if (is.binary.tree(phy)) {
+ N <- numeric(phy$Nnode + 1)
+ N[] <- 1
+ } else {
+ node.order <- tabulate(phy$edge[, 1])
+ N <- node.order[-(1:length(phy$tip.label))] - 1
+ }
+ bt <- branching.times(phy)
+ names(bt) <- NULL
+ o <- order(bt, decreasing = TRUE)
+ time <- c(-bt[o], 0)
+ if (!is.binary.tree(phy)) N <- c(1, N[o])
+ } else {
+ if (!is.binary.tree(phy)) phy <- multi2di(phy)
+ n <- Ntip(phy)
+ m <- phy$Nnode
+ ROOT <- n + 1L
+ event <- time.event <- numeric(n + m)
+
+ time.event[ROOT] <- 0
+ phy <- reorder(phy)
+
+ for (i in 1:nrow(phy$edge))
+ time.event[phy$edge[i, 2]] <- time.event[phy$edge[i, 1]] + phy$edge.length[i]
+
+ present <- max(time.event)
+ event[1:n] <- -1
+ event[ROOT:(n + m)] <- 1
+
+ ## delete the events that are too close to present:
+ past.event <- present - time.event > tol
+ event <- event[past.event]
+ time.event <- time.event[past.event]
+
+ ## reorder wrt time:
+ o <- order(time.event)
+ time.event <- time.event[o]
+ event <- event[o]
+
+ time <- c(time.event - present, 0)
+ N <- c(1, event)
+ }
+ N <- cumsum(N)
+ if (!is.null(phy$root.edge)) {
+ time <- c(time[1] - phy$root.edge, time)
+ N <- c(1, N)
+ }
+ if (!backward) time <- time - time[1]
+ cbind(time, N)
+}
+
+ltt.plot <- function(phy, xlab = "Time", ylab = "N",
+ backward = TRUE, tol = 1e-6, ...)
+{
+ if (!inherits(phy, "phylo"))
+ stop("object \"phy\" is not of class \"phylo\"")
+
+ xy <- ltt.plot.coords(phy, backward, tol)
+
+ plot.default(xy, xlab = xlab, ylab = ylab, xaxs = "r",
+ yaxs = "r", type = "S", ...)
+}
+
+ltt.lines <- function(phy, backward = TRUE, tol = 1e-6, ...)
+{
+ xy <- ltt.plot.coords(phy, backward, tol)
+ lines(xy, type = "S", ...)
+}
+
+mltt.plot <-
+ function(phy, ..., dcol = TRUE, dlty = FALSE, legend = TRUE,
+ xlab = "Time", ylab = "N", log = "", backward = TRUE, tol = 1e-6)
+{
+ if (inherits(phy, "phylo")) { # if a tree of class "phylo"
+ TREES <- list(ltt.plot.coords(phy, backward, tol))
+ names(TREES) <- deparse(substitute(phy))
+ } else { # a list of trees
+ TREES <- lapply(phy, ltt.plot.coords, backward = backward, tol = tol)
+ names(TREES) <- names(phy)
+ if (is.null(names(TREES)))
+ names(TREES) <-
+ paste(deparse(substitute(phy)), "-", 1:length(TREES))
+ }
+ dts <- list(...)
+ n <- length(dts)
+ if (n) {
+ mc <- as.character(match.call())[-(1:2)]
+ nms <- mc[1:n]
+ for (i in 1:n) {
+ if (inherits(dts[[i]], "phylo")) {
+ a <- list(ltt.plot.coords(dts[[i]], backward, tol))
+ names(a) <- nms[i]
+ } else { # a list of trees
+ a <- lapply(dts[[i]], ltt.plot.coords, backward = backward, tol = tol)
+ names(a) <- names(dts[[i]])
+ if (is.null(names(a)))
+ names(a) <- paste(deparse(substitute(phy)), "-", seq_along(a))
+ }
+ TREES <- c(TREES, a)
+ }
+ }
+ n <- length(TREES)
+ range.each.tree <- sapply(TREES, function(x) range(x[, 1]))
+ xl <- range(range.each.tree)
+ yl <- c(1, max(sapply(TREES, function(x) max(x[, 2]))))
+
+ ## if backward is FALSE, we have to rescale the time scales of each tree:
+ if (!backward) {
+ for (i in seq_along(TREES)) {
+ tmp <- TREES[[i]]
+ tmp[, 1] <- tmp[, 1] + xl[2] - range.each.tree[2, i]
+ TREES[[i]] <- tmp
+ }
+ }
+
+ plot.default(NA, type = "n", xlim = xl, ylim = yl, xaxs = "r",
+ yaxs = "r", xlab = xlab, ylab = ylab, log = log)
+
+ lty <- if (!dlty) rep(1, n) else 1:n
+ col <- if (!dcol) rep(1, n) else topo.colors(n)
+
+ for (i in 1:n)
+ lines(TREES[[i]], col = col[i], lty = lty[i], type = "S")
+
+ if (legend)
+ legend(xl[1], yl[2], legend = names(TREES),
+ lty = lty, col = col, bty = "n")
+}
+
+ltt.coplot <- function(phy, backward = TRUE, ...)
+{
+ layout(matrix(1:2, 2))
+ par(mar = c(0, 3, 0.5, 0.5))
+ o <- plot(phy, root.edge = TRUE, ...)
+ par(mar = c(3, 3, 0, 0.5))
+ ltt.plot(phy, xlim = o$x.lim, backward = FALSE, xaxt = "n")
+ if (backward) axisPhylo() else axis(1)
+}
diff --git a/R/makeLabel.R b/R/makeLabel.R
new file mode 100644
index 0000000..3f5b1ed
--- /dev/null
+++ b/R/makeLabel.R
@@ -0,0 +1,117 @@
+## makeLabel.R (2013-06-04)
+
+## Label Management
+
+## Copyright 2010-2013 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+makeLabel <- function(x, ...) UseMethod("makeLabel")
+
+makeLabel.character <- function(x, len = 99, space = "_",
+ make.unique = TRUE, illegal = "():;,[]", quote = FALSE, ...)
+{
+ x <- gsub("[[:space:]]", space, x)
+ if (illegal != "") {
+ illegal <- unlist(strsplit(illegal, NULL))
+ for (i in illegal) x <- gsub(i, "", x, fixed = TRUE)
+ }
+ if (quote) len <- len - 2
+ nc <- nchar(x) > len
+ if (any(nc)) x[nc] <- substr(x[nc], 1, len)
+ tab <- table(x)
+ if (all(tab == 1)) make.unique <- FALSE
+ if (make.unique) {
+ dup <- tab[which(tab > 1)]
+ nms <- names(dup)
+ for (i in 1:length(dup)) {
+ j <- which(x == nms[i])
+ end <- nchar(x[j][1])
+ ## w: number of characters to be added as suffix
+ w <- floor(log10(dup[i])) + 1
+ suffix <- formatC(1:dup[i], width = w, flag = "0")
+ if (end + w > len) {
+ start <- end - w + 1
+ substr(x[j], start, end) <- suffix
+ } else x[j] <- paste(x[j], suffix, sep = "")
+ }
+ }
+ if (quote) x <- paste('"', x, '"', sep = "")
+ x
+}
+
+makeLabel.phylo <- function(x, tips = TRUE, nodes = TRUE, ...)
+{
+ if (tips)
+ x$tip.label <- makeLabel.character(x$tip.label, ...)
+ if (!is.null(x$node.label) && nodes)
+ x$node.label <- makeLabel.character(x$node.label, ...)
+ x
+}
+
+makeLabel.multiPhylo <- function(x, tips = TRUE, nodes = TRUE, ...)
+{
+ y <- attr(x, "TipLabel")
+ if (is.null(y)) {
+ for (i in 1:length(x))
+ x[[i]] <- makeLabel.phylo(x[[i]], tips = tips, nodes = nodes, ...)
+ } else {
+ attr(x, "TipLabel") <- makeLabel.character(y, ...)
+ }
+ x
+}
+
+makeLabel.DNAbin <- function(x, ...)
+{
+ if (is.vector(x) || is.list(x))
+ names(x) <- makeLabel.character(names(x), ...)
+ else rownames(x) <- makeLabel.character(rownames(x), ...)
+ x
+}
+
+mixedFontLabel <-
+ function(..., sep = " ", italic = NULL, bold = NULL, parenthesis = NULL,
+ always.upright = c("sp.", "spp.", "ssp."))
+{
+ x <- list(...)
+ n <- length(x)
+
+ if (!is.null(italic)) {
+ for (i in italic) {
+ y <- x[[i]]
+ s <- ! y %in% always.upright
+ y[s] <- paste("italic(\"", y[s], "\")", sep = "")
+ if (any(!s)) y[!s] <- paste("plain(\"", y[!s], "\")", sep = "")
+ x[[i]] <- y
+ }
+ }
+
+ if (!is.null(bold)) {
+ for (i in bold) {
+ y <- x[[i]]
+ s <- logical(length(y))
+ s[grep("^italic", y)] <- TRUE
+ y[s] <- sub("^italic", "bolditalic", y[s])
+ y[!s] <- paste("bold(\"", y[!s], "\")", sep = "")
+ x[[i]] <- y
+ }
+ }
+
+ k <- which(! 1:n %in% c(italic, bold)) # those in upright
+ if (length(k))
+ for (i in k)
+ x[[i]] <- paste("plain(\"", x[[i]], "\")", sep = "")
+
+ if (!is.null(parenthesis))
+ for (i in parenthesis)
+ x[[i]] <- paste("(", x[[i]], ")", sep = "")
+
+ res <- x[[1L]]
+ if (n > 1) {
+ sep <- rep(sep, length.out = n - 1L)
+ for (i in 2:n)
+ res <- paste(res, "*\"", sep[i - 1L], "\"*", x[[i]], sep = "")
+ }
+ parse(text = res)
+}
diff --git a/R/makeNodeLabel.R b/R/makeNodeLabel.R
new file mode 100644
index 0000000..d806d04
--- /dev/null
+++ b/R/makeNodeLabel.R
@@ -0,0 +1,60 @@
+## makeNodeLabel.R (2009-03-22)
+
+## Makes Node Labels
+
+## Copyright 2009 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+makeNodeLabel <- function(phy, method = "number", prefix = "Node",
+ nodeList = list(), ...)
+{
+ method <- sapply(method, match.arg, c("number", "md5sum", "user"),
+ USE.NAMES = FALSE)
+
+ if ("number" %in% method)
+ phy$node.label <- paste(prefix, 1:phy$Nnode, sep = "")
+
+ if ("md5sum" %in% method) {
+ nl <- character(phy$Nnode)
+ pp <- prop.part(phy, check.labels = FALSE)
+ labs <- attr(pp, "labels")
+ fl <- tempfile()
+ for (i in seq_len(phy$Nnode)) {
+ cat(sort(labs[pp[[i]]]), sep = "\n", file = fl)
+ nl[i] <- tools::md5sum(fl)
+ }
+ unlink(fl)
+ phy$node.label <- nl
+ }
+
+ if ("user" %in% method) {
+ if (is.null(phy$node.label))
+ phy$node.label <- character(phy$Nnode)
+ nl <- names(nodeList)
+ if (is.null(nl)) stop("argument 'nodeList' has no names")
+ Ntip <- length(phy$tip.label)
+ seq.nod <- .Call(seq_root2tip, phy$edge, Ntip, phy$Nnode)
+ ## a local version to avoid the above call many times:
+ .getMRCA <- function(seq.nod, tip) {
+ sn <- seq.nod[tip]
+ MRCA <- Ntip + 1
+ i <- 2
+ repeat {
+ x <- unique(unlist(lapply(sn, "[", i)))
+ if (length(x) != 1) break
+ MRCA <- x
+ i <- i + 1
+ }
+ MRCA
+ }
+ for (i in seq_along(nodeList)) {
+ tips <- sapply(nodeList[[i]], grep, phy$tip.label, ...,
+ USE.NAMES = FALSE)
+ j <- .getMRCA(seq.nod, unique(unlist(tips)))
+ phy$node.label[j - Ntip] <- nl[i]
+ }
+ }
+ phy
+}
diff --git a/R/mantel.test.R b/R/mantel.test.R
new file mode 100644
index 0000000..0de2ad9
--- /dev/null
+++ b/R/mantel.test.R
@@ -0,0 +1,42 @@
+## mantel.test.R (2012-03-16)
+
+## Mantel Test for Similarity of Two Matrices
+
+## Copyright 2002-2011 Ben Bolker and Julien Claude
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+perm.rowscols <- function(m1, n)
+{
+ s <- sample(1:n)
+ m1[s, s]
+}
+
+### calculate the Mantel z-statistic for two square matrices m1 and m2
+mant.zstat <- function(m1, m2) sum(lower.triang(m1 * m2))
+
+lower.triang <- function(m)
+{
+ if (diff(dim(m))) print("Warning: non-square matrix")
+ m[col(m) <= row(m)]
+}
+
+mantel.test <- function(m1, m2, nperm = 999, graph = FALSE,
+ alternative = "two.sided", ...)
+{
+ alternative <- match.arg(alternative, c("two.sided", "less", "greater"))
+ n <- nrow(m1)
+ realz <- mant.zstat(m1, m2)
+ nullstats <- replicate(nperm, mant.zstat(m1, perm.rowscols(m2, n)))
+ pval <- switch(alternative,
+ "two.sided" = 2 * min(sum(nullstats >= realz), sum(nullstats <= realz)),
+ "less" = sum(nullstats <= realz),
+ "greater" = sum(nullstats >= realz))
+ pval <- (pval + 1) / (nperm + 1) # 'realz' is included in 'nullstats'
+ if (graph) {
+ plot(density(nullstats), type = "l", ...)
+ abline(v = realz)
+ }
+ list(z.stat = realz, p = pval, alternative = alternative)
+}
diff --git a/R/matexpo.R b/R/matexpo.R
new file mode 100644
index 0000000..5f472b9
--- /dev/null
+++ b/R/matexpo.R
@@ -0,0 +1,18 @@
+## ladderize.R (2007-10-08)
+
+## Matrix Exponential
+
+## Copyright 2007 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+matexpo <- function(x)
+{
+ if (!is.matrix(x)) stop('"x" must be a matrix')
+ nr <- dim(x)[1]
+ if (nr != dim(x)[2]) stop('"x" must be a square matrix')
+ ans <- .C(mat_expo, as.double(x), as.integer(nr))[[1]]
+ dim(ans) <- c(nr, nr)
+ ans
+}
diff --git a/R/mcmc.popsize.R b/R/mcmc.popsize.R
new file mode 100644
index 0000000..4ab7058
--- /dev/null
+++ b/R/mcmc.popsize.R
@@ -0,0 +1,440 @@
+## mcmc.popsize.R (2013-07-19)
+
+## Run reversible jump MCMC to sample demographic histories
+
+## Copyright 2004-2013 Rainer Opgen-Rhein and Korbinian Strimmer
+
+## Portions of this function are adapted from rjMCMC code by
+## Karl W Broman (see http://www.biostat.wisc.edu/~kbroman/)
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+# public function
+
+# run rjMCMC chain
+if (getRversion() >= "2.15.1")
+ utils::globalVariables(c("loglik", "b.lin", "popsize"))
+
+mcmc.popsize <-
+ function(tree, nstep, thinning = 1, burn.in = 0, progress.bar = TRUE,
+ method.prior.changepoints = c("hierarchical", "fixed.lambda"),
+ max.nodes = 30,
+ lambda = 0.5, # "fixed.lambda" method.prior.changepoints
+ gamma.shape = 0.5,
+ gamma.scale = 2, # gamma distribution from which lambda is drawn (for "hierarchical" method)
+ method.prior.heights = c("skyline", "constant", "custom"),
+ prior.height.mean, prior.height.var)
+{
+ method.prior.changepoints <- match.arg(method.prior.changepoints)
+ method.prior.heights <- match.arg(method.prior.heights)
+
+ ## Calculate skylineplot, coalescent intervals
+ ## and estimated population sizes
+
+ if (inherits(tree, "phylo")) {
+ ci <- coalescent.intervals(tree)
+ sk1 <- skyline(ci)
+ } else if (class(tree) == "coalescentIntervals") {
+ ci <- tree
+ sk1 <- skyline(ci)
+ } else
+ stop("tree must be an object of class phylo or coalescentIntervals")
+
+ ## consider possibility of more than one lineage
+ ci$lineages <- ci$lineages[sk1$interval.length > 0]
+ ci$interval.length <- ci$interval.length[sk1$interval.length > 0]
+ data <- sk1$time <- sk1$time[sk1$interval.length > 0]
+ sk1$population.size <- sk1$population.size[sk1$interval.length > 0]
+ sk1$interval.length <- sk1$interval.length[sk1$interval.length > 0]
+
+ ## constant prior for heights
+
+ if (method.prior.heights == "constant") {
+ prior.height.mean <- function(position)
+ mean(sk1$population.size)
+ prior.height.var <- function(position)
+ (mean(sk1$population.size))^2
+ }
+
+ ## skyline plot prior for heights
+
+ if (method.prior.heights == "skyline") {
+ TIME <- sk1$time
+ numb.interv <- 10
+ prior.change.times <- abs((0:numb.interv) * max(TIME)/numb.interv)
+ prior.height.mean.all <- prior.height.var.all <- vector(length = numb.interv)
+ for (p.int in 1:(numb.interv)) {
+ left <- p.int
+ right <- p.int + 1
+ sample.pop <- sk1$population.size[sk1$time >= prior.change.times[left] & sk1$time <= prior.change.times[right]]
+ while (length(sample.pop) < 10) {
+ if (left > 1) left <- left - 1
+ if (right < length(prior.change.times)) right <- right + 1
+ sample.pop <- sk1$population.size[sk1$time >= prior.change.times[left] & sk1$time <= prior.change.times[right]]
+ }
+ prior.height.mean.all[p.int] <- sum(sample.pop)/length(sample.pop)
+ prior.height.var.all[p.int] <- sum((sample.pop-prior.height.mean.all[p.int])^2)/(length(sample.pop) - 1)
+ }
+
+ prior.height.mean <- function(position) {
+ j <- sum(prior.change.times <= position)
+ if (j >= length(prior.height.mean.all)) j <- length(prior.height.mean.all)
+ prior.mean <- prior.height.mean.all[j]
+ prior.mean
+ }
+
+ prior.height.var <- function(position) {
+ j <- sum(prior.change.times <= position)
+ if (j >= length(prior.height.var.all)) j <- length(prior.height.var.all)
+ prior.var <- prior.height.var.all[j]
+ prior.var
+ }
+ }
+
+ if (method.prior.heights == "custom") {
+ if (missing(prior.height.mean) || missing(prior.height.var))
+ stop("custom priors not specified")
+ }
+
+ ## set prior
+ prior <- vector(length = 4)
+ prior[4] <- max.nodes
+
+ ## set initial position of markov chain and likelihood
+ pos <- c(0, max(data))
+ h <- c(rep(mean(sk1$population.size), 2))
+
+ b.lin <- choose(ci$lineages, 2)
+ ## loglik <<- loglik.pop # modified by EP
+
+ ## set lists for data
+ count.it <- floor((nstep - burn.in)/thinning)
+ save.pos <- save.h <- vector("list", count.it)
+ save.loglik <- 1:count.it
+ save.steptype <- 1:count.it
+ save.accept <- 1:count.it
+
+ ## calculate jump probabilities for given lambda of the prior
+ if (method.prior.changepoints == "fixed.lambda") {
+ prior[1] <- lambda
+ jump.prob <- matrix(ncol = 4, nrow = prior[4] + 1)
+ p <- dpois(0:prior[4], prior[1])/ppois(prior[4] + 1, prior[1])
+ bk <- c(p[-1]/p[-length(p)], 0)
+ bk[bk > 1] <- 1
+ dk <- c(0, p[-length(p)]/p[-1])
+ dk[dk > 1] <- 1
+ mx <- max(bk + dk)
+ bk <- bk/mx*0.9
+ dk <- dk/mx*0.9
+ bk[is.na(bk)] <- 0 # added
+ dk[is.na(dk)] <- 0 # added
+ jump.prob[, 3] <- bk
+ jump.prob[, 4] <- dk
+ jump.prob[1, 2] <- 0
+ jump.prob[1, 1] <- 1 - bk[1] - dk[1]
+ jump.prob[-1, 1] <- jump.prob[-1, 2] <-
+ (1 - jump.prob[-1, 3] - jump.prob[-1, 4])/2
+ }
+
+
+ ## calculate starting loglik
+ curloglik <- loglik.pop(data, pos, h, b.lin, sk1, ci)
+
+ count.i <- 1
+
+ ## set progress bar
+ if (progress.bar == TRUE) {
+ dev.new(width = 3, height = 0.7)
+ par(mar = c(0.5, 0.5, 2, 0.5))
+ plot(x = c(0, 0), y = c(0, 1), type = "l", xlim = c(0, 1), ylim = c(0, 1),
+ main = "rjMCMC in progress", ylab = "", xlab = "", xaxs = "i",
+ yaxs = "i", xaxt = "n", yaxt = "n")
+ }
+
+ ## BEGIN CALCULATION
+
+ for (i in (1:nstep + 1)) {
+ if (progress.bar == TRUE) {
+ if (i %% 100 == 0) {
+ z <- i/nstep
+ zt <- (i - 100)/(nstep)
+ polygon(c(zt, zt, z, z), c(1, 0, 0, 1), col = "black")
+ }
+ }
+
+ ## calculate jump probabilities without given lamda
+ if (method.prior.changepoints == "hierarchical") {
+ prior[1] <- rgamma(1, shape = gamma.shape, scale = gamma.scale)
+ jump.prob <- matrix(ncol = 4, nrow = prior[4] + 1)
+ p <- dpois(0:prior[4], prior[1]) / ppois(prior[4] + 1, prior[1])
+ bk <- c(p[-1]/p[-length(p)], 0)
+ bk[bk > 1] <- 1
+ dk <- c(0, p[-length(p)]/p[-1])
+ dk[dk > 1] <- 1
+ mx <- max(bk + dk)
+ bk <- bk/mx*0.9
+ dk <- dk/mx*0.9
+ bk[is.na(bk)] <- 0 # added
+ dk[is.na(dk)] <- 0 # added
+ jump.prob[, 3] <- bk
+ jump.prob[, 4] <- dk
+ jump.prob[1, 2] <- 0
+ jump.prob[1, 1] <- 1 - bk[1] - dk[1]
+ jump.prob[-1, 1] <- jump.prob[-1, 2] <-
+ (1 - jump.prob[-1, 3] - jump.prob[-1, 4])/2
+ }
+
+ ## determine what type of jump to make
+ wh <- sample(1:4, 1, prob = jump.prob[length(h)-1, ])
+
+ if (i %% thinning == 0 & i > burn.in) save.steptype[[count.i]] <- wh
+
+ if (wh == 1) {
+ step <- ht.move(data, pos, h, curloglik, prior, b.lin, sk1, ci, prior.height.mean, prior.height.var)
+ h <- step[[1]]
+ curloglik <- step[[2]]
+ if (i %% thinning == 0 & i > burn.in) {
+ save.pos[[count.i]] <- pos
+ save.h[[count.i]] <- h
+ save.loglik[[count.i]] <- step[[2]]
+ save.accept[[count.i]] <- step[[3]]
+ }
+ } else if (wh == 2) {
+ step <- pos.move(data, pos, h, curloglik, b.lin, sk1, ci)
+ pos <- step[[1]]
+ curloglik <- step[[2]]
+ if (i %% thinning == 0 & i > burn.in) {
+ save.pos[[count.i]] <- pos
+ save.h[[count.i]] <- h
+ save.loglik[[count.i]] <- step[[2]]
+ save.accept[[count.i]] <- step[[3]]
+ }
+ } else if (wh == 3) {
+ step <- birth.step(data, pos, h, curloglik, prior, jump.prob, b.lin, sk1, ci, prior.height.mean, prior.height.var)
+ pos <- step[[1]]
+ h <- step[[2]]
+ curloglik <- step[[3]]
+ if (i %% thinning == 0 & i > burn.in) {
+ save.pos[[count.i]] <- pos
+ save.h[[count.i]] <- h
+ save.loglik[[count.i]] <- step[[3]]
+ save.accept[[count.i]] <- step[[4]]
+ }
+ } else {
+ step <- death.step(data, pos, h, curloglik, prior, jump.prob, b.lin, sk1, ci, prior.height.mean, prior.height.var)
+ pos <- step[[1]]
+ h <- step[[2]]
+ curloglik <- step[[3]]
+ if (i %% thinning == 0 & i > burn.in) {
+ save.pos[[count.i]] <- pos
+ save.h[[count.i]] <- h
+ save.loglik[[count.i]] <- step[[3]]
+ save.accept[[count.i]] <- step[[4]]
+ }
+ }
+ if (i %% thinning == 0 & i > burn.in) count.i <- count.i + 1
+ }
+
+ if (progress.bar == TRUE) dev.off()
+
+ list(pos = save.pos, h = save.h, loglik = save.loglik,
+ steptype = save.steptype, accept = save.accept)
+}
+
+## private functions
+
+ht.move <-
+ function(data, pos, h, curloglik, prior, b.lin, sk1, ci, prior.height.mean, prior.height.var)
+{
+ j <- sample(1:length(h), 1)
+
+ prior.mean <- prior.height.mean(pos[j])
+ prior.var <- prior.height.var(pos[j])
+
+ prior[3] <- prior.mean/prior.var
+ prior[2] <- (prior.mean^2)/prior.var
+
+ newh <- h
+ newh[j] <- h[j] * exp(runif(1, -0.5, 0.5))
+
+ newloglik <- loglik.pop(data, pos, newh, b.lin, sk1, ci)
+ lr <- newloglik - curloglik
+
+ ratio <- exp(lr + prior[2] * (log(newh[j]) - log(h[j])) - prior[3] * (newh[j] - h[j]))
+
+ if (runif(1, 0, 1) < ratio)
+ return(list(newh, newloglik, 1))
+ else
+ return(list(h, curloglik, 0))
+}
+
+pos.move <- function(data, pos, h, curloglik, b.lin, sk1, ci)
+{
+ j <- if (length(pos) == 3) 2 else sample(2:(length(pos)-1), 1)
+ newpos <- pos
+ left <- pos[j - 1]
+ right <- pos[j + 1]
+ newpos[j] <- runif(1, left, right)
+
+ newloglik <- loglik.pop(data, newpos, h, b.lin, sk1, ci)
+ lr <- newloglik - curloglik
+
+ ratio <- exp(lr) * (right - newpos[j])*(newpos[j]- left)/
+ (right - pos[j])/(pos[j] - left)
+
+ if (runif(1, 0, 1) < ratio)
+ return(list(newpos, newloglik, 1))
+ else
+ return(list(pos, curloglik, 0))
+}
+
+birth.step <-
+ function(data, pos, h, curloglik, prior, jump.prob, b.lin, sk1, ci, prior.height.mean, prior.height.var)
+{
+ newpos <- runif(1, 0, pos[length(pos)])
+ j <- sum(pos < newpos)
+
+ left <- pos[j]
+ right <- pos[j + 1]
+
+ prior.mean <- prior.height.mean(pos[j])
+ prior.var <- prior.height.var(pos[j])
+ prior[3] <- prior.mean/prior.var
+ prior[2] <- (prior.mean^2)/prior.var
+
+ u <- runif(1, -0.5, 0.5)
+ oldh <- (((newpos - left)/(right - left))*(h[j + 1] - h[j]) + h[j])
+ newheight <- oldh*(1 + u)
+
+ ## ratio
+ ## recall that prior = (lambda, alpha, beta, maxk)
+ k <- length(pos) - 2
+ L <- max(pos)
+
+ prior.logratio <- log(prior[1]) - log(k+1) + log((2*k + 3)*(2*k + 2)) - 2*log(L) +
+ log(newpos - left) + log(right - newpos) - log(right - left) +
+ prior[2]*log(prior[3]) - lgamma(prior[2]) +
+ (prior[2] - 1) * log(newheight) + prior[3]*(newheight)
+
+ proposal.ratio <- jump.prob[k + 2, 4]*L/jump.prob[k + 1, 3]/(k + 1)
+ jacobian <- (((newpos - left)/(right - left))*(h[j + 1] - h[j])) + h[j]
+
+ ## form new parameters
+ newpos <- sort(c(pos, newpos))
+ newh <- c(h[1:j], newheight, h[(j + 1):length(h)])
+
+ newloglik <- loglik.pop(data, newpos, newh, b.lin, sk1, ci)
+ lr <- newloglik - curloglik
+ ratio <- exp(lr + prior.logratio) * proposal.ratio * jacobian
+
+ if (runif(1, 0, 1) < ratio)
+ return(list(newpos, newh, newloglik, 1))
+ else
+ return(list(pos, h, curloglik, 0))
+}
+
+death.step <-
+ function(data, pos, h, curloglik, prior, jump.prob, b.lin, sk1, ci, prior.height.mean, prior.height.var)
+{
+ ## position to drop
+ if (length(pos) == 3) j <- 2
+ else j <- sample(2:(length(pos) - 1), 1)
+
+ left <- pos[j - 1]
+ right <- pos[j + 1]
+
+ prior.mean <- prior.height.mean(pos[j])
+ prior.var <- prior.height.var(pos[j])
+ prior[3] <- prior.mean/prior.var
+ prior[2] <- (prior.mean^2)/prior.var
+
+ ## get new height
+ h.left <- h[j - 1]
+ h.right <- h[j + 1]
+ newheight <- (((pos[j] - left)/(right - left))*(h.right - h.left) + h.left)
+
+ ## ratio
+ ## recall that prior = (lambda, alpha, beta, maxk)
+ k <- length(pos) - 3
+ L <- max(pos)
+
+ prior.logratio <- log(k+1) - log(prior[1]) - log(2*(k + 1)*(2*k + 3)) + 2*log(L) -
+ log(pos[j] - left) - log(right - pos[j]) + log(right - left) -
+ prior[2]*log(prior[3]) + lgamma(prior[2]) -
+ (prior[2]-1) * log(newheight) - prior[3]*(newheight)
+ proposal.ratio <- (k + 1)*jump.prob[k + 1, 3]/jump.prob[k + 2, 4]/L
+ jacobian <- ((pos[j] - left)/(right - left))*(h[j + 1] - h[j - 1]) + h[j - 1]
+
+ ## form new parameters
+ newpos <- pos[-j]
+ newh <- h[-j]
+
+ newloglik <- loglik.pop(data, newpos, newh, b.lin, sk1, ci)
+ lr <- newloglik - curloglik
+ ratio <- exp(lr + prior.logratio) * proposal.ratio * (jacobian^(-1))
+
+ if (runif(1, 0, 1) < ratio)
+ return(list(newpos, newh, newloglik, 1))
+ else
+ return(list(pos, h, curloglik, 0))
+
+
+}
+
+# calculate the log likelihood for a set of data
+loglik.pop <-
+ function(time = sk1$time, pos = c(0, max(sk1$time)), h = mean(sk1$population.size), b = b.lin, sk1, ci)
+{
+ data.time <- c(0, time)
+
+ leftside <- 0
+ i <- 1
+ h1 <- c(h, h[length(h)])
+ pos1 <- c(pos, pos[length(pos)])
+ while (i < length(time)) {
+ left.pos <- sum(data.time[i + 1] >= pos)
+ right.pos <- left.pos + 1
+ h.mix <- (((data.time[i + 1] - pos[left.pos])/(pos[right.pos] - pos[left.pos]))*(h[right.pos] - h[left.pos])) + h[left.pos]
+ leftside <- leftside + log(b[i]/h.mix)
+ i <- i + 1
+ }
+
+ rightside <- 0
+ time1 <- c(0, time)
+ time.count <- 1
+
+ ## heigths of jumps
+ jumps <- sort(c(time1, pos))
+ h.jumps <- jumps
+ while (time.count <= length(jumps)) {
+ left.pos <- sum(jumps[time.count] >= pos)
+ right.pos <- left.pos + 1
+ h.jumps[time.count] <- (((jumps[time.count] - pos[left.pos])/(pos[right.pos] - pos[left.pos]))*(h[right.pos] - h[left.pos])) + h[left.pos]
+ if (is.na(h.jumps[time.count])) h.jumps[time.count] <- h[left.pos]
+ time.count <- time.count + 1
+ }
+
+ ## Vector for lineages
+ i <- 1
+ lineages.jumps <- jumps
+ while (i <= length(jumps)) {
+ lineages.jumps[i] <- sum(jumps[i] >= time)
+ if (lineages.jumps[i] == 0) lineages.jumps[i] <- 1
+ i <- i + 1
+ }
+ lineage <- ci$lineages[lineages.jumps]
+ b1 <- choose(lineage, 2)
+
+ ## Integral
+ a <- (h.jumps[-1] - h.jumps[-length(h.jumps)])/(jumps[-1] - jumps[-length(jumps)])
+ c <- h.jumps[-1] - jumps[-1] * a
+ area <- (1/a) * log(a*jumps[-1] + c) - (1/a)*log(a * jumps[-length(jumps)] + c)
+ stepfunction <- (jumps[-1] - jumps[-length(jumps)])/h.jumps[-1]
+ area[is.na(area)] <- stepfunction[is.na(area)]
+
+ rightside <- sum(area * b1[-1])
+
+ loglik <- leftside - rightside
+ loglik
+}
diff --git a/R/me.R b/R/me.R
new file mode 100644
index 0000000..3c1e229
--- /dev/null
+++ b/R/me.R
@@ -0,0 +1,66 @@
+## me.R (2012-09-14)
+
+## Tree Estimation Based on Minimum Evolution Algorithm
+
+## Copyright 2007 Vincent Lefort with modifications by
+## Emmanuel Paradis (2008-2012)
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+fastme.bal <- function(X, nni = TRUE, spr = TRUE, tbr = TRUE)
+{
+ if (is.matrix(X)) X <- as.dist(X)
+ N <- as.integer(attr(X, "Size"))
+ nedge <- 2L * N - 3L
+ ans <- .C(me_b, as.double(X), N, 1:N, as.integer(nni),
+ as.integer(spr), as.integer(tbr), integer(nedge),
+ integer(nedge), double(nedge), NAOK = TRUE)
+ labels <- attr(X, "Labels")
+ if (is.null(labels)) labels <- as.character(1:N)
+ labels <- labels[ans[[3]]]
+ obj <- list(edge = cbind(ans[[7]], ans[[8]]),
+ edge.length = ans[[9]],
+ tip.label = labels, Nnode = N - 2L)
+ class(obj) <- "phylo"
+ attr(obj, "order") <- "cladewise"
+ obj
+}
+
+fastme.ols <- function(X, nni = TRUE)
+{
+ if (is.matrix(X)) X <- as.dist(X)
+ N <- as.integer(attr(X, "Size"))
+ nedge <- 2L * N - 3L
+ ans <- .C(me_o, as.double(X), N, 1:N, as.integer(nni),
+ integer(nedge), integer(nedge), double(nedge),
+ NAOK = TRUE)
+ labels <- attr(X, "Labels")
+ if (is.null(labels)) labels <- as.character(1:N)
+ labels <- labels[ans[[3]]]
+ obj <- list(edge = cbind(ans[[5]], ans[[6]]),
+ edge.length = ans[[7]],
+ tip.label = labels, Nnode = N - 2L)
+ class(obj) <- "phylo"
+ attr(obj, "order") <- "cladewise"
+ obj
+}
+
+bionj <- function(X)
+{
+ if (is.matrix(X)) X <- as.dist(X)
+ if (any(is.na(X)))
+ stop("missing values are not allowed in the distance matrix.\nConsider using bionjs()")
+ if (any(X > 100))
+ stop("at least one distance was greater than 100")
+ N <- as.integer(attr(X, "Size"))
+
+ ans <- .C(C_bionj, as.double(X), N, integer(2 * N - 3),
+ integer(2 * N - 3), double(2*N - 3), NAOK = TRUE)
+ labels <- attr(X, "Labels")
+ if (is.null(labels)) labels <- as.character(1:N)
+ obj <- list(edge = cbind(ans[[3]], ans[[4]]), edge.length = ans[[5]],
+ tip.label = labels, Nnode = N - 2L)
+ class(obj) <- "phylo"
+ reorder(obj)
+}
diff --git a/R/mrca.R b/R/mrca.R
new file mode 100644
index 0000000..0c4b429
--- /dev/null
+++ b/R/mrca.R
@@ -0,0 +1,89 @@
+## mrca.R (2009-05-10)
+
+## Find Most Recent Common Ancestors Between Pairs
+
+## Copyright 2005-2009 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+mrca <- function(phy, full = FALSE)
+{
+ if (!inherits(phy, "phylo")) stop('object "phy" is not of class "phylo"')
+ ## if (!is.rooted(phy)) stop("the tree must be rooted.")
+ ## Get all clades:
+ nb.tip <- length(phy$tip.label)
+ nb.node <- phy$Nnode
+ BP <- .Call(bipartition, phy$edge, nb.tip, nb.node)
+ N <- nb.tip + nb.node
+ ROOT <- nb.tip + 1
+ ## In the following matrix, numeric indexing will be used:
+ M <- numeric(N * N)
+ dim(M) <- c(N, N)
+
+ ## We start at the root:
+ next.node <- ROOT
+ while (length(next.node)) {
+ tmp <- numeric(0)
+ for (anc in next.node) {
+ ## Find the branches which `anc' is the ancestor...:
+ id <- which(phy$edge[, 1] == anc)
+ ## ... and get their descendants:
+ desc <- phy$edge[id, 2]
+ ## `anc' is itself the MRCA of its direct descendants:
+ M[anc, desc] <- M[desc, anc] <- anc
+ ## Find all 2-by-2 combinations of `desc': `anc'
+ ## is their MRCA:
+ for (i in 1:length(desc))
+ M[cbind(desc[i], desc[-i])] <- anc
+ ## If one element of `desc' is a node, then the tips it
+ ## leads to and the other elements of `desc' have also
+ ## `anc' as MRCA!
+ for (i in 1:length(desc)) {
+ if (desc[i] < ROOT) next
+ ## (get the tips:)
+ tips <- BP[[desc[i] - nb.tip]]
+ ## Same thing for the nodes...
+ node.desc <- numeric(0)
+ for (k in 1:nb.node) {
+ if (k == desc[i] - nb.tip) next
+ ## If the clade of the current node is a
+ ## subset of desc[i], then it is one of its
+ ## descendants:
+ if (all(BP[[k]] %in% tips))
+ node.desc <- c(node.desc, k)
+ }
+ ## all nodes and tips which are descendants of
+ ## `desc[i]':
+ ALLDESC <- c(tips, node.desc + nb.tip)
+ M[ALLDESC, desc[-i]] <- M[desc[-i], ALLDESC] <- anc
+ for (j in 1:length(desc)) {
+ if (j == i || desc[j] < ROOT) next
+ tips2 <- BP[[desc[j] - nb.tip]]
+ node.desc <- numeric(0)
+ for (k in 1:nb.node) {
+ if (k == desc[j] - nb.tip) next
+ if (all(BP[[k]] %in% tips2))
+ node.desc <- c(node.desc, k)
+ }
+ ALLDESC2 <- c(tips2, node.desc + nb.tip)
+ M[ALLDESC, ALLDESC2] <- M[ALLDESC2, ALLDESC] <- anc
+ }
+ ## `anc' is also the MRCA of itself and its descendants:
+ M[ALLDESC, anc] <- M[anc, ALLDESC] <- anc
+ }
+ ## When it is done, `desc' i stored to become
+ ## the new `next.node', if they are nodes:
+ tmp <- c(tmp, desc[desc > nb.tip])
+ }
+ next.node <- tmp
+ }
+ M[cbind(1:N, 1:N)] <- 1:N
+ if (full)
+ dimnames(M)[1:2] <- list(as.character(1:N))
+ else {
+ M <- M[1:nb.tip, 1:nb.tip]
+ dimnames(M)[1:2] <- list(phy$tip.label)
+ }
+ M
+}
diff --git a/R/mst.R b/R/mst.R
new file mode 100644
index 0000000..2b16658
--- /dev/null
+++ b/R/mst.R
@@ -0,0 +1,90 @@
+## mst.R (2006-11-08)
+
+## Minimum Spanning Tree
+
+## Copyright 2002-2006 Yvonnick Noel, Julien Claude, and Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+mst <- function(X)
+{
+ if (class(X) == "dist") X <- as.matrix(X)
+ n <- dim(X)[1]
+ N <- matrix(0, n, n)
+ tree <- NULL
+ large.value <- max(X) + 1
+ diag(X) <- large.value
+ index.i <- 1
+
+ for (i in 1:(n - 1)) {
+ tree <- c(tree, index.i)
+ m <- apply(as.matrix(X[, tree]), 2, min) #calcul les minimum par colonne
+ a <- sortIndex(X[, tree])[1, ]
+ b <- sortIndex(m)[1]
+ index.j <- tree[b]
+ index.i <- a[b]
+
+ N[index.i, index.j] <- 1
+ N[index.j, index.i] <- 1
+
+ for (j in tree) {
+ X[index.i, j] <- large.value
+ X[j, index.i] <- large.value
+ }
+ }
+ dimnames(N) <- dimnames(X)
+ class(N) <- "mst"
+ return(N)
+}
+
+### Function returning an index matrix for an increasing sort
+sortIndex <- function(X)
+{
+ if(length(X) == 1) return(1) # sorting a scalar?
+ if(!is.matrix(X)) X <- as.matrix(X) # force vector into matrix
+ ## n <- nrow(X)
+ apply(X, 2, function(v) order(rank(v))) # find the permutation
+}
+
+plot.mst <- function(x, graph = "circle", x1 = NULL, x2 = NULL, ...)
+{
+ n <- nrow(x)
+ if (is.null(x1) || is.null(x2)) {
+ if (graph == "circle") {
+ ang <- seq(0, 2 * pi, length = n + 1)
+ x1 <- cos(ang)
+ x2 <- sin(ang)
+ plot(x1, x2, type = "n", xlab = "", ylab = "",
+ xaxt = "n", yaxt = "n", bty = "n", ...)
+ }
+ if (graph == "nsca") {
+ XY <- nsca(x)
+ x1 <- XY[, 1]
+ x2 <- XY[, 2]
+ plot(XY, type = "n", xlab = "\"nsca\" -- axis 1",
+ ylab = "\"nsca\" -- axis 2", ...)
+ }
+ } else plot(x1, x2, type = "n", xlab = deparse(substitute(x1)),
+ ylab = deparse(substitute(x2)), ...)
+ for (i in 1:n) {
+ w1 <- which(x[i, ] == 1)
+ segments(x1[i], x2[i], x1[w1], x2[w1])
+ }
+ points(x1, x2, pch = 21, col = "black", bg = "white", cex = 3)
+ text(x1, x2, 1:n, cex = 0.8)
+}
+
+nsca <- function(A)
+{
+ Dr <- apply(A, 1, sum)
+ Dc <- apply(A, 2, sum)
+
+ eig.res <- eigen(diag(1 / sqrt(Dr)) %*% A %*% diag(1 / sqrt(Dc)))
+ r <- diag(1 / Dr) %*% (eig.res$vectors)[, 2:4]
+ ## The next line has been changed by EP (20-02-2003), since
+ ## it does not work if 'r' has no dimnames already defined
+ ## dimnames(r)[[1]] <- dimnames(A)[[1]]
+ rownames(r) <- rownames(A)
+ r
+}
diff --git a/R/multi2di.R b/R/multi2di.R
new file mode 100644
index 0000000..2f9b62b
--- /dev/null
+++ b/R/multi2di.R
@@ -0,0 +1,125 @@
+## multi2di.R (2010-01-23)
+
+## Collapse and Resolve Multichotomies
+
+## Copyright 2005-2010 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+multi2di <- function(phy, random = TRUE)
+{
+ degree <- tabulate(phy$edge[, 1])
+ target <- which(degree > 2)
+ if (!length(target)) return(phy)
+ nb.edge <- dim(phy$edge)[1]
+ n <- length(phy$tip.label)
+ nextnode <- n + phy$Nnode + 1
+ new.edge <- edge2delete <- NULL
+ wbl <- FALSE
+ if (!is.null(phy$edge.length)) {
+ wbl <- TRUE
+ new.edge.length <- NULL
+ }
+
+ for (node in target) {
+ ind <- which(phy$edge[, 1] == node)
+ N <- length(ind)
+ desc <- phy$edge[ind, 2]
+ if (random) {
+ ## if we shuffle the descendants, we need to eventually
+ ## reorder the corresponding branch lenghts (see below)
+ ## so we store the result of sample()
+ tmp <- sample(length(desc))
+ desc <- desc[tmp]
+ res <- rtree(N)$edge
+ } else {
+ res <- matrix(0, 2*N - 2, 2)
+ res[, 1] <- N + rep(1:(N - 1), each = 2)
+ res[, 2] <- N + rep(2:N, each = 2)
+ res[seq(1, by = 2, length.out = N - 1), 2] <- 1:(N - 1)
+ res[length(res)] <- N
+ }
+ if (wbl) {
+ ## keep the branch lengths coming from `node'
+ el <- numeric(dim(res)[1]) # initialized with 0's
+ el[res[, 2] <= N] <-
+ if (random) phy$edge.length[ind][tmp] else phy$edge.length[ind]
+ }
+ ## now substitute the nodes in `res'
+ ## `node' stays at the "root" of these new
+ ## edges whereas their "tips" are `desc'
+ Nodes <- c(node, seq(from = nextnode, length.out = N - 2))
+ res[, 1] <- Nodes[res[, 1] - N]
+ tmp <- res[, 2] > N
+ res[tmp, 2] <- Nodes[res[tmp, 2] - N]
+ res[!tmp, 2] <- desc[res[!tmp, 2]]
+ new.edge <- rbind(new.edge, res)
+ edge2delete <- c(edge2delete, ind)
+ if (wbl) new.edge.length <- c(new.edge.length, el)
+ nextnode <- nextnode + N - 2
+ phy$Nnode <- phy$Nnode + N - 2
+ }
+ phy$edge <- rbind(phy$edge[-edge2delete, ], new.edge)
+ if (wbl)
+ phy$edge.length <- c(phy$edge.length[-edge2delete], new.edge.length)
+ if (!is.null(attr(phy, "order"))) attr(phy, "order") <- NULL
+ if (!is.null(phy$node.label))
+ phy$node.label <-
+ c(phy$node.label, rep("", phy$Nnode - length(phy$node.label)))
+ phy <- reorder(phy)
+
+ ## the node numbers are not in increasing order in edge[, 2]: this
+ ## will confuse drop.tip and other functions (root), so renumber them
+ newNb <- integer(phy$Nnode)
+ newNb[1] <- n + 1L
+ sndcol <- phy$edge[, 2] > n
+
+ ## reorder node labels before changing edge:
+ if (!is.null(phy$node.label)) {
+ o <- 1 + rank(phy$edge[sndcol, 2])
+ ## the root's label is not changed:
+ phy$node.label <- phy$node.label[c(1, o)]
+ }
+
+ ## executed from right to left, so newNb is modified before phy$edge:
+ phy$edge[sndcol, 2] <- newNb[phy$edge[sndcol, 2] - n] <-
+ n + 2:phy$Nnode
+ phy$edge[, 1] <- newNb[phy$edge[, 1] - n]
+ phy
+}
+
+di2multi <- function(phy, tol = 1e-8)
+{
+ if (is.null(phy$edge.length)) stop("the tree has no branch length")
+ ## We select only the internal branches which are
+ ## significantly small:
+ ind <- which(phy$edge.length < tol & phy$edge[, 2] > length(phy$tip.label))
+ n <- length(ind)
+ if (!n) return(phy)
+ ## recursive function to `propagate' node #'s in case
+ ## there is a series of consecutive edges to remove
+ foo <- function(ancestor, des2del) {
+ wh <- which(phy$edge[, 1] == des2del)
+ for (k in wh) {
+ if (phy$edge[k, 2] %in% node2del) foo(ancestor, phy$edge[k, 2])
+ else phy$edge[k, 1] <<- ancestor
+ }
+ }
+ node2del <- phy$edge[ind, 2]
+ anc <- phy$edge[ind, 1]
+ for (i in 1:n) {
+ if (anc[i] %in% node2del) next
+ foo(anc[i], node2del[i])
+ }
+ phy$edge <- phy$edge[-ind, ]
+ phy$edge.length <- phy$edge.length[-ind]
+ phy$Nnode <- phy$Nnode - n
+ ## Now we renumber the nodes that need to be:
+ sel <- phy$edge > min(node2del)
+ for (i in which(sel))
+ phy$edge[i] <- phy$edge[i] - sum(node2del < phy$edge[i])
+ if (!is.null(phy$node.label))
+ phy$node.label <- phy$node.label[-(node2del - length(phy$tip.label))]
+ phy
+}
diff --git a/R/mvr.R b/R/mvr.R
new file mode 100644
index 0000000..937cfec
--- /dev/null
+++ b/R/mvr.R
@@ -0,0 +1,52 @@
+## mvr.R (2012-03-30)
+
+## Minimum Variance Reduction
+
+## Copyright 2011 Andrei-Alin Popescu
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+mvr <- function(X, V)
+{
+ if (is.matrix(X)) X <- as.dist(X)
+ if (is.matrix(V)) V <- as.dist(V)
+ if (any(is.na(X)))
+ stop("missing values are not allowed in the distance matrix")
+ if (any(is.na(V)))
+ stop("missing values are not allowed in the variance matrix")
+ N <- attr(X, "Size")
+ labels <- attr(X, "Labels")
+ if (is.null(labels)) labels <- as.character(1:N)
+ ans <- .C(C_mvr, as.double(X), as.double(V), as.integer(N),
+ integer(2*N - 3), integer(2*N - 3), double(2*N - 3),
+ NAOK = TRUE)
+ obj <- list(edge = cbind(ans[[4]], ans[[5]]), edge.length = ans[[6]],
+ tip.label = labels, Nnode = N - 2L)
+ class(obj) <- "phylo"
+ reorder(obj)
+}
+
+mvrs <- function(X, V, fs = 15)
+{
+ if (fs < 1)
+ stop("argument 'fs' must be a non-zero positive integer")
+
+ if (is.matrix(X)) X <- as.dist(X)
+ if (is.matrix(V)) V <- as.dist(V)
+
+ X[is.na(X)] <- -1
+ X[X < 0] <- -1
+ X[is.nan(X)] <- -1
+
+ N <- attr(X, "Size")
+ labels <- attr(X, "Labels")
+ if (is.null(labels)) labels <- as.character(1:N)
+ ans <- .C(C_mvrs, as.double(X), as.double(V), as.integer(N),
+ integer(2*N - 3), integer(2*N - 3), double(2*N - 3),
+ as.integer(fs), NAOK = TRUE)
+ obj <- list(edge = cbind(ans[[4]], ans[[5]]), edge.length = ans[[6]],
+ tip.label = labels, Nnode = N - 2L)
+ class(obj) <- "phylo"
+ reorder(obj)
+}
diff --git a/R/nj.R b/R/nj.R
new file mode 100644
index 0000000..3a49f45
--- /dev/null
+++ b/R/nj.R
@@ -0,0 +1,24 @@
+## nj.R (2009-11-23)
+
+## Neighbor-Joining Tree Estimation
+
+## Copyright 2004-2009 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+nj <- function(X)
+{
+ if (is.matrix(X)) X <- as.dist(X)
+ if (any(is.na(X)))
+ stop("missing values are not allowed in the distance matrix\nConsider using njs()")
+ N <- attr(X, "Size")
+ labels <- attr(X, "Labels")
+ if (is.null(labels)) labels <- as.character(1:N)
+ ans <- .C(C_nj, as.double(X), as.integer(N), integer(2*N - 3),
+ integer(2*N - 3), double(2*N - 3), NAOK = TRUE)
+ obj <- list(edge = cbind(ans[[3]], ans[[4]]), edge.length = ans[[5]],
+ tip.label = labels, Nnode = N - 2L)
+ class(obj) <- "phylo"
+ reorder(obj)
+}
diff --git a/R/njs.R b/R/njs.R
new file mode 100644
index 0000000..4b894e8
--- /dev/null
+++ b/R/njs.R
@@ -0,0 +1,48 @@
+## njs.R (2013-10-04)
+
+## Tree Reconstruction from Incomplete Distances With NJ* or bio-NJ*
+
+## Copyright 2011-2013 Andrei-Alin Popescu
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+njs <- function(X, fs = 15)
+{
+ if (fs < 1)
+ stop("argument 'fs' must be a non-zero positive integer")
+ if (is.matrix(X)) X <- as.dist(X)
+ X[is.na(X)] <- -1
+ X[X < 0] <- -1
+ X[is.nan(X)] <- -1
+ N <- attr(X, "Size")
+ labels <- attr(X, "Labels")
+ if (is.null(labels)) labels <- as.character(1:N)
+ ans <- .C(C_njs, as.double(X), as.integer(N), integer(2*N - 3),
+ integer(2*N - 3), double(2*N - 3), as.integer(fs),
+ NAOK = TRUE)
+ obj <- list(edge = cbind(ans[[3]], ans[[4]]), edge.length = ans[[5]],
+ tip.label = labels, Nnode = N - 2L)
+ class(obj) <- "phylo"
+ reorder(obj)
+}
+
+bionjs <- function(X, fs = 15)
+{
+ if (fs < 1)
+ stop("argument 'fs' must be a non-zero positive integer")
+ if (is.matrix(X)) X <- as.dist(X)
+ X[is.na(X)] <- -1
+ X[X < 0] <- -1
+ X[is.nan(X)] <- -1
+ N <- attr(X, "Size")
+ labels <- attr(X, "Labels")
+ if (is.null(labels)) labels <- as.character(1:N)
+ ans <- .C(C_bionjs, as.double(X), as.integer(N), integer(2*N - 3),
+ integer(2*N - 3), double(2*N - 3), as.integer(fs),
+ NAOK = TRUE)
+ obj <- list(edge = cbind(ans[[3]], ans[[4]]), edge.length = ans[[5]],
+ tip.label = labels, Nnode = N - 2L)
+ class(obj) <- "phylo"
+ reorder(obj)
+}
diff --git a/R/nodelabels.R b/R/nodelabels.R
new file mode 100644
index 0000000..4d1aebb
--- /dev/null
+++ b/R/nodelabels.R
@@ -0,0 +1,296 @@
+## nodelabels.R (2013-09-21)
+
+## Labelling Trees
+
+## Copyright 2004-2013 Emmanuel Paradis, 2006 Ben Bolker, and 2006 Jim Lemon
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+## from JL:
+## floating.pie() from plotrix with two changes:
+## (1) aspect ratio fixed, so pies will appear circular
+## (`radius' is the radius in user coordinates along the x axis);
+## (2) zero values allowed (but not negative).
+
+floating.pie.asp <- function(xpos, ypos, x, edges = 200, radius = 1,
+ col = NULL, startpos = 0, ...)
+{
+ u <- par("usr")
+ user.asp <- diff(u[3:4])/diff(u[1:2])
+ p <- par("pin")
+ inches.asp <- p[2]/p[1]
+ asp <- user.asp/inches.asp
+ if (!is.numeric(x) || any(is.na(x) | x < 0))
+ stop("floating.pie: x values must be non-negative")
+ x <- c(0, cumsum(x)/sum(x))
+ dx <- diff(x)
+ nx <- length(dx)
+ col <- if (is.null(col)) rainbow(nx) else rep(col, length.out = nx) # rep_len(col, nx) was introduced in R 3.0.0 so we avoid it to keep working with older versions of R
+ ## next a fix from Klaus to avoid a "3-o'clock" segment on pies with
+ ## only one proportion equal to 1:
+ if (length(i <- which(dx == 1))) {
+ symbols(xpos, ypos, circles = radius, inches = FALSE, add = TRUE,
+ fg = 1, bg = col[i])
+ } else {
+ bc <- 2 * pi * (x[1:nx] + dx/2) + startpos
+ for (i in seq_len(nx)) {
+ n <- max(2, floor(edges * dx[i]))
+ t2p <- 2 * pi * seq(x[i], x[i + 1], length = n) + startpos
+ xc <- c(cos(t2p) * radius + xpos, xpos)
+ yc <- c(sin(t2p) * radius*asp + ypos, ypos)
+ polygon(xc, yc, col = col[i], ...)
+ }
+ }
+}
+
+BOTHlabels <- function(text, sel, XX, YY, adj, frame, pch, thermo,
+ pie, piecol, col, bg, horiz, width, height, ...)
+{
+ if (missing(text)) text <- NULL
+ if (length(adj) == 1) adj <- c(adj, 0.5)
+ if (is.null(text) && is.null(pch) && is.null(thermo) && is.null(pie))
+ text <- as.character(sel)
+ frame <- match.arg(frame, c("rect", "circle", "none"))
+ args <- list(...)
+ CEX <- if ("cex" %in% names(args)) args$cex else par("cex")
+ if (frame != "none" && !is.null(text)) {
+ if (frame == "rect") {
+ width <- strwidth(text, units = "inches", cex = CEX)
+ height <- strheight(text, units = "inches", cex = CEX)
+ if ("srt" %in% names(args)) {
+ args$srt <- args$srt %% 360 # just in case srt >= 360
+ if (args$srt == 90 || args$srt == 270) {
+ tmp <- width
+ width <- height
+ height <- tmp
+ } else if (args$srt != 0)
+ warning("only right angle rotation of frame is supported;\n try `frame = \"n\"' instead.\n")
+ }
+ width <- xinch(width)
+ height <- yinch(height)
+ xl <- XX - width*adj[1] - xinch(0.03)
+ xr <- xl + width + xinch(0.03)
+ yb <- YY - height*adj[2] - yinch(0.02)
+ yt <- yb + height + yinch(0.05)
+ rect(xl, yb, xr, yt, col = bg)
+ }
+ if (frame == "circle") {
+ radii <- 0.8*apply(cbind(strheight(text, units = "inches", cex = CEX),
+ strwidth(text, units = "inches", cex = CEX)), 1, max)
+ symbols(XX, YY, circles = radii, inches = max(radii), add = TRUE, bg = bg)
+ }
+ }
+ if (!is.null(thermo)) {
+ parusr <- par("usr")
+
+ if (is.null(width)) {
+ width <- CEX * (parusr[2] - parusr[1])
+ width <- if (horiz) width/15 else width/40
+ }
+
+ if (is.null(height)) {
+ height <- CEX * (parusr[4] - parusr[3])
+ height <- if (horiz) height/40 else height/15
+ }
+
+ if (is.vector(thermo)) thermo <- cbind(thermo, 1 - thermo)
+ thermo <- if (horiz) width * thermo else height * thermo
+ if (is.null(piecol)) piecol <- rainbow(ncol(thermo))
+
+ xl <- XX - width/2 + adj[1] - 0.5 # added 'adj' from Janet Young (2009-09-30)
+ xr <- xl + width
+ yb <- YY - height/2 + adj[2] - 0.5
+ yt <- yb + height
+
+ if (horiz) {
+ ## draw the first rectangle:
+ rect(xl, yb, xl + thermo[, 1], yt, border = NA, col = piecol[1])
+ for (i in 2:ncol(thermo))
+ rect(xl + rowSums(thermo[, 1:(i - 1), drop = FALSE]), yb,
+ xl + rowSums(thermo[, 1:i]), yt, border = NA, col = piecol[i])
+ } else {
+ ## draw the first rectangle:
+ rect(xl, yb, xr, yb + thermo[, 1], border = NA, col = piecol[1])
+ for (i in 2:ncol(thermo))
+ rect(xl, yb + rowSums(thermo[, 1:(i - 1), drop = FALSE]),
+ xr, yb + rowSums(thermo[, 1:i]),
+ border = NA, col = piecol[i])
+ }
+
+ ## check for NA's before drawing the borders
+ s <- apply(thermo, 1, function(xx) any(is.na(xx)))
+ xl[s] <- xr[s] <- NA
+ rect(xl, yb, xr, yt, border = "black")
+
+ if (!horiz) {
+ segments(xl, YY, xl - width/5, YY)
+ segments(xr, YY, xr + width/5, YY)
+ }
+ }
+ ## from BB:
+ if (!is.null(pie)) {
+ if (is.vector(pie)) pie <- cbind(pie, 1 - pie)
+ xrad <- CEX * diff(par("usr")[1:2]) / 50
+ xrad <- rep(xrad, length(sel))
+ XX <- XX + adj[1] - 0.5
+ YY <- YY + adj[2] - 0.5
+ for (i in seq_along(sel)) {
+ if (any(is.na(pie[i, ]))) next
+ floating.pie.asp(XX[i], YY[i], pie[i, ], radius = xrad[i], col = piecol)
+ }
+ }
+ if (!is.null(text)) text(XX, YY, text, adj = adj, col = col, ...)
+ if (!is.null(pch)) points(XX + adj[1] - 0.5, YY + adj[2] - 0.5,
+ pch = pch, col = col, bg = bg, ...)
+}
+
+nodelabels <-
+ function(text, node, adj = c(0.5, 0.5), frame = "rect",
+ pch = NULL, thermo = NULL, pie = NULL, piecol = NULL,
+ col = "black", bg = "lightblue", horiz = FALSE,
+ width = NULL, height = NULL, ...)
+{
+ lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv)
+ if (missing(node)) node <- (lastPP$Ntip + 1):length(lastPP$xx)
+ XX <- lastPP$xx[node]
+ YY <- lastPP$yy[node]
+ BOTHlabels(text, node, XX, YY, adj, frame, pch, thermo,
+ pie, piecol, col, bg, horiz, width, height, ...)
+}
+
+tiplabels <-
+ function(text, tip, adj = c(0.5, 0.5), frame = "rect",
+ pch = NULL, thermo = NULL, pie = NULL, piecol = NULL,
+ col = "black", bg = "yellow", horiz = FALSE,
+ width = NULL, height = NULL, ...)
+{
+ lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv)
+ if (missing(tip)) tip <- 1:lastPP$Ntip
+ XX <- lastPP$xx[tip]
+ YY <- lastPP$yy[tip]
+ BOTHlabels(text, tip, XX, YY, adj, frame, pch, thermo,
+ pie, piecol, col, bg, horiz, width, height, ...)
+}
+
+edgelabels <-
+ function(text, edge, adj = c(0.5, 0.5), frame = "rect",
+ pch = NULL, thermo = NULL, pie = NULL, piecol = NULL,
+ col = "black", bg = "lightgreen", horiz = FALSE,
+ width = NULL, height = NULL, date = NULL, ...)
+{
+ lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv)
+ if (missing(edge)) {
+ sel <- 1:dim(lastPP$edge)[1]
+ subedge <- lastPP$edge
+ } else {
+ sel <- edge
+ subedge <- lastPP$edge[sel, , drop = FALSE]
+ }
+ if (lastPP$type == "phylogram") {
+ if (lastPP$direction %in% c("rightwards", "leftwards")) {
+ XX <- (lastPP$xx[subedge[, 1]] + lastPP$xx[subedge[, 2]]) / 2
+ YY <- lastPP$yy[subedge[, 2]]
+ } else {
+ XX <- lastPP$xx[subedge[, 2]]
+ YY <- (lastPP$yy[subedge[, 1]] + lastPP$yy[subedge[, 2]]) / 2
+ }
+ } else {
+ XX <- (lastPP$xx[subedge[, 1]] + lastPP$xx[subedge[, 2]]) / 2
+ YY <- (lastPP$yy[subedge[, 1]] + lastPP$yy[subedge[, 2]]) / 2
+ }
+
+ ## suggestion by Rob Lanfear:
+ if (!is.null(date))
+ XX[] <- max(lastPP$xx) - date
+
+ BOTHlabels(text, sel, XX, YY, adj, frame, pch, thermo,
+ pie, piecol, col, bg, horiz, width, height, ...)
+}
+
+edges <- function(nodes0, nodes1, arrows = 0, type = "classical", ...)
+{
+ type <- match.arg(type, c("classical", "triangle", "harpoon"))
+ lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv)
+ ## we do the recycling if necessary:
+ if (length(nodes0) != length(nodes1)) {
+ tmp <- cbind(nodes0, nodes1)
+ nodes0 <- tmp[, 1]
+ nodes1 <- tmp[, 2]
+ }
+ x0 <- lastPP$xx[nodes0]
+ y0 <- lastPP$yy[nodes0]
+ x1 <- lastPP$xx[nodes1]
+ y1 <- lastPP$yy[nodes1]
+ if (arrows)
+ if (type == "classical")
+ arrows(x0, y0, x1, y1, code = arrows, ...)
+ else
+ fancyarrows(x0, y0, x1, y1, code = arrows, type = type, ...)
+ else
+ segments(x0, y0, x1, y1, ...)
+}
+
+fancyarrows <-
+ function(x0, y0, x1, y1, length = 0.25, angle = 30, code = 2,
+ col = par("fg"), lty = par("lty"), lwd = par("lwd"),
+ type = "triangle", ...)
+{
+ foo <- function(x0, y0, x1, y1) {
+ ## important to correct with these parameters cause
+ ## the coordinate system will likely not be Cartesian
+ pin <- par("pin")
+ usr <- par("usr")
+ A1 <- pin[1]/diff(usr[1:2])
+ A2 <- pin[2]/diff(usr[3:4])
+ x0 <- x0 * A1
+ y0 <- y0 * A2
+ x1 <- x1 * A1
+ y1 <- y1 * A2
+ atan2(y1 - y0, x1 - x0)
+ }
+ arrow.triangle <- function(x, y) {
+ beta <- alpha - angle/2
+ xa <- xinch(length * cos(beta)) + x
+ ya <- yinch(length * sin(beta)) + y
+ beta <- beta + angle
+ xb <- xinch(length * cos(beta)) + x
+ yb <- yinch(length * sin(beta)) + y
+ n <- length(x)
+ col <- rep(col, length.out = n)
+ for (i in 1:n)
+ polygon(c(x[i], xa[i], xb[i]), c(y[i], ya[i], yb[i]),
+ col = col[i], border = col[i])
+ list((xa + xb)/2, (ya + yb)/2)
+ }
+ arrow.harpoon <- function(x, y) {
+ beta <- alpha - angle/2
+ xa <- xinch(length * cos(beta)) + x
+ ya <- yinch(length * sin(beta)) + y
+ beta <- alpha + angle/2
+ xb <- xinch(length * cos(beta)) + x
+ yb <- yinch(length * sin(beta)) + y
+ xc <- x/2 + (xa + xb)/4
+ yc <- y/2 + (ya + yb)/4
+ n <- length(x)
+ col <- rep(col, length.out = n)
+ for (i in 1:n)
+ polygon(c(x[i], xa[i], xc[i], xb[i]),
+ c(y[i], ya[i], yc[i], yb[i]),
+ col = col[i], border = col[i])
+ list(xc, yc)
+ }
+
+ type <- match.arg(type, c("triangle", "harpoon"))
+ angle <- pi*angle/180 # degree -> radian
+ alpha <- foo(x0, y0, x1, y1) # angle of segment with x-axis
+ ## alpha is in [-pi, pi]
+
+ FUN <- if (type == "triangle") arrow.triangle else arrow.harpoon
+ XY0 <- if (code == 1 || code == 3) FUN(x0, y0) else list(x0, y0)
+ if (code >= 2) {
+ alpha <- (alpha + pi) %% (2 * pi)
+ XY1 <- FUN(x1, y1)
+ } else XY1 <- list(x1, y1)
+ segments(XY0[[1]], XY0[[2]], XY1[[1]], XY1[[2]], col = col, lty = lty, lwd = lwd, ...)
+}
diff --git a/R/parafit.R b/R/parafit.R
new file mode 100644
index 0000000..8c80019
--- /dev/null
+++ b/R/parafit.R
@@ -0,0 +1,160 @@
+'parafit' <-
+ function(host.D, para.D, HP, nperm=999, test.links=FALSE, seed=NULL, correction="none", silent=FALSE)
+#
+# Test of host-parasite coevolution
+# host.D = host distance or patristic matrix (class dist or matrix)
+# para.D = parasite distance or patristic matrix (class dist or matrix)
+# HP = host-parasite link matrix (n.host, n.para)
+#
+# Pierre Legendre, May 2009
+{
+epsilon <- sqrt(.Machine$double.eps)
+if(is.null(seed)) {
+ runif(1)
+ seed <- .Random.seed[trunc(runif(1,1,626))]
+ }
+
+host.D <- as.matrix(host.D)
+host.pc <- pcoa(host.D, correction=correction)
+if(host.pc$correction[2] == 1) {
+ if(min(host.pc$values[,2]) < -epsilon) stop('Host D matrix has negative eigenvalues. Rerun with correction="lingoes" or correction="cailliez"')
+ sum.host.values.sq <- sum(host.pc$values[,1]^2)
+ host.vectors <- host.pc$vectors
+ } else {
+ sum.host.values.sq <- sum(host.pc$values[,2]^2)
+ host.vectors <- host.pc$vectors.cor
+ }
+n.host <- nrow(host.D)
+
+para.D <- as.matrix(para.D)
+para.pc <- pcoa(para.D, correction=correction)
+if(para.pc$correction[2] == 1) {
+ if(min(para.pc$values[,2]) < -epsilon) stop('Parasite D matrix has negative eigenvalues. Rerun with correction="lingoes" or correction="cailliez"')
+ sum.para.values.sq <- sum(para.pc$values[,1]^2)
+ para.vectors <- para.pc$vectors
+ } else {
+ sum.para.values.sq <- sum(para.pc$values[,2]^2)
+ para.vectors <- para.pc$vectors.cor
+ }
+n.para <- nrow(para.D)
+
+if(!silent) cat("n.hosts =", n.host, ", n.parasites =", n.para,'\n')
+
+a <- system.time({
+tracemax <- max(sum.host.values.sq, sum.para.values.sq)
+
+if(n.host == n.para) {
+ if(!silent) cat("The function cannot check if matrix HP has been entered in the right way.",'\n')
+ if(!silent) cat("It will assume that the rows of HP are the hosts.",'\n')
+ } else {
+ temp <- dim(HP)
+ if(temp[1] == n.host) {
+ if(temp[2] != n.para) stop("Matrices host.D, para.D and HP not comformable")
+ } else if(temp[2] == n.host) {
+ if(temp[1] != n.para) stop("Matrices host.D, para.D and HP not comformable")
+ HP <- t(HP)
+ if(!silent) cat("Matrix HP has been transposed for comformity with host.D and para.D.",'\n')
+ } else {
+ stop("Matrices host.D, para.D and HP not comformable")
+ }
+ }
+p.per.h <- apply(HP, 1, sum)
+h.per.p <- apply(HP, 2, sum)
+#
+# Compute and test the global statistics
+mat.4 <- t(host.vectors) %*% HP %*% para.vectors
+global <- sum(mat.4^2)
+if(nperm > 0) {
+ set.seed(seed)
+ nGT <- 1
+ global.perm <- NA
+ for(i in 1:nperm) {
+ HP.perm <- apply(HP, 2, sample)
+ mat.4.perm <- t(host.vectors) %*% HP.perm %*% para.vectors
+ global.perm <- c(global.perm, sum(mat.4.perm^2))
+ if(global.perm[i+1] >= global) nGT <- nGT+1
+ }
+ global.perm <- global.perm[-1]
+ p.global <- nGT/(nperm+1)
+ } else { p.global <- NA }
+
+#
+# Test individual H-P links
+if(test.links) {
+ # 1. Create the list of H-P pairs
+ list.hp <- which( t(cbind(HP,rep(0,n.host))) > 0)
+ HP.list <- cbind((list.hp %/% (n.para+1))+1, list.hp %% (n.para+1))
+ colnames(HP.list) <- c("Host","Parasite")
+ n.links <- length(list.hp)
+
+ stat1 <- NA
+ stat2 <- NA
+ p.stat1 <- NA
+ p.stat2 <- NA
+ for(k in 1:n.links) {
+ #
+ # 2. Compute reference values of link statistics
+ HP.k <- HP
+ HP.k[HP.list[k,1], HP.list[k,2]] <- 0
+ mat.4.k <- t(host.vectors) %*% HP.k %*% para.vectors
+ trace.k <- sum(mat.4.k^2)
+ stat1 <- c(stat1, (global-trace.k))
+ den <- tracemax-global
+ if(den > epsilon) {
+ stat2 <- c(stat2, stat1[k+1]/den)
+ } else {
+ stat2 <- c(stat2, NA)
+ }
+ #
+ # 3. Test link statistics by permutations
+ if(nperm > 0) {
+ set.seed(seed)
+ nGT1 <- 1
+ nGT2 <- 1
+ nperm2 <- nperm
+ #
+ for(i in 1:nperm) {
+ HP.k.perm <- apply(HP.k, 2, sample)
+ mat.4.k.perm <- t(host.vectors) %*% HP.k.perm %*% para.vectors
+ trace.k.perm <- sum(mat.4.k.perm^2)
+ stat1.perm <- global.perm[i]-trace.k.perm
+ if(stat1.perm >= stat1[k+1]) nGT1 <- nGT1+1
+ #
+ if(!is.na(stat2[k+1])) {
+ den <- tracemax-global.perm[i]
+ if(den > epsilon) {
+ stat2.perm <- stat1.perm/den
+ if(stat2.perm >= stat2[k+1]) nGT2 <- nGT2+1
+ } else {
+ nperm2 <- nperm2-1
+ # if(!silent) cat("In permutation #",i,"den < epsilon",'\n')
+ }
+ }
+ }
+ p.stat1 <- c(p.stat1, nGT1/(nperm+1))
+ if(!is.na(stat2[k+1])) {
+ p.stat2 <- c(p.stat2, nGT2/(nperm2+1))
+ } else {
+ p.stat2 <- NA
+ }
+ } else {
+ p.stat1 <- NA
+ p.stat2 <- NA
+ }
+ }
+ #
+ link.table <- cbind(HP.list, stat1[-1], p.stat1[-1], stat2[-1], p.stat2[-1])
+ colnames(link.table) = c("Host","Parasite","F1.stat","p.F1","F2.stat","p.F2")
+ out <-list(ParaFitGlobal=global, p.global=p.global, link.table=link.table, para.per.host=p.per.h, host.per.para=h.per.p, nperm=nperm)
+ } else {
+ if(!silent) cat("Rerun the program with option 'test.links=TRUE' to test the individual H-P links",'\n')
+ out <-list(ParaFitGlobal=global, p.global=p.global, para.per.host=p.per.h, host.per.para=h.per.p, nperm=nperm)
+ }
+#
+})
+a[3] <- sprintf("%2f",a[3])
+if(!silent) cat("Computation time =",a[3]," sec",'\n')
+#
+class(out) <- "parafit"
+out
+}
diff --git a/R/pcoa.R b/R/pcoa.R
new file mode 100644
index 0000000..335fd15
--- /dev/null
+++ b/R/pcoa.R
@@ -0,0 +1,170 @@
+pcoa <- function(D, correction="none", rn=NULL)
+#
+# Principal coordinate analysis (PCoA) of a square distance matrix D
+# with correction for negative eigenvalues.
+#
+# References:
+# Gower, J. C. 1966. Some distance properties of latent root and vector methods
+# used in multivariate analysis. Biometrika. 53: 325-338.
+# Gower, J. C. and P. Legendre. 1986. Metric and Euclidean properties of
+# dissimilarity coefficients. J. Classif. 3: 5-48.
+# Legendre, P. and L. Legendre. 1998. Numerical ecology, 2nd English edition.
+# Elsevier Science BV, Amsterdam. [PCoA: Section 9.2]
+#
+# Pierre Legendre, October 2007
+{
+centre <- function(D,n)
+# Centre a square matrix D by matrix algebra
+# mat.cen = (I - 11'/n) D (I - 11'/n)
+{ One <- matrix(1,n,n)
+ mat <- diag(n) - One/n
+ mat.cen <- mat %*% D %*% mat
+}
+
+bstick.def <- function (n, tot.var = 1, ...) # 'bstick.default' from vegan
+{
+ res <- rev(cumsum(tot.var/n:1)/n)
+ names(res) <- paste("Stick", seq(len = n), sep = "")
+ return(res)
+}
+
+# ===== The PCoA function begins here =====
+
+# Preliminary actions
+ D <- as.matrix(D)
+ n <- nrow(D)
+ epsilon <- sqrt(.Machine$double.eps)
+ if(length(rn)!=0) {
+ names <- rn
+ } else {
+ names <- rownames(D)
+ }
+ CORRECTIONS <- c("none","lingoes","cailliez")
+ correct <- pmatch(correction, CORRECTIONS)
+ if(is.na(correct)) stop("Invalid correction method")
+ # cat("Correction method =",correct,'\n')
+
+# Gower centring of matrix D
+# delta1 = (I - 11'/n) [-0.5 d^2] (I - 11'/n)
+ delta1 <- centre((-0.5*D^2),n)
+ trace <- sum(diag(delta1))
+
+# Eigenvalue decomposition
+ D.eig <- eigen(delta1)
+
+# Negative eigenvalues?
+ min.eig <- min(D.eig$values)
+ zero.eig <- which(abs(D.eig$values) < epsilon)
+ D.eig$values[zero.eig] <- 0
+
+# No negative eigenvalue
+ if(min.eig > -epsilon) { # Curly 1
+ correct <- 1
+ eig <- D.eig$values
+ k <- length(which(eig > epsilon))
+ rel.eig <- eig[1:k]/trace
+ cum.eig <- cumsum(rel.eig)
+ vectors <- sweep(D.eig$vectors[,1:k], 2, sqrt(eig[1:k]), FUN="*")
+ bs <- bstick.def(k)
+ cum.bs <- cumsum(bs)
+
+ res <- data.frame(eig[1:k], rel.eig, bs, cum.eig, cum.bs)
+ colnames(res) <- c("Eigenvalues","Relative_eig","Broken_stick","Cumul_eig","Cumul_br_stick")
+ rownames(res) <- 1:nrow(res)
+
+ rownames(vectors) <- names
+ colnames(vectors) <- colnames(vectors, do.NULL = FALSE, prefix = "Axis.")
+ note <- paste("There were no negative eigenvalues. No correction was applied")
+ out <- (list(correction=c(correction,correct), note=note, values=res, vectors=vectors, trace=trace))
+
+# Negative eigenvalues present
+ } else { # Curly 1
+ k <- n
+ eig <- D.eig$values
+ rel.eig <- eig/trace
+ rel.eig.cor <- (eig - min.eig)/(trace - (n-1)*min.eig) # Eq. 9.27 for a single dimension
+ rel.eig.cor = c(rel.eig.cor[1:(zero.eig[1]-1)], rel.eig.cor[(zero.eig[1]+1):n], 0)
+ cum.eig.cor <- cumsum(rel.eig.cor)
+ k2 <- length(which(eig > epsilon))
+ k3 <- length(which(rel.eig.cor > epsilon))
+ vectors <- sweep(D.eig$vectors[,1:k2], 2, sqrt(eig[1:k2]), FUN="*")
+ # Only the eigenvectors with positive eigenvalues are shown
+
+# Negative eigenvalues: three ways of handling the situation
+ if((correct==2) | (correct==3)) { # Curly 2
+
+ if(correct == 2) { # Curly 3
+ # Lingoes correction: compute c1, then the corrected D
+ c1 <- -min.eig
+ note <- paste("Lingoes correction applied to negative eigenvalues: D' = -0.5*D^2 -",c1,", except diagonal elements")
+ D <- -0.5*(D^2 + 2*c1)
+
+ # Cailliez correction: compute c2, then the corrected D
+ } else if(correct == 3) {
+ delta2 <- centre((-0.5*D),n)
+ upper <- cbind(matrix(0,n,n), 2*delta1)
+ lower <- cbind(-diag(n), -4*delta2)
+ sp.matrix <- rbind(upper, lower)
+ c2 <- max(Re(eigen(sp.matrix, symmetric=FALSE, only.values=TRUE)$values))
+ note <- paste("Cailliez correction applied to negative eigenvalues: D' = -0.5*(D +",c2,")^2, except diagonal elements")
+ D <- -0.5*(D + c2)^2
+ } # End curly 3
+
+ diag(D) <- 0
+ mat.cor <- centre(D,n)
+ toto.cor <- eigen(mat.cor)
+ trace.cor <- sum(diag(mat.cor))
+
+ # Negative eigenvalues present?
+ min.eig.cor <- min(toto.cor$values)
+ zero.eig.cor <- which((toto.cor$values < epsilon) & (toto.cor$values > -epsilon))
+ toto.cor$values[zero.eig.cor] <- 0
+
+ # No negative eigenvalue after correction: result OK
+ if(min.eig.cor > -epsilon) { # Curly 4
+ eig.cor <- toto.cor$values
+ rel.eig.cor <- eig.cor[1:k]/trace.cor
+ cum.eig.cor <- cumsum(rel.eig.cor)
+ k2 <- length(which(eig.cor > epsilon))
+ vectors.cor <- sweep(toto.cor$vectors[,1:k2], 2, sqrt(eig.cor[1:k2]), FUN="*")
+ # bs <- broken.stick(k2)[,2]
+ bs <- bstick.def(k2)
+ bs <- c(bs, rep(0,(k-k2)))
+ cum.bs <- cumsum(bs)
+
+ # Negative eigenvalues still present after correction: incorrect result
+ } else {
+ if(correct == 2) cat("Problem! Negative eigenvalues are still present after Lingoes",'\n')
+ if(correct == 3) cat("Problem! Negative eigenvalues are still present after Cailliez",'\n')
+ rel.eig.cor <- cum.eig.cor <- bs <- cum.bs <- rep(NA,n)
+ vectors.cor <- matrix(NA,n,2)
+ } # End curly 4
+
+ res <- data.frame(eig[1:k], eig.cor[1:k], rel.eig.cor, bs, cum.eig.cor, cum.bs)
+ colnames(res) <- c("Eigenvalues", "Corr_eig", "Rel_corr_eig", "Broken_stick", "Cum_corr_eig", "Cum_br_stick")
+ rownames(res) <- 1:nrow(res)
+
+ rownames(vectors) <- names
+ colnames(vectors) <- colnames(vectors, do.NULL = FALSE, prefix = "Axis.")
+ out <- (list(correction=c(correction,correct), note=note, values=res, vectors=vectors, trace=trace, vectors.cor=vectors.cor, trace.cor=trace.cor))
+
+ } else { # Curly 2
+
+ note <- "No correction was applied to the negative eigenvalues"
+ bs <- bstick.def(k3)
+ bs <- c(bs, rep(0,(k-k3)))
+ cum.bs <- cumsum(bs)
+
+ res <- data.frame(eig[1:k], rel.eig, rel.eig.cor, bs, cum.eig.cor, cum.bs)
+ colnames(res) <- c("Eigenvalues","Relative_eig","Rel_corr_eig","Broken_stick","Cum_corr_eig","Cumul_br_stick")
+ rownames(res) <- 1:nrow(res)
+
+ rownames(vectors) <- names
+ colnames(vectors) <- colnames(vectors, do.NULL = FALSE, prefix = "Axis.")
+ out <- (list(correction=c(correction,correct), note=note, values=res, vectors=vectors, trace=trace))
+
+ } # End curly 2: three ways of handling the situation
+ } # End curly 1
+ class(out) <- "pcoa"
+ out
+} # End of PCoA
diff --git a/R/phydataplot.R b/R/phydataplot.R
new file mode 100644
index 0000000..1b91e8c
--- /dev/null
+++ b/R/phydataplot.R
@@ -0,0 +1,130 @@
+## phydataplot.R (2014-01-20)
+
+## Annotate Phylogenies
+
+## Copyright 2014 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+polar2rect <- function(r, angle)
+ list(x = r * cos(angle), y = r * sin(angle))
+
+rect2polar <- function(x, y)
+ list(r = sqrt(x^2 + y^2), angle = atan2(y, x))
+
+.matchDataPhylo <- function(x, phy)
+{
+ msg <- "'x' has no (row)names: data are assumed to be in the same order than the tips of the tree"
+ labs <- phy$tip.label
+ if (is.vector(x)) { # also for lists
+ if (is.null(names(x))) warning(msg) else x <- x[labs]
+ } else {
+ if (is.null(rownames(x))) warning(msg) else x <- x[labs, ]
+ }
+ x
+}
+
+ring <- function(x, phy, style = "ring", offset = 1, ...)
+{
+ style <- match.arg(style, c("ring", "segments", "arrows"))
+ x <- .matchDataPhylo(x, phy)
+ lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv)
+ n <- lastPP$Ntip
+ one2n <- seq_len(n)
+ tmp <- rect2polar(lastPP$xx[one2n], lastPP$yy[one2n])
+ theta <- tmp$angle
+ r0 <- max(tmp$r) + offset
+ r1 <- r0 + x
+ s0 <- polar2rect(rep.int(r0, 100L), seq(0, 2*pi, length.out = 100L))
+ s1 <- polar2rect(r1, theta)
+
+ switch(style, ring = {
+ if (length(x) < n) x <- rep_len(x, n)
+ dx <- dim(x)
+ if (is.null(dx)) dim(x) <- dx <- c(n, 1L)
+ nc <- dx[2]
+ col <- list(...)$col
+ if (is.null(col)) col <- "grey"
+ if (nc == 1) {
+ col <- rep_len(col, n)
+ } else {
+ colvar <- col
+ col <- rep(col[1], n)
+ }
+ iangle <- min(diff(sort(theta)))
+ iangle2 <- iangle / 2
+ for (i in one2n) {
+ R <- rep(r0, 100)
+ THETA <- seq(theta[i] - iangle2, theta[i] + iangle2, length.out = 100)
+ xy1 <- polar2rect(R, THETA)
+ xy2 <- polar2rect(R + x[i, 1], THETA)
+ polygon(c(xy1$x, rev(xy2$x)), c(xy1$y, rev(xy2$y)), col = col[i], border = NA)
+ if (nc > 1) {
+ for (j in 2:nc) {
+ xy1 <- xy2
+ xy2 <- polar2rect(R + sum(x[i, 1:j]), THETA)
+ polygon(c(xy1$x, rev(xy2$x)), c(xy1$y, rev(xy2$y)), col = colvar[j], border = NA)
+ }
+ }
+ }
+ ##polypath(c(s0$x, NA, s0$x), c(s0$y, NA, s1$y), rule = "evenodd",
+ ## border = 1, col = "transparent")
+ }, segments = {
+ s0 <- polar2rect(rep.int(r0, n), theta)
+ segments(s0$x, s0$y, s1$x, s1$y, ...)
+ }, arrows = {
+ s0 <- polar2rect(rep.int(r0, n), theta)
+ fancyarrows(s0$x, s0$y, s1$x, s1$y, ...)
+ })
+}
+
+phydataplot <- function(x, phy, style = "bars", offset = 1, ...)
+{
+ style <- match.arg(style, c("bars", "segments", "image", "arrows"))
+ lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv)
+ circular <- if (lastPP$type %in% c("radial", "fan")) TRUE else FALSE
+
+ n <- length(phy$tip.label)
+ one2n <- seq_len(n)
+ x <- .matchDataPhylo(x, phy)
+
+ if (!circular) {
+ if (lastPP$direction != "rightwards")
+ stop("for the moment, only rightwards trees are supported")
+ x0 <- max(lastPP$xx[one2n]) + offset
+ if (style != "image") x1 <- x0 + x
+ y1 <- lastPP$yy[one2n]
+ if (style %in% c("bars", "image")) {
+ o <- order(y1)
+ x <- if (style == "image") x[o, o] else
+ if (is.vector(x)) x[o] else x[o, ]
+ }
+ }
+
+ switch(style, bars = {
+ if (circular)
+ stop("style = \"bars\" not implemented with circular trees; see the function 'ring'")
+ if (!is.null(dim(x))) x <- t(x)
+ barplot(x, width = 1, add = TRUE, horiz = TRUE, offset = x0,
+ axes = FALSE, axisnames = FALSE, space = c(0.5, rep(0, n - 1)), ...)
+ px <- pretty(c(0, x))
+ axis(1, px + x0, labels = px, line = 1)
+ }, segments = {
+ if (circular) ring(x, phy, style, offset, ...)
+ else segments(x0, y1, x1, y1, ...)
+ }, image = {
+ if (circular)
+ stop("style = \"image\" not implemented with circular trees")
+ if (inherits(x, "DNAbin"))
+ stop("object of class \"DNAbin\" not yet supported")
+ ##image(x, show.labels = FALSE, add = TRUE, ...)
+ x1 <- seq(x0, lastPP$x.lim[2], length.out = n)
+ image(x1, y1[o], x, add = TRUE, ...)
+ mtext(phy$tip.label[o], 1, 1, at = x1, font = lastPP$font,
+ cex = lastPP$cex, col = lastPP$tip.color)
+ }, arrows = {
+ if (circular) ring(x, phy, style, offset, ...)
+ else fancyarrows(x0, y1, x1, y1, ...)
+ })
+}
diff --git a/R/phymltest.R b/R/phymltest.R
new file mode 100644
index 0000000..a87d46d
--- /dev/null
+++ b/R/phymltest.R
@@ -0,0 +1,122 @@
+## phymltest.R (2009-03-29)
+
+## Fits a Bunch of Models with PhyML
+
+## Copyright 2004-2009 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+.phymltest.model <-
+ c("JC69", "JC69+I", "JC69+G", "JC69+I+G",
+ "K80", "K80+I", "K80+G", "K80+I+G",
+ "F81", "F81+I", "F81+G", "F81+I+G",
+ "F84", "F84+I", "F84+G", "F84+I+G",
+ "HKY85", "HKY85+I", "HKY85+G", "HKY85+I+G",
+ "TN93", "TN93+I", "TN93+G", "TN93+I+G",
+ "GTR", "GTR+I", "GTR+G", "GTR+I+G")
+
+.phymltest.nfp <-
+ c(1, 2, 2, 3, 2, 3, 3, 4, 4, 5, 5, 6, 5, 6, 6, 7,
+ 5, 6, 6, 7, 6, 7, 7, 8, 9, 10, 10, 11)
+
+phymltest <- function(seqfile, format = "interleaved", itree = NULL,
+ exclude = NULL, execname = NULL, append = TRUE)
+{
+ os <- Sys.info()[1]
+ ## default names of PhyML:
+ if (is.null(execname)) {
+ if (os == "Linux") execname <- "phyml_3.0.1_linux32"
+ if (os == "Darwin") execname <- "phyml_3.0.1_macintel"
+ if (os == "Windows") execname <- "phyml_3.0.1_win32"
+ }
+ if (is.null(execname))
+ stop("you must give an executable file name for PHYML")
+ N <- length(.phymltest.model)
+ format <- match.arg(format, c("interleaved", "sequential"))
+ fmt <- rep("", N)
+ if (format != "interleaved") fmt[] <- "-q"
+ boot <- rep("-b 0", N) # to avoid any testing
+ mdl <- paste("-m", rep(c("JC69", "K80", "F81", "HKY85", "F84", "TN93", "GTR"), each = 4))
+ tstv <- rep("-t e", N) # ignored by PhyML with JC69 or F81
+ inv <- rep(c("", "-v e"), length.out = N)
+ ## no need to use the -c option of PhyML (4 categories by default if '-a e' is set):
+ alpha <- rep(rep(c("-c 1", "-a e"), each = 2), length.out = N)
+ tree <- rep("", N)
+ if (!is.null(itree)) tree[] <- paste("-u ", itree)
+
+ cmd <- paste(execname, "-i", seqfile, fmt, boot, mdl, tstv, inv, alpha, tree, "--append ")
+ outfile <- paste(seqfile, "_phyml_stats.txt", sep = "")
+ if (!append) {
+ unlink(outfile)
+ unlink(paste(seqfile, "_phyml_tree.txt", sep = ""))
+ }
+ imod <- 1:N
+ if (!is.null(exclude)) imod <- imod[!.phymltest.model %in% exclude]
+
+ for (i in imod) system(cmd[i])
+
+ l <- readLines(outfile)
+ l <- grep("Log-likelihood:", l, value = TRUE)
+ ## in case there were already some results in the output file:
+ if (dd <- length(l) - length(imod)) l <- l[-(1:dd)]
+ loglik <- as.numeric(sub(". Log-likelihood:", "", l))
+ names(loglik) <- .phymltest.model[imod]
+ class(loglik) <- "phymltest"
+ loglik
+}
+
+print.phymltest <- function(x, ...)
+{
+ nfp <- .phymltest.nfp[.phymltest.model %in% names(x)]
+ X <- cbind(nfp, x, 2 * (nfp - x))
+ rownames(X) <- names(x)
+ colnames(X) <- c("nb.free.para", "loglik", "AIC")
+ print(X)
+}
+
+summary.phymltest <- function(object, ...)
+{
+ nfp <- .phymltest.nfp[.phymltest.model %in% names(object)]
+ N <- length(object)
+ model1 <- model2 <- character(0)
+ chi2 <- df <- P.val <- numeric(0)
+ for (i in 1:(N - 1)) {
+ for (j in (i + 1):N) {
+ if (nfp[i] >= nfp[j]) next
+ m1 <- unlist(strsplit(names(object)[i], "\\+"))
+ m2 <- unlist(strsplit(names(object)[j], "\\+"))
+ if (m1[1] == "K80" && m2[1] == "F81") next
+ ## � v�rifier que ds les 2 lignes suivantes les conversions
+ ## se font bien correctement!!!!
+ if (length(grep("\\+I", names(object)[i])) > 0 && length(grep("\\+I", names(object)[j])) == 0) next
+ if (length(grep("\\+G", names(object)[i])) > 0 && length(grep("\\+G", names(object)[j])) == 0) next
+ ## Now we should be sure that m1 is nested in m2.
+ chi2 <- c(chi2, 2 * (object[j] - object[i]))
+ df <- c(df, nfp[j] - nfp[i])
+ P.val <- c(P.val, 1 - pchisq(2 * (object[j] - object[i]), nfp[j] - nfp[i]))
+ model1 <- c(model1, names(object)[i])
+ model2 <- c(model2, names(object)[j])
+ }
+ }
+ data.frame(model1, model2, chi2, df, P.val = round(P.val, 4))
+}
+
+plot.phymltest <- function(x, main = NULL, col = "blue", ...)
+{
+ nfp <- .phymltest.nfp[.phymltest.model %in% names(x)]
+ N <- length(x)
+ aic <- 2 * (nfp - x)
+ if (is.null(main))
+ main <- paste("Akaike information criterion for",
+ deparse(substitute(x)))
+ plot(rep(1, N), aic, bty = "n", xaxt = "n", yaxt = "n",
+ type = "n", xlab = "", ylab = "", main = main, ...)
+ axis(side = 2, pos = 0.85, las = 2)
+ abline(v = 0.85)
+ y.lab <- seq(min(aic), max(aic), length = N)
+ segments(0.85, sort(aic), 1.1, y.lab, col = col)
+ text(1.1, y.lab,
+ parse(text = sub("\\+G", "\\+Gamma", names(sort(aic)))),
+ adj = 0)
+}
diff --git a/R/pic.R b/R/pic.R
new file mode 100644
index 0000000..e66042b
--- /dev/null
+++ b/R/pic.R
@@ -0,0 +1,170 @@
+## pic.R (2013-02-18)
+
+## Phylogenetically Independent Contrasts
+
+## Copyright 2002-2013 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+pic <- function(x, phy, scaled = TRUE, var.contrasts = FALSE, rescaled.tree = FALSE)
+{
+ if (!inherits(phy, "phylo")) stop("object 'phy' is not of class \"phylo\"")
+ if (is.null(phy$edge.length)) stop("your tree has no branch lengths")
+ nb.tip <- length(phy$tip.label)
+ nb.node <- phy$Nnode
+ if (nb.node != nb.tip - 1)
+ stop("'phy' is not rooted and fully dichotomous")
+ if (length(x) != nb.tip)
+ stop("length of phenotypic and of phylogenetic data do not match")
+ if (any(is.na(x)))
+ stop("missing data in 'x': you may consider removing the species with missing data from your tree with the function 'drop.tip'.")
+
+ phy <- reorder(phy, "postorder")
+ phenotype <- numeric(nb.tip + nb.node)
+
+ if (is.null(names(x))) {
+ phenotype[1:nb.tip] <- x
+ } else {
+ if (all(names(x) %in% phy$tip.label))
+ phenotype[1:nb.tip] <- x[phy$tip.label]
+ else {
+ phenotype[1:nb.tip] <- x
+ warning("the names of argument 'x' and the tip labels of the tree did not match: the former were ignored in the analysis.")
+ }
+ }
+
+ ## No need to copy the branch lengths: they are rescaled
+ ## in the C code, so it's important to leave the default
+ ## `DUP = TRUE' of .C.
+ ans <- .C(C_pic, as.integer(nb.tip), as.integer(nb.node),
+ as.integer(phy$edge[, 1]), as.integer(phy$edge[, 2]),
+ as.double(phy$edge.length), as.double(phenotype),
+ double(nb.node), double(nb.node),
+ as.integer(var.contrasts), as.integer(scaled))
+
+ contr <- ans[[7]]
+ lbls <-
+ if (is.null(phy$node.label)) as.character(1:nb.node + nb.tip)
+ else phy$node.label
+ if (var.contrasts) {
+ contr <- cbind(contr, ans[[8]])
+ dimnames(contr) <- list(lbls, c("contrasts", "variance"))
+ } else names(contr) <- lbls
+ if (rescaled.tree) {
+ phy$edge.length <- ans[[5]]
+ contr <- list(contr = contr, rescaled.tree = phy)
+ }
+ contr
+}
+
+pic.ortho <- function(x, phy, var.contrasts = FALSE, intra = FALSE)
+{
+ n <- length(x)
+ m <- n - 1L # number of nodes
+ phy <- reorder(phy, "postorder")
+ xx <- unlist(lapply(x, mean)) # 'x' in Felsenstein's paper
+ xx <- c(xx, numeric(m))
+ delta.v <- numeric(n + m)
+ s <- 1/unlist(lapply(x, length))
+ s <- c(s, numeric(m))
+ contrast <- var.cont <- numeric(m)
+
+ i <- 1L
+ while (i < m + n) {
+ d1 <- phy$edge[i, 2]
+ d2 <- phy$edge[i + 1L, 2]
+ a <- phy$edge[i, 1]
+ tmp1 <- 1/(phy$edge.length[i] + delta.v[d1])
+ tmp2 <- 1/(phy$edge.length[i + 1L] + delta.v[d2])
+ xx[a] <- (tmp1 * xx[d1] + tmp2 * xx[d2])/(tmp1 + tmp2)
+ delta.v[a] <- 1/(tmp1 + tmp2)
+ f1 <- tmp1/(tmp1 + tmp2)
+ f2 <- tmp2/(tmp1 + tmp2)
+ s[a] <- f1*f1 * s[d1] + f2*f2 * s[d2]
+ tmp <- 1/(s[d1] + s[d2])
+ contrast[a - n] <- (xx[d1] - xx[d2]) * sqrt(tmp)
+ var.cont[a - n] <- (1/tmp1 + 1/tmp2) * tmp
+ i <- i + 2L
+ }
+
+ lbls <-
+ if (is.null(phy$node.label)) as.character(1:m + n)
+ else phy$node.label
+
+ if (var.contrasts) {
+ contrast <- cbind(contrast, var.cont)
+ dimnames(contrast) <- list(lbls, c("contrasts", "variance"))
+ } else names(contrast) <- lbls
+
+ if (intra) {
+ intraspe.ctr <- function(x) {
+ k <- length(x) - 1L
+ if (!k) return(NULL)
+ ctr <- numeric(k)
+ ctr[1L] <- x[1L] - x[2L]
+ if (k > 1)
+ for (i in 2:k)
+ ctr[i] <- x[i + 1L] - mean(x[1:i])
+ sqrt((1:k)/(1:k + 1)) * ctr
+ }
+ tmp <- lapply(x, intraspe.ctr)
+ names(tmp) <- phy$tip.label
+ attr(contrast, "intra") <- tmp
+ }
+
+ contrast
+}
+
+varCompPhylip <- function(x, phy, exec = NULL)
+{
+ n <- Ntip(phy)
+ if (is.vector(x)) x <- as.list(x)
+ if (is.matrix(x) || is.data.frame(x)) {
+ tmpx <- vector("list", n)
+ for (i in 1:n) tmpx[[i]] <- x[i, , drop = FALSE]
+ names(tmpx) <- rownames(x)
+ x <- tmpx
+ }
+ p <- if (is.vector(x[[1]])) 1L else ncol(x[[1]])
+ if (!is.null(names(x))) x <- x[phy$tip.label]
+
+ phy <- makeLabel(phy, len = 10)
+ lbs <- phy$tip.label
+
+ ni <- sapply(x, function(xx) if (is.vector(xx)) 1L else nrow(xx))
+
+ pfx <- tempdir()
+ write.tree(phy, file = paste(pfx, "intree", sep = "/"))
+ infile <- paste(pfx, "infile", sep = "/")
+ file.create(infile)
+ cat(n, " ", p, "\n", sep = "", file = infile, append = TRUE)
+ for (i in 1:n) {
+ cat(lbs[i], file = infile, append = TRUE)
+ ## can surely be better but OK for the moment:
+ cat(paste(rep(" ", 11 - nchar(lbs[i])), collapse = ""),
+ file = infile, append = TRUE)
+ cat(ni[i], "\n", sep = "", file = infile, append = TRUE)
+ if (ni[i] == 1) {
+ cat(x[[i]], sep = " ", file = infile, append = TRUE)
+ cat("\n", file = infile, append = TRUE)
+ } else write(t(x[[i]]), file = infile, ncolumns = p, append = TRUE)
+ }
+
+ if (is.null(exec))
+ exec <-
+ if (.Platform$OS.type == "unix") "phylip contrast"
+ else "contrast"
+
+ odir <- setwd(pfx)
+ on.exit(setwd(odir))
+ if (file.exists("outfile")) unlink("outfile")
+ system(exec, intern = TRUE, input = c("W", "A", "Y"))
+ varA <- scan("outfile", skip = 7, nlines = p, quiet = TRUE)
+ varE <- scan("outfile", skip = 11 + p, nlines = p, quiet = TRUE)
+ if (p > 1) {
+ varA <- matrix(varA, p, p, byrow = TRUE)
+ varE <- matrix(varE, p, p, byrow = TRUE)
+ }
+ list(varA = varA, varE = varE)
+}
diff --git a/R/plot.phylo.R b/R/plot.phylo.R
new file mode 100644
index 0000000..8950bed
--- /dev/null
+++ b/R/plot.phylo.R
@@ -0,0 +1,728 @@
+## plot.phylo.R (2014-03-03)
+
+## Plot Phylogenies
+
+## Copyright 2002-2014 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+plot.phylo <-
+ function(x, type = "phylogram", use.edge.length = TRUE,
+ node.pos = NULL, show.tip.label = TRUE,
+ show.node.label = FALSE, edge.color = "black",
+ edge.width = 1, edge.lty = 1, font = 3, cex = par("cex"),
+ adj = NULL, srt = 0, no.margin = FALSE, root.edge = FALSE,
+ label.offset = 0, underscore = FALSE, x.lim = NULL,
+ y.lim = NULL, direction = "rightwards", lab4ut = "horizontal",
+ tip.color = "black", plot = TRUE, rotate.tree = 0,
+ open.angle = 0, node.depth = 1, ...)
+{
+ Ntip <- length(x$tip.label)
+ if (Ntip < 2) {
+ warning("found less than 2 tips in the tree")
+ return(NULL)
+ }
+ if (any(tabulate(x$edge[, 1]) == 1))
+ stop("there are single (non-splitting) nodes in your tree; you may need to use collapse.singles()")
+
+ .nodeHeight <- function(Ntip, Nnode, edge, Nedge, yy)
+ .C(node_height, as.integer(Ntip), as.integer(Nnode),
+ as.integer(edge[, 1]), as.integer(edge[, 2]),
+ as.integer(Nedge), as.double(yy))[[6]]
+
+ .nodeDepth <- function(Ntip, Nnode, edge, Nedge, node.depth)
+ .C(node_depth, as.integer(Ntip), as.integer(Nnode),
+ as.integer(edge[, 1]), as.integer(edge[, 2]),
+ as.integer(Nedge), double(Ntip + Nnode), as.integer(node.depth))[[6]]
+
+ .nodeDepthEdgelength <- function(Ntip, Nnode, edge, Nedge, edge.length)
+ .C(node_depth_edgelength, as.integer(Ntip),
+ as.integer(Nnode), as.integer(edge[, 1]),
+ as.integer(edge[, 2]), as.integer(Nedge),
+ as.double(edge.length), double(Ntip + Nnode))[[7]]
+
+ Nedge <- dim(x$edge)[1]
+ Nnode <- x$Nnode
+ if (any(x$edge < 1) || any(x$edge > Ntip + Nnode))
+ stop("tree badly conformed; cannot plot. Check the edge matrix.")
+ ROOT <- Ntip + 1
+ type <- match.arg(type, c("phylogram", "cladogram", "fan",
+ "unrooted", "radial"))
+ direction <- match.arg(direction, c("rightwards", "leftwards",
+ "upwards", "downwards"))
+ if (is.null(x$edge.length)) use.edge.length <- FALSE
+
+ ## the order of the last two conditions is important:
+ if (type %in% c("unrooted", "radial") || !use.edge.length ||
+ is.null(x$root.edge) || !x$root.edge) root.edge <- FALSE
+ if (type == "fan" && root.edge) {
+ warning("drawing root edge with type = 'fan' is not yet supported")
+ root.edge <- FALSE
+ }
+
+ phyloORclado <- type %in% c("phylogram", "cladogram")
+ horizontal <- direction %in% c("rightwards", "leftwards")
+ xe <- x$edge # to save
+ if (phyloORclado) {
+ ## we first compute the y-coordinates of the tips.
+ phyOrder <- attr(x, "order")
+ ## make sure the tree is in cladewise order:
+ if (is.null(phyOrder) || phyOrder != "cladewise") {
+ x <- reorder(x) # fix from Klaus Schliep (2007-06-16)
+ if (!identical(x$edge, xe)) {
+ ## modified from Li-San Wang's fix (2007-01-23):
+ ereorder <- match(x$edge[, 2], xe[, 2])
+ if (length(edge.color) > 1) {
+ edge.color <- rep(edge.color, length.out = Nedge)
+ edge.color <- edge.color[ereorder]
+ }
+ if (length(edge.width) > 1) {
+ edge.width <- rep(edge.width, length.out = Nedge)
+ edge.width <- edge.width[ereorder]
+ }
+ if (length(edge.lty) > 1) {
+ edge.lty <- rep(edge.lty, length.out = Nedge)
+ edge.lty <- edge.lty[ereorder]
+ }
+ }
+ }
+### By contrats to ape (< 2.4), the arguments edge.color, etc., are
+### not elongated before being passed to segments(), except if needed
+### to be reordered
+ yy <- numeric(Ntip + Nnode)
+ TIPS <- x$edge[x$edge[, 2] <= Ntip, 2]
+ yy[TIPS] <- 1:Ntip
+ }
+ ## 'z' is the tree in postorder order used in calls to .C
+ z <- reorder(x, order = "postorder")
+
+ if (phyloORclado) {
+ if (is.null(node.pos)) {
+ node.pos <- 1
+ if (type == "cladogram" && !use.edge.length) node.pos <- 2
+ }
+ if (node.pos == 1)
+ yy <- .nodeHeight(Ntip, Nnode, z$edge, Nedge, yy)
+ else {
+ ## node_height_clado requires the number of descendants
+ ## for each node, so we compute `xx' at the same time
+ ans <- .C(node_height_clado, as.integer(Ntip),
+ as.integer(Nnode), as.integer(z$edge[, 1]),
+ as.integer(z$edge[, 2]), as.integer(Nedge),
+ double(Ntip + Nnode), as.double(yy))
+ xx <- ans[[6]] - 1
+ yy <- ans[[7]]
+ }
+ if (!use.edge.length) {
+ if (node.pos != 2) xx <- .nodeDepth(Ntip, Nnode, z$edge, Nedge, node.depth) - 1
+ xx <- max(xx) - xx
+ } else {
+ xx <- .nodeDepthEdgelength(Ntip, Nnode, z$edge, Nedge, z$edge.length)
+ }
+ } else {
+ twopi <- 2 * pi
+ rotate.tree <- twopi * rotate.tree/360
+ switch(type, "fan" = {
+ ## if the tips are not in the same order in tip.label
+ ## and in edge[, 2], we must reorder the angles: we
+ ## use `xx' to store temporarily the angles
+ TIPS <- x$edge[which(x$edge[, 2] <= Ntip), 2]
+ xx <- seq(0, twopi * (1 - 1/Ntip) - twopi * open.angle/360,
+ length.out = Ntip)
+ theta <- double(Ntip)
+ theta[TIPS] <- xx
+ theta <- c(theta, numeric(Nnode))
+ theta <- .nodeHeight(Ntip, Nnode, z$edge, Nedge, theta)
+ if (use.edge.length) {
+ r <- .nodeDepthEdgelength(Ntip, Nnode, z$edge, Nedge, z$edge.length)
+ } else {
+ r <- .nodeDepth(Ntip, Nnode, z$edge, Nedge, node.depth)
+ r <- 1/r
+ }
+ theta <- theta + rotate.tree
+ xx <- r * cos(theta)
+ yy <- r * sin(theta)
+ }, "unrooted" = {
+ nb.sp <- .nodeDepth(Ntip, Nnode, z$edge, Nedge, node.depth)
+ XY <- if (use.edge.length)
+ unrooted.xy(Ntip, Nnode, z$edge, z$edge.length, nb.sp, rotate.tree)
+ else
+ unrooted.xy(Ntip, Nnode, z$edge, rep(1, Nedge), nb.sp, rotate.tree)
+ ## rescale so that we have only positive values
+ xx <- XY$M[, 1] - min(XY$M[, 1])
+ yy <- XY$M[, 2] - min(XY$M[, 2])
+ }, "radial" = {
+ X <- .nodeDepth(Ntip, Nnode, z$edge, Nedge, node.depth)
+ X[X == 1] <- 0
+ ## radius:
+ X <- 1 - X/Ntip
+ ## angle (1st compute the angles for the tips):
+ yy <- c((1:Ntip)*twopi/Ntip, rep(0, Nnode))
+ Y <- .nodeHeight(Ntip, Nnode, z$edge, Nedge, yy)
+ xx <- X * cos(Y + rotate.tree)
+ yy <- X * sin(Y + rotate.tree)
+ })}
+ if (phyloORclado) {
+ if (!horizontal) {
+ tmp <- yy
+ yy <- xx
+ xx <- tmp - min(tmp) + 1
+ }
+ if (root.edge) {
+ if (direction == "rightwards") xx <- xx + x$root.edge
+ if (direction == "upwards") yy <- yy + x$root.edge
+ }
+ }
+ if (no.margin) par(mai = rep(0, 4))
+ if (is.null(x.lim)) {
+ if (phyloORclado) {
+ if (horizontal) {
+ x.lim <- c(0, NA)
+ pin1 <- par("pin")[1] # width of the device in inches
+ strWi <- strwidth(x$tip.label, "inches") # id. for the tip labels
+ ## 1.04 comes from that we are using a regular axis system
+ ## with 4% on both sides of the range of x:
+ xx.tips <- xx[1:Ntip] * 1.04
+ ## 'alp' is the conversion coefficient from
+ ## user coordinates to inches:
+ alp <- try(uniroot(function(a) max(a*xx.tips + strWi) - pin1,
+ c(0, 1e6))$root, silent = TRUE)
+ ## if the above fails, give 1/3 of the device for the tip labels:
+ if (is.character(alp)) tmp <- max(xx.tips)*1.5 else {
+ tmp <- if (show.tip.label) max(xx.tips + strWi/alp) else max(xx.tips)
+ }
+ x.lim[2] <- tmp
+ } else x.lim <- c(1, Ntip)
+ } else switch(type, "fan" = {
+ if (show.tip.label) {
+ offset <- max(nchar(x$tip.label) * 0.018 * max(yy) * cex)
+ x.lim <- c(min(xx) - offset, max(xx) + offset)
+ } else x.lim <- c(min(xx), max(xx))
+ }, "unrooted" = {
+ if (show.tip.label) {
+ offset <- max(nchar(x$tip.label) * 0.018 * max(yy) * cex)
+ x.lim <- c(0 - offset, max(xx) + offset)
+ } else x.lim <- c(0, max(xx))
+ }, "radial" = {
+ if (show.tip.label) {
+ offset <- max(nchar(x$tip.label) * 0.03 * cex)
+ x.lim <- c(-1 - offset, 1 + offset)
+ } else x.lim <- c(-1, 1)
+ })
+ } else if (length(x.lim) == 1) {
+ x.lim <- c(0, x.lim)
+ if (phyloORclado && !horizontal) x.lim[1] <- 1
+ if (type %in% c("fan", "unrooted") && show.tip.label)
+ x.lim[1] <- -max(nchar(x$tip.label) * 0.018 * max(yy) * cex)
+ if (type == "radial")
+ x.lim[1] <-
+ if (show.tip.label) -1 - max(nchar(x$tip.label) * 0.03 * cex)
+ else -1
+ }
+ ## mirror the xx:
+ if (phyloORclado && direction == "leftwards") xx <- x.lim[2] - xx
+ if (is.null(y.lim)) {
+ if (phyloORclado) {
+ if (horizontal) y.lim <- c(1, Ntip) else {
+ y.lim <- c(0, NA)
+ pin2 <- par("pin")[2] # height of the device in inches
+ strWi <- strwidth(x$tip.label, "inches")
+ ## 1.04 comes from that we are using a regular axis system
+ ## with 4% on both sides of the range of x:
+ yy.tips <- yy[1:Ntip] * 1.04
+ ## 'alp' is the conversion coefficient from
+ ## user coordinates to inches:
+ alp <- try(uniroot(function(a) max(a*yy.tips + strWi) - pin2,
+ c(0, 1e6))$root, silent = TRUE)
+ ## if the above fails, give 1/3 of the device for the tip labels:
+ if (is.character(alp)) tmp <- max(yy.tips)*1.5 else {
+ tmp <- if (show.tip.label) max(yy.tips + strWi/alp) else max(yy.tips)
+ }
+ y.lim[2] <- tmp
+ }
+ } else switch(type, "fan" = {
+ if (show.tip.label) {
+ offset <- max(nchar(x$tip.label) * 0.018 * max(yy) * cex)
+ y.lim <- c(min(yy) - offset, max(yy) + offset)
+ } else y.lim <- c(min(yy), max(yy))
+ }, "unrooted" = {
+ if (show.tip.label) {
+ offset <- max(nchar(x$tip.label) * 0.018 * max(yy) * cex)
+ y.lim <- c(0 - offset, max(yy) + offset)
+ } else y.lim <- c(0, max(yy))
+ }, "radial" = {
+ if (show.tip.label) {
+ offset <- max(nchar(x$tip.label) * 0.03 * cex)
+ y.lim <- c(-1 - offset, 1 + offset)
+ } else y.lim <- c(-1, 1)
+ })
+ } else if (length(y.lim) == 1) {
+ y.lim <- c(0, y.lim)
+ if (phyloORclado && horizontal) y.lim[1] <- 1
+ if (type %in% c("fan", "unrooted") && show.tip.label)
+ y.lim[1] <- -max(nchar(x$tip.label) * 0.018 * max(yy) * cex)
+ if (type == "radial")
+ y.lim[1] <- if (show.tip.label) -1 - max(nchar(x$tip.label) * 0.018 * max(yy) * cex) else -1
+ }
+ ## mirror the yy:
+ if (phyloORclado && direction == "downwards") yy <- y.lim[2] - yy # fix by Klaus
+ if (phyloORclado && root.edge) {
+ if (direction == "leftwards") x.lim[2] <- x.lim[2] + x$root.edge
+ if (direction == "downwards") y.lim[2] <- y.lim[2] + x$root.edge
+ }
+ asp <- if (type %in% c("fan", "radial", "unrooted")) 1 else NA # fixes by Klaus Schliep (2008-03-28 and 2010-08-12)
+ plot.default(0, type = "n", xlim = x.lim, ylim = y.lim, xlab = "",
+ ylab = "", axes = FALSE, asp = asp, ...)
+
+if (plot) {
+ if (is.null(adj))
+ adj <- if (phyloORclado && direction == "leftwards") 1 else 0
+ if (phyloORclado && show.tip.label) {
+ MAXSTRING <- max(strwidth(x$tip.label, cex = cex))
+ loy <- 0
+ if (direction == "rightwards") {
+ lox <- label.offset + MAXSTRING * 1.05 * adj
+ }
+ if (direction == "leftwards") {
+ lox <- -label.offset - MAXSTRING * 1.05 * (1 - adj)
+ ##xx <- xx + MAXSTRING
+ }
+ if (!horizontal) {
+ psr <- par("usr")
+ MAXSTRING <- MAXSTRING * 1.09 * (psr[4] - psr[3])/(psr[2] - psr[1])
+ loy <- label.offset + MAXSTRING * 1.05 * adj
+ lox <- 0
+ srt <- 90 + srt
+ if (direction == "downwards") {
+ loy <- -loy
+ ##yy <- yy + MAXSTRING
+ srt <- 180 + srt
+ }
+ }
+ }
+ if (type == "phylogram") {
+ phylogram.plot(x$edge, Ntip, Nnode, xx, yy,
+ horizontal, edge.color, edge.width, edge.lty)
+ } else {
+ if (type == "fan") {
+ ereorder <- match(z$edge[, 2], x$edge[, 2])
+ if (length(edge.color) > 1) {
+ edge.color <- rep(edge.color, length.out = Nedge)
+ edge.color <- edge.color[ereorder]
+ }
+ if (length(edge.width) > 1) {
+ edge.width <- rep(edge.width, length.out = Nedge)
+ edge.width <- edge.width[ereorder]
+ }
+ if (length(edge.lty) > 1) {
+ edge.lty <- rep(edge.lty, length.out = Nedge)
+ edge.lty <- edge.lty[ereorder]
+ }
+ circular.plot(z$edge, Ntip, Nnode, xx, yy, theta,
+ r, edge.color, edge.width, edge.lty)
+ } else
+ cladogram.plot(x$edge, xx, yy, edge.color, edge.width, edge.lty)
+ }
+ if (root.edge)
+ switch(direction,
+ "rightwards" = segments(0, yy[ROOT], x$root.edge, yy[ROOT]),
+ "leftwards" = segments(xx[ROOT], yy[ROOT], xx[ROOT] + x$root.edge, yy[ROOT]),
+ "upwards" = segments(xx[ROOT], 0, xx[ROOT], x$root.edge),
+ "downwards" = segments(xx[ROOT], yy[ROOT], xx[ROOT], yy[ROOT] + x$root.edge))
+ if (show.tip.label) {
+ if (is.expression(x$tip.label)) underscore <- TRUE
+ if (!underscore) x$tip.label <- gsub("_", " ", x$tip.label)
+
+ if (phyloORclado)
+ text(xx[1:Ntip] + lox, yy[1:Ntip] + loy, x$tip.label, adj = adj,
+ font = font, srt = srt, cex = cex, col = tip.color)
+
+ if (type == "unrooted") {
+ if (lab4ut == "horizontal") {
+ y.adj <- x.adj <- numeric(Ntip)
+ sel <- abs(XY$axe) > 0.75 * pi
+ x.adj[sel] <- -strwidth(x$tip.label)[sel] * 1.05
+ sel <- abs(XY$axe) > pi/4 & abs(XY$axe) < 0.75 * pi
+ x.adj[sel] <- -strwidth(x$tip.label)[sel] * (2 * abs(XY$axe)[sel] / pi - 0.5)
+ sel <- XY$axe > pi / 4 & XY$axe < 0.75 * pi
+ y.adj[sel] <- strheight(x$tip.label)[sel] / 2
+ sel <- XY$axe < -pi / 4 & XY$axe > -0.75 * pi
+ y.adj[sel] <- -strheight(x$tip.label)[sel] * 0.75
+ text(xx[1:Ntip] + x.adj * cex, yy[1:Ntip] + y.adj * cex,
+ x$tip.label, adj = c(adj, 0), font = font,
+ srt = srt, cex = cex, col = tip.color)
+ } else { # if lab4ut == "axial"
+ adj <- abs(XY$axe) > pi/2
+ srt <- 180 * XY$axe / pi
+ srt[adj] <- srt[adj] - 180
+ adj <- as.numeric(adj)
+ xx.tips <- xx[1:Ntip]
+ yy.tips <- yy[1:Ntip]
+ if (label.offset) {
+ xx.tips <- xx.tips + label.offset * cos(XY$axe)
+ yy.tips <- yy.tips + label.offset * sin(XY$axe)
+ }
+ ## `srt' takes only a single value, so can't vectorize this:
+ ## (and need to 'elongate' these vectors:)
+ font <- rep(font, length.out = Ntip)
+ tip.color <- rep(tip.color, length.out = Ntip)
+ cex <- rep(cex, length.out = Ntip)
+ for (i in 1:Ntip)
+ text(xx.tips[i], yy.tips[i], cex = cex[i],
+ x$tip.label[i], adj = adj[i], font = font[i],
+ srt = srt[i], col = tip.color[i])
+ }
+ }
+ if (type %in% c("fan", "radial")) {
+ xx.tips <- xx[1:Ntip]
+ yy.tips <- yy[1:Ntip]
+ angle <- atan2(yy.tips, xx.tips) # in radians
+ if (label.offset) {
+ xx.tips <- xx.tips + label.offset * cos(angle)
+ yy.tips <- yy.tips + label.offset * sin(angle)
+ }
+ s <- xx.tips < 0
+ angle <- angle * 180/pi # switch to degrees
+ angle[s] <- angle[s] + 180
+ adj <- as.numeric(s)
+ ## `srt' takes only a single value, so can't vectorize this:
+ ## (and need to 'elongate' these vectors:)
+ font <- rep(font, length.out = Ntip)
+ tip.color <- rep(tip.color, length.out = Ntip)
+ cex <- rep(cex, length.out = Ntip)
+ for (i in 1:Ntip)
+ text(xx.tips[i], yy.tips[i], x$tip.label[i], font = font[i],
+ cex = cex[i], srt = angle[i], adj = adj[i],
+ col = tip.color[i])
+ }
+ }
+ if (show.node.label)
+ text(xx[ROOT:length(xx)] + label.offset, yy[ROOT:length(yy)],
+ x$node.label, adj = adj, font = font, srt = srt, cex = cex)
+}
+ L <- list(type = type, use.edge.length = use.edge.length,
+ node.pos = node.pos, node.depth = node.depth,
+ show.tip.label = show.tip.label,
+ show.node.label = show.node.label, font = font,
+ cex = cex, adj = adj, srt = srt, no.margin = no.margin,
+ label.offset = label.offset, x.lim = x.lim, y.lim = y.lim,
+ direction = direction, tip.color = tip.color,
+ Ntip = Ntip, Nnode = Nnode)
+ assign("last_plot.phylo", c(L, list(edge = xe, xx = xx, yy = yy)),
+ envir = .PlotPhyloEnv)
+ invisible(L)
+}
+
+phylogram.plot <- function(edge, Ntip, Nnode, xx, yy, horizontal,
+ edge.color, edge.width, edge.lty)
+{
+ nodes <- (Ntip + 1):(Ntip + Nnode)
+ if (!horizontal) {
+ tmp <- yy
+ yy <- xx
+ xx <- tmp
+ }
+ ## un trait vertical a chaque noeud...
+ x0v <- xx[nodes]
+ y0v <- y1v <- numeric(Nnode)
+ ## store the index of each node in the 1st column of edge:
+ NodeInEdge1 <- vector("list", Nnode)
+ for (i in nodes) {
+ ii <- i - Ntip
+ j <- NodeInEdge1[[ii]] <- which(edge[, 1] == i)
+ tmp <- range(yy[edge[j, 2]])
+ y0v[ii] <- tmp[1]
+ y1v[ii] <- tmp[2]
+ }
+ ## ... et un trait horizontal partant de chaque tip et chaque noeud
+ ## vers la racine
+ x0h <- xx[edge[, 1]]
+ x1h <- xx[edge[, 2]]
+ y0h <- yy[edge[, 2]]
+
+ nc <- length(edge.color)
+ nw <- length(edge.width)
+ nl <- length(edge.lty)
+
+ if (nc + nw + nl == 3) {
+ color.v <- edge.color
+ width.v <- edge.width
+ lty.v <- edge.lty
+ } else {
+ Nedge <- dim(edge)[1]
+ edge.color <- rep(edge.color, length.out = Nedge)
+ edge.width <- rep(edge.width, length.out = Nedge)
+ edge.lty <- rep(edge.lty, length.out = Nedge)
+ DF <- data.frame(edge.color, edge.width, edge.lty, stringsAsFactors = FALSE)
+ color.v <- rep("black", Nnode)
+ width.v <- rep(1, Nnode)
+ lty.v <- rep(1, Nnode)
+ for (i in 1:Nnode) {
+ br <- NodeInEdge1[[i]]
+ if (length(br) > 2) {
+ x <- unique(DF[br, 1])
+ if (length(x) == 1) color.v[i] <- x
+ x <- unique(DF[br, 2])
+ if (length(x) == 1) width.v[i] <- x
+ x <- unique(DF[br, 3])
+ if (length(x) == 1) lty.v[i] <- x
+ } else {
+ A <- br[1]
+ B <- br[2]
+ if (any(DF[A, ] != DF[B, ])) {
+ color.v[i] <- edge.color[B]
+ width.v[i] <- edge.width[B]
+ lty.v[i] <- edge.lty[B]
+ ## add a new line:
+ y0v <- c(y0v, y0v[i])
+ y1v <- c(y1v, yy[i + Ntip])
+ x0v <- c(x0v, x0v[i])
+ color.v <- c(color.v, edge.color[A])
+ width.v <- c(width.v, edge.width[A])
+ lty.v <- c(lty.v, edge.lty[A])
+ ## shorten the line:
+ y0v[i] <- yy[i + Ntip]
+ } else {
+ color.v[i] <- edge.color[A]
+ width.v[i] <- edge.width[A]
+ lty.v[i] <- edge.lty[A]
+ }
+ }
+ }
+ }
+
+ if (horizontal) {
+ segments(x0h, y0h, x1h, y0h, col = edge.color, lwd = edge.width, lty = edge.lty) # draws horizontal lines
+ segments(x0v, y0v, x0v, y1v, col = color.v, lwd = width.v, lty = lty.v) # draws vertical lines
+ } else {
+ segments(y0h, x0h, y0h, x1h, col = edge.color, lwd = edge.width, lty = edge.lty) # draws vertical lines
+ segments(y0v, x0v, y1v, x0v, col = color.v, lwd = width.v, lty = lty.v) # draws horizontal lines
+ }
+}
+
+cladogram.plot <- function(edge, xx, yy, edge.color, edge.width, edge.lty)
+ segments(xx[edge[, 1]], yy[edge[, 1]], xx[edge[, 2]], yy[edge[, 2]],
+ col = edge.color, lwd = edge.width, lty = edge.lty)
+
+circular.plot <- function(edge, Ntip, Nnode, xx, yy, theta,
+ r, edge.color, edge.width, edge.lty)
+### 'edge' must be in postorder order
+{
+ r0 <- r[edge[, 1]]
+ r1 <- r[edge[, 2]]
+ theta0 <- theta[edge[, 2]]
+ costheta0 <- cos(theta0)
+ sintheta0 <- sin(theta0)
+
+ x0 <- r0 * costheta0
+ y0 <- r0 * sintheta0
+ x1 <- r1 * costheta0
+ y1 <- r1 * sintheta0
+
+ segments(x0, y0, x1, y1, col = edge.color, lwd = edge.width, lty = edge.lty)
+
+ tmp <- which(diff(edge[, 1]) != 0)
+ start <- c(1, tmp + 1)
+ Nedge <- dim(edge)[1]
+ end <- c(tmp, Nedge)
+
+ ## function dispatching the features to the arcs
+ foo <- function(edge.feat, default) {
+ if (length(edge.feat) == 1) return(as.list(rep(edge.feat, Nnode)))
+ edge.feat <- rep(edge.feat, length.out = Nedge)
+ feat.arc <- as.list(rep(default, Nnode))
+ for (k in 1:Nnode) {
+ tmp <- edge.feat[start[k]]
+ feat.arc[[k]] <-
+ if (tmp == edge.feat[end[k]]) tmp
+ else if (nodedegree[k] == 2)
+ rep(c(tmp, edge.feat[end[k]]), each = 50)
+ }
+ feat.arc
+ }
+ nodedegree <- tabulate(edge[, 1L])[-seq_len(Ntip)]
+ co <- foo(edge.color, "black")
+ lw <- foo(edge.width, 1)
+ ly <- foo(edge.lty, 1)
+
+ for (k in 1:Nnode) {
+ i <- start[k]
+ j <- end[k]
+ X <- rep(r[edge[i, 1]], 100)
+ Y <- seq(theta[edge[i, 2]], theta[edge[j, 2]], length.out = 100)
+ x <- X * cos(Y); y <- X * sin(Y)
+ x0 <- x[-100]; y0 <- y[-100]; x1 <- x[-1]; y1 <- y[-1]
+ segments(x0, y0, x1, y1, col = co[[k]], lwd = lw[[k]], lty = ly[[k]])
+ }
+}
+
+unrooted.xy <- function(Ntip, Nnode, edge, edge.length, nb.sp, rotate.tree)
+{
+ foo <- function(node, ANGLE, AXIS) {
+ ind <- which(edge[, 1] == node)
+ sons <- edge[ind, 2]
+ start <- AXIS - ANGLE/2
+ for (i in 1:length(sons)) {
+ h <- edge.length[ind[i]]
+ angle[sons[i]] <<- alpha <- ANGLE*nb.sp[sons[i]]/nb.sp[node]
+ axis[sons[i]] <<- beta <- start + alpha/2
+ start <- start + alpha
+ xx[sons[i]] <<- h*cos(beta) + xx[node]
+ yy[sons[i]] <<- h*sin(beta) + yy[node]
+ }
+ for (i in sons)
+ if (i > Ntip) foo(i, angle[i], axis[i])
+ }
+ Nedge <- dim(edge)[1]
+ yy <- xx <- numeric(Ntip + Nnode)
+ ## `angle': the angle allocated to each node wrt their nb of tips
+ ## `axis': the axis of each branch
+ axis <- angle <- numeric(Ntip + Nnode)
+ ## start with the root...
+ foo(Ntip + 1L, 2*pi, 0 + rotate.tree)
+
+ M <- cbind(xx, yy)
+ axe <- axis[1:Ntip] # the axis of the terminal branches (for export)
+ axeGTpi <- axe > pi
+ ## insures that returned angles are in [-PI, +PI]:
+ axe[axeGTpi] <- axe[axeGTpi] - 2*pi
+ list(M = M, axe = axe)
+}
+
+node.depth <- function(phy, method = 1)
+{
+ n <- length(phy$tip.label)
+ m <- phy$Nnode
+ N <- dim(phy$edge)[1]
+ phy <- reorder(phy, order = "postorder")
+ .C(node_depth, as.integer(n), as.integer(m),
+ as.integer(phy$edge[, 1]), as.integer(phy$edge[, 2]),
+ as.integer(N), double(n + m), as.integer(method))[[6]]
+}
+
+node.depth.edgelength <- function(phy)
+{
+ n <- length(phy$tip.label)
+ m <- phy$Nnode
+ N <- dim(phy$edge)[1]
+ phy <- reorder(phy, order = "postorder")
+ .C(node_depth_edgelength, as.integer(n), as.integer(n),
+ as.integer(phy$edge[, 1]), as.integer(phy$edge[, 2]),
+ as.integer(N), as.double(phy$edge.length), double(n + m))[[7]]
+}
+
+node.height <- function(phy, clado.style = FALSE)
+{ n <- length(phy$tip.label)
+ m <- phy$Nnode
+ N <- dim(phy$edge)[1]
+
+ phy <- reorder(phy)
+ yy <- numeric(n + m)
+ e2 <- phy$edge[, 2]
+ yy[e2[e2 <= n]] <- 1:n
+
+ phy <- reorder(phy, order = "postorder")
+ e1 <- phy$edge[, 1]
+ e2 <- phy$edge[, 2]
+
+ if (clado.style)
+ .C(node_height_clado, as.integer(n), as.integer(m),
+ as.integer(e1), as.integer(e2), as.integer(N),
+ double(n + m), as.double(yy))[[7]]
+ else
+ .C(node_height, as.integer(n), as.integer(m),
+ as.integer(e1), as.integer(e2), as.integer(N),
+ as.double(yy))[[6]]
+}
+
+node.height.clado <- function(phy)
+{
+ warning("the function 'node.height.clado' will be removed soon.\nUse node.height(phy, clado.style = TRUE) instead.")
+ node.height(phy, TRUE)
+}
+
+plot.multiPhylo <- function(x, layout = 1, ...)
+{
+ layout(matrix(1:layout, ceiling(sqrt(layout)), byrow = TRUE))
+ if (!devAskNewPage() && interactive()) {
+ devAskNewPage(TRUE)
+ on.exit(devAskNewPage(FALSE))
+ }
+ for (i in 1:length(x)) plot(x[[i]], ...)
+}
+
+trex <- function(phy, title = TRUE, subbg = "lightyellow3",
+ return.tree = FALSE, ...)
+{
+ lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv)
+ devmain <- dev.cur() # where the main tree is plotted
+
+ restore <- function() {
+ dev.set(devmain)
+ assign("last_plot.phylo", lastPP, envir = .PlotPhyloEnv)
+ }
+
+ on.exit(restore())
+ NEW <- TRUE
+ cat("Click close to a node. Right-click to exit.\n")
+ repeat {
+ x <- identify.phylo(phy, quiet = TRUE)
+ if (is.null(x)) return(invisible(NULL)) else {
+ x <- x$nodes
+ if (is.null(x)) cat("Try again!\n") else {
+ if (NEW) {
+ dev.new()
+ par(bg = subbg)
+ devsub <- dev.cur()
+ NEW <- FALSE
+ } else dev.set(devsub)
+
+ tr <- extract.clade(phy, x)
+ plot(tr, ...)
+ if (is.character(title)) title(title)
+ else if (title) {
+ tl <-
+ if (is.null(phy$node.label))
+ paste("From node #", x, sep = "")
+ else paste("From", phy$node.label[x - Ntip(phy)])
+ title(tl)
+ }
+ if (return.tree) return(tr)
+ restore()
+ }
+ }
+ }
+}
+
+kronoviz <- function(x, layout = length(x), horiz = TRUE, ...)
+{
+ par(mar = rep(0.5, 4), oma = rep(2, 4))
+ rts <- sapply(x, function(x) branching.times(x)[1])
+ maxrts <- max(rts)
+ lim <- cbind(rts - maxrts, rts)
+ Ntree <- length(x)
+ Ntips <- sapply(x, Ntip)
+ if (horiz) {
+ nrow <- layout
+ w <- 1
+ h <- Ntips
+ } else {
+ nrow <- 1
+ w <- Ntips
+ h <- 1
+ }
+ layout(matrix(1:layout, nrow), widths = w, heights = h)
+ if (layout < Ntree && !devAskNewPage() && interactive()) {
+ devAskNewPage(TRUE)
+ on.exit(devAskNewPage(FALSE))
+ }
+ if (horiz) {
+ for (i in 1:Ntree)
+ plot(x[[i]], x.lim = lim[i, ], ...)
+ } else {
+ for (i in 1:Ntree)
+ plot(x[[i]], y.lim = lim[i, ], direction = "u", ...)
+ }
+ axisPhylo(if (horiz) 1 else 4) # better if the deepest tree is last ;)
+}
diff --git a/R/plot.popsize.R b/R/plot.popsize.R
new file mode 100644
index 0000000..124e288
--- /dev/null
+++ b/R/plot.popsize.R
@@ -0,0 +1,64 @@
+## plot.popsize.R (2004-07-4)
+
+## Plot population size in dependence of time
+
+## Copyright 2004 Rainer Opgen-Rhein and Korbinian Strimmer
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+plot.popsize <- function(x, show.median=TRUE,
+ show.years=FALSE, subst.rate, present.year, ...)
+{
+ if (class(x) != "popsize")
+ stop("object \"x\" is not of class \"popsize\"")
+
+ ylim <- c(min(popsize[,2:5]),max(popsize[,2:5]))
+ if (show.years)
+ {
+ x1 <- -x[,1]/subst.rate+present.year
+ xlab <- "time (years)"
+ xlim <- c(min(x1),max(x1))
+ }
+ else
+ {
+ x1 <- x[,1]
+ xlab <- "time (past to present in units of substitutions)"
+ xlim <- c(max(x1),min(x1))
+ }
+
+ if (show.median)
+ plot(x1,x[,3],type="s", xlim=xlim, ylim=ylim, xlab=xlab,ylab="effective population size",log="y", lwd=2.5, ...) #median
+ else
+ plot(x1,x[,2],type="s", xlim=xlim, ylim=ylim, xlab=xlab,ylab="effective population size",log="y", lwd=2.5, ...) #median
+
+ lines(x1,x[,4], ...)
+ lines(x1,x[,5], ...)
+}
+
+
+
+lines.popsize <- function(x, show.median=TRUE,
+ show.years=FALSE, subst.rate, present.year, ...)
+{
+ if (class(x) != "popsize")
+ stop("object \"x\" is not of class \"popsize\"")
+
+ if (show.years)
+ {
+ x1 <- -x[,1]/subst.rate+present.year
+ }
+ else
+ {
+ x1 <- x[,1]
+ }
+
+
+ if (show.median)
+ lines(x1,x[,3], lwd=2.5, ...) #median
+ else
+ lines(x1,x[,2], lwd=2.5, ...) #median
+
+ lines(x1,x[,4], ...)
+ lines(x1,x[,5], ...)
+}
diff --git a/R/plotPhyloCoor.R b/R/plotPhyloCoor.R
new file mode 100644
index 0000000..db59f32
--- /dev/null
+++ b/R/plotPhyloCoor.R
@@ -0,0 +1,137 @@
+## plotPhyloCoor.R (2013-03-30)
+
+## Coordinates of a Tree Plot
+
+## Copyright 2008 Damien de Vienne, 2013 Klaus Schliep
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+plotPhyloCoor <-
+ function (x, type = "phylogram", use.edge.length = TRUE, node.pos = NULL,
+ direction = "rightwards", tip.order = NULL, ...)
+{
+ Ntip <- length(x$tip.label)
+ if (Ntip == 1)
+ stop("found only one tip in the tree!")
+ Nedge <- dim(x$edge)[1]
+ if (any(tabulate(x$edge[, 1]) == 1))
+ stop("there are single (non-splitting) nodes in your tree; you may need to use collapse.singles().")
+ Nnode <- x$Nnode
+ if (is.null(x$edge.length)) use.edge.length <- FALSE
+ phyloORclado <- type %in% c("phylogram", "cladogram")
+ horizontal <- direction %in% c("rightwards", "leftwards")
+ if (phyloORclado) {
+ ## changed by KS:
+ yy <- numeric(Ntip + Nnode)
+ if (!is.null(tip.order)) {
+ yy[tip.order] <- 1:length(tip.order)
+ } else {
+ x <- reorder(x)
+ TIPS <- x$edge[x$edge[, 2] <= Ntip, 2]
+ yy[TIPS] <- 1:Ntip
+ }
+ }
+
+ xe <- x$edge
+ ## first reorder the tree in cladewise order to avoid cophyloplot() hanging:
+ ## x <- reorder(reorder(x), order = "pruningwise") ... maybe not needed anymore (EP)
+ x <- reorder(x, order = "postorder")
+ ereorder <- match(x$edge[, 2], xe[, 2])
+
+ if (phyloORclado) {
+ if (is.null(node.pos)) {
+ node.pos <- 1
+ if (type == "cladogram" && !use.edge.length)
+ node.pos <- 2
+ }
+ if (node.pos == 1)
+ yy <- .C("node_height", as.integer(Ntip), as.integer(Nnode),
+ as.integer(x$edge[, 1]), as.integer(x$edge[,
+ 2]), as.integer(Nedge), as.double(yy),
+ PACKAGE = "ape")[[6]]
+ else {
+ ans <- .C("node_height_clado", as.integer(Ntip),
+ as.integer(Nnode), as.integer(x$edge[, 1]), as.integer(x$edge[,
+ 2]), as.integer(Nedge), double(Ntip + Nnode),
+ as.double(yy), PACKAGE = "ape")
+ xx <- ans[[6]] - 1
+ yy <- ans[[7]]
+ }
+ if (!use.edge.length) {
+ if (node.pos != 2)
+ xx <- .C("node_depth", as.integer(Ntip), as.integer(Nnode),
+ as.integer(x$edge[, 1]), as.integer(x$edge[, 2]),
+ as.integer(Nedge), double(Ntip + Nnode), 1L,
+ PACKAGE = "ape")[[6]] - 1
+ xx <- max(xx) - xx
+ } else {
+ xx <- .C("node_depth_edgelength", as.integer(Ntip),
+ as.integer(Nnode), as.integer(x$edge[, 1]), as.integer(x$edge[,
+ 2]), as.integer(Nedge), as.double(x$edge.length),
+ double(Ntip + Nnode), PACKAGE = "ape")[[7]]
+ }
+ }
+ ##if (type == "fan") {
+ ## TIPS <- xe[which(xe[, 2] <= Ntip), 2]
+ ## xx <- seq(0, 2 * pi * (1 - 1/Ntip), 2 * pi/Ntip)
+ ## theta <- double(Ntip)
+ ## theta[TIPS] <- xx
+ ## theta <- c(theta, numeric(Nnode))
+ ## theta <- .C("node_height", as.integer(Ntip), as.integer(Nnode),
+ ## as.integer(x$edge[, 1]), as.integer(x$edge[, 2]),
+ ## as.integer(Nedge), theta, DUP = FALSE, PACKAGE = "ape")[[6]]
+ ## if (use.edge.length) {
+ ## r <- .C("node_depth_edgelength", as.integer(Ntip),
+ ## as.integer(Nnode), as.integer(x$edge[, 1]), as.integer(x$edge[,
+ ## 2]), as.integer(Nedge), as.double(x$edge.length),
+ ## double(Ntip + Nnode), DUP = FALSE, PACKAGE = "ape")[[7]]
+ ## }
+ ## else {
+ ## r <- .C("node_depth", as.integer(Ntip), as.integer(Nnode),
+ ## as.integer(x$edge[, 1]), as.integer(x$edge[,
+ ## 2]), as.integer(Nedge), double(Ntip + Nnode),
+ ## DUP = FALSE, PACKAGE = "ape")[[6]]
+ ## r <- 1/r
+ ## }
+ ## xx <- r * cos(theta)
+ ## yy <- r * sin(theta)
+ ##}
+ ##if (type == "unrooted") {
+ ## XY <- if (use.edge.length)
+ ## unrooted.xy(Ntip, Nnode, x$edge, x$edge.length)
+ ## else unrooted.xy(Ntip, Nnode, x$edge, rep(1, Nedge))
+ ## xx <- XY$M[, 1] - min(XY$M[, 1])
+ ## yy <- XY$M[, 2] - min(XY$M[, 2])
+ ##}
+ ##if (type == "radial") {
+ ## X <- .C("node_depth", as.integer(Ntip), as.integer(Nnode),
+ ## as.integer(x$edge[, 1]), as.integer(x$edge[, 2]),
+ ## as.integer(Nedge), double(Ntip + Nnode), DUP = FALSE,
+ ## PACKAGE = "ape")[[6]]
+ ## X[X == 1] <- 0
+ ## X <- 1 - X/Ntip
+ ## yy <- c((1:Ntip) * 2 * pi/Ntip, rep(0, Nnode))
+ ## Y <- .C("node_height", as.integer(Ntip), as.integer(Nnode),
+ ## as.integer(x$edge[, 1]), as.integer(x$edge[, 2]),
+ ## as.integer(Nedge), as.double(yy), DUP = FALSE, PACKAGE = "ape")[[6]]
+ ## xx <- X * cos(Y)
+ ## yy <- X * sin(Y)
+ ##}
+ if (phyloORclado && direction != "rightwards") {
+ if (direction == "leftwards") {
+ xx <- -xx
+ xx <- xx - min(xx)
+ }
+ if (!horizontal) {
+ tmp <- yy
+ yy <- xx
+ xx <- tmp - min(tmp) + 1
+ if (direction == "downwards") {
+ yy <- -yy
+ yy <- yy - min(yy)
+ }
+ }
+ }
+ cbind(xx, yy)
+}
diff --git a/R/print.lmorigin.R b/R/print.lmorigin.R
new file mode 100644
index 0000000..1098a70
--- /dev/null
+++ b/R/print.lmorigin.R
@@ -0,0 +1,55 @@
+'print.lmorigin' <-
+ function(x, ...)
+{
+ if(x$origin) {
+ cat("\nRegression through the origin",'\n')
+ } else {
+ cat("\nMultiple regression with estimation of intercept",'\n')
+ }
+ cat("\nCall:\n")
+ cat(deparse(x$call),'\n')
+ if(x$origin) { names <- x$var.names[-1] }
+ else { names <- c("(Intercept)",x$var.names[-1]) }
+
+ cat("\nCoefficients and parametric test results \n",'\n')
+ res <- as.data.frame(cbind(summary(x$reg)$coefficients[,1], summary(x$reg)$coefficients[,2], summary(x$reg)$coefficients[,3], summary(x$reg)$coefficients[,4]))
+ rownames(res) <- names
+ colnames(res) <- c("Coefficient","Std_error","t-value","Pr(>|t|)")
+ printCoefmat(res, P.values=TRUE, signif.stars=TRUE)
+
+ if(x$nperm > 0) {
+ cat("\nTwo-tailed tests of regression coefficients\n",'\n')
+ res2 <- as.data.frame(cbind(summary(x$reg)$coefficients[,1], x$p.param.t.2tail, x$p.perm.t.2tail))
+ rownames(res2) <- names
+ colnames(res2) <- c("Coefficient","p-param","p-perm")
+ nc <- 3
+ printCoefmat(res2, P.values=TRUE, signif.stars=TRUE, has.Pvalue = 3 && substr(colnames(res2)[3],1,6) == "p-perm")
+
+ cat("\nOne-tailed tests of regression coefficients:",'\n')
+ cat("test in the direction of the sign of the coefficient\n",'\n')
+ res1 <- as.data.frame(cbind(summary(x$reg)$coefficients[,1], x$p.param.t.1tail, x$p.perm.t.1tail))
+ rownames(res1) <- names
+ colnames(res1) <- c("Coefficient","p-param","p-perm")
+ nc <- 3
+ printCoefmat(res1, P.values=TRUE, signif.stars=TRUE, has.Pvalue = 3 && substr(colnames(res1)[3],1,6) == "p-perm")
+
+ }
+ cat("\nResidual standard error:", summary(x$reg)$sigma, "on", summary(x$reg)$df[2],"degrees of freedom",'\n')
+ cat("Multiple R-square:", summary(x$reg)$r.squared," Adjusted R-square:", summary(x$reg)$adj.r.squared,'\n')
+
+ F <- summary(x$reg)$fstatistic[[1]]
+ df1 <- summary(x$reg)$fstatistic[[2]]
+ df2 <- summary(x$reg)$fstatistic[[3]]
+ p.param.F <- pf(F, df1, df2, lower.tail=FALSE)
+ cat("\nF-statistic:", F, "on", df1, "and", df2, "DF:\n")
+ cat(" parametric p-value :", p.param.F,'\n')
+ if(x$nperm > 0) {
+ cat(" permutational p-value:", x$p.perm.F,'\n')
+ if(x$method == "raw") {
+ cat("after",x$nperm,"permutations of",x$method,"data",'\n','\n')
+ } else {
+ cat("after",x$nperm,"permutations of",x$method,"of full model",'\n','\n')
+ }
+ }
+ invisible(x)
+}
diff --git a/R/print.parafit.R b/R/print.parafit.R
new file mode 100644
index 0000000..f23c009
--- /dev/null
+++ b/R/print.parafit.R
@@ -0,0 +1,18 @@
+'print.parafit' <-
+ function(x, ...)
+{
+ cat("\nTest of host-parasite coevolution",'\n','\n')
+
+ cat("Global test: ParaFitGlobal =",x$ParaFitGlobal,", p-value =", x$p.global, "(", x$nperm,"permutations)",'\n','\n')
+
+ n.links <- nrow(x$link.table)
+ cat("There are",n.links,"host-parasite links in matrix HP",'\n','\n')
+ cat("Test of individual host-parasite links", "(", x$nperm, "permutations)",'\n','\n')
+ print(x$link.table)
+
+ cat('\n',"Number of parasites per host",'\n')
+ print(x$para.per.host)
+ cat('\n',"Number of hosts per parasite",'\n')
+ print(x$host.per.para)
+ invisible(x)
+}
diff --git a/R/rTrait.R b/R/rTrait.R
new file mode 100644
index 0000000..d890db7
--- /dev/null
+++ b/R/rTrait.R
@@ -0,0 +1,174 @@
+## rTrait.R (2014-03-06)
+
+## Trait Evolution
+
+## Copyright 2010-2014 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+rTraitDisc <-
+ function(phy, model = "ER", k = if (is.matrix(model)) ncol(model) else 2,
+ rate = 0.1, states = LETTERS[1:k], freq = rep(1/k, k),
+ ancestor = FALSE, root.value = 1, ...)
+{
+ if (is.null(phy$edge.length))
+ stop("tree has no branch length")
+ if (any(phy$edge.length < 0))
+ stop("at least one branch length negative")
+
+ if (is.character(model)) {
+ switch(toupper(model), "ER" = {
+ if (length(rate) != 1)
+ stop("`rate' must have one element")
+ Q <- matrix(rate, k, k)
+ }, "ARD" = {
+ if (length(rate) != k*(k - 1))
+ stop("`rate' must have k(k - 1) elements")
+ Q <- matrix(0, k, k)
+ Q[col(Q) != row(Q)] <- rate
+ }, "SYM" = {
+ if (length(rate) != k*(k - 1)/2)
+ stop("`rate' must have k(k - 1)/2 elements")
+ Q <- matrix(0, k, k)
+ sel <- col(Q) < row(Q)
+ Q[sel] <- rate
+ Q <- t(Q)
+ Q[sel] <- rate
+ })
+ }
+ if (is.matrix(model)) {
+ Q <- model
+ if (ncol(Q) != nrow(Q))
+ stop("the matrix given as `model' must be square")
+ }
+
+ phy <- reorder(phy, "postorder")
+ n <- length(phy$tip.label)
+ N <- dim(phy$edge)[1]
+ ROOT <- n + 1L
+ x <- integer(n + phy$Nnode)
+ x[ROOT] <- as.integer(root.value)
+
+ anc <- phy$edge[, 1]
+ des <- phy$edge[, 2]
+ el <- phy$edge.length
+
+ if (is.function(model)) {
+ environment(model) <- environment() # to find 'k'
+ for (i in N:1) x[des[i]] <- model(x[anc[i]], el[i], ...)
+ } else {
+ freq <- rep(freq, each = k)
+ Q <- Q * freq
+ diag(Q) <- 0
+ diag(Q) <- -rowSums(Q)
+ for (i in N:1) {
+ p <- matexpo(Q * el[i])[x[anc[i]], ]
+ x[des[i]] <- sample.int(k, size = 1, FALSE, prob = p)
+ }
+ }
+
+ if (ancestor) {
+ if (is.null(phy$node.label)) phy <- makeNodeLabel(phy)
+ names(x) <- c(phy$tip.label, phy$node.label)
+ } else {
+ x <- x[1:n]
+ names(x) <- phy$tip.label
+ }
+ class(x) <- "factor"
+ levels(x) <- states
+ x
+}
+
+rTraitCont <-
+ function(phy, model = "BM", sigma = 0.1, alpha = 1, theta = 0,
+ ancestor = FALSE, root.value = 0, ...)
+{
+ if (is.null(phy$edge.length))
+ stop("tree has no branch length")
+ if (any(phy$edge.length < 0))
+ stop("at least one branch length negative")
+
+ phy <- reorder(phy, "postorder")
+ n <- length(phy$tip.label)
+ N <- dim(phy$edge)[1]
+ ROOT <- n + 1L
+ x <- numeric(n + phy$Nnode)
+ x[ROOT] <- root.value
+
+ anc <- phy$edge[, 1]
+ des <- phy$edge[, 2]
+ el <- phy$edge.length
+
+ if (is.function(model)) {
+ environment(model) <- environment()
+ for (i in N:1) x[des[i]] <- model(x[anc[i]], el[i], ...)
+ } else {
+ model <- pmatch(toupper(model), c("BM", "OU"))
+ if (length(sigma) == 1) sigma <- rep(sigma, N)
+ else if (length(sigma) != N)
+ stop("'sigma' must have one or Nedge(phy) elements")
+ if (model == 2) { # "OU"
+ if (length(alpha) == 1) alpha <- rep(alpha, N)
+ else if (length(alpha) != N)
+ stop("'alpha' must have one or Nedge(phy) elements")
+ if (length(theta) == 1) theta <- rep(theta, N)
+ else if (length(theta) != N)
+ stop("'theta' must have one or Nedge(phy) elements")
+ }
+ x <- .C(C_rTraitCont, as.integer(model), as.integer(N),
+ as.integer(anc - 1L), as.integer(des - 1L), el,
+ as.double(sigma), as.double(alpha), as.double(theta),
+ x = x, NAOK = TRUE)$x
+ }
+
+ if (ancestor) {
+ if (is.null(phy$node.label)) phy <- makeNodeLabel(phy)
+ names(x) <- c(phy$tip.label, phy$node.label)
+ } else {
+ x <- x[1:n]
+ names(x) <- phy$tip.label
+ }
+ x
+}
+
+rTraitMult <-
+ function(phy, model, p = 1, root.value = rep(0, p), ancestor = FALSE,
+ asFactor = NULL, trait.labels = paste("x", 1:p, sep = ""), ...)
+{
+ phy <- reorder(phy, "postorder")
+ n <- length(phy$tip.label)
+ m <- phy$Nnode
+ N <- dim(phy$edge)[1]
+ ROOT <- n + 1L
+
+ x <- matrix(0, n + m, p)
+ x[ROOT, ] <- root.value
+
+ anc <- phy$edge[, 1]
+ des <- phy$edge[, 2]
+
+ el <- phy$edge.length
+ if (is.null(el)) el <- numeric(N)
+
+ environment(model) <- environment() # to find 'p'
+
+ for (i in N:1) x[des[i], ] <- model(x[anc[i], ], el[i], ...)
+
+ if (ancestor) {
+ if (is.null(phy$node.label)) phy <- makeNodeLabel(phy)
+ rownames(x) <- c(phy$tip.label, phy$node.label)
+ } else {
+ x <- x[1:n, , drop = FALSE]
+ rownames(x) <- phy$tip.label
+ }
+ x <- as.data.frame(x)
+ names(x) <- trait.labels
+ if (!is.null(asFactor)) {
+ for (i in asFactor) {
+ y <- x[, i]
+ x[, i] <- factor(y, labels = LETTERS[1:length(unique(y))])
+ }
+ }
+ x
+}
diff --git a/R/read.GenBank.R b/R/read.GenBank.R
new file mode 100644
index 0000000..23bf4db
--- /dev/null
+++ b/R/read.GenBank.R
@@ -0,0 +1,53 @@
+## read.GenBank.R (2012-02-17)
+
+## Read DNA Sequences from GenBank via Internet
+
+## Copyright 2002-2012 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+read.GenBank <-
+ function(access.nb, seq.names = access.nb, species.names = TRUE,
+ gene.names = FALSE, as.character = FALSE)
+{
+ N <- length(access.nb)
+ ## If there are more than 400 sequences, we need to break down the
+ ## requests, otherwise there is a segmentation fault.
+ nrequest <- N %/% 400 + as.logical(N %% 400)
+ X <- character(0)
+ for (i in 1:nrequest) {
+ a <- (i - 1) * 400 + 1
+ b <- 400 * i
+ if (i == nrequest) b <- N
+ URL <- paste("http://eutils.ncbi.nlm.nih.gov/entrez/eutils/efetch.fcgi?db=nucleotide&id=",
+ paste(access.nb[a:b], collapse = ","),
+ "&rettype=gb&retmode=text", sep = "")
+ X <- c(X, scan(file = URL, what = "", sep = "\n", quiet = TRUE))
+ }
+ FI <- grep("^ {0,}ORIGIN", X) + 1
+ LA <- which(X == "//") - 1
+ obj <- vector("list", N)
+ for (i in 1:N) {
+ ## remove all spaces and digits
+ tmp <- gsub("[[:digit:] ]", "", X[FI[i]:LA[i]])
+ obj[[i]] <- unlist(strsplit(tmp, NULL))
+ }
+ names(obj) <- seq.names
+ if (!as.character) obj <- as.DNAbin(obj)
+ if (species.names) {
+ tmp <- character(N)
+ sp <- grep("ORGANISM", X)
+ for (i in 1:N)
+ tmp[i] <- unlist(strsplit(X[sp[i]], " +ORGANISM +"))[2]
+ attr(obj, "species") <- gsub(" ", "_", tmp)
+ }
+ if (gene.names) {
+ tmp <- character(N)
+ sp <- grep(" +gene +<", X)
+ for (i in 1:N)
+ tmp[i] <- unlist(strsplit(X[sp[i + 1L]], " +/gene=\""))[2]
+ attr(obj, "gene") <- gsub("\"$", "", tmp)
+ }
+ obj
+}
diff --git a/R/read.caic.R b/R/read.caic.R
new file mode 100644
index 0000000..5cb5d3a
--- /dev/null
+++ b/R/read.caic.R
@@ -0,0 +1,91 @@
+## read.caic.R (2005-09-21)
+
+## Read Tree File in CAIC Format
+
+## Copyright 2005 Julien Dutheil
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+read.caic <- function(file, brlen=NULL, skip = 0, comment.char="#", ...)
+{
+ text <- scan(file = file, what = character(), sep="\n", skip = skip, comment.char = comment.char, ...)
+
+ # Parse the whole file:
+ n <- length(text) / 2
+ nodes <- 1:n;
+ leaf.names <- character(n)
+ patterns <- character(n)
+ lengths <- numeric(n)
+ for(i in 1:n)
+ {
+ leaf.names[i] <- text[2*i]
+ patterns[i] <- text[2*i-1]
+ lengths[i] <- nchar(patterns[i])
+ }
+ # Sort all patterns if not done:
+ i <- order(patterns);
+ leaf.names <- leaf.names[i]
+ patterns <- patterns[i]
+ lengths <- lengths[i]
+
+ # This inner function compares two patterns:
+ test.patterns <- function(p1, p2)
+ {
+ t1 <- strsplit(p1, split="")[[1]]
+ t2 <- strsplit(p2, split="")[[1]]
+ if(length(t1) == length(t2))
+ {
+ l <- length(t1)
+ if(l==1) return(TRUE)
+ return(all(t1[1:(l-1)]==t2[1:(l-1)]) & t1[l] != t2[l])
+ }
+ return(FALSE)
+ }
+
+ # The main loop:
+ while(length(nodes) > 1)
+ {
+ # Recompute indexes:
+ index <- logical(length(nodes))
+ maxi <- max(lengths)
+ for(i in 1:length(nodes))
+ {
+ index[i] <- lengths[i] == maxi
+ }
+ i <- 1
+ while(i <= length(nodes))
+ {
+ if(index[i])
+ {
+ p <- paste("(",nodes[i],sep="")
+ c <- i+1
+ while(c <= length(nodes) && index[c] && test.patterns(patterns[i], patterns[c]))
+ {
+ p <- paste(p, nodes[c], sep=",")
+ c <- c+1
+ }
+ if(c-i < 2) stop("Unvalid format.")
+ p <- paste(p, ")", sep="")
+ nodes[i] <- p
+ patterns[i]<- substr(patterns[i],1,nchar(patterns[i])-1)
+ lengths[i] <- lengths[i]-1
+ nodes <- nodes [-((i+1):(c-1))]
+ lengths <- lengths [-((i+1):(c-1))]
+ patterns <- patterns[-((i+1):(c-1))]
+ index <- index [-((i+1):(c-1))]
+ }
+ i <- i+1
+ }
+ }
+
+ # Create a 'phylo' object and return it:
+ phy <- read.tree(text=paste(nodes[1],";", sep=""))
+ phy$tip.label <- leaf.names;
+ if(!is.null(brlen))
+ {
+ br <- read.table(file=brlen)
+ phy$edge.length <- br[,1]
+ }
+ return(phy)
+}
diff --git a/R/read.dna.R b/R/read.dna.R
new file mode 100644
index 0000000..b75d624
--- /dev/null
+++ b/R/read.dna.R
@@ -0,0 +1,132 @@
+## read.dna.R (2013-04-02)
+
+## Read DNA Sequences in a File
+
+## Copyright 2003-2013 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+read.FASTA <- function(file)
+{
+ sz <- file.info(file)$size
+ x <- readBin(file, "raw", sz)
+ icr <- which(x == as.raw(0x0d)) # CR
+ if (length(icr)) x <- x[-icr]
+ res <- .Call(rawStreamToDNAbin, x)
+ names(res) <- sub("^ +", "", names(res)) # to permit phylosim
+ class(res) <- "DNAbin"
+ res
+}
+
+read.dna <- function(file, format = "interleaved", skip = 0,
+ nlines = 0, comment.char = "#",
+ as.character = FALSE, as.matrix = NULL)
+{
+ findFirstNucleotide <- function(x) {
+ ## actually find the 1st non-blank character
+ ## just in case: pat.base <- "[-AaCcGgTtUuMmRrWwSsYyKkVvHhDdBbNn?]{10}"
+ tmp <- regexpr("[[:blank:]]+", x[1]) # consider only a single string
+ tmp[1] + attr(tmp, "match.length")
+ }
+ getTaxaNames <- function(x) {
+ x <- sub("^['\" ]+", "", x) # remove the leading quotes and spaces
+ x <- sub("['\" ]+$", "", x) # " " trailing " " "
+ x
+ }
+ getNucleotide <- function(x) {
+ x <- gsub(" ", "", x)
+ x <- strsplit(x, NULL)
+ tolower(unlist(x))
+ }
+ formats <- c("interleaved", "sequential", "fasta", "clustal")
+ format <- match.arg(format, formats)
+ if (format == "fasta") {
+ obj <- read.FASTA(file)
+ } else {
+ X <- scan(file = file, what = "", sep = "\n", quiet = TRUE,
+ skip = skip, nlines = nlines, comment.char = comment.char)
+ if (format %in% formats[1:2]) {
+ ## need to remove the possible leading spaces and/or tabs in the first line
+ fl <- gsub("^[[:blank:]]+", "", X[1])
+ fl <- as.numeric(unlist(strsplit(fl, "[[:blank:]]+")))
+ if (length(fl) != 2 || any(is.na(fl)))
+ stop("the first line of the file must contain the dimensions of the data")
+ n <- fl[1]
+ s <- fl[2]
+ obj <- matrix("", n, s)
+ X <- X[-1]
+ }
+ switch(format,
+ "interleaved" = {
+ start.seq <- findFirstNucleotide(X[1])
+ one2n <- 1:n
+ taxa <- getTaxaNames(substr(X[one2n], 1, start.seq - 1))
+ X[one2n] <- substr(X[one2n], start.seq, nchar(X[one2n]))
+ nl <- length(X)
+ for (i in one2n)
+ obj[i, ] <- getNucleotide(X[seq(i, nl, n)])
+ },
+ "sequential" = {
+ taxa <- character(n)
+ j <- 1L # line number
+ for (i in 1:n) {
+ start.seq <- findFirstNucleotide(X[j])
+ taxa[i] <- getTaxaNames(substr(X[j], 1, start.seq - 1))
+ sequ <- getNucleotide(substr(X[j], start.seq, nchar(X[j])))
+ j <- j + 1L
+ while (length(sequ) < s) {
+ sequ <- c(sequ, getNucleotide(X[j]))
+ j <- j + 1L
+ }
+ obj[i, ] <- sequ
+ }
+ taxa <- getTaxaNames(taxa)
+ },
+ "clustal" = {
+ X <- X[-1] # drop the line with "Clustal bla bla..."
+ ## find where the 1st sequence starts
+ start.seq <- findFirstNucleotide(X[1])
+ ## find the lines with *********....
+ nspaces <- paste("^ {", start.seq - 1, "}", sep = "", collapse = "")
+ stars <- grep(nspaces, X)
+ ## we now know how many sequences in the file:
+ n <- stars[1] - 1
+ taxa <- getTaxaNames(substr(X[1:n], 1, start.seq - 1))
+ ## need to remove the sequence names before getting the sequences:
+ X <- substr(X, start.seq, nchar(X))
+ nl <- length(X)
+ ## find the length of the 1st sequence:
+ tmp <- getNucleotide(X[seq(1, nl, n + 1)])
+ s <- length(tmp)
+ obj <- matrix("", n, s)
+ obj[1, ] <- tmp
+ for (i in 2:n)
+ obj[i, ] <- getNucleotide(X[seq(i, nl, n + 1)])
+ })
+ }
+ if (format != "fasta") {
+ rownames(obj) <- taxa
+ if (!as.character) obj <- as.DNAbin(obj)
+ } else {
+ LENGTHS <- unique(unlist(lapply(obj, length)))
+ allSameLength <- length(LENGTHS) == 1
+ if (is.logical(as.matrix)) {
+ if (as.matrix && !allSameLength)
+ stop("sequences in FASTA file not of the same length")
+ } else {
+ as.matrix <- allSameLength
+ }
+ if (as.matrix) {
+ taxa <- names(obj)
+ n <- length(obj)
+ y <- matrix(as.raw(0), n, LENGTHS)
+ for (i in seq_len(n)) y[i, ] <- obj[[i]]
+ obj <- y
+ rownames(obj) <- taxa
+ class(obj) <- "DNAbin"
+ }
+ if (as.character) obj <- as.character(obj)
+ }
+ obj
+}
diff --git a/R/read.nexus.R b/R/read.nexus.R
new file mode 100644
index 0000000..ac567c2
--- /dev/null
+++ b/R/read.nexus.R
@@ -0,0 +1,253 @@
+## read.nexus.R (2012-09-28)
+
+## Read Tree File in Nexus Format
+
+## Copyright 2003-2012 Emmanuel Paradis and 2010 Klaus Schliep
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+.treeBuildWithTokens <- function(x)
+{
+ phy <- .Call(treeBuildWithTokens, x)
+ dim(phy[[1]]) <- c(length(phy[[1]])/2, 2)
+ nms <- c("edge", "edge.length", "Nnode", "node.label", "root.edge")
+ if (length(phy) == 4) nms <- nms[-5]
+ names(phy) <- nms
+ if (all(phy$node.label == "")) phy$node.label <- NULL
+ class(phy) <- "phylo"
+ attr(phy, "order") <- "cladewise"
+ phy
+}
+
+clado.build <- function(tp)
+{
+ add.internal <- function() {
+ edge[j, 1] <<- current.node
+ node <<- node + 1
+ edge[j, 2] <<- current.node <<- node
+ index[node] <<- j # set index
+ j <<- j + 1
+ }
+ add.terminal <- function() {
+ edge[j, 1] <<- current.node
+ edge[j, 2] <<- tip
+ index[tip] <<- j # set index
+ tip.label[tip] <<- tpc[k]
+ k <<- k + 1
+ tip <<- tip + 1
+ j <<- j + 1
+ }
+ go.down <- function() {
+ l <- index[current.node]
+ node.label[current.node - nb.tip] <<- tpc[k]
+ k <<- k + 1
+ current.node <<- edge[l, 1]
+ }
+ if (!length(grep(",", tp))) {
+ obj <- list(edge = matrix(c(2, 1), 1, 2), Nnode = 1)
+ tp <- unlist(strsplit(tp, "[\\(\\);]"))
+ obj$tip.label <- tp[2]
+ if (tp[3] != "") obj$node.label <- tp[3]
+ class(obj) <- "phylo"
+ return(obj)
+ }
+ tsp <- unlist(strsplit(tp, NULL))
+ tp <- gsub(")", ")NA", tp)
+ tp <- gsub(" ", "", tp)
+ tpc <- unlist(strsplit(tp, "[\\(\\),;]"))
+ tpc <- tpc[tpc != ""]
+ skeleton <- tsp[tsp == "(" | tsp == ")" | tsp == "," | tsp == ";"]
+ nsk <- length(skeleton)
+ nb.node <- length(skeleton[skeleton == ")"])
+ nb.tip <- length(skeleton[skeleton == ","]) + 1
+ ## We will assume there is an edge at the root;
+ ## if so, it will be removed and put in a vector
+ nb.edge <- nb.node + nb.tip
+ node.label <- character(nb.node)
+ tip.label <- character(nb.tip)
+
+ edge <- matrix(NA, nb.edge, 2)
+ current.node <- node <- nb.tip + 1 # node number
+ edge[nb.edge, 1] <- 0 # see comment above
+ edge[nb.edge, 2] <- node #
+
+ index <- numeric(nb.edge + 1)
+ index[node] <- nb.edge
+ ## j: index of the line number of edge
+ ## k: index of the line number of tpc
+ ## tip: tip number
+ j <- k <- tip <- 1
+ for (i in 2:nsk) {
+ if (skeleton[i] == "(") add.internal() # add an internal branch (on top)
+ if (skeleton[i] == ",") {
+ if (skeleton[i - 1] != ")") add.terminal() # add a terminal branch
+ }
+ if (skeleton[i] == ")") {
+ if (skeleton[i - 1] == ",") { # add a terminal branch and go down one level
+ add.terminal()
+ go.down()
+ }
+ if (skeleton[i - 1] == ")") go.down() # go down one level
+ }
+ }
+ edge <- edge[-nb.edge, ]
+ obj <- list(edge = edge, tip.label = tip.label,
+ Nnode = nb.node, node.label = node.label)
+ obj$node.label <-
+ if (all(obj$node.label == "NA")) NULL
+ else gsub("^NA", "", obj$node.label)
+ class(obj) <- "phylo"
+ attr(obj, "order") <- "cladewise"
+ obj
+}
+
+read.nexus <- function(file, tree.names = NULL)
+{
+ X <- scan(file = file, what = "", sep = "\n", quiet = TRUE)
+ ## remove all comments
+ ## (this might not work if there are square brackets within the comments)
+ LEFT <- grep("\\[", X)
+ RIGHT <- grep("\\]", X)
+ if (length(LEFT)) { # in case there are no comments at all
+ w <- LEFT == RIGHT
+ if (any(w)) { # in case all comments use at least 2 lines
+ s <- LEFT[w]
+ X[s] <- gsub("\\[[^]]*\\]", "", X[s])
+ ## The above regexp was quite tough to find: it makes
+ ## possible to delete series of comments on the same line:
+ ## ...[...]xxx[...]...
+ ## without deleting the "xxx". This regexp is in three parts:
+ ## \\[ [^]]* \\]
+ ## where [^]]* means "any character, except "]", repeated zero
+ ## or more times" (note that the ']' is not escaped here).
+ ## The previous version was:
+ ## X[s] <- gsub("\\[.*\\]", "", X[s])
+ ## which deleted the "xxx". (EP 2008-06-24)
+ }
+ w <- !w
+ if (any(w)) {
+ s <- LEFT[w]
+ X[s] <- gsub("\\[.*", "", X[s])
+ sb <- RIGHT[w]
+ X[sb] <- gsub(".*\\]", "", X[sb])
+ if (any(s < sb - 1))
+ X <- X[-unlist(mapply(":", (s + 1), (sb - 1)))]
+ }
+ }
+ endblock <- grep("END;|ENDBLOCK;", X, ignore.case = TRUE)
+ semico <- grep(";", X)
+ i1 <- grep("BEGIN TREES;", X, ignore.case = TRUE)
+ i2 <- grep("TRANSLATE", X, ignore.case = TRUE)
+ translation <- if (length(i2) == 1 && i2 > i1) TRUE else FALSE
+ if (translation) {
+ end <- semico[semico > i2][1]
+ x <- X[(i2 + 1):end] # assumes there's a 'new line' after "TRANSLATE"
+ ## x <- gsub("TRANSLATE", "", x, ignore.case = TRUE)
+ x <- unlist(strsplit(x, "[,; \t]"))
+ x <- x[nzchar(x)]
+ TRANS <- matrix(x, ncol = 2, byrow = TRUE)
+ TRANS[, 2] <- gsub("['\"]", "", TRANS[, 2])
+ n <- dim(TRANS)[1]
+ }
+ start <-
+ if (translation) semico[semico > i2][1] + 1
+ else semico[semico > i1][1]
+ end <- endblock[endblock > i1][1] - 1
+ tree <- X[start:end]
+ rm(X)
+### tree <- gsub("^.*= *", "", tree)
+ ## check whether there are empty lines from the above manips:
+ tree <- tree[tree != ""]
+ semico <- grep(";", tree)
+ Ntree <- length(semico) # provisional -- some ";" may actually mark end of commands
+ ## are some trees on several lines?
+ ## -- this actually 'packs' all characters ending with a ";" in a single string --
+ if (Ntree == 1 && length(tree) > 1) STRING <- paste(tree, collapse = "") else {
+ if (any(diff(semico) != 1)) {
+ STRING <- character(Ntree)
+ s <- c(1, semico[-Ntree] + 1)
+ j <- mapply(":", s, semico)
+ if (is.list(j)) {
+ for (i in 1:Ntree)
+ STRING[i] <- paste(tree[j[[i]]], collapse = "")
+ } else {
+ for (i in 1:Ntree)
+ STRING[i] <- paste(tree[j[, i]], collapse = "")
+ }
+ } else STRING <- tree
+ }
+ rm(tree)
+ ## exclude the possible command lines ending with ";":
+ STRING <- STRING[grep("^[[:blank:]]*tree.*= *", STRING, ignore.case = TRUE)]
+ Ntree <- length(STRING) # update Ntree
+ ## get the tree names:
+ nms.trees <- sub(" *= *.*", "", STRING) # only the first occurence of "="
+ nms.trees <- sub("^ *tree *", "", nms.trees, ignore.case = TRUE)
+ STRING <- sub("^.*= *", "", STRING) # delete title and 'TREE' command with 'sub'
+ STRING <- gsub(" ", "", STRING) # delete all white spaces
+ colon <- grep(":", STRING)
+ if (!length(colon)) {
+ trees <- lapply(STRING, clado.build)
+ } else if (length(colon) == Ntree) {
+ trees <-
+ if (translation) lapply(STRING, .treeBuildWithTokens)
+ else lapply(STRING, tree.build)
+ } else {
+ trees <- vector("list", Ntree)
+ trees[colon] <- lapply(STRING[colon], tree.build)
+ nocolon <- (1:Ntree)[!1:Ntree %in% colon]
+ trees[nocolon] <- lapply(STRING[nocolon], clado.build)
+ if (translation) {
+ for (i in 1:Ntree) {
+ tr <- trees[[i]]
+ for (j in 1:n) {
+ ind <- which(tr$tip.label[j] == TRANS[, 1])
+ tr$tip.label[j] <- TRANS[ind, 2]
+ }
+ if (!is.null(tr$node.label)) {
+ for (j in 1:length(tr$node.label)) {
+ ind <- which(tr$node.label[j] == TRANS[, 1])
+ tr$node.label[j] <- TRANS[ind, 2]
+ }
+ }
+ trees[[i]] <- tr
+ }
+ translation <- FALSE
+ }
+ }
+ for (i in 1:Ntree) {
+ tr <- trees[[i]]
+ ## Check here that the root edge is not incorrectly represented
+ ## in the object of class "phylo" by simply checking that there
+ ## is a bifurcation at the root
+ if (!translation) n <- length(tr$tip.label)
+ ROOT <- n + 1
+ if (sum(tr$edge[, 1] == ROOT) == 1 && dim(tr$edge)[1] > 1) {
+ stop(paste("The tree has apparently singleton node(s): cannot read tree file.\n Reading NEXUS file aborted at tree no.", i, sep = ""))
+ }
+ }
+ if (Ntree == 1) {
+ trees <- trees[[1]]
+ if (translation) {
+ trees$tip.label <-
+ if (length(colon)) TRANS[, 2] else
+ TRANS[, 2][as.numeric(trees$tip.label)]
+ }
+ } else {
+ if (!is.null(tree.names)) names(trees) <- tree.names
+ if (translation) {
+ if (length(colon) == Ntree) # .treeBuildWithTokens() was used
+ attr(trees, "TipLabel") <- TRANS[, 2]
+ else { # reassign the tip labels then compress
+ for (i in 1:Ntree)
+ trees[[i]]$tip.label <-
+ TRANS[, 2][as.numeric(trees[[i]]$tip.label)]
+ trees <- .compressTipLabel(trees)
+ }
+ }
+ class(trees) <- "multiPhylo"
+ if (!all(nms.trees == "")) names(trees) <- nms.trees
+ }
+ trees
+}
diff --git a/R/read.nexus.data.R b/R/read.nexus.data.R
new file mode 100644
index 0000000..cd261a4
--- /dev/null
+++ b/R/read.nexus.data.R
@@ -0,0 +1,142 @@
+"read.nexus.data" <- function (file)
+{
+ # Simplified NEXUS data parser.
+ #
+ # Version: 09/13/2006 01:01:59 PM CEST
+ # (modified by EP 2011-06-01)
+ #
+ # By: Johan Nylander, nylander @ scs.fsu.edu
+ #
+ # WARNING: This is parser reads a restricted nexus format,
+ # see README for details.
+ #
+ # Argument (x) is a nexus formatted data file.
+ #
+ # Returns (Value) a list of data sequences each made of a single
+ # vector of mode character where each element is a character.
+ #
+ # TODO: Error checking, gap/missing, find.datatype, etc.
+ #------------------------------------------------------------------
+
+ "find.ntax" <- function (x)
+ {
+ for (i in 1:NROW(x)) {
+ if(any(f <- grep("\\bntax", x[i], ignore.case = TRUE))) {
+ ntax <- as.numeric(sub("(.+?)(ntax\\s*\\=\\s*)(\\d+)(.+)",
+ "\\3", x[i], perl = TRUE, ignore.case = TRUE))
+ break
+ }
+ }
+ ntax
+ }
+
+ "find.nchar" <- function (x)
+ {
+ for (i in 1:NROW(x)) {
+ if(any(f <- grep("\\bnchar", x[i], ignore.case = TRUE))) {
+ nchar <- as.numeric(sub("(.+?)(nchar\\s*\\=\\s*)(\\d+)(.+)",
+ "\\3", x[i], perl = TRUE, ignore.case = TRUE))
+ break
+ }
+ }
+ nchar
+ }
+
+ "find.matrix.line" <- function (x)
+ {
+ for (i in 1:NROW(x)) {
+ if(any(f <- grep("\\bmatrix\\b", x[i], ignore.case = TRUE))) {
+ matrix.line <- as.numeric(i)
+ break
+ }
+ }
+ matrix.line
+ }
+
+ "trim.whitespace" <- function (x)
+ {
+ gsub("\\s+", "", x)
+ }
+
+ "trim.semicolon" <- function (x)
+ {
+ gsub(";", "", x)
+ }
+
+ X <- scan(file = file, what = character(), sep = "\n",
+ quiet = TRUE, comment.char = "[", strip.white = TRUE)
+ ntax <- find.ntax(X)
+ nchar <- find.nchar(X)
+ matrix.line <- find.matrix.line(X)
+ start.reading <- matrix.line + 1
+ Obj <- list()
+ length(Obj) <- ntax
+ i <- 1
+ pos <- 0
+ tot.nchar <- 0
+ tot.ntax <- 0
+
+ for (j in start.reading:NROW(X)) {
+ Xj <- trim.semicolon(X[j])
+ if(Xj == "") {
+ break
+ }
+ if(any(jtmp <- grep("\\bend\\b", X[j], perl = TRUE, ignore.case = TRUE))) {
+ break
+ }
+ ts <- unlist(strsplit(Xj, "(?<=\\S)(\\s+)(?=\\S)", perl = TRUE))
+ if (length(ts) > 2) {
+ stop("nexus parser does not handle spaces in sequences or taxon names (ts>2)")
+ }
+ if (length(ts) !=2) {
+ stop("nexus parser failed to read the sequences (ts!=2)")
+ }
+ Seq <- trim.whitespace(ts[2])
+ Name <- trim.whitespace(ts[1])
+ nAME <- paste(c("\\b", Name, "\\b"), collapse = "")
+ if (any(l <- grep(nAME, names(Obj)))) {
+ tsp <- strsplit(Seq, NULL)[[1]]
+ for (k in 1:length(tsp)) {
+ p <- k + pos
+ Obj[[l]][p] <- tsp[k]
+ chars.done <- k
+ }
+ }
+ else {
+ names(Obj)[i] <- Name
+ tsp <- strsplit(Seq, NULL)[[1]]
+ for (k in 1:length(tsp)) {
+ p <- k + pos
+ Obj[[i]][p] <- tsp[k]
+ chars.done <- k
+ }
+ }
+ tot.ntax <- tot.ntax + 1
+ if (tot.ntax == ntax) {
+ i <- 1
+ tot.ntax <- 0
+ tot.nchar <- tot.nchar + chars.done
+ if (tot.nchar == nchar*ntax) {
+ print("ntot was more than nchar*ntax")
+ break
+ }
+ pos <- tot.nchar
+ }
+ else {
+ i <- i + 1
+ }
+ }
+ if (tot.ntax != 0) {
+ cat("ntax:",ntax,"differ from actual number of taxa in file?\n")
+ stop("nexus parser did not read names correctly (tot.ntax!=0)")
+ }
+ for (i in 1:length(Obj)) {
+ if (length(Obj[[i]]) != nchar) {
+ cat(names(Obj[i]),"has",length(Obj[[i]]),"characters\n")
+ stop("nchar differ from sequence length (length(Obj[[i]])!=nchar)")
+ }
+ }
+ Obj <- lapply(Obj, tolower)
+ Obj
+}
+
diff --git a/R/read.tree.R b/R/read.tree.R
new file mode 100644
index 0000000..47a432c
--- /dev/null
+++ b/R/read.tree.R
@@ -0,0 +1,169 @@
+## read.tree.R (2012-09-14)
+
+## Read Tree Files in Parenthetic Format
+
+## Copyright 2002-2012 Emmanuel Paradis, Daniel Lawson and Klaus Schliep
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+tree.build <- function(tp)
+{
+ add.internal <- function() {
+ edge[j, 1] <<- current.node
+ edge[j, 2] <<- current.node <<- node <<- node + 1L
+ index[node] <<- j # set index
+ j <<- j + 1L
+ }
+ add.terminal <- function() {
+ edge[j, 1] <<- current.node
+ edge[j, 2] <<- tip
+ index[tip] <<- j # set index
+ X <- unlist(strsplit(tpc[k], ":"))
+ tip.label[tip] <<- X[1]
+ edge.length[j] <<- as.numeric(X[2])
+ k <<- k + 1L
+ tip <<- tip + 1L
+ j <<- j + 1L
+ }
+ go.down <- function() {
+ l <- index[current.node]
+ X <- unlist(strsplit(tpc[k], ":"))
+ node.label[current.node - nb.tip] <<- X[1]
+ edge.length[l] <<- as.numeric(X[2])
+ k <<- k + 1L
+ current.node <<- edge[l, 1]
+ }
+ if (!length(grep(",", tp))) {
+ obj <- list(edge = matrix(c(2L, 1L), 1, 2))
+ tp <- unlist(strsplit(tp, "[\\(\\):;]"))
+ obj$edge.length <- as.numeric(tp[3])
+ obj$Nnode <- 1L
+ obj$tip.label <- tp[2]
+ if (tp[4] != "") obj$node.label <- tp[4]
+ class(obj) <- "phylo"
+ return(obj)
+ }
+
+ tpc <- unlist(strsplit(tp, "[\\(\\),;]"))
+ tpc <- tpc[nzchar(tpc)]
+ ## the following 2 lines are (slightly) faster than using gsub()
+ tsp <- unlist(strsplit(tp, NULL))
+ skeleton <- tsp[tsp %in% c("(", ")", ",", ";")]
+ nsk <- length(skeleton)
+ nb.node <- sum(skeleton == ")")
+ nb.tip <- sum(skeleton == ",") + 1
+ ## We will assume there is an edge at the root;
+ ## if so, it will be removed and put into a vector
+ nb.edge <- nb.node + nb.tip
+ node.label <- character(nb.node)
+ tip.label <- character(nb.tip)
+
+ edge.length <- numeric(nb.edge)
+ edge <- matrix(0L, nb.edge, 2)
+ current.node <- node <- as.integer(nb.tip + 1) # node number
+ edge[nb.edge, 2] <- node
+ index <- numeric(nb.edge + 1) # hash index to avoid which
+ index[node] <- nb.edge
+
+ ## j: index of the line number of edge
+ ## k: index of the line number of tpc
+ ## tip: tip number
+ j <- k <- tip <- 1L
+
+ for (i in 2:nsk) {
+ if (skeleton[i] == "(") add.internal() # add an internal branch (on top)
+ if (skeleton[i] == ",") {
+ if (skeleton[i - 1] != ")") add.terminal() # add a terminal branch
+ }
+ if (skeleton[i] == ")") {
+ if (skeleton[i - 1] == ",") { # add a terminal branch and go down one level
+ add.terminal()
+ go.down()
+ }
+ if (skeleton[i - 1] == ")") go.down() # go down one level
+ }
+ }
+
+ edge <- edge[-nb.edge, ]
+ obj <- list(edge = edge, Nnode = nb.node, tip.label = tip.label)
+ root.edge <- edge.length[nb.edge]
+ edge.length <- edge.length[-nb.edge]
+ if (!all(is.na(edge.length))) # added 2005-08-18
+ obj$edge.length <- edge.length
+ if (is.na(node.label[1])) node.label[1] <- ""
+ if (any(nzchar(node.label))) obj$node.label <- node.label
+ if (!is.na(root.edge)) obj$root.edge <- root.edge
+ class(obj) <- "phylo"
+ attr(obj, "order") <- "cladewise"
+ obj
+}
+
+read.tree <- function(file = "", text = NULL, tree.names = NULL, skip = 0,
+ comment.char = "#", keep.multi = FALSE, ...)
+{
+ unname <- function(treetext) {
+ nc <- nchar(treetext)
+ tstart <- 1
+ while (substr(treetext, tstart, tstart) != "(" && tstart <= nc)
+ tstart <- tstart + 1
+ if (tstart > 1)
+ return(c(substr(treetext, 1, tstart - 1),
+ substr(treetext, tstart, nc)))
+ return(c("", treetext))
+ }
+ if (!is.null(text)) {
+ if (!is.character(text))
+ stop("argument `text' must be of mode character")
+ tree <- text
+ } else {
+ tree <- scan(file = file, what = "", sep = "\n", quiet = TRUE,
+ skip = skip, comment.char = comment.char, ...)
+ }
+ ## Suggestion from Eric Durand and Nicolas Bortolussi (added 2005-08-17):
+ if (identical(tree, character(0))) {
+ warning("empty character string.")
+ return(NULL)
+ }
+ tree <- gsub("[ \t]", "", tree)
+ tree <- unlist(strsplit(tree, NULL))
+ y <- which(tree == ";")
+ Ntree <- length(y)
+ x <- c(1, y[-Ntree] + 1)
+ ## Suggestion from Olivier Fran�ois (added 2006-07-15):
+ if (is.na(y[1])) return(NULL)
+ STRING <- character(Ntree)
+ for (i in 1:Ntree)
+ STRING[i] <- paste(tree[x[i]:y[i]], sep = "", collapse = "")
+
+ tmp <- unlist(lapply(STRING, unname))
+ tmpnames <- tmp[c(TRUE, FALSE)]
+ STRING <- tmp[c(FALSE, TRUE)]
+ if (is.null(tree.names) && any(nzchar(tmpnames)))
+ tree.names <- tmpnames
+
+ colon <- grep(":", STRING)
+ if (!length(colon)) {
+ obj <- lapply(STRING, clado.build)
+ } else if (length(colon) == Ntree) {
+ obj <- lapply(STRING, tree.build)
+ } else {
+ obj <- vector("list", Ntree)
+ obj[colon] <- lapply(STRING[colon], tree.build)
+ nocolon <- (1:Ntree)[!1:Ntree %in% colon]
+ obj[nocolon] <- lapply(STRING[nocolon], clado.build)
+ }
+ for (i in 1:Ntree) {
+ ## Check here that the root edge is not incorrectly represented
+ ## in the object of class "phylo" by simply checking that there
+ ## is a bifurcation at the root
+ ROOT <- length(obj[[i]]$tip.label) + 1
+ if(sum(obj[[i]]$edge[, 1] == ROOT) == 1 && dim(obj[[i]]$edge)[1] > 1)
+ stop(paste("The tree has apparently singleton node(s): cannot read tree file.\n Reading Newick file aborted at tree no.", i))
+ }
+ if (Ntree == 1 && !keep.multi) obj <- obj[[1]] else {
+ if (!is.null(tree.names)) names(obj) <- tree.names
+ class(obj) <- "multiPhylo"
+ }
+ obj
+}
diff --git a/R/reorder.phylo.R b/R/reorder.phylo.R
new file mode 100644
index 0000000..c820c18
--- /dev/null
+++ b/R/reorder.phylo.R
@@ -0,0 +1,82 @@
+## reorder.phylo.R (2013-09-03)
+
+## Internal Reordering of Trees
+
+## Copyright 2006-2013 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+reorder.phylo <- function(x, order = "cladewise", index.only = FALSE, ...)
+{
+ ORDER <- c("cladewise", "postorder", "pruningwise")
+ io <- pmatch(order, ORDER)
+ if (is.na(io)) stop("ambiguous order")
+ order <- ORDER[io]
+ nb.edge <- dim(x$edge)[1]
+ if (!is.null(attr(x, "order")))
+ if (attr(x, "order") == order)
+ if (index.only) return(1:nb.edge) else return(x)
+ nb.node <- x$Nnode
+ if (nb.node == 1) return(x)
+ nb.tip <- length(x$tip.label)
+
+ ## I'm adding the next check for badly conformed trees to avoid R
+ ## crashing (2013-05-17):
+ if (nb.node >= nb.tip)
+ stop("tree apparently badly conformed")
+
+ if (io == 3) {
+ x <- reorder(x)
+ neworder <-
+ .C(neworder_pruningwise, as.integer(nb.tip),
+ as.integer(nb.node), as.integer(x$edge[, 1]),
+ as.integer(x$edge[, 2]), as.integer(nb.edge),
+ integer(nb.edge))[[6]]
+ } else {
+ neworder <-
+ .C(neworder_phylo, as.integer(nb.tip),
+ as.integer(x$edge[, 1]), as.integer(x$edge[, 2]),
+ as.integer(nb.edge), integer(nb.edge), io,
+ NAOK = TRUE)[[5]]
+ }
+ if (index.only) return(neworder)
+ x$edge <- x$edge[neworder, ]
+ if (!is.null(x$edge.length))
+ x$edge.length <- x$edge.length[neworder]
+ attr(x, "order") <- order
+ x
+}
+
+rotateConstr <- function(phy, constraint)
+{
+ D <- match(phy$tip.label, constraint)
+ n <- Ntip(phy)
+
+ P <- c(as.list(1:n), prop.part(phy))
+ e1 <- phy$edge[, 1L]
+ e2 <- phy$edge[, 2L]
+
+ foo <- function(node) {
+ i <- which(e1 == node) # the edges where 'node' is ancestral
+ desc <- e2[i] # the descendants of 'node'
+ ## below, min() seems to work better than median() which
+ ## seems to work better than mean() which seems to work
+ ## better than sum()
+ o <- order(sapply(desc, function(x) min(D[P[[x]]])))
+ for (k in o) {
+ j <<- j + 1L
+ neworder[j] <<- i[k]
+ if ((dk <- desc[k]) > n) foo(dk)
+ }
+ }
+
+ neworder <- integer(Nedge(phy))
+ j <- 0L
+ foo(n + 1L)
+ phy$edge <- phy$edge[neworder, ]
+ if (!is.null(phy$edge.length))
+ phy$edge.length <- phy$edge.length[neworder]
+ attr(phy, "order") <- "cladewise"
+ phy
+}
diff --git a/R/root.R b/R/root.R
new file mode 100644
index 0000000..9badd2e
--- /dev/null
+++ b/R/root.R
@@ -0,0 +1,342 @@
+## root.R (2013-10-04)
+
+## Root of Phylogenetic Trees
+
+## Copyright 2004-2013 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+is.rooted <- function(phy)
+{
+ if (!inherits(phy, "phylo"))
+ stop('object "phy" is not of class "phylo"')
+ if (!is.null(phy$root.edge)) TRUE
+ else
+ if (tabulate(phy$edge[, 1])[length(phy$tip.label) + 1] > 2)
+ FALSE else TRUE
+}
+
+unroot <- function(phy)
+{
+ if (!inherits(phy, "phylo"))
+ stop('object "phy" is not of class "phylo"')
+ N <- dim(phy$edge)[1]
+ if (N < 3)
+ stop("cannot unroot a tree with less than three edges.")
+
+ ## delete FIRST the root.edge (in case this is sufficient to
+ ## unroot the tree, i.e. there is a multichotomy at the root)
+ if (!is.null(phy$root.edge)) phy$root.edge <- NULL
+ if (!is.rooted(phy)) return(phy)
+
+ n <- length(phy$tip.label)
+ ROOT <- n + 1L
+
+### EDGEROOT[1]: the edge to delete
+### EDGEROOT[2]: the target where to stick the edge to delete
+
+### If the tree is in pruningwise (or postorder) order, then
+### the last two edges are those connected to the root; the node
+### situated in phy$edge[N - 2L, 1L] will be the new root...
+
+ ophy <- attr(phy, "order")
+ if (!is.null(ophy) && ophy != "cladewise") {
+ NEWROOT <- phy$edge[N - 2L, 1L]
+ EDGEROOT <- c(N, N - 1L)
+ } else {
+
+### ... otherwise, we remove one of the edges coming from
+### the root, and eventually adding the branch length to
+### the other one also coming from the root.
+### In all cases, the node deleted is the 2nd one (numbered
+### nb.tip+2 in 'edge'), so we simply need to renumber the
+### nodes by adding 1, except the root (this remains the
+### origin of the tree).
+
+ EDGEROOT <- which(phy$edge[, 1L] == ROOT)
+ NEWROOT <- ROOT + 1L
+ }
+
+ ## make sure EDGEROOT is ordered as described above:
+ if (phy$edge[EDGEROOT[1L], 2L] != NEWROOT)
+ EDGEROOT <- EDGEROOT[2:1]
+
+ phy$edge <- phy$edge[-EDGEROOT[1L], ]
+
+ s <- phy$edge == NEWROOT # renumber the new root
+ phy$edge[s] <- ROOT
+
+ s <- phy$edge > NEWROOT # renumber all nodes greater than the new root
+ phy$edge[s] <- phy$edge[s] - 1L
+
+ if (!is.null(phy$edge.length)) {
+ phy$edge.length[EDGEROOT[2L]] <-
+ phy$edge.length[EDGEROOT[2L]] + phy$edge.length[EDGEROOT[1L]]
+ phy$edge.length <- phy$edge.length[-EDGEROOT[1L]]
+ }
+
+ phy$Nnode <- phy$Nnode - 1L
+
+ if (!is.null(phy$node.label)) {
+ if (NEWROOT == n + 2L)
+ phy$node.label <- phy$node.label[-1]
+ else {
+ lbs <- phy$node.label
+ tmp <- lbs[NEWROOT - n]
+ lbs <- lbs[-c(1, NEWROOT)]
+ phy$node.label <- c(tmp, lbs)
+ }
+ }
+ phy
+}
+
+root <- function(phy, outgroup, node = NULL,
+ resolve.root = FALSE, interactive = FALSE)
+{
+ if (!inherits(phy, "phylo"))
+ stop('object "phy" is not of class "phylo"')
+ phy <- reorder(phy)
+ n <- length(phy$tip.label)
+ ROOT <- n + 1L
+ if (interactive) {
+ node <- identify(phy)$nodes
+ cat("You have set resolve.root =", resolve.root, "\n")
+ }
+ if (!is.null(node)) {
+ if (node <= n)
+ stop("incorrect node#: should be greater than the number of taxa")
+ outgroup <- NULL
+ newroot <- node
+ } else {
+ if (is.numeric(outgroup)) {
+ if (any(outgroup > n))
+ stop("incorrect taxa#: should not be greater than the number of taxa")
+ outgroup <- sort(outgroup) # used below
+ }
+ if (is.character(outgroup))
+ outgroup <- which(phy$tip.label %in% outgroup)
+ if (length(outgroup) == n) return(phy)
+
+ ## First check that the outgroup is monophyletic--
+ ## unless there's only one tip specified of course
+ if (length(outgroup) > 1) {
+ pp <- prop.part(phy)
+ ingroup <- (1:n)[-outgroup]
+ newroot <- 0L
+ for (i in 2:phy$Nnode) {
+ if (identical(pp[[i]], ingroup)) {
+ ## inverted with the next if (... (2013-06-16)
+ newroot <- phy$edge[which(phy$edge[, 2] == i + n), 1]
+ break
+ }
+ if (identical(pp[[i]], outgroup)) {
+ newroot <- i + n
+ break
+ }
+ }
+ if (!newroot)
+ stop("the specified outgroup is not monophyletic")
+ } else newroot <- phy$edge[which(phy$edge[, 2] == outgroup), 1]
+ }
+ N <- Nedge(phy)
+ oldNnode <- phy$Nnode
+ if (newroot == ROOT) {
+ ## assumes length(outgroup) == 1
+ if (resolve.root) {
+ snw <- which(phy$edge[, 1L] == newroot)
+ if (length(snw) > 2) {
+ i <- which(phy$edge[, 2L] == outgroup) # see comment above
+ j <- snw[snw != i]
+ newnod <- oldNnode + n + 1L
+ phy$edge[j, 1] <- newnod
+
+ ## put the row with the outgroup as the last one in 'edge':
+ if (i != N) {
+ no <- 1:N
+ no <- c(no[-i], i)
+ phy$edge <- phy$edge[no, ]
+ if (!is.null(phy$edge.length))
+ phy$edge.length <- phy$edge.length[no]
+ }
+
+ phy$edge <- rbind(c(ROOT, newnod), phy$edge)
+ if (!is.null(phy$edge.length))
+ phy$edge.length <- c(0, phy$edge.length)
+
+ phy$Nnode <- phy$Nnode + 1L
+ ## node renumbering (see comments below)
+ newNb <- integer(n + oldNnode)
+ newNb[newroot] <- n + 1L
+ sndcol <- phy$edge[, 2] > n
+ phy$edge[sndcol, 2] <- newNb[phy$edge[sndcol, 2]] <- n + 2:phy$Nnode
+ phy$edge[, 1] <- newNb[phy$edge[, 1]]
+ }
+ }
+ return(phy)
+ }
+
+ phy$root.edge <- NULL # just in case...
+ Nclade <- tabulate(phy$edge[, 1])[ROOT] # degree of the root node
+ ## if only 2 edges connect to the root, we have to fuse them:
+ fuseRoot <- Nclade == 2
+
+ start <- which(phy$edge[, 1] == ROOT)
+ end <- c(start[-1] - 1, N)
+ o <- integer(N)
+ INV <- logical(N)
+
+ w <- which(phy$edge[, 2] == newroot)
+ nod <- phy$edge[w, 1]
+ i <- w
+ NEXT <- 1L
+
+ ## The loop below starts from the new root and goes up in the edge
+ ## matrix reversing the edges that need to be as well as well
+ ## inverting their order. The other edges must not be changed, so
+ ## their indices are stored in `stack'.
+ ## We then bind the other edges in a straightforward way.
+
+ if (nod != ROOT) {
+ ## it is important that the 3 next lines
+ ## are inside this "if" statement
+ o[NEXT] <- w
+ NEXT <- NEXT + 1L
+ INV[w] <- TRUE
+ i <- w - 1L
+ stack <- 0L
+ repeat {
+ if (phy$edge[i, 2] == nod) {
+ if (stack) {
+ o[NEXT:(NEXT + stack - 1L)] <- i + 1:stack
+ NEXT <- NEXT + stack
+ stack <- 0L
+ }
+ if (phy$edge[i, 1] == ROOT) break
+ o[NEXT] <- i
+ NEXT <- NEXT + 1L
+ INV[i] <- TRUE
+ nod <- phy$edge[i, 1]
+ } else stack <- stack + 1L
+ i <- i - 1L
+ }
+ }
+
+ ## we keep the edge leading to the old root if needed:
+ if (!fuseRoot) {
+ o[NEXT] <- i
+ INV[i] <- TRUE
+ NEXT <- NEXT + 1L
+ }
+
+ endOfOutgroup <- which(phy$edge[(w+1):N, 1] < newroot)[1] + w - 1
+ if (is.na(endOfOutgroup)) endOfOutgroup <- N
+ endOfClade <- end[end >= endOfOutgroup][1]
+
+ ## bind the other clades...
+ for (j in 1:Nclade) {
+ if (end[j] == endOfClade) next
+ ## do we have to fuse the two basal edges?
+ if (fuseRoot) {
+ phy$edge[start[j], 1] <- phy$edge[i, 2]
+ if (!is.null(phy$edge.length))
+ phy$edge.length[start[j]] <- phy$edge.length[start[j]] + phy$edge.length[i]
+ } #else {
+ # o[NEXT] <- i#start[j]
+ # NEXT <- NEXT + 1L
+ #}
+ s <- start[j]:end[j]
+ ne <- length(s)
+ o[NEXT:(NEXT + ne - 1L)] <- s
+ NEXT <- NEXT + ne
+ }
+
+ ## possibly bind the edges below the outgroup till the end of the clade
+ if (all(endOfOutgroup != end)) {
+ j <- (endOfOutgroup + 1L):endOfClade
+ ## we must take care that the branch inversions done above
+ ## may have changed the hierarchy of clades here, so we
+ ## travel from the bottom of this series of edges
+ stack <- 0L
+ inverted <- phy$edge[INV, 1] # <- fails if ', 2]' is used
+ for (k in rev(j)) {
+ if (any(phy$edge[k, 1] == inverted)) {
+ o[NEXT] <- k
+ NEXT <- NEXT + 1L
+ if (stack){
+ o[NEXT:(NEXT + stack - 1L)] <- (k + 1L):(k + stack)
+ NEXT <- NEXT + stack
+ stack <- 0L
+ }
+ } else stack <- stack + 1L
+ }
+ }
+
+ ## ... and the outgroup
+ s <- (w + 1L):endOfOutgroup
+ ne <- length(s)
+ o[NEXT:(NEXT + ne - 1L)] <- s
+
+ if (fuseRoot) {
+ phy$Nnode <- oldNnode - 1L
+ N <- N - 1L
+ }
+ phy$edge[INV, ] <- phy$edge[INV, 2:1]
+ phy$edge <- phy$edge[o, ]
+ if (!is.null(phy$edge.length))
+ phy$edge.length <- phy$edge.length[o]
+
+ if (resolve.root) {
+ newnod <- oldNnode + n + 1
+ if (length(outgroup) == 1L) {
+ wh <- which(phy$edge[, 2] == outgroup)
+ phy$edge[1] <- newnod
+ phy$edge <-
+ rbind(c(newroot, newnod), phy$edge[-wh, ], phy$edge[wh, ])
+ snw <- which(phy$edge[, 1] == newroot)
+ phy$edge[snw[length(snw) - 1], 1] <- newnod
+ if (!is.null(phy$edge.length)) {
+ phy$edge.length <-
+ c(0, phy$edge.length[-wh], phy$edge.length[wh])
+ }
+ } else {
+ wh <- which(phy$edge[, 1] == newroot)
+ phy$edge[wh[-1], 1] <- newnod
+ s1 <- 1:(wh[2] - 1)
+ s2 <- wh[2]:N
+ phy$edge <-
+ rbind(phy$edge[s1, ], c(newroot, newnod), phy$edge[s2, ])
+ if (!is.null(phy$edge.length)) {
+ phy$edge.length <-
+ c(phy$edge.length[s1], 0, phy$edge.length[s2])
+ }
+ }
+ ## N <- N + 1L ... not needed
+ phy$Nnode <- phy$Nnode + 1L
+ }
+
+ ## The block below renumbers the nodes so that they conform
+ ## to the "phylo" format
+ newNb <- integer(n + oldNnode)
+ newNb[newroot] <- n + 1L
+ sndcol <- phy$edge[, 2] > n
+ ## executed from right to left, so newNb is modified before phy$edge:
+ phy$edge[sndcol, 2] <- newNb[phy$edge[sndcol, 2]] <- n + 2:phy$Nnode
+ phy$edge[, 1] <- newNb[phy$edge[, 1]]
+
+ if (!is.null(phy$node.label)) {
+ newNb <- newNb[-(1:n)]
+ if (fuseRoot) {
+ newNb <- newNb[-1]
+ phy$node.label <- phy$node.label[-1]
+ }
+ phy$node.label <- phy$node.label[order(newNb)]
+ if (resolve.root) {
+ phy$node.label[is.na(phy$node.label)] <- phy$node.label[1]
+ phy$node.label[1] <- "Root"
+ ##phy$node.label <- c(phy$node.label[1], NA, phy$node.label[-1])
+ ##phy$node.label <- c("NA", phy$node.label)
+ }
+ }
+ phy
+}
diff --git a/R/rotate.R b/R/rotate.R
new file mode 100644
index 0000000..2ea8480
--- /dev/null
+++ b/R/rotate.R
@@ -0,0 +1,126 @@
+### ROTATE
+### Last update CH on 09.08.2007 (updated by EP 2011-06-14)
+
+# Contents:
+# 1. rotate
+
+# 1: This function swops sister clades in a phylogenetic tree.
+# Branch lengths are considered.
+# Arguments:
+# phy: an object of class phylo
+# node: the number (integer) of the corresponding node or number or names of two tips that coalesce to th internal node
+# polytom: use a vector of two integers to define those two clades of a tritomy, that are swopped. The default is c(1,2). The clade number is counted from the from bottom to top in the plotted tree.
+# Author: C.Heibl
+
+
+rotate <- function(phy, node, polytom = c(1,2)){
+ # load DESCENDANTS function
+ DESCENDANTS <- function(tree, node){
+ tips <- length(tree$tip.label)
+ x <- tree$edge[,2][tree$edge[,1] == node]
+ while(max(x) > tips){
+ x <- x[x > tips]
+ for(h in 1:length(x)) tree$edge <- tree$edge[!tree$edge[,2] == x[h],]
+ for(i in 1:length(x)) tree$edge[,1][tree$edge[,1] == x[i]] <- node
+ x <- tree$edge[,2][tree$edge[,1] == node]
+ }
+ x
+ }
+# function starts here
+# definitions
+ if (!inherits(phy, "phylo")) # is phy of class phylo?
+ stop("object \"phy\" is not of class \"phylo\"")
+ nb.tips <- length(phy$tip.label) # number of tiplabels
+ max.int.node <- phy$Nnode+nb.tips # number of last internal node
+ nb.edges <- dim(phy$edge)[1] # number of branches
+ if (length(node) == 2){ # get MRCA if tips are given for node
+ if (mode(node) == "character"){
+ if (any(!node %in% phy$tip.label)) # do tiplabels correspond
+ stop("object \"node\" contains tiplabels not present in object \"phy\"")
+ tips <- cbind(phy$tip.label, 1:nb.tips)
+ node[1] <- tips[,2][tips[,1] == node[1]]
+ node[2] <- tips[,2][tips[,1] == node[2]]
+ node <- as.numeric(node)
+ }
+ if (any(!node %in% 1:nb.tips)) # is phy of class phylo?
+ stop("object \"node\" does not contain terminal nodes")
+ node <- getMRCA(phy, node)
+ }
+ if (node <= nb.tips || node > max.int.node) # is node really internal?
+ stop("object \"node\" is not an internal node of object \"phy\"")
+ with.br.length <- !is.null(phy$edge.length) # does phy contain brlength?
+ G <- cbind(phy$edge, 1:(length(phy$edge)/2))
+ N <- phy$edge[phy$edge[,1] == node]
+ N <- N[N != node]
+ if (length(N) > 2) N <- N[polytom]
+ CLADE1 <- N[1]
+ CLADE2 <- N[2]
+# do clades comprise interior nodes?
+ if (CLADE1 > nb.tips) CLADE11 <- DESCENDANTS(phy, CLADE1)
+ if (CLADE2 > nb.tips) CLADE22 <- DESCENDANTS(phy, CLADE2)
+# calculate inidices of clades in phy.edge
+ if (CLADE1 > nb.tips){
+ c1 <- G[,3][G[,2] == CLADE1]
+ c2 <- G[,3][G[,2] == max(CLADE11)]
+ } else {
+ c1 <- G[,3][G[,2] == CLADE1]
+ c2 <- G[,3][G[,2] == CLADE1]
+ }
+ if (CLADE2 > nb.tips){
+ c3 <- G[,3][G[,2] == CLADE2]
+ c4 <- G[,3][G[,2] == max(CLADE22)]
+ } else {
+ c3 <- G[,3][G[,2] == CLADE2]
+ c4 <- G[,3][G[,2] == CLADE2]
+ }
+
+# create new phy$edge and phy$edge.length
+if (c2+1 == c3){
+ if (c1 == 1 && c4 != nb.edges){
+ phy$edge <- rbind(phy$edge[c3:c4,], phy$edge[c1:c2,], phy$edge[(c4+1):nb.edges,])
+ if (with.br.length)
+ phy$edge.length <- c(phy$edge.length[c3:c4], phy$edge.length[c1:c2], phy$edge.length[(c4+1):nb.edges])
+ }
+ if (c1 !=1 && c4 == nb.edges){
+ phy$edge <- rbind(phy$edge[1:(c1-1),], phy$edge[c3:c4,], phy$edge[c1:c2,])
+ if (with.br.length)
+ phy$edge.length <- c(phy$edge.length[1:(c1-1)], phy$edge.length[c3:c4], phy$edge.length[c1:c2])
+ }
+ if (c1 !=1 && c4 != nb.edges){
+ phy$edge <- rbind(phy$edge[1:(c1-1),], phy$edge[c3:c4,], phy$edge[c1:c2,], phy$edge[(c4+1):nb.edges,])
+ if (with.br.length)
+ phy$edge.length <- c(phy$edge.length[1:(c1-1)], phy$edge.length[c3:c4], phy$edge.length[c1:c2], phy$edge.length[(c4+1):nb.edges])
+ }
+ if (c1 ==1 && c4 == nb.edges){
+ phy$edge <- rbind(phy$edge[c3:c4,], phy$edge[c1:c2,])
+ if (with.br.length)
+ phy$edge.length <- c(phy$edge.length[c3:c4], phy$edge.length[c1:c2])
+ }
+ }
+else {
+ if (c1 == 1 && c4 != nb.edges){
+ phy$edge <- rbind(phy$edge[c3:c4,], phy$edge[(c2+1):(c3-1),], phy$edge[c1:c2,], phy$edge[(c4+1):nb.edges,])
+ if (with.br.length)
+ phy$edge.length <- c(phy$edge.length[c3:c4], phy$edge.length[(c2+1):(c3-1)], phy$edge.length[c1:c2], phy$edge.length[(c4+1):nb.edges])
+ }
+ if (c1 !=1 && c4 == nb.edges){
+ phy$edge <- rbind(phy$edge[1:(c1-1),], phy$edge[c3:c4,], phy$edge[(c2+1):(c3-1),], phy$edge[c1:c2,])
+ if (with.br.length)
+ phy$edge.length <- c(phy$edge.length[1:(c1-1)], phy$edge.length[c3:c4], phy$edge.length[(c2+1):(c3-1)], phy$edge.length[c1:c2])
+ }
+ if (c1 !=1 && c4 != nb.edges){
+ phy$edge <- rbind(phy$edge[1:(c1-1),], phy$edge[c3:c4,], phy$edge[(c2+1):(c3-1),], phy$edge[c1:c2,], phy$edge[(c4+1):nb.edges,])
+ if (with.br.length)
+ phy$edge.length <- c(phy$edge.length[1:(c1-1)], phy$edge.length[c3:c4], phy$edge.length[(c2+1):(c3-1)], phy$edge.length[c1:c2], phy$edge.length[(c4+1):nb.edges])
+ }
+ if (c1 ==1 && c4 == nb.edges){
+ phy$edge <- rbind(phy$edge[c3:c4,], phy$edge[(c2+1):(c3-1),], phy$edge[c1:c2,])
+ if (with.br.length)
+ phy$edge.length <- c(phy$edge.length[c3:c4], phy$edge.length[(c2+1):(c3-1)], phy$edge.length[c1:c2])
+ }
+ }
+ ## deleted by EP (2011-06-14):
+ ## S <- write.tree(phy)
+ ## phy <- if (!with.br.length) clado.build(S) else tree.build(S)
+ phy
+ }
diff --git a/R/rtree.R b/R/rtree.R
new file mode 100644
index 0000000..b2a48b4
--- /dev/null
+++ b/R/rtree.R
@@ -0,0 +1,213 @@
+## rtree.R (2013-04-02)
+
+## Generates Trees
+
+## Copyright 2004-2013 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+rtree <- function(n, rooted = TRUE, tip.label = NULL, br = runif, ...)
+{
+ foo <- function(n, pos) {
+ n1 <- sample.int(n - 1, 1, FALSE, NULL)
+ n2 <- n - n1
+ po2 <- pos + 2*n1 - 1
+ edge[c(pos, po2), 1] <<- nod
+ nod <<- nod + 1L
+ if (n1 > 2) {
+ edge[pos, 2] <<- nod
+ foo(n1, pos + 1)
+ } else if (n1 == 2) {
+ edge[c(pos + 1, pos + 2), 1] <<- edge[pos, 2] <<- nod
+ nod <<- nod + 1L
+ }
+ if (n2 > 2) {
+ edge[po2, 2] <<- nod
+ foo(n2, po2 + 1)
+ } else if (n2 == 2) {
+ edge[c(po2 + 1, po2 + 2), 1] <<- edge[po2, 2] <<- nod
+ nod <<- nod + 1L
+ }
+ }
+
+ if (n < 2) stop("a tree must have at least 2 tips.")
+ nbr <- 2 * n - 3 + rooted
+ edge <- matrix(NA, nbr, 2)
+
+ n <- as.integer(n)
+ if (n == 2) {
+ if (rooted) edge[] <- c(3L, 3L, 1L, 2L)
+ else stop("an unrooted tree must have at least 3 tips.")
+ } else if (n == 3) {
+ edge[] <-
+ if (rooted) c(4L, 5L, 5L, 4L, 5L, 1:3)
+ else c(4L, 4L, 4L, 1:3)
+ } else if (n == 4 && !rooted) {
+ edge[] <- c(5L, 6L, 6L, 5L, 5L, 6L, 1:4)
+ } else {
+ nod <- n + 1L
+ if (rooted) { # n > 3
+ foo(n, 1)
+ ## The following is slightly more efficient than affecting the
+ ## tip numbers in foo(): the gain is 0.006 s for n = 1000.
+ i <- which(is.na(edge[, 2]))
+ edge[i, 2] <- 1:n
+ } else { # n > 4
+ n1 <- sample.int(n - 2L, 1L)
+ if (n1 == n - 2L) {
+ n2 <- n3 <- 1L
+ } else {
+ n2 <- sample.int(n - n1 - 1L, 1L)
+ n3 <- n - n1 - n2
+ }
+ po2 <- 2L * n1
+ po3 <- 2L * (n1 + n2) - 1L
+ edge[c(1, po2, po3), 1L] <- nod
+ nod <- nod + 1L
+ if (n1 > 2L) {
+ edge[1L, 2L] <- nod
+ foo(n1, 2L)
+ } else if (n1 == 2L) {
+ edge[2:3, 1L] <- edge[1L, 2L] <- nod
+ nod <- nod + 1L
+ }
+ if (n2 > 2L) {
+ edge[po2, 2L] <- nod
+ foo(n2, po2 + 1L)
+ } else if (n2 == 2L) {
+ edge[c(po2 + 1L, po2 + 2), 1L] <- edge[po2, 2L] <- nod
+ nod <- nod + 1L
+ }
+ if (n3 > 2) {
+ edge[po3, 2L] <- nod
+ foo(n3, po3 + 1L)
+ } else if (n3 == 2L) {
+ edge[c(po3 + 1L, po3 + 2), 1L] <- edge[po3, 2L] <- nod
+ ## nod <- nod + 1L
+ }
+ i <- which(is.na(edge[, 2L]))
+ edge[i, 2] <- 1:n
+ }
+ }
+ phy <- list(edge = edge)
+ phy$tip.label <-
+ if (is.null(tip.label)) paste("t", sample(n), sep = "")
+ else sample(tip.label)
+ if (!is.null(br)) {
+ phy$edge.length <-
+ if (is.function(br)) br(nbr, ...) else rep(br, length.out = nbr)
+ }
+ phy$Nnode <- n - 2L + rooted
+ class(phy) <- "phylo"
+ attr(phy, "order") <- "cladewise"
+ phy
+}
+
+rcoal <- function(n, tip.label = NULL, br = "coalescent", ...)
+{
+ n <- as.integer(n)
+ nbr <- 2*n - 2
+ edge <- matrix(NA, nbr, 2)
+ ## coalescence times by default:
+ x <- if (is.character(br)) 2*rexp(n - 1)/(as.double(n:2) * as.double((n - 1):1))
+ else if (is.numeric(br)) rep(br, length.out = n - 1) else br(n - 1, ...)
+ if (n == 2) {
+ edge[] <- c(3L, 3L, 1:2)
+ edge.length <- rep(x, 2)
+ } else if (n == 3) {
+ edge[] <- c(4L, 5L, 5L, 4L, 5L, 1:3)
+ edge.length <- c(x[c(2, 1, 1)], sum(x))
+ } else {
+ edge.length <- numeric(nbr)
+ h <- numeric(2*n - 1)
+ node.height <- cumsum(x)
+ pool <- 1:n
+ nextnode <- 2L*n - 1L
+ for (i in 1:(n - 1)) {
+ y <- sample(pool, size = 2)
+ ind <- (i - 1)*2 + 1:2
+ edge[ind, 2] <- y
+ edge[ind, 1] <- nextnode
+ edge.length[ind] <- node.height[i] - h[y]
+ h[nextnode] <- node.height[i]
+ pool <- c(pool[! pool %in% y], nextnode)
+ nextnode <- nextnode - 1L
+ }
+ }
+ phy <- list(edge = edge, edge.length = edge.length)
+ if (is.null(tip.label))
+ tip.label <- paste("t", 1:n, sep = "")
+ phy$tip.label <- sample(tip.label)
+ phy$Nnode <- n - 1L
+ class(phy) <- "phylo"
+ phy <- reorder(phy)
+ ## to avoid crossings when converting with as.hclust:
+ phy$edge[phy$edge[, 2] <= n, 2] <- 1:n
+ phy
+}
+
+rmtree <- function(N, n, rooted = TRUE, tip.label = NULL, br = runif, ...)
+{
+ a <- replicate(N, rtree(n, rooted = rooted, tip.label = tip.label,
+ br = br, ...), simplify = FALSE)
+ class(a) <- "multiPhylo"
+ a
+}
+
+stree <- function(n, type = "star", tip.label = NULL)
+{
+ type <- match.arg(type, c("star", "balanced", "left", "right"))
+ n <- as.integer(n)
+ if (type == "star") {
+ N <- n
+ m <- 1L
+ } else {
+ m <- n - 1L
+ N <- n + m - 1L
+ }
+ edge <- matrix(0L, N, 2)
+
+ switch(type, "star" = {
+ edge[, 1] <- n + 1L
+ edge[, 2] <- 1:n
+ }, "balanced" = {
+ if (log2(n) %% 1)
+ stop("'n' is not a power of 2: cannot make a balanced tree")
+ foo <- function(node, size) {
+ if (size == 2) {
+ edge[c(i, i + 1L), 1L] <<- node
+ edge[c(i, i + 1L), 2L] <<- c(nexttip, nexttip + 1L)
+ nexttip <<- nexttip + 2L
+ i <<- i + 2L
+ } else {
+ for (k in 1:2) { # do the 2 subclades
+ edge[i, ] <<- c(node, nextnode)
+ nextnode <<- nextnode + 1L
+ i <<- i + 1L
+ foo(nextnode - 1L, size/2)
+ }
+ }
+ }
+ i <- 1L
+ nexttip <- 1L
+ nextnode <- n + 2L
+ foo(n + 1L, n)
+ }, "left" = {
+ edge[c(seq.int(from = 1, to = N - 1, by = 2), N), 2L] <- 1:n
+ nodes <- (n + 1L):(n + m)
+ edge[seq.int(from = 2, to = N - 1, by = 2), 2L] <- nodes[-1]
+ edge[, 1L] <- rep(nodes, each = 2)
+ }, "right" = {
+ nodes <- (n + 1L):(n + m)
+ edge[, 1L] <- c(nodes, rev(nodes))
+ edge[, 2L] <- c(nodes[-1], 1:n)
+ })
+
+ if (is.null(tip.label))
+ tip.label <- paste("t", 1:n, sep = "")
+ phy <- list(edge = edge, tip.label = tip.label, Nnode = m)
+ class(phy) <- "phylo"
+ attr(phy, "order") <- "cladewise"
+ phy
+}
diff --git a/R/scales.R b/R/scales.R
new file mode 100644
index 0000000..fc43a6b
--- /dev/null
+++ b/R/scales.R
@@ -0,0 +1,130 @@
+## scales.R (2013-12-20)
+
+## Add a Scale Bar or Axis to a Phylogeny Plot
+
+## add.scale.bar: add a scale bar to a phylogeny plot
+## axisPhylo: add a scale axis on the side of a phylogeny plot
+
+## Copyright 2002-2013 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+add.scale.bar <- function(x, y, length = NULL, ask = FALSE,
+ lwd = 1, lcol = "black", ...)
+{
+ lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv)
+ direc <- lastPP$direction
+ if (is.null(length)) {
+ nb.digit <-
+ if (direc %in% c("rightwards", "leftwards")) diff(range(lastPP$xx))
+ else diff(range(lastPP$yy))
+ length <- pretty(c(0, nb.digit) / 6, 1)[2] # by Klaus
+ }
+
+ if (ask) {
+ cat("\nClick where you want to draw the bar\n")
+ x <- unlist(locator(1))
+ y <- x[2]
+ x <- x[1]
+ } else if (missing(x) || missing(y)) {
+ if (lastPP$type %in% c("phylogram", "cladogram")) {
+ switch(direc,
+ "rightwards" = {
+ x <- 0
+ y <- 1
+ },
+ "leftwards" = {
+ x <- max(lastPP$xx)
+ y <- 1
+ },
+ "upwards" = {
+ x <- max(lastPP$xx)
+ y <- 0
+ },
+ "downwards" = {
+ x <- 1
+ y <- max(lastPP$yy)
+ })
+ } else {
+ direc <- "rightwards" # just to be sure for below
+ x <- lastPP$x.lim[1]
+ y <- lastPP$y.lim[1]
+ }
+ }
+
+ switch(direc,
+ "rightwards" = {
+ segments(x, y, x + length, y, col = lcol, lwd = lwd)
+ text(x + length * 1.1, y, as.character(length), adj = c(0, 0.5), ...)
+ },
+ "leftwards" = {
+ segments(x - length, y, x, y, col = lcol, lwd = lwd)
+ text(x - length * 1.1, y, as.character(length), adj = c(1, 0.5), ...)
+ },
+ "upwards" = {
+ segments(x, y, x, y + length, col = lcol, lwd = lwd)
+ text(x, y + length * 1.1, as.character(length), adj = c(0, 0.5), srt = 90, ...)
+ },
+ "downwards" = {
+ segments(x, y - length, x, y, col = lcol, lwd = lwd)
+ text(x, y - length * 1.1, as.character(length), adj = c(0, 0.5), srt = 270, ...)
+ })
+}
+
+axisPhylo <- function(side = 1, ...)
+{
+ lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv)
+ type <- lastPP$type
+
+ if (type == "unrooted")
+ stop("axisPhylo() not available for unrooted plots; try add.scale.bar()")
+ if (type == "radial")
+ stop("axisPhylo() not meaningful for this type of plot")
+
+ if (type %in% c("phylogram", "cladogram")) {
+ if (lastPP$direction %in% c("rightwards", "leftwards")) {
+ x <- pretty(lastPP$xx)
+ if (lastPP$direction == "rightwards") maxi <- max(lastPP$xx)
+ else {
+ maxi <- min(lastPP$xx)
+ x <- -x
+ }
+ } else {
+ x <- pretty(lastPP$yy)
+ if (lastPP$direction == "upwards") maxi <- max(lastPP$yy)
+ else {
+ maxi <- min(lastPP$yy)
+ x <- -x
+ }
+ }
+ axis(side = side, at = c(maxi - x), labels = abs(x), ...)
+ } else { # type == "fan"
+ n <- lastPP$Ntip
+ xx <- lastPP$xx[1:n]; yy <- lastPP$yy[1:n]
+ r0 <- max(sqrt(xx^2 + yy^2))
+ firstandlast <- c(1, n)
+ theta0 <- mean(atan2(yy[firstandlast], xx[firstandlast]))
+ x0 <- r0 * cos(theta0); y0 <- r0 * sin(theta0)
+ inc <- diff(pretty(c(0, r0))[1:2])
+ srt <- 360*theta0/(2*pi)
+ coef <- -1
+ if (abs(srt) > 90) {
+ srt <- srt + 180
+ coef <- 1
+ }
+ len <- 0.025 * r0 # the length of tick marks
+ r <- r0
+ while (r > 1e-8) {
+ x <- r * cos(theta0); y <- r * sin(theta0)
+ if (len/r < 1) {
+ ra <- sqrt(len^2 + r^2); thetaa <- theta0 + coef * asin(len/r)
+ xa <- ra * cos(thetaa); ya <- ra * sin(thetaa)
+ segments(xa, ya, x, y)
+ text(xa, ya, r0 - r, srt = srt, adj = c(0.5, 1.1), ...)
+ }
+ r <- r - inc
+ }
+ segments(x, y, x0, y0)
+ }
+}
diff --git a/R/skyline.R b/R/skyline.R
new file mode 100644
index 0000000..34484db
--- /dev/null
+++ b/R/skyline.R
@@ -0,0 +1,149 @@
+## skyline.R (2002-09-12)
+
+## Methods to construct skyline objects (data underlying skyline plot)
+
+## Copyright 2002 Korbinian Strimmer
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+skyline <- function(x, ...) UseMethod("skyline")
+
+# input: phylogenetic tree
+skyline.phylo <- function(x, ...)
+{
+ if (class(x) != "phylo")
+ stop("object \"x\" is not of class \"phylo\"")
+
+ skyline(coalescent.intervals(x), ...)
+}
+
+# input: coalescent intervals and epsilon
+skyline.coalescentIntervals <- function(x, epsilon=0, ...)
+{
+ if (class(x) != "coalescentIntervals")
+ stop("object \"x\" is not of class \"coalescentIntervals\"")
+
+ if (epsilon < 0)
+ {
+ eps <- find.skyline.epsilon(x, ...)
+ }
+ else
+ eps <- epsilon
+
+ skyline(collapsed.intervals(x, epsilon=eps), ...)
+}
+
+
+# input: collapsed intervals
+skyline.collapsedIntervals <- function(x, old.style=FALSE, ...)
+{
+ if (class(x) != "collapsedIntervals")
+ stop("object \"x\" is not of class \"collapsedIntervals\"")
+
+ link <- x$collapsed.interval
+ params <- x$collapsed.interval.count
+ l <- x$lineages
+ w <- x$interval.length
+
+ b <- choose(l,2) # binomial coefficients
+
+ sg <- rep(0,params) # sizes of collapsed intervals
+ cg <- rep(0,params) # coalescent events in interval
+
+ if(old.style)
+ ng <- rep(0,params) # lineages at beginning of an in interval
+ else
+ {
+ ng <- rep(0,params) # sum of classic skp estimates in an interval
+ m.classic <- w*b
+ }
+
+ for (i in 1:params)
+ {
+ group <- link==i
+ sgr <- w[group]
+ sg[[i]] <- sum(sgr)
+ cg[[i]] <- length(sgr)
+
+ if(old.style)
+ ng[[i]] <- l[group][[1]]
+ else
+ ng[[i]] <- sum(m.classic[group])
+ }
+
+ # generalized skp estimate
+ t <- cumsum(sg)
+ if (old.style)
+ m <- sg*(ng*(ng-cg)/(2.0*cg) )
+ else
+ m <- ng/cg
+
+ # log-likelihood
+ logL <- sum(log(b/m[link]) - b/m[link]*w)
+
+ # AICc corrected log-likelihood
+ K <- x$collapsed.interval.count
+ S <- x$interval.count
+ if (S-K > 1)
+ logL.AICc <- logL - K- K*(K+1)/(S-K-1)
+ else
+ logL.AICc <- NA
+
+ obj <- list(
+ time=t,
+ interval.length=sg,
+ population.size=m,
+ parameter.count=length(t),
+ epsilon = x$epsilon,
+ logL = logL,
+ logL.AICc = logL.AICc
+ )
+ class(obj) <- "skyline"
+ return(obj)
+}
+
+# grid search for finding optimal epsilon parameter
+find.skyline.epsilon <- function(ci, GRID=1000, MINEPS=1e-6, ...)
+{
+ # Why MINEPS?
+ # Because most "clock-like" trees are not properly
+ # clock-like for a variety of reasons, i.e. the heights
+ # of the tips are not exactly zero.
+
+ cat("Searching for the optimal epsilon... ")
+
+ # a grid search is a naive way but still effective of doing this ...
+
+ size <- ci$interval.count
+ besteps <- ci$total.depth
+ eps <- besteps
+
+ cli <- collapsed.intervals(ci,eps)
+ skpk <- skyline(cli, ...)
+ bestaicc <- skpk$ logL.AICc
+ params <- skpk$parameter.count
+
+ delta <- besteps/GRID
+
+ eps <- eps-delta
+ while(eps > MINEPS)
+ {
+ cli <- collapsed.intervals(ci,eps)
+ skpk <- skyline(cli, ...)
+ aicc <- skpk$ logL.AICc
+ params <- skpk$parameter.count
+
+ if (aicc > bestaicc && params < size-1)
+ {
+ besteps <- eps
+ bestaicc <- aicc
+ }
+ eps <- eps-delta
+ }
+
+ cat("epsilon =", besteps, "\n")
+
+ besteps
+}
+
diff --git a/R/skylineplot.R b/R/skylineplot.R
new file mode 100644
index 0000000..b54e1d0
--- /dev/null
+++ b/R/skylineplot.R
@@ -0,0 +1,73 @@
+## skylineplot.R (2004-07-4)
+
+## Various methods to plot skyline objects (= skyline plots)
+
+## Copyright 2002-2004 Korbinian Strimmer
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+# plot skyline
+plot.skyline <- function(x, show.years=FALSE, subst.rate, present.year, ...)
+{
+ if (class(x) != "skyline")
+ stop("object \"x\" is not of class \"skyline\"")
+ t <- x$time
+ m <- x$population.size
+ lm <- length(m)
+
+ if (show.years)
+ {
+ plot((-c(0,t))/subst.rate+present.year,c(m,m[lm]),type="s",
+ xlab="time (years)",ylab="effective population size",log="y", ...)
+
+ }
+ else
+ {
+ plot(c(0,t),c(m,m[lm]),type="s", xlim=c(t[lm],0),
+ xlab="time (past to present in units of substitutions)",ylab="effective population size",log="y", ...)
+ }
+
+}
+
+# plot another skyline plot on top
+lines.skyline <- function(x, show.years=FALSE, subst.rate, present.year, ...)
+{
+ if (class(x) != "skyline")
+ stop("object \"x\" is not of class \"skyline\"")
+ t <- x$time
+ m <- x$population.size
+ lm <- length(m)
+
+
+ if (show.years)
+ {
+ lines((-c(0,t))/subst.rate+present.year,c(m,m[lm]),type="s", ...)
+ }
+ else
+ {
+ lines(c(0,t),c(m,m[lm]),type="s", ...)
+ }
+}
+
+
+# convenience short cut (almost compatible with APE 0.1)
+skylineplot <- function(z, ...) plot(skyline(z, ...))
+
+
+#input: phylogenetic tree
+skylineplot.deluxe <- function(tree, ...)
+{
+ if (class(tree) != "phylo")
+ stop("object \"tree\" is not of class \"phylo\"")
+
+ ci <- coalescent.intervals(tree)
+ classic <- skyline(ci)
+ generalized <- skyline(ci, -1)
+ plot(classic,col=grey(.8), ...)
+ lines(generalized, ...)
+ return(generalized)
+}
+
+
+
diff --git a/R/speciesTree.R b/R/speciesTree.R
new file mode 100644
index 0000000..a8db765
--- /dev/null
+++ b/R/speciesTree.R
@@ -0,0 +1,29 @@
+## speciesTree.R (2013-08-12)
+
+## Species Trees
+
+## Copyright 2010-2013 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+speciesTree <- function(x, FUN = min)
+### FUN = min => MAXTREE (Liu et al. 2010)
+### FUN = sum => shallowest divergence (Maddison & Knowles 2006)
+{
+ test.ultra <- which(!unlist(lapply(x, is.ultrametric)))
+ if (length(test.ultra))
+ stop(paste("the following trees were not ultrametric:\n",
+ paste(test.ultra, collapse = " ")))
+
+ Ntree <- length(x)
+ D <- lapply(x, cophenetic.phylo)
+ nms <- rownames(D[[1]])
+ n <- length(nms)
+ M <- matrix(0, n*(n - 1)/2, Ntree)
+ for (i in 1:Ntree) M[, i] <- as.dist(D[[i]][nms, nms])
+ Y <- apply(M, 1, FUN)
+ attributes(Y) <- list(Size = n, Labels = nms, Diag = FALSE,
+ Upper = FALSE, class = "dist")
+ as.phylo(hclust(Y, "single"))
+}
diff --git a/R/subtreeplot.R b/R/subtreeplot.R
new file mode 100644
index 0000000..b733e90
--- /dev/null
+++ b/R/subtreeplot.R
@@ -0,0 +1,47 @@
+## subtreeplot.R (2008-04-30)
+
+## Zoom on a Portion of a Phylogeny by Successive Clicks
+
+## Copyright 2008 Damien de Vienne
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+subtreeplot<-function(x, wait=FALSE, ...) {
+
+ sub<-subtrees(x, wait=wait)
+ y<-NULL
+ plot.default(0, type="n",axes=FALSE, ann=FALSE)
+ repeat {
+ split.screen(c(1,2))
+ screen(2)
+ if (is.null(y)) plot(x,...)
+ else plot(y,sub=paste("Node :", click),...)
+ screen(1)
+ plot(x,sub="Complete tree",main="Type ESC or right click to exit", cex.main=0.9, ...)
+
+ N.tip<-Ntip(x)
+ N.node<-Nnode(x)
+
+ coor<-plotPhyloCoor(x)
+ tips<-x$tip.label
+ nodes<-x$node.label
+ if (is.null(x$node.label)) nodes<-(N.tip+1):(N.tip+N.node)
+ labs<-c(rep("",N.tip), nodes)
+
+ click<-identify(coor[,1], coor[,2], labels=labs, n=1)
+ if (length(click) == 0) {return(y)}
+ if (click > N.tip) {
+ close.screen(c(1,2),all.screens = TRUE)
+ split.screen(c(1,2))
+ screen(1) #selects the screen to plot in
+ plot(x, sub="Complete tree", ...) # plots x in screen 1 (left)
+ screen(2)
+ for (i in 1:length(sub)) if (sub[[i]]$name==click) break
+ y<-sub[[i]]
+ }
+ else cat("this is a tip, you have to choose a node\n")
+
+ }
+ on.exit(return(y))
+}
diff --git a/R/subtrees.R b/R/subtrees.R
new file mode 100644
index 0000000..bd5bab9
--- /dev/null
+++ b/R/subtrees.R
@@ -0,0 +1,55 @@
+## subtrees.R (2008-04-14)
+
+## All subtrees of a Phylogenetic Tree
+
+## Copyright 2008 Damien de Vienne
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+subtrees<-function(tree, wait = FALSE)
+{
+N.tip<-Ntip (tree)
+N.node<-Nnode(tree)
+limit<-N.tip+N.node
+sub<-list(N.node)
+u<-0
+
+ for (k in (N.tip+1):limit)
+ {
+ u<-u+1
+ if (wait==TRUE) cat("wait... Node",u,"out of", N.node, "treated\n")
+ fils<-NULL
+ pere<-res <- k
+ repeat
+ {
+ for (i in 1: length(pere)) fils<-c(fils, tree$edge[,2][tree$edge[,1]==pere[i]])
+ res<-c(res, fils)
+ pere<-fils
+ fils<-NULL
+ if (length(pere)==0) break
+ }
+
+ len<-res[res>N.tip]
+ if (u==1) {
+ tree2<-tree
+ len<-(N.tip+1):limit
+ }
+ else {
+ len.tip<-res[res<N.tip+1]
+ vec<-1:length(tree$tip.label)
+ len.tip.stay<-setdiff(vec, len.tip)
+ tree2<-drop.tip(tree, len.tip.stay)
+ }
+ sub[[u]]<-tree2
+ sub[[u]]$name<-k
+ #sub[[u]]$name<-tree2$node.label[1]
+ sub[[u]]$Ntip<-Ntip(tree2)
+ sub[[u]]$Nnode<-Nnode(tree2)
+ if (is.null(tree$node.label))
+ sub[[u]]$node.label<-len
+
+ }
+return(sub)
+cat("\n")
+}
diff --git a/R/summary.phylo.R b/R/summary.phylo.R
new file mode 100644
index 0000000..f390b24
--- /dev/null
+++ b/R/summary.phylo.R
@@ -0,0 +1,231 @@
+## summary.phylo.R (2011-08-04)
+
+## Print Summary of a Phylogeny and "multiPhylo" operators
+
+## Copyright 2003-2011 Emmanuel Paradis, and 2006 Ben Bolker
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+Ntip <- function(phy)
+{
+ if (!inherits(phy, "phylo"))
+ stop('object "phy" is not of class "phylo"')
+ length(phy$tip.label)
+}
+
+Nnode <- function(phy, internal.only = TRUE)
+{
+ if (!inherits(phy, "phylo"))
+ stop('object "phy" is not of class "phylo"')
+ if (internal.only) return(phy$Nnode)
+ phy$Nnode + length(phy$tip.label)
+}
+
+Nedge <- function(phy)
+{
+ if (!inherits(phy, "phylo"))
+ stop('object "phy" is not of class "phylo"')
+ dim(phy$edge)[1]
+}
+
+summary.phylo <- function(object, ...)
+{
+ cat("\nPhylogenetic tree:", deparse(substitute(object)), "\n\n")
+ nb.tip <- length(object$tip.label)
+ nb.node <- object$Nnode
+ cat(" Number of tips:", nb.tip, "\n")
+ cat(" Number of nodes:", nb.node, "\n")
+ if (is.null(object$edge.length))
+ cat(" No branch lengths.\n")
+ else {
+ cat(" Branch lengths:\n")
+ cat(" mean:", mean(object$edge.length), "\n")
+ cat(" variance:", var(object$edge.length), "\n")
+ cat(" distribution summary:\n")
+ print(summary(object$edge.length)[-4])
+ }
+ if (is.null(object$root.edge))
+ cat(" No root edge.\n")
+ else
+ cat(" Root edge:", object$root.edge, "\n")
+ if (nb.tip <= 10) {
+ cat(" Tip labels:", object$tip.label[1], "\n")
+ cat(paste(" ", object$tip.label[-1]), sep = "\n")
+ }
+ else {
+ cat(" First ten tip labels:", object$tip.label[1], "\n")
+ cat(paste(" ", object$tip.label[2:10]), sep = "\n")
+ }
+ if (is.null(object$node.label))
+ cat(" No node labels.\n")
+ else {
+ if (nb.node <= 10) {
+ cat(" Node labels:", object$node.label[1], "\n")
+ cat(paste(" ", object$node.label[-1]), sep = "\n")
+ }
+ else {
+ cat(" First ten node labels:", object$node.label[1], "\n")
+ cat(paste(" ", object$node.label[2:10]), sep = "\n")
+
+ }
+ }
+}
+
+### by BB:
+print.phylo <- function(x, printlen = 6,...)
+{
+ nb.tip <- length(x$tip.label)
+ nb.node <- x$Nnode
+ cat(paste("\nPhylogenetic tree with", nb.tip, "tips and", nb.node,
+ "internal nodes.\n\n"))
+ cat("Tip labels:\n")
+ if (nb.tip > printlen) {
+ cat(paste("\t", paste(x$tip.label[1:printlen],
+ collapse=", "), ", ...\n", sep = ""))
+ } else print(x$tip.label)
+ if (!is.null(x$node.label)) {
+ cat("Node labels:\n")
+ if (nb.node > printlen) {
+ cat(paste("\t", paste(x$node.label[1:printlen],
+ collapse=", "), ", ...\n", sep = ""))
+ } else print(x$node.label)
+ }
+ rlab <- if (is.rooted(x)) "Rooted" else "Unrooted"
+ cat("\n", rlab, "; ", sep="")
+
+ blen <- if (is.null(x$edge.length)) "no branch lengths." else
+ "includes branch lengths."
+ cat(blen, "\n", sep = "")
+}
+
+print.multiPhylo <- function(x, details = FALSE, ...)
+{
+ N <- length(x)
+ cat(N, "phylogenetic trees\n")
+ if (details)
+ for (i in 1:N)
+ cat("tree", i, ":", length(x[[i]]$tip.label), "tips\n")
+}
+
+"[[.multiPhylo" <- function(x, i)
+{
+ class(x) <- NULL
+ phy <- x[[i]]
+ if (!is.null(attr(x, "TipLabel")))
+ phy$tip.label <- attr(x, "TipLabel")
+ phy
+}
+
+`$.multiPhylo` <- function(x, name) x[[name]]
+
+"[.multiPhylo" <- function(x, i)
+{
+ oc <- oldClass(x)
+ class(x) <- NULL
+ structure(x[i], TipLabel = attr(x, "TipLabel"),
+ class = oc)
+}
+
+str.multiPhylo <- function(object, ...)
+{
+ class(object) <- NULL
+ cat('Class "multiPhylo"\n')
+ str(object, ...)
+}
+
+c.phylo <- function(..., recursive = FALSE)
+ structure(list(...), class = "multiPhylo")
+## only the first object in '...' is checked for its class,
+## but that should be OK for the moment
+
+c.multiPhylo <- function(..., recursive = FALSE)
+{
+ obj <- list(...)
+ n <- length(obj)
+ x <- obj[[1L]]
+ N <- length(x)
+ i <- 2L
+ while (i <= n) {
+ a <- N + 1L
+ N <- N + length(obj[[i]])
+ ## x is of class "multiPhylo", so this uses the operator below:
+ x[a:N] <- obj[[i]]
+ i <- i + 1L
+ }
+ x
+}
+
+.uncompressTipLabel <- function(x)
+{
+ Lab <- attr(x, "TipLabel")
+ if (is.null(Lab)) return(x)
+ class(x) <- NULL
+ for (i in 1:length(x)) x[[i]]$tip.label <- Lab
+ class(x) <- "multiPhylo"
+ attr(x, "TipLabel") <- NULL
+ x
+}
+
+`[<-.multiPhylo` <- function(x, ..., value)
+{
+ ## recycling is allowed so no need to check: length(value) != length(..1)
+
+ ## check that all elements in 'value' inherit class "phylo"
+ test <- unlist(lapply(value, function(xx) !inherits(xx, "phylo")))
+ if (any(test))
+ stop("at least one element in 'value' is not of class \"phylo\".")
+
+ oc <- oldClass(x)
+ class(x) <- NULL
+
+ if (is.null(attr(x, "TipLabel"))) {
+ x[..1] <- value
+ class(x) <- oc
+ return(x)
+ }
+
+ x[..1] <- 0L # in case x needs to be elongated
+ class(x) <- oc
+ j <- 1L
+ for (i in ..1) {
+ ## x is of class "multiPhylo", so this uses the operator below:
+ x[[i]] <- value[[j]]
+ j <- j + 1L
+ }
+ x
+}
+
+`[[<-.multiPhylo` <- function(x, ..., value)
+{
+ if (!inherits(value, "phylo"))
+ stop('trying to assign an object not of class "phylo" into an object of class "multiPhylo".')
+
+ oc <- oldClass(x)
+ class(x) <- NULL
+
+ Lab <- attr(x, "TipLabel")
+
+ if (!is.null(Lab)) {
+ n <- length(Lab)
+ if (n != length(value$tip.label))
+ stop("tree with different number of tips than those in the list (which all have the same labels; maybe you want to uncompress them)")
+
+ o <- match(value$tip.label, Lab)
+ if (any(is.na(o)))
+ stop("tree tip labels do not match with those in the list; maybe you want to uncompress them.")
+ value$tip.label <- NULL
+ ie <- match(o, value$edge[, 2])
+ value$edge[ie, 2] <- 1:n
+ }
+
+ x[[..1]] <- value
+ class(x) <- oc
+ x
+}
+
+`$<-.multiPhylo` <- function(x, ..., value)
+{
+ x[[..1]] <- value
+ x
+}
diff --git a/R/treePop.R b/R/treePop.R
new file mode 100644
index 0000000..0a6a52f
--- /dev/null
+++ b/R/treePop.R
@@ -0,0 +1,25 @@
+## treePop.R (2011-10-11)
+
+## Tree Popping
+
+## Copyright 2011 Andrei-Alin Popescu
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+treePop <- function(obj)
+{
+ mf <- obj$matsplit
+ labels <- obj$labels
+ n <- length(labels)
+ imf <- as.integer(mf)
+ freq <- obj$freq
+ mimf <- matrix(imf, nrow(mf), ncol(mf))
+ ans <- .C(C_treePop, mimf, as.double(freq), as.integer(ncol(mf)),
+ as.integer(n), integer(2*n - 3), integer(2*n - 3),
+ double(2*n - 3), NAOK = TRUE)
+ obj <- list(edge = cbind(ans[[5]], ans[[6]]), edge.length = ans[[7]],
+ tip.label = labels, Nnode = n - 2L)
+ class(obj) <- "phylo"
+ reorder(obj)
+}
diff --git a/R/triangMtd.R b/R/triangMtd.R
new file mode 100644
index 0000000..75a229a
--- /dev/null
+++ b/R/triangMtd.R
@@ -0,0 +1,40 @@
+## treePop.R (2011-10-11)
+
+## Tree Reconstruction With the Triangles Method
+
+## Copyright 2011 Andrei-Alin Popescu
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+triangMtd <- function(X)
+{
+ if (is.matrix(X)) X <- as.dist(X)
+ if (any(is.na(X)))
+ stop("missing values are not allowed in the distance matrix")
+ N <- attr(X, "Size")
+ labels <- attr(X, "Labels")
+ if (is.null(labels)) labels <- as.character(1:N)
+ ans <- .C(C_triangMtd, as.double(X), as.integer(N), integer(2*N - 3),
+ integer(2*N - 3), double(2*N - 3), NAOK = TRUE)
+ obj <- list(edge = cbind(ans[[3]], ans[[4]]), edge.length = ans[[5]],
+ tip.label = labels, Nnode = N - 2L)
+ class(obj) <- "phylo"
+ reorder(obj)
+}
+
+triangMtds <- function(X)
+{
+ if (is.matrix(X)) X <- as.dist(X)
+ X[is.na(X)] <- -1
+ X[X < 0] <- -1
+ N <- attr(X, "Size")
+ labels <- attr(X, "Labels")
+ if (is.null(labels)) labels <- as.character(1:N)
+ ans <- .C(C_triangMtds, as.double(X), as.integer(N), integer(2*N - 3),
+ integer(2*N - 3), double(2*N - 3), NAOK = TRUE)
+ obj <- list(edge = cbind(ans[[3]], ans[[4]]), edge.length = ans[[5]],
+ tip.label = labels, Nnode = N - 2L)
+ class(obj) <- "phylo"
+ reorder(obj)
+}
diff --git a/R/unique.multiPhylo.R b/R/unique.multiPhylo.R
new file mode 100644
index 0000000..308bbf9
--- /dev/null
+++ b/R/unique.multiPhylo.R
@@ -0,0 +1,34 @@
+## unique.multiPhylo.R (2014-01-15)
+
+## Revomes Duplicate Trees from a List
+
+## Copyright 2007-2014 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+unique.multiPhylo <-
+ function(x, incomparables = FALSE,
+ use.edge.length = FALSE,
+ use.tip.label = TRUE, ...)
+{
+ n <- length(x)
+ keep <- 1L
+ old.index <- seq_len(n)
+ for (i in 2:n) {
+ already.seen <- FALSE
+ for (j in keep) {
+ if (all.equal(x[[j]], x[[i]],
+ use.edge.length = use.edge.length,
+ use.tip.label = use.tip.label)) {
+ already.seen <- TRUE
+ old.index[i] <- j
+ break
+ }
+ }
+ if (!already.seen) keep <- c(keep, i)
+ }
+ res <- x[keep]
+ attr(res, "old.index") <- old.index
+ res
+}
diff --git a/R/varcomp.R b/R/varcomp.R
new file mode 100644
index 0000000..81a709a
--- /dev/null
+++ b/R/varcomp.R
@@ -0,0 +1,37 @@
+## varcomp.R (2004-10-29)
+
+## Variance Component of Mixed-Effect Linear Model
+
+## Copyright 2004 Julien Dutheil
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+varcomp <- function(x, scale = FALSE, cum = FALSE)
+{
+ if (!("lme" %in% class(x))) stop("Object \"x\" is not of class \"lme\"")
+ res <- seq(along = x$modelStruct$reStruct)
+ var <- vector(length = length(res) + 1)
+ for(i in res) {
+ var[length(var) - i] <- attr(summary(x$modelStruct$reStruct[[i]]),"stdDev")[1]*x$sigma
+ }
+ var[length(var)] <- x$sigma
+ var <- var^2
+ if(scale) var <- var/sum(var)
+ if(cum) var <- cumsum(var)
+ names(var) <- c(rev(names(x$modelStruct$reStruct)), "Within")
+ class(var) <- "varcomp"
+ return(var)
+}
+
+plot.varcomp <- function(x, xlab = "Levels", ylab = "Variance", type = "b", ...) {
+ if (!("varcomp" %in% class(x))) stop("Object \"x\" is not of class \"varcomp\"")
+ return(xyplot(x ~ ordered(names(x), levels=rev(names(x))), xlab=xlab, ylab=ylab, type=type, ...))
+}
+
+# For debuging:
+#data(carnivora)
+#m <- lme(log10(SW) ~ 1, random = ~ 1|Order/SuperFamily/Family/Genus, data=carnivora)
+#v <- varcomp(m,T,T)
+#plot(v)
+
diff --git a/R/vcv.phylo.R b/R/vcv.phylo.R
new file mode 100644
index 0000000..0b70029
--- /dev/null
+++ b/R/vcv.phylo.R
@@ -0,0 +1,72 @@
+## vcv.phylo.R (2012-02-21)
+
+## Phylogenetic Variance-Covariance or Correlation Matrix
+
+## Copyright 2002-2012 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+vcv <- function(phy, ...) UseMethod("vcv")
+
+vcv.phylo <- function(phy, model = "Brownian", corr = FALSE, ...)
+{
+ if (is.null(phy$edge.length))
+ stop("the tree has no branch lengths")
+
+ pp <- prop.part(phy)
+
+ phy <- reorder(phy, "postorder")
+
+ n <- length(phy$tip.label)
+ e1 <- phy$edge[, 1]
+ e2 <- phy$edge[, 2]
+ EL <- phy$edge.length
+
+ ## xx: vecteur donnant la distance d'un noeud
+ ## ou d'un tip à partir de la racine
+ ## (same than in is.ultrametric)
+ xx <- numeric(n + phy$Nnode)
+
+ vcv <- matrix(0, n, n)
+
+ ## the loop below starts from the bottom of the edge matrix, so
+ ## from the root
+
+ for (i in length(e1):1) {
+ var.cur.node <- xx[e1[i]]
+ xx[e2[i]] <- var.cur.node + EL[i] # sets the variance
+ j <- i - 1L
+ while (e1[j] == e1[i] && j > 0) {
+ left <- if (e2[j] > n) pp[[e2[j] - n]] else e2[j]
+ right <- if (e2[i] > n) pp[[e2[i] - n]] else e2[i]
+ vcv[left, right] <- vcv[right, left] <- var.cur.node # sets the covariance
+ j <- j - 1L
+ }
+ }
+
+ diag.elts <- 1 + 0:(n - 1)*(n + 1)
+ vcv[diag.elts] <- xx[1:n]
+
+ if (corr) {
+ ## This is inspired from the code of cov2cor (2005-09-08):
+ Is <- sqrt(1 / vcv[diag.elts])
+ ## below 'vcv[] <- ...' has been changed to 'vcv <- ...'
+ ## which seems to be twice faster for n = 1000 and
+ ## respects the additional attributes (2012-02-21):
+ vcv <- Is * vcv * rep(Is, each = n)
+ vcv[diag.elts] <- 1
+ }
+
+ dimnames(vcv)[1:2] <- list(phy$tip.label)
+ vcv
+}
+
+vcv.corPhyl <- function(phy, corr = FALSE, ...)
+{
+ labels <- attr(phy, "tree")$tip.label
+ dummy.df <- data.frame(seq_along(labels), row.names = labels)
+ res <- corMatrix(Initialize.corPhyl(phy, dummy.df), corr = corr)
+ dimnames(res) <- list(labels, labels)
+ res
+}
diff --git a/R/which.edge.R b/R/which.edge.R
new file mode 100644
index 0000000..d22d97a
--- /dev/null
+++ b/R/which.edge.R
@@ -0,0 +1,67 @@
+## which.edge.R (2013-05-10)
+
+## Identifies Edges of a Tree
+
+## Copyright 2004-2013 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+getMRCA <- function(phy, tip)
+### Find the MRCA of the tips given as `tip'
+### (see `root.R' for comments on the code)
+{
+ if (!inherits(phy, "phylo"))
+ stop('object "phy" is not of class "phylo"')
+ if (is.character(tip)) tip <- which(phy$tip.label %in% tip)
+ if (length(tip) < 2) return(NULL)
+ Ntip <- length(phy$tip.label)
+ seq.nod <- .Call(seq_root2tip, phy$edge, Ntip, phy$Nnode)
+ sn <- seq.nod[tip]
+ MRCA <- Ntip + 1
+ i <- 2
+ repeat {
+ x <- unique(unlist(lapply(sn, "[", i)))
+ if (length(x) != 1) break
+ MRCA <- x
+ i <- i + 1
+ }
+ MRCA
+}
+
+which.edge <- function(phy, group)
+{
+ if (!inherits(phy, "phylo"))
+ stop('object "phy" is not of class "phylo"')
+ if (is.character(group))
+ group <- which(phy$tip.label %in% group)
+ if (length(group) == 1)
+ return(match(group, phy$edge[, 2]))
+ nb.tip <- length(phy$tip.label)
+ MRCA <- getMRCA(phy, group)
+ if (MRCA == nb.tip + 1) {
+ from <- 1
+ to <- dim(phy$edge)[1]
+ } else {
+ from <- which(phy$edge[, 2] == MRCA) + 1
+ to <- max(which(phy$edge[, 2] %in% group))
+ }
+ wh <- from:to
+ tmp <- phy$edge[wh, 2]
+ ## check that there are no extra tips:
+ ## (we do this by selecting the tips in `group' and the nodes
+ ## i.e., the internal edges)
+ test <- tmp %in% group | tmp > nb.tip
+ if (any(!test)) {
+ wh <- wh[test] # drop the extra tips
+ ## see if there are no extra internal edges:
+ tmp <- phy$edge[wh, ]
+ test <- !(tmp[, 2] %in% tmp[, 1]) & tmp[, 2] > nb.tip
+ while (any(test)){
+ wh <- wh[!test]
+ tmp <- phy$edge[wh, ]
+ test <- !(tmp[, 2] %in% tmp[, 1]) & tmp[, 2] > nb.tip
+ }
+ }
+ wh
+}
diff --git a/R/write.dna.R b/R/write.dna.R
new file mode 100644
index 0000000..3f53cb9
--- /dev/null
+++ b/R/write.dna.R
@@ -0,0 +1,131 @@
+## write.dna.R (2012-06-22)
+
+## Write DNA Sequences in a File
+
+## Copyright 2003-2012 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+write.dna <- function(x, file, format = "interleaved", append = FALSE,
+ nbcol = 6, colsep = " ", colw = 10, indent = NULL,
+ blocksep = 1)
+{
+ format <- match.arg(format, c("interleaved", "sequential", "fasta"))
+ phylip <- if (format %in% c("interleaved", "sequential")) TRUE else FALSE
+ if (inherits(x, "DNAbin")) x <- as.character(x)
+ aligned <- TRUE
+ if (is.matrix(x)) {
+ N <- dim(x)
+ S <- N[2]
+ N <- N[1]
+ xx <- vector("list", N)
+ for (i in 1:N) xx[[i]] <- x[i, ]
+ names(xx) <- rownames(x)
+ x <- xx
+ rm(xx)
+ } else {
+ N <- length(x)
+ S <- unique(unlist(lapply(x, length)))
+ if (length(S) > 1) aligned <- FALSE
+ }
+ if (is.null(names(x))) names(x) <- as.character(1:N)
+ if (is.null(indent))
+ indent <- if (phylip) 10 else 0
+ if (is.numeric(indent))
+ indent <- paste(rep(" ", indent), collapse = "")
+ if (format == "interleaved") {
+ blocksep <- paste(rep("\n", blocksep), collapse = "")
+ if (nbcol < 0) format <- "sequential"
+ }
+ zz <- if (append) file(file, "a") else file(file, "w")
+ on.exit(close(zz))
+ if (phylip) {
+ if (!aligned)
+ stop("sequences must have the same length for
+ interleaved or sequential format.")
+ cat(N, " ", S, "\n", sep = "", file = zz)
+ if (nbcol < 0) {
+ nb.block <- 1
+ nbcol <- totalcol <- ceiling(S/colw)
+ } else {
+ nb.block <- ceiling(S/(colw * nbcol))
+ totalcol <- ceiling(S/colw)
+ }
+ ## Prepare the sequences in a matrix whose elements are
+ ## strings with `colw' characters.
+ SEQ <- matrix("", N, totalcol)
+ for (i in 1:N) {
+ X <- paste(x[[i]], collapse = "")
+ for (j in 1:totalcol)
+ SEQ[i, j] <- substr(X, 1 + (j - 1)*colw, colw + (j - 1)*colw)
+ }
+ ## Prepare the names so that they all have the same nb of chars
+ max.nc <- max(nchar(names(x)))
+ ## always put a space between the sequences and the taxa names
+ fmt <- paste("%-", max.nc + 1, "s", sep = "")
+ names(x) <- sprintf(fmt, names(x))
+ }
+ switch(format, "interleaved" = {
+ ## Write the first block with the taxon names
+ colsel <- if (nb.block == 1) 1:totalcol else 1:nbcol
+ for (i in 1:N) {
+ cat(names(x)[i], file = zz)
+ cat(SEQ[i, colsel], sep = colsep, file = zz)
+ cat("\n", file = zz)
+ }
+ ## Write eventually the other blocks
+ if (nb.block > 1) {
+ for (k in 2:nb.block) {
+ cat(blocksep, file = zz)
+ endcolsel <- if (k == nb.block) totalcol else nbcol + (k - 1)*nbcol
+ for (i in 1:N) {
+ cat(indent, file = zz)
+ cat(SEQ[i, (1 + (k - 1)*nbcol):endcolsel], sep = colsep, file = zz)
+ cat("\n", file = zz)
+ }
+ }
+ }
+
+ }, "sequential" = {
+ if (nb.block == 1) {
+ for (i in 1:N) {
+ cat(names(x)[i], file = zz)
+ cat(SEQ[i, ], sep = colsep, file = zz)
+ cat("\n", file = zz)
+ }
+ } else {
+ for (i in 1:N) {
+ cat(names(x)[i], file = zz)
+ cat(SEQ[i, 1:nbcol], sep = colsep, file = zz)
+ cat("\n", file = zz)
+ for (k in 2:nb.block) {
+ endcolsel <- if (k == nb.block) totalcol else nbcol + (k - 1)*nbcol
+ cat(indent, file = zz)
+ cat(SEQ[i, (1 + (k - 1)*nbcol):endcolsel], sep = colsep, file = zz)
+ cat("\n", file = zz)
+ }
+ }
+ }
+ }, "fasta" = {
+ for (i in 1:N) {
+ cat(">", names(x)[i], file = zz, sep = "")
+ cat("\n", file = zz)
+ X <- paste(x[[i]], collapse = "")
+ S <- length(x[[i]])
+ totalcol <- ceiling(S/colw)
+ if (nbcol < 0) nbcol <- totalcol
+ nb.lines <- ceiling(totalcol/nbcol)
+ SEQ <- character(totalcol)
+ for (j in 1:totalcol)
+ SEQ[j] <- substr(X, 1 + (j - 1) * colw, colw + (j - 1) * colw)
+ for (k in 1:nb.lines) {
+ endsel <-
+ if (k == nb.lines) length(SEQ) else nbcol + (k - 1)*nbcol
+ cat(indent, file = zz)
+ cat(SEQ[(1 + (k - 1)*nbcol):endsel], sep = colsep, file = zz)
+ cat("\n", file = zz)
+ }
+ }
+ })
+}
diff --git a/R/write.nexus.R b/R/write.nexus.R
new file mode 100644
index 0000000..ac383f7
--- /dev/null
+++ b/R/write.nexus.R
@@ -0,0 +1,73 @@
+## write.nexus.R (2012-03-30)
+
+## Write Tree File in Nexus Format
+
+## Copyright 2003-2012 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+write.nexus <- function(..., file = "", translate = TRUE)
+{
+ obj <- list(...)
+ ## We insure that all trees are in a list, even if there is a single one:
+ if (length(obj) == 1) {
+ if (class(obj[[1]]) == "phylo") ntree <- 1
+ else {
+ obj <- obj[[1]] # NOT use unlist()
+ ntree <- length(obj)
+ }
+ } else ntree <- length(obj)
+ cat("#NEXUS\n", file = file)
+ cat(paste("[R-package APE, ", date(), "]\n\n", sep = ""),
+ file = file, append = TRUE)
+
+ N <- length(obj[[1]]$tip.label)
+
+ cat("BEGIN TAXA;\n", file = file, append = TRUE)
+ cat(paste("\tDIMENSIONS NTAX = ", N, ";\n", sep = ""),
+ file = file, append = TRUE)
+ cat("\tTAXLABELS\n", file = file, append = TRUE)
+ cat(paste("\t\t", obj[[1]]$tip.label, sep = ""),
+ sep = "\n", file = file, append = TRUE)
+ cat("\t;\n", file = file, append = TRUE)
+ cat("END;\n", file = file, append = TRUE)
+
+ cat("BEGIN TREES;\n", file = file, append = TRUE)
+ if (translate) {
+ cat("\tTRANSLATE\n", file = file, append = TRUE)
+ obj <- .compressTipLabel(obj)
+ X <- paste("\t\t", 1:N, "\t", attr(obj, "TipLabel"), ",", sep = "")
+ ## We remove the last comma:
+ X[length(X)] <- gsub(",", "", X[length(X)])
+ cat(X, file = file, append = TRUE, sep = "\n")
+ cat("\t;\n", file = file, append = TRUE)
+ class(obj) <- NULL
+ for (i in 1:ntree)
+ obj[[i]]$tip.label <- as.character(1:N)
+ } else {
+ if (is.null(attr(obj, "TipLabel"))) {
+ for (i in 1:ntree)
+ obj[[i]]$tip.label <- checkLabel(obj[[i]]$tip.label)
+ } else {
+ attr(obj, "TipLabel") <- checkLabel(attr(obj, "TipLabel"))
+ obj <- .uncompressTipLabel(obj)
+ }
+ }
+
+ title <- names(obj)
+ if (is.null(title))
+ title <- rep("UNTITLED", ntree)
+ else {
+ if (any(s <- title == "")) title[s] <- "UNTITLED"
+ }
+
+ for (i in 1:ntree) {
+ if (class(obj[[i]]) != "phylo") next
+ root.tag <- if (is.rooted(obj[[i]])) "= [&R] " else "= [&U] "
+ cat("\tTREE *", title[i], root.tag, file = file, append = TRUE)
+ cat(write.tree(obj[[i]], file = ""),
+ "\n", sep = "", file = file, append = TRUE)
+ }
+ cat("END;\n", file = file, append = TRUE)
+}
diff --git a/R/write.nexus.data.R b/R/write.nexus.data.R
new file mode 100644
index 0000000..deae1f8
--- /dev/null
+++ b/R/write.nexus.data.R
@@ -0,0 +1,168 @@
+"write.nexus.data" <- function (x, file, format = "dna", datablock = TRUE,
+ interleaved = TRUE, charsperline = NULL,
+ gap = NULL, missing = NULL)
+{
+ # Nexus data parser.
+ #
+ # Version: 09/13/2006 09:06:33 AM CEST
+ #
+ # By: Johan Nylander, nylander @ scs.fsu.edu
+ #
+ # TODO: Standard data, mixed data, nice indent
+ #------------------------------------------------------------------
+
+ indent <- " " # Two blanks
+ maxtax <- 5 # Max nr of taxon names to be printed on a line
+ defcharsperline <- 80 # Default nr of characters per line if interleaved
+ defgap <- "-" # Default gap character
+ defmissing <- "?" # Default missing data character
+
+ ntax <- length(x)
+ nchars <- length(x[[1]])
+ zz <- file(file, "w")
+
+ if (is.null(names(x))) {
+ names(x) <- as.character(1:ntax)
+ }
+
+ "fcat" <- function (..., file = zz)
+ {
+ cat(..., file = file, sep = "", append = TRUE)
+ }
+
+ "find.max.length" <- function (x)
+ {
+ max <- 0
+ for (i in 1:length(x)) {
+ val <- length((strsplit(x[i], split = NULL))[[1]])
+ if (val > max) {
+ max <- val
+ }
+ }
+ max
+ }
+
+ "print.matrix" <- function(x, dindent = " ")
+ {
+ Names <- names(x)
+ printlength <- find.max.length(Names) + 2
+ if (interleaved == FALSE) {
+ for (i in 1:length(x)) {
+ sequence <- paste(x[[i]], collapse = "")
+ taxon <- Names[i]
+ thestring <- sprintf("%-*s%s%s", printlength, taxon, dindent, sequence)
+ fcat(indent, indent, thestring, "\n")
+ }
+ }
+ else {
+ ntimes <- ceiling(nchars/charsperline)
+ start <- 1
+ end <- charsperline
+ for (j in 1:ntimes) {
+ for (i in 1:length(x)) {
+ sequence <- paste(x[[i]][start:end], collapse = "")
+ taxon <- Names[i]
+ thestring <- sprintf("%-*s%s%s", printlength, taxon, dindent, sequence)
+ fcat(indent, indent, thestring, "\n")
+ }
+ if (j < ntimes) {
+ fcat("\n")
+ }
+ start <- start + charsperline
+ end <- end + charsperline
+ if (end > nchars) {
+ end <- nchars
+ }
+ }
+ }
+ }
+
+ fcat("#NEXUS\n[Data written by write.nexus.data.R,", " ", date(),"]\n")
+
+ NCHAR <- paste("NCHAR=", nchars, sep = "")
+ NTAX <- paste("NTAX=", ntax, sep = "")
+
+ if (format == "dna") {
+ DATATYPE <- "DATATYPE=DNA"
+ }
+ if (format == "protein") {
+ DATATYPE <- "DATATYPE=PROTEIN"
+ }
+
+ if (is.null(charsperline)) {
+ if (nchars < defcharsperline) {
+ charsperline <- nchars
+ interleaved <- FALSE
+ }
+ else {
+ if (nchars > defcharsperline) {
+ charsperline <- defcharsperline
+ }
+ }
+ }
+
+ if (is.null(missing)) {
+ MISSING <- paste("MISSING=", defmissing, sep = "")
+ }
+ else {
+ MISSING <- paste("MISSING=", missing, sep = "")
+ }
+
+ if (is.null(gap)) {
+ GAP <- paste("GAP=", defgap, sep = "")
+ }
+ else {
+ GAP <- paste("GAP=", gap, sep = "")
+ }
+
+ if (interleaved == TRUE) {
+ INTERLEAVE <- "INTERLEAVE=YES"
+ }
+ if (interleaved == FALSE) {
+ INTERLEAVE <- "INTERLEAVE=NO"
+ }
+
+ if (datablock == TRUE) {
+ fcat("BEGIN DATA;\n")
+ fcat(indent,"DIMENSIONS", " ", NTAX, " ", NCHAR, ";\n")
+ if (format %in% c("dna", "protein")) {
+ fcat(indent, "FORMAT", " ", DATATYPE, " ", MISSING, " ", GAP, " ", INTERLEAVE, ";\n") # from Fran�ois Michonneau (2009-10-02)
+ }
+ fcat(indent,"MATRIX\n")
+ print.matrix(x)
+ fcat(indent, ";\n")
+ fcat("END;\n\n")
+ }
+ else {
+ fcat("BEGIN TAXA;\n")
+ fcat(indent, "DIMENSIONS", " ", NTAX, ";\n")
+ fcat(indent, "TAXLABELS\n")
+ fcat(indent, indent)
+ j <- 0
+ for (i in 1:ntax) {
+ fcat(names(x[i]), " ")
+ j <- j + 1
+ if (i == ntax) {
+ fcat("\n", indent, ";\n")
+ }
+ else {
+ if (j == maxtax) {
+ fcat("\n", indent, indent)
+ j <- 0
+ }
+ }
+ }
+ fcat("END;\n\n")
+ fcat("BEGIN CHARACTERS;\n")
+ fcat(indent, "DIMENSIONS", " ", NCHAR, ";\n")
+ if (format %in% c("dna", "protein")) {
+ fcat(indent, "FORMAT", " ", MISSING, " ", GAP, " ", DATATYPE, " ", INTERLEAVE, ";\n")
+ }
+ fcat(indent,"MATRIX\n")
+ print.matrix(x)
+ fcat(indent, ";")
+ fcat("\nEND;\n\n")
+ }
+ close(zz)
+}
+
diff --git a/R/write.tree.R b/R/write.tree.R
new file mode 100644
index 0000000..08de505
--- /dev/null
+++ b/R/write.tree.R
@@ -0,0 +1,131 @@
+## write.tree.R (2010-12-07)
+
+## Write Tree File in Parenthetic Format
+
+## Copyright 2002-2010 Emmanuel Paradis, Daniel Lawson, and Klaus Schliep
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+checkLabel <- function(x, ...)
+{
+ ## delete all leading and trailing spaces and tabs, and
+ ## the leading left and trailing right parentheses:
+ ## (the syntax will work with any mix of these characters,
+ ## e.g., " ( ( (( " will correctly be deleted)
+ x <- gsub("^[[:space:]\\(]+", "", x)
+ x <- gsub("[[:space:]\\)]+$", "", x)
+ ## replace all spaces and tabs by underscores:
+ x <- gsub("[[:space:]]", "_", x)
+ ## remove all commas, colons, and semicolons
+ x <- gsub("[,:;]", "", x)
+ ## replace left and right parentheses with dashes:
+ x <- gsub("[\\(\\)]", "-", x)
+ ## delete extra underscores and extra dashes:
+ x <- gsub("_{2,}", "_", x)
+ x <- gsub("-{2,}", "-", x)
+ x
+}
+
+write.tree <-
+ function(phy, file = "", append = FALSE, digits = 10, tree.names = FALSE)
+{
+ if (!(inherits(phy, c("phylo", "multiPhylo"))))
+ stop("object \"phy\" has no trees")
+
+ if (inherits(phy, "phylo")) phy <- c(phy)
+ N <- length(phy)
+ res <- character(N)
+
+ if (is.logical(tree.names)) {
+ if (tree.names) {
+ tree.names <-
+ if (is.null(names(phy))) character(N)
+ else names(phy)
+ } else tree.names <- character(N)
+ }
+
+ for (i in 1:N)
+ res[i] <- .write.tree2(phy[[i]], digits = digits,
+ tree.prefix = tree.names[i])
+
+ if (file == "") return(res)
+ else cat(res, file = file, append = append, sep = "\n")
+}
+
+.write.tree2 <- function(phy, digits = 10, tree.prefix = "")
+{
+ brl <- !is.null(phy$edge.length)
+ nodelab <- !is.null(phy$node.label)
+ phy$tip.label <- checkLabel(phy$tip.label)
+ if (nodelab) phy$node.label <- checkLabel(phy$node.label)
+ f.d <- paste("%.", digits, "g", sep = "")
+ cp <- function(x){
+ STRING[k] <<- x
+ k <<- k + 1
+ }
+ add.internal <- function(i) {
+ cp("(")
+ desc <- kids[[i]]
+ for (j in desc) {
+ if (j > n) add.internal(j)
+ else add.terminal(ind[j])
+ if (j != desc[length(desc)]) cp(",")
+ }
+ cp(")")
+ if (nodelab && i > n) cp(phy$node.label[i - n]) # fixed by Naim Matasci (2010-12-07)
+ if (brl) {
+ cp(":")
+ cp(sprintf(f.d, phy$edge.length[ind[i]]))
+ }
+ }
+ add.terminal <- function(i) {
+ cp(phy$tip.label[phy$edge[i, 2]])
+ if (brl) {
+ cp(":")
+ cp(sprintf(f.d, phy$edge.length[i]))
+ }
+ }
+
+ n <- length(phy$tip.label)
+
+ ## borrowed from phangorn:
+ parent <- phy$edge[, 1]
+ children <- phy$edge[, 2]
+ kids <- vector("list", n + phy$Nnode)
+ for (i in 1:length(parent))
+ kids[[parent[i]]] <- c(kids[[parent[i]]], children[i])
+
+ ind <- match(1:max(phy$edge), phy$edge[, 2])
+
+ LS <- 4*n + 5
+ if (brl) LS <- LS + 4*n
+ if (nodelab) LS <- LS + n
+ STRING <- character(LS)
+ k <- 1
+ cp(tree.prefix)
+ cp("(")
+ getRoot <- function(phy)
+ phy$edge[, 1][!match(phy$edge[, 1], phy$edge[, 2], 0)][1]
+ root <- getRoot(phy) # replaced n+1 with root - root has not be n+1
+ desc <- kids[[root]]
+ for (j in desc) {
+ if (j > n) add.internal(j)
+ else add.terminal(ind[j])
+ if (j != desc[length(desc)]) cp(",")
+ }
+
+ if (is.null(phy$root.edge)) {
+ cp(")")
+ if (nodelab) cp(phy$node.label[1])
+ cp(";")
+ }
+ else {
+ cp(")")
+ if (nodelab) cp(phy$node.label[1])
+ cp(":")
+ cp(sprintf(f.d, phy$root.edge))
+ cp(";")
+ }
+ paste(STRING, collapse = "")
+}
diff --git a/R/yule.R b/R/yule.R
new file mode 100644
index 0000000..abd719c
--- /dev/null
+++ b/R/yule.R
@@ -0,0 +1,81 @@
+## yule.R (2011-11-03)
+
+## Fits Yule Model to a Phylogenetic Tree
+
+## yule: standard Yule model (constant birth rate)
+## yule.cov: Yule model with covariates
+
+## Copyright 2003-2011 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+yule <- function(phy, use.root.edge = FALSE)
+{
+ if (!is.binary.tree(phy))
+ stop("tree must be dichotomous to fit the Yule model.")
+
+ X <- sum(phy$edge.length)
+ nb.node <- phy$Nnode
+
+ if (!is.null(phy$root.edge) && use.root.edge) X <- X + phy$root.edge
+ else nb.node <- nb.node - 1
+
+ lambda <- nb.node/X
+ se <- lambda/sqrt(nb.node)
+ loglik <- -lambda * X + lfactorial(phy$Nnode) + nb.node * log(lambda)
+ obj <- list(lambda = lambda, se = se, loglik = loglik)
+ class(obj) <- "yule"
+ obj
+}
+
+yule.cov <- function(phy, formula, data = NULL)
+{
+ if (is.null(data)) data <- parent.frame()
+ n <- length(phy$tip.label)
+ nb.node <- phy$Nnode
+ if (!is.null(phy$node.label)) phy$node.label <- NULL
+ bt <- sort(branching.times(phy)) # branching times (from present to past)
+ bt <- rev(bt) # branching times from past to present
+ ni <- cumsum(rev(table(bt))) + 1
+ X <- model.matrix(formula, data)
+ Xi <- X[phy$edge[, 1], , drop = FALSE]
+ Xj <- X[phy$edge[, 2], , drop = FALSE]
+ dev <- function(b) {
+ 2 * sum(((1/(1 + exp(-(Xi %*% b)))) +
+ (1/(1 + exp(-(Xj %*% b)))))
+ * phy$edge.length/2) -
+ 2 * (sum(log(ni[-length(ni)])) +
+ sum(log((1/(1 + exp(-(X[-(1:(n + 1)), , drop = FALSE] %*% b)))))))
+ }
+ out <- nlm(function(p) dev(p), p = c(rep(0, ncol(X) - 1), -1),
+ hessian = TRUE)
+ Dev <- out$minimum
+ para <- matrix(NA, ncol(X), 2)
+ para[, 1] <- out$estimate
+ if (any(out$gradient == 0))
+ warning("The likelihood gradient seems flat in at least one dimension (null gradient):\ncannot compute the standard-errors of the parameters.\n")
+ else para[, 2] <- sqrt(diag(solve(out$hessian)))
+ rownames(para) <- colnames(X)
+ colnames(para) <- c("Estimate", "StdErr")
+ ## fit the intercept-only model:
+ X <- model.matrix(~ 1, data = data.frame(X))
+ Xi <- X[phy$edge[, 1], , drop = FALSE]
+ Xj <- X[phy$edge[, 2], , drop = FALSE]
+ Dev.null <- nlm(function(p) dev(p), p = -1)$minimum
+ cat("\n---- Yule Model with Covariates ----\n\n")
+ cat(" Phylogenetic tree:", deparse(substitute(phy)), "\n")
+ cat(" Number of tips:", n, "\n")
+ cat(" Number of nodes:", nb.node, "\n")
+ cat(" Deviance:", Dev, "\n")
+ cat(" Log-likelihood:", -Dev/2, "\n\n")
+ cat(" Parameter estimates:\n")
+ print(para)
+ cat("\n")
+ cat("Null Deviance:", Dev.null, "\n")
+ cat(" Test of the fitted model: ")
+ chi <- Dev.null - Dev
+ df <- nrow(para) - 1
+ cat("chi^2 =", round(chi, 3), " df =", df,
+ " P =", round(1 - pchisq(chi, df), 3), "\n")
+}
diff --git a/R/yule.time.R b/R/yule.time.R
new file mode 100644
index 0000000..f82aab8
--- /dev/null
+++ b/R/yule.time.R
@@ -0,0 +1,71 @@
+## yule.time.R (2009-02-20)
+
+## Fits the Time-Dependent Yule Model
+
+## Copyright 2009 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+yule.time <- function(phy, birth, BIRTH = NULL, root.time = 0,
+ opti = "nlm", start = 0.01)
+{
+ opti <- pmatch(opti, c("nlm", "nlminb", "optim"))
+ if (is.na(opti)) stop("ambiguous argument 'opti'")
+ LAMBDA <- function() x
+ body(LAMBDA) <- body(birth)
+ formals(LAMBDA) <- alist(t=)
+ BT <- branching.times(phy)
+ T <- BT[1]
+ x <- BT[1] - BT + root.time
+ m <- phy$Nnode
+
+ paranam <- c(names(formals(birth)))
+ np <- length(paranam)
+ start <- rep(start, length.out = np)
+
+ ## Foo is always vectorized
+ if (is.null(BIRTH)) {
+ Foo <- function(x) {
+ n <- length(x)
+ res <- numeric(n)
+ for (i in 1:n)
+ res[i] <- integrate(LAMBDA, x[i], T)$value
+ res
+ }
+ } else {
+ environment(BIRTH) <- environment()
+ Foo <- function(x) BIRTH(T) - BIRTH(x)
+ }
+
+ half.dev <- function(p) {
+ for (i in 1:np)
+ assign(paranam[i], p[i], pos = sys.frame(1))
+ root.term <-
+ if (is.null(BIRTH)) integrate(LAMBDA, x[1], T)$value
+ else BIRTH(T) - BIRTH(x[1])
+ sum(Foo(x)) + root.term - sum(log(LAMBDA(x[2:m])))
+ }
+
+ switch(opti,
+ {
+ out <- nlm(half.dev, start, hessian = TRUE)
+ est <- out$estimate
+ se <- sqrt(diag(solve(out$hessian)))
+ loglik <- lfactorial(m) - out$minimum
+ },{
+ out <- nlminb(start, half.dev)
+ est <- out$par
+ se <- NULL
+ loglik <- lfactorial(m) - out$objective
+ },{
+ out <- optim(start, half.dev, hessian = TRUE,
+ control = list(maxit = 1000), method = "BFGS")
+ est <- out$par
+ se <- sqrt(diag(solve(out$hessian)))
+ loglik <- lfactorial(m) - out$value
+ })
+ names(est) <- paranam
+ if (!is.null(se)) names(se) <- paranam
+ structure(list(estimate = est, se = se, loglik = loglik), class = "yule")
+}
diff --git a/R/zoom.R b/R/zoom.R
new file mode 100644
index 0000000..b247376
--- /dev/null
+++ b/R/zoom.R
@@ -0,0 +1,37 @@
+## zoom.R (2009-07-27)
+
+## Zoom on a Portion of a Phylogeny
+
+## Copyright 2003-2009 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+zoom <- function(phy, focus, subtree = FALSE, col = rainbow, ...)
+{
+ if (!is.list(focus)) focus <- list(focus)
+ n <- length(focus)
+ for (i in 1:n)
+ if (is.character(focus[[i]]))
+ focus[[i]] <- which(phy$tip.label %in% focus[[i]]) # fix by Yan Wong
+ if (is.function(col)) {
+ col <- if (deparse(substitute(col)) == "grey") grey(1:n/n) else col(n)
+ }
+ ext <- vector("list", n)
+ for (i in 1:n)
+ ext[[i]] <- drop.tip(phy, phy$tip.label[-focus[[i]]],
+ subtree = subtree, rooted = TRUE)
+ nc <- round(sqrt(n)) + 1
+ nr <- ceiling(sqrt(n))
+ M <- matrix(0, nr, nc)
+ x <- c(rep(1, nr), 2:(n + 1))
+ M[1:length(x)] <- x
+ layout(M, c(1, rep(3/(nc - 1), nc - 1)))
+ phy$tip.label <- rep("", length(phy$tip.label))
+ colo <- rep("black", dim(phy$edge)[1])
+ for (i in 1:n)
+ colo[which.edge(phy, focus[[i]])] <- col[i]
+ plot.phylo(phy, edge.color = colo, ...)
+ for (i in 1:n)
+ plot.phylo(ext[[i]], edge.color = col[i], ...)
+}
diff --git a/R/zzz.R b/R/zzz.R
new file mode 100644
index 0000000..9ab2b1c
--- /dev/null
+++ b/R/zzz.R
@@ -0,0 +1,10 @@
+## zzz.R (2009-01-12)
+
+## Library Loading
+
+## Copyright 2003-2009 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+.PlotPhyloEnv <- new.env()
diff --git a/build/vignette.rds b/build/vignette.rds
new file mode 100644
index 0000000..4ce6254
Binary files /dev/null and b/build/vignette.rds differ
diff --git a/data/HP.links.rda b/data/HP.links.rda
new file mode 100644
index 0000000..c05999d
Binary files /dev/null and b/data/HP.links.rda differ
diff --git a/data/bird.families.rda b/data/bird.families.rda
new file mode 100644
index 0000000..9816415
Binary files /dev/null and b/data/bird.families.rda differ
diff --git a/data/bird.orders.rda b/data/bird.orders.rda
new file mode 100644
index 0000000..bd5ffef
Binary files /dev/null and b/data/bird.orders.rda differ
diff --git a/data/carnivora.csv.gz b/data/carnivora.csv.gz
new file mode 100644
index 0000000..8af3824
Binary files /dev/null and b/data/carnivora.csv.gz differ
diff --git a/data/chiroptera.rda b/data/chiroptera.rda
new file mode 100644
index 0000000..ff55345
Binary files /dev/null and b/data/chiroptera.rda differ
diff --git a/data/cynipids.rda b/data/cynipids.rda
new file mode 100644
index 0000000..d0e814a
Binary files /dev/null and b/data/cynipids.rda differ
diff --git a/data/gopher.D.rda b/data/gopher.D.rda
new file mode 100644
index 0000000..5d8f617
Binary files /dev/null and b/data/gopher.D.rda differ
diff --git a/data/hivtree.newick.rda b/data/hivtree.newick.rda
new file mode 100644
index 0000000..94b996f
Binary files /dev/null and b/data/hivtree.newick.rda differ
diff --git a/data/hivtree.table.txt.gz b/data/hivtree.table.txt.gz
new file mode 100644
index 0000000..9bdc710
Binary files /dev/null and b/data/hivtree.table.txt.gz differ
diff --git a/data/landplants.newick.rda b/data/landplants.newick.rda
new file mode 100644
index 0000000..2ad392d
Binary files /dev/null and b/data/landplants.newick.rda differ
diff --git a/data/lice.D.rda b/data/lice.D.rda
new file mode 100644
index 0000000..6a66396
Binary files /dev/null and b/data/lice.D.rda differ
diff --git a/data/lmorigin.ex1.rda b/data/lmorigin.ex1.rda
new file mode 100644
index 0000000..e1e8c7c
Binary files /dev/null and b/data/lmorigin.ex1.rda differ
diff --git a/data/lmorigin.ex2.rda b/data/lmorigin.ex2.rda
new file mode 100644
index 0000000..eebc812
Binary files /dev/null and b/data/lmorigin.ex2.rda differ
diff --git a/data/mat3.RData b/data/mat3.RData
new file mode 100644
index 0000000..e41691b
Binary files /dev/null and b/data/mat3.RData differ
diff --git a/data/mat5M3ID.RData b/data/mat5M3ID.RData
new file mode 100644
index 0000000..62b55ee
Binary files /dev/null and b/data/mat5M3ID.RData differ
diff --git a/data/mat5Mrand.RData b/data/mat5Mrand.RData
new file mode 100644
index 0000000..b47aa25
Binary files /dev/null and b/data/mat5Mrand.RData differ
diff --git a/data/opsin.newick.rda b/data/opsin.newick.rda
new file mode 100644
index 0000000..2561a99
Binary files /dev/null and b/data/opsin.newick.rda differ
diff --git a/data/woodmouse.rda b/data/woodmouse.rda
new file mode 100644
index 0000000..8b9ef61
Binary files /dev/null and b/data/woodmouse.rda differ
diff --git a/inst/CITATION b/inst/CITATION
new file mode 100644
index 0000000..74c1a5a
--- /dev/null
+++ b/inst/CITATION
@@ -0,0 +1,13 @@
+citHeader("To cite ape in a publication use:")
+
+citEntry(entry="Article",
+ title = "A{PE}: analyses of phylogenetics and evolution in {R} language",
+ author = personList(as.person("E. Paradis"),as.person("J. Claude"), as.person("K. Strimmer")),
+ journal = "Bioinformatics",
+ year = "2004",
+ volume = "20",
+ pages = "289-290",
+
+ textVersion = "Paradis E., Claude J. & Strimmer K. 2004. APE: analyses of phylogenetics and evolution in R language. Bioinformatics 20: 289-290.")
+
+citFooter("As ape is evolving quickly, you may want to cite also its version number (found with 'library(help = ape)').")
\ No newline at end of file
diff --git a/inst/doc/MoranI.R b/inst/doc/MoranI.R
new file mode 100644
index 0000000..63c0f51
--- /dev/null
+++ b/inst/doc/MoranI.R
@@ -0,0 +1,88 @@
+### R code from vignette source 'MoranI.Rnw'
+
+###################################################
+### code chunk number 1: MoranI.Rnw:21-22
+###################################################
+options(width=60)
+
+
+###################################################
+### code chunk number 2: MoranI.Rnw:119-122
+###################################################
+body <- c(4.09434, 3.61092, 2.37024, 2.02815, -1.46968)
+longevity <- c(4.74493, 3.3322, 3.3673, 2.89037, 2.30259)
+names(body) <- names(longevity) <- c("Homo", "Pongo", "Macaca", "Ateles", "Galago")
+
+
+###################################################
+### code chunk number 3: MoranI.Rnw:128-134
+###################################################
+library(ape)
+trnwk <- "((((Homo:0.21,Pongo:0.21):0.28,Macaca:0.49):0.13,Ateles:0.62)"
+trnwk[2] <- ":0.38,Galago:1.00);"
+tr <- read.tree(text = trnwk)
+plot(tr)
+axisPhylo()
+
+
+###################################################
+### code chunk number 4: MoranI.Rnw:140-142
+###################################################
+w <- 1/cophenetic(tr)
+w
+
+
+###################################################
+### code chunk number 5: MoranI.Rnw:146-147
+###################################################
+diag(w) <- 0
+
+
+###################################################
+### code chunk number 6: MoranI.Rnw:151-152
+###################################################
+Moran.I(body, w)
+
+
+###################################################
+### code chunk number 7: MoranI.Rnw:172-173
+###################################################
+Moran.I(body, w, alt = "greater")
+
+
+###################################################
+### code chunk number 8: MoranI.Rnw:178-179
+###################################################
+Moran.I(longevity, w)
+
+
+###################################################
+### code chunk number 9: MoranI.Rnw:240-243
+###################################################
+data(carnivora)
+carnivora$log10SW <- log10(carnivora$SW)
+carnivora$log10FW <- log10(carnivora$FW)
+
+
+###################################################
+### code chunk number 10: MoranI.Rnw:247-250
+###################################################
+fm1.carn <- log10SW ~ Order/SuperFamily/Family/Genus
+co1 <- correlogram.formula(fm1.carn, data = carnivora)
+plot(co1)
+
+
+###################################################
+### code chunk number 11: MoranI.Rnw:265-268
+###################################################
+fm2.carn <- log10SW + log10FW ~ Order/SuperFamily/Family/Genus
+co2 <- correlogram.formula(fm2.carn, data = carnivora)
+print(plot(co2))
+
+
+###################################################
+### code chunk number 12: MoranI.Rnw:276-277
+###################################################
+plot(co2, FALSE)
+
+
diff --git a/inst/doc/MoranI.Rnw b/inst/doc/MoranI.Rnw
new file mode 100644
index 0000000..04de862
--- /dev/null
+++ b/inst/doc/MoranI.Rnw
@@ -0,0 +1,351 @@
+\documentclass[a4paper]{article}
+%\VignetteIndexEntry{Moran's I}
+%\VignettePackage{ape}
+\usepackage{fancyvrb}
+\usepackage{color}
+
+\newcommand{\code}{\texttt}
+\newcommand{\pkg}{\textsf}
+\newcommand{\ape}{\pkg{ape}}
+\newcommand{\ade}{\pkg{ade4}}
+\newcommand{\spatial}{\pkg{spatial}}
+\renewcommand{\sp}{\pkg{sp}}
+
+\author{Emmanuel Paradis}
+\title{Moran's Autocorrelation Coefficient in Comparative Methods}
+
+\begin{document}
+
+\maketitle
+
+<<echo=false,quiet=true>>=
+options(width=60)
+@
+
+This document clarifies the use of Moran's autocorrelation coefficient
+to quantify whether the distribution of a trait among a set of species
+is affected or not by their phylogenetic relationships.
+
+\section{Theoretical Background}
+
+Moran's autocorrelation coefficient (often denoted as $I$) is an
+extension of Pearson product-moment correlation coefficient to a univariate
+series \cite{Cliff1973, Moran1950}. Recall that Pearson's correlation
+(denoted as $\rho$) between two variables $x$ and $y$ both of length $n$ is:
+
+\begin{displaymath}
+\rho = \frac{\displaystyle\sum_{i=1}^n(x_i - \bar{x})(y_i -
+ \bar{y})}{\displaystyle\left[{\sum_{i=1}^n(x_i - \bar{x})^2\sum_{i=1}^n(y_i - \bar{y})^2}\right]^{1/2}},
+\end{displaymath}
+where $\bar{x}$ and $\bar{y}$ are the sample means of both
+variables. $\rho$ measures whether, on average, $x_i$ and $y_i$ are
+associated. For a single variable, say $x$, $I$ will
+measure whether $x_i$ and $x_j$, with $i\ne j$, are associated. Note
+that with $\rho$, $x_i$ and $x_j$ are {\em not} associated since the
+pairs $(x_i,y_i)$ are assumed to be independent of each other.
+
+In the study of spatial patterns and processes, we may logically
+expect that close observations are more likely to be similar than
+those far apart. It is usual to associate a {\em weight} to each
+pair $(x_i,x_j)$ which quantifies this \cite{Cliff1981}. In its simplest
+form, these weights will take values 1 for close neighbours, and 0
+otherwise. We also set $w_{ii}=0$. These weights are sometimes
+referred to as a {\em neighbouring function}.
+
+$I$'s formula is:
+
+\begin{equation}
+I = \frac{n}{S_0}
+\frac{\displaystyle\sum_{i=1}^n \sum_{j=1}^n w_{ij}(x_i - \bar{x})(x_j -
+ \bar{x})}{\displaystyle\sum_{i=1}^n (x_i - \bar{x})^2},\label{eq:morani}
+\end{equation}
+where $w_{ij}$ is the weight between observation $i$ and $j$, and
+$S_0$ is the sum of all $w_{ij}$'s:
+
+\begin{displaymath}
+S_0 = \sum_{i=1}^n \sum_{j=1}^n w_{ij}.
+\end{displaymath}
+
+Quite not so intuitively, the expected value of $I$ under the null
+hypothesis of no autocorrelation is not equal to zero but given by
+$I_0 = -1/(n-1)$. The expected variance of $I_0$ is also known, and
+so we can make a test of the null hypothesis. If the observed value
+of $I$ (denoted $\hat{I}$) is significantly greater than $I_0$, then
+values of $x$ are positively autocorrelated, whereas if $\hat{I}<I_0$,
+this will indicate negative autocorrelation. This allows us to design
+one- or two-tailed tests in the standard way.
+
+Gittleman \& Kot \cite{Gittleman1990} proposed to use Moran's $I$ to
+test for ``phylogenetic effects''. They considered two ways to
+calculate the weights $w$:
+
+\begin{itemize}
+\item With phylogenetic distances among species, e.g., $w_{ij} =
+ 1/d_{ij}$, where $d_{ij}$ are distances measured on a tree.
+\item With taxonomic levels where $w_{ij} = 1$ if species $i$ and $j$
+ belong to the same group, 0 otherwise.
+\end{itemize}
+
+Note that in the first situation, there are quite a lot of
+possibilities to set the weights. For instance, Gittleman \& Kot also proposed:
+
+\[\begin{array}{ll}
+w_{ij} = 1/d_{ij}^\alpha & \mathrm{if}\ d_{ij} \le c\\
+w_{ij} = 0 & \mathrm{if}\ d_{ij} > c,\\
+\end{array}\]
+where $c$ is a cut-off phylogenetic distance above which the species
+are considered to have evolved completely independently, and $\alpha$
+is a coefficient (see \cite{Gittleman1990} for details).
+By analogy to the use of a spatial correlogram where coefficients are
+calculated assuming different sizes of the ``neighbourhood'' and then
+plotted to visualize the spatial extent of autocorrelation, they
+proposed to calculate $I$ at different taxonomic levels.
+
+\section{Implementation in \ape}
+
+From version 1.2-6, \ape\ has functions \code{Moran.I} and
+\code{correlogram.formula} implementing the approach developed by Gittleman \&
+Kot. There was an error in the help pages of \code{?Moran.I}
+(corrected in ver.\ 2.1) where the weights were referred to as
+``distance weights''. This has been wrongly interpreted in my book
+\cite[pp.~139--142]{Paradis2006}. The analyses below aim to correct
+this.
+
+\subsection{Phylogenetic Distances}
+
+The data, taken from \cite{Cheverud1985}, are the log-transformed
+body mass and longevity of five species of primates:
+
+<<>>=
+body <- c(4.09434, 3.61092, 2.37024, 2.02815, -1.46968)
+longevity <- c(4.74493, 3.3322, 3.3673, 2.89037, 2.30259)
+names(body) <- names(longevity) <- c("Homo", "Pongo", "Macaca", "Ateles", "Galago")
+@
+
+The tree has branch lengths scaled so that the root age is one. We
+read the tree with \ape, and plot it:
+
+<<fig=true>>=
+library(ape)
+trnwk <- "((((Homo:0.21,Pongo:0.21):0.28,Macaca:0.49):0.13,Ateles:0.62)"
+trnwk[2] <- ":0.38,Galago:1.00);"
+tr <- read.tree(text = trnwk)
+plot(tr)
+axisPhylo()
+@
+
+We choose the weights as $w_{ij}=1/d_{ij}$, where the $d$'s is the
+distances measured on the tree:
+
+<<>>=
+w <- 1/cophenetic(tr)
+w
+@
+Of course, we must set the diagonal to zero:
+
+<<>>=
+diag(w) <- 0
+@
+We can now perform the analysis with Moran's $I$:
+
+<<>>=
+Moran.I(body, w)
+@
+
+Not surprisingly, the results are opposite to those in
+\cite{Paradis2006} since, there, the distances (given by
+\code{cophenetic(tr)}) were used as weights. (Note that the argument
+\code{dist} has been since renamed \code{weight}.\footnote{The older
+ code was actually correct; nevertheless, it has been rewritten, and
+ is now much faster. The documentation has been clarified.
+ The function \code{correlogram.phylo}, which computed
+ Moran's $I$ for a tree given as argument using the distances among
+ taxa, has been removed.}) We can now conclude for a slighly
+significant positive phylogenetic correlation among body mass values
+for these five species.
+
+The new version of \code{Moran.I} gains the option \code{alternative}
+which specifies the alternative hypothesis (\code{"two-sided"} by
+default, i.e., H$_1$: $I \ne I_0$). As expected from the above result, we divide the $P$-value
+be two if we define H$_1$ as $I > I_0$:
+
+<<>>=
+Moran.I(body, w, alt = "greater")
+@
+
+The same analysis with \code{longevity} gives:
+
+<<>>=
+Moran.I(longevity, w)
+@
+
+As for \code{body}, the results are nearly mirrored compared to
+\cite{Paradis2006} where a non-significant negative phylogenetic
+correlation was found: it is now positive but still largely not
+significant.
+
+\subsection{Taxonomic Levels}
+
+The function \code{correlogram.formula} provides an interface to
+calculate Moran's $I$ for one or several variables giving a series of
+taxonomic levels. An example of its use was provided in
+\cite[pp.~141--142]{Paradis2006}. The code of this function has been
+simplified, and the graphical presentation of the results have been improved.
+
+\code{correlogram.formula}'s main argument is a formula which is ``sliced'',
+and \code{Moran.I} is called for each of these elements. Two things
+have been changed for the end-user at this level:
+
+\begin{enumerate}
+\item In the old version, the rhs of the formula was given in the
+ order of the taxonomic hierarchy: e.g.,
+ \code{Order/SuperFamily/Family/Genus}. Not respecting this order
+ resulted in an error. In the new version, any order is accepted, but
+ the order given it is then respected when plotted the correlogram.
+\item Variable transformations (e.g., log) were allowed on the lhs of
+ the formula. Because of the simplification of the code, this is no
+ more possible. So it is the responsibility of the user to apply any
+ tranformation before the analysis.
+\end{enumerate}
+
+Following Gittleman \& Kot \cite{Gittleman1990}, the autocorrelation at a higher level
+(e.g., family) is calculated among species belonging to the same
+category and to different categories at the level below (genus).
+To formalize this, let us write the different levels as
+$X^1/X^2/X^3/\dots/X^n$ with $X^n$ being the lowest one (\code{Genus} in the
+above formula):
+
+\begin{displaymath}
+\begin{array}{l}
+\left.\begin{array}{ll}
+w_{ij}=1 & \mathrm{if}\ X_i^k = X_j^k\ \mathrm{and}\ X_i^{k+1} \ne X_j^{k+1}\\
+w_{ij}=0 & \mathrm{otherwise}\\
+\end{array} \right\} k < n
+\\\\
+\left.\begin{array}{ll}
+w_{ij}=1 & \mathrm{if}\ X_i^k = X_j^k\\
+w_{ij}=0 & \mathrm{otherwise}\\
+\end{array} \right\} k = n
+\end{array}
+\end{displaymath}
+This is thus different from the idea of a ``neighbourhood'' of
+different sizes, but rather similar to the idea of partial correlation
+where the influence of the lowest level is removed when considering
+the highest ones \cite{Gittleman1990}.
+
+To repeat the analyses on the \code{carnivora} data set, we first
+log$_{10}$-transform the variables mean body mass (\code{SW}) and the
+mean female body mass (\code{FW}):
+
+<<>>=
+data(carnivora)
+carnivora$log10SW <- log10(carnivora$SW)
+carnivora$log10FW <- log10(carnivora$FW)
+@
+We first consider a single variable analysis (as in \cite{Paradis2006}):
+
+<<fig=true>>=
+fm1.carn <- log10SW ~ Order/SuperFamily/Family/Genus
+co1 <- correlogram.formula(fm1.carn, data = carnivora)
+plot(co1)
+@
+
+A legend now appears by default, but can be removed with \code{legend
+= FALSE}. Most of the appearance of the graph can be customized via
+the option of the plot method (see \code{?plot.correlogram} for
+details). This is the same analysis than the one displayed on Fig.~6.3
+of \cite{Paradis2006}.
+
+When a single variable is given in the lhs in
+\code{correlogram.formula}, an object of class \code{"correlogram"} is
+returned as above. If several variables are analysed simultaneously,
+the object returned is of class \code{"correlogramList"}, and the
+correlograms can be plotted together with the appropriate plot method:
+
+<<fig=true>>=
+fm2.carn <- log10SW + log10FW ~ Order/SuperFamily/Family/Genus
+co2 <- correlogram.formula(fm2.carn, data = carnivora)
+print(plot(co2))
+@
+
+By default, lattice is used to plot the correlograms on separate
+panels; using \code{lattice = FALSE} (actually the second argument,
+see \code{?plot.correlogramList}) makes a standard graph superimposing
+the different correlograms:
+
+<<fig=true>>=
+plot(co2, FALSE)
+@
+
+The options are roughly the same than above, but do not have always
+the same effect since lattice and base graphics do not have the same
+graphical parameters. For instance, \code{legend = FALSE} has no
+effect if \code{lattice = TRUE}.
+
+\section{Implementation in \ade}
+
+The analysis done with \ade\ in \cite{Paradis2006} suffers from the
+same error than the one done with \code{Moran.I} since it was also
+done with a distance matrix. So I correct this below:
+
+\begin{Schunk}
+\begin{Sinput}
+> library(ade4)
+> gearymoran(w, data.frame(body, longevity))
+\end{Sinput}
+\begin{Soutput}
+class: krandtest
+Monte-Carlo tests
+Call: as.krandtest(sim = matrix(res$result, ncol = nvar, byr = TRUE),
+ obs = res$obs, alter = alter, names = test.names)
+
+Test number: 2
+Permutation number: 999
+Alternative hypothesis: greater
+
+ Test Obs Std.Obs Pvalue
+1 body -0.06256789 2.1523342 0.001
+2 longevity -0.22990437 0.3461414 0.414
+
+other elements: NULL
+\end{Soutput}
+\end{Schunk}
+
+The results are wholly consistent with those from \ape, but the
+estimated coefficients are substantially different. This is because
+the computational methods are not the same in both packages. In \ade,
+the weight matrix is first transformed as a relative frequency matrix with
+$\tilde{w}_{ij} = w_{ij}/S_0$. The weights are further transformed with:
+
+\begin{displaymath}
+p_{ij} = \tilde{w}_{ij} - \sum_{i=1}^n\tilde{w}_{ij}\sum_{j=1}^n\tilde{w}_{ij},
+\end{displaymath}
+with $p_{ij}$ being the elements of the matrix denoted as $P$. Moran's
+$I$ is finally computed with $x^\mathrm{T}Px$. In \ape, the weights
+are first row-normalized:
+
+\begin{displaymath}
+w_{ij} \Big/ \sum_{i=1}^n w_{ij},
+\end{displaymath}
+then eq.~\ref{eq:morani} is applied.
+
+Another difference between both packages, though less
+important, is that in \ade\ the weight matrix is forced to be
+symmetric with $(W+W^\mathrm{T})/2$. In \ape, this matrix is assumed
+to be symmetric, which is likely to be the case like in the examples above.
+
+\section{Other Implementations}
+
+Package \sp\ has several functions, including
+\code{moran.test}, that are more specifically targeted to the analysis
+of spatial data. Package \spatial\ has the function \code{correlogram}
+that computes and plots spatial correlograms.
+
+\section*{Acknowledgements}
+
+I am thankful to Thibaut Jombart for clarifications on Moran's $I$.
+
+\bibliographystyle{plain}
+\bibliography{ape}
+
+\end{document}
diff --git a/inst/doc/MoranI.pdf b/inst/doc/MoranI.pdf
new file mode 100644
index 0000000..75ecbf2
Binary files /dev/null and b/inst/doc/MoranI.pdf differ
diff --git a/man/CADM.global.Rd b/man/CADM.global.Rd
new file mode 100644
index 0000000..007918b
--- /dev/null
+++ b/man/CADM.global.Rd
@@ -0,0 +1,136 @@
+\name{CADM.global}
+\alias{CADM}
+\alias{CADM.global}
+\alias{CADM.post}
+\title{ Congruence among distance matrices }
+\description{
+Function \code{\link{CADM.global}} compute and test the coefficient of concordance among several distance matrices through a permutation test.
+
+Function \code{\link{CADM.post}} carries out a posteriori permutation tests of the contributions of individual distance matrices to the overall concordance of the group.
+
+Use in phylogenetic analysis: to identify congruence among distance matrices (D) representing different genes or different types of data. Congruent D matrices correspond to data tables that can be used together in a combined phylogenetic or other type of multivariate analysis.
+}
+\usage{
+CADM.global(Dmat, nmat, n, nperm=99, make.sym=TRUE, weights=NULL,
+ silent=FALSE)
+CADM.post (Dmat, nmat, n, nperm=99, make.sym=TRUE, weights=NULL,
+ mult="holm", mantel=FALSE, silent=FALSE)
+}
+
+\arguments{
+ \item{Dmat}{ A text file listing the distance matrices one after the other, with or without blank lines in-between. Each matrix is in the form of a square distance matrix with 0's on the diagonal. }
+ \item{nmat}{ Number of distance matrices in file Dmat. }
+ \item{n}{ Number of objects in each distance matrix. All matrices must have the same number of objects. }
+ \item{nperm}{ Number of permutations for the tests of significance. }
+ \item{make.sym}{ TRUE: turn asymmetric matrices into symmetric matrices by averaging the two triangular portions. FALSE: analyse asymmetric matrices as they are. }
+ \item{weights}{ A vector of positive weights for the distance matrices. Example: weights = c(1,2,3). NULL (default): all matrices have same weight in the calculation of W. }
+ \item{mult}{ Method for correcting P-values in multiple testing. The methods are "holm" (default), "sidak", and "bonferroni". The Bonferroni correction is overly conservative; it is not recommended. It is included to allow comparisons with the other methods. }
+ \item{mantel}{ TRUE: Mantel statistics will be computed from ranked distances, as well as permutational P-values. FALSE (default): Mantel statistics and tests will not be computed. }
+ \item{silent}{ TRUE: informative messages will not be printed, but stopping messages will. Option useful for simulation work. FALSE: informative messages will be printed. }
+}
+\details{
+\code{Dmat} must contain two or more distance matrices, listed one after the other, all of the same size, and corresponding to the same objects in the same order. Raw data tables can be transformed into distance matrices before comparison with other such distance matrices, or with data that have been obtained as distance matrices, e.g. serological or DNA hybridization data. The distances will be transformed to ranks before computation of the coefficient of concordance and other statistics.
+
+\code{CADM.global} tests the global null hypothesis that all matrices are incongruent. If the global null is rejected, function \code{CADM.post} can be used to identify the concordant (H0 rejected) and discordant matrices (H0 not rejected) in the group. If a distance matrix has a negative value for the \code{Mantel.mean} statistic, that matrix clearly does not belong to the group. Remove that matrix (if there are more than one, remove first the matrix that has the most strongly negative [...]
+
+The corrections used for multiple testing are applied to the list of P-values (P) produced in the a posteriori tests; they take into account the number of tests (k) carried out simulatenously (number of matrices, parameter \code{nmat}).
+
+The Holm correction is computed after ordering the P-values in a list with the smallest value to the left. Compute adjusted P-values as:
+
+\deqn{P_{corr} = (k-i+1)*P}{P_corr = (k-i+1)*P}
+
+where i is the position in the ordered list. Final step: from left to right, if an adjusted \eqn{P_{corr}}{P_corr} in the ordered list is smaller than the one occurring at its left, make the smallest one equal to the largest one.
+
+The Sidak correction is:
+
+\deqn{P_{corr} = 1 - (1 - P)^k}{P_corr = 1 - (1 - P)^k}
+
+The Bonferonni correction is:
+
+\deqn{P_{corr} = k*P}{P_corr = k*P}
+}
+
+\value{
+
+\code{CADM.global} produces a small table containing the W, Chi2, and Prob.perm statistics described in the following list.
+\code{CADM.post} produces a table stored in element \code{A_posteriori_tests}, containing Mantel.mean, Prob, and Corrected.prob statistics in rows; the columns correspond to the k distance matrices under study, labeled Dmat.1 to Dmat.k.
+If parameter \code{mantel} is TRUE, tables of Mantel statistics and P-values are computed among the matrices.
+
+ \item{W }{Kendall's coefficient of concordance, W (Kendall and Babington Smith 1939; see also Legendre 2010). }
+ \item{Chi2 }{Friedman's chi-square statistic (Friedman 1937) used in the permutation test of W. }
+ \item{Prob.perm }{Permutational probability. }
+
+ \item{Mantel.mean }{Mean of the Mantel correlations, computed on rank-transformed distances, between the distance matrix under test and all the other matrices in the study. }
+ \item{Prob }{Permutational probabilities, uncorrected. }
+ \item{Corrected prob }{Permutational probabilities corrected using the method selected in parameter \code{mult}. }
+
+ \item{Mantel.cor }{Matrix of Mantel correlations, computed on rank-transformed distances, among the distance matrices. }
+ \item{Mantel.prob }{One-tailed P-values associated with the Mantel correlations of the previous table. The probabilities are computed in the right-hand tail. H0 is tested against the alternative one-tailed hypothesis that the Mantel correlation under test is positive. No correction is made for multiple testing. }
+}
+
+\references{
+Campbell, V., Legendre, P. and Lapointe, F.-J. (2009) Assessing congruence among ultrametric distance matrices. \emph{Journal of Classification}, \bold{26}, 103--117.
+
+Campbell, V., Legendre, P. and Lapointe, F.-J. (2011) The performance of the Congruence Among Distance Matrices (CADM) test in phylogenetic analysis. \emph{BMC Evolutionary Biology}, \bold{11}, 64. \url{http://www.biomedcentral.com/1471-2148/11/64}.
+
+Friedman, M. (1937) The use of ranks to avoid the assumption of normality implicit in the analysis of variance. \emph{Journal of the American Statistical Association}, \bold{32}, 675--701.
+
+Kendall, M. G. and Babington Smith, B. (1939) The problem of m rankings. \emph{Annals of Mathematical Statistics}, \bold{10}, 275--287.
+
+Lapointe, F.-J., Kirsch, J. A. W. and Hutcheon, J. M. (1999) Total evidence, consensus, and bat phylogeny: a distance-based approach. \emph{Molecular Phylogenetics and Evolution}, \bold{11}, 55--66.
+
+Legendre, P. (2010) Coefficient of concordance. Pp. 164-169 in: Encyclopedia of Research Design, Vol. 1. N. J. Salkind, ed. SAGE Publications, Inc., Los Angeles.
+
+Legendre, P. and Lapointe, F.-J. (2004) Assessing congruence among distance matrices: single malt Scotch whiskies
+revisited. \emph{Australian and New Zealand Journal of Statistics}, \bold{46}, 615--629.
+
+Legendre, P. and Lapointe, F.-J. (2005) Congruence entre matrices de distance. P. 178-181 in: Makarenkov, V., G. Cucumel et F.-J. Lapointe [eds] Comptes rendus des 12emes Rencontres de la Societe Francophone de Classification, Montreal, 30 mai - 1er juin 2005.
+
+Siegel, S. and Castellan, N. J., Jr. (1988) \emph{Nonparametric statistics for the behavioral sciences. 2nd edition}. New York: McGraw-Hill.
+}
+
+\author{Pierre Legendre, Universite de Montreal}
+
+\examples{
+# Examples 1 and 2: 5 genetic distance matrices computed from simulated DNA
+# sequences representing 50 taxa having evolved along additive trees with
+# identical evolutionary parameters (GTR+ Gamma + I). Distance matrices were
+# computed from the DNA sequence matrices using a p distance corrected with the
+# same parameters as those used to simulate the DNA sequences. See Campbell et
+# al. (2009) for details.
+
+# Example 1: five independent additive trees. Data provided by V. Campbell.
+
+data(mat5Mrand)
+res.global <- CADM.global(mat5Mrand, 5, 50)
+
+# Example 2: three partly similar trees, two independent trees.
+# Data provided by V. Campbell.
+
+data(mat5M3ID)
+res.global <- CADM.global(mat5M3ID, 5, 50)
+res.post <- CADM.post(mat5M3ID, 5, 50, mantel=TRUE)
+
+# Example 3: three matrices respectively representing Serological
+# (asymmetric), DNA hybridization (asymmetric) and Anatomical (symmetric)
+# distances among 9 families. Data from Lapointe et al. (1999).
+
+data(mat3)
+res.global <- CADM.global(mat3, 3, 9, nperm=999)
+res.post <- CADM.post(mat3, 3, 9, nperm=999, mantel=TRUE)
+
+# Example 4, showing how to bind two D matrices (cophenetic matrices
+# in this example) into a file using rbind(), then run the global test.
+
+a <- rtree(5)
+b <- rtree(5)
+A <- cophenetic(a)
+B <- cophenetic(b)
+x <- rownames(A)
+B <- B[x, x]
+M <- rbind(A, B)
+CADM.global(M, 2, 5)
+}
+
+\keyword{ multivariate }
+\keyword{ nonparametric }
diff --git a/man/DNAbin.Rd b/man/DNAbin.Rd
new file mode 100644
index 0000000..020f6f7
--- /dev/null
+++ b/man/DNAbin.Rd
@@ -0,0 +1,114 @@
+\name{DNAbin}
+\alias{DNAbin}
+\alias{print.DNAbin}
+\alias{[.DNAbin}
+\alias{rbind.DNAbin}
+\alias{cbind.DNAbin}
+\alias{as.matrix.DNAbin}
+\alias{c.DNAbin}
+\alias{as.list.DNAbin}
+\alias{labels.DNAbin}
+\title{Manipulate DNA Sequences in Bit-Level Format}
+\description{
+ These functions help to manipulate DNA sequences coded in the
+ bit-level coding scheme.
+}
+\usage{
+\method{print}{DNAbin}(x, printlen = 6, digits = 3, \dots)
+\method{rbind}{DNAbin}(\dots)
+\method{cbind}{DNAbin}(\dots, check.names = TRUE, fill.with.gaps = FALSE,
+ quiet = FALSE)
+\method{[}{DNAbin}(x, i, j, drop = FALSE)
+\method{as.matrix}{DNAbin}(x, \dots)
+\method{c}{DNAbin}(\dots, recursive = FALSE)
+\method{as.list}{DNAbin}(x, \dots)
+\method{labels}{DNAbin}(object, \dots)
+}
+\arguments{
+ \item{x, object}{an object of class \code{"DNAbin"}.}
+ \item{\dots}{either further arguments to be passed to or from other
+ methods in the case of \code{print}, \code{as.matrix}, and
+ \code{labels}, or a series of objects of class \code{"DNAbin"} in the
+ case of \code{rbind}, \code{cbind}, and \code{c}.}
+ \item{printlen}{the number of labels to print (6 by default).}
+ \item{digits}{the number of digits to print (3 by default).}
+ \item{check.names}{a logical specifying whether to check the rownames
+ before binding the columns (see details).}
+ \item{fill.with.gaps}{a logical indicating whether to keep all
+ possible individuals as indicating by the rownames, and eventually
+ filling the missing data with insertion gaps (ignored if
+ \code{check.names = FALSE}).}
+ \item{quiet}{a logical to switch off warning messages when some rows
+ are dropped.}
+ \item{i, j}{indices of the rows and/or columns to select or to drop.
+ They may be numeric, logical, or character (in the same way than for
+ standard \R objects).}
+ \item{drop}{logical; if \code{TRUE}, the returned object is of the
+ lowest possible dimension.}
+ \item{recursive}{for compatibility with the generic (unused).}
+}
+\details{
+ These are all `methods' of generic functions which are here applied to
+ DNA sequences stored as objects of class \code{"DNAbin"}. They are
+ used in the same way than the standard \R functions to manipulate
+ vectors, matrices, and lists. Additionally, the operators \code{[[}
+ and \code{$} may be used to extract a vector from a list. Note that
+ the default of \code{drop} is not the same than the generic operator:
+ this is to avoid dropping rownames when selecting a single sequence.
+
+ These functions are provided to manipulate easily DNA sequences coded
+ with the bit-level coding scheme. The latter allows much faster
+ comparisons of sequences, as well as storing them in less memory
+ compared to the format used before \pkg{ape} 1.10.
+
+ For \code{cbind}, the default behaviour is to keep only individuals
+ (as indicated by the rownames) for which there are no missing data. If
+ \code{fill.with.gaps = TRUE}, a `complete' matrix is returned,
+ enventually with insertion gaps as missing data. If \code{check.names
+ = TRUE} (the default), the rownames of each matrix are checked, and
+ the rows are reordered if necessary. If \code{check.names = FALSE},
+ the matrices must all have the same number of rows, and are simply
+ binded; the rownames of the first matrix are used. See the examples.
+
+ \code{as.matrix} may be used to convert DNA sequences (of the same
+ length) stored in a list into a matrix while keeping the names and the
+ class. \code{as.list} does the reverse operation.
+}
+\value{
+ an object of class \code{"DNAbin"} in the case of \code{rbind},
+ \code{cbind}, and \code{[}.
+}
+\references{
+ Paradis, E. (2007) A Bit-Level Coding Scheme for Nucleotides.
+ \url{http://ape.mpl.ird.fr/misc/BitLevelCodingScheme_20April2007.pdf}
+
+ Paradis, E. (2012) \emph{Analysis of Phylogenetics and Evolution with
+ R (Second Edition).} New York: Springer.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{as.DNAbin}}, \code{\link{read.dna}},
+ \code{\link{read.GenBank}}, \code{\link{write.dna}},
+ \code{\link{image.DNAbin}}
+
+ The corresponding generic functions are documented in the package
+ \pkg{base}.
+}
+\examples{
+data(woodmouse)
+woodmouse
+print(woodmouse, 15, 6)
+print(woodmouse[1:5, 1:300], 15, 6)
+### Just to show how distances could be influenced by sampling:
+dist.dna(woodmouse[1:2, ])
+dist.dna(woodmouse[1:3, ])
+### cbind and its options:
+x <- woodmouse[1:2, 1:5]
+y <- woodmouse[2:4, 6:10]
+as.character(cbind(x, y)) # gives warning
+as.character(cbind(x, y, fill.with.gaps = TRUE))
+\dontrun{
+as.character(cbind(x, y, check.names = FALSE)) # gives an error
+}
+}
+\keyword{manip}
diff --git a/man/Initialize.corPhyl.Rd b/man/Initialize.corPhyl.Rd
new file mode 100644
index 0000000..875e39e
--- /dev/null
+++ b/man/Initialize.corPhyl.Rd
@@ -0,0 +1,24 @@
+\name{Initialize.corPhyl}
+\alias{Initialize.corPhyl}
+\title{Initialize a `corPhyl' Structure Object}
+\usage{
+ \method{Initialize}{corPhyl}(object, data, ...)
+}
+\arguments{
+ \item{object}{An object inheriting from class \code{corPhyl}.}
+ \item{data}{The data to use. If it contains rownames, they are matched with the tree tip labels, otherwise data are supposed to be in the same order than tip labels and a warning is sent.}
+ \item{\dots}{some methods for this generic require additional arguments. None are used in this method.}
+}
+\description{
+ Initialize a \code{corPhyl} correlation structure object.
+ Does the same as \code{Initialize.corStruct}, but also checks the row names of data and builds an index.
+}
+\value{
+ An initialized object of same class as \code{object}.
+}
+\author{Julien Dutheil \email{julien.dutheil at univ-montp2.fr}}
+\seealso{
+ \code{\link{corClasses}}, \code{\link[nlme]{Initialize.corStruct}}.
+}
+\keyword{models}
+\keyword{manip}
diff --git a/man/LTT.Rd b/man/LTT.Rd
new file mode 100644
index 0000000..7ef9012
--- /dev/null
+++ b/man/LTT.Rd
@@ -0,0 +1,74 @@
+\name{LTT}
+\alias{LTT}
+\title{Theoretical Lineage-Through Time Plots}
+\description{
+ This function draws the lineage-through time (LTT) plots predicted
+ under a speciation-extinction model (aka birth-death model) with
+ specified values of speciation and extinction rates (which may vary
+ with time).
+
+ A prediction interval is plotted by default which requires to define a
+ sample size (100 by default), and different curves can be combined.
+}
+\usage{
+LTT(birth = 0.1, death = 0, N = 100, Tmax = 50, PI = 95,
+ scaled = TRUE, eps = 0.1, add = FALSE, backward = TRUE,
+ ltt.style = list("black", 1, 1), pi.style = list("blue", 1, 2))
+}
+\arguments{
+ \item{birth}{the speciation rate, this may be either a numeric value
+ or a funtion of time (named \code{t} in the code of the function).}
+ \item{death}{id. for the extinction rate.}
+ \item{N}{the size of the tree.}
+ \item{Tmax}{the age of the root of the tree.}
+ \item{PI}{the percentage value of the prediction interval; set this
+ value to 0 to not draw this interval.}
+ \item{scaled}{a logical values specifying whether to scale the
+ \eqn{y}-axis between 0 and 1.}
+ \item{eps}{a numerical value giving the resolution of the time axis.}
+ \item{add}{a logical values specifying whether to make a new plot (the
+ default).}
+ \item{backward}{a logical value: should the time axis be traced from
+ the present (the default), or from the root of the tree?}
+ \item{ltt.style}{a list with three elements giving the style of the
+ LTT curve with, respectively, the colour (\code{"col"}), the line
+ thickness (\code{"lwd"}), and the line type (\code{"lty"}).}
+ \item{pi.style}{id. for the prediction interval.}
+}
+\details{
+ For the moment, this works well when \code{birth} and \code{death} are
+ constant. Some improvements are under progress for time-dependent
+ rates (but see below for and example).
+}
+\references{
+ Paradis, E. (2011) Time-dependent speciation and extinction from
+ phylogenies: a least squares approach. \emph{Evolution}, \bold{65},
+ 661--672.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{ltt.plot}}
+}
+\examples{
+### predicted LTT plot under a Yule model with lambda = 0.1
+### and 50 species after 50 units of time...
+LTT(N = 50)
+### ... and with a birth-death model with the same rate of
+### diversification (try with N = 500):
+LTT(0.2, 0.1, N = 50, PI = 0, add = TRUE, ltt.style = list("red", 2, 1))
+### predictions under different tree sizes:
+layout(matrix(1:4, 2, 2, byrow = TRUE))
+for (N in c(50, 100, 500, 1000)) {
+ LTT(0.2, 0.1, N = N)
+ title(paste("N =", N))
+}
+layout(1)
+\dontrun{
+### speciation rate decreasing with time
+birth.logis <- function(t) 1/(1 + exp(0.02 * t + 4))
+LTT(birth.logis)
+LTT(birth.logis, 0.05)
+LTT(birth.logis, 0.1)
+}
+}
+\keyword{hplot}
diff --git a/man/MPR.Rd b/man/MPR.Rd
new file mode 100644
index 0000000..cf4e69a
--- /dev/null
+++ b/man/MPR.Rd
@@ -0,0 +1,69 @@
+\name{MPR}
+\alias{MPR}
+\title{Most Parsimonious Reconstruction}
+\description{
+ This function does ancestral character reconstruction by parsimony as
+ described in Hanazawa et al. (1995) and modified by Narushima and
+ Hanazawa (1997).
+}
+\usage{
+MPR(x, phy, outgroup)
+}
+\arguments{
+ \item{x}{a vector of integers.}
+ \item{phy}{an object of class \code{"phylo"}; the tree must be
+ unrooted and fully dichotomous.}
+ \item{outgroup}{an integer or a character string giving the tip of
+ \code{phy} used as outgroup.}
+}
+\details{
+ Hanazawa et al. (1995) and Narushima and Hanazawa (1997) used Farris's
+ (1970) and Swofford and Maddison's (1987) framework to reconstruct
+ ancestral states using parsimony. The character is assumed to take
+ integer values. The algorithm finds the sets of values for each node
+ as intervals with lower and upper values.
+
+ It is recommended to root the tree with the outgroup before the
+ analysis, so plotting the values with \code{\link{nodelabels}} is
+ simple.
+}
+\value{
+ a matrix of integers with two columns named ``lower'' and ``upper''
+ giving the lower and upper values of the reconstructed sets for each
+ node.
+}
+\references{
+ Farris, J. M. (1970) Methods for computing Wagner trees.
+ \emph{Systematic Zoology}, \bold{19}, 83--92.
+
+ Hanazawa, M., Narushima, H. and Minaka, N. (1995) Generating most
+ parsimonious reconstructions on a tree: a generalization of the
+ Farris--Swofford--Maddison method. \emph{Discrete Applied
+ Mathematics}, \bold{56}, 245--265.
+
+ Narushima, H. and Hanazawa, M. (1997) A more efficient algorithm for
+ MPR problems in phylogeny. \emph{Discrete Applied Mathematics},
+ \bold{80}, 231--238.
+
+ Swofford, D. L. and Maddison, W. P. (1987) Reconstructing ancestral
+ character states under Wagner parsimony. \emph{Mathematical
+ Biosciences}, \bold{87}, 199--229.
+}\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{ace}}, \code{\link{root}}, \code{\link{nodelabels}}
+}
+\examples{
+## the example in Narushima and Hanazawa (1997):
+tr <- read.tree(text = "(((i,j)c,(k,l)b)a,(h,g)e,f)d;")
+x <- c(1, 3, 0, 6, 5, 2, 4)
+names(x) <- letters[6:12]
+(o <- MPR(x, tr, "f"))
+plot(tr)
+nodelabels(paste("[", o[, 1], ",", o[, 2], "]", sep = ""))
+tiplabels(x[tr$tip.label], adj = -2)
+## some random data:
+x <- rpois(30, 1)
+tr <- rtree(30, rooted = FALSE)
+MPR(x, tr, "t1")
+}
+\keyword{models}
diff --git a/man/MoranI.Rd b/man/MoranI.Rd
new file mode 100644
index 0000000..fd7b28e
--- /dev/null
+++ b/man/MoranI.Rd
@@ -0,0 +1,79 @@
+\name{Moran.I}
+\alias{Moran.I}
+\title{Moran's I Autocorrelation Index}
+\usage{
+ Moran.I(x, weight, scaled = FALSE, na.rm = FALSE,
+ alternative = "two.sided")
+}
+\arguments{
+ \item{x}{a numeric vector.}
+ \item{weight}{a matrix of weights.}
+ \item{scaled}{a logical indicating whether the coefficient should be
+ scaled so that it varies between -1 and +1 (default to
+ \code{FALSE}).}
+ \item{na.rm}{a logical indicating whether missing values should be
+ removed.}
+ \item{alternative}{a character string specifying the alternative
+ hypothesis that is tested against the null hypothesis of no
+ phylogenetic correlation; must be of one "two.sided", "less", or
+ "greater", or any unambiguous abbrevation of these.}
+}
+\description{
+ This function computes Moran's I autocorrelation coefficient of
+ \code{x} giving a matrix of weights using the method described by
+ Gittleman and Kot (1990).
+}
+\details{
+ The matrix \code{weight} is used as ``neighbourhood'' weights, and
+ Moran's I coefficient is computed using the formula:
+ \deqn{I = \frac{n}{S_0} \frac{\sum_{i=1}^n\sum_{j=1}^n w_{i,j}(y_i -
+ \overline{y})(y_j - \overline{y})}{\sum_{i=1}^n {(y_i -
+ \overline{y})}^2}}{\code{I = n/S0 * (sum\{i=1..n\} sum\{j=1..n\} wij(yi - ym))(yj - ym)
+ / (sum\{i=1..n\} (yi - ym)^2)}}
+ with
+ \itemize{
+ \item \eqn{y_i}{yi} = observations
+ \item \eqn{w_{i,j}}{wij} = distance weight
+ \item \eqn{n} = number of observations
+ \item \eqn{S_0}{S0} = \eqn{\sum_{i=1}^n\sum_{j=1}^n wij}{\code{sum_{i=1..n} sum{j=1..n} wij}}
+ }
+
+ The null hypothesis of no phylogenetic correlation is tested assuming
+ normality of I under this null hypothesis. If the observed value
+ of I is significantly greater than the expected value, then the values
+ of \code{x} are positively autocorrelated, whereas if Iobserved <
+ Iexpected, this will indicate negative autocorrelation.
+}
+\value{
+ A list containing the elements:
+
+ \item{observed}{the computed Moran's I.}
+ \item{expected}{the expected value of I under the null hypothesis.}
+ \item{sd}{the standard deviation of I under the null hypothesis.}
+ \item{p.value}{the P-value of the test of the null hypothesis against
+ the alternative hypothesis specified in \code{alternative}.}
+}
+\references{
+ Gittleman, J. L. and Kot, M. (1990) Adaptation: statistics and a null
+ model for estimating phylogenetic effects. \emph{Systematic Zoology},
+ \bold{39}, 227--241.
+}
+\author{Julien Dutheil \email{julien.dutheil at univ-montp2.fr} and
+ Emmanuel Paradis}
+\seealso{
+ \code{\link{weight.taxo}}
+}
+\examples{
+tr <- rtree(30)
+x <- rnorm(30)
+## weights w[i,j] = 1/d[i,j]:
+w <- 1/cophenetic(tr)
+## set the diagonal w[i,i] = 0 (instead of Inf...):
+diag(w) <- 0
+Moran.I(x, w)
+Moran.I(x, w, alt = "l")
+Moran.I(x, w, alt = "g")
+Moran.I(x, w, scaled = TRUE) # usualy the same
+}
+\keyword{models}
+\keyword{regression}
diff --git a/man/SDM.Rd b/man/SDM.Rd
new file mode 100644
index 0000000..e3c0028
--- /dev/null
+++ b/man/SDM.Rd
@@ -0,0 +1,39 @@
+\name{SDM}
+\alias{SDM}
+\title{Construction of Consensus Distance Matrix With SDM}
+\description{
+ This function implements the SDM method of Criscuolo et al. (2006) for
+ a set of n distance matrices.
+}
+\usage{
+SDM(...)
+}
+\arguments{
+ \item{\dots}{2n elements (with n > 1), the first n elements are the
+ distance matrices: these can be (symmetric) matrices, objects of
+ class \code{"dist"}, or a mix of both. The next n elements are the
+ sequence length from which the matrices have been estimated (can be
+ seen as a degree of confidence in matrices).}
+}
+\details{
+ Reconstructs a consensus distance matrix from a set of input distance
+ matrices on overlapping sets of taxa. Potentially missing values in
+ the supermatrix are represented by \code{NA}. An error is returned if
+ the input distance matrices can not resolve to a consensus matrix.
+}
+\value{
+ a 2-element list containing a distance matrix labelled by the union of
+ the set of taxa of the input distance matrices, and a variance matrix
+ associated to the returned distance matrix.
+}
+\references{
+ Criscuolo, A., Berry, V., Douzery, E. J. P. , and Gascuel, O. (2006)
+ SDM: A fast distance-based approach for (super)tree building in
+ phylogenomics. \emph{Systematic Biology}, \bold{55}, 740--755.
+}
+\author{Andrei Popescu \email{niteloserpopescu at gmail.com}}
+\seealso{
+ \code{\link{bionj}}, \code{\link{fastme}}, \code{\link{njs}},
+ \code{\link{mvrs}}, \code{\link{triangMtd}}
+}
+\keyword{models}
diff --git a/man/ace.Rd b/man/ace.Rd
new file mode 100644
index 0000000..1461ff0
--- /dev/null
+++ b/man/ace.Rd
@@ -0,0 +1,207 @@
+\name{ace}
+\alias{ace}
+\alias{print.ace}
+\alias{logLik.ace}
+\alias{deviance.ace}
+\alias{AIC.ace}
+\alias{anova.ace}
+\title{Ancestral Character Estimation}
+\description{
+ This function estimates ancestral character states, and the associated
+ uncertainty, for continuous and discrete characters.
+
+ \code{logLik}, \code{deviance}, and \code{AIC} are generic functions
+ used to extract the log-likelihood, the deviance, or the Akaike
+ information criterion of a fitted object. If no such values are
+ available, \code{NULL} is returned.
+
+ \code{anova} is another generic function which is used to compare
+ nested models: the significance of the additional parameter(s) is
+ tested with likelihood ratio tests. You must ensure that the models
+ are effectively nested (if they are not, the results will be
+ meaningless). It is better to list the models from the smallest to the
+ largest.
+}
+\usage{
+ace(x, phy, type = "continuous", method = if (type == "continuous")
+ "REML" else "ML", CI = TRUE,
+ model = if (type == "continuous") "BM" else "ER",
+ scaled = TRUE, kappa = 1, corStruct = NULL, ip = 0.1,
+ use.expm = FALSE, use.eigen = TRUE)
+\method{print}{ace}(x, digits = 4, ...)
+\method{logLik}{ace}(object, ...)
+\method{deviance}{ace}(object, ...)
+\method{AIC}{ace}(object, ..., k = 2)
+\method{anova}{ace}(object, ...)
+}
+\arguments{
+ \item{x}{a vector or a factor; an object of class \code{"ace"} in the
+ case of \code{print}.}
+ \item{phy}{an object of class \code{"phylo"}.}
+ \item{type}{the variable type; either \code{"continuous"} or
+ \code{"discrete"} (or an abbreviation of these).}
+ \item{method}{a character specifying the method used for
+ estimation. Four choices are possible: \code{"ML"}, \code{"REML"},
+ \code{"pic"}, or \code{"GLS"}.}
+ \item{CI}{a logical specifying whether to return the 95\% confidence
+ intervals of the ancestral state estimates (for continuous
+ characters) or the likelihood of the different states (for discrete
+ ones).}
+ \item{model}{a character specifying the model (ignored if \code{method
+ = "GLS"}), or a numeric matrix if \code{type = "discrete"} (see
+ details).}
+ \item{scaled}{a logical specifying whether to scale the contrast
+ estimate (used only if \code{method = "pic"}).}
+ \item{kappa}{a positive value giving the exponent transformation of
+ the branch lengths (see details).}
+ \item{corStruct}{if \code{method = "GLS"}, specifies the correlation
+ structure to be used (this also gives the assumed model).}
+ \item{ip}{the initial value(s) used for the ML estimation procedure
+ when \code{type == "discrete"} (possibly recycled).}
+ \item{use.expm}{a logical specifying whether to use the package
+ \pkg{expm} to compute the matrix exponential (relevant only if
+ \code{type = "d"}). If \code{FALSE}, the function \code{matexpo}
+ from \pkg{ape} is used (see details). This option is ignored if
+ \code{use.eigen = TRUE} (see next).}
+ \item{use.eigen}{a logical (relevant if \code{type = "d"}); if
+ \code{TRUE} then the probability matrix is computed with an eigen
+ decomposition instead of a matrix exponential (see details).}
+ \item{digits}{the number of digits to be printed.}
+ \item{object}{an object of class \code{"ace"}.}
+ \item{k}{a numeric value giving the penalty per estimated parameter;
+ the default is \code{k = 2} which is the classical Akaike
+ information criterion.}
+ \item{\dots}{further arguments passed to or from other methods.}
+}
+\details{
+ If \code{type = "continuous"}, the default model is Brownian motion
+ where characters evolve randomly following a random walk. This model
+ can be fitted by residual maximum likelihood (the default), maximum
+ likelihood (Felsenstein 1973, Schluter et al. 1997), least squares
+ (\code{method = "pic"}, Felsenstein 1985), or generalized least
+ squares (\code{method = "GLS"}, Martins and Hansen 1997, Cunningham et
+ al. 1998). In the last case, the specification of \code{phy} and
+ \code{model} are actually ignored: it is instead given through a
+ correlation structure with the option \code{corStruct}.
+
+ In the setting \code{method = "ML"} and \code{model = "BM"} (this used
+ to be the default until \pkg{ape} 3.0-7) the maximum likelihood
+ estimation is done simultaneously on the ancestral values and the
+ variance of the Brownian motion process; these estimates are then used
+ to compute the confidence intervals in the standard way. The REML
+ method first estimates the ancestral value at the root (aka, the
+ phylogenetic mean), then the variance of the Brownian motion process
+ is estimated by optimizing the residual log-likelihood. The ancestral
+ values are finally inferred from the likelihood function giving these
+ two parameters. If \code{method = "pic"} or \code{"GLS"}, the
+ confidence intervals are computed using the expected variances under
+ the model, so they depend only on the tree.
+
+ It could be shown that, with a continous character, REML results in
+ unbiased estimates of the variance of the Brownian motion process
+ while ML gives a downward bias. Therefore the former is recommanded.
+
+ For discrete characters (\code{type = "discrete"}), only maximum
+ likelihood estimation is available (Pagel 1994) (see \code{\link{MPR}}
+ for an alternative method). The model is specified through a numeric
+ matrix with integer values taken as indices of the parameters. The
+ numbers of rows and of columns of this matrix must be equal, and are
+ taken to give the number of states of the character. For instance,
+ \code{matrix(c(0, 1, 1, 0), 2)} will represent a model with two
+ character states and equal rates of transition, \code{matrix(c(0, 1,
+ 2, 0), 2)} a model with unequal rates, \code{matrix(c(0, 1, 1, 1, 0,
+ 1, 1, 1, 0), 3)} a model with three states and equal rates of
+ transition (the diagonal is always ignored). There are short-cuts to
+ specify these models: \code{"ER"} is an equal-rates model (e.g., the
+ first and third examples above), \code{"ARD"} is an
+ all-rates-different model (the second example), and \code{"SYM"} is a
+ symmetrical model (e.g., \code{matrix(c(0, 1, 2, 1, 0, 3, 2, 3, 0),
+ 3)}). If a short-cut is used, the number of states is determined from
+ the data.
+
+ With discrete characters it is necessary to compute the exponential of
+ the rate matrix. The only possibility until \pkg{ape} 3.0-7) was the
+ function \code{\link{matexpo}} in \pkg{ape}. If \code{use.expm = TRUE}
+ and \code{use.eigen = FALSE}, the function \code{\link[expm]{expm}},
+ in the package of the same name, is used. \code{matexpo} is faster but
+ quite inaccurate for large and/or asymmetric matrices. In case of
+ doubt, use the latter. Since \pkg{ape} 3.0-10, it is possible to use
+ an eigen decomposition avoiding the need to compute the matrix
+ exponential; see details in Lebl (2013, sect. 3.8.3). This is much
+ faster and is now the default.
+}
+\value{
+ an object of class \code{"ace"} with the following elements:
+
+ \item{ace}{if \code{type = "continuous"}, the estimates of the
+ ancestral character values.}
+ \item{CI95}{if \code{type = "continuous"}, the estimated 95\%
+ confidence intervals.}
+ \item{sigma2}{if \code{type = "continuous"}, \code{model = "BM"}, and
+ \code{method = "ML"}, the maximum likelihood estimate of the
+ Brownian parameter.}
+ \item{rates}{if \code{type = "discrete"}, the maximum likelihood
+ estimates of the transition rates.}
+ \item{se}{if \code{type = "discrete"}, the standard-errors of
+ estimated rates.}
+ \item{index.matrix}{if \code{type = "discrete"}, gives the indices of
+ the \code{rates} in the rate matrix.}
+ \item{loglik}{if \code{method = "ML"}, the maximum log-likelihood.}
+ \item{lik.anc}{if \code{type = "discrete"}, the scaled likelihoods of
+ each ancestral state.}
+ \item{call}{the function call.}
+}
+\references{
+ Cunningham, C. W., Omland, K. E. and Oakley, T. H. (1998)
+ Reconstructing ancestral character states: a critical
+ reappraisal. \emph{Trends in Ecology & Evolution}, \bold{13},
+ 361--366.
+
+ Felsenstein, J. (1973) Maximum likelihood estimation
+ of evolutionary trees from continuous characters. \emph{American
+ Journal of Human Genetics}, \bold{25}, 471--492.
+
+ Felsenstein, J. (1985) Phylogenies and the comparative
+ method. \emph{American Naturalist}, \bold{125}, 1--15.
+
+ Lebl, J. (2013) \emph{Notes on Diffy Qs: Differential Equations for
+ Engineers}. \url{http://www.jirka.org/diffyqs/}.
+
+ Martins, E. P. and Hansen, T. F. (1997) Phylogenies and the
+ comparative method: a general approach to incorporating phylogenetic
+ information into the analysis of interspecific data. \emph{American
+ Naturalist}, \bold{149}, 646--667.
+
+ Pagel, M. (1994) Detecting correlated evolution on phylogenies: a
+ general method for the comparative analysis of discrete
+ characters. \emph{Proceedings of the Royal Society of London. Series
+ B. Biological Sciences}, \bold{255}, 37--45.
+
+ 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{Emmanuel Paradis, Ben Bolker}
+\seealso{
+ \code{\link{MPR}}, \code{\link{corBrownian}}, \code{\link{corGrafen}},
+ \code{\link{corMartins}}, \code{\link{compar.ou}}, \code{\link[stats]{anova}}
+}
+\examples{
+### Just some random data...
+data(bird.orders)
+x <- rnorm(23)
+### Compare the three methods for continuous characters:
+ace(x, bird.orders)
+ace(x, bird.orders, method = "pic")
+ace(x, bird.orders, method = "GLS",
+ corStruct = corBrownian(1, bird.orders))
+### For discrete characters:
+x <- factor(c(rep(0, 5), rep(1, 18)))
+ans <- ace(x, bird.orders, type = "d")
+#### Showing the likelihoods on each node:
+plot(bird.orders, type = "c", FALSE, label.offset = 1)
+co <- c("blue", "yellow")
+tiplabels(pch = 22, bg = co[as.numeric(x)], cex = 2, adj = 1)
+nodelabels(thermo = ans$lik.anc, piecol = co, cex = 0.75)
+}
+\keyword{models}
diff --git a/man/add.scale.bar.Rd b/man/add.scale.bar.Rd
new file mode 100644
index 0000000..3f1ee59
--- /dev/null
+++ b/man/add.scale.bar.Rd
@@ -0,0 +1,51 @@
+\name{add.scale.bar}
+\alias{add.scale.bar}
+\title{Add a Scale Bar to a Phylogeny Plot}
+\usage{
+add.scale.bar(x, y, length = NULL, ask = FALSE,
+ lwd = 1, lcol = "black", ...)
+}
+\arguments{
+ \item{x}{x location of the bar (can be left missing).}
+ \item{y}{y location of the bar (can be left missing).}
+ \item{length}{a numeric value giving the length of the scale bar. If
+ none is supplied, a value is calculated from the data.}
+ \item{ask}{a logical; if \code{TRUE} the user is asked to click where
+ to draw the bar. The default is \code{FALSE}.}
+ \item{lwd}{the width of the bar.}
+ \item{lcol}{the colour of the bar (use \code{col} for the colour of
+ the text).}
+ \item{\dots}{further arguments to be passed to \code{text}.}
+}
+\description{
+ This function adds a horizontal bar giving the scale of the branch
+ lengths to a plot of a phylogenetic tree on the current graphical
+ device.
+}
+\details{
+ By default, the bar is placed in a corner of the graph depending on
+ the direction of the tree. Otherwise both \code{x} and \code{y} must
+ be specified (if only one is given it is ignored).
+
+ The further arguments (\code{\dots}) are used to format the text. They
+ may be \code{font}, \code{cex}, \code{col}, and so on (see examples
+ below, and the help page on \code{\link[graphics]{text}}).
+
+ The function \code{\link[graphics]{locator}} may be used to
+ determine the \code{x} and \code{y} arguments.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{plot.phylo}}, \code{\link{axisPhylo}},
+ \code{\link[graphics]{locator}}
+}
+\examples{
+tr <- rtree(10)
+layout(matrix(1:2, 2, 1))
+plot(tr)
+add.scale.bar()
+plot(tr)
+add.scale.bar(cex = 0.7, font = 2, col = "red")
+layout(matrix(1))
+}
+\keyword{aplot}
diff --git a/man/additive.Rd b/man/additive.Rd
new file mode 100644
index 0000000..df8c649
--- /dev/null
+++ b/man/additive.Rd
@@ -0,0 +1,26 @@
+\name{additive}
+\alias{additive}
+\alias{ultrametric}
+\title{Incomplete Distance Matrix Filling}
+\description{
+ Fills missing entries from incomplete distance matrix using the
+ additive or the ultrametric procedure (see reference for details).
+}
+\usage{
+additive(X)
+ultrametric(X)
+}
+\arguments{
+ \item{X}{a distance matrix or an object of class \code{"dist"}.}
+}
+\value{
+ a distance matrix.
+}
+\references{
+ Makarenkov, V. and Lapointe, F.-J. (2004) A weighted least-squares
+ approach for inferring phylogenies from incomplete distance
+ matrices. \emph{Bioinformatics}, \bold{20}, 2113--2121.
+ \url{http://dx.doi.org/10.1093/bioinformatics/bth211}
+}
+\author{Andrei Popescu \email{niteloserpopescu at gmail.com}}
+\keyword{manip}
diff --git a/man/alex.Rd b/man/alex.Rd
new file mode 100644
index 0000000..92176e0
--- /dev/null
+++ b/man/alex.Rd
@@ -0,0 +1,44 @@
+\name{alex}
+\alias{alex}
+\title{Alignment Explorer With Multiple Devices}
+\description{
+ This function helps to explore DNA alignments by zooming in. The user
+ clicks twice defining the opposite corners of the portion which is
+ extracted and drawned on a new window.
+}
+\usage{
+alex(x, ...)
+}
+\arguments{
+ \item{x}{an object of class \code{"DNAbin"}.}
+ \item{\dots}{further arguments to pass to \code{image.DNAbin}.}
+}
+\details{
+ This function works with a DNA alignment (freshly) plotted on an
+ interactive graphical device (i.e., not a file) with \code{image}.
+ After calling \code{alex}, the user clicks twice defining a rectangle
+ in the alignment, then this portion of the alignment is extacted and
+ plotted on a \emph{new} window. The user can click as many times on
+ the alignment. The process is stopped by a right-click. If the user
+ clicks twice outside the alignment, a message ``Try again!'' is
+ printed.
+
+ Each time \code{alex} is called, the alignment is plotted on a new
+ window without closing or deleting those possibly already plotted.
+
+ In all cases, the device where \code{x} is plotted is the active
+ window after the operation. It should \emph{not} be closed during the
+ whole process.
+}
+\value{NULL}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{image.DNAbin}}, \code{\link{trex}}
+}
+\examples{
+\dontrun{
+data(woodmouse)
+image(woodmouse)
+alex(woodmouse)
+}}
+\keyword{hplot}
diff --git a/man/all.equal.phylo.Rd b/man/all.equal.phylo.Rd
new file mode 100644
index 0000000..4840618
--- /dev/null
+++ b/man/all.equal.phylo.Rd
@@ -0,0 +1,67 @@
+\encoding{latin1}
+\name{all.equal.phylo}
+\alias{all.equal.phylo}
+\title{Global Comparison of two Phylogenies}
+\usage{
+\method{all.equal}{phylo}(target, current, use.edge.length = TRUE,
+ use.tip.label = TRUE, index.return = FALSE,
+ tolerance = .Machine$double.eps ^ 0.5,
+ scale = NULL, \dots)
+}
+\arguments{
+ \item{target}{an object of class \code{"phylo"}.}
+ \item{current}{an object of class \code{"phylo"}.}
+ \item{use.edge.length}{if \code{FALSE} only the topologies are
+ compared; the default is \code{TRUE}.}
+ \item{use.tip.label}{if \code{FALSE} the unlabelled trees are
+ compared; the default is \code{TRUE}.}
+ \item{index.return}{if \code{TRUE} the function returns a two-column
+ matrix giving the correspondence between the nodes of both trees.}
+ \item{tolerance}{the numeric tolerance used to compare the branch
+ lengths.}
+ \item{scale}{a positive number, comparison of branch lengths is made
+ after scaling (i.e., dividing) them by this number.}
+ \item{\dots}{further arguments passed to or from other methods.}
+}
+\description{
+ This function makes a global comparison of two phylogenetic trees.
+}
+\details{
+ This function is meant to be an adaptation of the generic function
+ \code{all.equal} for the comparison of phylogenetic trees.
+
+ A single phylogenetic tree may have several representations in the Newick
+ format and in the \code{"phylo"} class of objects used in `ape'. One
+ aim of the present function is to be able to identify whether two
+ objects of class \code{"phylo"} represent the same phylogeny.
+}
+\note{
+ The algorithm used here does not work correctly for the comparison of
+ topologies (i.e., ignoring tip labels) of unrooted trees. This also
+ affects \code{\link{unique.multiPhylo}} which calls the present function. See:
+
+ \url{https://stat.ethz.ch/pipermail/r-sig-phylo/2011-August/001562.html}
+}
+\value{
+ A logical value, or a two-column matrix.
+}
+\author{\enc{Beno�t}{Benoit} Durand \email{b.durand at alfort.AFSSA.FR}}
+\seealso{
+ \code{\link[base]{all.equal}} for the generic \R function
+}
+\examples{
+### maybe the simplest example of two representations
+### for the same rooted tree...:
+t1 <- read.tree(text = "(a:1,b:1);")
+t2 <- read.tree(text = "(b:1,a:1);")
+all.equal(t1, t2)
+### ... compare with this:
+identical(t1, t2)
+### one just slightly more complicated...:
+t3 <- read.tree(text = "((a:1,b:1):1,c:2);")
+t4 <- read.tree(text = "(c:2,(a:1,b:1):1);")
+all.equal(t3, t4) # == all.equal.phylo(t3, t4)
+### ... here we force the comparison as lists:
+all.equal.list(t3, t4)
+}
+\keyword{manip}
diff --git a/man/ape-internal.Rd b/man/ape-internal.Rd
new file mode 100644
index 0000000..f73498d
--- /dev/null
+++ b/man/ape-internal.Rd
@@ -0,0 +1,75 @@
+\name{ape-internal}
+\alias{tree.build}
+\alias{f.cherry.yule}
+\alias{f.cherry.uniform}
+\alias{sortIndex}
+\alias{nsca}
+\alias{perm.rowscols}
+\alias{mant.zstat}
+\alias{lower.triang}
+\alias{clado.build}
+\alias{phylogram.plot}
+\alias{cladogram.plot}
+\alias{circular.plot}
+\alias{unrooted.plot}
+\alias{unrooted.xy}
+\alias{birth.step}
+\alias{death.step}
+\alias{ht.move}
+\alias{loglik.pop}
+\alias{pos.move}
+\alias{BOTHlabels}
+\alias{chronopl.cv}
+\alias{floating.pie.asp}
+\alias{checkLabel}
+\alias{plotCophylo2}
+\alias{plotPhyloCoor}
+\alias{integrateTrapeze}
+\alias{CDF.birth.death}
+\alias{postprocess.prop.part}
+\alias{ONEwise}
+\alias{BaseProportion}
+\alias{C_additive}
+\alias{C_bionj}
+\alias{C_bionjs}
+\alias{C_ewLasso}
+\alias{C_mvr}
+\alias{C_mvrs}
+\alias{C_nj}
+\alias{C_njs}
+\alias{C_pic}
+\alias{C_rTraitCont}
+\alias{C_treePop}
+\alias{C_triangMtd}
+\alias{C_triangMtds}
+\alias{C_ultrametric}
+\alias{C_where}
+\alias{GlobalDeletionDNA}
+\alias{SegSites}
+\alias{bipartition}
+\alias{delta_plot}
+\alias{dist_dna}
+\alias{dist_nodes}
+\alias{mat_expo}
+\alias{me_b}
+\alias{me_o}
+\alias{neworder_phylo}
+\alias{neworder_pruningwise}
+\alias{node_depth}
+\alias{node_depth_edgelength}
+\alias{node_height}
+\alias{node_height_clado}
+\alias{prop_part}
+\alias{rawStreamToDNAbin}
+\alias{seq_root2tip}
+\alias{treeBuildWithTokens}
+\alias{polar2rect}
+\alias{rect2polar}
+\alias{CountBipartitionsFromTrees}
+\alias{bitsplits_multiPhylo}
+\alias{bitsplits_phylo}
+\title{Internal Ape Functions}
+\description{
+ Internal \pkg{ape} functions.
+}
+\keyword{internal}
diff --git a/man/ape-package.Rd b/man/ape-package.Rd
new file mode 100644
index 0000000..46c7b61
--- /dev/null
+++ b/man/ape-package.Rd
@@ -0,0 +1,38 @@
+\name{ape-package}
+\alias{ape-package}
+\alias{ape}
+\docType{package}
+\title{
+Analyses of Phylogenetics and Evolution
+}
+\description{
+ \pkg{ape} provides functions for reading and manipulating phylogenetic
+ trees and DNA sequences, computing DNA distances, estimating trees
+ with distance-based methods, and a range of methods for comparative
+ analyses and analysis of diversification. Functionalities are also
+ provided for programming new phylogenetic methods.
+
+ The complete list of functions can be displayed with
+ \code{library(help = ape)}.
+
+ More information on \pkg{ape} can be found at \url{http://ape-package.ird.fr/}.
+}
+
+\author{
+ Emmanuel Paradis, Ben Bolker, Julien Claude, Hoa Sien Cuong, Richard
+ Desper, Benoit Durand, Julien Dutheil, Olivier Gascuel, Christoph
+ Heibl, Daniel Lawson, Vincent Lefort, Pierre Legendre, Jim Lemon,
+ Yvonnick Noel, Johan Nylander, Rainer Opgen-Rhein, Andrei-Alin
+ Popescu, Klaus Schliep, Korbinian Strimmer, Damien de Vienne
+
+ Maintainer: Emmanuel Paradis <Emmanuel.Paradis at ird.fr>
+}
+\references{
+ Paradis, E. (2012) \emph{Analysis of Phylogenetics and Evolution with
+ R (Second Edition).} New York: Springer.
+
+ Paradis, E., Claude, J. and Strimmer, K. (2004) APE: analyses of
+ phylogenetics and evolution in R language. \emph{Bioinformatics},
+ \bold{20}, 289--290.
+}
+\keyword{package}
diff --git a/man/as.alignment.Rd b/man/as.alignment.Rd
new file mode 100644
index 0000000..276d68d
--- /dev/null
+++ b/man/as.alignment.Rd
@@ -0,0 +1,63 @@
+\name{as.alignment}
+\alias{as.alignment}
+\alias{as.DNAbin}
+\alias{as.DNAbin.character}
+\alias{as.DNAbin.list}
+\alias{as.DNAbin.alignment}
+\alias{as.character.DNAbin}
+\title{Conversion Among DNA Sequence Internal Formats}
+\description{
+ These functions transform a set of DNA sequences among various
+ internal formats.
+}
+\usage{
+as.alignment(x)
+as.DNAbin(x, ...)
+
+\method{as.DNAbin}{character}(x, ...)
+
+\method{as.DNAbin}{list}(x, ...)
+
+\method{as.DNAbin}{alignment}(x, ...)
+
+\method{as.character}{DNAbin}(x, ...)
+}
+\arguments{
+ \item{x}{a matrix or a list containing the DNA sequences, or an object
+ of class \code{"alignment"}.}
+ \item{\dots}{further arguments to be passed to or from other methods.}
+}
+\details{
+ For \code{as.alignment}, the sequences given as argument should be
+ stored as matrices or lists of single-character strings (the format
+ used in \pkg{ape} before version 1.10). The returned object is in the
+ format used in the package \pkg{seqinr} to store aligned sequences.
+
+ \code{as.DNAbin} is a generic function with methods so that it works
+ with sequences stored into vectors, matrices, or lists.
+
+ \code{as.character} is a generic function: the present method
+ converts objects of class \code{"DNAbin"} into the format used
+ before \pkg{ape} 1.10 (matrix of single characters, or list of vectors
+ of single characters). This function must be used first to convert
+ objects of class \code{"DNAbin"} into the class \code{"alignment"}.
+}
+\value{
+ an object of class \code{"alignment"} in the case of
+ \code{"as.alignment"}; an object of class \code{"DNAbin"} in the case
+ of \code{"as.DNAbin"}; a matrix of mode character or a list containing
+ vectors of mode character in the case of \code{"as.character"}.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{DNAbin}}, \code{\link{read.dna}},
+ \code{\link{read.GenBank}}, \code{\link{write.dna}}
+}
+\examples{
+data(woodmouse)
+x <- as.character(woodmouse)
+x[, 1:20]
+str(as.alignment(x))
+identical(as.DNAbin(x), woodmouse)
+}
+\keyword{manip}
diff --git a/man/as.bitsplits.Rd b/man/as.bitsplits.Rd
new file mode 100644
index 0000000..4aeadb8
--- /dev/null
+++ b/man/as.bitsplits.Rd
@@ -0,0 +1,61 @@
+\name{as.bitsplits}
+\alias{as.bitsplits}
+\alias{as.bitsplits.prop.part}
+\alias{print.bitsplits}
+\alias{bitsplits}
+\alias{countBipartitions}
+\alias{as.prop.part}
+\alias{as.prop.part.bitsplits}
+\title{Split Frequencies and Conversion Among Split Classes}
+\description{
+ \code{bitsplits} returns the bipartitions (aka splits) for a single
+ tree or a list of trees.
+
+ \code{countBipartitions} returns the frequencies of the bipartitions
+ from a reference tree (phy) observed in a list of trees (X).
+
+ \code{as.bitsplits} and \code{as.prop.part} are generic functions for
+ converting between the \code{"bitsplits"} and \code{"prop.part"}
+ classes.
+}
+\usage{
+bitsplits(x)
+countBipartitions(phy, X)
+as.bitsplits(x)
+\method{as.bitsplits}{prop.part}(x)
+\method{print}{bitsplits}(x, ...)
+as.prop.part(x)
+\method{as.prop.part}{bitsplits}(x)
+}
+\arguments{
+ \item{x}{an object of the appropriate class.}
+ \item{phy}{an object of class \code{"phylo"}.}
+ \item{X}{an object of class \code{"multiPhylo"}.}
+ \item{\dots}{further arguments passed to or from other methods.}
+}
+\details{
+ These functions count bipartitions as defined by internal branches, so
+ they do not work with rooted trees (see examples). The structure of
+ the class \code{"bitsplits"} is described in a separate document
+ on ape's web site.
+}
+\value{
+ \code{bitsplits} and \code{as.bitsplits} return an object of class
+ \code{"bitsplits"}.
+
+ \code{countBipartitions} returns a vector of integers.
+
+ \code{as.prop.part} returns an object of class \code{"prop.part"}.
+}
+\author{Emmanuel Paradis}
+\seealso{\code{\link{prop.part}}}
+\examples{
+tr <- rtree(20)
+pp <- prop.part(tr)
+as.bitsplits(pp)
+## doesn't work for rooted trees...:
+countBipartitions(rtree(10), rmtree(100, 10))
+## ... but OK with unrooted trees:
+countBipartitions(rtree(10, rooted = FALSE), rmtree(100, 10, rooted = FALSE))
+}
+\keyword{manip}
diff --git a/man/as.matching.Rd b/man/as.matching.Rd
new file mode 100644
index 0000000..29d665c
--- /dev/null
+++ b/man/as.matching.Rd
@@ -0,0 +1,67 @@
+\name{as.matching}
+\alias{as.matching}
+\alias{matching}
+\alias{as.matching.phylo}
+\alias{as.phylo.matching}
+\title{Conversion Between Phylo and Matching Objects}
+\description{
+ These functions convert objects between the classes \code{"phylo"} and
+ \code{"matching"}.
+}
+\usage{
+as.matching(x, ...)
+\method{as.matching}{phylo}(x, labels = TRUE, ...)
+\method{as.phylo}{matching}(x, ...)
+}
+\arguments{
+ \item{x}{an object to convert as an object of class \code{"matching"}
+ or of class \code{"phylo"}.}
+ \item{labels}{a logical specifying whether the tip and node labels
+ should be included in the returned matching.}
+ \item{\dots}{further arguments to be passed to or from other methods.}
+}
+\details{
+ A matching is a representation where each tip and each node are given
+ a number, and sibling groups are grouped in a ``matching pair'' (see
+ Diaconis and Holmes 1998, for details). This coding system can be used
+ only for binary (fully dichotomous) trees.
+
+ Diaconis and Holmes (1998) gave some conventions to insure that a
+ given tree has a unique representation as a matching. I have tried to
+ follow them in the present functions.
+}
+\value{
+ \code{as.matching} returns an object of class \code{"matching"} with
+ the following component:
+
+ \item{matching}{a two-column numeric matrix where the columns
+ represent the sibling pairs.}
+ \item{tip.label}{(optional) a character vector giving the tip labels
+ where the ith element is the label of the tip numbered i in
+ \code{matching}.}
+ \item{node.label}{(optional) a character vector giving the node
+ labels in the same order than in \code{matching} (i.e. the ith
+ element is the label of the node numbered i + n in \code{matching},
+ with n the number of tips).}
+
+ \code{as.phylo.matching} returns an object of class \code{"phylo"}.
+}
+\note{
+ Branch lengths are not supported in the present version.
+}
+\author{Emmanuel Paradis}
+\references{
+ Diaconis, P. W. and Holmes, S. P. (1998) Matchings and phylogenetic
+ trees. \emph{Proceedings of the National Academy of Sciences USA},
+ \bold{95}, 14600--14602.
+}
+\seealso{\code{\link{as.phylo}}}
+\examples{
+data(bird.orders)
+m <- as.matching(bird.orders)
+str(m)
+m
+tr <- as.phylo(m)
+all.equal(tr, bird.orders, use.edge.length = FALSE)
+}
+\keyword{manip}
diff --git a/man/as.phylo.Rd b/man/as.phylo.Rd
new file mode 100644
index 0000000..09af082
--- /dev/null
+++ b/man/as.phylo.Rd
@@ -0,0 +1,110 @@
+\name{as.phylo}
+\alias{as.phylo}
+\alias{as.phylo.hclust}
+\alias{as.phylo.phylog}
+\alias{as.hclust.phylo}
+\alias{old2new.phylo}
+\alias{new2old.phylo}
+\alias{as.network.phylo}
+\alias{as.igraph}
+\alias{as.igraph.phylo}
+\title{Conversion Among Tree and Network Objects}
+\description{
+ \code{as.phylo} is a generic function which converts an object into a
+ tree of class \code{"phylo"}. There are currently two methods for
+ objects of class \code{"hclust"} and of class \code{"phylog"}
+ (implemented in the package ade4).
+
+ \code{as.hclust.phylo} is a method of the generic
+ \code{\link[stats]{as.hclust}} which converts an object of class
+ \code{"phylo"} into one of class \code{"hclust"}. This can used to
+ convert an object of class \code{"phylo"} into one of class
+ \code{"dendrogram"} (see examples).
+
+ \code{as.network} and \code{as.igraph} convert trees of class
+ \code{"phylo"} into these respective classes defined in the packages
+ of the same names (where the generics are defined).
+
+ \code{old2new.phylo} and \code{new2old.phylo} are utility functions
+ for converting between the old and new coding of the class
+ \code{"phylo"}.
+}
+\usage{
+as.phylo(x, ...)
+\method{as.phylo}{hclust}(x, ...)
+\method{as.phylo}{phylog}(x, ...)
+\method{as.hclust}{phylo}(x, ...)
+old2new.phylo(phy)
+new2old.phylo(phy)
+\method{as.network}{phylo}(x, directed = is.rooted(x), ...)
+\method{as.igraph}{phylo}(x, directed = is.rooted(x), use.labels = TRUE, ...)
+}
+\arguments{
+ \item{x}{an object to be converted into another class.}
+ \item{directed}{a logical value: should the network be directed? By
+ default, this depends on whether the tree is rooted or not.}
+ \item{use.labels}{a logical specifying whether to use labels to build
+ the network of class \code{"igraph"}. If \code{TRUE} and the tree
+ has no node labels, then some default labels are created first. If
+ \code{FALSE}, the network is built with integers.}
+ \item{\dots}{further arguments to be passed to or from other methods.}
+ \item{phy}{an object of class \code{"phylo"}.}
+}
+\value{
+ An object of class \code{"hclust"}, \code{"phylo"}, \code{"network"},
+ or \code{"igraph"}.
+}
+\note{
+ In an object of class \code{"hclust"}, the \code{height} gives the
+ distance between the two sets that are being agglomerated. So these
+ distances are divided by two when setting the branch lengths of a
+ phylogenetic tree.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link[stats]{hclust}}, \code{\link[stats]{as.hclust}},
+ \code{\link[stats]{dendrogram}}, \code{\link[ade4]{phylog}},
+ \code{\link{as.phylo.formula}}
+}
+\examples{
+data(bird.orders)
+hc <- as.hclust(bird.orders)
+tr <- as.phylo(hc)
+all.equal(bird.orders, tr) # FALSE, but...
+tr$edge.length <- 2 * tr$edge.length
+all.equal(bird.orders, tr) # ... TRUE
+
+### shows the three plots for tree objects:
+dend <- as.dendrogram(hc)
+layout(matrix(c(1:3, 3), 2, 2))
+plot(bird.orders, font = 1)
+plot(hc)
+par(mar = c(8, 0, 0, 0)) # leave space for the labels
+plot(dend)
+
+### how to get (nearly) identical plots with
+### plot.phylo and plot.dendrogram:
+layout(matrix(1:2, 2, 1))
+plot(bird.orders, font = 1, no.margin = TRUE)
+par(mar = c(0, 0, 0, 8))
+plot(dend, horiz = TRUE)
+layout(matrix(1))
+
+\dontrun{
+### convert into networks:
+if (require(network)) {
+ x <- as.network(rtree(10))
+ print(x)
+ plot(x, vertex.cex = 1:4)
+ plot(x, displaylabels = TRUE)
+}
+tr <- rtree(5)
+if (require(igraph)) {
+ print((x <- as.igraph(tr)))
+ plot(x)
+ print(as.igraph(tr, TRUE, FALSE))
+ print(as.igraph(tr, FALSE, FALSE))
+}
+}
+}
+\keyword{manip}
diff --git a/man/as.phylo.formula.Rd b/man/as.phylo.formula.Rd
new file mode 100644
index 0000000..d13a112
--- /dev/null
+++ b/man/as.phylo.formula.Rd
@@ -0,0 +1,30 @@
+\name{as.phylo.formula}
+\alias{as.phylo.formula}
+\title{ Conversion from Taxonomy Variables to Phylogenetic Trees }
+\description{
+ The function \code{as.phylo.formula} (short form \code{as.phylo})
+ builds a phylogenetic tree (an object of class \code{phylo}) from
+ a set of nested taxonomic variables.
+}
+\usage{
+\method{as.phylo}{formula}(x, data = parent.frame(), ...)
+}
+\arguments{
+ \item{x}{ a right-side formula describing the taxonomic relationship: \code{~C1/C2/.../Cn}. }
+ \item{data}{ the data.frame where to look for the variables (default to environment). }
+ \item{\dots}{ further arguments to be passed from other methods.}
+}
+\details{
+ Taxonomic variables must be nested and passed in the correct order: the higher clade must be on the left of the formula, for instance \code{~Order/Family/Genus/Species}.
+ In most cases, the resulting tree will be unresolved and contain polytomies.
+}
+\value{
+ An object of class \code{phylo}.
+}
+\author{Julien Dutheil \email{Julien.Dutheil at univ-montp2.fr}}
+\seealso{ \code{\link{as.phylo}}, \code{\link{read.tree}} for a description of \code{phylo} objects, \code{\link{multi2di}} }
+\examples{
+data(carnivora)
+plot(as.phylo(~SuperFamily/Family/Genus/Species, data=carnivora))
+}
+\keyword{manip}
diff --git a/man/axisPhylo.Rd b/man/axisPhylo.Rd
new file mode 100644
index 0000000..42caaff
--- /dev/null
+++ b/man/axisPhylo.Rd
@@ -0,0 +1,34 @@
+\name{axisPhylo}
+\alias{axisPhylo}
+\title{Axis on Side of Phylogeny}
+\usage{
+axisPhylo(side = 1, ...)
+}
+\arguments{
+ \item{side}{a numeric value specifying the side where the axis is
+ plotted: 1: below, 2: left, 3: above, 4: right.}
+ \item{\dots}{further arguments to be passed to \code{axis}.}
+}
+\description{
+ This function adds a scaled axis on the side of a phylogeny plot.
+}
+\details{
+ The further arguments (\code{...}) are used to format the axis. They
+ may be \code{font}, \code{cex}, \code{col}, \code{las}, and so on (see
+ the help pages on \code{\link[graphics]{axis}} and
+ \code{\link[graphics]{par}}).
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{plot.phylo}}, \code{\link{add.scale.bar}},
+ \code{\link[graphics]{axis}}, \code{\link[graphics]{par}}
+}
+\examples{
+tr <- rtree(30)
+ch <- rcoal(30)
+plot(ch)
+axisPhylo()
+plot(tr, "c", FALSE, direction = "u")
+axisPhylo(2, las = 1)
+}
+\keyword{aplot}
diff --git a/man/balance.Rd b/man/balance.Rd
new file mode 100644
index 0000000..35f037b
--- /dev/null
+++ b/man/balance.Rd
@@ -0,0 +1,29 @@
+\name{balance}
+\alias{balance}
+\title{Balance of a Dichotomous Phylogenetic Tree}
+\usage{
+balance(phy)
+}
+\arguments{
+ \item{phy}{an object of class \code{"phylo"}.}
+}
+\description{
+ This function computes the balance of a phylogenetic tree, that is for
+ each node of the tree the numbers of descendants (i.e. tips) on each
+ of its daughter-branch. The tree must be fully dichotomous.
+}
+\value{
+ a numeric matrix with two columns and one row for each node of the
+ tree. The columns give the numbers of descendants on each
+ daughter-branches (the order of both columns being arbitrary). If the
+ phylogeny \code{phy} has an element \code{node.label}, this is used as
+ rownames for the returned matrix; otherwise the numbers (of mode
+ character) of the matrix \code{edge} of \code{phy} are used as rownames.
+}
+\references{
+ Aldous, D. J. (2001) Stochastic models and descriptive statistics for
+ phylogenetic trees, from Yule to today. \emph{Statistical Science},
+ \bold{16}, 23--34.
+}
+\author{Emmanuel Paradis}
+\keyword{manip}
diff --git a/man/base.freq.Rd b/man/base.freq.Rd
new file mode 100644
index 0000000..8832fcc
--- /dev/null
+++ b/man/base.freq.Rd
@@ -0,0 +1,62 @@
+\name{base.freq}
+\alias{base.freq}
+\alias{GC.content}
+\alias{Ftab}
+\title{Base frequencies from DNA Sequences}
+\description{
+ \code{base.freq} computes the frequencies (absolute or relative) of
+ the four DNA bases (adenine, cytosine, guanine, and thymidine) from a
+ sample of sequences.
+
+ \code{GC.content} computes the proportion of G+C (using the previous
+ function). All missing or unknown sites are ignored.
+
+ \code{Ftab} computes the contingency table with the absolute
+ frequencies of the DNA bases from a pair of sequences.
+}
+\usage{
+base.freq(x, freq = FALSE, all = FALSE)
+GC.content(x)
+Ftab(x, y = NULL)
+}
+\arguments{
+ \item{x}{a vector, a matrix, or a list which contains the DNA
+ sequences.}
+ \item{y}{a vector with a single DNA sequence.}
+ \item{freq}{a logical specifying whether to return the proportions
+ (the default) or the absolute frequencies (counts).}
+ \item{all}{a logical; by default only the counts of A, C, G, and T are
+ returned. If \code{all = TRUE}, all counts of bases, ambiguous codes,
+ missing data, and alignment gaps are returned.}
+}
+\details{
+ The base frequencies are computed over all sequences in the
+ sample.
+
+ For \code{Ftab}, if the argument \code{y} is given then both \code{x}
+ and \code{y} are coerced as vectors and must be of equal length. If
+ \code{y} is not given, \code{x} must be a matrix or a list and only
+ the two first sequences are used.
+}
+\value{
+ A numeric vector with names \code{c("a", "c", "g", "t")} (and possibly
+ \code{"r", "m", ...}, a single numeric value, or a four by four matrix
+ with similar dimnames.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{seg.sites}}, \code{\link[pegas]{nuc.div}},
+ \code{\link{DNAbin}}
+}
+\examples{
+data(woodmouse)
+base.freq(woodmouse)
+base.freq(woodmouse, TRUE)
+base.freq(woodmouse, TRUE, TRUE)
+GC.content(woodmouse)
+Ftab(woodmouse)
+Ftab(woodmouse[1, ], woodmouse[2, ]) # same than above
+Ftab(woodmouse[14:15, ]) # between the last two
+}
+\keyword{univar}
+\keyword{manip}
diff --git a/man/bd.ext.Rd b/man/bd.ext.Rd
new file mode 100644
index 0000000..1cccd8c
--- /dev/null
+++ b/man/bd.ext.Rd
@@ -0,0 +1,77 @@
+\name{bd.ext}
+\alias{bd.ext}
+\title{Extended Version of the Birth-Death Models to Estimate Speciation
+ and Extinction Rates}
+\usage{
+bd.ext(phy, S, conditional = TRUE)
+}
+\arguments{
+ \item{phy}{an object of class \code{"phylo"}.}
+ \item{S}{a numeric vector giving the number of species for each tip.}
+ \item{conditional}{whether probabilities should be conditioned on no
+ extinction (mainly to compare results with previous analyses; see
+ details).}
+}
+\description{
+ This function fits by maximum likelihood a birth-death model to the
+ combined phylogenetic and taxonomic data of a given clade. The
+ phylogenetic data are given by a tree, and the taxonomic data by the
+ number of species for the its tips.
+}
+\details{
+ A re-parametrization of the birth-death model studied by Kendall
+ (1948) so that the likelihood has to be maximized over \emph{d/b} and
+ \emph{b - d}, where \emph{b} is the birth rate, and \emph{d} the death
+ rate.
+
+ The standard-errors of the estimated parameters are computed using a
+ normal approximation of the maximum likelihood estimates.
+
+ If the argument \code{S} has names, then they are matched to the tip
+ labels of \code{phy}. The user must be careful here since the function
+ requires that both series of names perfectly match, so this operation
+ may fail if there is a typing or syntax error. If both series of names
+ do not match, the values \code{S} are taken to be in the same order
+ than the tip labels of \code{phy}, and a warning message is issued.
+
+ Note that the function does not check that the tree is effectively
+ ultrametric, so if it is not, the returned result may not be
+ meaningful.
+
+ If \code{conditional = TRUE}, the probabilities of the taxonomic data
+ are calculated conditioned on no extinction (Rabosky et al. 2007). In
+ previous versions of the present function (until ape 2.6-1),
+ unconditional probabilities were used resulting in underestimated
+ extinction rate. Though it does not make much sense to use
+ \code{conditional = FALSE}, this option is provided to compare results
+ from previous analyses: if the species richnesses are relatively low,
+ both versions will give similar results (see examples).
+}
+\references{
+ Paradis, E. (2003) Analysis of diversification: combining phylogenetic
+ and taxonomic data. \emph{Proceedings of the Royal Society of
+ London. Series B. Biological Sciences}, \bold{270}, 2499--2505.
+
+ Rabosky, D. L., Donnellan, S. C., Talaba, A. L. and Lovette,
+ I. J. (2007) Exceptional among-lineage variation in diversification
+ rates during the radiation of Australia's most diverse vertebrate
+ clade. \emph{Proceedings of the Royal Society of London. Series
+ B. Biological Sciences}, \bold{274}, 2915--2923.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{birthdeath}}, \code{\link{branching.times}},
+ \code{\link{diversi.gof}}, \code{\link{diversi.time}},
+ \code{\link{ltt.plot}}, \code{\link{yule}}, \code{\link{yule.cov}},
+ \code{\link{bd.time}}
+}
+\examples{
+### An example from Paradis (2003) using the avian orders:
+data(bird.orders)
+### Number of species in each order from Sibley and Monroe (1990):
+S <- c(10, 47, 69, 214, 161, 17, 355, 51, 56, 10, 39, 152,
+ 6, 143, 358, 103, 319, 23, 291, 313, 196, 1027, 5712)
+bd.ext(bird.orders, S)
+bd.ext(bird.orders, S, FALSE) # same than older versions
+}
+\keyword{models}
diff --git a/man/bd.time.Rd b/man/bd.time.Rd
new file mode 100644
index 0000000..fb053b8
--- /dev/null
+++ b/man/bd.time.Rd
@@ -0,0 +1,87 @@
+\name{bd.time}
+\alias{bd.time}
+\title{Time-Dependent Birth-Death Models}
+\description{
+ This function fits a used-defined time-dependent birth-death
+ model.
+}
+\usage{
+bd.time(phy, birth, death, BIRTH = NULL, DEATH = NULL,
+ ip, lower, upper, fast = FALSE, boot = 0, trace = 0)
+}
+\arguments{
+ \item{phy}{an object of class \code{"phylo"}.}
+ \item{birth}{either a numeric (if speciation rate is assumed
+ constant), or a (vectorized) function specifying how the birth
+ (speciation) probability changes through time (see details).}
+ \item{death}{id. for extinction probability.}
+ \item{BIRTH}{(optional) a vectorized function giving the primitive
+ of \code{birth}.}
+ \item{DEATH}{id. for \code{death}.}
+ \item{ip}{a numeric vector used as initial values for the estimation
+ procedure. If missing, these values are guessed.}
+ \item{lower, upper}{the lower and upper bounds of the parameters. If
+ missing, these values are guessed too.}
+ \item{fast}{a logical value specifying whether to use faster
+ integration (see details).}
+ \item{boot}{the number of bootstrap replicates to assess the
+ confidence intervals of the parameters. Not run by default.}
+ \item{trace}{an integer value. If non-zero, the fitting procedure is
+ printed every \code{trace} steps. This can be helpful if convergence
+ is particularly slow.}
+}
+\details{
+ Details on how to specify the birth and death functions and their
+ primitives can be found in the help page of \code{\link{yule.time}}.
+
+ The model is fitted by minimizing the least squares deviation between
+ the observed and the predicted distributions of branching times. These
+ computations rely heavily on numerical integrations. If \code{fast =
+ FALSE}, integrations are done with R's \code{\link[stats]{integrate}}
+ function. If \code{fast = TRUE}, a faster but less accurate function
+ provided in \pkg{ape} is used. If fitting a complex model to a large
+ phylogeny, a strategy might be to first use the latter option, and
+ then to use the estimates as starting values with \code{fast = FALSE}.
+}
+\value{
+ A list with the following components:
+
+\itemize{
+ \item{par}{a vector of estimates with names taken from the parameters
+ in the specified functions.}
+ \item{SS}{the minimized sum of squares.}
+ \item{convergence}{output convergence criterion from
+ \code{\link[stats]{nlminb}}.}
+ \item{message}{id.}
+ \item{iterations}{id.}
+ \item{evaluations}{id.}
+}}
+\references{
+ Paradis, E. (2011) Time-dependent speciation and extinction from
+ phylogenies: a least squares approach. \emph{Evolution}, \bold{65},
+ 661--672.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{ltt.plot}}, \code{\link{birthdeath}},
+ \code{\link{yule.time}}, \code{\link{LTT}}
+}
+\examples{
+set.seed(3)
+tr <- rbdtree(0.1, 0.02)
+bd.time(tr, 0, 0) # fits a simple BD model
+bd.time(tr, 0, 0, ip = c(.1, .01)) # 'ip' is useful here
+## the classic logistic:
+birth.logis <- function(a, b) 1/(1 + exp(-a*t - b))
+\dontrun{
+bd.time(tr, birth.logis, 0, ip = c(0, -2, 0.01))
+## slow to get:
+## $par
+## a b death
+## -0.003486961 -1.995983179 0.016496454
+##
+## $SS
+## [1] 20.73023
+}
+}
+\keyword{models}
diff --git a/man/bind.tree.Rd b/man/bind.tree.Rd
new file mode 100644
index 0000000..b1e9908
--- /dev/null
+++ b/man/bind.tree.Rd
@@ -0,0 +1,115 @@
+\name{bind.tree}
+\alias{bind.tree}
+\alias{+.phylo}
+\title{Binds Trees}
+\usage{
+bind.tree(x, y, where = "root", position = 0, interactive = FALSE)
+\special{x + y}
+}
+\arguments{
+ \item{x}{an object of class \code{"phylo"}.}
+ \item{y}{an object of class \code{"phylo"}.}
+ \item{where}{an integer giving the number of the node or tip of the
+ tree \code{x} where the tree \code{y} is binded (\code{"root"} is a
+ short-cut for the root).}
+ \item{position}{a numeric value giving the position from the tip or
+ node given by \code{node} where the tree \code{y} is binded;
+ negative values are ignored.}
+ \item{interactive}{if \code{TRUE} the user is asked to choose the tip
+ or node of \code{x} by clicking on the tree which must be plotted.}
+}
+\description{
+ This function binds together two phylogenetic trees to give a single
+ object of class \code{"phylo"}.
+}
+\details{
+ The argument \code{x} can be seen as the receptor tree, whereas
+ \code{y} is the donor tree. The root of \code{y} is then grafted on a
+ location of \code{x} specified by \code{where} and, possibly,
+ \code{position}. If \code{y} has a root edge, this is added as in
+ internal branch in the resulting tree.
+
+ \code{x + y} is a shortcut for:
+
+ \preformatted{
+ bind.tree(x, y, position = if (is.null(x$root.edge)) 0 else
+ x$root.edge)
+ }
+
+ If only one of the trees has no branch length, the branch lengths of
+ the other one are ignored with a warning.
+
+ If one (or both) of the trees has no branch length, it is possible to
+ specify a value of 'position' to graft 'y' below the node of 'x'
+ specified by 'where'. In this case, the exact value of 'position' is
+ not important as long as it is greater than zero. The new node will be
+ multichotomous if 'y' has no root edge. This can be solved by giving
+ an arbitrary root edge to 'y' beforehand (e.g., \code{y$root.edge <-
+ 1}): it will be deleted during the binding operation.
+}
+\value{
+ an object of class \code{"phylo"}.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{drop.tip}}, \code{\link{root}}
+}
+\examples{
+### binds the two clades of bird orders
+cat("((Struthioniformes:21.8,Tinamiformes:21.8):4.1,",
+ "((Craciformes:21.6,Galliformes:21.6):1.3,Anseriformes:22.9):3.0):2.1;",
+ file = "ex1.tre", sep = "\n")
+cat("(Turniciformes:27.0,(Piciformes:26.3,((Galbuliformes:24.4,",
+ "((Bucerotiformes:20.8,Upupiformes:20.8):2.6,",
+ "(Trogoniformes:22.1,Coraciiformes:22.1):1.3):1.0):0.6,",
+ "(Coliiformes:24.5,(Cuculiformes:23.7,(Psittaciformes:23.1,",
+ "(((Apodiformes:21.3,Trochiliformes:21.3):0.6,",
+ "(Musophagiformes:20.4,Strigiformes:20.4):1.5):0.6,",
+ "((Columbiformes:20.8,(Gruiformes:20.1,Ciconiiformes:20.1):0.7):0.8,",
+ "Passeriformes:21.6):0.9):0.6):0.6):0.8):0.5):1.3):0.7):1.0;",
+ file = "ex2.tre", sep = "\n")
+tree.bird1 <- read.tree("ex1.tre")
+tree.bird2 <- read.tree("ex2.tre")
+unlink(c("ex1.tre", "ex2.tre")) # clean-up
+(birds <- tree.bird1 + tree.bird2)
+layout(matrix(c(1, 2, 3, 3), 2, 2))
+plot(tree.bird1)
+plot(tree.bird2)
+plot(birds)
+
+### examples with random trees
+x <- rtree(4, tip.label = LETTERS[1:4])
+y <- rtree(4, tip.label = LETTERS[5:8])
+x <- makeNodeLabel(x, prefix = "x_")
+y <- makeNodeLabel(y, prefix = "y_")
+x$root.edge <- y$root.edge <- .2
+
+z <- bind.tree(x, y, po=.2)
+plot(y, show.node.label = TRUE, font = 1, root.edge = TRUE)
+title("y")
+plot(x, show.node.label = TRUE, font = 1, root.edge = TRUE)
+title("x")
+plot(z, show.node.label = TRUE, font = 1, root.edge = TRUE)
+title("z <- bind.tree(x, y, po=.2)")
+
+z <- bind.tree(x, y, 2, .1)
+plot(y, show.node.label = TRUE, font = 1, root.edge = TRUE)
+title("y")
+plot(x, show.node.label = TRUE, font = 1, root.edge = TRUE)
+title("x")
+plot(z, show.node.label = TRUE, font = 1, root.edge = TRUE)
+title("z <- bind.tree(x, y, 2, .1)")
+
+x <- rtree(50)
+y <- rtree(50)
+x$root.edge <- y$root.edge <- .2
+z <- x + y
+plot(y, show.tip.label = FALSE, root.edge = TRUE); axisPhylo()
+title("y")
+plot(x, show.tip.label = FALSE, root.edge = TRUE); axisPhylo()
+title("x")
+plot(z, show.tip.label = FALSE, root.edge = TRUE); axisPhylo()
+title("z <- x + y")
+layout(1)
+}
+\keyword{manip}
diff --git a/man/bionj.Rd b/man/bionj.Rd
new file mode 100644
index 0000000..3fe1a79
--- /dev/null
+++ b/man/bionj.Rd
@@ -0,0 +1,49 @@
+\name{BIONJ}
+\alias{bionj}
+\title{
+ Tree Estimation Based on an Improved Version of the NJ Algorithm
+}
+\description{
+ This function performs the BIONJ algorithm of Gascuel (1997).
+}
+\usage{
+bionj(X)
+}
+\arguments{
+ \item{X}{a distance matrix; may be an object of class \code{"dist"}.}
+}
+\value{
+ an object of class \code{"phylo"}.
+}
+\references{
+ Gascuel, O. (1997) BIONJ: an improved version of the NJ algorithm
+ based on a simple model of sequence data.
+ \emph{Molecular Biology and Evolution}, \bold{14:}, 685--695.
+}
+\author{
+ original C code by Hoa Sien Cuong and Olivier Gascuel; adapted and
+ ported to \R by Vincent Lefort \email{vincent.lefort at lirmm.fr}
+}
+\seealso{
+ \code{\link{nj}}, \code{\link{fastme}}, \code{\link{mvr}},
+ \code{\link{bionjs}}, \code{\link{SDM}}, \code{\link{dist.dna}}
+}
+\examples{
+### From Saitou and Nei (1987, Table 1):
+x <- c(7, 8, 11, 13, 16, 13, 17, 5, 8, 10, 13,
+ 10, 14, 5, 7, 10, 7, 11, 8, 11, 8, 12,
+ 5, 6, 10, 9, 13, 8)
+M <- matrix(0, 8, 8)
+M[lower.tri(M)] <- x
+M <- t(M)
+M[lower.tri(M)] <- x
+dimnames(M) <- list(1:8, 1:8)
+tr <- bionj(M)
+plot(tr, "u")
+### a less theoretical example
+data(woodmouse)
+trw <- bionj(dist.dna(woodmouse))
+plot(trw)
+}
+\keyword{models}
+
diff --git a/man/bird.families.Rd b/man/bird.families.Rd
new file mode 100644
index 0000000..80e80f0
--- /dev/null
+++ b/man/bird.families.Rd
@@ -0,0 +1,40 @@
+\name{bird.families}
+\alias{bird.families}
+\title{Phylogeny of the Families of Birds From Sibley and Ahlquist}
+\description{
+ This data set describes the phylogenetic relationships of the families
+ of birds as reported by Sibley and Ahlquist (1990). Sibley and
+ Ahlquist inferred this phylogeny from an extensive number of DNA/DNA
+ hybridization experiments. The ``tapestry'' reported by these two
+ authors (more than 1000 species out of the ca. 9000 extant bird
+ species) generated a lot of debates.
+
+ The present tree is based on the relationships among families. A few
+ families were not included in the figures in Sibley and Ahlquist, and
+ thus are not included here as well. The branch lengths were calculated
+ from the values of \eqn{\Delta T_{50}H}{Delta T50H} as found in Sibley
+ and Ahlquist (1990, figs. 354, 355, 356, and 369).
+}
+\usage{
+data(bird.families)
+}
+\format{
+ The data are stored as an object of class \code{"phylo"} which
+ structure is described in the help page of the function
+ \code{\link{read.tree}}.
+}
+\source{
+ Sibley, C. G. and Ahlquist, J. E. (1990) Phylogeny and classification
+ of birds: a study in molecular evolution. New Haven: Yale University Press.
+}
+\seealso{
+ \code{\link{read.tree}}, \code{\link{bird.orders}}
+}
+\examples{
+data(bird.families)
+op <- par()
+par(cex = 0.3)
+plot(bird.families)
+par(op)
+}
+\keyword{datasets}
diff --git a/man/bird.orders.Rd b/man/bird.orders.Rd
new file mode 100644
index 0000000..656fd6f
--- /dev/null
+++ b/man/bird.orders.Rd
@@ -0,0 +1,36 @@
+\name{bird.orders}
+\alias{bird.orders}
+\title{Phylogeny of the Orders of Birds From Sibley and Ahlquist}
+\description{
+ This data set describes the phylogenetic relationships of the orders
+ of birds as reported by Sibley and Ahlquist (1990). Sibley and
+ Ahlquist inferred this phylogeny from an extensive number of DNA/DNA
+ hybridization experiments. The ``tapestry'' reported by these two
+ authors (more than 1000 species out of the ca. 9000 extant bird
+ species) generated a lot of debates.
+
+ The present tree is based on the relationships among orders. The
+ branch lengths were calculated from the values of \eqn{\Delta
+ T_{50}H}{Delta T50H} as found in Sibley and Ahlquist (1990,
+ fig. 353).
+}
+\usage{
+data(bird.orders)
+}
+\format{
+ The data are stored as an object of class \code{"phylo"} which
+ structure is described in the help page of the function
+ \code{\link{read.tree}}.
+}
+\source{
+ Sibley, C. G. and Ahlquist, J. E. (1990) Phylogeny and classification
+ of birds: a study in molecular evolution. New Haven: Yale University Press.
+}
+\seealso{
+ \code{\link{read.tree}}, \code{\link{bird.families}}
+}
+\examples{
+data(bird.orders)
+plot(bird.orders)
+}
+\keyword{datasets}
diff --git a/man/birthdeath.Rd b/man/birthdeath.Rd
new file mode 100644
index 0000000..7e2cd5c
--- /dev/null
+++ b/man/birthdeath.Rd
@@ -0,0 +1,66 @@
+\name{birthdeath}
+\alias{birthdeath}
+\alias{print.birthdeath}
+\title{Estimation of Speciation and Extinction Rates With Birth-Death Models}
+\usage{
+birthdeath(phy)
+\method{print}{birthdeath}(x, ...)
+}
+\arguments{
+ \item{phy}{an object of class \code{"phylo"}.}
+ \item{x}{an object of class \code{"birthdeath"}.}
+ \item{\dots}{further arguments passed to the \code{print} function.}
+}
+\description{
+ This function fits by maximum likelihood a birth-death model to the
+ branching times computed from a phylogenetic tree using the method of
+ Nee et al. (1994).
+}
+\details{
+ Nee et al. (1994) used a re-parametrization of the birth-death model
+ studied by Kendall (1948) so that the likelihood has to be maximized
+ over \emph{d/b} and \emph{b - d}, where \emph{b} is the birth rate,
+ and \emph{d} the death rate. This is the approach used by the present
+ function.
+
+ This function computes the standard-errors of the estimated parameters
+ using a normal approximations of the maximum likelihood estimates:
+ this is likely to be inaccurate because of asymmetries of the
+ likelihood function (Nee et al. 1995). In addition, 95 % confidence
+ intervals of both parameters are computed using profile likelihood:
+ they are particularly useful if the estimate of \emph{d/b} is at the
+ boundary of the parameter space (i.e. 0, which is often the case).
+
+ Note that the function does not check that the tree is effectively
+ ultrametric, so if it is not, the returned result may not be meaningful.
+}
+\value{
+ An object of class \code{"birthdeath"} which is a list with the
+ following components:
+ \item{tree}{the name of the tree analysed.}
+ \item{N}{the number of species.}
+ \item{dev}{the deviance (= -2 log lik) at its minimum.}
+ \item{para}{the estimated parameters.}
+ \item{se}{the corresponding standard-errors.}
+ \item{CI}{the 95\% profile-likelihood confidence intervals.}
+}
+\references{
+ Kendall, D. G. (1948) On the generalized ``birth-and-death''
+ process. \emph{Annals of Mathematical Statistics}, \bold{19}, 1--15.
+
+ Nee, S., May, R. M. and Harvey, P. H. (1994) The reconstructed
+ evolutionary process. \emph{Philosophical Transactions of the Royal
+ Society of London. Series B. Biological Sciences}, \bold{344}, 305--311.
+
+ Nee, S., Holmes, E. C., May, R. M. and Harvey, P. H. (1995) Estimating
+ extinctions from molecular phylogenies. in \emph{Extinction Rates},
+ eds. Lawton, J. H. and May, R. M., pp. 164--182, Oxford University Press.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{branching.times}}, \code{\link{diversi.gof}},
+ \code{\link{diversi.time}}, \code{\link{ltt.plot}},
+ \code{\link{yule}}, \code{\link{bd.ext}}, \code{\link{yule.cov}},
+ \code{\link{bd.time}}
+}
+\keyword{models}
diff --git a/man/boot.phylo.Rd b/man/boot.phylo.Rd
new file mode 100644
index 0000000..b031e0a
--- /dev/null
+++ b/man/boot.phylo.Rd
@@ -0,0 +1,155 @@
+\name{boot.phylo}
+\alias{boot.phylo}
+\alias{prop.part}
+\alias{prop.clades}
+\alias{print.prop.part}
+\alias{summary.prop.part}
+\alias{plot.prop.part}
+\title{Tree Bipartition and Bootstrapping Phylogenies}
+\description{
+ These functions analyse bipartitions found in a series of trees.
+
+ \code{prop.part} counts the number of bipartitions found in a series
+ of trees given as \code{\dots}. If a single tree is passed, the
+ returned object is a list of vectors with the tips descending from
+ each node (i.e., clade compositions indexed by node number).
+
+ \code{prop.clades} counts the number of times the bipartitions present
+ in \code{phy} are present in a series of trees given as \code{\dots} or
+ in the list previously computed and given with \code{part}.
+
+ \code{boot.phylo} performs a bootstrap analysis.
+}
+\usage{
+boot.phylo(phy, x, FUN, B = 100, block = 1,
+ trees = FALSE, quiet = FALSE, rooted = FALSE)
+prop.part(..., check.labels = TRUE)
+prop.clades(phy, ..., part = NULL, rooted = FALSE)
+\method{print}{prop.part}(x, ...)
+\method{summary}{prop.part}(object, ...)
+\method{plot}{prop.part}(x, barcol = "blue", leftmar = 4, ...)
+}
+\arguments{
+ \item{phy}{an object of class \code{"phylo"}.}
+ \item{x}{in the case of \code{boot.phylo}: a taxa (rows) by characters
+ (columns) matrix; in the case of \code{print} and \code{plot}: an
+ object of class \code{"prop.part"}.}
+ \item{FUN}{the function used to estimate \code{phy} (see details).}
+ \item{B}{the number of bootstrap replicates.}
+ \item{block}{the number of columns in \code{x} that will be resampled
+ together (see details).}
+ \item{trees}{a logical specifying whether to return the bootstraped
+ trees (\code{FALSE} by default).}
+ \item{quiet}{a logical: a progress bar is displayed by default.}
+ \item{rooted}{a logical specifying whether the trees should be treated
+ as rooted or not (the default).}
+ \item{\dots}{either (i) a single object of class \code{"phylo"}, (ii) a
+ series of such objects separated by commas, or (iii) a list
+ containing such objects. In the case of \code{plot} further
+ arguments for the plot (see details).}
+ \item{check.labels}{a logical specifying whether to check the labels
+ of each tree. If \code{FALSE}, it is assumed that all trees have the
+ same tip labels, and that they are in the same order (see details).}
+ \item{part}{a list of partitions as returned by \code{prop.part}; if
+ this is used then \code{\dots} is ignored.}
+ \item{object}{an object of class \code{"prop.part"}.}
+ \item{barcol}{the colour used for the bars displaying the number of
+ partitions in the upper panel.}
+ \item{leftmar}{the size of the margin on the left to display the tip
+ labels.}
+}
+\details{
+ The argument \code{FUN} in \code{boot.phylo} must be the function used
+ to estimate the tree from the original data matrix. Thus, if the tree
+ was estimated with neighbor-joining (see \code{nj}), one maybe wants
+ something like \code{FUN = function(xx) nj(dist.dna(xx))}.
+
+ \code{block} in \code{boot.phylo} specifies the number of columns to
+ be resampled altogether. For instance, if one wants to resample at the
+ codon-level, then \code{block = 3} must be used.
+
+ Using \code{check.labels = FALSE} in \code{prop.part} decreases
+ computing times. This requires that (i) all trees have the same tip
+ labels, \emph{and} (ii) these labels are ordered similarly in all
+ trees (in other words, the element \code{tip.label} are identical in
+ all trees).
+
+ The plot function represents a contingency table of the different
+ partitions (on the \emph{x}-axis) in the lower panel, and their observed
+ numbers in the upper panel. Any further arguments (\dots) are used to
+ change the aspects of the points in the lower panel: these may be
+ \code{pch}, \code{col}, \code{bg}, \code{cex}, etc. This function
+ works only if there is an attribute \code{labels} in the object.
+
+ The print method displays the partitions and their numbers. The
+ summary method extracts the numbers only.
+}
+\note{
+ \code{prop.clades} calls internally \code{prop.part} with the option
+ \code{check.labels = TRUE}, which may be very slow. If the trees
+ passed as \code{\dots} fulfills conditions (i) and (ii) above, then it
+ might be faster to first call, e.g., \code{pp <- prop.part(...)}, then
+ use the option \code{part}: \code{prop.clades(phy, part = pp)}.
+
+ You have to be careful that by default \code{prop.clades} considers
+ the trees as unrooted and this may result in spurious results if the
+ trees are rooted (see examples).
+}
+\value{
+ \code{prop.part} returns an object of class \code{"prop.part"} which
+ is a list with an attribute \code{"number"}. The elements of this list
+ are the observed clades, and the attribute their respective
+ numbers. If the default \code{check.labels = FALSE} is used, an
+ attribute \code{"labels"} is added, and the vectors of the returned
+ object contains the indices of these labels instead of the labels
+ themselves.
+
+ \code{prop.clades} and \code{boot.phylo} return a numeric vector
+ which \emph{i}th element is the number associated to the \emph{i}th
+ node of \code{phy}. If \code{trees = TRUE}, \code{boot.phylo} returns
+ a list whose first element (named \code{"BP"}) is like before, and the
+ second element (\code{"trees"}) is a list with the bootstraped
+ trees.
+
+ \code{summary} returns a numeric vector.
+}
+\references{
+ Efron, B., Halloran, E. and Holmes, S. (1996) Bootstrap confidence
+ levels for phylogenetic trees. \emph{Proceedings of the National
+ Academy of Sciences USA}, \bold{93}, 13429--13434.
+
+ Felsenstein, J. (1985) Confidence limits on phylogenies: an approach
+ using the bootstrap. \emph{Evolution}, \bold{39}, 783--791.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{as.bitsplits}}, \code{\link{dist.topo}},
+ \code{\link{consensus}}, \code{\link{nodelabels}}
+}
+\examples{
+data(woodmouse)
+f <- function(x) nj(dist.dna(x))
+tr <- f(woodmouse)
+### Are bootstrap values stable?
+for (i in 1:5)
+ print(boot.phylo(tr, woodmouse, f, quiet = TRUE))
+### How many partitions in 100 random trees of 10 labels?...
+TR <- rmtree(100, 10)
+pp10 <- prop.part(TR)
+length(pp10)
+### ... and in 100 random trees of 20 labels?
+TR <- rmtree(100, 20)
+pp20 <- prop.part(TR)
+length(pp20)
+plot(pp10, pch = "x", col = 2)
+plot(pp20, pch = "x", col = 2)
+
+set.seed(1)
+tr <- rtree(10) # rooted by default
+prop.clades(tr, tr) # clearly wrong
+prop.clades(tr, tr, rooted = TRUE)
+tr <- rtree(10, rooted = FALSE)
+prop.clades(tr, tr) # correct
+}
+\keyword{manip}
+\keyword{htest}
diff --git a/man/branching.times.Rd b/man/branching.times.Rd
new file mode 100644
index 0000000..9bb5329
--- /dev/null
+++ b/man/branching.times.Rd
@@ -0,0 +1,27 @@
+\name{branching.times}
+\alias{branching.times}
+\title{Branching Times of a Phylogenetic Tree}
+\usage{
+branching.times(phy)
+}
+\arguments{
+ \item{phy}{an object of class \code{"phylo"}.}
+}
+\description{
+ This function computes the branching times of a phylogenetic tree,
+ that is the distance from each node to the tips, under the assumption that
+ the tree is ultrametric. Note that the function does not check that the
+ tree is effectively ultrametric, so if it is not, the returned result
+ may not be meaningful.
+}
+\value{
+ a numeric vector with the branching times. If the phylogeny \code{phy}
+ has an element \code{node.label}, this is used as names for the
+ returned vector; otherwise the numbers (of mode character) of the
+ matrix \code{edge} of \code{phy} are used as names.
+}
+\author{Emmanuel Paradis}
+\seealso{
+\code{\link{is.ultrametric}}
+}
+\keyword{manip}
diff --git a/man/c.phylo.Rd b/man/c.phylo.Rd
new file mode 100644
index 0000000..98497f3
--- /dev/null
+++ b/man/c.phylo.Rd
@@ -0,0 +1,55 @@
+\name{c.phylo}
+\alias{c.phylo}
+\alias{c.multiPhylo}
+\alias{.compressTipLabel}
+\alias{.uncompressTipLabel}
+\title{Building Lists of Trees}
+\description{
+ These functions help to build lists of trees of class \code{"multiPhylo"}.
+}
+\usage{
+\method{c}{phylo}(..., recursive = FALSE)
+\method{c}{multiPhylo}(..., recursive = FALSE)
+.compressTipLabel(x)
+.uncompressTipLabel(x)
+}
+\arguments{
+ \item{\dots}{one or several objects of class \code{"phylo"} or
+ \code{"multiPhylo"}.}
+ \item{recursive}{for compatibily with the generic (do not change).}
+ \item{x}{an object of class \code{"phylo"} or \code{"multiPhylo"}.}
+}
+\details{
+ These \code{c} methods do not check all the arguments, so it is the
+ user's responsibility to make sure that only objects of the same class
+ (either \code{"phylo"} or \code{"multiPhylo"}) are used.
+
+ \code{.compressTipLabel} transforms an object of class
+ \code{"multiPhylo"} by checking that all trees have the same tip
+ labels and renumbering the tips in the \code{edge} matrix so that the
+ tip numbers are also the same taking the first tree as the reference
+ (duplicated labels are not allowed). The returned object has a unique
+ vector of tip labels (\code{attr(x, "TipLabel")}).
+
+ \code{.uncompressTipLabel} does the reverse operation.
+}
+\value{
+ An object of class \code{"multiPhylo"}.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{summary.phylo}}, \code{\link{multiphylo}}
+}
+\examples{
+x <- c(rtree(4), rtree(2))
+x
+y <- c(rtree(4), rtree(4))
+z <- c(x, y)
+z
+print(z, TRUE)
+try(.compressTipLabel(x)) # error
+a <- .compressTipLabel(y)
+.uncompressTipLabel(a) # back to y
+## eventually compare str(a) and str(y)
+}
+\keyword{manip}
diff --git a/man/carnivora.Rd b/man/carnivora.Rd
new file mode 100644
index 0000000..fb1dfca
--- /dev/null
+++ b/man/carnivora.Rd
@@ -0,0 +1,49 @@
+\name{carnivora}
+\docType{data}
+\alias{carnivora}
+\title{Carnivora body sizes and life history traits}
+\description{
+ Dataset adapted from Gittleman (1986), including 2 morphological variables (body and brain sizes), 8 life history traits variables and 4 taxonomic variables.
+}
+\usage{data(carnivora)}
+\format{
+ A data frame with 112 observations on 17 variables.
+
+ \tabular{rlll}{
+ [,1] \tab Order \tab factor \tab Carnivora order \cr
+ [,2] \tab SuperFamily \tab factor \tab Super family (Caniformia or Feliformia) \cr
+ [,3] \tab Family \tab factor \tab Carnivora family \cr
+ [,4] \tab Genus \tab factor \tab Carnivora genus \cr
+ [,5] \tab Species \tab factor \tab Carnivora species \cr
+ [,6] \tab FW \tab numeric \tab Female body weight (kg) \cr
+ [,7] \tab SW \tab numeric \tab Average body weight of adult male and adult female (kg) \cr
+ [,8] \tab FB \tab numeric \tab Female brain weight (g) \cr
+ [,9] \tab SB \tab numeric \tab Average brain weight of adult male and adult female (g) \cr
+ [,10] \tab LS \tab numeric \tab Litter size \cr
+ [,11] \tab GL \tab numeric \tab Gestation length (days) \cr
+ [,12] \tab BW \tab numeric \tab Birth weigth (g) \cr
+ [,13] \tab WA \tab numeric \tab Weaning age (days) \cr
+ [,14] \tab AI \tab numeric \tab Age of independance (days) \cr
+ [,15] \tab LY \tab numeric \tab Longevity (months) \cr
+ [,16] \tab AM \tab numeric \tab Age of sexual maturity (days) \cr
+ [,17] \tab IB \tab numeric \tab Inter-birth interval (months) \cr
+ }
+}
+\source{
+ Gittleman, J. L. (1986) Carnivore life history patterns: allometric,
+ phylogenetic and ecological associations. \emph{American Naturalist},
+ \bold{127}: 744--771.
+}
+\examples{
+ data(carnivora);
+ # This is figure 1 of Gittleman 1986:
+ library(lattice)
+ trellis.device(color=FALSE)
+ xyplot(BW ~ FW, groups=Family, data=carnivora, auto.key=TRUE, xlog=TRUE,
+ scale=list(log=TRUE), ylim=c(1, 2000))
+ trellis.device(color=FALSE)
+ xyplot(BW ~ FB, groups=Family, data=carnivora, auto.key=TRUE, xlog=TRUE,
+ scale=list(log=TRUE), ylim=c(1, 2000))
+}
+\keyword{datasets}
+
diff --git a/man/cherry.Rd b/man/cherry.Rd
new file mode 100644
index 0000000..e57f275
--- /dev/null
+++ b/man/cherry.Rd
@@ -0,0 +1,47 @@
+\name{cherry}
+\alias{cherry}
+\title{Number of Cherries and Null Models of Trees}
+\usage{
+cherry(phy)
+}
+\arguments{
+ \item{phy}{an object of class \code{"phylo"}.}
+}
+\description{
+ This function calculates the number of cherries (see definition below)
+ on a phylogenetic tree, and tests the null hypotheses whether this
+ number agrees with those predicted from two null models of trees (the
+ Yule model, and the uniform model).
+}
+\value{
+ A NULL value is returned, the results are simply printed.
+}
+\details{
+ A cherry is a pair of adjacent tips on a tree. The tree can be either
+ rooted or unrooted, but the present function considers only rooted
+ trees. The probability distribution function of the number of cherries
+ on a tree depends on the speciation/extinction model that generated
+ the tree.
+
+ McKenzie and Steel (2000) derived the probability
+ distribution function of the number of cherries for two models: the
+ Yule model and the uniform model. Broadly, in the Yule model, each extant
+ species is equally likely to split into two daughter-species; in the
+ uniform model, a branch is added to tree on any of the already
+ existing branches with a uniform probability.
+
+ The probabilities are computed using recursive formulae; however, for
+ both models, the probability density function converges to a normal
+ law with increasing number of tips in the tree. The function uses
+ these normal approximations for a number of tips greater than or equal
+ to 20.
+}
+\references{
+ McKenzie, A. and Steel, M. (2000) Distributions of cherries for two
+ models of trees. \emph{Mathematical Biosciences}, \bold{164}, 81--92.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{gammaStat}}
+}
+\keyword{univar}
diff --git a/man/chiroptera.Rd b/man/chiroptera.Rd
new file mode 100644
index 0000000..e8081f3
--- /dev/null
+++ b/man/chiroptera.Rd
@@ -0,0 +1,32 @@
+\name{chiroptera}
+\alias{chiroptera}
+\title{Bat Phylogeny}
+\description{
+ This phylogeny of bats (Mammalia: Chiroptera) is a supertree (i.e. a
+ composite phylogeny constructed from several sources; see source for
+ details).
+}
+\usage{
+data(chiroptera)
+}
+\format{
+ The data are stored in RData (binary) format.
+}
+\source{
+ Jones, K. E., Purvis, A., MacLarnon, A., Bininda-Emonds, O. R. P. and
+ Simmons, N. B. (2002) A phylogenetic supertree of the bats (Mammalia:
+ Chiroptera). \emph{Biological Reviews of the Cambridge Philosophical
+ Society}, \bold{77}, 223--259.
+}
+\seealso{
+ \code{\link{read.nexus}}, \code{\link{zoom}}
+}
+\examples{
+data(chiroptera)
+str(chiroptera)
+op <- par()
+par(cex = 0.3)
+plot(chiroptera, type = "c")
+par(op)
+}
+\keyword{datasets}
diff --git a/man/chronoMPL.Rd b/man/chronoMPL.Rd
new file mode 100644
index 0000000..fb1a6f4
--- /dev/null
+++ b/man/chronoMPL.Rd
@@ -0,0 +1,75 @@
+\name{chronoMPL}
+\alias{chronoMPL}
+\title{Molecular Dating With Mean Path Lengths}
+\usage{
+chronoMPL(phy, se = TRUE, test = TRUE)
+}
+\arguments{
+ \item{phy}{an object of class \code{"phylo"}.}
+ \item{se}{a logical specifying whether to compute the standard-errors
+ of the node ages (\code{TRUE} by default).}
+ \item{test}{a logical specifying whether to test the molecular clock
+ at each node (\code{TRUE} by default).}
+}
+\description{
+ This function estimates the node ages of a tree using the mean path
+ lengths method of Britton et al. (2002). The branch lengths of the
+ input tree are interpreted as (mean) numbers of substitutions.
+}
+\details{
+ The mean path lengths (MPL) method estimates the age of a node with
+ the mean of the distances from this node to all tips descending from
+ it. Under the assumption of a molecular clock, standard-errors of the
+ estimates node ages can be computed (Britton et al. 2002).
+
+ The tests performed if \code{test = TRUE} is a comparison of the MPL
+ of the two subtrees originating from a node; the null hypothesis is
+ that the rate of substitution was the same in both subtrees (Britton
+ et al. 2002). The test statistic follows, under the null hypothesis, a
+ standard normal distribution. The returned \emph{P}-value is the
+ probability of observing a greater absolute value (i.e., a two-sided
+ test). No correction for multiple testing is applied: this is left to
+ the user.
+
+ Absolute dating can be done by multiplying the edge lengths found by
+ calibrating one node age.
+}
+\note{
+ The present version requires a dichotomous tree.
+}
+\value{
+ an object of class \code{"phylo"} with branch lengths as estimated by
+ the function. There are, by default, two attributes:
+
+ \item{stderr}{the standard-errors of the node ages.}
+ \item{Pval}{the \emph{P}-value of the test of the molecular clock for
+ each node.}
+}
+\references{
+ Britton, T., Oxelman, B., Vinnersten, A. and Bremer, K. (2002)
+ Phylogenetic dating with confidence intervals using mean path
+ lengths. \emph{Molecular Phylogenetics and Evolution}, \bold{24},
+ 58--65.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{chronopl}}
+}
+\examples{
+tr <- rtree(10)
+tr$edge.length <- 5*tr$edge.length
+chr <- chronoMPL(tr)
+layout(matrix(1:4, 2, 2, byrow = TRUE))
+plot(tr)
+title("The original tree")
+plot(chr)
+axisPhylo()
+title("The dated MPL tree")
+plot(chr)
+nodelabels(round(attr(chr, "stderr"), 3))
+title("The standard-errors")
+plot(tr)
+nodelabels(round(attr(chr, "Pval"), 3))
+title("The tests")
+}
+\keyword{models}
diff --git a/man/chronopl.Rd b/man/chronopl.Rd
new file mode 100644
index 0000000..339a284
--- /dev/null
+++ b/man/chronopl.Rd
@@ -0,0 +1,118 @@
+\name{chronopl}
+\alias{chronopl}
+\title{Molecular Dating With Penalized Likelihood}
+\description{
+ This function estimates the node ages of a tree using a
+ semi-parametric method based on penalized likelihood (Sanderson
+ 2002). The branch lengths of the input tree are interpreted as mean
+ numbers of substitutions (i.e., per site).
+}
+\usage{
+chronopl(phy, lambda, age.min = 1, age.max = NULL,
+ node = "root", S = 1, tol = 1e-8,
+ CV = FALSE, eval.max = 500, iter.max = 500, ...)
+}
+\arguments{
+ \item{phy}{an object of class \code{"phylo"}.}
+ \item{lambda}{value of the smoothing parameter.}
+ \item{age.min}{numeric values specifying the fixed node ages (if
+ \code{age.max = NULL}) or the youngest bound of the nodes known to
+ be within an interval.}
+ \item{age.max}{numeric values specifying the oldest bound of the nodes
+ known to be within an interval.}
+ \item{node}{the numbers of the nodes whose ages are given by
+ \code{age.min}; \code{"root"} is a short-cut for the root.}
+ \item{S}{the number of sites in the sequences; leave the default if
+ branch lengths are in mean number of substitutions.}
+ \item{tol}{the value below which branch lengths are considered
+ effectively zero.}
+ \item{CV}{whether to perform cross-validation.}
+ \item{eval.max}{the maximal number of evaluations of the penalized
+ likelihood function.}
+ \item{iter.max}{the maximal number of iterations of the optimization
+ algorithm.}
+ \item{\dots}{further arguments passed to control \code{nlminb}.}
+}
+\details{
+ The idea of this method is to use a trade-off between a parametric
+ formulation where each branch has its own rate, and a nonparametric
+ term where changes in rates are minimized between contiguous
+ branches. A smoothing parameter (lambda) controls this trade-off. If
+ lambda = 0, then the parametric component dominates and rates vary as
+ much as possible among branches, whereas for increasing values of
+ lambda, the variation are smoother to tend to a clock-like model (same
+ rate for all branches).
+
+ \code{lambda} must be given. The known ages are given in
+ \code{age.min}, and the correponding node numbers in \code{node}.
+ These two arguments must obviously be of the same length. By default,
+ an age of 1 is assumed for the root, and the ages of the other nodes
+ are estimated.
+
+ If \code{age.max = NULL} (the default), it is assumed that
+ \code{age.min} gives exactly known ages. Otherwise, \code{age.max} and
+ \code{age.min} must be of the same length and give the intervals for
+ each node. Some node may be known exactly while the others are
+ known within some bounds: the values will be identical in both
+ arguments for the former (e.g., \code{age.min = c(10, 5), age.max =
+ c(10, 6), node = c(15, 18)} means that the age of node 15 is 10
+ units of time, and the age of node 18 is between 5 and 6).
+
+ If two nodes are linked (i.e., one is the ancestor of the other) and
+ have the same values of \code{age.min} and \code{age.max} (say, 10 and
+ 15) this will result in an error because the medians of these values
+ are used as initial times (here 12.5) giving initial branch length(s)
+ equal to zero. The easiest way to solve this is to change slightly the
+ given values, for instance use \code{age.max = 14.9} for the youngest
+ node, or \code{age.max = 15.1} for the oldest one (or similarly for
+ \code{age.min}).
+
+ The input tree may have multichotomies. If some internal branches are
+ of zero-length, they are collapsed (with a warning), and the returned
+ tree will have less nodes than the input one. The presence of
+ zero-lengthed terminal branches of results in an error since it makes
+ little sense to have zero-rate branches.
+
+ The cross-validation used here is different from the one proposed by
+ Sanderson (2002). Here, each tip is dropped successively and the
+ analysis is repeated with the reduced tree: the estimated dates for
+ the remaining nodes are compared with the estimates from the full
+ data. For the \eqn{i}{i}th tip the following is calculated:
+
+ \deqn{\sum_{j=1}^{n-2}{\frac{(t_j - t_j^{-i})^2}{t_j}}}{SUM[j = 1, ..., n-2] (tj - tj[-i])^2/tj},
+
+ where \eqn{t_j}{tj} is the estimated date for the \eqn{j}{j}th node
+ with the full phylogeny, \eqn{t_j^{-i}}{tj[-i]} is the estimated date
+ for the \eqn{j}{j}th node after removing tip \eqn{i}{i} from the tree,
+ and \eqn{n}{n} is the number of tips.
+
+ The present version uses the \code{\link[stats]{nlminb}} to optimise
+ the penalized likelihood function: see its help page for details on
+ parameters controlling the optimisation procedure.
+}
+\value{
+ an object of class \code{"phylo"} with branch lengths as estimated by
+ the function. There are three or four further attributes:
+
+ \item{ploglik}{the maximum penalized log-likelihood.}
+ \item{rates}{the estimated rates for each branch.}
+ \item{message}{the message returned by \code{nlminb} indicating
+ whether the optimisation converged.}
+ \item{D2}{the influence of each observation on overall date
+ estimates (if \code{CV = TRUE}).}
+}
+\note{
+ The new function \code{\link{chronos}} replaces the present one which
+ is no more maintained.
+}
+\references{
+ Sanderson, M. J. (2002) Estimating absolute rates of molecular
+ evolution and divergence times: a penalized likelihood
+ approach. \emph{Molecular Biology and Evolution}, \bold{19},
+ 101--109.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{chronos}}, \code{\link{chronoMPL}}
+}
+\keyword{models}
diff --git a/man/chronos.Rd b/man/chronos.Rd
new file mode 100644
index 0000000..8f01d25
--- /dev/null
+++ b/man/chronos.Rd
@@ -0,0 +1,137 @@
+\name{chronos}
+\alias{chronos}
+\alias{makeChronosCalib}
+\alias{chronos.control}
+\alias{print.chronos}
+\title{Molecular Dating by Penalised Likelihood and Maximum Likelihood}
+\description{
+ \code{chronos} is the main function fitting a chronogram to a
+ phylogenetic tree whose branch lengths are in number of substitution
+ per sites.
+
+ \code{makeChronosCalib} is a tool to prepare data frames with the
+ calibration points of the phylogenetic tree.
+
+ \code{chronos.control} creates a list of parameters to be passed
+ to \code{chronos}.
+}
+\usage{
+chronos(phy, lambda = 1, model = "correlated", quiet = FALSE,
+ calibration = makeChronosCalib(phy),
+ control = chronos.control())
+\method{print}{chronos}(x, ...)
+makeChronosCalib(phy, node = "root", age.min = 1,
+ age.max = age.min, interactive = FALSE, soft.bounds = FALSE)
+chronos.control(...)
+}
+\arguments{
+ \item{phy}{an object of class \code{"phylo"}.}
+ \item{lambda}{value of the smoothing parameter.}
+ \item{model}{a character string specifying the model of substitution
+ rate variation among branches. The possible choices are:
+ ``correlated'', ``relaxed'', ``discrete'', or an unambiguous
+ abbreviation of these.}
+ \item{quiet}{a logical value; by default the calculation progress are
+ displayed.}
+ \item{calibration}{a data frame (see details).}
+ \item{control}{a list of parameters controlling the optimisation
+ procedure (see details).}
+ \item{x}{an object of class \code{c("chronos", "phylo")}.}
+ \item{node}{a vector of integers giving the node numbers for which a
+ calibration point is given. The default is a short-cut for the
+ root.}
+ \item{age.min, age.max}{vectors of numerical values giving the minimum
+ and maximum ages of the nodes specified in \code{node}.}
+ \item{interactive}{a logical value. If \code{TRUE}, then \code{phy} is
+ plotted and the user is asked to click close to a node and enter the
+ ages on the keyboard.}
+ \item{soft.bounds}{(currently unused)}
+ \item{\dots}{in the case of \code{chronos.control}: one of the five
+ parameters controlling optimisation (unused in the case of
+ \code{print.chronos}).}
+}
+\details{
+ \code{chronos} replaces \code{chronopl} but with a different interface
+ and some extensions (see References).
+
+ The known dates (argument \code{calibration}) must be given in a data
+ frame with the following column names: node, age.min, age.max, and
+ soft.bounds (the last one is yet unused). For each row, these are,
+ respectively: the number of the node in the ``phylo'' coding standard,
+ the minimum age for this node, the maximum age, and a logical value
+ specifying whether the bounds are soft. If age.min = age.max, this
+ means that the age is exactly known. This data frame can be built with
+ \code{makeChronosCalib} which returns by default a data frame with a
+ single row giving age = 1 for the root. The data frame can be built
+ interactively by clicking on the plotted tree.
+
+ The argument \code{control} allows one to change some parameters of
+ the optimisation procedure. This must be a list with names. The
+ available options with their default values are:
+
+ \itemize{
+ \item{tol = 1e-8: }{tolerance for the estimation of the substitution
+ rates.}
+ \item{iter.max = 1e4: }{the maximum number of iterations at each
+ optimization step.}
+ \item{eval.max = 1e4: }{the maximum number of function evaluations at
+ each optimization step.}
+ \item{nb.rate.cat = 10: }{the number of rate categories if \code{model
+ = "discrete"} (set this parameter to 1 to fit a strict clock
+ model).}
+ \item{dual.iter.max = 20: }{the maximum number of alternative
+ iterations between rates and dates.}
+ }
+
+ The command \code{chronos.control()} returns a list with the default
+ values of these parameters. They may be modified by passing them to
+ this function, or directly in the list.
+}
+\value{
+ \code{chronos} returns an object of class \code{c("chronos",
+ "phylo")}. There is a print method for it. There are additional
+ attributes which can be visualised with \code{str} or extracted with
+ \code{attr}.
+
+ \code{makeChronosCalib} returns a data frame.
+
+ \code{chronos.control} returns a list.
+}
+\references{
+ Kim, J. and Sanderson, M. J. (2008) Penalized likelihood phylogenetic
+ inference: bridging the parsimony-likelihood gap. \emph{Systematic
+ Biology}, \bold{57}, 665--674.
+
+ Paradis, E. (2013) Molecular dating of phylogenies by likelihood
+ methods: a comparison of models and a new information
+ criterion. \emph{Molecular Phylogenetics and Evolution}, \bold{67},
+ 436--444.
+
+ Sanderson, M. J. (2002) Estimating absolute rates of molecular
+ evolution and divergence times: a penalized likelihood
+ approach. \emph{Molecular Biology and Evolution}, \bold{19},
+ 101--109.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{chronoMPL}}
+}
+\examples{
+tr <- rtree(10)
+### the default is the correlated rate model:
+chr <- chronos(tr)
+### strict clock model:
+ctrl <- chronos.control(nb.rate.cat = 1)
+chr.clock <- chronos(tr, model = "discrete", control = ctrl)
+### How different are the rates?
+attr(chr, "rates")
+attr(chr.clock, "rates")
+\dontrun{
+cal <- makeChronosCalib(tr, interactive = TRUE)
+cal
+### if you made mistakes, you can edit the data frame with:
+### fix(cal)
+chr <- chronos(tr, calibration = cal)
+}
+}
+\keyword{models}
diff --git a/man/clustal.Rd b/man/clustal.Rd
new file mode 100644
index 0000000..afb8d73
--- /dev/null
+++ b/man/clustal.Rd
@@ -0,0 +1,87 @@
+\name{clustal}
+\alias{clustal}
+\alias{muscle}
+\alias{tcoffee}
+\title{Multiple Sequence Alignment with External Applications}
+\description{
+ These functions call their respective program from \R to align a set of
+ nucleotide sequences of class \code{"DNAbin"}.
+}
+\usage{
+clustal(x, pw.gapopen = 10, pw.gapext = 0.1,
+ gapopen = 10, gapext = 0.2, exec = NULL,
+ MoreArgs = "", quiet = TRUE, original.ordering = TRUE)
+muscle(x, exec = "muscle", MoreArgs = "", quiet = TRUE,
+ original.ordering = TRUE)
+tcoffee(x, exec = "t_coffee", MoreArgs = "", quiet = TRUE,
+ original.ordering = TRUE)
+}
+\arguments{
+ \item{x}{an object of class \code{"DNAbin"}.}
+ \item{pw.gapopen, pw.gapext}{gap opening and gap extension penalties
+ used by Clustal during pairwise alignments.}
+ \item{gapopen, gapext}{idem for global alignment.}
+ \item{exec}{a character string giving the name of the program, with
+ its path if necessary. \code{clustal} tries to guess it depending on
+ the operating system (see details).}
+ \item{MoreArgs}{a character string giving additional options.}
+ \item{quiet}{a logical: the default is to not print on \R's console the
+ messages from the external program.}
+ \item{original.ordering}{a logical specifying whether to return the
+ aligned sequences in the same order than in \code{x}.}
+}
+\details{
+ \code{clustal} tries to guess the name of the executable program
+ depending on the operating system. Specifically, the followings are
+ used: ``clustalw'' under Linux, ``clustalw2'' under MacOS, or
+ ``C:/Program Files/ClustalW2/clustalw2'' under Windows.
+
+ The calculations are done in a temporary directory which is deleted
+ when \R is quit. So it is possible to find the files created by the
+ last call in the directory printed by \code{tempdir()}.
+
+ When called without arguments (i.e., \code{clustal()}, \dots), the
+ function prints the options of the program which may be passed to
+ \code{MoreArgs}.
+}
+\value{
+ an object of class \code{"DNAbin"} with the aligned sequences.
+}
+\references{
+ Chenna, R., Sugawara, H., Koike, T., Lopez, R., Gibson, T. J.,
+ Higgins, D. G. and Thompson, J. D. (2003) Multiple sequence alignment
+ with the Clustal series of programs. \emph{Nucleic Acids Research}
+ \bold{31}, 3497--3500.
+ \url{http://www.clustal.org/}
+
+ Edgar, R. C. (2004) MUSCLE: Multiple sequence alignment with high
+ accuracy and high throughput. \emph{Nucleic Acids Research},
+ \bold{32}, 1792--1797.
+ \url{http://www.drive5.com/muscle/muscle_userguide3.8.html}
+
+ Notredame, C., Higgins, D. and Heringa, J. (2000) T-Coffee: A novel
+ method for multiple sequence alignments. \emph{Journal of Molecular
+ Biology}, \bold{302}, 205--217.
+ \url{http://www.tcoffee.org/Documentation/t_coffee/t_coffee_technical.htm}
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{image.DNAbin}}, \code{\link{del.gaps}}, \code{\link{alex}}
+
+ The package \pkg{phyloch} which has similar functions for the MAFFT
+ and Prank.
+}
+\examples{
+\dontrun{
+### display the options:
+clustal()
+muscle()
+tcoffee()
+
+data(woodmouse)
+### open gaps more easily:
+clustal(woodmouse, pw.gapopen = 1, pw.gapext = 1)
+### T-Coffee requires negative values (quite slow; muscle is much faster):
+tcoffee(woodmouse, MoreArgs = "-gapopen=-10 -gapext=-2")
+}}
+\keyword{manip}
diff --git a/man/coalescent.intervals.Rd b/man/coalescent.intervals.Rd
new file mode 100644
index 0000000..1a3ac19
--- /dev/null
+++ b/man/coalescent.intervals.Rd
@@ -0,0 +1,50 @@
+\name{coalescent.intervals}
+\alias{coalescent.intervals}
+\alias{coalescent.intervals.phylo}
+\alias{coalescent.intervals.default}
+
+\title{Coalescent Intervals}
+\usage{
+coalescent.intervals(x)
+}
+\arguments{
+ \item{x}{either an ultra-metric phylogenetic tree (i.e. an object of
+ class \code{"phylo"}) or, alternatively, a vector of interval lengths.}
+}
+\description{
+ This function extracts or generates information about coalescent intervals
+ (number of lineages, interval lengths, interval count, total depth) from
+ a phylogenetic tree or a list of internode distances. The input tree
+ needs to be ultra-metric (i.e. clock-like).
+}
+\value{
+An object of class \code{"coalescentIntervals"} with the following entries:
+
+ \item{lineages}{ A vector with the number of lineages at the start of each coalescent
+ interval.}
+ \item{interval.length}{ A vector with the length of each coalescent
+ interval.}
+ \item{interval.count}{ The total number of coalescent
+ intervals.}
+ \item{total.depth}{ The sum of the lengths of all coalescent
+ intervals.}
+}
+\seealso{
+\code{\link{branching.times}}, \code{\link{collapsed.intervals}},
+\code{\link{read.tree}}.
+}
+
+\author{Korbinian Strimmer (\url{http://www.stat.uni-muenchen.de/~strimmer/})}
+
+\examples{
+data("hivtree.newick") # example tree in NH format
+tree.hiv <- read.tree(text = hivtree.newick) # load tree
+
+ci <- coalescent.intervals(tree.hiv) # from tree
+ci
+
+data("hivtree.table") # same tree, but in table format
+ci <- coalescent.intervals(hivtree.table$size) # from vector of interval lengths
+ci
+}
+\keyword{manip}
diff --git a/man/collapse.singles.Rd b/man/collapse.singles.Rd
new file mode 100644
index 0000000..ecfa0ec
--- /dev/null
+++ b/man/collapse.singles.Rd
@@ -0,0 +1,21 @@
+\name{collapse.singles}
+\alias{collapse.singles}
+\title{Collapse Single Nodes}
+\usage{
+collapse.singles(tree)
+}
+\arguments{
+ \item{tree}{an object of class \code{"phylo"}.}
+}
+\description{
+ This function deletes the single nodes (i.e., with a single
+ descendant) in a tree.
+}
+\value{
+ an object of class \code{"phylo"}.
+}
+\author{Ben Bolker}
+\seealso{
+ \code{\link{plot.phylo}}, \code{\link{read.tree}}
+}
+\keyword{manip}
diff --git a/man/collapsed.intervals.Rd b/man/collapsed.intervals.Rd
new file mode 100644
index 0000000..27a79ce
--- /dev/null
+++ b/man/collapsed.intervals.Rd
@@ -0,0 +1,74 @@
+\name{collapsed.intervals}
+\alias{collapsed.intervals}
+
+\title{Collapsed Coalescent Intervals}
+\usage{
+collapsed.intervals(ci, epsilon=0)
+}
+\arguments{
+ \item{ci}{coalescent intervals (i.e. an object of class \code{"coalescentIntervals"}).}
+ \item{epsilon}{collapsing parameter that controls the amount of smoothing
+ (allowed range: from \code{0} to \code{ci$total.depth})}
+}
+\description{
+ This function takes a \code{"coalescentIntervals"} objects and collapses neighbouring
+ coalescent intervals into a single combined interval so that every collapsed interval is
+ larger than \code{epsilon}. Collapsed coalescent intervals are used, e.g., to obtain the
+ generalized skyline plot (\code{\link{skyline}}). For \code{epsilon = 0} no interval
+ is collapsed.
+}
+\details{
+Proceeding from the tips to the root of the tree each small
+interval is pooled with the neighboring interval closer to the root. If the
+neighboring interval is also small, then pooling continues until the composite
+interval is larger than \code{epsilon}. Note that this approach prevents the
+occurrence of zero-length intervals at the present.
+For more details see Strimmer and Pybus (2001).
+}
+
+\value{
+An object of class \code{"collapsedIntervals"} with the following entries:
+
+ \item{lineages}{ A vector with the number of lineages at the start of each coalescent
+ interval.}
+ \item{interval.length}{ A vector with the length of each coalescent
+ interval.}
+ \item{collapsed.interval}{A vector indicating for each coalescent interval to which
+ collapsed interval it belongs.}
+ \item{interval.count}{ The total number of coalescent
+ intervals.}
+ \item{collapsed.interval.count}{The number of collapsed intervals.}
+ \item{total.depth}{ The sum of the lengths of all coalescent
+ intervals.}
+ \item{epsilon}{The value of the underlying smoothing parameter.}
+}
+
+\author{Korbinian Strimmer (\url{http://www.stat.uni-muenchen.de/~strimmer/})}
+
+\seealso{
+\code{\link{coalescent.intervals}},\code{\link{skyline}}.
+}
+
+
+\references{
+ Strimmer, K. and Pybus, O. G. (2001) Exploring the demographic history
+ of DNA sequences using the generalized skyline plot. \emph{Molecular
+ Biology and Evolution}, \bold{18}, 2298--2305.
+}
+
+\examples{
+data("hivtree.table") # example tree
+
+# colescent intervals from vector of interval lengths
+ci <- coalescent.intervals(hivtree.table$size)
+ci
+
+# collapsed intervals
+cl1 <- collapsed.intervals(ci,0)
+cl2 <- collapsed.intervals(ci,0.0119)
+
+cl1
+cl2
+
+}
+\keyword{manip}
diff --git a/man/compar.cheverud.Rd b/man/compar.cheverud.Rd
new file mode 100644
index 0000000..404b788
--- /dev/null
+++ b/man/compar.cheverud.Rd
@@ -0,0 +1,74 @@
+\name{compar.cheverud}
+\alias{compar.cheverud}
+\title{Cheverud's Comparative Method}
+\description{
+ This function computes the phylogenetic variance component and the
+ residual deviation for continous characters, taking into account the
+ phylogenetic relationships among species, following the comparative
+ method described in Cheverud et al. (1985). The correction proposed by
+ Rholf (2001) is used.
+}
+\usage{
+compar.cheverud(y, W, tolerance = 1e-06, gold.tol = 1e-04)
+}
+\arguments{
+ \item{y}{A vector containing the data to analyse.}
+ \item{W}{The phylogenetic connectivity matrix. All diagonal elements
+ will be ignored.}
+ \item{tolerance}{Minimum difference allowed to consider eigenvalues as
+ distinct.}
+ \item{gold.tol}{Precision to use in golden section search alogrithm.}
+}
+\details{
+ Model: \deqn{y = \rho W y + e}{y = rho.W.y + e}
+
+ where \eqn{e}{e} is the error term, assumed to be normally distributed.
+ \eqn{\rho}{rho} is estimated by the maximum likelihood procedure given
+ in Rohlf (2001), using a golden section search algorithm. The code of
+ this function is indeed adapted from a MatLab code given in appendix
+ in Rohlf's article, to correct a mistake in Cheverud's original paper.
+}
+\value{
+ A list with the following components:
+
+ \item{rhohat}{The maximum likelihood estimate of \eqn{\rho}{rho}}
+ \item{Wnorm}{The normalized version of \code{W}}
+ \item{residuals}{Error terms (\eqn{e}{e})}
+}
+\references{
+ Cheverud, J. M., Dow, M. M. and Leutenegger, W. (1985) The quantitative
+ assessment of phylogenetic constraints in comparative analyses: sexual
+ dimorphism in body weight among primates. \emph{Evolution},
+ \bold{39}, 1335--1351.
+
+ Rohlf, F. J. (2001) Comparative methods for the analysis of continuous
+ variables: geometric interpretations. \emph{Evolution}, \bold{55},
+ 2143--2160.
+
+ Harvey, P. H. and Pagel, M. D. (1991) \emph{The Comparative Method in
+ Evolutionary Biology}. Oxford University Press.
+}
+\author{Julien Dutheil \email{julien.dutheil at univ-montp2.fr}}
+\seealso{\code{\link{compar.lynch}}}
+\examples{
+### Example from Harvey and Pagel's book:
+y<-c(10,8,3,4)
+W <- matrix(c(1,1/6,1/6,1/6,1/6,1,1/2,1/2,1/6,1/2,1,1,1/6,1/2,1,1), 4)
+compar.cheverud(y,W)
+### Example from Rohlf's 2001 article:
+W<- matrix(c(
+ 0,1,1,2,0,0,0,0,
+ 1,0,1,2,0,0,0,0,
+ 1,1,0,2,0,0,0,0,
+ 2,2,2,0,0,0,0,0,
+ 0,0,0,0,0,1,1,2,
+ 0,0,0,0,1,0,1,2,
+ 0,0,0,0,1,1,0,2,
+ 0,0,0,0,2,2,2,0
+),8)
+W <- 1/W
+W[W == Inf] <- 0
+y<-c(-0.12,0.36,-0.1,0.04,-0.15,0.29,-0.11,-0.06)
+compar.cheverud(y,W)
+}
+\keyword{regression}
diff --git a/man/compar.gee.Rd b/man/compar.gee.Rd
new file mode 100644
index 0000000..3c8e270
--- /dev/null
+++ b/man/compar.gee.Rd
@@ -0,0 +1,123 @@
+\name{compar.gee}
+\alias{compar.gee}
+\alias{print.compar.gee}
+\alias{drop1.compar.gee}
+\alias{predict.compar.gee}
+\title{Comparative Analysis with GEEs}
+\description{
+ \code{compar.gee} performs the comparative analysis using generalized
+ estimating equations as described by Paradis and Claude (2002).
+
+ \code{drop1} tests single effects of a fitted model output from
+ \code{compar.gee}.
+
+ \code{predict} returns the predicted (fitted) values of the model.
+}
+\usage{
+compar.gee(formula, data = NULL, family = "gaussian", phy, corStruct,
+ scale.fix = FALSE, scale.value = 1)
+\method{drop1}{compar.gee}(object, scope, quiet = FALSE, ...)
+\method{predict}{compar.gee}(object, newdata = NULL, type = c("link", "response"), ...)
+}
+\arguments{
+ \item{formula}{a formula giving the model to be fitted.}
+ \item{data}{the name of the data frame where the variables in
+ \code{formula} are to be found; by default, the variables are looked
+ for in the global environment.}
+ \item{family}{a function specifying the distribution assumed for the
+ response; by default a Gaussian distribution (with link identity) is
+ assumed (see \code{?family} for details on specifying the
+ distribution, and on changing the link function).}
+ \item{phy}{an object of class \code{"phylo"} (ignored if
+ \code{corStruct} is used).}
+ \item{corStruct}{a (phylogenetic) correlation structure.}
+ \item{scale.fix}{logical, indicates whether the scale parameter should
+ be fixed (TRUE) or estimated (FALSE, the default).}
+ \item{scale.value}{if \code{scale.fix = TRUE}, gives the value for the
+ scale (default: \code{scale.value = 1}).}
+ \item{object}{an object of class \code{"compar.gee"} resulting from
+ fitting \code{compar.gee}.}
+ \item{scope}{<unused>.}
+ \item{quiet}{a logical specifying whether to display a warning message
+ about eventual ``marginality principle violation''.}
+ \item{newdata}{a data frame with column names matching the variables
+ in the formula of the fitted object (see
+ \code{\link[stats]{predict}} for details).}
+ \item{type}{a character string specifying the type of predicted
+ values. By default, the linear (link) prediction is returned.}
+ \item{\dots}{further arguments to be passed to \code{drop1}.}
+}
+\details{
+ If a data frame is specified for the argument \code{data}, then its
+ rownames are matched to the tip labels of \code{phy}. The user must be
+ careful here since the function requires that both series of names
+ perfectly match, so this operation may fail if there is a typing or
+ syntax error. If both series of names do not match, the values in the
+ data frame are taken to be in the same order than the tip labels of
+ \code{phy}, and a warning message is issued.
+
+ If \code{data = NULL}, then it is assumed that the variables are in
+ the same order than the tip labels of \code{phy}.
+}
+\note{
+ The calculation of the phylogenetic degrees of freedom is likely to be
+ approximative for non-Brownian correlation structures (this will be
+ refined soon).
+
+ The calculation of the quasilikelihood information criterion (QIC)
+ needs to be tested.
+}
+\value{
+ \code{compar.gee} returns an object of class \code{"compar.gee"} with
+ the following components:
+ \item{call}{the function call, including the formula.}
+ \item{effect.assign}{a vector of integers assigning the coefficients
+ to the effects (used by \code{drop1}).}
+ \item{nobs}{the number of observations.}
+ \item{QIC}{the quasilikelihood information criterion as defined by Pan
+ (2001).}
+ \item{coefficients}{the estimated coefficients (or regression parameters).}
+ \item{residuals}{the regression residuals.}
+ \item{family}{a character string, the distribution assumed for the response.}
+ \item{link}{a character string, the link function used for the mean function.}
+ \item{scale}{the scale (or dispersion parameter).}
+ \item{W}{the variance-covariance matrix of the estimated coefficients.}
+ \item{dfP}{the phylogenetic degrees of freedom (see Paradis and Claude
+ for details on this).}
+
+ \code{drop1} returns an object of class \code{"\link[stats]{anova}"}.
+
+ \code{predict} returns a vector or a data frame if \code{newdata} is used.
+}
+\references{
+ Pan, W. (2001) Akaike's information criterion in generalized
+ estimating equations. \emph{Biometrics}, \bold{57}, 120--125.
+
+ Paradis, E. and Claude J. (2002) Analysis of comparative data using
+ generalized estimating equations. \emph{Journal of theoretical
+ Biology}, \bold{218}, 175--185.
+}
+
+\author{Emmanuel Paradis}
+
+\seealso{
+ \code{\link{read.tree}}, \code{\link{pic}},
+ \code{\link{compar.lynch}}, \code{\link[stats]{drop1}}
+}
+\examples{
+### The example in Phylip 3.5c (originally from Lynch 1991)
+### (the same analysis than in help(pic)...)
+tr <- "((((Homo:0.21,Pongo:0.21):0.28,Macaca:0.49):0.13,Ateles:0.62):0.38,Galago:1.00);"
+tree.primates <- read.tree(text = tr)
+X <- c(4.09434, 3.61092, 2.37024, 2.02815, -1.46968)
+Y <- c(4.74493, 3.33220, 3.36730, 2.89037, 2.30259)
+### Both regressions... the results are quite close to those obtained
+### with pic().
+compar.gee(X ~ Y, phy = tree.primates)
+compar.gee(Y ~ X, phy = tree.primates)
+### Now do the GEE regressions through the origin: the results are quite
+### different!
+compar.gee(X ~ Y - 1, phy = tree.primates)
+compar.gee(Y ~ X - 1, phy = tree.primates)
+}
+\keyword{regression}
diff --git a/man/compar.lynch.Rd b/man/compar.lynch.Rd
new file mode 100644
index 0000000..5cbea68
--- /dev/null
+++ b/man/compar.lynch.Rd
@@ -0,0 +1,67 @@
+\name{compar.lynch}
+\alias{compar.lynch}
+\title{Lynch's Comparative Method}
+\usage{
+compar.lynch(x, G, eps = 1e-4)
+}
+\arguments{
+ \item{x}{eiher a matrix, a vector, or a data.frame containing the data
+ with species as rows and variables as columns.}
+ \item{G}{a matrix that can be interpreted as an among-species correlation
+ matrix.}
+ \item{eps}{a numeric value to detect convergence of the EM algorithm.}
+}
+\description{
+ This function computes the heritable additive value and the residual
+ deviation for continous characters, taking into account the
+ phylogenetic relationships among species, following the comparative
+ method described in Lynch (1991).
+}
+\details{
+ The parameter estimates are computed following the EM
+ (expectation-maximization) algorithm. This algorithm usually leads to
+ convergence but may lead to local optima of the likelihood
+ function. It is recommended to run several times the function in order
+ to detect these potential local optima. The `optimal' value for
+ \code{eps} depends actually on the range of the data and may be
+ changed by the user in order to check the stability of the parameter
+ estimates. Convergence occurs when the differences between two
+ successive iterations of the EM algorithm leads to differences between
+ both residual and additive values less than or equal to \code{eps}.
+}
+\note{
+ The present function does not perform the estimation of ancestral
+ phentoypes as proposed by Lynch (1991). This will be implemented in
+ a future version.
+}
+\value{
+ A list with the following components:
+ \item{vare}{estimated residual variance-covariance matrix.}
+ \item{vara}{estimated additive effect variance covariance matrix.}
+ \item{u}{estimates of the phylogeny-wide means.}
+ \item{A}{addtitive value estimates.}
+ \item{E}{residual values estimates.}
+ \item{lik}{logarithm of the likelihood for the entire set of observed
+ taxon-specific mean.}
+}
+\references{
+ Lynch, M. (1991) Methods for the analysis of comparative data in
+ evolutionary biology. \emph{Evolution}, \bold{45}, 1065--1080.
+}
+\author{Julien Claude \email{claude at isem.univ-montp2.fr}}
+\seealso{
+ \code{\link{pic}}, \code{\link{compar.gee}}
+}
+\examples{
+### The example in Lynch (1991)
+cat("((((Homo:0.21,Pongo:0.21):0.28,",
+ "Macaca:0.49):0.13,Ateles:0.62):0.38,Galago:1.00);",
+ file = "ex.tre", sep = "\n")
+tree.primates <- read.tree("ex.tre")
+unlink("ex.tre")
+X <- c(4.09434, 3.61092, 2.37024, 2.02815, -1.46968)
+Y <- c(4.74493, 3.33220, 3.36730, 2.89037, 2.30259)
+compar.lynch(cbind(X, Y),
+ G = vcv.phylo(tree.primates, cor = TRUE))
+}
+\keyword{regression}
diff --git a/man/compar.ou.Rd b/man/compar.ou.Rd
new file mode 100644
index 0000000..84be454
--- /dev/null
+++ b/man/compar.ou.Rd
@@ -0,0 +1,102 @@
+\name{compar.ou}
+\alias{compar.ou}
+\title{Ornstein--Uhlenbeck Model for Continuous Characters}
+\usage{
+compar.ou(x, phy, node = NULL, alpha = NULL)
+}
+\arguments{
+ \item{x}{a numeric vector giving the values of a continuous
+ character.}
+ \item{phy}{an object of class \code{"phylo"}.}
+ \item{node}{a vector giving the number(s) of the node(s) where the
+ parameter `theta' (the trait optimum) is assumed to change. The
+ node(s) can be specified with their labels if \code{phy} has node
+ labels. By default there is no change (same optimum thoughout lineages).}
+ \item{alpha}{the value of \eqn{\alpha}{alpha} to be used when fitting
+ the model. By default, this parameter is estimated (see details).}
+}
+\description{
+ This function fits an Ornstein--Uhlenbeck model giving a phylogenetic
+ tree, and a continuous character. The user specifies the node(s) where
+ the optimum changes. The parameters are estimated by maximum
+ likelihood; their standard-errors are computed assuming normality of
+ these estimates.
+}
+\details{
+ The Ornstein--Uhlenbeck (OU) process can be seen as a generalization
+ of the Brownian motion process. In the latter, characters are assumed
+ to evolve randomly under a random walk, that is change is equally
+ likely in any direction. In the OU model, change is more likely
+ towards the direction of an optimum (denoted \eqn{\theta}{theta}) with
+ a strength controlled by a parameter denoted \eqn{\alpha}{alpha}.
+
+ The present function fits a model where the optimum parameter
+ \eqn{\theta}{theta}, is allowed to vary throughout the tree. This is
+ specified with the argument \code{node}: \eqn{\theta}{theta} changes
+ after each node whose number is given there. Note that the optimum
+ changes \emph{only} for the lineages which are descendants of this
+ node.
+
+ Hansen (1997) recommends to not estimate \eqn{\alpha}{alpha} together
+ with the other parameters. The present function allows this by giving
+ a numeric value to the argument \code{alpha}. By default, this
+ parameter is estimated, but this seems to yield very large
+ standard-errors, thus validating Hansen's recommendation. In practice,
+ a ``poor man estimation'' of \eqn{\alpha}{alpha} can be done by
+ repeating the function call with different values of \code{alpha}, and
+ selecting the one that minimizes the deviance (see Hansen 1997 for an
+ example).
+
+ If \code{x} has names, its values are matched to the tip labels of
+ \code{phy}, otherwise its values are taken to be in the same order
+ than the tip labels of \code{phy}.
+
+ The user must be careful here since the function requires that both
+ series of names perfectly match, so this operation may fail if there
+ is a typing or syntax error. If both series of names do not match, the
+ values in the \code{x} are taken to be in the same order than the tip
+ labels of \code{phy}, and a warning message is issued.
+}
+\note{
+ The inversion of the variance-covariance matrix in the likelihood
+ function appeared as somehow problematic. The present implementation
+ uses a Cholevski decomposition with the function
+ \code{\link[base]{chol2inv}} instead of the usual function
+ \code{\link[base]{solve}}.
+}
+\value{
+ an object of class \code{"compar.ou"} which is list with the following
+ components:
+
+ \item{deviance}{the deviance (= -2 * loglik).}
+ \item{para}{a data frame with the maximum likelihood estimates and
+ their standard-errors.}
+ \item{call}{the function call.}
+}
+\references{
+ Hansen, T. F. (1997) Stabilizing selection and the comparative
+ analysis of adaptation. \emph{Evolution}, \bold{51}, 1341--1351.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{ace}}, \code{\link{compar.lynch}},
+ \code{\link{corBrownian}}, \code{\link{corMartins}}, \code{\link{pic}}
+}
+\examples{
+data(bird.orders)
+### This is likely to give you estimates close to 0, 1, and 0
+### for alpha, sigma^2, and theta, respectively:
+compar.ou(x <- rnorm(23), bird.orders)
+### Much better with a fixed alpha:
+compar.ou(x, bird.orders, alpha = 0.1)
+### Let us 'mimick' the effect of different optima
+### for the two clades of birds...
+x <- c(rnorm(5, 0), rnorm(18, 5))
+### ... the model with two optima:
+compar.ou(x, bird.orders, node = 25, alpha = .1)
+### ... and the model with a single optimum:
+compar.ou(x, bird.orders, node = NULL, alpha = .1)
+### => Compare both models with the difference in deviances
+## which follows a chi^2 with df = 1.
+}
+\keyword{models}
diff --git a/man/compute.brlen.Rd b/man/compute.brlen.Rd
new file mode 100644
index 0000000..780655c
--- /dev/null
+++ b/man/compute.brlen.Rd
@@ -0,0 +1,60 @@
+\name{compute.brlen}
+\alias{compute.brlen}
+\title{Branch Lengths Computation}
+\usage{
+compute.brlen(phy, method = "Grafen", power = 1, ...)
+}
+\arguments{
+ \item{phy}{an object of class \code{phylo} representing the tree.}
+ \item{method}{the method to be used to compute the branch lengths;
+ this must be one of the followings: (i) \code{"Grafen"} (the
+ default), (ii) a numeric vector, or (iii) a function.}
+ \item{power}{The power at which heights must be raised (see below).}
+ \item{\dots}{further argument(s) to be passed to \code{method} if it is
+ a function.}
+}
+\description{
+ This function computes branch lengths of a tree using different
+ methods.
+}
+\details{
+ Grafen's (1989) computation of branch lengths: each node is given a
+ `height', namely the number of leaves of the subtree minus one, 0 for
+ leaves. Each height is scaled so that root height is 1, and then
+ raised at power 'rho' (> 0). Branch lengths are then computed as the
+ difference between height of lower node and height of upper node.
+
+ If one or several numeric values are provided as \code{method}, they
+ are recycled if necessary. If a function is given instead, further
+ arguments are given in place of \code{...} (they must be named, see
+ examples).
+
+ Zero-length branches are not treated as multichotomies, and thus may
+ need to be collapsed (see \code{\link{di2multi}}).
+}
+\value{
+ An object of class \code{phylo} with branch lengths.
+}
+\author{Julien Dutheil \email{julien.dutheil at univ-montp2.fr} and
+ Emmanuel Paradis}
+\references{
+ Grafen, A. (1989) The phylogenetic regression. \emph{Philosophical
+ Transactions of the Royal society of London. Series B. Biological
+ Sciences}, \bold{326}, 119--157.
+}
+\seealso{
+ \code{\link{read.tree}} for a description of \code{phylo} objects,
+ \code{\link{di2multi}}, \code{\link{multi2di}}
+}
+\examples{
+data(bird.orders)
+plot(compute.brlen(bird.orders, 1))
+plot(compute.brlen(bird.orders, runif, min = 0, max = 5))
+layout(matrix(1:4, 2, 2))
+plot(compute.brlen(bird.orders, power=1), main=expression(rho==1))
+plot(compute.brlen(bird.orders, power=3), main=expression(rho==3))
+plot(compute.brlen(bird.orders, power=0.5), main=expression(rho==0.5))
+plot(compute.brlen(bird.orders, power=0.1), main=expression(rho==0.1))
+layout(1)
+}
+\keyword{manip}
diff --git a/man/compute.brtime.Rd b/man/compute.brtime.Rd
new file mode 100644
index 0000000..8d0c8c4
--- /dev/null
+++ b/man/compute.brtime.Rd
@@ -0,0 +1,47 @@
+\name{compute.brtime}
+\alias{compute.brtime}
+\title{Compute and Set Branching Times}
+\description{
+ This function computes the branch lengths of a tree giving its
+ branching times (aka node ages or heights).
+}
+\usage{
+compute.brtime(phy, method = "coalescent", force.positive = NULL)
+}
+\arguments{
+ \item{phy}{an object of class \code{"phylo"}.}
+ \item{method}{either \code{"coalescent"} (the default), or a numeric
+ vector giving the branching times.}
+ \item{force.positive}{a logical value (see details).}
+}
+\details{
+ By default, a set of random branching times is generated from a simple
+ coalescent, and the option \code{force.positive} is set to \code{TRUE}
+ so that no branch length is negative.
+
+ If a numeric vector is passed to \code{method}, it is taken as the
+ branching times of the nodes with respect to their numbers (i.e., the
+ first element of \code{method} is the branching time of the node
+ numbered \eqn{n + 1} [= the root], the second element of the node
+ numbered \eqn{n + 2}, and so on), so \code{force.positive} is set to
+ \code{FALSE}. This may result in negative branch lengths. To avoid
+ this, one should use \code{force.positive = TRUE} in which case the
+ branching times are eventually reordered.
+}
+\value{
+ An object of class \code{"phylo"} with branch lengths and ultrametric.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{compute.brlen}}, \code{\link{branching.times}}
+}
+\examples{
+tr <- rtree(10)
+layout(matrix(1:4, 2))
+plot(compute.brtime(tr)); axisPhylo()
+plot(compute.brtime(tr, force.positive = FALSE)); axisPhylo()
+plot(compute.brtime(tr, 1:9)); axisPhylo() # a bit nonsense
+plot(compute.brtime(tr, 1:9, TRUE)); axisPhylo()
+layout(1)
+}
+\keyword{manip}
diff --git a/man/consensus.Rd b/man/consensus.Rd
new file mode 100644
index 0000000..ffaa58f
--- /dev/null
+++ b/man/consensus.Rd
@@ -0,0 +1,42 @@
+\name{consensus}
+\alias{consensus}
+\title{Concensus Trees}
+\usage{
+consensus(..., p = 1, check.labels = TRUE)
+}
+\arguments{
+ \item{\dots}{either (i) a single object of class \code{"phylo"}, (ii) a
+ series of such objects separated by commas, or (iii) a list
+ containing such objects.}
+ \item{p}{a numeric value between 0.5 and 1 giving the proportion for a
+ clade to be represented in the consensus tree.}
+ \item{check.labels}{a logical specifying whether to check the labels
+ of each tree. If \code{FALSE} (the default), it is assumed that all
+ trees have the same tip labels, and that they are in the same order
+ (see details).}
+}
+\description{
+ Given a series of trees, this function returns the consensus tree. By
+ default, the strict-consensus tree is computed. To get the
+ majority-rule consensus tree, use \code{p = 0.5}. Any value between
+ 0.5 and 1 can be used.
+}
+\details{
+ Using \code{check.labels = FALSE} results in
+ considerable decrease in computing times. This requires that all
+ trees have the same tip labels, \emph{and} these labels are
+ ordered similarly in all trees (in other words, the element
+ \code{tip.label} are identical in all trees).
+}
+\value{
+ an object of class \code{"phylo"}.
+}
+\references{
+ Felsenstein, J. (2004) \emph{Inferring Phylogenies}. Sunderland:
+ Sinauer Associates.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{prop.part}}, \code{\link{dist.topo}}
+}
+\keyword{manip}
diff --git a/man/cophenetic.phylo.Rd b/man/cophenetic.phylo.Rd
new file mode 100644
index 0000000..78913eb
--- /dev/null
+++ b/man/cophenetic.phylo.Rd
@@ -0,0 +1,30 @@
+\name{cophenetic.phylo}
+\alias{cophenetic.phylo}
+\alias{dist.nodes}
+\title{Pairwise Distances from a Phylogenetic Tree}
+\usage{
+\method{cophenetic}{phylo}(x)
+dist.nodes(x)
+}
+\arguments{
+ \item{x}{an object of class \code{"phylo"}.}
+}
+\description{
+ \code{cophenetic.phylo} computes the pairwise distances between the
+ pairs of tips from a phylogenetic tree using its branch lengths.
+
+ \code{dist.nodes} does the same but between all nodes, internal and
+ terminal, of the tree.
+}
+\value{
+ a numeric matrix with colnames and rownames set to the names of the
+ tips (as given by the element \code{tip.label} of the argument
+ \code{phy}), or, in the case of \code{dist.nodes}, the numbers of the
+ tips and the nodes (as given by the element \code{edge}).
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{read.tree}} to read tree files in Newick format,
+ \code{\link[stats]{cophenetic}} for the generic function
+}
+\keyword{manip}
diff --git a/man/cophyloplot.Rd b/man/cophyloplot.Rd
new file mode 100644
index 0000000..1e7ad1e
--- /dev/null
+++ b/man/cophyloplot.Rd
@@ -0,0 +1,71 @@
+\name{cophyloplot}
+\alias{cophyloplot}
+\title{Plots two phylogenetic trees face to face with links between the tips.}
+\description{
+ This function plots two trees face to face with the links if specified. It is possible to rotate the branches of each tree around the nodes by clicking.
+}
+\usage{
+cophyloplot(x, y, assoc = NULL, use.edge.length = FALSE, space = 0,
+ length.line = 1, gap = 2, type = "phylogram", rotate = FALSE,
+ col = par("fg"), lwd = par("lwd"), lty = par("lty"),
+ show.tip.label = TRUE, font = 3, \dots)
+}
+
+\arguments{
+ \item{x, y}{two objects of class \code{"phylo"}.}
+ \item{assoc}{a matrix with 2 columns specifying the associations
+ between the tips. If NULL, no links will be drawn.}
+ \item{use.edge.length}{a logical indicating whether the branch lengths
+ should be used to plot the trees; default is FALSE.}
+ \item{space}{a positive value that specifies the distance between the
+ two trees.}
+ \item{length.line}{a positive value that specifies the length of the
+ horizontal line associated to each taxa. Default is 1.}
+ \item{gap}{a value specifying the distance between the tips of the
+ phylogeny and the lines.}
+ \item{type}{a character string specifying the type of phylogeny to be
+ drawn; it must be one of "phylogram" (the default) or "cladogram".}
+ \item{rotate}{a logical indicating whether the nodes of the phylogeny
+ can be rotated by clicking. Default is FALSE.}
+ \item{col}{a character vector indicating the color to be used for the
+ links; recycled as necessary.}
+ \item{lwd}{id. for the width.}
+ \item{lty}{id. for the line type.}
+ \item{show.tip.label}{a logical indicating whether to show the tip
+ labels on the phylogeny (defaults to 'TRUE', i.e. the labels are
+ shown).}
+ \item{font}{an integer specifying the type of font for the
+ labels: 1 (plain text), 2 (bold), 3 (italic, the default), or 4
+ (bold italic).}
+ \item{\dots}{(unused)}
+}
+\details{
+The aim of this function is to plot simultaneously two phylogenetic trees with associated taxa. The two trees do not necessarily have the same number of tips and more than one tip in one phylogeny can be associated with a tip in the other.
+
+The association matrix used to draw the links has to be a matrix with two columns containing the names of the tips. One line in the matrix represents one link on the plot. The first column of the matrix has to contain tip labels of the first tree (\code{phy1}) and the second column of the matrix, tip labels of the second tree (\code{phy2}). There is no limit (low or high) for the number of lines in the matrix. A matrix with two colums and one line will give a plot with one link.
+
+Arguments \code{gap}, \code{length.line} and \code{space} have to be changed to get a nice plot of the two phylogenies. Note that the function takes into account the length of the character strings corresponding to the names at the tips, so that the lines do not overwrite those names.
+
+The \code{rotate} argument can be used to transform both phylogenies in order to get the more readable plot (typically by decreasing the number of crossing lines). This can be done by clicking on the nodes. The escape button or right click take back to the console.
+}
+\author{Damien de Vienne \email{damien.de-vienne at u-psud.fr}}
+\seealso{
+ \code{\link{plot.phylo}}, \code{\link{rotate}}, \code{\link{rotateConstr}}
+}
+\examples{
+#two random trees
+tree1 <- rtree(40)
+tree2 <- rtree(20)
+
+#creation of the association matrix:
+association <- cbind(tree2$tip.label, tree2$tip.label)
+
+cophyloplot(tree1, tree2, assoc = association,
+ length.line = 4, space = 28, gap = 3)
+
+#plot with rotations
+\dontrun{
+cophyloplot(tree1, tree2, assoc=association, length.line=4, space=28, gap=3, rotate=TRUE)
+}
+}
+\keyword{hplot}
diff --git a/man/corBlomberg.Rd b/man/corBlomberg.Rd
new file mode 100644
index 0000000..ae60db4
--- /dev/null
+++ b/man/corBlomberg.Rd
@@ -0,0 +1,47 @@
+\name{corBlomberg}
+\alias{corBlomberg}
+\alias{coef.corBlomberg}
+\alias{corMatrix.corBlomberg}
+\title{Blomberg et al.'s Correlation Structure}
+\usage{
+corBlomberg(value, phy, form = ~1, fixed = FALSE)
+\method{corMatrix}{corBlomberg}(object, covariate = getCovariate(object),
+ corr = TRUE, ...)
+\method{coef}{corBlomberg}(object, unconstrained = TRUE, \dots)
+}
+\arguments{
+ \item{value}{the (initial) value of the parameter \eqn{g}{g}.}
+ \item{phy}{an object of class \code{"phylo"}.}
+ \item{form}{(ignored).}
+ \item{fixed}{a logical specifying whether \code{gls} should
+ estimate \eqn{\gamma}{gamma} (the default) or keep it fixed.}
+ \item{object}{an (initialized) object of class \code{"corBlomberg"}.}
+ \item{covariate}{(ignored).}
+ \item{corr}{a logical value specifying whether to return the
+ correlation matrix (the default) or the variance-covariance matrix.}
+ \item{unconstrained}{a logical value. If \code{TRUE} (the default),
+ the coefficients are returned in unconstrained form (the same used
+ in the optimization algorithm). If \code{FALSE} the coefficients are
+ returned in ``natural'', possibly constrained, form.}
+ \item{\dots}{further arguments passed to or from other methods.}
+}
+\description{
+ The ``ACDC'' (accelerated/decelerated) model assumes that continuous
+ traits evolve under a Brownian motion model which rates accelerates
+ (if \eqn{g}{g} < 1) or decelerates (if \eqn{g}{g} > 1) through
+ time. If \eqn{g}{g} = 1, then the model reduces to a Brownian motion
+ model.
+}
+\value{
+ an object of class \code{"corBlomberg"}, the coefficients from an
+ object of this class, or the correlation matrix of an initialized
+ object of this class. In most situations, only \code{corBlomberg} will
+ be called by the user.
+}
+\author{Emmanuel Paradis}
+\references{
+ Blomberg, S. P., Garland, Jr, T., and Ives, A. R. (2003) Testing for
+ phylogenetic signal in comparative data: behavioral traits are more
+ labile. \emph{Evolution}, \bold{57}, 717--745.
+}
+\keyword{models}
diff --git a/man/corBrownian.Rd b/man/corBrownian.Rd
new file mode 100644
index 0000000..14e082c
--- /dev/null
+++ b/man/corBrownian.Rd
@@ -0,0 +1,55 @@
+\name{corBrownian}
+\alias{corBrownian}
+\alias{coef.corBrownian}
+\alias{corMatrix.corBrownian}
+\title{Brownian Correlation Structure}
+\usage{
+corBrownian(value=1, phy, form=~1)
+\method{coef}{corBrownian}(object, unconstrained = TRUE, ...)
+\method{corMatrix}{corBrownian}(object, covariate = getCovariate(object), corr = TRUE, ...)
+}
+\arguments{
+ \item{value}{The \eqn{\gamma}{gamma} parameter (default to 1)}
+ \item{phy}{An object of class \code{phylo} representing the phylogeny
+ (with branch lengths) to consider}
+ \item{object}{An (initialized) object of class \code{corBrownian}}
+ \item{corr}{a logical value. If 'TRUE' the function returns the
+ correlation matrix, otherwise it returns the variance/covariance matrix.}
+ \item{form}{ignored for now.}
+ \item{covariate}{ignored for now.}
+ \item{unconstrained}{a logical value. If 'TRUE' the coefficients are returned
+ in unconstrained form (the same used in the optimization
+ algorithm). If 'FALSE' the coefficients are returned in
+ "natural", possibly constrained, form. Defaults to 'TRUE'}
+ \item{\dots}{some methods for these generics require additional arguments.
+ None are used in these methods.}
+}
+\description{
+ Expected covariance under a Brownian model (Felsenstein 1985, Martins
+ and Hansen 1997)
+
+ \deqn{V_{ij} = \gamma \times t_a}{Vij = gamma . ta}
+
+ where \eqn{t_a}{ta} is the distance on the phylogeny between the root
+ and the most recent common ancestor of taxa \eqn{i}{i} and \eqn{j}{j}
+ and \eqn{\gamma}{gamma} is a constant.
+}
+\value{
+ An object of class \code{corBrownian}, or the coefficient from an
+ object of this class (actually sends \code{numeric(0)}), or the
+ correlation matrix of an initialized object of this class.
+}
+\author{Julien Dutheil \email{julien.dutheil at univ-montp2.fr}}
+\seealso{
+ \code{\link{corClasses}}
+}
+\references{
+ Felsenstein, J. (1985) Phylogenies and the comparative method.
+ \emph{American Naturalist}, \bold{125}, 1--15.
+
+ Martins, E. P. and Hansen, T. F. (1997) Phylogenies and the comparative
+ method: a general approach to incorporating phylogenetic information
+ into the analysis of interspecific data. \emph{American Naturalist},
+ \bold{149}, 646--667.
+}
+\keyword{models}
diff --git a/man/corClasses.Rd b/man/corClasses.Rd
new file mode 100644
index 0000000..179e1aa
--- /dev/null
+++ b/man/corClasses.Rd
@@ -0,0 +1,48 @@
+\name{corClasses}
+\alias{corClasses}
+\alias{corPhyl}
+\title{Phylogenetic Correlation Structures}
+\description{
+ Classes of phylogenetic correlation structures (\code{"corPhyl"})
+ available in \pkg{ape}.
+
+ \itemize{
+ \item{corBrownian}{Brownian motion model (Felsenstein 1985)}
+ \item{corMartins}{The covariance matrix defined in Martins and Hansen
+ (1997)}
+ \item{corGrafen}{The covariance matrix defined in Grafen (1989)}
+ \item{corPagel}{The covariance matrix defined in Freckelton et al. (2002)}
+ \item{corBlomberg}{The covariance matrix defined in Blomberg et al. (2003)}
+ }
+
+ See the help page of each class for references and detailed
+ description.
+}
+\seealso{
+ \code{\link[nlme]{corClasses}} and \code{\link[nlme]{gls}} in the
+ \pkg{nlme} librarie, \code{\link{corBrownian}},
+ \code{\link{corMartins}}, \code{\link{corGrafen}},
+ \code{\link{corPagel}}, \code{\link{corBlomberg}}
+}
+\author{Julien Dutheil \email{julien.dutheil at univ-montp2.fr}, Emmanuel
+ Paradis}
+\examples{
+library(nlme)
+cat("((((Homo:0.21,Pongo:0.21):0.28,",
+"Macaca:0.49):0.13,Ateles:0.62):0.38,Galago:1.00);",
+file = "ex.tre", sep = "\n")
+tree.primates <- read.tree("ex.tre")
+X <- c(4.09434, 3.61092, 2.37024, 2.02815, -1.46968)
+Y <- c(4.74493, 3.33220, 3.36730, 2.89037, 2.30259)
+unlink("ex.tre") # delete the file "ex.tre"
+m1 <- gls(Y ~ X, correlation=corBrownian(1, tree.primates))
+summary(m1)
+m2 <- gls(Y ~ X, correlation=corMartins(1, tree.primates))
+summary(m2)
+corMatrix(m2$modelStruct$corStruct)
+m3 <- gls(Y ~ X, correlation=corGrafen(1, tree.primates))
+summary(m3)
+corMatrix(m3$modelStruct$corStruct)
+}
+\keyword{models}
+
diff --git a/man/corGrafen.Rd b/man/corGrafen.Rd
new file mode 100644
index 0000000..46df055
--- /dev/null
+++ b/man/corGrafen.Rd
@@ -0,0 +1,53 @@
+\name{corGrafen}
+\alias{corGrafen}
+\alias{coef.corGrafen}
+\alias{corMatrix.corGrafen}
+\title{Grafen's (1989) Correlation Structure}
+\usage{
+corGrafen(value, phy, form=~1, fixed = FALSE)
+\method{coef}{corGrafen}(object, unconstrained = TRUE, ...)
+\method{corMatrix}{corGrafen}(object,
+ covariate = getCovariate(object), corr = TRUE, ...)
+}
+\arguments{
+ \item{value}{The \eqn{\rho}{rho} parameter}
+ \item{phy}{An object of class \code{phylo} representing the phylogeny
+ (branch lengths are ignored) to consider}
+ \item{object}{An (initialized) object of class \code{corGrafen}}
+ \item{corr}{a logical value. If 'TRUE' the function returns the
+ correlation matrix, otherwise it returns the variance/covariance
+ matrix.}
+ \item{fixed}{an optional logical value indicating whether the
+ coefficients should be allowed to vary in the optimization, or kept
+ fixed at their initial value. Defaults to 'FALSE', in which case the
+ coefficients are allowed to vary.}
+ \item{form}{ignored for now.}
+ \item{covariate}{ignored for now.}
+ \item{unconstrained}{a logical value. If 'TRUE' the coefficients are
+ returned in unconstrained form (the same used in the optimization
+ algorithm). If 'FALSE' the coefficients are returned in "natural",
+ possibly constrained, form. Defaults to 'TRUE'}
+ \item{\dots}{some methods for these generics require additional
+ arguments. None are used in these methods.}
+}
+\description{
+ Grafen's (1989) covariance structure. Branch lengths are computed using
+ Grafen's method (see \code{\link{compute.brlen}}). The covariance
+ matrice is then the traditional variance-covariance matrix for a
+ phylogeny.
+}
+\value{
+ An object of class \code{corGrafen} or the rho coefficient from an
+ object of this class or the correlation matrix of an initialized
+ object of this class.
+}
+\author{Julien Dutheil \email{julien.dutheil at univ-montp2.fr}}
+\seealso{
+ \code{\link{corClasses}}, \code{\link{compute.brlen}}, \code{\link{vcv.phylo}}.
+}
+\references{
+ Grafen, A. (1989) The phylogenetic regression. \emph{Philosophical
+ Transactions of the Royal society of London. Series B. Biological
+ Sciences}, \bold{326}, 119--157.
+}
+\keyword{models}
diff --git a/man/corMartins.Rd b/man/corMartins.Rd
new file mode 100644
index 0000000..7e27d7c
--- /dev/null
+++ b/man/corMartins.Rd
@@ -0,0 +1,53 @@
+\name{corMartins}
+\alias{corMartins}
+\alias{coef.corMartins}
+\alias{corMatrix.corMartins}
+\title{Martins's (1997) Correlation Structure}
+\usage{
+corMartins(value, phy, form = ~1, fixed = FALSE)
+\method{coef}{corMartins}(object, unconstrained = TRUE, ...)
+\method{corMatrix}{corMartins}(object,
+ covariate = getCovariate(object), corr = TRUE, ...)
+}
+\arguments{
+ \item{value}{The \eqn{\alpha}{alpha} parameter}
+ \item{phy}{An object of class \code{phylo} representing the phylogeny
+ (with branch lengths) to consider}
+ \item{object}{An (initialized) object of class \code{corMartins}}
+ \item{corr}{a logical value. If 'TRUE' the function returns the
+ correlation matrix, otherwise it returns the variance/covariance
+ matrix.}
+ \item{fixed}{an optional logical value indicating whether the
+ coefficients should be allowed to vary in the optimization, ok kept
+ fixed at their initial value. Defaults to 'FALSE', in which case the
+ coefficients are allowed to vary.}
+ \item{form}{ignored for now.}
+ \item{covariate}{ignored for now.}
+ \item{unconstrained}{a logical value. If 'TRUE' the coefficients are returned
+ in unconstrained form (the same used in the optimization
+ algorithm). If 'FALSE' the coefficients are returned in
+ "natural", possibly constrained, form. Defaults to 'TRUE'}
+ \item{\dots}{some methods for these generics require additional arguments.
+ None are used in these methods.}
+}
+\description{
+ Martins and Hansen's (1997) covariance structure:
+ \deqn{V_{ij} = \gamma \times e^{-\alpha t_{ij}}}{%
+ Vij = gamma . exp(-alpha . tij)}
+ where \eqn{t_{ij}}{tij} is the phylogenetic distance between taxa \eqn{i}{i} and \eqn{j}{j} and \eqn{\gamma}{gamma} is a constant.
+}
+\value{
+ An object of class \code{corMartins} or the alpha coefficient from an object of this class
+ or the correlation matrix of an initialized object of this class.
+}
+\author{Julien Dutheil \email{julien.dutheil at univ-montp2.fr}}
+\seealso{
+ \code{\link{corClasses}}.
+}
+\references{
+ Martins, E. P. and Hansen, T. F. (1997) Phylogenies and the comparative
+ method: a general approach to incorporating phylogenetic information
+ into the analysis of interspecific data. \emph{American Naturalist},
+ \bold{149}, 646--667.
+}
+\keyword{models}
diff --git a/man/corPagel.Rd b/man/corPagel.Rd
new file mode 100644
index 0000000..096a248
--- /dev/null
+++ b/man/corPagel.Rd
@@ -0,0 +1,50 @@
+\name{corPagel}
+\alias{corPagel}
+\alias{coef.corPagel}
+\alias{corMatrix.corPagel}
+\title{Pagel's ``lambda'' Correlation Structure}
+\usage{
+corPagel(value, phy, form = ~1, fixed = FALSE)
+\method{corMatrix}{corPagel}(object, covariate = getCovariate(object),
+ corr = TRUE, ...)
+\method{coef}{corPagel}(object, unconstrained = TRUE, \dots)
+}
+\arguments{
+ \item{value}{the (initial) value of the parameter
+ \eqn{\lambda}{lambda}.}
+ \item{phy}{an object of class \code{"phylo"}.}
+ \item{form}{(ignored).}
+ \item{fixed}{a logical specifying whether \code{gls} should
+ estimate \eqn{\lambda}{lambda} (the default) or keep it fixed.}
+ \item{object}{an (initialized) object of class \code{"corPagel"}.}
+ \item{covariate}{(ignored).}
+ \item{corr}{a logical value specifying whether to return the
+ correlation matrix (the default) or the variance-covariance matrix.}
+ \item{unconstrained}{a logical value. If \code{TRUE} (the default),
+ the coefficients are returned in unconstrained form (the same used
+ in the optimization algorithm). If \code{FALSE} the coefficients are
+ returned in ``natural'', possibly constrained, form.}
+ \item{\dots}{further arguments passed to or from other methods.}
+}
+\description{
+ The correlation structure from the present model is derived from the
+ Brownian motion model by multiplying the off-diagonal elements (i.e.,
+ the covariances) by \eqn{\lambda}{lambda}. The variances are thus the
+ same than for a Brownian motion model.
+}
+\value{
+ an object of class \code{"corPagel"}, the coefficients from an object
+ of this class, or the correlation matrix of an initialized object of
+ this class. In most situations, only \code{corPagel} will be called
+ by the user.
+}
+\author{Emmanuel Paradis}
+\references{
+ Freckleton, R. P., Harvey, P. H. and M. Pagel, M. (2002) Phylogenetic
+ analysis and comparative data: a test and review of evidence.
+ \emph{American Naturalist}, \bold{160}, 712--726.
+
+ Pagel, M. (1999) Inferring the historical patterns of biological
+ evolution. \emph{Nature}, \bold{401},877--884.
+}
+\keyword{models}
diff --git a/man/correlogram.formula.Rd b/man/correlogram.formula.Rd
new file mode 100644
index 0000000..6522ea9
--- /dev/null
+++ b/man/correlogram.formula.Rd
@@ -0,0 +1,58 @@
+\name{correlogram.formula}
+\alias{correlogram.formula}
+\title{Phylogenetic Correlogram}
+\usage{
+ correlogram.formula(formula, data = NULL, use = "all.obs")
+}
+\arguments{
+ \item{formula}{a formula of the type \code{y1+..+yn ~ g1/../gn}, where
+ the \code{y}'s are the data to analyse and the \code{g}'s are the
+ taxonomic levels.}
+ \item{data}{a data frame containing the variables specified in the
+ formula. If \code{NULL}, the variables are sought in the user's
+ workspace.}
+ \item{use}{a character string specifying how to handle missing
+ values (i.e., \code{NA}). This must be one of "all.obs",
+ "complete.obs", or "pairwise.complete.obs", or any unambiguous
+ abbrevation of these. In the first case, the presence of missing
+ values produces an error. In the second case, all rows with missing
+ values will be removed before computation. In the last case, missing
+ values are removed on a case-by-case basis.}
+}
+\description{
+ This function computes a correlogram from taxonomic levels.
+}
+\details{
+ See the vignette in R: \code{vignette("MoranI")}.
+}
+\value{
+ An object of class \code{correlogram} which is a data frame with three
+ columns:
+
+ \item{obs}{the computed Moran's I}
+ \item{p.values}{the corresponding P-values}
+ \item{labels}{the names of each level}
+
+ or an object of class \code{correlogramList} containing a list of
+ objects of class \code{correlogram} if several variables are given as
+ response in \code{formula}.
+}
+\author{Julien Dutheil \email{julien.dutheil at univ-montp2.fr} and
+ Emmanuel Paradis}
+\seealso{
+ \code{\link{plot.correlogram}, \link{Moran.I}}
+}
+\examples{
+data(carnivora)
+### Using the formula interface:
+co <- correlogram.formula(SW ~ Order/SuperFamily/Family/Genus,
+ data=carnivora)
+co
+plot(co)
+### Several correlograms on the same plot:
+cos <- correlogram.formula(SW + FW ~ Order/SuperFamily/Family/Genus,
+ data=carnivora)
+cos
+plot(cos)
+}
+\keyword{regression}
diff --git a/man/cynipids.Rd b/man/cynipids.Rd
new file mode 100644
index 0000000..e2b0efd
--- /dev/null
+++ b/man/cynipids.Rd
@@ -0,0 +1,24 @@
+\name{data.nex}
+\docType{data}
+\alias{data.nex}
+\alias{cynipids}
+\title{NEXUS Data Example}
+\description{
+ Example of Protein data in NEXUS format (Maddison et al., 1997).
+ Data is written in interleaved format using a single DATA block.
+ Original data from Rokas et al (2002).
+}
+\usage{data(cynipids)}
+\format{ASCII text in NEXUS format}
+\references{
+ Maddison, D. R., Swofford, D. L. and Maddison, W. P. (1997) NEXUS: an
+ extensible file format for systematic information. \emph{Systematic
+ Biology}, \bold{46}, 590--621.
+
+ Rokas, A., Nylander, J. A. A., Ronquist, F. and Stone, G. N. (2002) A
+ maximum likelihood analysis of eight phylogenetic markers in Gallwasps
+ (Hymenoptera: Cynipidae): implications for insect phylogenetic
+ studies. \emph{Molecular Phylogenetics and Evolution}, \bold{22},
+ 206--219.
+}
+\keyword{datasets}
diff --git a/man/dbd.Rd b/man/dbd.Rd
new file mode 100644
index 0000000..4f5ba15
--- /dev/null
+++ b/man/dbd.Rd
@@ -0,0 +1,107 @@
+\name{dbd}
+\alias{dyule}
+\alias{dbd}
+\alias{dbdTime}
+\title{Probability Density Under Birth--Death Models}
+\description{
+ These functions compute the probability density under some
+ birth--death models, that is the probability of obtaining \emph{x}
+ species after a time \emph{t} giving how speciation and extinction
+ probabilities vary through time (these may be constant, or even equal
+ to zero for extinction).
+}
+\usage{
+dyule(x, lambda = 0.1, t = 1, log = FALSE)
+dbd(x, lambda, mu, t, conditional = FALSE, log = FALSE)
+dbdTime(x, birth, death, t, conditional = FALSE,
+ BIRTH = NULL, DEATH = NULL, fast = FALSE)
+}
+\arguments{
+ \item{x}{a numeric vector of species numbers (see Details).}
+ \item{lambda}{a numerical value giving the probability of speciation;
+ can be a vector with several values for \code{dyule}.}
+ \item{mu}{id. for extinction.}
+ \item{t}{id. for the time(s).}
+ \item{log}{a logical value specifying whether the probabilities should
+ be returned log-transformed; the default is \code{FALSE}.}
+ \item{conditional}{a logical specifying whether the probabilities
+ should be computed conditional under the assumption of no extinction
+ after time \code{t}.}
+ \item{birth, death}{a (vectorized) function specifying how the
+ speciation or extinction probability changes through time (see
+ \code{\link{yule.time}} and below).}
+ \item{BIRTH, DEATH}{a (vectorized) function giving the primitive
+ of \code{birth} or \code{death}.}
+ \item{fast}{a logical value specifying whether to use faster
+ integration (see \code{\link{bd.time}}).}
+}
+\details{
+ These three functions compute the probabilities to observe \code{x}
+ species starting from a single one after time \code{t} (assumed to be
+ continuous). The first function is a short-cut for the second one with
+ \code{mu = 0} and with default values for the two other arguments.
+ \code{dbdTime} is for time-varying \code{lambda} and \code{mu}
+ specified as \R functions.
+
+ \code{dyule} is vectorized simultaneously on its three arguments
+ \code{x}, \code{lambda}, and \code{t}, according to \R's rules of
+ recycling arguments. \code{dbd} is vectorized simultaneously \code{x}
+ and \code{t} (to make likelihood calculations easy), and
+ \code{dbdTime} is vectorized only on \code{x}; the other arguments are
+ eventually shortened with a warning if necessary.
+
+ The returned value is, logically, zero for values of \code{x} out of
+ range, i.e., negative or zero for \code{dyule} or if \code{conditional
+ = TRUE}. However, it is not checked if the values of \code{x} are
+ positive non-integers and the probabilities are computed and returned.
+
+ The details on the form of the arguments \code{birth}, \code{death},
+ \code{BIRTH}, \code{DEATH}, and \code{fast} can be found in the links
+ below.
+}
+\note{
+ If you use these functions to calculate a likelihood function, it is
+ strongly recommended to compute the log-likelihood with, for instance
+ in the case of a Yule process, \code{sum(dyule( , log = TRUE))} (see
+ examples).
+}
+\value{
+ a numeric vector.
+}
+\references{
+ Kendall, D. G. (1948) On the generalized ``birth-and-death''
+ process. \emph{Annals of Mathematical Statistics}, \bold{19}, 1--15.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{bd.time}}, \code{\link{yule.time}}
+}
+\examples{
+x <- 0:10
+plot(x, dyule(x), type = "h", main = "Density of the Yule process")
+text(7, 0.85, expression(list(lambda == 0.1, t == 1)))
+
+y <- dbd(x, 0.1, 0.05, 10)
+z <- dbd(x, 0.1, 0.05, 10, conditional = TRUE)
+d <- rbind(y, z)
+colnames(d) <- x
+barplot(d, beside = TRUE, ylab = "Density", xlab = "Number of species",
+ legend = c("unconditional", "conditional on\nno extinction"),
+ args.legend = list(bty = "n"))
+title("Density of the birth-death process")
+text(17, 0.4, expression(list(lambda == 0.1, mu == 0.05, t == 10)))
+
+\dontrun{
+### generate 1000 values from a Yule process with lambda = 0.05
+x <- replicate(1e3, Ntip(rlineage(0.05, 0)))
+
+### the correct way to calculate the log-likelihood...:
+sum(dyule(x, 0.05, 50, log = TRUE))
+
+### ... and the wrong way:
+log(prod(dyule(x, 0.05, 50)))
+
+### a third, less preferred, way:
+sum(log(dyule(x, 0.05, 50)))
+}}
+\keyword{utilities}
diff --git a/man/del.gaps.Rd b/man/del.gaps.Rd
new file mode 100644
index 0000000..7a9ff18
--- /dev/null
+++ b/man/del.gaps.Rd
@@ -0,0 +1,31 @@
+\name{del.gaps}
+\alias{del.gaps}
+\title{
+ Delete Alignment Gaps in DNA Sequences
+}
+\usage{
+del.gaps(x)
+}
+\arguments{
+ \item{x}{a matrix, a list, or a vector containing the DNA sequences.}
+}
+\description{
+ This function removes the insertion gaps (\code{"-"}) in a sample of
+ DNA sequences.
+}
+\details{
+ The sequences can be either in \code{"DNAbin"} or in character format,
+ but the returned object is always of class \code{"DNAbin"}. If
+ \code{x} is a vector, then a vector is returned; if it is a list or a
+ matrix, then a list is returned.
+}
+\value{
+ A vector (if there is only one input sequence) or a list of class
+ \code{"DNAbin"}.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{base.freq}}, \code{\link{GC.content}},
+ \code{\link{seg.sites}}, \code{\link{image.DNAbin}}
+}
+\keyword{univar}
diff --git a/man/delta.plot.Rd b/man/delta.plot.Rd
new file mode 100644
index 0000000..cf45e2c
--- /dev/null
+++ b/man/delta.plot.Rd
@@ -0,0 +1,54 @@
+\name{delta.plot}
+\alias{delta.plot}
+\title{Delta Plots}
+\usage{
+delta.plot(X, k = 20, plot = TRUE, which = 1:2)
+}
+\arguments{
+ \item{X}{a distance matrix, may be an object of class ``dist''.}
+ \item{k}{an integer giving the number of intervals in the plot.}
+ \item{plot}{a logical specifying whether to draw the
+ \eqn{\delta}{delta} plot (the default).}
+ \item{which}{a numeric vector indicating which plots are done; 1: the
+ histogram of the \eqn{\delta_q}{delta_q} values, 2: the plot of the
+ individual \eqn{\bar{\delta}}{delta.bar} values. By default, both
+ plots are done.}
+}
+\description{
+ This function makes a \eqn{\delta}{delta} plot following Holland et
+ al. (2002).
+}
+\details{
+ See Holland et al. (2002) for details and interpretation.
+
+ The computing time of this function is proportional to the fourth
+ power of the number of observations (\eqn{O(n^4)}), so calculations
+ may be very long with only a slight increase in sample size.
+}
+\value{
+ This function returns invisibly a named list with two components:
+
+ \itemize{
+ \item{counts}{the counts for the histogram of
+ \eqn{\delta_q}{delta_q} values}
+ \item{delta.bar}{the mean \eqn{\delta}{delta} value for each
+ observation}
+ }
+}
+\references{
+ Holland, B. R., Huber, K. T., Dress, A. and Moulton, V. (2002) Delta
+ plots: a tool for analyzing phylogenetic distance data.
+ \emph{Molecular Biology and Evolution}, \bold{12}, 2051--2059.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{dist.dna}}
+}
+\examples{
+data(woodmouse)
+d <- dist.dna(woodmouse)
+delta.plot(d)
+layout(1)
+delta.plot(d, 40, which = 1)
+}
+\keyword{hplot}
diff --git a/man/dist.dna.Rd b/man/dist.dna.Rd
new file mode 100644
index 0000000..8168603
--- /dev/null
+++ b/man/dist.dna.Rd
@@ -0,0 +1,208 @@
+\name{dist.dna}
+\alias{dist.dna}
+\title{Pairwise Distances from DNA Sequences}
+\usage{
+dist.dna(x, model = "K80", variance = FALSE,
+ gamma = FALSE, pairwise.deletion = FALSE,
+ base.freq = NULL, as.matrix = FALSE)
+}
+\arguments{
+ \item{x}{a matrix or a list containing the DNA sequences; this must be
+ of class \code{"DNAbin"} (use \code{\link{as.DNAbin}} is they are
+ stored as character).}
+ \item{model}{a character string specifying the evolutionary model to be
+ used; must be one of \code{"raw"}, \code{"N"}, \code{"TS"},
+ \code{"TV"}, \code{"JC69"}, \code{"K80"} (the default),
+ \code{"F81"}, \code{"K81"}, \code{"F84"}, \code{"BH87"},
+ \code{"T92"}, \code{"TN93"}, \code{"GG95"}, \code{"logdet"},
+ \code{"paralin"}, \code{"indel"}, or \code{"indelblock"}.}
+ \item{variance}{a logical indicating whether to compute the variances
+ of the distances; defaults to \code{FALSE} so the variances are not
+ computed.}
+ \item{gamma}{a value for the gamma parameter possibly used to apply a
+ correction to the distances (by default no correction is applied).}
+ \item{pairwise.deletion}{a logical indicating whether to delete the
+ sites with missing data in a pairwise way. The default is to delete
+ the sites with at least one missing data for all sequences (ignored
+ if \code{model = "indel"} or \code{"indelblock"}).}
+ \item{base.freq}{the base frequencies to be used in the computations
+ (if applicable). By default, the base frequencies are computed from
+ the whole set of sequences.}
+ \item{as.matrix}{a logical indicating whether to return the results as
+ a matrix. The default is to return an object of class
+ \link[stats]{dist}.}
+}
+\description{
+ This function computes a matrix of pairwise distances from DNA
+ sequences using a model of DNA evolution. Eleven substitution models
+ (and the raw distance) are currently available.
+}
+\details{
+ The molecular evolutionary models available through the option
+ \code{model} have been extensively described in the literature. A
+ brief description is given below; more details can be found in the
+ References.
+
+\itemize{
+ \item{\code{raw}, \code{N}: }{This is simply the proportion or the number of
+ sites that differ between each pair of sequences. This may be useful
+ to draw ``saturation plots''. The options \code{variance} and
+ \code{gamma} have no effect, but \code{pairwise.deletion} can.}
+
+ \item{\code{TS}, \code{TV}: }{These are the numbers of transitions and
+ transversions, respectively.}
+
+ \item{\code{JC69}: }{This model was developed by Jukes and Cantor (1969). It
+ assumes that all substitutions (i.e. a change of a base by another
+ one) have the same probability. This probability is the same for all
+ sites along the DNA sequence. This last assumption can be relaxed by
+ assuming that the substition rate varies among site following a
+ gamma distribution which parameter must be given by the user. By
+ default, no gamma correction is applied. Another assumption is that
+ the base frequencies are balanced and thus equal to 0.25.}
+
+ \item{\code{K80}: }{The distance derived by Kimura (1980), sometimes referred
+ to as ``Kimura's 2-parameters distance'', has the same underlying
+ assumptions than the Jukes--Cantor distance except that two kinds of
+ substitutions are considered: transitions (A <-> G, C <-> T), and
+ transversions (A <-> C, A <-> T, C <-> G, G <-> T). They are assumed
+ to have different probabilities. A transition is the substitution of
+ a purine (C, T) by another one, or the substitution of a pyrimidine
+ (A, G) by another one. A transversion is the substitution of a
+ purine by a pyrimidine, or vice-versa. Both transition and
+ transversion rates are the same for all sites along the DNA
+ sequence. Jin and Nei (1990) modified the Kimura model to allow for
+ variation among sites following a gamma distribution. Like for the
+ Jukes--Cantor model, the gamma parameter must be given by the
+ user. By default, no gamma correction is applied.}
+
+ \item{\code{F81}: }{Felsenstein (1981) generalized the Jukes--Cantor model
+ by relaxing the assumption of equal base frequencies. The formulae
+ used in this function were taken from McGuire et al. (1999)}.
+
+ \item{\code{K81}: }{Kimura (1981) generalized his model (Kimura 1980) by
+ assuming different rates for two kinds of transversions: A <-> C and
+ G <-> T on one side, and A <-> T and C <-> G on the other. This is
+ what Kimura called his ``three substitution types model'' (3ST), and
+ is sometimes referred to as ``Kimura's 3-parameters distance''}.
+
+ \item{\code{F84}: }{This model generalizes K80 by relaxing the assumption
+ of equal base frequencies. It was first introduced by Felsenstein in
+ 1984 in Phylip, and is fully described by Felsenstein and Churchill
+ (1996). The formulae used in this function were taken from McGuire
+ et al. (1999)}.
+
+ \item{\code{BH87}: }{Barry and Hartigan (1987) developed a distance based
+ on the observed proportions of changes among the four bases. This
+ distance is not symmetric.}
+
+ \item{\code{T92}: }{Tamura (1992) generalized the Kimura model by relaxing
+ the assumption of equal base frequencies. This is done by taking
+ into account the bias in G+C content in the sequences. The
+ substitution rates are assumed to be the same for all sites along
+ the DNA sequence.}
+
+ \item{\code{TN93}: }{Tamura and Nei (1993) developed a model which assumes
+ distinct rates for both kinds of transition (A <-> G versus C <->
+ T), and transversions. The base frequencies are not assumed to be
+ equal and are estimated from the data. A gamma correction of the
+ inter-site variation in substitution rates is possible.}
+
+ \item{\code{GG95}: }{Galtier and Gouy (1995) introduced a model where the
+ G+C content may change through time. Different rates are assumed for
+ transitons and transversions.}
+
+ \item{\code{logdet}: }{The Log-Det distance, developed by Lockhart et
+ al. (1994), is related to BH87. However, this distance is
+ symmetric. Formulae from Gu and Li (1996) are used.
+ \code{dist.logdet} in \pkg{phangorn} uses a different
+ implementation that gives substantially different distances for
+ low-diverging sequences.}
+
+ \item{\code{paralin}: }{Lake (1994) developed the paralinear distance which
+ can be viewed as another variant of the Barry--Hartigan distance.}
+
+ \item{\code{indel}: }{this counts the number of sites where there is an
+ insertion/deletion gap in one sequence and not in the other.}
+
+ \item{\code{indelblock}: }{same than before but contiguous gaps are
+ counted as a single unit. Note that the distance between \code{-A-} and
+ \code{A--} is 3 because there are three different blocks of gaps, whereas
+ the ``indel'' distance will be 2.}
+}}
+\value{
+ an object of class \link[stats]{dist} (by default), or a numeric
+ matrix if \code{as.matrix = TRUE}. If \code{model = "BH87"}, a numeric
+ matrix is returned because the Barry--Hartigan distance is not
+ symmetric.
+
+ If \code{variance = TRUE} an attribute called \code{"variance"} is
+ given to the returned object.
+}
+\references{
+ Barry, D. and Hartigan, J. A. (1987) Asynchronous distance between
+ homologous DNA sequences. \emph{Biometrics}, \bold{43}, 261--276.
+
+ Felsenstein, J. (1981) Evolutionary trees from DNA sequences: a
+ maximum likelihood approach. \emph{Journal of Molecular Evolution},
+ \bold{17}, 368--376.
+
+ Felsenstein, J. and Churchill, G. A. (1996) A Hidden Markov model
+ approach to variation among sites in rate of evolution.
+ \emph{Molecular Biology and Evolution}, \bold{13}, 93--104.
+
+ Galtier, N. and Gouy, M. (1995) Inferring phylogenies from DNA
+ sequences of unequal base compositions. \emph{Proceedings of the
+ National Academy of Sciences USA}, \bold{92}, 11317--11321.
+
+ Gu, X. and Li, W.-H. (1996) Bias-corrected paralinear and LogDet
+ distances and tests of molecular clocks and phylogenies under
+ nonstationary nucleotide frequencies. \emph{Molecular Biology and
+ Evolution}, \bold{13}, 1375--1383.
+
+ Jukes, T. H. and Cantor, C. R. (1969) Evolution of protein
+ molecules. in \emph{Mammalian Protein Metabolism}, ed. Munro, H. N.,
+ pp. 21--132, New York: Academic Press.
+
+ Kimura, M. (1980) A simple method for estimating evolutionary rates of
+ base substitutions through comparative studies of nucleotide
+ sequences. \emph{Journal of Molecular Evolution}, \bold{16}, 111--120.
+
+ Kimura, M. (1981) Estimation of evolutionary distances between
+ homologous nucleotide sequences. \emph{Proceedings of the National
+ Academy of Sciences USA}, \bold{78}, 454--458.
+
+ Jin, L. and Nei, M. (1990) Limitations of the evolutionary parsimony
+ method of phylogenetic analysis. \emph{Molecular Biology and
+ Evolution}, \bold{7}, 82--102.
+
+ Lake, J. A. (1994) Reconstructing evolutionary trees from DNA and
+ protein sequences: paralinear distances. \emph{Proceedings of the
+ National Academy of Sciences USA}, \bold{91}, 1455--1459.
+
+ Lockhart, P. J., Steel, M. A., Hendy, M. D. and Penny, D. (1994)
+ Recovering evolutionary trees under a more realistic model of sequence
+ evolution. \emph{Molecular Biology and Evolution}, \bold{11},
+ 605--602.
+
+ McGuire, G., Prentice, M. J. and Wright, F. (1999). Improved error
+ bounds for genetic distances from DNA sequences. \emph{Biometrics},
+ \bold{55}, 1064--1070.
+
+ Tamura, K. (1992) Estimation of the number of nucleotide substitutions
+ when there are strong transition-transversion and G + C-content
+ biases. \emph{Molecular Biology and Evolution}, \bold{9}, 678--687.
+
+ Tamura, K. and Nei, M. (1993) Estimation of the number of nucleotide
+ substitutions in the control region of mitochondrial DNA in humans and
+ chimpanzees. \emph{Molecular Biology and Evolution}, \bold{10}, 512--526.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{read.GenBank}}, \code{\link{read.dna}},
+ \code{\link{write.dna}}, \code{\link{DNAbin}},
+ \code{\link{dist.gene}}, \code{\link{cophenetic.phylo}},
+ \code{\link[stats]{dist}}
+}
+\keyword{manip}
+\keyword{multivariate}
diff --git a/man/dist.gene.Rd b/man/dist.gene.Rd
new file mode 100644
index 0000000..6d5ccb3
--- /dev/null
+++ b/man/dist.gene.Rd
@@ -0,0 +1,52 @@
+\name{dist.gene}
+\alias{dist.gene}
+\title{Pairwise Distances from Genetic Data}
+\usage{
+dist.gene(x, method = "pairwise", pairwise.deletion = FALSE,
+ variance = FALSE)
+}
+\arguments{
+ \item{x}{a matrix or a data frame (will be coerced as a matrix).}
+ \item{method}{a character string specifying the method used to compute
+ the distances; two choices are available: \code{"pairwise"} and
+ \code{"percentage"}, or any unambiguous abbreviation of these.}
+ \item{pairwise.deletion}{a logical indicating whether to delete the
+ columns with missing data on a pairwise basis. The default is to
+ delete the columns with at least one missing observation.}
+ \item{variance}{a logical, indicates whether the variance of the
+ distances should be returned (default to \code{FALSE}).}
+}
+\description{
+ This function computes a matrix of distances between pairs of
+ individuals from a matrix or a data frame of genetic data.
+}
+\details{
+ This function is meant to be very general and accepts different kinds
+ of data (alleles, haplotypes, SNP, DNA sequences, \dots). The rows of
+ the data matrix represent the individuals, and the columns the loci.
+
+ In the case of the pairwise method, the distance \eqn{d} between two
+ individuals is the number of loci for which they differ, and the
+ associated variance is \eqn{d(L - d)/L}, where \eqn{L} is the number
+ of loci.
+
+ In the case of the percentage method, this distance is divided by \eqn{L},
+ and the associated variance is \eqn{d(1 - d)/L}.
+
+ For more elaborate distances with DNA sequences, see the function
+ \code{dist.dna}.
+}
+\note{
+ Missing data (\code{NA}) are coded and treated in R's usual way.
+}
+\value{
+ an object of class \code{dist}. If \code{variance = TRUE} an
+ attribute called \code{"variance"} is given to the returned object.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{dist.dna}}, \code{\link{cophenetic.phylo}},
+ \code{\link[stats]{dist}}
+}
+\keyword{manip}
+
diff --git a/man/dist.topo.Rd b/man/dist.topo.Rd
new file mode 100644
index 0000000..d1542ad
--- /dev/null
+++ b/man/dist.topo.Rd
@@ -0,0 +1,70 @@
+\name{dist.topo}
+\alias{dist.topo}
+\title{Topological Distances Between Two Trees}
+\usage{
+dist.topo(x, y, method = "PH85")
+}
+\arguments{
+ \item{x}{an object of class \code{"phylo"}.}
+ \item{y}{an object of class \code{"phylo"}.}
+ \item{method}{a character string giving the method to be used: either
+ \code{"PH85"}, or \code{"score"}.}
+}
+\description{
+ This function computes the topological distance between two
+ phylogenetic trees using different methods.
+}
+\value{
+ a single numeric value.
+}
+\details{
+ Two methods are available: the one by Penny and Hendy (1985), and the
+ branch length score by Kuhner and Felsenstein (1994). The trees are
+ always considered as unrooted.
+
+ The topological distance is defined as twice the number of internal
+ branches defining different bipartitions of the tips (Penny and Hendy
+ 1985). Rzhetsky and Nei (1992) proposed a modification of the original
+ formula to take multifurcations into account.
+
+ The branch length score may be seen as similar to the previous
+ distance but taking branch lengths into account. Kuhner and
+ Felsenstein (1994) proposed to calculate the square root of the sum of
+ the squared differences of the (internal) branch lengths defining
+ similar bipartitions (or splits) in both trees.
+}
+\note{
+ The geodesic distance of Billera et al. (2001) has been disabled: see
+ the package \pkg{distory} on CRAN.
+}
+\references{
+ Billera, L. J., Holmes, S. P. and Vogtmann, K. (2001) Geometry of the
+ space of phylogenetic trees. \emph{Advances in Applied Mathematics},
+ \bold{27}, 733--767.
+
+ Kuhner, M. K. and Felsenstein, J. (1994) Simulation comparison of
+ phylogeny algorithms under equal and unequal evolutionary rates.
+ \emph{Molecular Biology and Evolution}, \bold{11}, 459--468.
+
+ Nei, M. and Kumar, S. (2000) \emph{Molecular Evolution and
+ Phylogenetics}. Oxford: Oxford University Press.
+
+ Penny, D. and Hendy, M. D. (1985) The use of tree comparison
+ metrics. \emph{Systemetic Zoology}, \bold{34}, 75--82.
+
+ Rzhetsky, A. and Nei, M. (1992) A simple method for estimating and
+ testing minimum-evolution trees. \emph{Molecular Biology and
+ Evolution}, \bold{9}, 945--967.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{read.tree}} to read tree files in Newick format,
+ \code{\link{cophenetic.phylo}}, \code{\link{prop.part}}
+}
+\examples{
+ta <- rtree(30)
+tb <- rtree(30)
+dist.topo(ta, ta) # = 0
+dist.topo(ta, tb) # This is unlikely to be 0 !
+}
+\keyword{manip}
diff --git a/man/diversi.gof.Rd b/man/diversi.gof.Rd
new file mode 100644
index 0000000..202082c
--- /dev/null
+++ b/man/diversi.gof.Rd
@@ -0,0 +1,75 @@
+\encoding{latin1}
+\name{diversi.gof}
+\alias{diversi.gof}
+\title{Tests of Constant Diversification Rates}
+\usage{
+diversi.gof(x, null = "exponential", z = NULL)
+}
+\arguments{
+ \item{x}{a numeric vector with the branching times.}
+ \item{null}{a character string specifying the null distribution for
+ the branching times. Only two choices are possible: either
+ \code{"exponential"}, or \code{"user"}.}
+ \item{z}{used if \code{null = "user"}; gives the expected distribution
+ under the model.}
+}
+\description{
+ This function computes two tests of the distribution of branching
+ times using the \enc{Cram�r}{Cramer}--von Mises and Anderson--Darling
+ goodness-of-fit tests. By default, it is assumed that the
+ diversification rate is constant, and an exponential distribution is
+ assumed for the branching times. In this case, the expected
+ distribution under this model is computed with a rate estimated from
+ the data. Alternatively, the user may specify an expected cumulative
+ density function (\code{z}): in this case, \code{x} and \code{z} must
+ be of the same length. See the examples for how to compute the latter
+ from a sample of expected branching times.
+}
+\details{
+ The \enc{Cram�r}{Cramer}--von Mises and Anderson--Darling tests
+ compare the empirical density function (EDF) of the observations to an
+ expected cumulative density function. By contrast to the
+ Kolmogorov--Smirnov test where the greatest difference between these
+ two functions is used, in both tests all differences are taken into
+ account.
+
+ The distributions of both test statistics depend on the null
+ hypothesis, and on whether or not some parameters were estimated from
+ the data. However, these distributions are not known precisely and
+ critical values were determined by Stephens (1974) using
+ simulations. These critical values were used for the present function.
+}
+\value{
+ A NULL value is returned, the results are simply printed.
+}
+\references{
+ Paradis, E. (1998) Testing for constant diversification rates using
+ molecular phylogenies: a general approach based on statistical tests
+ for goodness of fit. \emph{Molecular Biology and Evolution},
+ \bold{15}, 476--479.
+
+ Stephens, M. A. (1974) EDF statistics for goodness of fit and some
+ comparisons. \emph{Journal of the American Statistical Association},
+ \bold{69}, 730--737.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{branching.times}}, \code{\link{diversi.time}}
+ \code{\link{ltt.plot}}, \code{\link{birthdeath}}, \code{\link{yule}},
+ \code{\link{yule.cov}}
+}
+\examples{
+data(bird.families)
+x <- branching.times(bird.families)
+### suppose we have a sample of expected branching times `y';
+### for simplicity, take them from a uniform distribution:
+y <- runif(500, 0, max(x) + 1) # + 1 to avoid A2 = Inf
+### now compute the expected cumulative distribution:
+x <- sort(x)
+N <- length(x)
+ecdf <- numeric(N)
+for (i in 1:N) ecdf[i] <- sum(y <= x[i])/500
+### finally do the test:
+diversi.gof(x, "user", z = ecdf)
+}
+\keyword{univar}
diff --git a/man/diversi.time.Rd b/man/diversi.time.Rd
new file mode 100644
index 0000000..24d6856
--- /dev/null
+++ b/man/diversi.time.Rd
@@ -0,0 +1,58 @@
+\name{diversi.time}
+\alias{diversi.time}
+\title{Analysis of Diversification with Survival Models}
+\usage{
+diversi.time(x, census = NULL, censoring.codes = c(1, 0), Tc = NULL)
+}
+\arguments{
+ \item{x}{a numeric vector with the branching times.}
+ \item{census}{a vector of the same length than `x' used as an
+ indicator variable; thus, it must have only two values, one coding
+ for accurately known branching times, and the other for censored
+ branching times. This argument can be of any mode (numeric, character,
+ logical), or can even be a factor.}
+ \item{censoring.codes}{a vector of length two giving the codes used
+ for \code{census}: by default 1 (accurately known times) and 0 (censored
+ times). The mode must be the same than the one of \code{census}.}
+ \item{Tc}{a single numeric value specifying the break-point time to
+ fit Model C. If none is provided, then it is set arbitrarily to the
+ mean of the analysed branching times.}
+}
+\description{
+ This functions fits survival models to a set of branching times, some
+ of them may be known approximately (censored). Three models are
+ fitted, Model A assuming constant diversification, Model B assuming
+ that diversification follows a Weibull law, and Model C assuming that
+ diversification changes with a breakpoint at time `Tc'. The models are
+ fitted by maximum likelihood.
+}
+\details{
+ The principle of the method is to consider each branching time as an
+ event: if the branching time is accurately known, then it is a failure
+ event; if it is approximately knwon then it is a censoring event. An
+ analogy is thus made between the failure (or hazard) rate estimated by
+ the survival models and the diversification rate of the lineage. Time
+ is here considered from present to past.
+
+ Model B assumes a monotonically changing diversification rate. The
+ parameter that controls the change of this rate is called beta. If
+ beta is greater than one, then the diversification rate decreases
+ through time; if it is lesser than one, the the rate increases through
+ time. If beta is equal to one, then Model B reduces to Model A.
+}
+\value{
+ A NULL value is returned, the results are simply printed.
+}
+\references{
+ Paradis, E. (1997) Assessing temporal variations in diversification
+ rates from phylogenies: estimation and hypothesis
+ testing. \emph{Proceedings of the Royal Society of London. Series
+ B. Biological Sciences}, \bold{264}, 1141--1147.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{branching.times}}, \code{\link{diversi.gof}}
+ \code{\link{ltt.plot}}, \code{\link{birthdeath}},
+ \code{\link{bd.ext}}, \code{\link{yule}}, \code{\link{yule.cov}}
+}
+\keyword{models}
diff --git a/man/diversity.contrast.test.Rd b/man/diversity.contrast.test.Rd
new file mode 100644
index 0000000..c55acc7
--- /dev/null
+++ b/man/diversity.contrast.test.Rd
@@ -0,0 +1,97 @@
+\name{diversity.contrast.test}
+\alias{diversity.contrast.test}
+\title{Diversity Contrast Test}
+\description{
+ This function performs the diversity contrast test comparing pairs of
+ sister-clades.
+}
+\usage{
+diversity.contrast.test(x, method = "ratiolog",
+ alternative = "two.sided", nrep = 0, ...)
+}
+\arguments{
+ \item{x}{a matrix or a data frame with at least two columns: the first
+ one gives the number of species in clades with a trait supposed to
+ increase or decrease diversification rate, and the second one the
+ number of species in the sister-clades without the trait. Each row
+ represents a pair of sister-clades.}
+ \item{method}{a character string specifying the kind of test:
+ \code{"ratiolog"} (default), \code{"proportion"},
+ \code{"difference"}, \code{"logratio"}, or any unambiguous
+ abbreviation of these.}
+ \item{alternative}{a character string defining the alternative
+ hypothesis: \code{"two.sided"} (default), \code{"less"},
+ \code{"greater"}, or any unambiguous abbreviation of these.}
+ \item{nrep}{the number of replications of the randomization test; by
+ default, a Wilcoxon test is done.}
+ \item{\dots}{arguments passed to the function
+ \code{\link[stats]{wilcox.test}}.}
+}
+\details{
+ If \code{method = "ratiolog"}, the test described in Barraclough et
+ al. (1996) is performed. If \code{method = "proportion"}, the version
+ in Barraclough et al. (1995) is used. If \code{method = "difference"},
+ the signed difference is used (Sargent 2004). If \code{method = "logratio"},
+ then this is Wiegmann et al.'s (1993) version. These
+ four tests are essentially different versions of the same test (Vamosi
+ and Vamosi 2005, Vamosi 2007). See Paradis (2012) for a comparison of
+ their statistical performance with other tests.
+
+ If \code{nrep = 0}, a Wilcoxon test is done on the species diversity
+ contrasts with the null hypothesis is that they are distributed around
+ zero. If \code{nrep > 0}, a randomization procedure is done where the
+ signs of the diversity contrasts are randomly chosen. This is used to
+ create a distribution of the test statistic which is compared with the
+ observed value (the sum of the diversity contrasts).
+}
+\value{
+ a single numeric value with the \emph{P}-value.
+}
+\references{
+ Barraclough, T. G., Harvey, P. H. and Nee, S. (1995) Sexual
+ selection and taxonomic diversity in passerine birds.
+ \emph{Proceedings of the Royal Society of London. Series B. Biological
+ Sciences}, \bold{259}, 211--215.
+
+ Barraclough, T. G., Harvey, P. H., and Nee, S. (1996) Rate of
+ \emph{rbc}L gene sequence evolution and species diversification in
+ flowering plants (angiosperms). \emph{Proceedings of the Royal Society
+ of London. Series B. Biological Sciences}, \bold{263}, 589--591.
+
+ Paradis, E. (2012) Shift in diversification in sister-clade
+ comparisons: a more powerful test. \emph{Evolution}, \bold{66},
+ 288--295.
+
+ Sargent, R. D. (2004) Floral symmetry affects speciation rates in
+ angiosperms. \emph{Proceedings of the Royal Society of London. Series
+ B. Biological Sciences}, \bold{271}, 603--608.
+
+ Vamosi, S. M. (2007) Endless tests: guidelines for analysing non-nested
+ sister-group comparisons. An addendum. \emph{Evolutionary Ecology
+ Research}, \bold{9}, 717.
+
+ Vamosi, S. M. and Vamosi, J. C. (2005) Endless tests: guidelines for
+ analysing non-nested sister-group comparisons. \emph{Evolutionary
+ Ecology Research}, \bold{7}, 567--579.
+
+ Wiegmann, B., Mitter, C. and Farrell, B. 1993. Diversification of
+ carnivorous parasitic insects: extraordinary radiation or specialized
+ dead end? \emph{American Naturalist}, \bold{142}, 737--754.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{slowinskiguyer.test}}, \code{\link{mcconwaysims.test}}
+ \code{\link{richness.yule.test}}
+}
+\examples{
+### data from Vamosi & Vamosi (2005):
+fleshy <- c(1, 1, 1, 1, 1, 3, 3, 5, 9, 16, 33, 40, 50, 100, 216, 393, 850, 947,1700)
+dry <- c(2, 64, 300, 89, 67, 4, 34, 10, 150, 35, 2, 60, 81, 1, 3, 1, 11, 1, 18)
+x <- cbind(fleshy, dry)
+diversity.contrast.test(x)
+diversity.contrast.test(x, alt = "g")
+diversity.contrast.test(x, alt = "g", nrep = 1e4)
+slowinskiguyer.test(x)
+mcconwaysims.test(x)
+}
+\keyword{htest}
diff --git a/man/drop.tip.Rd b/man/drop.tip.Rd
new file mode 100644
index 0000000..4b4b60e
--- /dev/null
+++ b/man/drop.tip.Rd
@@ -0,0 +1,96 @@
+\name{drop.tip}
+\alias{drop.tip}
+\alias{extract.clade}
+\title{Remove Tips in a Phylogenetic Tree}
+\description{
+ \code{drop.tip} removes the terminal branches of a phylogenetic tree,
+ possibly removing the corresponding internal branches.
+
+ \code{extract.clade} does the inverse operation: it keeps all the tips
+ from a given node, and deletes all the other tips.
+}
+\usage{
+drop.tip(phy, tip, trim.internal = TRUE, subtree = FALSE,
+ root.edge = 0, rooted = is.rooted(phy), interactive = FALSE)
+extract.clade(phy, node, root.edge = 0, interactive = FALSE)
+}
+\arguments{
+ \item{phy}{an object of class \code{"phylo"}.}
+ \item{tip}{a vector of mode numeric or character specifying the tips
+ to delete.}
+ \item{trim.internal}{a logical specifying whether to delete the
+ corresponding internal branches.}
+ \item{subtree}{a logical specifying whether to output in the tree how
+ many tips have been deleted and where.}
+ \item{root.edge}{an integer giving the number of internal branches to
+ be used to build the new root edge. This has no effect if
+ \code{trim.internal = FALSE}.}
+ \item{rooted}{a logical indicating whether the tree must be treated as
+ rooted or not. This allows to force the tree to be considered as
+ unrooted (see examples).}
+ \item{node}{a node number or label.}
+ \item{interactive}{if \code{TRUE} the user is asked to select the tips
+ or the node by clicking on the tree which must be plotted.}
+}
+\details{
+ The argument \code{tip} can be either character or numeric. In the
+ first case, it gives the labels of the tips to be deleted; in the
+ second case the numbers of these labels in the vector
+ \code{phy$tip.label} are given.
+
+ This also applies to \code{node}, but if this argument is character
+ and the tree has no node label, this results in an error. If more than
+ one value is given with \code{node} (i.e., a vector of length two or
+ more), only the first one is used with a warning.
+
+ If \code{trim.internal = FALSE}, the new tips are given \code{"NA"} as
+ labels, unless there are node labels in the tree in which case they
+ are used.
+
+ If \code{subtree = TRUE}, the returned tree has one or several
+ terminal branches indicating how many tips have been removed (with a
+ label \code{"[x_tips]"}). This is done for as many monophyletic groups
+ that have been deleted.
+
+ Note that \code{subtree = TRUE} implies \code{trim.internal = TRUE}.
+
+ To undestand how the option \code{root.edge} works, see the examples
+ below.
+}
+\value{
+ an object of class \code{"phylo"}.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{bind.tree}}, \code{\link{root}}
+}
+\examples{
+data(bird.families)
+tip <- c(
+"Eopsaltriidae", "Acanthisittidae", "Pittidae", "Eurylaimidae",
+"Philepittidae", "Tyrannidae", "Thamnophilidae", "Furnariidae",
+"Formicariidae", "Conopophagidae", "Rhinocryptidae", "Climacteridae",
+"Menuridae", "Ptilonorhynchidae", "Maluridae", "Meliphagidae",
+"Pardalotidae", "Petroicidae", "Irenidae", "Orthonychidae",
+"Pomatostomidae", "Laniidae", "Vireonidae", "Corvidae",
+"Callaeatidae", "Picathartidae", "Bombycillidae", "Cinclidae",
+"Muscicapidae", "Sturnidae", "Sittidae", "Certhiidae",
+"Paridae", "Aegithalidae", "Hirundinidae", "Regulidae",
+"Pycnonotidae", "Hypocoliidae", "Cisticolidae", "Zosteropidae",
+"Sylviidae", "Alaudidae", "Nectariniidae", "Melanocharitidae",
+"Paramythiidae","Passeridae", "Fringillidae")
+plot(drop.tip(bird.families, tip))
+plot(drop.tip(bird.families, tip, trim.internal = FALSE))
+data(bird.orders)
+plot(drop.tip(bird.orders, 6:23, subtree = TRUE))
+plot(drop.tip(bird.orders, c(1:5, 20:23), subtree = TRUE))
+plot(drop.tip(bird.orders, c(1:20, 23), subtree = TRUE))
+plot(drop.tip(bird.orders, c(1:20, 23), subtree = TRUE, rooted = FALSE))
+### Examples of the use of `root.edge'
+tr <- read.tree(text = "(A:1,(B:1,(C:1,(D:1,E:1):1):1):1):1;")
+drop.tip(tr, c("A", "B"), root.edge = 0) # = (C:1,(D:1,E:1):1);
+drop.tip(tr, c("A", "B"), root.edge = 1) # = (C:1,(D:1,E:1):1):1;
+drop.tip(tr, c("A", "B"), root.edge = 2) # = (C:1,(D:1,E:1):1):2;
+drop.tip(tr, c("A", "B"), root.edge = 3) # = (C:1,(D:1,E:1):1):3;
+}
+\keyword{manip}
diff --git a/man/edges.Rd b/man/edges.Rd
new file mode 100644
index 0000000..4153863
--- /dev/null
+++ b/man/edges.Rd
@@ -0,0 +1,50 @@
+\name{edges}
+\alias{edges}
+\alias{fancyarrows}
+\title{Draw Additional Edges on a Plotted Tree}
+\description{
+ \code{edges} draws edges on a plotted tree. \code{fancyarrows}
+ enhances \code{\link[graphics]{arrows}} with triangle and harpoon
+ heads; it can be called from \code{edges}.
+}
+\usage{
+edges(nodes0, nodes1, arrows = 0, type = "classical", ...)
+fancyarrows(x0, y0, x1, y1, length = 0.25, angle = 30, code = 2,
+ col = par("fg"), lty = par("lty"), lwd = par("lwd"),
+ type = "triangle", ...)
+}
+\arguments{
+ \item{nodes0, nodes1}{vectors of integers giving the tip and/or node
+ numbers where to start and to end the edges (eventually recycled).}
+ \item{arrows}{an integer between 0 and 3; 0: lines (the default); 1:
+ an arrow head is drawn at \code{nodes0}; 2: at \code{nodes1}; 3:
+ both.}
+ \item{type}{if the previous argument is not 0, the type of arrow head:
+ \code{"classical"} (just lines, the default), \code{"triangle"},
+ \code{"harpoon"}, or any unambiguous abbreviations of these. For
+ \code{fancyarrows} only the last two are available.}
+ \item{x0, y0, x1, y1}{the coordinates of the start and end points for
+ \code{fancyarrows} (these are not recycled and so should be vectors
+ of the same length).}
+ \item{length, angle, code, col, lty, lwd}{default options similar to
+ those of \code{\link[graphics]{arrows}}.}
+ \item{\dots}{further arguments passed to \code{\link[graphics]{segments}}.}
+}
+\details{
+ The first function is helpful when drawing reticulations on a phylogeny,
+ especially if computed from the edge matrix.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{plot.phylo}}, \code{\link{nodelabels}}
+}
+\examples{
+set.seed(2)
+tr <- rcoal(6)
+plot(tr, "c")
+edges(10, 9, col = "red", lty = 2)
+edges(10:11, 8, col = c("blue", "green")) # recycling of 'nodes1'
+edges(1, 2, lwd = 2, type = "h", arrows = 3, col = "green")
+nodelabels()
+}
+\keyword{aplot}
diff --git a/man/evonet.Rd b/man/evonet.Rd
new file mode 100644
index 0000000..b41acf0
--- /dev/null
+++ b/man/evonet.Rd
@@ -0,0 +1,70 @@
+\name{evonet}
+\alias{evonet}
+\alias{print.evonet}
+\alias{plot.evonet}
+\alias{as.phylo.evonet}
+\alias{as.networx.evonet}
+\alias{as.network.evonet}
+\alias{as.igraph.evonet}
+\title{Evolutionary Networks}
+\description{
+ \code{evonet} builds a network from a tree of class
+ \code{"phylo"}. There are \code{print} and \code{plot} methods as well
+ as a few conversion functions.
+}
+\usage{
+evonet(phy, from, to = NULL)
+\method{print}{evonet}(x, ...)
+\method{plot}{evonet}(x, col = "blue", lty = 1, lwd = 1, alpha = 0.5,
+ arrows = 0, arrow.type = "classical", ...)
+\method{as.phylo}{evonet}(x, ...)
+\method{as.networx}{evonet}(x, weight = NA, ...)
+\method{as.network}{evonet}(x, directed = TRUE, ...)
+\method{as.igraph}{evonet}(x, directed = TRUE, use.labels = TRUE, ...)
+}
+\arguments{
+ \item{phy, x}{an object of class \code{"phylo"} or \code{"evonet"}.}
+ \item{from}{a vector (or a matrix if \code{to = NULL}) giving the node
+ or tip numbers involved in the reticulations.}
+ \item{to}{a vector of the same length than \code{from}.}
+ \item{col, lty, lwd}{colors, line type and width of the reticulations
+ (recycled if necessary).}
+ \item{alpha}{a value between 0 and 1 specifying the transparency of
+ the reticulations.}
+ \item{arrows}{see \code{\link{fancyarrows}}.}
+ \item{arrow.type}{idem.}
+ \item{weight}{a numeric vector giving the weights for the
+ reticulations when converting to the class \code{"networx"}
+ (recycled or shortened if needed).}
+ \item{directed}{a logical: should the network be considered as
+ directed? \code{TRUE} by default.}
+ \item{use.labels}{a logical specifying whether to use the tip and node
+ labels when building the network of class \code{"igraph"}.}
+ \item{\dots}{arguments passed to other methods.}
+}
+\details{
+ \code{evonet} is a constructor function that checks the arguments.
+
+ The classes \code{"networx"}, \code{"network"}, and \code{"igraph"}
+ are defined in the packages \pkg{phangorn}, \pkg{network}, and
+ \pkg{igraph}, respectively.
+}
+\value{
+ an object of class \code{c("evonet", "phylo")} which is made of an
+ object of class \code{"\link{phylo}"} plus an element
+ \code{reticulation} coding additional edges among nodes and uses the
+ same coding rules than the \code{edge} matrix.
+
+ The conversion functions return an object of the appropriate class.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link[phangorn]{as.networx}} in package \pkg{phangorn}
+}
+\examples{
+tr <- rcoal(5)
+(x <- evonet(tr, 6:7, 8:9))
+plot(x)
+}
+\keyword{manip}
+\keyword{hplot}
diff --git a/man/ewLasso.Rd b/man/ewLasso.Rd
new file mode 100644
index 0000000..0212fef
--- /dev/null
+++ b/man/ewLasso.Rd
@@ -0,0 +1,48 @@
+\name{ewLasso}
+\alias{ewLasso}
+\title{
+ Incomplete distances and edge weights of unrooted topology
+}
+\description{
+ This function implements a method for checking whether an incomplete
+ set of distances satisfy certain conditions that might make it
+ uniquely determine the edge weights of a given topology, T. It prints
+ information about whether the graph with vertex set the set of leaves,
+ denoted by X, and edge set the set of non-missing distance pairs,
+ denoted by L, is connected or strongly non-bipartite. It then also
+ checks whether L is a triplet cover for T.
+}
+\usage{
+ewLasso(X, phy)
+}
+\arguments{
+ \item{X}{a distance matrix.}
+ \item{phy}{an unrooted tree of class \code{"phylo"}.}
+}
+\details{
+ Missing values must be represented by either \code{NA} or a negative value.
+
+ This implements a method for checking whether an incomplete set of
+ distances satisfies certain conditions that might make it uniquely
+ determine the edge weights of a given topology, T. It prints
+ information about whether the graph, G, with vertex set the set of
+ leaves, denoted by X, and edge set the set of non-missing distance
+ pairs, denoted by L, is connected or strongly non-bipartite. It also
+ checks whether L is a triplet cover for T. If G is not connected, then
+ T does not need to be the only topology satisfying the input
+ incomplete distances. If G is not strongly non-bipartite then the
+ edge-weights of the edges of T are not the unique ones for which the
+ input distance is satisfied. If L is a triplet cover, then the input
+ distance matrix uniquely determines the edge weights of T. See Dress
+ et al. (2012) for details.
+}
+\value{
+ NULL, the results are printed in the console.
+}
+\references{
+ Dress, A. W. M., Huber, K. T., and Steel, M. (2012) `Lassoing' a
+ phylogentic tree I: basic properties, shellings and covers.
+ \emph{Journal of Mathematical Biology}, \bold{65(1)}, 77--105.
+}
+\author{Andrei Popescu \email{niteloserpopescu at gmail.com}}
+\keyword{multivariate}
diff --git a/man/fastme.Rd b/man/fastme.Rd
new file mode 100644
index 0000000..0500cdd
--- /dev/null
+++ b/man/fastme.Rd
@@ -0,0 +1,58 @@
+\name{FastME}
+\alias{FastME}
+\alias{fastme}
+\alias{fastme.bal}
+\alias{fastme.ols}
+\title{
+ Tree Estimation Based on the Minimum Evolution Algorithm
+}
+\description{
+ The two FastME functions (balanced and OLS) perform the
+ minimum evolution algorithm of Desper and Gascuel (2002).
+}
+\usage{
+ fastme.bal(X, nni = TRUE, spr = TRUE, tbr = TRUE)
+ fastme.ols(X, nni = TRUE)
+}
+\arguments{
+ \item{X}{a distance matrix; may be an object of class \code{"dist"}.}
+ \item{nni}{a boolean value; TRUE to do NNIs (default).}
+ \item{spr}{ditto for SPRs.}
+ \item{tbr}{ditto for TBRs.}
+}
+\value{
+ an object of class \code{"phylo"}.
+}
+\references{
+ Desper, R. and Gascuel, O. (2002) Fast and accurate phylogeny
+ reconstruction algorithms based on the minimum-evolution principle.
+ \emph{Journal of Computational Biology}, \bold{9(5)}, 687--705.
+}
+\author{
+ original C code by Richard Desper; adapted and ported to R
+ by Vincent Lefort \email{vincent.lefort at lirmm.fr}
+}
+\seealso{
+ \code{\link{nj}}, \code{\link{bionj}},
+ \code{\link{write.tree}}, \code{\link{read.tree}},
+ \code{\link{dist.dna}}
+}
+\examples{
+### From Saitou and Nei (1987, Table 1):
+x <- c(7, 8, 11, 13, 16, 13, 17, 5, 8, 10, 13,
+ 10, 14, 5, 7, 10, 7, 11, 8, 11, 8, 12,
+ 5, 6, 10, 9, 13, 8)
+M <- matrix(0, 8, 8)
+M[lower.tri(M)] <- x
+M <- t(M)
+M[lower.tri(M)] <- x
+dimnames(M) <- list(1:8, 1:8)
+tr <- fastme.bal(M)
+plot(tr, "u")
+### a less theoretical example
+data(woodmouse)
+trw <- fastme.bal(dist.dna(woodmouse))
+plot(trw)
+}
+\keyword{models}
+
diff --git a/man/gammaStat.Rd b/man/gammaStat.Rd
new file mode 100644
index 0000000..c4b3b80
--- /dev/null
+++ b/man/gammaStat.Rd
@@ -0,0 +1,41 @@
+\name{gammaStat}
+\alias{gammaStat}
+\title{Gamma-Statistic of Pybus and Harvey}
+\usage{
+gammaStat(phy)
+}
+\arguments{
+ \item{phy}{an object of class \code{"phylo"}.}
+}
+\description{
+ This function computes the gamma-statistic which summarizes the
+ information contained in the inter-node intervals of a phylogeny. It
+ is assumed that the tree is ultrametric. Note that the function does
+ not check that the tree is effectively ultrametric, so if it is not,
+ the returned result may not be meaningful.
+}
+\value{
+ a numeric vector of length one.
+}
+\details{
+ The gamma-statistic is a summary of the information contained in the
+ inter-node intervals of a phylogeny; it follows, under the assumption
+ that the clade diversified with constant rates, a normal distribution
+ with mean zero and standard-deviation unity (Pybus and Harvey
+ 2000). Thus, the null hypothesis that the clade diversified with
+ constant rates may be tested with \code{2*(1 -
+ pnorm(abs(gammaStat(phy))))} for a two-tailed test, or \code{1 -
+ pnorm(abs(gammaStat(phy)))} for a one-tailed test, both returning
+ the corresponding P-value.
+}
+\references{
+ Pybus, O. G. and Harvey, P. H. (2000) Testing macro-evolutionary
+ models using incomplete molecular phylogenies. \emph{Proceedings of
+ the Royal Society of London. Series B. Biological Sciences},
+ \bold{267}, 2267--2272.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{branching.times}}, \code{\link{ltt.plot}}, \code{\link{skyline}}
+}
+\keyword{univar}
diff --git a/man/hivtree.Rd b/man/hivtree.Rd
new file mode 100644
index 0000000..af908ce
--- /dev/null
+++ b/man/hivtree.Rd
@@ -0,0 +1,56 @@
+\name{hivtree}
+\alias{hivtree}
+\alias{hivtree.newick}
+\alias{hivtree.table}
+
+\title{Phylogenetic Tree of 193 HIV-1 Sequences}
+
+\description{
+ This data set describes an estimated clock-like phylogeny of 193 HIV-1
+ group M sequences sampled in the Democratic Republic of Congo.
+}
+
+\usage{
+data(hivtree.newick)
+data(hivtree.table)
+}
+
+\format{
+ \code{hivtree.newick} is a string with the tree in Newick format.
+ The data frame \code{hivtree.table} contains the corresponding internode
+ distances.
+}
+
+\source{
+ This is a data example from Strimmer and Pybus (2001).
+}
+
+\references{
+ Strimmer, K. and Pybus, O. G. (2001) Exploring the demographic history
+ of DNA sequences using the generalized skyline plot. \emph{Molecular
+ Biology and Evolution}, \bold{18}, 2298--2305.
+}
+
+\examples{
+# example tree in NH format (a string)
+data("hivtree.newick")
+hivtree.newick
+
+# generate file "hivtree.phy" in working directory
+cat(hivtree.newick, file = "hivtree.phy", sep = "\n")
+tree.hiv <- read.tree("hivtree.phy") # load tree
+unlink("hivtree.phy") # delete the file "hivtree.phy"
+
+plot(tree.hiv)
+
+# table with list of internode distances
+data("hivtree.table")
+hivtree.table
+
+
+# construct coalescence intervals
+ci <- coalescent.intervals(tree.hiv) # from tree
+ci <- coalescent.intervals(hivtree.table$size) #from intervals
+ci
+}
+\keyword{datasets}
diff --git a/man/howmanytrees.Rd b/man/howmanytrees.Rd
new file mode 100644
index 0000000..23bc7e6
--- /dev/null
+++ b/man/howmanytrees.Rd
@@ -0,0 +1,66 @@
+\name{howmanytrees}
+\alias{howmanytrees}
+\title{Calculate Numbers of Phylogenetic Trees}
+\usage{
+howmanytrees(n, rooted = TRUE, binary = TRUE,
+ labeled = TRUE, detail = FALSE)
+}
+\arguments{
+ \item{n}{a positive numeric integer giving the number of tips.}
+ \item{rooted}{a logical indicating whether the trees are rooted
+ (default is \code{TRUE}).}
+ \item{binary}{a logical indicating whether the trees are bifurcating
+ (default is \code{TRUE}).}
+ \item{labeled}{a logical indicating whether the trees have tips
+ labeled (default is \code{TRUE}).}
+ \item{detail}{a logical indicating whether the eventual intermediate
+ calculations should be returned (default is \code{FALSE}). This
+ applies only for the multifurcating trees, and the bifurcating,
+ rooted, unlabeled trees (aka tree shapes).}
+}
+\description{
+ This function calculates the number of possible phylogenetic trees for
+ a given number of tips.
+}
+\details{
+ In the cases of labeled binary trees, the calculation is done directly
+ and a single numeric value is returned.
+
+ For multifurcating trees, and bifurcating, rooted, unlabeled trees,
+ the calculation is done iteratively for 1 to \code{n} tips. Thus the
+ user can print all the intermediate values if \code{detail = TRUE}, or
+ only a single value if \code{detail = FALSE} (the default).
+
+ For multifurcating trees, if \code{detail = TRUE}, a matrix is
+ returned with the number of tips as rows (named from \code{1} to
+ \code{n}), and the number of nodes as columns (named from \code{1} to
+ \code{n - 1}). For bifurcating, rooted, unlabeled trees, a vector is
+ returned with names equal to the number of tips (from \code{1} to
+ \code{n}).
+
+ The number of unlabeled trees (aka tree shapes) can be computed only
+ for the rooted binary cases.
+
+ Note that if an infinite value (\code{Inf}) is returned this does not
+ mean that there is an infinite number of trees (this cannot be if the
+ number of tips is finite), but that the calculation is beyond the
+ limits of the computer.
+}
+\value{
+ a single numeric value, or in the case where \code{detail = TRUE} is
+ used, a named vector or matrix.
+}
+\references{
+ Felsenstein, J. (2004) \emph{Inferring Phylogenies}. Sunderland:
+ Sinauer Associates.
+}
+\author{Emmanuel Paradis}
+\examples{
+### Table 3.1 in Felsenstein 2004:
+for (i in c(1:20, 30, 40, 50))
+ cat(paste(i, howmanytrees(i), sep = "\t"), sep ="\n")
+### Table 3.6:
+howmanytrees(8, binary = FALSE, detail = TRUE)
+}
+\keyword{arith}
+\keyword{math}
diff --git a/man/identify.phylo.Rd b/man/identify.phylo.Rd
new file mode 100644
index 0000000..c7fd7af
--- /dev/null
+++ b/man/identify.phylo.Rd
@@ -0,0 +1,62 @@
+\name{identify.phylo}
+\alias{identify.phylo}
+\title{Graphical Identification of Nodes and Tips}
+\usage{
+\method{identify}{phylo}(x, nodes = TRUE, tips = FALSE,
+ labels = FALSE, quiet = FALSE, ...)
+}
+\arguments{
+ \item{x}{an object of class \code{"phylo"}.}
+ \item{nodes}{a logical specifying whether to identify the node.}
+ \item{tips}{a logical specifying whether to return the tip
+ information.}
+ \item{labels}{a logical specifying whether to return the labels; by
+ default only the numbers are returned.}
+ \item{quiet}{a logical controlling whether to print a message inviting
+ the user to click on the tree.}
+ \item{\dots}{further arguments to be passed to or from other methods.}
+}
+\description{
+ This function allows to identify a clade on a plotted tree by clicking
+ on the plot with the mouse. The tree, specified in the argument
+ \code{x}, must be plotted beforehand.
+}
+\details{
+ By default, the clade is identified by its number as found in the
+ `edge' matrix of the tree. If \code{tips = TRUE}, the tips descending
+ from the identified node are returned, possibly together with the
+ node. If \code{labels = TRUE}, the labels are returned (if the tree
+ has no node labels, then the node numbered is returned).
+
+ The node is identified by the shortest distance where the click
+ occurs. If the click occurs close to a tip, the function returns its
+ information.
+}
+\note{
+ This function does not add anything on the plot, but it can be wrapped
+ with, e.g., \code{\link{nodelabels}} (see example), or its results can
+ be sent to, e.g., \code{\link{drop.tip}}.
+}
+\value{
+ A list with one or two vectors named \code{"tips"} and/or
+ \code{"nodes"} with the identification of the tips and/or of the
+ nodes.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{plot.phylo}}, \code{\link{nodelabels}},
+ \code{\link[graphics]{identify}} for the generic function
+}
+\examples{
+\dontrun{
+tr <- rtree(20)
+f <- function(col) {
+ o <- identify(tr)
+ nodelabels(node=o$nodes, pch = 19, col = col)
+}
+plot(tr)
+f("red") # click close to a node
+f("green")
+}
+}
+\keyword{aplot}
diff --git a/man/image.DNAbin.Rd b/man/image.DNAbin.Rd
new file mode 100644
index 0000000..0740aae
--- /dev/null
+++ b/man/image.DNAbin.Rd
@@ -0,0 +1,66 @@
+\name{image.DNAbin}
+\alias{image.DNAbin}
+\title{Plot of DNA Sequence Alignement}
+\description{
+ This function plots an image of an alignment of nucleotide sequences.
+}
+\usage{
+\method{image}{DNAbin}(x, what, col, bg = "white", xlab = "", ylab = "",
+ show.labels = TRUE, cex.lab = 1, legend = TRUE, ...)
+}
+\arguments{
+ \item{x}{a matrix of DNA sequences (class \code{"DNAbin"}).}
+ \item{what}{a vector of characters specifying the bases to
+ visualize. If missing, this is set to ``a'', ``g'', ``c'', ``t'',
+ ``n'', and ``-'' (in this order).}
+ \item{col}{a vector of colours. If missing, this is set to ``red'',
+ ``yellow'', ``green'', ``blue'', ``grey'', and ``black''. If it is
+ shorter (or longer) than \code{what}, it is recycled (or shortened).}
+ \item{bg}{the colour used for nucleotides whose base is not among
+ \code{what}.}
+ \item{xlab}{the label for the \emph{x}-axis; none by default.}
+ \item{ylab}{Idem for the \emph{y}-axis. Note that by default, the
+ labels of the sequences are printed on the \emph{y}-axis (see next option).}
+ \item{show.labels}{a logical controlling whether the sequence labels
+ are printed (\code{TRUE} by default).}
+ \item{cex.lab}{a single numeric controlling the size of the sequence labels.
+ Use \code{cex.axis} to control the size of the annotations on the \emph{x}-axis.}
+ \item{legend}{a logical controlling whether the legend is plotted
+ (\code{TRUE} by default).}
+ \item{\dots}{further arguments passed to
+ \code{\link[graphics]{image.default}} (e.g., \code{cex.axis}).}
+}
+\details{
+ The idea of this function is to allow flexible plotting and colouring
+ of a nucleotide alignment. By default, the most common bases (a, g, c,
+ t, and n) and alignment gap are plotted using a standard colour
+ scheme.
+
+ It is possible to plot only one base specified as \code{what} with a
+ chosen colour: this might be useful to check, for instance, the
+ distribution of alignment gaps (\code{image(x, "-")}) or missing data
+ (see examples).
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{DNAbin}}, \code{\link{del.gaps}}, \code{\link{alex}},
+ \code{\link{clustal}}, \code{\link[graphics]{grid}}
+}
+\examples{
+data(woodmouse)
+image(woodmouse)
+image(woodmouse, "n", "blue") # show missing data
+image(woodmouse, c("g", "c"), "green") # G+C
+par(mfcol = c(2, 2))
+### barcoding style:
+for (x in c("a", "g", "c", "t"))
+ image(woodmouse, x, "black", cex.lab = 0.5, cex.axis = 0.7)
+par(mfcol = c(1, 1))
+### zoom on a portion of the data:
+image(woodmouse[11:15, 1:50], c("a", "n"), c("blue", "grey"))
+grid(50, 5, col = "black")
+### see the guanines on a black background:
+image(woodmouse, "g", "yellow", "black")
+}
+\keyword{hplot}
+
diff --git a/man/is.binary.tree.Rd b/man/is.binary.tree.Rd
new file mode 100644
index 0000000..992091b
--- /dev/null
+++ b/man/is.binary.tree.Rd
@@ -0,0 +1,35 @@
+\name{is.binary.tree}
+\alias{is.binary.tree}
+\title{Test for Binary Tree}
+\description{
+ This function tests whether a phylogenetic tree is binary.
+}
+\usage{
+is.binary.tree(phy)
+}
+\arguments{
+ \item{phy}{an object of class \code{"phylo"}.}
+}
+\details{
+ The test differs slightly whether the tree is rooted or not. An
+ urooted tree is considered binary if all its nodes are of degree three
+ (i.e., three edges connect to each node). A rooted tree is considered
+ binary if all nodes (including the root node) have exactly two
+ descendant nodes, so that they are of degree three expect the root
+ which is of degree 2.
+}
+\value{
+ \code{is.binary.tree} returns \code{TRUE} if \code{tree} is a fully
+ binary phylogenetic tree, otherwise it returns \code{FALSE}.
+}
+\seealso{
+\code{\link{is.rooted}}, \code{\link{is.ultrametric}}, \code{\link{multi2di}}
+}
+\author{Korbinian Strimmer (\url{http://www.stat.uni-muenchen.de/~strimmer/})}
+\examples{
+data("hivtree.newick") # example tree in NH format
+tree.hiv <- read.tree(text = hivtree.newick)
+is.binary.tree(tree.hiv)
+plot(tree.hiv)
+}
+\keyword{logic}
diff --git a/man/is.compatible.Rd b/man/is.compatible.Rd
new file mode 100644
index 0000000..e8f2af7
--- /dev/null
+++ b/man/is.compatible.Rd
@@ -0,0 +1,25 @@
+\name{is.compatible}
+\alias{is.compatible}
+\alias{is.compatible.bitsplits}
+\alias{arecompatible}
+\title{Check Compatibility of Splits}
+\description{
+ \code{is.compatible} is a generic function with a method for the class
+ \code{"bitsplits"}. It checks whether a set of splits is compatible
+ using the \code{arecompatible} function.
+}
+\usage{
+is.compatible(obj)
+\method{is.compatible}{bitsplits}(obj)
+arecompatible(x, y, n)
+}
+\arguments{
+ \item{obj}{an object of class \code{"bitsplits"}.}
+ \item{x, y}{a vector of mode raw\code{}.}
+ \item{n}{the number of taxa in the splits.}
+}
+\value{
+ \code{TRUE} if the splits are compatible, \code{FALSE} otherwise.
+}
+\author{Andrei Popescu \email{niteloserpopescu at gmail.com}}
+\keyword{manip}
diff --git a/man/is.monophyletic.Rd b/man/is.monophyletic.Rd
new file mode 100644
index 0000000..1c170a7
--- /dev/null
+++ b/man/is.monophyletic.Rd
@@ -0,0 +1,59 @@
+\name{is.monophyletic}
+\alias{is.monophyletic}
+\title{
+ Is Group Monophyletic
+}
+\usage{
+is.monophyletic(phy, tips, reroot = !is.rooted(phy), plot = FALSE, ...)
+}
+\description{
+ This function tests whether a list of tip labels is monophyletic on a given tree.
+}
+\arguments{
+ \item{phy}{
+ a phylogenetic tree description of class \code{"phylo"}.
+ }
+ \item{tips}{
+ a vector of mode numeric or character specifying the tips to be tested.
+ }
+ \item{reroot}{
+ a logical. If \code{FALSE}, then the input tree is not unrooted before the test.
+ }
+ \item{plot}{
+ a logical. If \code{TRUE}, then the tree is plotted with the specified group \code{tips} highlighted.
+ }
+ \item{\dots}{
+ further arguments passed to \code{plot}.
+ }
+}
+\details{
+ If \code{phy} is rooted, the test is done on the rooted tree, otherwise
+ the tree is first unrooted, then arbitrarily rerooted, in order to be
+ independent on the current position of the root. That is, the test
+ asks if \code{tips} could be monophyletic given any favourably rooting
+ of \code{phy}.
+
+ If \code{phy} is unrooted the test is done on an unrooted tree, unless
+ \code{reroot = FALSE} is specified.
+
+ If tip labels in the list \code{tips} are given as characters, they need
+ to be spelled as in the object \code{phy}.
+}
+\value{
+ \code{TRUE} or \code{FALSE}.
+}
+\author{
+ Johan Nylander \email{jnylander at users.sourceforge.net}
+}
+\seealso{
+ \code{\link{which.edge}}, \code{\link{drop.tip}}, \code{\link{mrca}}.
+}
+\examples{
+ ## Test one monophyletic and one paraphyletic group on the bird.orders tree
+ \dontrun{data("bird.orders")}
+ \dontrun{is.monophyletic(phy = bird.orders, tips = c("Ciconiiformes", "Gruiformes"))}
+ \dontrun{is.monophyletic(bird.orders, c("Passeriformes", "Ciconiiformes", "Gruiformes"))}
+ \dontshow{\dontrun{rm(bird.orders)}}
+}
+\keyword{utilities}
+
diff --git a/man/is.ultrametric.Rd b/man/is.ultrametric.Rd
new file mode 100644
index 0000000..b3fdab4
--- /dev/null
+++ b/man/is.ultrametric.Rd
@@ -0,0 +1,29 @@
+\name{is.ultrametric}
+\alias{is.ultrametric}
+\title{Test if a Tree is Ultrametric}
+\usage{
+is.ultrametric(phy, tol = .Machine$double.eps^0.5)
+}
+\arguments{
+ \item{phy}{an object of class \code{"phylo"}.}
+ \item{tol}{a numeric >= 0, variation below this value are considered
+ non-significant (see details).}
+}
+\description{
+ This function computes the distances from each tip to the root: if the
+ variance of these distances is null, the tree is considered as
+ ultrametric.
+}
+\value{
+ a logical: \code{TRUE} if the tree is ultrametric, \code{FALSE}
+ otherwise.
+}
+\details{
+ The default value for \code{tol} is based on the numerical
+ characteristics of the machine \R is running on.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{is.binary.tree}}, \code{\link[base]{.Machine}}
+}
+\keyword{utilities}
diff --git a/man/kronoviz.Rd b/man/kronoviz.Rd
new file mode 100644
index 0000000..596fc54
--- /dev/null
+++ b/man/kronoviz.Rd
@@ -0,0 +1,33 @@
+\name{kronoviz}
+\alias{kronoviz}
+\title{Plot Multiple Chronograms on the Same Scale}
+\description{
+ The main argument is a list of (rooted) trees which are plotted on the
+ same scale.
+}
+\usage{
+kronoviz(x, layout = length(x), horiz = TRUE, ...)
+}
+\arguments{
+ \item{x}{a list of (rooted) trees of class \code{"phylo"}.}
+ \item{layout}{an integer giving the number of trees plotted
+ simultaneously; by default all.}
+ \item{horiz}{a logical specifying whether the trees should be plotted
+ rightwards (the default) or upwards.}
+ \item{\dots}{further arguments passed to \code{plot.phylo}.}
+}
+\details{
+ The size of the individual plots is proportional to the size of the
+ trees.
+}
+\value{NULL}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{plot.phylo}}
+}
+\examples{
+TR <- replicate(10, rcoal(sample(11:20, size = 1)), simplify = FALSE)
+kronoviz(TR)
+kronoviz(TR, horiz = FALSE, type = "c", show.tip.label = FALSE)
+}
+\keyword{hplot}
diff --git a/man/ladderize.Rd b/man/ladderize.Rd
new file mode 100644
index 0000000..8855837
--- /dev/null
+++ b/man/ladderize.Rd
@@ -0,0 +1,29 @@
+\name{ladderize}
+\alias{ladderize}
+\title{Ladderize a Tree}
+\usage{
+ladderize(phy, right = TRUE)
+}
+\arguments{
+ \item{phy}{an object of class \code{"phylo"}.}
+ \item{right}{a logical specifying whether the smallest clade is on the
+ right-hand side (when the tree is plotted upwards), or the opposite
+ (if \code{FALSE}).}
+}
+\description{
+ This function reorganizes the internal structure of the tree to get
+ the ladderized effect when plotted.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{plot.phylo}}, \code{\link{reorder.phylo}}
+}
+\examples{
+tr <- rcoal(50)
+layout(matrix(1:4, 2, 2))
+plot(tr, main = "normal")
+plot(ladderize(tr), main = "right-ladderized")
+plot(ladderize(tr, FALSE), main = "left-ladderized")
+layout(matrix(1, 1))
+}
+\keyword{manip}
diff --git a/man/landplants.Rd b/man/landplants.Rd
new file mode 100644
index 0000000..837a274
--- /dev/null
+++ b/man/landplants.Rd
@@ -0,0 +1,37 @@
+\name{landplants}
+\alias{landplants}
+\alias{landplants.newick}
+\title{Gene Tree of 36 Landplant rbcL Sequences}
+\description{
+ This data set describes a gene tree estimated from 36 landplant
+ \emph{rbc}L sequences.
+}
+\usage{
+data(landplants.newick)
+}
+\format{
+ \code{landplants.newick} is a string with the tree in Newick format.
+}
+\source{
+ This tree is described in Sanderson (1997) and is also a
+ data example in the software package r8s
+ (\url{http://ginger.ucdavis.edu/r8s/}).
+}
+\references{
+ Sanderson, M. J. (1997) A nonparametric approach to estimating
+ divergence times in the absence of rate constancy. \emph{Molecular
+ Biology and Evolution}, \bold{14}, 1218--1231.
+}
+\examples{
+# example tree in NH format (a string)
+data("landplants.newick")
+landplants.newick
+
+# get corresponding phylo object
+tree.landplants <- read.tree(text = landplants.newick)
+
+# plot tree
+plot(tree.landplants, label.offset = 0.001)
+}
+\keyword{datasets}
+
diff --git a/man/lmorigin.Rd b/man/lmorigin.Rd
new file mode 100644
index 0000000..d21d484
--- /dev/null
+++ b/man/lmorigin.Rd
@@ -0,0 +1,83 @@
+\name{lmorigin}
+\alias{lmorigin}
+\alias{print.lmorigin}
+\alias{lmorigin.ex1}
+\alias{lmorigin.ex2}
+\title{ Multiple regression through the origin }
+\description{
+Function \code{\link{lmorigin}} computes a multiple linear regression and performs tests of significance of the equation parameters (F-test of R-square and t-tests of regression coefficients) using permutations.
+
+The regression line can be forced through the origin. Testing the significance in that case requires a special permutation procedure. This option was developed for the analysis of independent contrasts, which requires regression through the origin. A permutation test, described by Legendre & Desdevises (2009), is needed to analyze contrasts that are not normally distributed.
+}
+\usage{
+lmorigin(formula, data, origin=TRUE, nperm=999, method=NULL, silent=FALSE)
+}
+
+\arguments{
+ \item{formula }{ A formula specifying the bivariate model, as in
+ \code{\link{lm}} and \code{\link{aov}}. }
+ \item{data}{ A data frame containing the two variables specified in the formula. }
+ \item{origin}{ \code{origin = TRUE} (default) to compute regression through the origin; \code{origin = FALSE} to compute multiple regression with estimation of the intercept. }
+ \item{nperm}{ Number of permutations for the tests. If \code{nperm =
+ 0}, permutation tests will not be computed. The default value is \code{nperm = 999}. For large data files, the permutation test is rather slow since the permutation procedure is not compiled. }
+ \item{method}{ \code{method = "raw"} computes t-tests of the regression coefficients by permutation of the raw data. \code{method = "residuals"} computes t-tests of the regression coefficients by permutation of the residuals of the full model. If \code{method = NULL}, permutation of the raw data is used to test the regression coefficients in regression through the origin; permutation of the residuals of the full model is used to test the regression coefficients in ordinary multiple reg [...]
+ \item{silent}{ Informative messages and the time to compute the tests will not be written to the \R console if silent=TRUE. Useful when the function is called by a numerical simulation function. }
+}
+
+\details{
+The permutation F-test of R-square is always done by permutation of the raw data. When there is a single explanatory variable, permutation of the raw data is used for the t-test of the single regression coefficient, whatever the method chosen by the user. The rationale is found in Anderson & Legendre (1999).
+
+The \code{print.lmorigin} function prints out the results of the parametric tests (in all cases) and the results of the permutational tests (when nperm > 0).
+}
+
+\value{
+
+ \item{reg }{The regression output object produced by function \code{lm}. }
+ \item{p.param.t.2tail }{Parametric probabilities for 2-tailed tests of the regression coefficients. }
+ \item{p.param.t.1tail }{Parametric probabilities for 1-tailed tests of the regression coefficients. Each test is carried out in the direction of the sign of the coefficient. }
+ \item{p.perm.t.2tail }{Permutational probabilities for 2-tailed tests of the regression coefficients. }
+ \item{p.perm.t.1tail }{Permutational probabilities for 1-tailed tests of the regression coefficients. Each test is carried out in the direction of the sign of the coefficient. }
+ \item{p.perm.F }{Permutational probability for the F-test of R-square. }
+ \item{origin }{TRUE is regression through the origin has been computed, FALSE if multiple regression with estimation of the intercept has been used. }
+ \item{nperm }{Number of permutations used in the permutation tests. }
+ \item{method }{Permutation method for the t-tests of the regression coefficients: \code{method = "raw"} or \code{method = "residuals"}. }
+ \item{var.names }{Vector containing the names of the variables used in the regression. }
+ \item{call }{The function call.}
+}
+
+\author{ Pierre Legendre, Universite de Montreal }
+
+\references{
+Anderson, M. J. and Legendre, P. (1999) An empirical comparison of permutation methods for tests of partial regression coefficients in a linear model. \emph{Journal of Statistical Computation and Simulation}, \bold{62}, 271--303.
+
+Legendre, P. and Desdevises, Y. (2009) Independent contrasts and regression through the origin. \emph{Journal of Theoretical Biology}, \bold{259}, 727--743.
+
+Sokal, R. R. and Rohlf, F. J. (1995) \emph{Biometry - The principles and
+ practice of statistics in biological research. Third edition.} New
+ York: W. H. Freeman.
+}
+
+\examples{
+## Example 1 from Sokal & Rohlf (1995) Table 16.1
+## SO2 air pollution in 41 cities of the USA
+data(lmorigin.ex1)
+out <- lmorigin(SO2 ~ ., data=lmorigin.ex1, origin=FALSE, nperm=99)
+out
+
+## Example 2: Contrasts computed on the phylogenetic tree of Lamellodiscus
+## parasites. Response variable: non-specificity index (NSI); explanatory
+## variable: maximum host size. Data from Table 1 of Legendre & Desdevises
+## (2009).
+data(lmorigin.ex2)
+out <- lmorigin(NSI ~ MaxHostSize, data=lmorigin.ex2, origin=TRUE, nperm=99)
+out
+
+## Example 3: random numbers
+y <- rnorm(50)
+X <- as.data.frame(matrix(rnorm(250),50,5))
+out <- lmorigin(y ~ ., data=X, origin=FALSE, nperm=99)
+out
+
+}
+
+\keyword{ multivariate }
diff --git a/man/ltt.plot.Rd b/man/ltt.plot.Rd
new file mode 100644
index 0000000..546e372
--- /dev/null
+++ b/man/ltt.plot.Rd
@@ -0,0 +1,164 @@
+\name{ltt.plot}
+\alias{ltt.plot}
+\alias{ltt.lines}
+\alias{mltt.plot}
+\alias{ltt.coplot}
+\alias{ltt.plot.coords}
+\title{Lineages Through Time Plot}
+\description{
+ These functions provide tools for plotting the numbers of lineages
+ through time from phylogenetic trees.
+}
+\usage{
+ltt.plot(phy, xlab = "Time", ylab = "N",
+ backward = TRUE, tol = 1e-6, ...)
+ltt.lines(phy, backward = TRUE, tol = 1e-6, ...)
+mltt.plot(phy, ..., dcol = TRUE, dlty = FALSE, legend = TRUE,
+ xlab = "Time", ylab = "N", log = "", backward = TRUE,
+ tol = 1e-6)
+ltt.coplot(phy, backward = TRUE, ...)
+ltt.plot.coords(phy, backward = TRUE, tol = 1e-6)
+}
+\arguments{
+ \item{phy}{an object of class \code{"phylo"}; this could be an object
+ of class \code{"multiPhylo"} in the case of \code{mltt.plot}.}
+ \item{xlab}{a character string (or a variable of mode character)
+ giving the label for the \eqn{x}-axis (default is "Time").}
+ \item{ylab}{idem for the \eqn{y}-axis (default is "N").}
+ \item{backward}{a logical value: should the time axis be traced from
+ the present (the default), or from the root of the tree?}
+ \item{tol}{a numeric value (see details).}
+ \item{\dots}{in the cases of \code{ltt.plot()}, \code{ltt.lines()},
+ or \code{ltt.coplot()} these are further (graphical) arguments to be
+ passed to \code{plot()}, \code{lines()}, or \code{plot.phylo()},
+ respectively (see details on how to transform the axes); in
+ the case of \code{mltt.plot()} these are additional trees to be plotted
+ (see details).}
+ \item{dcol}{a logical specifying whether the different curves should
+ be differentiated with colors (default is \code{TRUE}).}
+ \item{dlty}{a logical specifying whether the different curves should
+ be differentiated with patterns of dots and dashes (default is
+ \code{FALSE}).}
+ \item{legend}{a logical specifying whether a legend should be
+ plotted.}
+ \item{log}{a character string specifying which axis(es) to be
+ log-transformed; must be one of the followings: \code{""},
+ \code{"x"}, \code{"y"}, or \code{"xy"}.}
+}
+\details{
+ \code{ltt.plot} does a simple lineages through time (LTT)
+ plot. Additional arguments (\code{\dots}) may be used to change, for
+ instance, the limits on the axes (with \code{xlim} and/or
+ \code{ylim}) or other graphical settings (\code{col} for the color,
+ \code{lwd} for the line thickness, \code{lty} for the line type may be
+ useful; see \code{\link[graphics]{par}} for an exhaustive listing of
+ graphical parameters). The \eqn{y}-axis can be log-transformed by
+ adding the following option: \code{log = "y"}.
+
+ The option \code{tol} is used as follows: first the most distant tip
+ from the root is found, then all tips whose distance to the root is
+ not different from the previous one more than \code{tol} are
+ considered to be contemporaneous with it.
+
+ If the tree is not ultrametric, the plot is done assuming the tips,
+ except the most distant from the root, represent extinction events. If
+ a root edge is present, it is taken into account.
+
+ \code{ltt.lines} adds a LTT curve to an existing plot. Additional
+ arguments (\code{\dots}) may be used to change the settings of the added
+ line.
+
+ \code{mltt.plot} does a multiple LTT plot taking as arguments one or
+ several trees. These trees may be given as objects of class
+ \code{"phylo"} (single trees) and/or \code{"multiPhylo"} (multiple
+ trees). Any number of objects may be given. This function is mainly
+ for exploratory analyses with the advantages that the axes are set
+ properly to view all lines, and the legend is plotted by default. The
+ plot will certainly make sense if all trees have their
+ most-distant-from-the-root tips contemporaneous (i.e., trees with only
+ extinct lineages will not be represented properly). For more flexible
+ settings of line drawings, it may be better to combine
+ \code{ltt.plot()} with successive calls of \code{ltt.lines()} (see
+ examples).
+
+ \code{ltt.coplot} is meant to show how to set a tree and a LTT plots
+ on the same scales. All extra arguments modify only the appearance of
+ the tree. The code can be easily edited and tailored.
+}
+\value{
+ \code{ltt.plot.coords} returns a two-column matrix with the time
+ points and the number of lineages, respectively. The \eqn{i}th value
+ of the second column is the number of lineages for the interval
+ defined by the \eqn{(i - 1)}th and the \eqn{i}th values of the first
+ column. These are then plotted with the option \code{type = "S"} by
+ the other functions.
+}
+\references{
+ Harvey, P. H., May, R. M. and Nee, S. (1994) Phylogenies without
+ fossils. \emph{Evolution}, \bold{48}, 523--529.
+
+ Nee, S., Holmes, E. C., Rambaut, A. and Harvey, P. H. (1995) Inferring
+ population history from molecular phylogenies. \emph{Philosophical
+ Transactions of the Royal Society of London. Series B. Biological
+ Sciences}, \bold{349}, 25--31.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{kronoviz}}, \code{\link{skyline}}, \code{\link{LTT}},
+ \code{\link{branching.times}}, \code{\link{birthdeath}},
+ \code{\link{bd.ext}}, \code{\link{yule.cov}}, \code{\link{bd.time}};
+ \code{\link[graphics]{plot}} for the basic plotting function in R
+}
+\examples{
+data(bird.families)
+opar <- par(mfrow = c(2, 1))
+ltt.plot(bird.families)
+title("Lineages Through Time Plot of the Bird Families")
+ltt.plot(bird.families, log = "y")
+title(main = "Lineages Through Time Plot of the Bird Families",
+ sub = "(with logarithmic transformation of the y-axis)")
+par(opar)
+
+### to plot the tree and the LTT plot together
+data(bird.orders)
+layout(matrix(1:4, 2, 2))
+plot(bird.families, show.tip.label = FALSE)
+ltt.plot(bird.families, main = "Bird families")
+plot(bird.orders, show.tip.label = FALSE)
+ltt.plot(bird.orders, main = "Bird orders")
+layout(1)
+
+### better with ltt.coplot():
+ltt.coplot(bird.families, show.tip.label = FALSE, x.lim = 27.5)
+data(chiroptera)
+chiroptera <- compute.brlen(chiroptera)
+ltt.coplot(chiroptera, show.tip.label = FALSE, type = "c")
+
+### with extinct lineages and a root edge:
+omar <- par("mar")
+set.seed(31)
+tr <- rlineage(0.2, 0.15)
+tr$root.edge <- 5
+ltt.coplot(tr, show.tip.label = FALSE, x.lim = 55)
+## compare with:
+## ltt.coplot(drop.fossil(tr), show.tip.label = FALSE)
+layout(1)
+par(mar = omar)
+
+mltt.plot(bird.families, bird.orders)
+### Generates 10 random trees with 23 tips:
+TR <- replicate(10, rcoal(23), FALSE)
+### Give names to each tree:
+names(TR) <- paste("random tree", 1:10)
+### And specify the class of the list so that mltt.plot()
+### does not trash it!
+class(TR) <- "multiPhylo"
+mltt.plot(TR, bird.orders)
+### And now for something (not so) completely different:
+ltt.plot(bird.orders, lwd = 2)
+for (i in 1:10) ltt.lines(TR[[i]], lty = 2)
+legend(-20, 10, lwd = c(2, 1), lty = c(1, 2), bty = "n",
+ legend = c("Bird orders", "Random (coalescent) trees"))
+}
+\keyword{hplot}
+\keyword{aplot}
diff --git a/man/makeLabel.Rd b/man/makeLabel.Rd
new file mode 100644
index 0000000..be99abd
--- /dev/null
+++ b/man/makeLabel.Rd
@@ -0,0 +1,74 @@
+\name{makeLabel}
+\alias{makeLabel}
+\alias{makeLabel.character}
+\alias{makeLabel.phylo}
+\alias{makeLabel.multiPhylo}
+\alias{makeLabel.DNAbin}
+\title{Label Management}
+\description{
+ This is a generic function with methods for character vectors, trees
+ of class \code{"phylo"}, lists of trees of class \code{"multiPhylo"},
+ and DNA sequences of class \code{"DNAbin"}. All options for the class
+ character may be used in the other methods.
+}
+\usage{
+makeLabel(x, ...)
+\method{makeLabel}{character}(x, len = 99, space = "_", make.unique = TRUE,
+ illegal = "():;,[]", quote = FALSE, ...)
+\method{makeLabel}{phylo}(x, tips = TRUE, nodes = TRUE, ...)
+\method{makeLabel}{multiPhylo}(x, tips = TRUE, nodes = TRUE, ...)
+\method{makeLabel}{DNAbin}(x, ...)
+}
+\arguments{
+ \item{x}{a vector of mode character or an object for which labels are
+ to be changed.}
+ \item{len}{the maximum length of the labels: those longer than `len'
+ will be truncated.}
+ \item{space}{the character to replace spaces, tabulations, and
+ linebreaks.}
+ \item{make.unique}{a logical specifying whether duplicate labels
+ should be made unique by appending numerals; \code{TRUE} by
+ default.}
+ \item{illegal}{a string specifying the characters to be deleted.}
+ \item{quote}{a logical specifying whether to quote the labels;
+ \code{FALSE} by default.}
+ \item{tips}{a logical specifying whether tip labels are to be
+ modified; \code{TRUE} by default.}
+ \item{nodes}{a logical specifying whether node labels are to be
+ modified; \code{TRUE} by default.}
+ \item{\dots}{further arguments to be passed to or from other methods.}
+}
+\details{
+ The option \code{make.unique} does not work exactly in the same way
+ then the function of the same name: numbers are suffixed to all labels
+ that are identical (without separator). See the examples.
+
+ If there are 10--99 identical labels, the labels returned are "xxx01",
+ "xxx02", etc, or "xxx001", "xxx002", etc, if they are 100--999, and so
+ on. The number of digits added preserves the option `len'.
+
+ The default for `len' makes labels short enough to be read by
+ PhyML. Clustal accepts labels up to 30 character long.
+}
+\note{
+ The current version does not perform well when trying to make very
+ short unique labels (e.g., less than 5 character long).
+}
+\value{
+ An object of the appropriate class.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{makeNodeLabel}}, \code{\link[base]{make.unique}},
+ \code{\link[base]{make.names}}, \code{\link[base]{abbreviate}},
+ \code{\link{mixedFontLabel}}
+}
+\examples{
+x <- rep("a", 3)
+makeLabel(x)
+make.unique(x) # <- from R's base
+x <- rep("aaaaa", 2)
+makeLabel(x, len = 3) # made unique and of length 3
+makeLabel(x, len = 3, make.unique = FALSE)
+}
+\keyword{manip}
diff --git a/man/makeNodeLabel.Rd b/man/makeNodeLabel.Rd
new file mode 100644
index 0000000..b48ea13
--- /dev/null
+++ b/man/makeNodeLabel.Rd
@@ -0,0 +1,72 @@
+\name{makeNodeLabel}
+\alias{makeNodeLabel}
+\title{Makes Node Labels}
+\description{
+ This function makes node labels in a tree in a flexible way.
+}
+
+\usage{
+makeNodeLabel(phy, method = "number", prefix = "Node", nodeList = list(), ...)
+}
+\arguments{
+ \item{phy}{an object of class \code{"phylo"}.}
+ \item{method}{a character string giving the method used to create the
+ labels. Three choices are possible: \code{"number"} (the default),
+ \code{"md5sum"}, and \code{"user"}, or any unambiguous abbreviation
+ of these.}
+ \item{prefix}{the prefix used if \code{method = "number"}.}
+ \item{nodeList}{a named list specifying how nodes are names if
+ \code{method = "user"} (see details and examples).}
+ \item{\dots}{further arguments passed to \code{grep}.}
+}
+\details{
+ The three methods are described below:
+
+ \itemize{
+ \item{``number''}{The labels are created with 1, 2, \dots prefixed
+ with the argument \code{prefix}; thus the default is to have
+ Node1, Node2, \dots Set \code{prefix = ""} to have only numbers.}
+ \item{``md5sum''}{For each node, the labels of the tips descendant
+ from this node are extracted, sorted alphabetically, and written
+ into a temporary file, then the md5sum of this file is extracted
+ and used as label. This results in a 32-character string which is
+ unique (even accross trees) for a given set of tip labels.}
+ \item{``user''}{the argument \code{nodeList} must be a list with
+ names, the latter will be used as node labels. For each element of
+ \code{nodeList}, the tip labels of the tree are searched for
+ patterns present in this element: this is done using
+ \code{\link[base]{grep}}. Then the most recent common ancestor of
+ the matching tips is given the corresponding names as labels. This
+ is repeated for each element of \code{nodeList}.}
+ }
+
+ The method \code{"user"} can be used in combination with either of the
+ two others (see examples). Note that this method only modifies the
+ specified node labels (so that if the other nodes have already labels
+ they are not modified) while the two others change all labels.
+}
+\value{
+ an object of class \code{"phylo"}.
+}
+\author{Emmanuel Paradis \email{Emmanuel.Paradis at mpl.ird.fr}}
+\seealso{
+ \code{\link{makeLabel}}, \code{\link[base]{grep}},
+ \code{\link{mixedFontLabel}}
+}
+\examples{
+tr <-
+"((Pan_paniscus,Pan_troglodytes),((Homo_sapiens,Homo_erectus),Homo_abilis));"
+tr <- read.tree(text = tr)
+tr <- makeNodeLabel(tr, "u", nodeList = list(Pan = "Pan", Homo = "Homo"))
+plot(tr, show.node.label = TRUE)
+### does not erase the previous node labels:
+tr <- makeNodeLabel(tr, "u", nodeList = list(Hominid = c("Pan","Homo")))
+plot(tr, show.node.label = TRUE)
+### the two previous commands could be combined:
+L <- list(Pan = "Pan", Homo = "Homo", Hominid = c("Pan","Homo"))
+tr <- makeNodeLabel(tr, "u", nodeList = L)
+### combining different methods:
+tr <- makeNodeLabel(tr, c("n", "u"), prefix = "#", nodeList = list(Hominid = c("Pan","Homo")))
+plot(tr, show.node.label = TRUE)
+}
+\keyword{manip}
diff --git a/man/mantel.test.Rd b/man/mantel.test.Rd
new file mode 100644
index 0000000..07dfc39
--- /dev/null
+++ b/man/mantel.test.Rd
@@ -0,0 +1,68 @@
+\name{mantel.test}
+\alias{mantel.test}
+\title{Mantel Test for Similarity of Two Matrices}
+\usage{
+mantel.test(m1, m2, nperm = 999, graph = FALSE,
+ alternative = "two.sided", ...)
+}
+\arguments{
+ \item{m1}{a numeric matrix giving a measure of pairwise distances,
+ correlations, or similarities among observations.}
+ \item{m2}{a second numeric matrix giving another measure of pairwise
+ distances, correlations, or similarities among observations.}
+ \item{nperm}{the number of times to permute the data.}
+ \item{graph}{a logical indicating whether to produce a summary graph
+ (by default the graph is not plotted).}
+ \item{alternative}{a character string defining the alternative
+ hypothesis: \code{"two.sided"} (default), \code{"less"},
+ \code{"greater"}, or any unambiguous abbreviation of these.}
+ \item{\dots}{further arguments to be passed to \code{plot()} (to add a
+ title, change the axis labels, and so on).}
+}
+\description{
+ This function computes Mantel's permutation test for similarity of two
+ matrices. It permutes the rows and columns of the two matrices
+ randomly and calculates a \eqn{Z}-statistic.
+}
+\details{
+ The function calculates a \eqn{Z}-statistic for the Mantel test, equal to
+ the sum of the pairwise product of the lower triangles of the
+ permuted matrices, for each permutation of rows and columns. It
+ compares the permuted distribution with the \eqn{Z}-statistic observed
+ for the actual data.
+
+ If \code{graph = TRUE}, the functions plots the density estimate of
+ the permutation distribution along with the observed \eqn{Z}-statistic
+ as a vertical line.
+
+ The \code{\dots} argument allows the user to give further options to
+ the \code{plot} function: the title main be changed with \code{main=},
+ the axis labels with \code{xlab =}, and \code{ylab =}, and so on.
+}
+\value{
+ \item{z.stat}{the \eqn{Z}-statistic (sum of rows*columns of lower
+ triangle) of the data matrices.}
+ \item{p}{\eqn{P}-value (quantile of the observed \eqn{Z}-statistic in
+ the permutation distribution).}
+ \item{alternative}{the alternative hypothesis.}
+}
+\references{
+ Mantel, N. (1967) The detection of disease clustering and a
+ generalized regression approach. \emph{Cancer Research}, \bold{27},
+ 209--220.
+
+ Manly, B. F. J. (1986) \emph{Multivariate statistical methods: a primer.}
+ London: Chapman & Hall.
+}
+\author{
+ Original code in S by Ben Bolker, ported to \R by Julien Claude
+}
+\examples{
+q1 <- matrix(runif(36), nrow = 6)
+q2 <- matrix(runif(36), nrow = 6)
+mantel.test(q1, q2, graph = TRUE,
+ main = "Mantel test: a random example with 6 X 6 matrices",
+ xlab = "z-statistic", ylab = "Density",
+ sub = "The vertical line shows the observed z-statistic")
+}
+\keyword{multivariate}
diff --git a/man/mat3.Rd b/man/mat3.Rd
new file mode 100644
index 0000000..791cc2b
--- /dev/null
+++ b/man/mat3.Rd
@@ -0,0 +1,23 @@
+\name{mat3}
+\alias{mat3}
+\title{Three Matrices}
+\description{
+ Three matrices respectively representing Serological (asymmetric),
+ DNA hybridization (asymmetric) and Anatomical (symmetric) distances
+ among 9 families.
+}
+\usage{
+data(mat3)
+}
+\format{
+ A data frame with 27 observations and 9 variables.
+}
+\source{
+ Lapointe, F.-J., J. A. W. Kirsch and J. M. Hutcheon. 1999. Total
+ evidence, consensus, and bat phylogeny: a distance-based
+ approach. Molecular Phylogenetics and Evolution 11: 55-66.
+}
+\seealso{
+ \code{\link{mat5Mrand}}, \code{\link{mat5M3ID}}
+}
+\keyword{datasets}
diff --git a/man/mat5M3ID.Rd b/man/mat5M3ID.Rd
new file mode 100644
index 0000000..adc38cf
--- /dev/null
+++ b/man/mat5M3ID.Rd
@@ -0,0 +1,19 @@
+\name{mat5M3ID}
+\alias{mat5M3ID}
+\title{Five Trees}
+\description{
+ Three partly similar trees, two independent trees.
+}
+\usage{
+data(mat5M3ID)
+}
+\format{
+ A data frame with 250 observations and 50 variables.
+}
+\source{
+ Data provided by V. Campbell.
+}
+\seealso{
+ \code{\link{mat5Mrand}}, \code{\link{mat3}}
+}
+\keyword{datasets}
diff --git a/man/mat5Mrand.Rd b/man/mat5Mrand.Rd
new file mode 100644
index 0000000..a567de1
--- /dev/null
+++ b/man/mat5Mrand.Rd
@@ -0,0 +1,19 @@
+\name{mat5Mrand}
+\alias{mat5Mrand}
+\title{Five Independent Trees}
+\description{
+ Five independent additive trees.
+}
+\usage{
+data(mat5Mrand)
+}
+\format{
+ A data frame with 250 observations and 50 variables.
+}
+\source{
+ Data provided by V. Campbell.
+}
+\seealso{
+ \code{\link{mat5M3ID}}, \code{\link{mat3}}
+}
+\keyword{datasets}
diff --git a/man/matexpo.Rd b/man/matexpo.Rd
new file mode 100644
index 0000000..9172a96
--- /dev/null
+++ b/man/matexpo.Rd
@@ -0,0 +1,26 @@
+\name{matexpo}
+\alias{matexpo}
+\title{Matrix Exponential}
+\usage{
+matexpo(x)
+}
+\arguments{
+ \item{x}{a square matrix of mode numeric.}
+}
+\description{
+ This function computes the exponential of a square matrix using a
+ spectral decomposition.
+}
+\value{
+ a numeric matrix of the same dimensions than `x'.
+}
+\author{Emmanuel Paradis}
+\examples{
+### a simple rate matrix:
+m <- matrix(0.1, 4, 4)
+diag(m) <- -0.3
+### towards equilibrium:
+for (t in c(1, 5, 10, 50)) print(matexpo(m*t))
+}
+\keyword{array}
+\keyword{multivariate}
diff --git a/man/mcconwaysims.test.Rd b/man/mcconwaysims.test.Rd
new file mode 100644
index 0000000..35549b2
--- /dev/null
+++ b/man/mcconwaysims.test.Rd
@@ -0,0 +1,56 @@
+\name{mcconwaysims.test}
+\alias{mcconwaysims.test}
+\title{McConway-Sims Test of Homogeneous Diversification}
+\description{
+ This function performs the McConway--Sims test that a trait or
+ variable does not affect diversification rate.
+}
+\usage{
+mcconwaysims.test(x)
+}
+\arguments{
+ \item{x}{a matrix or a data frame with at least two columns: the first
+ one gives the number of species in clades with a trait supposed to
+ increase or decrease diversification rate, and the second one the number of
+ species in the sister-clades without the trait. Each
+ row represents a pair of sister-clades.}
+}
+\details{
+ The McConway--Sims test compares a series of sister-clades where one
+ of the two is characterized by a trait supposed to affect
+ diversification rate. The null hypothesis is that the trait does not
+ affect diversification. The alternative hypothesis is that
+ diversification rate is increased or decreased by the trait (by
+ contrast to the Slowinski--Guyer test). The test is a likelihood-ratio
+ of a null Yule model and an alternative model with two parameters.
+}
+\value{
+ a data frame with the \eqn{\chi^2}{chi2}, the number of degrees of
+ freedom, and the \emph{P}-value.
+}
+\references{
+ McConway, K. J. and Sims, H. J. (2004) A likelihood-based method for
+ testing for nonstochastic variation of diversification rates in
+ phylogenies. \emph{Evolution}, \bold{58}, 12--23.
+
+ Paradis, E. (2012) Shift in diversification in sister-clade
+ comparisons: a more powerful test. \emph{Evolution}, \bold{66},
+ 288--295.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{balance}}, \code{\link{slowinskiguyer.test}},
+ \code{\link[geiger]{rc}} in \pkg{geiger},
+ \code{\link[apTreeshape]{shift.test}} in \pkg{apTreeshape}
+}
+\examples{
+### simulate 10 clades with lambda = 0.1 and mu = 0.09:
+n0 <- replicate(10, balance(rbdtree(.1, .09, Tmax = 35))[1])
+### simulate 10 clades with lambda = 0.15 and mu = 0.1:
+n1 <- replicate(10, balance(rbdtree(.15, .1, Tmax = 35))[1])
+x <- cbind(n1, n0)
+mcconwaysims.test(x)
+slowinskiguyer.test(x)
+richness.yule.test(x, 35)
+}
+\keyword{htest}
diff --git a/man/mcmc.popsize.Rd b/man/mcmc.popsize.Rd
new file mode 100644
index 0000000..b909eed
--- /dev/null
+++ b/man/mcmc.popsize.Rd
@@ -0,0 +1,116 @@
+\name{mcmc.popsize}
+\alias{mcmc.popsize}
+\alias{extract.popsize}
+\alias{plot.popsize}
+\alias{lines.popsize}
+\title{Reversible Jump MCMC to Infer Demographic History}
+\usage{
+mcmc.popsize(tree,nstep, thinning=1, burn.in=0,progress.bar=TRUE,
+ method.prior.changepoints=c("hierarchical", "fixed.lambda"), max.nodes=30,
+ lambda=0.5, gamma.shape=0.5, gamma.scale=2,
+ method.prior.heights=c("skyline", "constant", "custom"),
+ prior.height.mean,
+ prior.height.var)
+extract.popsize(mcmc.out, credible.interval=0.95, time.points=200, thinning=1, burn.in=0)
+\method{plot}{popsize}(x, show.median=TRUE, show.years=FALSE, subst.rate, present.year, ...)
+\method{lines}{popsize}(x, show.median=TRUE,show.years=FALSE, subst.rate, present.year, ...)
+
+}
+\arguments{
+ \item{tree}{Either an ultrametric tree (i.e. an object of class \code{"phylo"}),
+ or coalescent intervals (i.e. an object of class \code{"coalescentIntervals"}). }
+ \item{nstep}{Number of MCMC steps, i.e. length of the Markov chain (suggested value: 10,000-50,000).}
+ \item{thinning}{Thinning factor (suggest value: 10-100).}
+ \item{burn.in}{Number of steps dropped from the chain to allow for a burn-in phase (suggest value: 1000).}
+
+ \item{progress.bar}{Show progress bar during the MCMC run.}
+
+ \item{method.prior.changepoints}{If \code{hierarchical}is chosen (the default) then the smoothing parameter lambda is drawn from
+ a gamma distribution with some specified shape and scale parameters.
+ Alternatively, for \code{fixed.lambda} the value of lambda is a given constant.
+ }
+
+ \item{max.nodes}{Upper limit for the number of internal nodes of the approximating spline (default: 30).}
+ \item{lambda}{Smoothing parameter. For \code{method="fixed.lambda"} the specifed value of lambda determines
+ the mean of the prior distribution for the number of internal nodes of the approximating
+ spline for the demographic function (suggested value: 0.1-1.0).}
+ \item{gamma.shape}{Shape parameter of the gamma function from which \code{lambda} is drawn for
+ \code{method="hierarchical"}.}
+ \item{gamma.scale}{Scale parameter of the gamma function from which \code{lambda} is drawn for
+ \code{method="hierarchical"}.}
+ \item{method.prior.heights}{Determines the prior for the heights of the change points.
+ If \code{custom} is chosen then two functions describing the mean and variance
+ of the heigths in depence of time have to be specified (via \code{prior.height.mean}
+ and \code{prior.height.var} options). Alternatively, two built-in priors are available:
+ \code{constant} assumes constant population size and variance determined by Felsenstein
+ (1992), and \code{skyline} assumes a skyline plot (see Opgen-Rhein et al. 2004 for
+ more details).}
+ \item{prior.height.mean}{Function describing the mean of the prior distribution for the heights
+ (only used if \code{method.prior.heights = custom}).}
+
+ \item{prior.height.var}{Function describing the variance of the prior distribution for the heights
+ (only used if \code{method.prior.heights = custom}).}
+ \item{mcmc.out}{Output from \code{mcmc.popsize} - this is needed as input for \code{extract.popsize}.}
+ \item{credible.interval}{Probability mass of the confidence band (default: 0.95).}
+
+ \item{time.points}{Number of discrete time points in the table output by \code{extract.popsize}.}
+
+ \item{x}{Table with population size versus time, as computed by \code{extract.popsize}. }
+
+ \item{show.median}{Plot median rather than mean as point estimate for demographic function (default: TRUE).}
+
+ \item{show.years}{Option that determines whether the time is plotted in units of
+ of substitutions (default) or in years (requires specification of substution rate
+ and year of present).}
+\item{subst.rate}{Substitution rate (see option show.years).}
+\item{present.year}{Present year (see option show.years).}
+ \item{\dots}{Further arguments to be passed on to \code{plot}.}
+}
+\description{
+ These functions implement a reversible jump MCMC framework to infer the demographic history,
+ as well as corresponding confidence bands,
+ from a genealogical tree. The computed demographic history is a continous
+ and smooth function in time.
+ \code{mcmc.popsize} runs the actual MCMC chain and outputs information about the
+ sampling steps, \code{extract.popsize} generates from this MCMC
+ output a table of population size in time, and \code{plot.popsize} and \code{lines.popsize}
+ provide utility functions to plot the corresponding demographic functions.
+}
+
+\details{
+ Please refer to Opgen-Rhein et al. (2005) for methodological details, and the help page of
+ \code{\link{skyline}} for information on a related approach.
+}
+
+
+\author{Rainer Opgen-Rhein and
+ Korbinian Strimmer (\url{http://strimmerlab.org}).
+ Parts of the rjMCMC sampling procedure are adapted from \R code by Karl Browman
+ (\url{http://www.biostat.wisc.edu/~kbroman/})}
+
+\seealso{
+\code{\link{skyline}} and \code{\link{skylineplot}}. }
+\references{
+ Opgen-Rhein, R., Fahrmeir, L. and Strimmer, K. 2005. Inference of
+ demographic history from genealogical trees using reversible jump
+ Markov chain Monte Carlo. \emph{BMC Evolutionary Biology}, \bold{5},
+ 6.
+}
+\examples{
+# get tree
+data("hivtree.newick") # example tree in NH format
+tree.hiv <- read.tree(text = hivtree.newick) # load tree
+
+# run mcmc chain
+mcmc.out <- mcmc.popsize(tree.hiv, nstep=100, thinning=1, burn.in=0,progress.bar=FALSE) # toy run
+#mcmc.out <- mcmc.popsize(tree.hiv, nstep=10000, thinning=5, burn.in=500) # remove comments!!
+
+# make list of population size versus time
+popsize <- extract.popsize(mcmc.out)
+
+# plot and compare with skyline plot
+sk <- skyline(tree.hiv)
+plot(sk, lwd=1, lty=3, show.years=TRUE, subst.rate=0.0023, present.year = 1997)
+lines(popsize, show.years=TRUE, subst.rate=0.0023, present.year = 1997)
+}
+\keyword{manip}
diff --git a/man/mixedFontLabel.Rd b/man/mixedFontLabel.Rd
new file mode 100644
index 0000000..d4b6267
--- /dev/null
+++ b/man/mixedFontLabel.Rd
@@ -0,0 +1,64 @@
+\name{mixedFontLabel}
+\alias{mixedFontLabel}
+\title{Mixed Font Labels for Plotting}
+\description{
+ This function helps to format labels with bits of text in different
+ font shapes (italics, bold, or bolditalics) and different
+ separators. The output is intended to be used for plotting.
+}
+\usage{
+mixedFontLabel(..., sep = " ", italic = NULL, bold = NULL,
+ parenthesis = NULL,
+ always.upright = c("sp.", "spp.", "ssp."))
+}
+\arguments{
+ \item{\dots}{vectors of mode character to be formatted. They may be
+ of different lengths in which case the shortest ones are
+ recycled.}
+ \item{sep}{a vector of mode character giving the separators to be
+ printed between the elements in \code{\dots}.}
+ \item{italic}{a vector of integers specifying the elements in
+ \code{\dots} to be printed in italics.}
+ \item{bold}{id. in boldface.}
+ \item{parenthesis}{id. within parentheses.}
+ \item{always.upright}{of vector of mode character giving the strings
+ to not print in italics. Use \code{always.upright = ""} to cancel
+ this option.}
+}
+\details{
+ The idea is to have different bits of text in different vectors that
+ are put together to make a vector of \R expressions. This vector is
+ interpreted by graphical functions to format the text. A simple use
+ may be \code{mixedFontLabel(genus, species), italic = 1:2}, but it is
+ more interesting when mixing fonts (see examples).
+
+ To have an element in bolditalics, its number must given in both
+ \code{italic} and \code{bold}.
+
+ The vector returned by this function may be assigned as the
+ \code{tip.label} element of a tree of class \code{"phylo"}, or even as
+ its \code{node.label} element.
+}
+\value{
+ A vector of mode expression.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{makeLabel}}, \code{\link{makeNodeLabel}},
+ \code{taxo.fonts} in package \pkg{phyloch} for fancy alignments
+}
+\examples{
+tr <- read.tree(text = "((a,(b,c)),d);")
+genus <- c("Gorilla", "Pan", "Homo", "Pongo")
+species <- c("gorilla", "spp.", "sapiens", "pygmaeus")
+geo <- c("Africa", "Africa", "World", "Asia")
+tr$tip.label <- mixedFontLabel(genus, species, geo, italic = 1:2,
+ parenthesis = 3)
+layout(matrix(c(1, 2), 2))
+plot(tr)
+tr$tip.label <- mixedFontLabel(genus, species, geo, sep = c(" ", " | "),
+ italic = 1:2, bold = 3)
+plot(tr)
+layout(1)
+}
+\keyword{manip}
diff --git a/man/mrca.Rd b/man/mrca.Rd
new file mode 100644
index 0000000..696f055
--- /dev/null
+++ b/man/mrca.Rd
@@ -0,0 +1,36 @@
+\name{mrca}
+\alias{mrca}
+\alias{getMRCA}
+\title{Find Most Recent Common Ancestors Between Pairs}
+\description{
+ \code{mrca} returns for each pair of tips (and nodes) its most
+ recent common ancestor (MRCA).
+
+ \code{getMRCA} returns the MRCA of two or more tips.
+}
+\usage{
+mrca(phy, full = FALSE)
+getMRCA(phy, tip)
+}
+\arguments{
+ \item{phy}{an object of class \code{"phylo"}.}
+ \item{full}{a logical indicating whether to return the MRCAs among
+ all tips and nodes (if \code{TRUE}); the default is to return only
+ the MRCAs among tips.}
+ \item{tip}{a vector of mode numeric or character specifying the tips.}
+}
+\details{
+ For \code{mrca}, the diagonal is set to the number of the tips (and
+ nodes if \code{full = TRUE}). If \code{full = FALSE}, the colnames and
+ rownames are set with the tip labels of the tree; otherwise the
+ numbers are given as names.
+
+ For \code{getMRCA}, if \code{tip} is of length one or zero then
+ \code{NULL} is returned.
+}
+\value{
+ a matrix of mode numeric (\code{mrca}) or a single numeric value
+ (\code{getMRCA}).
+}
+\author{Emmanuel Paradis}
+\keyword{manip}
diff --git a/man/mst.Rd b/man/mst.Rd
new file mode 100644
index 0000000..936b2b9
--- /dev/null
+++ b/man/mst.Rd
@@ -0,0 +1,76 @@
+\name{mst}
+\alias{mst}
+\alias{plot.mst}
+\title{Minimum Spanning Tree}
+\usage{
+mst(X)
+\method{plot}{mst}(x, graph = "circle", x1 = NULL, x2 = NULL, \dots)
+}
+\arguments{
+ \item{X}{either a matrix that can be interpreted as a distance matrix,
+ or an object of class \code{"dist"}.}
+ \item{x}{an object of class \code{"mst"} (e.g. returned by \code{mst()}).}
+ \item{graph}{a character string indicating the type of graph to plot
+ the minimum spanning tree; two choices are possible: \code{"circle"} where
+ the observations are plotted regularly spaced on a circle, and
+ \code{"nsca"} where the two first axes of a non-symmetric correspondence
+ analysis are used to plot the observations (see Details below). If
+ both arguments \code{x1} and \code{x2} are given, the argument
+ \code{graph} is ignored.}
+ \item{x1}{a numeric vector giving the coordinates of the observations
+ on the \emph{x}-axis. Both \code{x1} and \code{x2} must be specified
+ to be used.}
+ \item{x2}{a numeric vector giving the coordinates of the observations
+ on the \emph{y}-axis. Both \code{x1} and \code{x2} must be specified
+ to be used.}
+ \item{\dots}{further arguments to be passed to \code{plot()}.}
+}
+\description{
+ The function \code{mst} finds the minimum spanning tree between a set of
+ observations using a matrix of pairwise distances.
+
+ The \code{plot} method plots the minimum spanning tree showing the
+ links where the observations are identified by their numbers.
+}
+\details{
+ These functions provide two ways to plot the minimum spanning tree which
+ try to space as much as possible the observations in order to show as
+ clearly as possible the links. The option \code{graph = "circle"}
+ simply plots regularly the observations on a circle, whereas
+ \code{graph = "nsca"} uses a non-symmetric correspondence analysis
+ where each observation is represented at the centroid of its neighbours.
+
+ Alternatively, the user may use any system of coordinates for the
+ obsevations, for instance a principal components analysis (PCA) if the
+ distances were computed from an original matrix of continous variables.
+}
+\value{
+ an object of class \code{"mst"} which is a square numeric matrix of size
+ equal to the number of observations with either \code{1} if a link
+ between the corresponding observations was found, or \code{0}
+ otherwise. The names of the rows and columns of the distance matrix,
+ if available, are given as rownames and colnames to the returned object.
+}
+\author{
+ Yvonnick Noel \email{noel at univ-lille3.fr},
+ Julien Claude \email{claude at isem.univ-montp2.fr} and
+ Emmanuel Paradis
+}
+\seealso{
+ \code{\link{dist.dna}}, \code{\link{dist.gene}},
+ \code{\link[stats]{dist}}, \code{\link[graphics]{plot}}
+}
+\examples{
+require(stats)
+X <- matrix(runif(200), 20, 10)
+d <- dist(X)
+PC <- prcomp(X)
+M <- mst(d)
+opar <- par()
+par(mfcol = c(2, 2))
+plot(M)
+plot(M, graph = "nsca")
+plot(M, x1 = PC$x[, 1], x2 = PC$x[, 2])
+par(opar)
+}
+\keyword{multivariate}
diff --git a/man/multi2di.Rd b/man/multi2di.Rd
new file mode 100644
index 0000000..2dd5f03
--- /dev/null
+++ b/man/multi2di.Rd
@@ -0,0 +1,47 @@
+\name{multi2di}
+\alias{multi2di}
+\alias{di2multi}
+\title{Collapse and Resolve Multichotomies}
+\description{
+ These two functions collapse or resolve multichotomies in phylogenetic
+ trees.
+}
+\usage{
+multi2di(phy, random = TRUE)
+di2multi(phy, tol = 1e-08)
+}
+\arguments{
+ \item{phy}{an object of class \code{"phylo"}.}
+ \item{random}{a logical value specifying whether to resolve the
+ multichotomies randomly (the default) or in the order they appear in
+ the tree (if \code{random = FALSE}).}
+ \item{tol}{a numeric value giving the tolerance to consider a branch
+ length significantly greater than zero.}
+}
+\details{
+ \code{multi2di} transforms all multichotomies into a series of
+ dichotomies with one (or several) branch(es) of length zero.
+
+ \code{di2multi} deletes all branches smaller than \code{tol} and
+ collapses the corresponding dichotomies into a multichotomy.
+}
+\seealso{
+\code{\link{is.binary.tree}}
+}
+\author{Emmanuel Paradis}
+\value{
+ Both functions return an object of class \code{"phylo"}.
+}
+\examples{
+data(bird.families)
+is.binary.tree(bird.families)
+is.binary.tree(multi2di(bird.families))
+all.equal(di2multi(multi2di(bird.families)), bird.families)
+### To see the results of randomly resolving a trichotomy:
+tr <- read.tree(text = "(a:1,b:1,c:1);")
+layout(matrix(1:4, 2, 2))
+for (i in 1:4)
+ plot(multi2di(tr), use.edge.length = FALSE, cex = 1.5)
+layout(matrix(1))
+}
+\keyword{manip}
diff --git a/man/multiphylo.Rd b/man/multiphylo.Rd
new file mode 100644
index 0000000..45368ad
--- /dev/null
+++ b/man/multiphylo.Rd
@@ -0,0 +1,69 @@
+\name{multiphylo}
+\alias{multiphylo}
+\alias{[.multiPhylo}
+\alias{[[.multiPhylo}
+\alias{$.multiPhylo}
+\alias{[<-.multiPhylo}
+\alias{[[<-.multiPhylo}
+\alias{$<-.multiPhylo}
+\title{Manipulating Lists of Trees}
+\description{
+ These are extraction and replacement operators for lists of trees
+ stored in the class \code{"multiPhylo"}.
+}
+\usage{
+\method{[}{multiPhylo}(x, i)
+\method{[[}{multiPhylo}(x, i)
+\method{$}{multiPhylo}(x, name)
+\method{[}{multiPhylo}(x, ...) <- value
+\method{[[}{multiPhylo}(x, ...) <- value
+\method{$}{multiPhylo}(x, ...) <- value
+}
+\arguments{
+ \item{x, value}{an object of class \code{"phylo"} or \code{"multiPhylo"}.}
+ \item{i}{index(ices) of the tree(s) to select from a list; this may be a
+ vector of integers, logicals, or names.}
+ \item{name}{a character string specifying the tree to be extracted.}
+ \item{\dots}{index(ices) of the tree(s) to replace; this may be a
+ vector of integers, logicals, or names.}
+}
+\details{
+ The subsetting operator \code{[} keeps the class correctly
+ (\code{"multiPhylo"}).
+
+The replacement operators check the labels of \code{value} if \code{x}
+has a single vector of tip labels for all trees (see examples).
+}
+\value{
+ An object of class \code{"phylo"} (\code{[[}, \code{$}) or of class
+ \code{"multiPhylo"} (\code{[} and the replacement operators).
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{summary.phylo}}, \code{\link{c.phylo}}
+}
+\examples{
+x <- rmtree(10, 20)
+names(x) <- paste("tree", 1:10, sep = "")
+x[1:5]
+x[1] # subsetting
+x[[1]] # extraction
+x$tree1 # same than above
+x[[1]] <- rtree(20)
+
+y <- .compressTipLabel(x)
+## up to here 'x' and 'y' have exactly the same information
+## but 'y' has a unique vector of tip labels for all the trees
+x[[1]] <- rtree(10) # no error
+try(y[[1]] <- rtree(10)) # error
+
+try(x[1] <- rtree(20)) # error
+## use instead one of the two:
+x[1] <- list(rtree(20))
+x[1] <- c(rtree(20))
+
+x[1:5] <- rmtree(5, 20) # replacement
+x[11:20] <- rmtree(10, 20) # elongation
+x # 20 trees
+}
+\keyword{manip}
diff --git a/man/mvr.Rd b/man/mvr.Rd
new file mode 100644
index 0000000..fbebb99
--- /dev/null
+++ b/man/mvr.Rd
@@ -0,0 +1,45 @@
+\name{mvr}
+\alias{mvr}
+\alias{mvrs}
+\title{Minimum Variance Reduction}
+\description{
+ Phylogenetic tree construction based on the minimum variance reduction.
+}
+\usage{
+mvr(X, V)
+mvrs(X, V, fs = 15)
+}
+\arguments{
+ \item{X}{a distance matrix.}
+ \item{V}{a variance matrix.}
+ \item{fs}{agglomeration criterion parameter: it is coerced as an
+ integer and must at least equal to one.}
+}
+\details{
+ The MVR method can be seen as a version of BIONJ which is not
+ restricted to the Poison model of variance (Gascuel 2000).
+}
+\value{
+ an object of class \code{"phylo"}.
+}
+\references{
+ Criscuolo, A. and Gascuel, O. (2008). Fast NJ-like algorithms to deal
+ with incomplete distance matrices. \emph{BMC Bioinformatics}, 9.
+
+ Gascuel, O. (2000). Data model and classification by trees: the
+ minimum variance reduction (MVR) method. \emph{Journal of
+ Classification}, \bold{17}, 67--99.
+}
+\author{Andrei Popescu \email{niteloserpopescu at gmail.com}}
+\seealso{
+ \code{\link{bionj}}, \code{\link{fastme}}, \code{\link{njs}},
+ \code{\link{SDM}}
+}
+\examples{
+data(woodmouse)
+rt <- dist.dna(woodmouse, variance = TRUE)
+v <- attr(rt, "variance")
+tr <- mvr(rt, v)
+plot(tr, "u")
+}
+\keyword{models}
diff --git a/man/nj.Rd b/man/nj.Rd
new file mode 100644
index 0000000..3bd7f2f
--- /dev/null
+++ b/man/nj.Rd
@@ -0,0 +1,49 @@
+\name{nj}
+\alias{nj}
+\title{Neighbor-Joining Tree Estimation}
+\description{
+ This function performs the neighbor-joining tree estimation of Saitou
+ and Nei (1987).
+}
+\usage{
+nj(X)
+}
+\arguments{
+ \item{X}{a distance matrix; may be an object of class ``dist''.}
+}
+\value{
+ an object of class \code{"phylo"}.
+}
+\references{
+ Saitou, N. and Nei, M. (1987) The neighbor-joining method: a new
+ method for reconstructing phylogenetic trees. \emph{Molecular Biology
+ and Evolution}, \bold{4}, 406--425.
+
+ Studier, J. A. and Keppler, K. J. (1988) A note on the
+ neighbor-joining algorithm of Saitou and Nei. \emph{Molecular Biology
+ and Evolution}, \bold{5}, 729--731.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{write.tree}}, \code{\link{read.tree}},
+ \code{\link{dist.dna}}, \code{\link{bionj}},
+ \code{\link{fastme}}, \code{\link{njs}}
+}
+\examples{
+### From Saitou and Nei (1987, Table 1):
+x <- c(7, 8, 11, 13, 16, 13, 17, 5, 8, 10, 13,
+ 10, 14, 5, 7, 10, 7, 11, 8, 11, 8, 12,
+ 5, 6, 10, 9, 13, 8)
+M <- matrix(0, 8, 8)
+M[lower.tri(M)] <- x
+M <- t(M)
+M[lower.tri(M)] <- x
+dimnames(M) <- list(1:8, 1:8)
+tr <- nj(M)
+plot(tr, "u")
+### a less theoretical example
+data(woodmouse)
+trw <- nj(dist.dna(woodmouse))
+plot(trw)
+}
+\keyword{models}
diff --git a/man/njs.Rd b/man/njs.Rd
new file mode 100644
index 0000000..b400e26
--- /dev/null
+++ b/man/njs.Rd
@@ -0,0 +1,45 @@
+\name{njs}
+\alias{njs}
+\alias{bionjs}
+\title{Tree Reconstruction from Incomplete Distances With NJ* or bio-NJ*}
+\description{
+ Reconstructs a phylogenetic tree from a distance matrix with possibly
+ missing values.
+}
+\usage{
+njs(X, fs = 15)
+bionjs(X, fs = 15)
+}
+\arguments{
+ \item{X}{a distance matrix.}
+ \item{fs}{argument \emph{s} of the agglomerative criterion: it is
+ coerced as an integer and must at least equal to one.}
+}
+\details{
+ Missing values represented by either \code{NA} or any negative number.
+
+ Basically, the Q* criterion is applied to all the pairs of leaves, and
+ the \emph{s} highest scoring ones are chosen for further analysis by
+ the agglomeration criteria that better handle missing distances (see
+ references for details).
+}
+\value{
+ an object of class \code{"phylo"}.
+}
+\references{
+ \url{http://www.biomedcentral.com/1471-2105/9/166}
+}
+\author{Andrei Popescu \email{niteloserpopescu at gmail.com}}
+\seealso{
+ \code{\link{nj}}, \code{\link{bionj}}, \code{\link{triangMtds}}
+}
+\examples{
+data(woodmouse)
+d <- dist.dna(woodmouse)
+dm <- d
+dm[sample(length(dm), size = 3)] <- NA
+dist.topo(njs(dm), nj(d)) # often 0
+dm[sample(length(dm), size = 10)] <- NA
+dist.topo(njs(dm), nj(d)) # sometimes 0
+}
+\keyword{models}
diff --git a/man/node.depth.Rd b/man/node.depth.Rd
new file mode 100644
index 0000000..925f9e1
--- /dev/null
+++ b/man/node.depth.Rd
@@ -0,0 +1,46 @@
+\name{node.depth}
+\alias{node.depth}
+\alias{node.depth.edgelength}
+\alias{node.height}
+\alias{node.height.clado}
+\title{Depth and Heights of Nodes and Tips}
+\description{
+ These functions return the depths or heights of nodes and tips.
+}
+\usage{
+node.depth(phy, method = 1)
+node.depth.edgelength(phy)
+node.height(phy, clado.style = FALSE)
+node.height.clado(phy)
+}
+\arguments{
+ \item{phy}{an object of class "phylo".}
+ \item{method}{an integer value (1 or 2); 1: the node depths are
+ proportional to the number of tips descending from each node, 2:
+ they are evenly spaced.}
+ \item{clado.style}{a logical value; if \code{TRUE}, the node heights
+ are calculated for a cladogram.}
+}
+\details{
+ \code{node.depth} computes the depth of a node depending on the value
+ of \code{method} (see the option \code{node.depth} in
+ \code{\link{plot.phylo}}). The value of 1 is given to the tips.
+
+ \code{node.depth.edgelength} does the same but using branch lengths.
+
+ \code{node.height} computes the heights of nodes and tips as plotted
+ by a phylogram or a cladogram.
+
+ \code{node.height.clado} does the same but for a cladogram (this
+ function will be removed soon as \code{node.height(phy, clado.style =
+ TRUE)} does the same thing).
+}
+\value{
+ A numeric vector indexed with the node numbers of the matrix `edge' of
+ \code{phy}.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{plot.phylo}}
+}
+\keyword{manip}
diff --git a/man/nodelabels.Rd b/man/nodelabels.Rd
new file mode 100644
index 0000000..5c44f3f
--- /dev/null
+++ b/man/nodelabels.Rd
@@ -0,0 +1,162 @@
+\name{nodelabels}
+\alias{nodelabels}
+\alias{tiplabels}
+\alias{edgelabels}
+\title{Labelling the Nodes, Tips, and Edges of a Tree}
+\description{
+ These functions add labels to or near the nodes, the tips, or the
+ edges of a tree using text or plotting symbols. The text can be
+ framed.
+}
+\usage{
+nodelabels(text, node, adj = c(0.5, 0.5), frame = "rect",
+ pch = NULL, thermo = NULL, pie = NULL, piecol = NULL,
+ col = "black", bg = "lightblue", horiz = FALSE,
+ width = NULL, height = NULL, ...)
+tiplabels(text, tip, adj = c(0.5, 0.5), frame = "rect",
+ pch = NULL, thermo = NULL, pie = NULL, piecol = NULL,
+ col = "black", bg = "yellow", horiz = FALSE,
+ width = NULL, height = NULL, ...)
+edgelabels(text, edge, adj = c(0.5, 0.5), frame = "rect",
+ pch = NULL, thermo = NULL, pie = NULL, piecol = NULL,
+ col = "black", bg = "lightgreen", horiz = FALSE,
+ width = NULL, height = NULL, date = NULL, ...)
+
+}
+\arguments{
+ \item{text}{a vector of mode character giving the text to be
+ printed. Can be left empty.}
+ \item{node}{a vector of mode numeric giving the numbers of the nodes
+ where the text or the symbols are to be printed. Can be left empty.}
+ \item{tip}{a vector of mode numeric giving the numbers of the tips
+ where the text or the symbols are to be printed. Can be left empty.}
+ \item{edge}{a vector of mode numeric giving the numbers of the edges
+ where the text or the symbols are to be printed. Can be left empty.}
+ \item{adj}{one or two numeric values specifying the horizontal and
+ vertical, respectively, justification of the text or symbols. By
+ default, the text is centered horizontally and vertically. If a
+ single value is given, this alters only the horizontal position of
+ the text.}
+ \item{frame}{a character string specifying the kind of frame to be
+ printed around the text. This must be one of "rect" (the default),
+ "circle", "none", or any unambiguous abbreviation of these.}
+ \item{pch}{a numeric giving the type of plotting symbol to be used;
+ this is eventually recycled. See \code{\link[graphics]{par}} for R's
+ plotting symbols. If \code{pch} is used, then \code{text} is
+ ignored.}
+ \item{thermo}{a numeric vector giving some proportions (values between
+ 0 and 1) for each node, or a numeric matrix giving some proportions
+ (the rows must sum to one).}
+ \item{pie}{same than \code{thermo}.}
+ \item{piecol}{a list of colours (given as a character vector) to be
+ used by \code{thermo} or \code{pie}; if left \code{NULL}, a series
+ of colours given by the function \code{rainbow} is used.}
+ \item{col}{a character string giving the color to be used for the
+ text or the plotting symbols; this is eventually recycled.}
+ \item{bg}{a character string giving the color to be used for the
+ background of the text frames or of the plotting symbols if it
+ applies; this is eventually recycled.}
+ \item{\dots}{further arguments passed to the \code{text} or
+ \code{points} functions (e.g. \code{cex} to alter the size of the
+ text or the symbols, or \code{font} for the text; see the examples
+ below).}
+ \item{horiz, width, height}{parameters controlling the aspect of
+ thermometers; by default, their width and height are determined
+ automatically.}
+ \item{date}{specifies the positions of labels on edges of chronograms
+ with respect to the time scale.}
+}
+\details{
+ These three functions have the same optional arguments and the same
+ functioning.
+
+ If the arguments \code{text} is missing and \code{pch} and
+ \code{thermo} are left as \code{NULL}, then the numbers of the nodes
+ (or of the tips) are printed.
+
+ If \code{node}, \code{tip}, or \code{edge} is missing, then the text
+ or the symbols are printed on all nodes, tips, or edges.
+
+ The option \code{cex} can be used to change the size of all types of
+ labels.
+
+ A simple call of these functions with no arguments (e.g.,
+ \code{nodelabels()}) prints the numbers of all nodes (or tips).
+
+ In the case of \code{tiplabels}, it would be useful to play with the
+ options \code{x.lim} and \code{label.offset} (and possibly
+ \code{show.tip.label}) of \code{plot.phylo} in most cases (see the
+ examples).
+}
+\author{Emmanuel Paradis, Ben Bolker, and Jim Lemon}
+\seealso{
+ \code{\link{plot.phylo}}, \code{\link{edges}},
+ \code{\link{mixedFontLabel}}
+}
+\examples{
+tr <- read.tree(text = "((Homo,Pan),Gorilla);")
+plot(tr)
+nodelabels("7.3 Ma", 4, frame = "r", bg = "yellow", adj = 0)
+nodelabels("5.4 Ma", 5, frame = "c", bg = "tomato", font = 3)
+
+data(bird.orders)
+plot(bird.orders, use.edge.length = FALSE, font = 1)
+bs <- round(runif(22, 90, 100), 0) # some imaginary bootstrap values
+bs2 <- round(runif(22, 90, 100), 0)
+bs3 <- round(runif(22, 90, 100), 0)
+nodelabels(bs, adj = 1.2)
+nodelabels(bs2, adj = -0.2, bg = "yellow")
+
+### something more classical
+plot(bird.orders, use.edge.length = FALSE, font = 1)
+nodelabels(bs, adj = -0.2, frame = "n", cex = 0.8)
+nodelabels(bs2, adj = c(1.2, 1), frame = "n", cex = 0.8)
+nodelabels(bs3, adj = c(1.2, -0.2), frame = "n", cex = 0.8)
+
+### the same but we play with the font
+plot(bird.orders, use.edge.length = FALSE, font = 1)
+nodelabels(bs, adj = -0.2, frame = "n", cex = 0.8, font = 2)
+nodelabels(bs2, adj = c(1.2, 1), frame = "n", cex = 0.8, font = 3)
+nodelabels(bs3, adj = c(1.2, -0.2), frame = "n", cex = 0.8)
+
+plot(bird.orders, "c", use.edge.length = FALSE, font = 1)
+nodelabels(thermo = runif(22), cex = .8)
+
+plot(bird.orders, "u", FALSE, font = 1, lab4ut = "a")
+nodelabels(cex = .75, bg = "yellow")
+
+### representing two characters at the tips (you could have as many
+### as you want)
+plot(bird.orders, "c", FALSE, font = 1, label.offset = 3,
+ x.lim = 31, no.margin = TRUE)
+tiplabels(pch = 21, bg = gray(1:23/23), cex = 2, adj = 1.4)
+tiplabels(pch = 19, col = c("yellow", "red", "blue"), adj = 2.5, cex = 2)
+### This can be used to highlight tip labels:
+plot(bird.orders, font = 1)
+i <- c(1, 7, 18)
+tiplabels(bird.orders$tip.label[i], i, adj = 0)
+### Some random data to compare piecharts and thermometres:
+tr <- rtree(15)
+x <- runif(14, 0, 0.33)
+y <- runif(14, 0, 0.33)
+z <- runif(14, 0, 0.33)
+x <- cbind(x, y, z, 1 - x - y - z)
+layout(matrix(1:2, 1, 2))
+plot(tr, "c", FALSE, no.margin = TRUE)
+nodelabels(pie = x, cex = 1.3)
+text(4.5, 15, "Are you \"pie\"...", font = 4, cex = 1.5)
+plot(tr, "c", FALSE, no.margin = TRUE)
+nodelabels(thermo = x, col = rainbow(4), cex = 1.3)
+text(4.5, 15, "... or \"thermo\"?", font = 4, cex = 1.5)
+plot(tr, "c", FALSE, no.margin = TRUE)
+nodelabels(thermo = x, col = rainbow(4), cex = 1.3)
+plot(tr, "c", FALSE, no.margin = TRUE)
+nodelabels(thermo = x, col = rainbow(4), width = 3, horiz = TRUE)
+layout(matrix(1))
+plot(tr, main = "Showing Edge Lengths")
+edgelabels(round(tr$edge.length, 3), srt = 90)
+plot(tr, "p", FALSE)
+edgelabels("above", adj = c(0.5, -0.25), bg = "yellow")
+edgelabels("below", adj = c(0.5, 1.25), bg = "lightblue")
+}
+\keyword{aplot}
diff --git a/man/opsin.Rd b/man/opsin.Rd
new file mode 100644
index 0000000..8b56c7e
--- /dev/null
+++ b/man/opsin.Rd
@@ -0,0 +1,35 @@
+\name{opsin}
+\alias{opsin}
+\alias{opsin.newick}
+\title{Gene Tree of 32 opsin Sequences}
+\description{
+ This data set describes a gene tree estimated from 32 opsin
+ sequences.
+}
+\usage{
+data(opsin.newick)
+}
+\format{
+ \code{opsin.newick} is a string with the tree in Newick format.
+}
+\source{
+ This tree is described in Misawa and Tajima (2000) as an example
+ for application of the Klastorin (1982) classification method.
+}
+\references{
+ Misawa, K. (2000) A simple method for classifying genes and a bootstrap
+ test for classifications. \emph{Molecular
+ Biology and Evolution}, \bold{17}, 1879--1884.
+}
+\examples{
+# example tree in NH format (a string)
+data("opsin.newick")
+opsin.newick
+
+# get corresponding phylo object
+tree.opsin <- read.tree(text = opsin.newick)
+
+# plot tree
+plot(tree.opsin, label.offset = 0.01)
+}
+\keyword{datasets}
diff --git a/man/parafit.Rd b/man/parafit.Rd
new file mode 100644
index 0000000..9a1c156
--- /dev/null
+++ b/man/parafit.Rd
@@ -0,0 +1,77 @@
+\name{parafit}
+\alias{parafit}
+\alias{print.parafit}
+\alias{gopher.D}
+\alias{lice.D}
+\alias{HP.links}
+\title{ Test of host-parasite coevolution }
+\description{
+Function \code{\link{parafit}} tests the hypothesis of coevolution between a clade of hosts and a clade of parasites. The null hypothesis (H0) of the global test is that the evolution of the two groups, as revealed by the two phylogenetic trees and the set of host-parasite association links, has been independent. Tests of individual host-parasite links are also available as an option.
+
+The method, which is described in detail in Legendre et al. (2002), requires some estimates of the phylogenetic trees or phylogenetic distances, and also a description of the host-parasite associations (H-P links) observed in nature.
+}
+\usage{
+parafit(host.D, para.D, HP, nperm = 999, test.links = FALSE,
+ seed = NULL, correction = "none", silent = FALSE)
+}
+
+\arguments{
+ \item{host.D }{ A matrix of phylogenetic or patristic distances among the hosts (object class: \code{matrix}, \code{data.frame} or \code{dist}). A matrix of patristic distances exactly represents the information in a phylogenetic tree. }
+ \item{para.D }{ A matrix of phylogenetic or patristic distances among the parasites (object class: \code{matrix}, \code{data.frame} or \code{dist}). A matrix of patristic distances exactly represents the information in a phylogenetic tree. }
+ \item{HP }{ A rectangular matrix with hosts as rows and parasites as columns. The matrix contains 1's when a host-parasite link has been observed in nature between the host in the row and the parasite in the column, and 0's otherwise. }
+ \item{nperm}{ Number of permutations for the tests. If \code{nperm =
+ 0}, permutation tests will not be computed. The default value is \code{nperm = 999}. For large data files, the permutation test is rather slow since the permutation procedure is not compiled. }
+ \item{test.links }{ \code{test.links = TRUE} will test the significance of individual host-parasite links. Default: \code{test.links = FALSE}. }
+ \item{seed }{ \code{seed = NULL} (default): a seed is chosen at random by the function. That seed is used as the starting point for all tests of significance, i.e. the global H-P test and the tests of individual H-P links if they are requested. Users can select a seed of their choice by giving any integer value to \code{seed}, for example \code{seed = -123456}. Running the function again with the same seed value will produce the exact same test results. }
+ \item{correction}{ Correction methods for negative eigenvalues (details below): \code{correction="lingoes"} and \code{correction="cailliez"}. Default value: \code{"none"}. }
+ \item{silent}{ Informative messages and the time to compute the tests will not be written to the \R console if silent=TRUE. Useful when the function is called by a numerical simulation function. }
+}
+
+\details{
+Two types of test are produced by the program: a global test of coevolution and, optionally, a test on the individual host-parasite (H-P) link.
+
+The function computes principal coordinates for the host and the parasite distance matrices. The principal coordinates (all of them) act as a complete representation of either the phylogenetic distance matrix or the phylogenetic tree.
+
+Phylogenetic distance matrices are normally Euclidean. Patristic distance matrices are additive, thus they are metric and Euclidean. Euclidean matrices are fully represented by real-valued principal coordinate axes. For non-Euclidean matrices, negative eigenvalues are produced; complex principal coordinate axes are associated with the negative eigenvalues. So, the program rejects matrices that are not Euclidean and stops.
+
+Negative eigenvalues can be corrected for by one of two methods: the Lingoes or the Caillez correction. It is up to the user to decide which correction method should be applied. This is done by selecting the option \code{correction="lingoes"} or \code{correction="cailliez"}. Details on these correction methods are given in the help file of the \code{pcoa} function.
+
+The principle of the global test is the following (H0: independent evolution of the hosts and parasites): (1) Compute matrix D = C t(A) B. Note: D is a fourth-corner matrix (sensu Legendre et al. 1997), where A is the H-P link matrix, B is the matrix of principal coordinates computed from the host.D matrix, and C is the matrix of principal coordinates computed from the para.D matrix. (2) Compute the statistic ParaFitGlobal, the sum of squares of all values in matrix D. (3) Permute at ran [...]
+
+The test of each individual H-P link is carried out as follows (H0: this particular link is random): (1) Remove one link (k) from matrix A. (2) Compute matrix D = C t(A) B. (3a) Compute trace(k), the sum of squares of all values in matrix D. (3b) Compute the statistic ParaFitLink1 = (trace - trace(k)) where trace is the ParaFitGlobal statistic. (3c) Compute the statistic ParaFitLink2 = (trace - trace(k)) / (tracemax - trace) where tracemax is the maximum value that can be taken by trace. [...]
+
+The \code{print.parafit} function prints out the results of the global test and, optionally, the results of the tests of the individual host-parasite links.
+}
+
+\value{
+
+ \item{ParaFitGlobal }{The statistic of the global H-P test. }
+ \item{p.global }{The permutational p-value associated with the ParaFitGlobal statistic. }
+ \item{link.table }{The results of the tests of individual H-P links, including the ParaFitLink1 and ParaFitLink2 statistics and the p-values obtained from their respective permutational tests. }
+ \item{para.per.host }{Number of parasites per host. }
+ \item{host.per.para }{Number of hosts per parasite. }
+ \item{nperm }{Number of permutations for the tests. }
+ }
+
+\author{ Pierre Legendre, Universite de Montreal }
+
+\references{
+Hafner, M. S, P. D. Sudman, F. X. Villablanca, T. A. Spradling, J. W. Demastes and S. A. Nadler. 1994. Disparate rates of molecular evolution in cospeciating hosts and parasites. \emph{Science}, \bold{265}, 1087--1090.
+
+Legendre, P., Y. Desdevises and E. Bazin. 2002. A statistical test for host-parasite coevolution. \emph{Systematic Biology}, \bold{51(2)}, 217--234.
+}
+
+\seealso{\code{\link{pcoa}} }
+
+\examples{
+## Gopher and lice data from Hafner et al. (1994)
+
+data(gopher.D)
+data(lice.D)
+data(HP.links)
+
+res <- parafit(gopher.D, lice.D, HP.links, nperm=99, test.links=TRUE)
+# res # or else: print(res)
+}
+
+\keyword{ multivariate }
diff --git a/man/pcoa.Rd b/man/pcoa.Rd
new file mode 100644
index 0000000..c5e43ea
--- /dev/null
+++ b/man/pcoa.Rd
@@ -0,0 +1,119 @@
+\name{pcoa}
+\alias{pcoa}
+\alias{biplot.pcoa}
+\title{ Principal Coordinate Analysis }
+\description{
+Function \code{\link{pcoa}} computes principal coordinate decomposition (also called classical scaling) of a distance matrix D (Gower 1966). It implements two correction methods for negative eigenvalues.
+}
+\usage{
+pcoa(D, correction="none", rn=NULL)
+
+\method{biplot}{pcoa}(x, Y=NULL, plot.axes = c(1,2), dir.axis1=1, dir.axis2=1, rn=NULL, ...)
+}
+
+\arguments{
+ \item{D}{ A distance matrix of class \code{dist} or \code{matrix}. }
+ \item{correction}{ Correction methods for negative eigenvalues (details below): \code{"lingoes"} and \code{"cailliez"}. Default value: \code{"none"}. }
+ \item{rn}{ An optional vector of row names, of length n, for the n objects. }
+ \item{x}{ Output object from \code{\link{pcoa}}. }
+ \item{Y}{ Any rectangular data table containing explanatory variables to be projected onto the ordination plot. That table may contain, for example, the community composition data used to compute D, or any transformation of these data; see examples. }
+ \item{plot.axes}{ The two PCoA axes to plot. }
+ \item{dir.axis1}{ = -1 to revert axis 1 for the projection of points and variables. Default value: +1. }
+ \item{dir.axis2}{ = -1 to revert axis 2 for the projection of points and variables. Default value: +1. }
+ \item{...}{ Other graphical arguments passed to function. }
+}
+
+\details{
+This function implements two methods for correcting for negative values in principal coordinate analysis (PCoA). Negative eigenvalues can be produced in PCoA when decomposing distance matrices produced by coefficients that are not Euclidean (Gower and Legendre 1986, Legendre and Legendre 1998).
+
+In \code{pcoa}, when negative eigenvalues are present in the decomposition results, the distance matrix D can be modified using either the Lingoes or the Cailliez procedure to produce results without negative eigenvalues.
+
+In the Lingoes (1971) procedure, a constant c1, equal to twice absolute value of the largest negative value of the original principal coordinate analysis, is added to each original squared distance in the distance matrix, except the diagonal values. A newe principal coordinate analysis, performed on the modified distances, has at most (n-2) positive eigenvalues, at least 2 null eigenvalues, and no negative eigenvalue.
+
+In the Cailliez (1983) procedure, a constant c2 is added to the original distances in the distance matrix, except the diagonal values. The calculation of c2 is described in Legendre and Legendre (1998). A new principal coordinate analysis, performed on the modified distances, has at most (n-2) positive eigenvalues, at least 2 null eigenvalues, and no negative eigenvalue.
+
+In all cases, only the eigenvectors corresponding to positive eigenvalues are shown in the output list. The eigenvectors are scaled to the square root of the corresponding eigenvalues. Gower (1966) has shown that eigenvectors scaled in that way preserve the original distance (in the D matrix) among the objects. These eigenvectors can be used to plot ordination graphs of the objects.
+
+We recommend not to use PCoA to produce ordinations from the chord, chi-square, abundance profile, or Hellinger distances. It is easier to first transform the community composition data using the following transformations, available in the \code{decostand} function of the \code{vegan} package, and then carry out a principal component analysis (PCA) on the transformed data:
+
+\describe{
+\item{ }{Chord transformation: decostand(spiders,"normalize") }
+\item{ }{Transformation to relative abundance profiles: decostand(spiders,"total") }
+\item{ }{Hellinger transformation: decostand(spiders,"hellinger") }
+\item{ }{Chi-square transformation: decostand(spiders,"chi.square") }
+}
+
+The ordination results will be identical and the calculations shorter. This two-step ordination method, called transformation-based PCA (tb-PCA), was described by Legendre and Gallagher (2001).
+
+The \code{biplot.pcoa} function produces plots for any pair of principal coordinates. The original variables can be projected onto the ordination plot.
+}
+
+\value{
+
+ \item{correction }{The values of parameter \code{correction} and variable 'correct' in the function. }
+ \item{note }{A note describing the type of correction done, if any. }
+ \item{values }{The eigenvalues and related information: }
+ \item{Eigenvalues}{All eigenvalues (positive, null, negative). }
+ \item{Relative_eig}{Relative eigenvalues. }
+ \item{Corr_eig}{Corrected eigenvalues (Lingoes correction); Legendre and Legendre (1998, p. 438, eq. 9.27). }
+ \item{Rel_corr_eig}{Relative eigenvalues after Lingoes or Cailliez correction. }
+ \item{Broken_stick}{Expected fractions of variance under the broken stick model. }
+ \item{Cumul_eig}{Cumulative relative eigenvalues. }
+ \item{Cum_corr_eig}{Cumulative corrected relative eigenvalues. }
+ \item{Cumul_br_stick}{Cumulative broken stick fractions. }
+ \item{vectors}{The principal coordinates with positive eigenvalues. }
+ \item{trace}{The trace of the distance matrix. This is also the sum of all eigenvalues, positive and negative. }
+ \item{vectors.cor }{The principal coordinates with positive eigenvalues from the distance matrix corrected using the method specified by parameter \code{correction}. }
+ \item{trace.cor }{The trace of the corrected distance matrix. This is also the sum of its eigenvalues. }
+}
+
+\references{
+Cailliez, F. (1983) The analytical solution of the additive constant problem. \emph{Psychometrika}, \bold{48}, 305--308.
+
+Gower, J. C. (1966) Some distance properties of latent root and vector methods used in multivariate analysis. \emph{Biometrika}, \bold{53}, 325--338.
+
+Gower, J. C. and Legendre, P. (1986) Metric and Euclidean properties of
+dissimilarity coefficients. \emph{Journal of Classification}, \bold{3}, 5--48.
+
+Legendre, P. and Gallagher, E. D. (2001) Ecologically meaningful transformations for ordination of species data. \emph{Oecologia}, \bold{129}, 271--280.
+
+Legendre, P. and Legendre, L. (1998) \emph{Numerical Ecology, 2nd English
+ edition.} Amsterdam: Elsevier Science BV.
+
+Lingoes, J. C. (1971) Some boundary conditions for a monotone analysis of symmetric matrices. \emph{Psychometrika}, \bold{36}, 195--203.
+}
+
+\author{ Pierre Legendre, Universite de Montreal }
+
+\examples{
+# Oribatid mite data from Borcard and Legendre (1994)
+
+\dontrun{
+if (require(vegan)) {
+data(mite) # Community composition data, 70 peat cores, 35 species
+
+# Select rows 1:30. Species 35 is absent from these rows. Transform to log
+mite.log <- log(mite[1:30,-35]+1) # Equivalent: log1p(mite[1:30,-35])
+
+# Principal coordinate analysis and simple ordination plot
+mite.D <- vegdist(mite.log, "bray")
+res <- pcoa(mite.D)
+res$values
+biplot(res)
+
+# Project unstandardized and standardized species on the PCoA ordination plot
+mite.log.st = apply(mite.log, 2, scale, center=TRUE, scale=TRUE)
+
+par(mfrow=c(1,2))
+biplot(res, mite.log)
+biplot(res, mite.log.st)
+
+# Reverse the ordination axes in the plot
+par(mfrow=c(1,2))
+biplot(res, mite.log, dir.axis1=-1, dir.axis2=-1)
+biplot(res, mite.log.st, dir.axis1=-1, dir.axis2=-1)
+}
+}
+}
+
+\keyword{ multivariate }
diff --git a/man/phydataplot.Rd b/man/phydataplot.Rd
new file mode 100644
index 0000000..10de7d4
--- /dev/null
+++ b/man/phydataplot.Rd
@@ -0,0 +1,116 @@
+\name{phydataplot}
+\alias{phydataplot}
+\alias{ring}
+\title{Tree Annotation}
+\description{
+ \code{phydataplot} plots data on a tree in a way that adapts to the
+ type of tree. \code{ring} does the same for circular trees.
+
+ Both functions match the data with the labels of the tree.
+}
+\usage{
+phydataplot(x, phy, style = "bars", offset = 1, ...)
+ring(x, phy, style = "ring", offset = 1, ...)
+}
+\arguments{
+ \item{x}{a vector, a factor, a matrix, or a data frame.}
+ \item{phy}{the tree (which must be already plotted).}
+ \item{style}{a character string specifying the type of graphics; can
+ be abbreviated (see details).}
+ \item{offset}{the space between the tips of the tree and the plot.}
+ \item{\dots}{further arguments passed to the graphical functions.}
+}
+\details{
+ The possible values for \code{style} are ``bars'', ``segments'',
+ ``image'', or ``arrows'' for \code{phydataplot}, and ``ring'',
+ ``segments'', or ``arrows'' for \code{ring}.
+}
+\note{
+ For the moment, only rightwards trees are supported (does not apply to
+ circular trees).
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{plot.phylo}}, \code{\link{nodelabels}},
+ \code{\link{fancyarrows}}
+}
+\examples{
+## demonstrates matching with names:
+tr <- rcoal(n <- 10)
+x <- 1:n
+names(x) <- tr$tip.label
+plot(tr, x.lim = 11)
+phydataplot(x, tr)
+## shuffle x but matching names with tip labels reorders them:
+phydataplot(sample(x), tr, "s", lwd = 3, lty = 3)
+
+## adapts to the tree:
+plot(tr, "f", x.l = c(-11, 11), y.l = c(-11, 11))
+phydataplot(x, tr, "s")
+
+## leave more space with x.lim to show 2 barplots:
+plot(tr, x.lim = 22)
+phydataplot(x, tr, "b")
+phydataplot(x, tr, "b", offset = 12, col = "yellow")
+
+ts <- rcoal(N <- 100)
+X <- rTraitCont(ts) # names are set
+dd <- dist(X)
+op <- par(mar = rep(0, 4))
+plot(ts, x.lim = 10, cex = 0.4, font = 1)
+phydataplot(as.matrix(dd), ts, "i", offset = 0.2)
+
+par(xpd = TRUE, mar = op$mar)
+co <- c("blue", "red"); l <- c(-2, 2)
+X <- X + abs(min(X)) # move scale so X >= 0
+plot(ts, "f", show.tip.label = FALSE, x.lim = l, y.lim = l, open.angle = 30)
+phydataplot(X, ts, "s", col = co, offset = 0.05)
+ring(X, ts, "ring", col = co, offset = max(X) + 0.1) # the same info as a ring
+
+## as many rings as you want...
+co <- c("blue", "yellow")
+plot(ts, "r", show.tip.label = FALSE, x.l = c(-1, 1), y.l = c(-1, 1))
+for (o in seq(0, 0.4, 0.2)) {
+ co <- rev(co)
+ ring(0.2, ts, "r", col = rep(co, each = 5), offset = o)
+}
+
+lim <- c(-5, 5)
+co <- rgb(0, 0.4, 1, alpha = 0.1)
+y <- seq(0.01, 1, 0.01)
+plot(ts, "f", x.lim = lim, y.lim = lim, show.tip.label = FALSE)
+ring(y, ts, offset = 0, col = co, lwd = 0.1)
+for (i in 1:3) {
+ y <- y + 1
+ ring(y, ts, offset = 0, col = co, lwd = 0.1)
+}
+
+## rings can be in the background
+plot(ts, "r", plot = FALSE)
+ring(1, ts, "r", col = rainbow(100), offset = -1)
+par(new = TRUE)
+plot(ts, "r", font = 1, edge.color = "white")
+
+## might be more useful:
+co <- c("lightblue", "yellow")
+plot(ts, "r", plot = FALSE)
+ring(0.1, ts, "r", col = sample(co, size = N, rep = TRUE), offset = -.1)
+par(new = TRUE)
+plot(ts, "r", font = 1)
+
+## if x is matrix:
+tx <- rcoal(m <- 20)
+X <- runif(m, 0, 0.5); Y <- runif(m, 0, 0.5)
+X <- cbind(X, Y, 1 - X - Y)
+rownames(X) <- tx$tip.label
+plot(tx, x.lim = 6)
+co <- rgb(diag(3))
+phydataplot(X, tx, col = co)
+## a variation:
+plot(tx, show.tip.label = FALSE, x.lim = 5)
+phydataplot(X, tx, col = co, offset = 0.05, border = NA)
+
+plot(tx, "f", show.tip.label = FALSE, open.angle = 180)
+ring(X, tx, col = co, offset = 0.05)
+}
+\keyword{aplot}
diff --git a/man/phymltest.Rd b/man/phymltest.Rd
new file mode 100644
index 0000000..9117471
--- /dev/null
+++ b/man/phymltest.Rd
@@ -0,0 +1,149 @@
+\name{phymltest}
+\alias{phymltest}
+\alias{print.phymltest}
+\alias{summary.phymltest}
+\alias{plot.phymltest}
+\title{Fits a Bunch of Models with PhyML}
+\usage{
+phymltest(seqfile, format = "interleaved", itree = NULL,
+ exclude = NULL, execname = NULL, append = TRUE)
+\method{print}{phymltest}(x, ...)
+\method{summary}{phymltest}(object, ...)
+\method{plot}{phymltest}(x, main = NULL, col = "blue", ...)
+}
+\arguments{
+ \item{seqfile}{a character string giving the name of the file that
+ contains the DNA sequences to be analysed by PhyML.}
+ \item{format}{a character string specifying the format of the DNA
+ sequences: either \code{"interleaved"} (the default), or
+ \code{"sequential"}.}
+ \item{itree}{a character string giving the name of a file with a tree
+ in Newick format to be used as an initial tree by PhyML. If
+ \code{NULL} (the default), PhyML uses a ``BIONJ'' tree.}
+ \item{exclude}{a vector of mode character giving the models to be
+ excluded from the analysis. These must be among those below, and
+ follow the same syntax.}
+ \item{execname}{a character string specifying the name of the PhyML
+ executable. This argument can be left as \code{NULL} if PhyML's
+ default names are used: \code{"phyml_3.0_linux32"},
+ \code{"phyml_3.0_macintel"}, or \code{"phyml_3.0_win32.exe"}, under
+ Linux, MacOS, or Windows respectively.}
+ \item{append}{a logical indicating whether to erase previous PhyML
+ output files if present; the default is to not erase.}
+ \item{x}{an object of class \code{"phymltest"}.}
+ \item{object}{an object of class \code{"phymltest"}.}
+ \item{main}{a title for the plot; if left \code{NULL}, a title is made
+ with the name of the object (use \code{main = ""} to have no
+ title).}
+ \item{col}{a colour used for the segments showing the AIC values (blue
+ by default).}
+ \item{\dots}{further arguments passed to or from other methods.}
+}
+\description{
+ This function calls PhyML and fits successively 28 models of DNA
+ evolution. The results are saved on disk, as PhyML usually does, and
+ returned in \R as a vector with the log-likelihood value of each model.
+}
+\details{
+ The present function requires version 3.0.1 of PhyML; it won't work with
+ older versions.
+
+ The user must take care to set correctly the three different paths
+ involved here: the path to PhyML's binary, the path to the sequence
+ file, and the path to R's working directory. The function should work
+ if all three paths are different. Obviously, there should be no problem
+ if they are all the same.
+
+ The following syntax is used for the models:
+
+ "X[Y][Z]00[+I][+G]"
+
+ where "X" is the first letter of the author of the model, "Y" and "Z"
+ are possibly other co-authors of the model, "00" is the year of the
+ publication of the model, and "+I" and "+G" indicates whether the
+ presence of invariant sites and/or a gamma distribution of
+ substitution rates have been specified. Thus, Kimura's model is
+ denoted "K80" and not "K2P". The exception to this rule is the general
+ time-reversible model which is simple denoted "GTR" model.
+
+ The seven substitution models used are: "JC69", "K80", "F81", "F84",
+ "HKY85", "TN93", and "GTR". These models are then altered by adding
+ the "+I" and/or "+G", resulting thus in four variants for each of them
+ (e.g., "JC69", "JC69+I", "JC69+G", "JC69+I+G"). Some of these models
+ are described in the help page of \code{\link{dist.dna}}.
+
+ When a gamma distribution of substitution rates is specified, four
+ categories are used (which is PhyML's default behaviour), and the
+ ``alpha'' parameter is estimated from the data.
+
+ For the models with a different substition rate for transitions and
+ transversions, these rates are left free and estimated from the data
+ (and not constrained with a ratio of 4 as in PhyML's default).
+
+ The option \code{path2exec} has been removed in the present version:
+ the path to PhyML's executable can be specified with the option
+ \code{execname}.
+}
+\note{
+ It is important to note that the models fitted by this function is
+ only a small fraction of the models possible with PhyML. For instance,
+ it is possible to vary the number of categories in the (discretized)
+ gamma distribution of substitution rates, and many parameters can be
+ fixed by the user. The results from the present function should rather
+ be taken as indicative of a best model.
+}
+\value{
+ \code{phymltest} returns an object of class \code{"phymltest"}: a
+ numeric vector with the models as names.
+
+ The \code{print} method prints an object of class \code{"phymltest"}
+ as matrix with the name of the models, the number of free parameters,
+ the log-likelihood value, and the value of the Akaike information
+ criterion (AIC = -2 * loglik + 2 * number of free parameters)
+
+ The \code{summary} method prints all the possible likelihood ratio
+ tests for an object of class \code{"phymltest"}.
+
+ The \code{plot} method plots the values of AIC of an object of class
+ \code{"phymltest"} on a vertical scale.
+}
+\references{
+ Posada, D. and Crandall, K. A. (2001) Selecting the best-fit model of
+ nucleotide substitution. \emph{Systematic Biology}, \bold{50},
+ 580--601.
+
+ Guindon, S. and Gascuel, O. (2003) A simple, fast, and accurate
+ algorithm to estimate large phylogenies by maximum likelihood.
+ \emph{Systematic Biology}, \bold{52}, 696--704.
+ \url{http://www.atgc-montpellier.fr/phyml/}
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{read.tree}}, \code{\link{write.tree}},
+ \code{\link{dist.dna}}
+}
+\examples{
+### A `fake' example with random likelihood values: it does not
+### make sense, but does not need PhyML and gives you a flavour
+### of what the output looks like:
+x <- runif(28, -100, -50)
+names(x) <- ape:::.phymltest.model
+class(x) <- "phymltest"
+x
+summary(x)
+plot(x)
+plot(x, main = "", col = "red")
+### This example needs PhyML, copy/paste or type the
+### following commands if you want to try them, eventually
+### changing setwd() and the options of phymltest()
+\dontrun{
+setwd("D:/phyml_v2.4/exe") # under Windows
+data(woodmouse)
+write.dna(woodmouse, "woodmouse.txt")
+X <- phymltest("woodmouse.txt")
+X
+summary(X)
+plot(X)
+}
+}
+\keyword{models}
diff --git a/man/pic.Rd b/man/pic.Rd
new file mode 100644
index 0000000..80a421e
--- /dev/null
+++ b/man/pic.Rd
@@ -0,0 +1,71 @@
+\name{pic}
+\alias{pic}
+\title{Phylogenetically Independent Contrasts}
+\usage{
+pic(x, phy, scaled = TRUE, var.contrasts = FALSE,
+ rescaled.tree = FALSE)
+}
+\arguments{
+ \item{x}{a numeric vector.}
+ \item{phy}{an object of class \code{"phylo"}.}
+ \item{scaled}{logical, indicates whether the contrasts should be
+ scaled with their expected variances (default to \code{TRUE}).}
+ \item{var.contrasts}{logical, indicates whether the expected
+ variances of the contrasts should be returned (default to
+ \code{FALSE}).}
+ \item{rescaled.tree}{logical, if \code{TRUE} the rescaled tree is
+ returned together with the main results.}
+}
+\description{
+ Compute the phylogenetically independent contrasts using the method
+ described by Felsenstein (1985).
+}
+\details{
+ If \code{x} has names, its values are matched to the tip labels of
+ \code{phy}, otherwise its values are taken to be in the same order
+ than the tip labels of \code{phy}.
+
+ The user must be careful here since the function requires that both
+ series of names perfectly match. If both series of names do not match,
+ the values in the \code{x} are taken to be in the same order than the
+ tip labels of \code{phy}, and a warning message is issued.
+}
+\value{
+ either a vector of phylogenetically independent contrasts (if
+ \code{var.contrasts = FALSE}), or a two-column matrix with the
+ phylogenetically independent contrasts in the first column and their
+ expected variance in the second column (if \code{var.contrasts =
+ TRUE}). If the tree has node labels, these are used as labels of the
+ returned object.
+
+ If \code{rescaled.tree = TRUE}, a list is returned with two elements
+ named ``contr'' with the above results and ``rescaled.tree'' with the
+ tree and its rescaled branch lengths (see Felsenstein 1985).
+}
+\references{
+ Felsenstein, J. (1985) Phylogenies and the comparative method.
+ \emph{American Naturalist}, \bold{125}, 1--15.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{read.tree}}, \code{\link{compar.gee}},
+ \code{\link{compar.lynch}}, \code{\link{pic.ortho}},
+ \code{\link{varCompPhylip}}
+}
+\examples{
+### The example in Phylip 3.5c (originally from Lynch 1991)
+cat("((((Homo:0.21,Pongo:0.21):0.28,",
+ "Macaca:0.49):0.13,Ateles:0.62):0.38,Galago:1.00);",
+ file = "ex.tre", sep = "\n")
+tree.primates <- read.tree("ex.tre")
+X <- c(4.09434, 3.61092, 2.37024, 2.02815, -1.46968)
+Y <- c(4.74493, 3.33220, 3.36730, 2.89037, 2.30259)
+names(X) <- names(Y) <- c("Homo", "Pongo", "Macaca", "Ateles", "Galago")
+pic.X <- pic(X, tree.primates)
+pic.Y <- pic(Y, tree.primates)
+cor.test(pic.X, pic.Y)
+lm(pic.Y ~ pic.X - 1) # both regressions
+lm(pic.X ~ pic.Y - 1) # through the origin
+unlink("ex.tre") # delete the file "ex.tre"
+}
+\keyword{regression}
diff --git a/man/pic.ortho.Rd b/man/pic.ortho.Rd
new file mode 100644
index 0000000..c55e032
--- /dev/null
+++ b/man/pic.ortho.Rd
@@ -0,0 +1,59 @@
+\name{pic.ortho}
+\alias{pic.ortho}
+\title{Phylogenetically Independent Orthonormal Contrasts}
+\description{
+ This function computes the orthonormal contrasts using the method
+ described by Felsenstein (2008). Only a single trait can be analyzed;
+ there can be several observations per species.
+}
+\usage{
+pic.ortho(x, phy, var.contrasts = FALSE, intra = FALSE)
+}
+\arguments{
+ \item{x}{a numeric vector or a list of numeric vectors.}
+ \item{phy}{an object of class \code{"phylo"}.}
+ \item{var.contrasts}{logical, indicates whether the expected
+ variances of the contrasts should be returned (default to
+ \code{FALSE}).}
+ \item{intra}{logical, whether to return the intraspecific contrasts.}
+}
+\details{
+ The data \code{x} can be in two forms: a vector if there is a single
+ observation for each species, or a list whose elements are vectors
+ containing the individual observations for each species. These vectors
+ may be of different lengths.
+
+ If \code{x} has names, its values are matched to the tip labels of
+ \code{phy}, otherwise its values are taken to be in the same order
+ than the tip labels of \code{phy}.
+}
+\value{
+ either a vector of contrasts, or a two-column matrix with the
+ contrasts in the first column and their expected variances in the
+ second column (if \code{var.contrasts = TRUE}). If the tree has node
+ labels, these are used as labels of the returned object.
+
+ If \code{intra = TRUE}, the attribute \code{"intra"}, a list of
+ vectors with the intraspecific contrasts or \code{NULL} for the
+ species with a one observation, is attached to the returned object.
+}
+\references{
+ Felsenstein, J. (2008) Comparative methods with sampling error and
+ within-species variation: Contrasts revisited and revised.
+ \emph{American Naturalist}, \bold{171}, 713--725.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{pic}}, \code{\link{varCompPhylip}}
+}
+\examples{
+tr <- rcoal(30)
+### a single observation per species:
+x <- rTraitCont(tr)
+pic.ortho(x, tr)
+pic.ortho(x, tr, TRUE)
+### different number of observations per species:
+x <- lapply(sample(1:5, 30, TRUE), rnorm)
+pic.ortho(x, tr, intra = TRUE)
+}
+\keyword{regression}
diff --git a/man/plot.correlogram.Rd b/man/plot.correlogram.Rd
new file mode 100644
index 0000000..bf38608
--- /dev/null
+++ b/man/plot.correlogram.Rd
@@ -0,0 +1,55 @@
+\name{plot.correlogram}
+\alias{plot.correlogram}
+\alias{plot.correlogramList}
+\title{Plot a Correlogram}
+\usage{
+ \method{plot}{correlogram}(x, legend = TRUE, test.level = 0.05,
+ col = c("grey", "red"), type = "b", xlab = "",
+ ylab = "Moran's I", pch = 21, cex = 2, ...)
+ \method{plot}{correlogramList}(x, lattice = TRUE, legend = TRUE,
+ test.level = 0.05, col = c("grey", "red"),
+ xlab = "", ylab = "Moran's I",
+ type = "b", pch = 21, cex = 2, ...)
+}
+\arguments{
+ \item{x}{an object of class \code{"correlogram"} or of class
+ \code{"correlogramList"} (both produced by
+ \code{\link{correlogram.formula}}).}
+ \item{legend}{should a legend be added on the plot?}
+ \item{test.level}{the level used to discriminate the plotting symbols
+ with colours considering the P-values.}
+ \item{col}{two colours for the plotting symbols: the first one is used
+ if the P-value is greater than or equal to \code{test.level}, the
+ second one otherwise.}
+ \item{type}{the type of plot to produce (see
+ \code{\link[graphics]{plot}} for possible choices).}
+ \item{xlab}{an optional character string for the label on the x-axis
+ (none by default).}
+ \item{ylab}{the default label on the y-axis.}
+ \item{pch}{the type of plotting symbol.}
+ \item{cex}{the default size for the plotting symbols.}
+ \item{lattice}{when plotting several correlograms, should they be
+ plotted in trellis-style with lattice (the default), or together on
+ the same plot?}
+ \item{\dots}{other parameters passed to the \code{plot} or \code{lines}
+ function.}
+}
+\description{
+ These functions plot correlagrams previously computed with
+ \code{\link{correlogram.formula}}.
+}
+\details{
+ When plotting several correlograms with lattice, some options have no
+ effect: \code{legend}, \code{type}, and \code{pch} (\code{pch=19} is
+ always used in this situation).
+
+ When using \code{pch} between 1 and 20 (i.e., non-filled symbols, the
+ colours specified in \code{col} are also used for the lines joining
+ the points. To keep black lines, it is better to leave \code{pch}
+ between 21 and 25.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{correlogram.formula}}, \code{\link{Moran.I}}
+}
+\keyword{hplot}
diff --git a/man/plot.phylo.Rd b/man/plot.phylo.Rd
new file mode 100644
index 0000000..3c3a0da
--- /dev/null
+++ b/man/plot.phylo.Rd
@@ -0,0 +1,249 @@
+\name{plot.phylo}
+\alias{plot.phylo}
+\alias{plot.multiPhylo}
+\title{Plot Phylogenies}
+\description{
+ These functions plot phylogenetic trees on the current graphical
+ device.
+}
+\usage{
+\method{plot}{phylo}(x, type = "phylogram", use.edge.length = TRUE,
+ node.pos = NULL, show.tip.label = TRUE, show.node.label = FALSE,
+ edge.color = "black", edge.width = 1, edge.lty = 1, font = 3,
+ cex = par("cex"), adj = NULL, srt = 0, no.margin = FALSE,
+ root.edge = FALSE, label.offset = 0, underscore = FALSE,
+ x.lim = NULL, y.lim = NULL, direction = "rightwards",
+ lab4ut = "horizontal", tip.color = "black", plot = TRUE,
+ rotate.tree = 0, open.angle = 0, node.depth = 1, ...)
+\method{plot}{multiPhylo}(x, layout = 1, ...)
+}
+\arguments{
+ \item{x}{an object of class \code{"phylo"} or of class
+ \code{"multiPhylo"}.}
+ \item{type}{a character string specifying the type of phylogeny to be
+ drawn; it must be one of "phylogram" (the default), "cladogram",
+ "fan", "unrooted", "radial" or any unambiguous abbreviation of
+ these.}
+ \item{use.edge.length}{a logical indicating whether to use the edge
+ lengths of the phylogeny to draw the branches (the default) or not
+ (if \code{FALSE}). This option has no effect if the object of class
+ \code{"phylo"} has no `edge.length' element.}
+ \item{node.pos}{a numeric taking the value 1 or 2 which specifies the
+ vertical position of the nodes with respect to their descendants. If
+ \code{NULL} (the default), then the value is determined in relation
+ to `type' and `use.edge.length' (see details).}
+ \item{show.tip.label}{a logical indicating whether to show the tip
+ labels on the phylogeny (defaults to \code{TRUE}, i.e. the labels
+ are shown).}
+ \item{show.node.label}{a logical indicating whether to show the node
+ labels on the phylogeny (defaults to \code{FALSE}, i.e. the labels
+ are not shown).}
+ \item{edge.color}{a vector of mode character giving the colours used
+ to draw the branches of the plotted phylogeny. These are taken to be
+ in the same order than the component \code{edge} of \code{phy}. If
+ fewer colours are given than the length of \code{edge}, then the
+ colours are recycled.}
+ \item{edge.width}{a numeric vector giving the width of the branches of
+ the plotted phylogeny. These are taken to be in the same order than
+ the component \code{edge} of \code{phy}. If fewer widths are given
+ than the length of \code{edge}, then these are recycled.}
+ \item{edge.lty}{same than the previous argument but for line types;
+ 1: plain, 2: dashed, 3: dotted, 4: dotdash, 5: longdash, 6: twodash.}
+ \item{font}{an integer specifying the type of font for the labels: 1
+ (plain text), 2 (bold), 3 (italic, the default), or 4 (bold
+ italic).}
+ \item{cex}{a numeric value giving the factor scaling of the tip and
+ node labels (Character EXpansion). The default is to take the
+ current value from the graphical parameters.}
+ \item{adj}{a numeric specifying the justification of the text strings
+ of the labels: 0 (left-justification), 0.5 (centering), or 1
+ (right-justification). This option has no effect if \code{type =
+ "unrooted"}. If \code{NULL} (the default) the value is set with
+ respect of \code{direction} (see details).}
+ \item{srt}{a numeric giving how much the labels are rotated in degrees
+ (negative values are allowed resulting in clock-like rotation); the
+ value has an effect respectively to the value of
+ \code{direction} (see Examples). This option has no effect if
+ \code{type = "unrooted"}.}
+ \item{no.margin}{a logical. If \code{TRUE}, the margins are set to
+ zero and the plot uses all the space of the device (note that this
+ was the behaviour of \code{plot.phylo} up to version 0.2-1 of `ape'
+ with no way to modify it by the user, at least easily).}
+ \item{root.edge}{a logical indicating whether to draw the root edge
+ (defaults to FALSE); this has no effect if `use.edge.length = FALSE'
+ or if `type = "unrooted"'.}
+ \item{label.offset}{a numeric giving the space between the nodes and
+ the tips of the phylogeny and their corresponding labels. This
+ option has no effect if \code{type = "unrooted"}.}
+ \item{underscore}{a logical specifying whether the underscores in tip
+ labels should be written as spaces (the default) or left as are (if
+ \code{TRUE}).}
+ \item{x.lim}{a numeric vector of length one or two giving the limit(s)
+ of the x-axis. If \code{NULL}, this is computed with respect to
+ various parameters such as the string lengths of the labels and the
+ branch lengths. If a single value is given, this is taken as the
+ upper limit.}
+ \item{y.lim}{same than above for the y-axis.}
+ \item{direction}{a character string specifying the direction of the
+ tree. Four values are possible: "rightwards" (the default),
+ "leftwards", "upwards", and "downwards".}
+ \item{lab4ut}{(= labels for unrooted trees) a character string
+ specifying the display of tip labels for unrooted trees: either
+ \code{"horizontal"} where all labels are horizontal (the default),
+ or \code{"axial"} where the labels are displayed in the axis of the
+ corresponding terminal branches. This option has an effect only if
+ \code{type = "unrooted"}.}
+ \item{tip.color}{the colours used for the tip labels, eventually
+ recycled (see examples).}
+ \item{plot}{a logical controlling whether to draw the tree. If
+ \code{FALSE}, the graphical device is set as if the tree was
+ plotted, and the coordinates are saved as well.}
+ \item{rotate.tree}{for "fan", "unrooted", or "radial" trees: the
+ rotation of the whole tree in degrees (negative values are
+ accepted).}
+ \item{open.angle}{if \code{type = "f"}, the angle in degrees left
+ blank. Use a non-zero value if you want to call
+ \code{\link{axisPhylo}} after the tree is plotted.}
+ \item{node.depth}{an integer value (1 or 2) used if branch lengths are
+ not used to plot the tree; 1: the node depths are proportional to
+ the number of tips descending from each node (the default and was the
+ only possibility previously), 2: they are evenly spaced.}
+ \item{layout}{the number of trees to be plotted simultaneously.}
+ \item{\dots}{further arguments to be passed to \code{plot} or to
+ \code{plot.phylo}.}
+}
+\details{
+ If \code{x} is a list of trees (i.e., an object of class
+ \code{"multiPhylo"}), then any further argument may be passed with
+ \code{...} and could be any one of those listed above for a single
+ tree.
+
+ The font format of the labels of the nodes and the tips is the same.
+
+ If \code{no.margin = TRUE}, the margins are set to zero and are not
+ restored after plotting the tree, so that the user can access the
+ coordinates system of the plot.
+
+ The option `node.pos' allows the user to alter the vertical position
+ (i.e., ordinates) of the nodes. If \code{node.pos = 1}, then the
+ ordinate of a node is the mean of the ordinates of its direct
+ descendants (nodes and/or tips). If \code{node.pos = 2}, then the
+ ordinate of a node is the mean of the ordinates of all the tips of
+ which it is the ancestor. If \code{node.pos = NULL} (the default),
+ then its value is determined with respect to other options: if
+ \code{type = "phylogram"} then `node.pos = 1'; if \code{type =
+ "cladogram"} and \code{use.edge.length = FALSE} then `node.pos = 2';
+ if \code{type = "cladogram"} and \code{use.edge.length = TRUE} then
+ `node.pos = 1'. Remember that in this last situation, the branch
+ lengths make sense when projected on the x-axis.
+
+ If \code{adj} is not specified, then the value is determined with
+ respect to \code{direction}: if \code{direction = "leftwards"} then
+ \code{adj = 1} (0 otherwise).
+
+ If the arguments \code{x.lim} and \code{y.lim} are not specified by the
+ user, they are determined roughly by the function. This may not always
+ give a nice result: the user may check these values with the
+ (invisibly) returned list (see ``Value:'').
+
+ If you resize manually the graphical device (windows or X11) you may
+ need to replot the tree.
+}
+\note{
+ The argument \code{asp} cannot be passed with \code{\dots}.
+}
+\value{
+ \code{plot.phylo} returns invisibly a list with the following
+ components which values are those used for the current plot:
+
+ \item{type}{}
+ \item{use.edge.length}{}
+ \item{node.pos}{}
+ \item{node.depth}{}
+ \item{show.tip.label}{}
+ \item{show.node.label}{}
+ \item{font}{}
+ \item{cex}{}
+ \item{adj}{}
+ \item{srt}{}
+ \item{no.margin}{}
+ \item{label.offset}{}
+ \item{x.lim}{}
+ \item{y.lim}{}
+ \item{direction}{}
+ \item{tip.color}{}
+ \item{Ntip}{}
+ \item{Nnode}{}
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{read.tree}}, \code{\link{trex}}, \code{\link{kronoviz}},
+ \code{\link{add.scale.bar}}, \code{\link{axisPhylo}},
+ \code{\link{nodelabels}}, \code{\link{edges}},
+ \code{\link[graphics]{plot}} for the basic plotting function in R
+}
+\examples{
+### An extract from Sibley and Ahlquist (1990)
+cat("(((Strix_aluco:4.2,Asio_otus:4.2):3.1,",
+ "Athene_noctua:7.3):6.3,Tyto_alba:13.5);",
+ file = "ex.tre", sep = "\n")
+tree.owls <- read.tree("ex.tre")
+plot(tree.owls)
+unlink("ex.tre") # delete the file "ex.tre"
+
+### Show the types of trees.
+layout(matrix(1:6, 3, 2))
+plot(tree.owls, main = "With branch lengths")
+plot(tree.owls, type = "c")
+plot(tree.owls, type = "u")
+plot(tree.owls, use.edge.length = FALSE, main = "Without branch lengths")
+plot(tree.owls, type = "c", use.edge.length = FALSE)
+plot(tree.owls, type = "u", use.edge.length = FALSE)
+layout(matrix(1))
+
+data(bird.orders)
+### using random colours and thickness
+plot(bird.orders,
+ edge.color = sample(colors(), length(bird.orders$edge)/2),
+ edge.width = sample(1:10, length(bird.orders$edge)/2, replace = TRUE))
+title("Random colours and branch thickness")
+### rainbow colouring...
+X <- c("red", "orange", "yellow", "green", "blue", "purple")
+plot(bird.orders,
+ edge.color = sample(X, length(bird.orders$edge)/2, replace = TRUE),
+ edge.width = sample(1:10, length(bird.orders$edge)/2, replace = TRUE))
+title("Rainbow colouring")
+plot(bird.orders, type = "c", use.edge.length = FALSE,
+ edge.color = sample(X, length(bird.orders$edge)/2, replace = TRUE),
+ edge.width = rep(5, length(bird.orders$edge)/2))
+segments(rep(0, 6), 6.5:1.5, rep(2, 6), 6.5:1.5, lwd = 5, col = X)
+text(rep(2.5, 6), 6.5:1.5, paste(X, "..."), adj = 0)
+title("Character mapping...")
+plot(bird.orders, "u", font = 1, cex = 0.75)
+data(bird.families)
+plot(bird.families, "u", lab4ut = "axial", font = 1, cex = 0.5)
+plot(bird.families, "r", font = 1, cex = 0.5)
+### cladogram with oblique tip labels
+plot(bird.orders, "c", FALSE, direction = "u", srt = -40, x.lim = 25.5)
+### facing trees with different informations...
+tr <- bird.orders
+tr$tip.label <- rep("", 23)
+layout(matrix(1:2, 1, 2), c(5, 4))
+plot(bird.orders, "c", FALSE, adj = 0.5, no.margin = TRUE, label.offset = 0.8,
+ edge.color = sample(X, length(bird.orders$edge)/2, replace = TRUE),
+ edge.width = rep(5, length(bird.orders$edge)/2))
+text(7.5, 23, "Facing trees with\ndifferent informations", font = 2)
+plot(tr, "p", direction = "l", no.margin = TRUE,
+ edge.width = sample(1:10, length(bird.orders$edge)/2, replace = TRUE))
+### Recycling of arguments gives a lot of possibilities
+### for tip labels:
+plot(bird.orders, tip.col = c(rep("red", 5), rep("blue", 18)),
+ font = c(rep(3, 5), rep(2, 17), 1))
+plot(bird.orders, tip.col = c("blue", "green"),
+ cex = 23:1/23 + .3, font = 1:3)
+co <- c(rep("blue", 9), rep("green", 35))
+plot(bird.orders, "f", edge.col = co)
+plot(bird.orders, edge.col = co)
+layout(1)
+}
+\keyword{hplot}
diff --git a/man/plot.varcomp.Rd b/man/plot.varcomp.Rd
new file mode 100644
index 0000000..d096295
--- /dev/null
+++ b/man/plot.varcomp.Rd
@@ -0,0 +1,22 @@
+\name{plot.varcomp}
+\alias{plot.varcomp}
+\title{Plot Variance Components}
+\description{
+ Plot previously estimated variance components.
+}
+\usage{
+\method{plot}{varcomp}(x, xlab = "Levels", ylab = "Variance", type = "b", ...)
+}
+\arguments{
+ \item{x}{ A \var{varcomp} object}
+ \item{xlab}{ x axis label}
+ \item{ylab}{ y axis label }
+ \item{type}{ plot type ("l", "p" or "b", see \code{\link{plot}})}
+ \item{\dots}{Further argument sent to the \code{\link[lattice]{xyplot}} function.}
+}
+\value{
+ The same as \code{\link[lattice]{xyplot}}.
+}
+\author{Julien Dutheil \email{julien.dutheil at univ-montp2.fr}}
+\seealso{\code{\link{varcomp}}}
+\keyword{hplot}
diff --git a/man/print.phylo.Rd b/man/print.phylo.Rd
new file mode 100644
index 0000000..f1ad306
--- /dev/null
+++ b/man/print.phylo.Rd
@@ -0,0 +1,40 @@
+\name{print.phylo}
+\alias{print.phylo}
+\alias{print.multiPhylo}
+\alias{str.multiPhylo}
+\title{Compact Display of a Phylogeny}
+\usage{
+\method{print}{phylo}(x, printlen = 6 ,...)
+\method{print}{multiPhylo}(x, details = FALSE ,...)
+\method{str}{multiPhylo}(object, ...)
+}
+\arguments{
+ \item{x}{an object of class \code{"phylo"} or \code{"multiPhylo"}.}
+ \item{object}{an object of class \code{"multiPhylo"}.}
+ \item{printlen}{the number of labels to print (6 by default).}
+ \item{details}{a logical indicating whether to print information on
+ all trees.}
+ \item{\dots}{further arguments passed to or from other methods.}
+}
+\description{
+ These functions prints a compact summary of a phylogeny, or a list of
+ phylogenies, on the console.
+}
+\value{
+ NULL.
+}
+\author{Ben Bolker and Emmanuel Paradis}
+\seealso{
+ \code{\link{read.tree}}, \code{\link{summary.phylo}},
+ \code{\link[base]{print}} for the generic \R function
+}
+\examples{
+x <- rtree(10)
+print(x)
+print(x, printlen = 10)
+x <- rmtree(2, 10)
+print(x)
+print(x, TRUE)
+str(x)
+}
+\keyword{manip}
diff --git a/man/rTraitCont.Rd b/man/rTraitCont.Rd
new file mode 100644
index 0000000..2251c85
--- /dev/null
+++ b/man/rTraitCont.Rd
@@ -0,0 +1,100 @@
+\name{rTraitCont}
+\alias{rTraitCont}
+\title{Continuous Character Simulation}
+\usage{
+rTraitCont(phy, model = "BM", sigma = 0.1, alpha = 1, theta = 0,
+ ancestor = FALSE, root.value = 0, ...)
+}
+\arguments{
+ \item{phy}{an object of class \code{"phylo"}.}
+ \item{model}{a character (either \code{"BM"} or \code{"OU"}) or a
+ function specifying the model (see details).}
+ \item{sigma}{a numeric vector giving the standard-deviation of the
+ random component for each branch (can be a single value).}
+ \item{alpha}{if \code{model = "OU"}, a numeric vector giving the
+ strength of the selective constraint for each branch (can be a
+ single value).}
+ \item{theta}{if \code{model = "OU"}, a numeric vector giving the
+ optimum for each branch (can be a single value).}
+ \item{ancestor}{a logical value specifying whether to return the
+ values at the nodes as well (by default, only the values at the tips
+ are returned).}
+ \item{root.value}{a numeric giving the value at the root.}
+ \item{\dots}{further arguments passed to \code{model} if it is a
+ function.}
+}
+\description{
+ This function simulates the evolution of a continuous character along a
+ phylogeny. The calculation is done recursively from the root. See
+ Paradis (2012, pp. 232 and 324) for an introduction.
+}
+\details{
+ There are three possibilities to specify \code{model}:
+
+\itemize{
+ \item{\code{"BM"}:}{a Browian motion model is used. If the arguments
+ \code{sigma} has more than one value, its length must be equal to the
+ the branches of the tree. This allows to specify a model with variable
+ rates of evolution. You must be careful that branch numbering is done
+ with the tree in ``pruningwise'' order: to see the order of the branches
+ you can use: \code{tr <- reorder(tr, "p"); plor(tr); edgelabels()}.
+ The arguments \code{alpha} and \code{theta} are ignored.}
+
+ \item{\code{"OU"}:}{an Ornstein-Uhlenbeck model is used. The above
+ indexing rule is used for the three parameters \code{sigma},
+ \code{alpha}, and \code{theta}. This may be interesting for the last
+ one to model varying phenotypic optima. The exact updating formula
+ from Gillespie (1996) are used which are reduced to BM formula if
+ \code{alpha = 0}.}
+
+ \item{A function:}{it must be of the form \code{foo(x, l)} where
+ \code{x} is the trait of the ancestor and \code{l} is the branch
+ length. It must return the value of the descendant. The arguments
+ \code{sigma}, \code{alpha}, and \code{theta} are ignored.}
+}}
+\value{
+ A numeric vector with names taken from the tip labels of
+ \code{phy}. If \code{ancestor = TRUE}, the node labels are used if
+ present, otherwise, ``Node1'', ``Node2'', etc.
+}
+\references{
+ Gillespie, D. T. (1996) Exact numerical simulation of the
+ Ornstein-Uhlenbeck process and its integral. \emph{Physical Review E},
+ \bold{54}, 2084--2091.
+
+ Paradis, E. (2012) \emph{Analysis of Phylogenetics and Evolution with
+ R (Second Edition).} New York: Springer.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{rTraitDisc}}, \code{\link{rTraitMult}}, \code{\link{ace}}
+}
+\examples{
+data(bird.orders)
+rTraitCont(bird.orders) # BM with sigma = 0.1
+### OU model with two optima:
+tr <- reorder(bird.orders, "postorder")
+plot(tr)
+edgelabels()
+theta <- rep(0, Nedge(tr))
+theta[c(1:4, 15:16, 23:24)] <- 2
+## sensitive to 'alpha' and 'sigma':
+rTraitCont(tr, "OU", theta = theta, alpha=.1, sigma=.01)
+### an imaginary model with stasis 0.5 time unit after a node, then
+### BM evolution with sigma = 0.1:
+foo <- function(x, l) {
+ if (l <= 0.5) return(x)
+ x + (l - 0.5)*rnorm(1, 0, 0.1)
+}
+tr <- rcoal(20, br = runif)
+rTraitCont(tr, foo, ancestor = TRUE)
+### a cumulative Poisson process:
+bar <- function(x, l) x + rpois(1, l)
+(x <- rTraitCont(tr, bar, ancestor = TRUE))
+plot(tr, show.tip.label = FALSE)
+Y <- x[1:20]
+A <- x[-(1:20)]
+nodelabels(A)
+tiplabels(Y)
+}
+\keyword{datagen}
diff --git a/man/rTraitDisc.Rd b/man/rTraitDisc.Rd
new file mode 100644
index 0000000..a800c46
--- /dev/null
+++ b/man/rTraitDisc.Rd
@@ -0,0 +1,102 @@
+\name{rTraitDisc}
+\alias{rTraitDisc}
+\title{Discrete Character Simulation}
+\usage{
+rTraitDisc(phy, model = "ER", k = if (is.matrix(model)) ncol(model) else 2,
+ rate = 0.1, states = LETTERS[1:k], freq = rep(1/k, k),
+ ancestor = FALSE, root.value = 1, ...)
+}
+\arguments{
+ \item{phy}{an object of class \code{"phylo"}.}
+ \item{model}{a character, a square numeric matrix, or a function
+ specifying the model (see details).}
+ \item{k}{the number of states of the character.}
+ \item{rate}{the rate of change used if \code{model} is a character; it
+ is \emph{not} recycled if \code{model = "ARD"} of \code{model =
+ "SYM"}.}
+ \item{states}{the labels used for the states; by default ``A'', ``B'',
+ \dots}
+ \item{freq}{a numeric vector giving the equilibrium relative
+ frequencies of each state; by default the frequencies are equal.}
+ \item{ancestor}{a logical value specifying whether to return the
+ values at the nodes as well (by default, only the values at the tips
+ are returned).}
+ \item{root.value}{an integer giving the value at the root (by default,
+ it's the first state). To have a random value, use \code{root.value
+ = sample(k)}.}
+ \item{\dots}{further arguments passed to \code{model} if it is a
+ function.}
+}
+\description{
+ This function simulates the evolution of a discrete character along a
+ phylogeny. If \code{model} is a character or a matrix, evolution is
+ simulated with a Markovian model; the transition probabilities are
+ calculated for each branch with \eqn{P = e^{Qt}} where \eqn{Q} is the
+ rate matrix given by \code{model} and \eqn{t} is the branch length.
+ The calculation is done recursively from the root. See Paradis (2006,
+ p. 101) for a general introduction applied to evolution.
+}
+\details{
+ There are three possibilities to specify \code{model}:
+
+\itemize{
+ \item{A matrix:}{it must be a numeric square matrix; the diagonal is
+ always ignored. The arguments \code{k} and \code{rate} are ignored.}
+
+ \item{A character:}{these are the same short-cuts than in the function
+ \code{\link{ace}}: \code{"ER"} is an equal-rates model, \code{"ARD"}
+ is an all-rates-different model, and \code{"SYM"} is a symmetrical
+ model. Note that the argument \code{rate} must be of the appropriate
+ length, i.e., 1, \eqn{k(k - 1)}, or \eqn{k(k - 1)/2} for the three models,
+ respectively. The rate matrix \eqn{Q} is then filled column-wise.}
+
+ \item{A function:}{it must be of the form \code{foo(x, l)} where
+ \code{x} is the trait of the ancestor and \code{l} is the branch
+ length. It must return the value of the descendant as an integer.}
+}}
+\value{
+ A factor with names taken from the tip labels of \code{phy}. If
+ \code{ancestor = TRUE}, the node labels are used if present,
+ otherwise, ``Node1'', ``Node2'', etc.
+}
+\references{
+ Paradis, E. (2006) \emph{Analyses of Phylogenetics and Evolution with
+ R.} New York: Springer.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{rTraitCont}}, \code{\link{rTraitMult}}, \code{\link{ace}}
+}
+\examples{
+data(bird.orders)
+### the two followings are the same:
+rTraitDisc(bird.orders)
+rTraitDisc(bird.orders, model = matrix(c(0, 0.1, 0.1, 0), 2))
+
+### two-state model with irreversibility:
+rTraitDisc(bird.orders, model = matrix(c(0, 0, 0.1, 0), 2))
+
+### simple two-state model:
+tr <- rcoal(n <- 40, br = runif)
+x <- rTraitDisc(tr, ancestor = TRUE)
+plot(tr, show.tip.label = FALSE)
+nodelabels(pch = 19, col = x[-(1:n)])
+tiplabels(pch = 19, col = x[1:n])
+
+### an imaginary model with stasis 0.5 time unit after a node, then
+### random evolution:
+foo <- function(x, l) {
+ if (l < 0.5) return(x)
+ sample(2, size = 1)
+}
+tr <- rcoal(20, br = runif)
+x <- rTraitDisc(tr, foo, ancestor = TRUE)
+plot(tr, show.tip.label = FALSE)
+co <- c("blue", "yellow")
+cot <- c("white", "black")
+Y <- x[1:20]
+A <- x[-(1:20)]
+nodelabels(A, bg = co[A], col = cot[A])
+tiplabels(Y, bg = co[Y], col = cot[Y])
+}
+\keyword{datagen}
diff --git a/man/rTraitMult.Rd b/man/rTraitMult.Rd
new file mode 100644
index 0000000..57f8993
--- /dev/null
+++ b/man/rTraitMult.Rd
@@ -0,0 +1,60 @@
+\name{rTraitMult}
+\alias{rTraitMult}
+\title{Multivariate Character Simulation}
+\description{
+ This function simulates the evolution of a multivariate set of traits
+ along a phylogeny. The calculation is done recursively from the
+ root.
+}
+\usage{
+rTraitMult(phy, model, p = 1, root.value = rep(0, p), ancestor = FALSE,
+ asFactor = NULL, trait.labels = paste("x", 1:p, sep = ""), ...)
+}
+\arguments{
+ \item{phy}{an object of class \code{"phylo"}.}
+ \item{model}{a function specifying the model (see details).}
+ \item{p}{an integer giving the number of traits.}
+ \item{root.value}{a numeric vector giving the values at the root.}
+ \item{ancestor}{a logical value specifying whether to return the
+ values at the nodes as well (by default, only the values at the tips
+ are returned).}
+ \item{asFactor}{the indices of the traits that are returned as factors
+ (discrete traits).}
+ \item{trait.labels}{a vector of mode character giving the names of the
+ traits.}
+ \item{\dots}{further arguments passed to \code{model} if it is a
+ function.}
+}
+\details{
+ The model is specified with an \R function of the form \code{foo(x,
+ l)} where \code{x} is a vector of the traits of the ancestor and
+ \code{l} is the branch length. Other arguments may be added. The
+ function must return a vector of length \code{p}.
+}
+\value{
+ A data frame with \code{p} columns whose names are given by
+ \code{trait.labels} and row names taken from the labels of the tree.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{rTraitCont}}, \code{\link{rTraitDisc}}, \code{\link{ace}}
+}
+\examples{
+## correlated evolution of 2 continuous traits:
+mod <- function(x, l) {
+ y1 <- rnorm(1, x[1] + 0.5*x[2], 0.1)
+ y2 <- rnorm(1, 0.5*x[1] + x[2], 0.1)
+ c(y1, y2)
+}
+set.seed(11)
+tr <- makeNodeLabel(rcoal(20))
+x <- rTraitMult(tr, mod, 2, ancestor = TRUE)
+op <- par(mfcol = c(2, 1))
+plot(x, type = "n")
+text(x, labels = rownames(x), cex = 0.7)
+oq <- par(mar = c(0, 1, 0, 1), xpd = TRUE)
+plot(tr, font = 1, cex = 0.7)
+nodelabels(tr$node.label, cex = 0.7, adj = 1)
+par(c(op, oq))
+}
+\keyword{datagen}
diff --git a/man/read.GenBank.Rd b/man/read.GenBank.Rd
new file mode 100644
index 0000000..d7ea055
--- /dev/null
+++ b/man/read.GenBank.Rd
@@ -0,0 +1,70 @@
+\name{read.GenBank}
+\alias{read.GenBank}
+\title{Read DNA Sequences from GenBank via Internet}
+\usage{
+read.GenBank(access.nb, seq.names = access.nb, species.names = TRUE,
+ gene.names = FALSE, as.character = FALSE)
+}
+\arguments{
+ \item{access.nb}{a vector of mode character giving the accession numbers.}
+ \item{seq.names}{the names to give to each sequence; by default the
+ accession numbers are used.}
+ \item{species.names}{a logical indicating whether to attribute the
+ species names to the returned object.}
+ \item{gene.names}{a logical indicating whether to attribute the
+ gene names to the returned object. It is \code{FALSE} by default
+ because this will work correctly only when reading sequences with a
+ single gene.}
+ \item{as.character}{a logical controlling whether to return the
+ sequences as an object of class \code{"DNAbin"} (the default).}
+}
+\description{
+ This function connects to the GenBank database, and reads nucleotide
+ sequences using accession numbers given as arguments.
+}
+\value{
+ A list of DNA sequences made of vectors of class \code{"DNAbin"}, or
+ of single characters (if \code{as.character = "TRUE"}).
+}
+\details{
+ The function uses the site \url{http://www.ncbi.nlm.nih.gov/} from
+ where the sequences are downloaded.
+
+ If \code{species.names = TRUE}, the returned list has an attribute
+ \code{"species"} containing the names of the species taken from the
+ field ``ORGANISM'' in GenBank.
+
+ If \code{gene.names = TRUE}, the returned list has an attribute
+ \code{"gene"} containing the names of the gene. This will not work
+ correctly if reading a sequence with multiple genes (e.g., a
+ mitochondrial genome).
+}
+\seealso{
+ \code{\link{read.dna}}, \code{\link{write.dna}},
+ \code{\link{dist.dna}}, \code{\link{DNAbin}}
+}
+\author{Emmanuel Paradis}
+\examples{
+### This won't work if your computer is not connected
+### to the Internet!!!
+###
+### Get the 8 sequences of tanagers (Ramphocelus)
+### as used in Paradis (1997)
+ref <- c("U15717", "U15718", "U15719", "U15720",
+ "U15721", "U15722", "U15723", "U15724")
+### Copy/paste or type the following commands if you
+### want to try them.
+\dontrun{
+Rampho <- read.GenBank(ref)
+### get the species names:
+attr(Rampho, "species")
+### build a matrix with the species names and the accession numbers:
+cbind(attr(Rampho, "species"), names(Rampho))
+### print the first sequence
+### (can be done with `Rampho$U15717' as well)
+Rampho[[1]]
+### print the first sequence in a cleaner way
+cat(Rampho[[1]], "\n", sep = "")
+}
+}
+\keyword{IO}
diff --git a/man/read.caic.Rd b/man/read.caic.Rd
new file mode 100644
index 0000000..39bc2a1
--- /dev/null
+++ b/man/read.caic.Rd
@@ -0,0 +1,43 @@
+\name{read.caic}
+\alias{read.caic}
+\title{Read Tree File in CAIC Format}
+\description{
+This function reads one tree from a CAIC file.
+A second file containing branch lengths values may also be passed (experimental).
+}
+\usage{
+read.caic(file, brlen = NULL, skip = 0, comment.char = "#", ...)
+}
+\arguments{
+ \item{file}{a file name specified by either a variable of mode character, or a double-quoted string.}
+ \item{brlen}{a file name for the branch lengths file.}
+ \item{skip}{the number of lines of the input file to skip before beginning to read data (this is passed directly to scan()).}
+ \item{comment.char}{a single character, the remaining of the line after this character is ignored (this is passed directly to scan()).}
+ \item{\dots}{Further arguments to be passed to scan().}
+}
+\details{
+ Read a tree from a file in the format used by the CAIC and MacroCAIc program.
+}
+\value{
+ an object of class \code{"phylo"}.
+}
+\references{
+ Purvis, A. and Rambaut, A. (1995) Comparative analysis by independent
+ contrasts (CAIC): an Apple Macintosh application for analysing
+ comparative data. \emph{CABIOS}, \bold{11} :241--251.
+}
+\author{Julien Dutheil \email{julien.dutheil at univ-montp2.fr}}
+\section{Warning }{The branch length support is still experimental and was not fully tested.}
+\seealso{ \code{\link{read.tree}}, \code{\link{read.nexus}} }
+\examples{
+### The same example than in read.tree, without branch lengths.
+### An extract from Sibley and Ahlquist (1990)
+cat("AAA","Strix_aluco","AAB","Asio_otus",
+ "AB","Athene_noctua","B","Tyto_alba",
+ file = "ex.tre", sep = "\n")
+tree.owls <- read.caic("ex.tre")
+plot(tree.owls)
+tree.owls
+unlink("ex.tre") # delete the file "ex.tre"
+}
+\keyword{hplot}
diff --git a/man/read.dna.Rd b/man/read.dna.Rd
new file mode 100644
index 0000000..ca0a5c0
--- /dev/null
+++ b/man/read.dna.Rd
@@ -0,0 +1,146 @@
+\name{read.dna}
+\alias{read.dna}
+\alias{read.FASTA}
+\title{Read DNA Sequences in a File}
+\description{
+ These functions read DNA sequences in a file, and returns a matrix or a
+ list of DNA sequences with the names of the taxa read in the file as
+ rownames or names, respectively. By default, the sequences are stored
+ in binary format, otherwise (if \code{as.character = "TRUE"}) in lower
+ case.
+}
+\usage{
+read.dna(file, format = "interleaved", skip = 0,
+ nlines = 0, comment.char = "#",
+ as.character = FALSE, as.matrix = NULL)
+read.FASTA(file)
+}
+\arguments{
+ \item{file}{a file name specified by either a variable of mode character,
+ or a double-quoted string.}
+ \item{format}{a character string specifying the format of the DNA
+ sequences. Four choices are possible: \code{"interleaved"},
+ \code{"sequential"}, \code{"clustal"}, or \code{"fasta"}, or any
+ unambiguous abbreviation of these.}
+ \item{skip}{the number of lines of the input file to skip before
+ beginning to read data (ignored for FASTA files; see below).}
+ \item{nlines}{the number of lines to be read (by default the file is
+ read untill its end; ignored for FASTA files)).}
+ \item{comment.char}{a single character, the remaining of the line
+ after this character is ignored (ignored for FASTA files).}
+ \item{as.character}{a logical controlling whether to return the
+ sequences as an object of class \code{"DNAbin"} (the default).}
+ \item{as.matrix}{(used if \code{format = "fasta"}) one of the three
+ followings: (i) \code{NULL}: returns the sequences in a matrix if
+ they are of the same length, otherwise in a list; (ii) \code{TRUE}:
+ returns the sequences in a matrix, or stops with an error if they
+ are of different lengths; (iii) \code{FALSE}: always returns the
+ sequences in a list.}
+}
+\details{
+ \code{read.dna} follows the interleaved and sequential formats defined
+ in PHYLIP (Felsenstein, 1993) but with the original feature than there
+ is no restriction on the lengths of the taxa names. For these two
+ formats, the first line of the file must contain the dimensions of the
+ data (the numbers of taxa and the numbers of nucleotides); the
+ sequences are considered as aligned and thus must be of the same
+ lengths for all taxa. For the FASTA format, the conventions defined in
+ the URL below (see References) are followed; the sequences are taken as
+ non-aligned. For all formats, the nucleotides can be arranged in any
+ way with blanks and line-breaks inside (with the restriction that the
+ first ten nucleotides must be contiguous for the interleaved and
+ sequential formats, see below). The names of the sequences are read in
+ the file. Particularities for each format are detailed below.
+
+\itemize{
+ \item{Interleaved:}{the function starts to read the sequences after it
+ finds one or more spaces (or tabulations). All characters before the
+ sequences are taken as the taxa names after removing the leading and
+ trailing spaces (so spaces in taxa names are allowed). It is assumed
+ that the taxa names are not repeated in the subsequent blocks of
+ nucleotides.}
+
+ \item{Sequential:}{the same criterion than for the interleaved format
+ is used to start reading the sequences and the taxa names; the
+ sequences are then read until the number of nucleotides specified in
+ the first line of the file is reached. This is repeated for each taxa.}
+
+ \item{Clustal:}{this is the format output by the Clustal programs
+ (.aln). It is somehow similar to the interleaved format: the
+ differences being that the dimensions of the data are not indicated
+ in the file, and the names of the sequences are repeated in each block.}
+
+ \item{FASTA:}{This looks like the sequential format but the taxa names
+ (or rather a description of the sequence) are on separate lines
+ beginning with a `greater than' character `>' (there may be
+ leading spaces before this character). These lines are taken as taxa
+ names after removing the `>' and the possible leading and trailing
+ spaces. All the data in the file before the first sequence is ignored.}
+}}
+\value{
+ a matrix or a list (if \code{format = "fasta"}) of DNA sequences
+ stored in binary format, or of mode character (if \code{as.character =
+ "TRUE"}).
+
+ \code{read.FASTA} always returns a list of class \code{"DNAbin"}.
+}
+\references{
+ Anonymous. FASTA format description.
+ \url{http://www.ncbi.nlm.nih.gov/BLAST/fasta.html}
+
+ Anonymous. IUPAC ambiguity codes.
+ \url{http://www.ncbi.nlm.nih.gov/SNP/iupac.html}
+
+ Felsenstein, J. (1993) Phylip (Phylogeny Inference Package) version
+ 3.5c. Department of Genetics, University of Washington.
+ \url{http://evolution.genetics.washington.edu/phylip/phylip.html}
+}
+\seealso{
+ \code{\link{read.GenBank}}, \code{\link{write.dna}},
+ \code{\link{DNAbin}}, \code{\link{dist.dna}}, \code{\link{woodmouse}}
+}
+\author{Emmanuel Paradis}
+\examples{
+### a small extract from `data(woddmouse)'
+cat("3 40",
+"No305 NTTCGAAAAACACACCCACTACTAAAANTTATCAGTCACT",
+"No304 ATTCGAAAAACACACCCACTACTAAAAATTATCAACCACT",
+"No306 ATTCGAAAAACACACCCACTACTAAAAATTATCAATCACT",
+file = "exdna.txt", sep = "\n")
+ex.dna <- read.dna("exdna.txt", format = "sequential")
+str(ex.dna)
+ex.dna
+### the same data in interleaved format...
+cat("3 40",
+"No305 NTTCGAAAAA CACACCCACT",
+"No304 ATTCGAAAAA CACACCCACT",
+"No306 ATTCGAAAAA CACACCCACT",
+" ACTAAAANTT ATCAGTCACT",
+" ACTAAAAATT ATCAACCACT",
+" ACTAAAAATT ATCAATCACT",
+file = "exdna.txt", sep = "\n")
+ex.dna2 <- read.dna("exdna.txt")
+### ... in clustal format...
+cat("CLUSTAL (ape) multiple sequence alignment", "",
+"No305 NTTCGAAAAACACACCCACTACTAAAANTTATCAGTCACT",
+"No304 ATTCGAAAAACACACCCACTACTAAAAATTATCAACCACT",
+"No306 ATTCGAAAAACACACCCACTACTAAAAATTATCAATCACT",
+" ************************** ****** ****",
+file = "exdna.txt", sep = "\n")
+ex.dna3 <- read.dna("exdna.txt", format = "clustal")
+### ... and in FASTA format
+cat(">No305",
+"NTTCGAAAAACACACCCACTACTAAAANTTATCAGTCACT",
+">No304",
+"ATTCGAAAAACACACCCACTACTAAAAATTATCAACCACT",
+">No306",
+"ATTCGAAAAACACACCCACTACTAAAAATTATCAATCACT",
+file = "exdna.txt", sep = "\n")
+ex.dna4 <- read.dna("exdna.txt", format = "fasta")
+### The first three are the same!
+identical(ex.dna, ex.dna2)
+identical(ex.dna, ex.dna3)
+identical(ex.dna, ex.dna4)
+unlink("exdna.txt") # clean-up
+}
+\keyword{IO}
diff --git a/man/read.nexus.Rd b/man/read.nexus.Rd
new file mode 100644
index 0000000..5594e0e
--- /dev/null
+++ b/man/read.nexus.Rd
@@ -0,0 +1,56 @@
+\name{read.nexus}
+\alias{read.nexus}
+\title{Read Tree File in Nexus Format}
+\usage{
+read.nexus(file, tree.names = NULL)
+}
+\arguments{
+ \item{file}{a file name specified by either a variable of mode character,
+ or a double-quoted string.}
+ \item{tree.names}{if there are several trees to be read, a vector of
+ mode character giving names to the individual trees (by default,
+ this uses the labels in the NEXUS file if these are present).}
+}
+\description{
+ This function reads one or several trees in a NEXUS file.
+}
+\details{
+ The present implementation tries to follow as much as possible the
+ NEXUS standard (but see the restriction below on TRANSLATION
+ tables). Only the block ``TREES'' is read; the other data can be read
+ with other functions (e.g., \code{\link{read.dna}},
+ \code{\link[utils]{read.table}}, \dots).
+
+ If a TRANSLATION table is present it is assumed that only the tip
+ labels are translated and they are all translated with integers
+ without gap. Consequently, if nodes have labels in the tree(s) they
+ are read as they are and not looked for in the translation table. The
+ logic behind this is that in the vast majority of cases, node labels
+ will be support values rather than proper taxa names. This is
+ consistent with \code{\link{write.nexus}} which translates only the
+ tip labels.
+
+ `read.nexus' tries to represent correctly trees with a badly
+ represented root edge (i.e. with an extra pair of parentheses). For
+ instance, the tree "((A:1,B:1):10);" will be read like "(A:1,B:1):10;"
+ but a warning message will be issued in the former case as this is
+ apparently not a valid Newick format. If there are two root edges
+ (e.g., "(((A:1,B:1):10):10);"), then the tree is not read and an error
+ message is issued.
+}
+\value{
+ an object of class \code{"phylo"} or of class \code{"multiPhylo"}.
+}
+\references{
+ Maddison, D. R., Swofford, D. L. and Maddison, W. P. (1997) NEXUS: an
+ extensible file format for systematic information. \emph{Systematic
+ Biology}, \bold{46}, 590--621.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{read.tree}}, \code{\link{write.nexus}},
+ \code{\link{write.tree}}, \code{\link{read.nexus.data}},
+ \code{\link{write.nexus.data}}
+}
+\keyword{manip}
+\keyword{IO}
diff --git a/man/read.nexus.data.Rd b/man/read.nexus.data.Rd
new file mode 100644
index 0000000..ce7ae55
--- /dev/null
+++ b/man/read.nexus.data.Rd
@@ -0,0 +1,112 @@
+\name{read.nexus.data}
+\alias{read.nexus.data}
+\title{
+ Read Character Data In NEXUS Format
+}
+\description{
+ This function reads a file with sequences in the NEXUS format.
+}
+\usage{
+read.nexus.data(file)
+}
+\arguments{
+ \item{file}{a file name specified by either a variable of mode
+ character, or a double-quoted string.}
+}
+\details{
+ This parser tries to read data from a file written in a
+ \emph{restricted} NEXUS format (see examples below).
+
+ Please see files \file{data.nex} and \file{taxacharacters.nex} for
+ examples of formats that will work.
+
+ Some noticeable exceptions from the NEXUS standard (non-exhaustive
+ list):
+
+ \itemize{
+ \item{\bold{I}}{Comments must be either on separate lines or at the
+ end of lines. Examples:\cr
+ \code{[Comment]} \bold{--- OK}\cr
+ \code{Taxon ACGTACG [Comment]} \bold{--- OK}\cr
+ \code{[Comment line 1}
+
+ \code{Comment line 2]} \bold{--- NOT OK!}\cr
+ \code{Tax[Comment]on ACG[Comment]T} \bold{--- NOT OK!}}
+ \item{\bold{II}}{No spaces (or comments) are allowed in the
+ sequences. Examples:\cr
+ \code{name ACGT} \bold{--- OK}\cr
+ \code{name AC GT} \bold{--- NOT OK!}}
+ \item{\bold{III}}{No spaces are allowed in taxon names, not even if
+ names are in single quotes. That is, single-quoted names are not
+ treated as such by the parser. Examples:\cr
+ \code{Genus_species} \bold{--- OK}\cr
+ \code{'Genus_species'} \bold{--- OK}\cr
+ \code{'Genus species'} \bold{--- NOT OK!}}
+ \item{\bold{IV}}{The trailing \code{end} that closes the
+ \code{matrix} must be on a separate line. Examples:\cr
+ \code{taxon AACCGGT}
+
+ \code{end;} \bold{--- OK}\cr
+ \code{taxon AACCGGT;}
+
+ \code{end;} \bold{--- OK}\cr
+ \code{taxon AACCCGT; end;} \bold{--- NOT OK!}}
+ \item{\bold{V}}{Multistate characters are not allowed. That is,
+ NEXUS allows you to specify multiple character states at a
+ character position either as an uncertainty, \code{(XY)}, or as an
+ actual appearance of multiple states, \code{\{XY\}}. This is
+ information is not handled by the parser. Examples:\cr
+ \code{taxon 0011?110} \bold{--- OK}\cr
+ \code{taxon 0011{01}110} \bold{--- NOT OK!}\cr
+ \code{taxon 0011(01)110} \bold{--- NOT OK!}}
+ \item{\bold{VI}}{The number of taxa must be on the same line as
+ \code{ntax}. The same applies to \code{nchar}. Examples:\cr
+ \code{ntax = 12} \bold{--- OK}\cr
+ \code{ntax =}
+
+ \code{12} \bold{--- NOT OK!}}
+ \item{\bold{VII}}{The word \dQuote{matrix} can not occur anywhere in
+ the file before the actual \code{matrix} command, unless it is in
+ a comment. Examples:\cr
+ \code{BEGIN CHARACTERS;}
+
+ \code{TITLE 'Data in file "03a-cytochromeB.nex"';}
+
+ \code{DIMENSIONS NCHAR=382;}
+
+ \code{FORMAT DATATYPE=Protein GAP=- MISSING=?;}
+
+ \code{["This is The Matrix"]} \bold{--- OK}
+
+ \code{MATRIX}\cr
+
+ \code{BEGIN CHARACTERS;}
+
+ \code{TITLE 'Matrix in file "03a-cytochromeB.nex"';} \bold{--- NOT OK!}
+
+ \code{DIMENSIONS NCHAR=382;}
+
+ \code{FORMAT DATATYPE=Protein GAP=- MISSING=?;}
+
+ \code{MATRIX}}
+ }
+}
+\value{
+ A list of sequences each made of a single vector of mode character
+ where each element is a (phylogenetic) character state.
+}
+\references{
+ Maddison, D. R., Swofford, D. L. and Maddison, W. P. (1997) NEXUS: an
+ extensible file format for systematic information. \emph{Systematic
+ Biology}, \bold{46}, 590--621.
+}
+\author{Johan Nylander \email{nylander at scs.fsu.edu}}
+\seealso{
+ \code{\link{read.nexus}}, \code{\link{write.nexus}},
+ \code{\link{write.nexus.data}}
+}
+\examples{
+## Use read.nexus.data to read a file in NEXUS format into object x
+\dontrun{x <- read.nexus.data("file.nex")}
+}
+\keyword{file}
diff --git a/man/read.tree.Rd b/man/read.tree.Rd
new file mode 100644
index 0000000..4ad7e91
--- /dev/null
+++ b/man/read.tree.Rd
@@ -0,0 +1,116 @@
+\name{read.tree}
+\alias{read.tree}
+\alias{phylo}
+\title{Read Tree File in Parenthetic Format}
+\usage{
+read.tree(file = "", text = NULL, tree.names = NULL, skip = 0,
+ comment.char = "#", keep.multi = FALSE, ...)
+}
+\arguments{
+ \item{file}{a file name specified by either a variable of mode character,
+ or a double-quoted string; if \code{file = ""} (the default) then the
+ tree is input on the keyboard, the entry being terminated with a
+ blank line.}
+ \item{text}{alternatively, the name of a variable of mode character
+ which contains the tree(s) in parenthetic format. By default, this
+ is ignored (set to \code{NULL}, meaning that the tree is read in a
+ file); if \code{text} is not \code{NULL}, then the argument
+ \code{file} is ignored.}
+ \item{tree.names}{if there are several trees to be read, a vector of
+ mode character that gives names to the individual trees; if
+ \code{NULL} (the default), the trees are named \code{"tree1"},
+ \code{"tree2"}, ...}
+ \item{skip}{the number of lines of the input file to skip before
+ beginning to read data (this is passed directly to\code{ scan()}).}
+ \item{comment.char}{a single character, the remaining of the line
+ after this character is ignored (this is passed directly to
+ \code{scan()}).}
+ \item{keep.multi}{if \code{TRUE} and \code{tree.names = NULL} then
+ single trees are returned in \code{"multiPhylo"} format, with any
+ name that is present (see details). Default is \code{FALSE}.}
+ \item{\dots}{further arguments to be passed to \code{scan()}.}
+}
+\description{
+ This function reads a file which contains one or several trees in
+ parenthetic format known as the Newick or New Hampshire format.
+}
+\details{
+ The default option for \code{file} allows to type directly the tree on
+ the keyboard (or possibly to copy from an editor and paste in R's
+ console) with, e.g., \code{mytree <- read.tree()}.
+
+ `read.tree' tries to represent correctly trees with a badly
+ represented root edge (i.e. with an extra pair of parentheses). For
+ instance, the tree "((A:1,B:1):10);" will be read like "(A:1,B:1):10;"
+ but a warning message will be issued in the former case as this is
+ apparently not a valid Newick format. If there are two root edges
+ (e.g., "(((A:1,B:1):10):10);"), then the tree is not read and an error
+ message is issued.
+
+ If there are any characters preceding the first "(" in a line then
+ this is assigned to the name. This is returned when a "multiPhylo"
+ object is returned and \code{tree.names = NULL}.
+}
+\value{
+ an object of class \code{"phylo"} with the following components:
+ \item{edge}{a two-column matrix of mode numeric where each row
+ represents an edge of the tree; the nodes and the tips are
+ symbolized with numbers; the tips are numbered 1, 2, \dots, and the
+ nodes are numbered after the tips. For each row, the first column
+ gives the ancestor.}
+ \item{edge.length}{(optional) a numeric vector giving the lengths of the
+ branches given by \code{edge}.}
+ \item{tip.label}{a vector of mode character giving the names of the
+ tips; the order of the names in this vector corresponds to the
+ (positive) number in \code{edge}.}
+ \item{Nnode}{the number of (internal) nodes.}
+ \item{node.label}{(optional) a vector of mode character giving the
+ names of the nodes.}
+ \item{root.edge}{(optional) a numeric value giving the length of the
+ branch at the root if it exists.}
+
+ If several trees are read in the file, the returned object is of class
+ \code{"multiPhylo"}, and is a list of objects of class \code{"phylo"}.
+ The name of each tree can be specified by \code{tree.names}, or can be
+ read from the file (see details).
+}
+\references{
+ Felsenstein, J. The Newick tree format.
+ \url{http://evolution.genetics.washington.edu/phylip/newicktree.html}
+
+ Olsen, G. Interpretation of the "Newick's 8:45" tree format standard.
+ \url{http://evolution.genetics.washington.edu/phylip/newick_doc.html}
+
+ Paradis, E. (2008) Definition of Formats for Coding Phylogenetic Trees
+ in R. \url{http://ape.mpl.ird.fr/misc/FormatTreeR_28July2008.pdf}
+
+ Paradis, E. (2012) \emph{Analysis of Phylogenetics and Evolution with
+ R (Second Edition).} New York: Springer.
+}
+
+\author{Emmanuel Paradis and Daniel Lawson \email{dan.lawson at bristol.ac.uk}}
+\seealso{
+ \code{\link{write.tree}}, \code{\link{read.nexus}},
+ \code{\link{write.nexus}}, \code{\link[base]{scan}} for the basic R
+ function to read data in a file
+}
+\examples{
+### An extract from Sibley and Ahlquist (1990)
+s <- "owls(((Strix_aluco:4.2,Asio_otus:4.2):3.1,Athene_noctua:7.3):6.3,Tyto_alba:13.5);"
+cat(s, file = "ex.tre", sep = "\n")
+tree.owls <- read.tree("ex.tre")
+str(tree.owls)
+tree.owls
+tree.owls <- read.tree("ex.tre", keep.multi = TRUE)
+tree.owls
+names(tree.owls)
+unlink("ex.tre") # delete the file "ex.tre"
+### Only the first three species using the option `text'
+TREE <- "((Strix_aluco:4.2,Asio_otus:4.2):3.1,Athene_noctua:7.3);"
+TREE
+tree.owls.bis <- read.tree(text = TREE)
+str(tree.owls.bis)
+tree.owls.bis
+}
+\keyword{manip}
+\keyword{IO}
diff --git a/man/reorder.phylo.Rd b/man/reorder.phylo.Rd
new file mode 100644
index 0000000..c81beee
--- /dev/null
+++ b/man/reorder.phylo.Rd
@@ -0,0 +1,59 @@
+\name{reorder.phylo}
+\alias{reorder.phylo}
+\title{Internal Reordering of Trees}
+\description{
+ This function changes the internal structure of a phylogeny stored as
+ an object of class \code{"phylo"}. The tree returned is the same than
+ the one input, but the ordering of the edges could be different.
+}
+\usage{
+\method{reorder}{phylo}(x, order = "cladewise", index.only = FALSE, ...)
+}
+\arguments{
+ \item{x}{an object of class \code{"phylo"}.}
+ \item{order}{a character string: either \code{"cladewise"} (the
+ default), \code{"postorder"}, \code{"pruningwise"}, or any
+ unambiguous abbreviation of these.}
+ \item{index.only}{should the function return only the ordered indices
+ of the rows of the edge matrix?}
+ \item{\dots}{further arguments passed to or from other methods.}
+}
+\details{
+ Because in a tree coded as an object of class \code{"phylo"} each
+ branch is represented by a row in the element `edge', there is an
+ arbitrary choice for the ordering of these rows. \code{reorder} allows
+ to reorder these rows according to three rules: in the
+ \code{"cladewise"} order each clade is formed by a series of
+ contiguous rows. In the \code{"postorder"} order, the rows are
+ arranged so that computations following pruning-like algorithm the
+ tree (or postorder tree traversal) can be done by descending along
+ these rows (conversely, a preorder tree traversal can be performed by
+ moving from the last to the first row). The \code{"pruningwise"} order
+ is an alternative ``pruning'' order which is actually a bottom-up
+ traversal order (Valiente 2002). (This third choice might be removed
+ in the future as it merely duplicates the second one which is more
+ efficient.) The possible multichotomies and branch lengths are preserved.
+
+ Note that for a given order, there are several possible orderings of
+ the rows of `edge'.
+}
+\value{
+ an object of class \code{"phylo"} (with the attribute \code{"order"}
+ set accordingly), or a numeric vector if \code{index.only = TRUE}.
+}
+\references{
+ Valiente, G. (2002) \emph{Algorithms on Trees and Graphs.} New York:
+ Springer.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{read.tree}} to read tree files in Newick format,
+ \code{\link[stats]{reorder}} for the generic function
+}
+\examples{
+data(bird.families)
+tr <- reorder(bird.families, "postorder")
+all.equal(bird.families, tr) # uses all.equal.phylo actually
+all.equal.list(bird.families, tr) # bypasses the generic
+}
+\keyword{manip}
diff --git a/man/richness.yule.test.Rd b/man/richness.yule.test.Rd
new file mode 100644
index 0000000..91177f6
--- /dev/null
+++ b/man/richness.yule.test.Rd
@@ -0,0 +1,37 @@
+\name{richness.yule.test}
+\alias{richness.yule.test}
+\title{Test of Diversification-Shift With the Yule Process}
+\description{
+ This function performs a test of shift in diversification rate using
+ probabilities from the Yule process.
+}
+\usage{
+richness.yule.test(x, t)
+}
+\arguments{
+ \item{x}{a matrix or a data frame with at least two columns: the first
+ one gives the number of species in clades with a trait supposed to
+ increase or decrease diversification rate, and the second one the number of
+ species in the sister-clades without the trait. Each
+ row represents a pair of sister-clades.}
+ \item{t}{a numeric vector giving the divergence times of each pair of
+ clades in \code{x}.}
+}
+\value{
+ a data frame with the \eqn{\chi^2}{chi2}, the number of degrees of
+ freedom (= 1), and the \emph{P}-value.
+}
+\references{
+ Paradis, E. (2012) Shift in diversification in sister-clade
+ comparisons: a more powerful test. \emph{Evolution}, \bold{66},
+ 288--295.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{slowinskiguyer.test}}, \code{\link{mcconwaysims.test}},
+ \code{\link{diversity.contrast.test}}
+}
+\examples{
+### see examples(mcconwaysims.test)
+}
+\keyword{htest}
diff --git a/man/rlineage.Rd b/man/rlineage.Rd
new file mode 100644
index 0000000..e01a810
--- /dev/null
+++ b/man/rlineage.Rd
@@ -0,0 +1,75 @@
+\name{rlineage}
+\alias{rlineage}
+\alias{rbdtree}
+\alias{drop.fossil}
+\title{Tree Simulation Under the Time-Dependent Birth--Death Models}
+\description{
+ These two functions simulate phylogenies under any time-dependent
+ birth--death model. \code{lineage} generates a complete tree including
+ the species that go extinct; \code{rbdtree} generates a tree with only
+ the species until present; \code{drop.fossil} is a utility function to
+ remove the extinct species.
+}
+\usage{
+rlineage(birth, death, Tmax = 50, BIRTH = NULL,
+ DEATH = NULL, eps = 1e-6)
+rbdtree(birth, death, Tmax = 50, BIRTH = NULL,
+ DEATH = NULL, eps = 1e-6)
+drop.fossil(phy, tol = 1e-8)
+}
+\arguments{
+ \item{birth, death}{a numeric value or a (vectorized) function
+ specifying how speciation and extinction rates vary through time.}
+ \item{Tmax}{a numeric value giving the length of the simulation.}
+ \item{BIRTH, DEATH}{a (vectorized) function which is the primitive
+ of \code{birth} or \code{death}. This can be used to speed-up the
+ computation. By default, numerical integration is done.}
+ \item{eps}{a numeric value giving the time resolution of the
+ simulation; this may be increased (e.g., 0.001) to shorten
+ computation times.}
+ \item{phy}{an object of class \code{"phylo"}.}
+ \item{tol}{a numeric value giving the tolerance to consider a species
+ as extinct.}
+}
+\details{
+ Both functions use continuous-time algorithms described in the
+ references. The models are time-dependent birth--death models as
+ described in Kendall (1948). Speciation (birth) and extinction (death)
+ rates may be constant or vary through time according to an \R function
+ specified by the user. In the latter case, \code{BIRTH} and/or
+ \code{DEATH} may be used if the primitives of \code{birth} and
+ \code{death} are known. In these functions time is the formal argument
+ and must be named \code{t}.
+}
+\value{
+ An object of class \code{"phylo"}.
+}
+\references{
+ Kendall, D. G. (1948) On the generalized ``birth-and-death''
+ process. \emph{Annals of Mathematical Statistics}, \bold{19}, 1--15.
+
+ Paradis, E. (2011) Time-dependent speciation and extinction from
+ phylogenies: a least squares approach. \emph{Evolution}, \bold{65},
+ 661--672.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{yule}}, \code{\link{yule.time}}, \code{\link{birthdeath}},
+ \code{\link{rtree}}, \code{\link{stree}}
+}
+\examples{
+plot(rlineage(0.1, 0)) # Yule process with lambda = 0.1
+plot(rlineage(0.1, 0.05)) # simple birth-death process
+b <- function(t) 1/(1 + exp(0.2*t - 1)) # logistic
+layout(matrix(0:3, 2, byrow = TRUE))
+curve(b, 0, 50, xlab = "Time", ylab = "")
+mu <- 0.07
+segments(0, mu, 50, mu, lty = 2)
+legend("topright", c(expression(lambda), expression(mu)),
+ lty = 1:2, bty = "n")
+plot(rlineage(b, mu), show.tip.label = FALSE)
+title("Simulated with 'rlineage'")
+plot(rbdtree(b, mu), show.tip.label = FALSE)
+title("Simulated with 'rbdtree'")
+}
+\keyword{datagen}
diff --git a/man/root.Rd b/man/root.Rd
new file mode 100644
index 0000000..05ef593
--- /dev/null
+++ b/man/root.Rd
@@ -0,0 +1,81 @@
+\name{root}
+\alias{root}
+\alias{unroot}
+\alias{is.rooted}
+\title{Roots Phylogenetic Trees}
+\usage{
+root(phy, outgroup, node = NULL, resolve.root = FALSE, interactive = FALSE)
+unroot(phy)
+is.rooted(phy)
+}
+\arguments{
+ \item{phy}{an object of class \code{"phylo"}.}
+ \item{outgroup}{a vector of mode numeric or character specifying the
+ new outgroup.}
+ \item{node}{alternatively, a node number where to root the tree (this
+ should give the MRCA of the ingroup).}
+ \item{resolve.root}{a logical specifying whether to resolve the new
+ root as a bifurcating node.}
+ \item{interactive}{if \code{TRUE} the user is asked to select the node
+ by clicking on the tree which must be plotted.}
+}
+\description{
+ \code{root} reroots a phylogenetic tree with respect to the specified
+ outgroup or at the node specified in \code{node}.
+
+ \code{unroot} unroots a phylogenetic tree, or returns it unchanged if
+ it is already unrooted.
+
+ \code{is.rooted} tests whether a tree is rooted.
+}
+\details{
+ The argument \code{outgroup} can be either character or numeric. In
+ the first case, it gives the labels of the tips of the new outgroup;
+ in the second case the numbers of these labels in the vector
+ \code{phy$tip.label} are given.
+
+ If \code{outgroup} is of length one (i.e., a single value), then the
+ tree is rerooted using the node below this tip as the new root.
+
+ If \code{outgroup} is of length two or more, the most recent common
+ ancestor (MRCA) \emph{of the ingroup} is used as the new root. Note
+ that the tree is unrooted before being rerooted, so that if
+ \code{outgroup} is already the outgroup, then the returned tree is not
+ the same than the original one (see examples). If \code{outgroup} is
+ not monophyletic, the operation fails and an error message is issued.
+
+ If \code{resolve.root = TRUE}, \code{root} adds a zero-length branch
+ below the MRCA of the ingroup.
+
+ A tree is considered rooted if either only two branches connect to the
+ root, or if there is a \code{root.edge} element. In all other cases,
+ \code{is.rooted} returns \code{FALSE}.
+}
+\value{
+ an object of class \code{"phylo"} for \code{root} and \code{unroot}; a
+ single logical value for \code{is.rooted}.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{bind.tree}}, \code{\link{drop.tip}},
+ \code{\link{nodelabels}}, \code{\link{identify.phylo}}
+}
+\examples{
+data(bird.orders)
+plot(root(bird.orders, 1))
+plot(root(bird.orders, 1:5))
+
+tr <- root(bird.orders, 1)
+is.rooted(bird.orders) # yes!
+is.rooted(tr) # no!
+### This is because the tree has been unrooted first before rerooting.
+### You can delete the outgroup...
+is.rooted(drop.tip(tr, "Struthioniformes"))
+### ... or resolve the basal trichotomy in two ways:
+is.rooted(multi2di(tr))
+is.rooted(root(bird.orders, 1, r = TRUE))
+### To keep the basal trichotomy but forcing the tree as rooted:
+tr$root.edge <- 0
+is.rooted(tr)
+}
+\keyword{manip}
diff --git a/man/rotate.Rd b/man/rotate.Rd
new file mode 100644
index 0000000..61c6418
--- /dev/null
+++ b/man/rotate.Rd
@@ -0,0 +1,108 @@
+\name{rotate}
+\alias{rotate}
+\alias{rotateConstr}
+\title{Swapping Sister Clades}
+\description{
+ For a given node, \code{rotate} exchanges the position of two clades
+ descending from this node. It can handle dichotomies as well as
+ polytomies. In the latter case, two clades from the polytomy are
+ selected for swapping.
+
+ \code{rotateConstr} rotates internal branches giving a constraint on
+ the order of the tips.
+}
+\usage{
+rotate(phy, node, polytom = c(1, 2))
+rotateConstr(phy, constraint)
+}
+\arguments{
+ \item{phy}{an object of class \code{"phylo"}.}
+ \item{node}{a vector of mode numeric or character specifying the
+ number of the node.}
+ \item{polytom}{a vector of mode numeric and length two specifying the
+ two clades that should be exchanged in a polytomy.}
+ \item{constraint}{a vector of mode character specifying the order of
+ the tips as they should appear when plotting the tree (from bottom
+ to top).}
+}
+\details{
+ \code{phy} can be either rooted or unrooted, contain polytomies and lack
+ branch lengths. In the presence of very short branch lengths it is
+ convenient to plot the phylogenetic tree without branch lengths in order
+ to identify the number of the node in question.
+
+ \code{node} can be any of the interior nodes of a phylogenetic tree
+ including the root node. Number of the nodes can be identified by the
+ nodelabels function. Alternatively, you can specify a vector of length
+ two that contains either the number or the names of two tips that
+ coalesce in the node of interest.
+
+ If the node subtends a polytomy, any two clades of the the polytomy
+ can be chosen by polytom. On a plotted phylogeny, the clades are
+ numbered from bottom to top and polytom is used to index the two
+ clades one likes to swop.
+}
+\value{
+ an object of class \code{"phylo"}.
+}
+\author{Christoph Heibl \email{heibl at lmu.de}, Emmanuel Paradis}
+\seealso{
+ \code{\link{plot.phylo}}, \code{\link{nodelabels}},
+ \code{\link{root}}, \code{\link{drop.tip}}}
+\examples{
+# create a random tree:
+tre <- rtree(25)
+
+# visualize labels of internal nodes:
+plot(tre, use.edge.length=FALSE)
+nodelabels()
+
+# rotate clades around node 30:
+tre.new <- rotate(tre, 30)
+
+# compare the results:
+par(mfrow=c(1,2)) # split graphical device
+plot(tre) # plot old tre
+plot(tre.new) # plot new tree
+
+# visualize labels of terminal nodes:
+plot(tre)
+tiplabels()
+
+# rotate clades containing nodes 12 and 20:
+tre.new <- rotate(tre, c(12, 21))
+
+# compare the results:
+par(mfrow=c(1,2)) # split graphical device
+plot(tre) # plot old tre
+plot(tre.new) # plot new tree
+
+# or you migth just specify tiplabel names:
+tre.new <- rotate(tre, c("t3", "t14"))
+
+# compare the results:
+par(mfrow=c(1,2)) # devide graphical device
+plot(tre) # plot old tre
+plot(tre.new) # plot new tree
+
+# a simple example for rotateConstr:
+A <- read.tree(text = "((A,B),(C,D));")
+B <- read.tree(text = "(((D,C),B),A);")
+B <- rotateConstr(B, A$tip.label)
+plot(A); plot(B, d = "l")
+
+# something more interesting (from ?cophyloplot):
+tr1 <- rtree(40)
+## drop 20 randomly chosen tips:
+tr2 <- drop.tip(tr1, sample(tr1$tip.label, size = 20))
+## rotate the root and reorder the whole:
+tr2 <- rotate(tr2, 21)
+tr2 <- read.tree(text = write.tree(tr2))
+X <- cbind(tr2$tip.label, tr2$tip.label) # association matrix
+cophyloplot(tr1, tr2, assoc = X, space = 28)
+## before reordering tr2 we have to find the constraint:
+co <- tr2$tip.label[order(match(tr2$tip.label, tr1$tip.label))]
+newtr2 <- rotateConstr(tr2, co)
+cophyloplot(tr1, newtr2, assoc = X, space = 28)
+}
+\keyword{manip}
diff --git a/man/rtree.Rd b/man/rtree.Rd
new file mode 100644
index 0000000..514f39b
--- /dev/null
+++ b/man/rtree.Rd
@@ -0,0 +1,68 @@
+\name{rtree}
+\alias{rtree}
+\alias{rcoal}
+\alias{rmtree}
+\title{Generates Random Trees}
+\description{
+ These functions generate trees by splitting randomly the edges
+ (\code{rtree}) or randomly clustering the tips (\code{rcoal}).
+ \code{rtree} generates general trees, and \code{rcoal} generates
+ coalescent trees. The algorithms are described in Paradis (2012).
+}
+\usage{
+rtree(n, rooted = TRUE, tip.label = NULL, br = runif, ...)
+rcoal(n, tip.label = NULL, br = "coalescent", ...)
+rmtree(N, n, rooted = TRUE, tip.label = NULL, br = runif, ...)
+}
+\arguments{
+ \item{n}{an integer giving the number of tips in the tree.}
+ \item{rooted}{a logical indicating whether the tree should be rooted
+ (the default).}
+ \item{tip.label}{a character vector giving the tip labels; if not
+ specified, the tips "t1", "t2", ..., are given.}
+ \item{br}{one of the following: (i) an \R function used to generate the
+ branch lengths (\code{rtree}; use \code{NULL} to simulate only a
+ topology), or the coalescence times (\code{rcoal}); (ii) a character
+ to simulate a genuine coalescent tree for \code{rcoal} (the
+ default); or (iii) a numeric vector for the branch lengths or the
+ coalescence times.}
+ \item{\dots}{further argument(s) to be passed to \code{br}.}
+ \item{N}{an integer giving the number of trees to generate.}
+}
+\details{
+ The trees generated are bifurcating. If \code{rooted = FALSE} in
+ (\code{rtree}), the tree is trifurcating at its root.
+
+ The default function to generate branch lengths in \code{rtree} is
+ \code{runif}. If further arguments are passed to \code{br}, they need
+ to be tagged (e.g., \code{min = 0, max = 10}).
+
+ \code{rmtree} calls successively \code{rtree} and set the class of
+ the returned object appropriately.
+}
+\value{
+ An object of class \code{"phylo"} or of class \code{"multiPhylo"} in
+ the case of \code{rmtree}.
+}
+\references{
+ Paradis, E. (2012) \emph{Analysis of Phylogenetics and Evolution with
+ R (Second Edition).} New York: Springer.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{stree}}, \code{\link{rlineage}}
+}
+\examples{
+layout(matrix(1:9, 3, 3))
+### Nine random trees:
+for (i in 1:9) plot(rtree(20))
+### Nine random cladograms:
+for (i in 1:9) plot(rtree(20, FALSE), type = "c")
+### generate 4 random trees of bird orders:
+data(bird.orders)
+layout(matrix(1:4, 2, 2))
+for (i in 1:4)
+ plot(rcoal(23, tip.label = bird.orders$tip.label), no.margin = TRUE)
+layout(matrix(1))
+}
+\keyword{datagen}
diff --git a/man/seg.sites.Rd b/man/seg.sites.Rd
new file mode 100644
index 0000000..81f046a
--- /dev/null
+++ b/man/seg.sites.Rd
@@ -0,0 +1,40 @@
+\name{seg.sites}
+\alias{seg.sites}
+\title{
+ Find Segregating Sites in DNA Sequences
+}
+\usage{
+seg.sites(x)
+}
+\arguments{
+ \item{x}{a matrix or a list which contains the DNA sequences.}
+}
+\description{
+ This function gives the indices of segregating (polymorphic) sites in
+ a sample of DNA sequences.
+}
+\details{
+ If the sequences are in a list, all the sequences must be of the same
+ length. Ambiguous nucleotides are ignored.
+}
+\value{
+ A numeric (integer) vector giving the indices of the segregating
+ sites.
+}
+\author{Emmanuel Paradis}
+\note{
+ The present version looks for the sites which are ``variable'' in the
+ data in terms of different \emph{letters}. This may give unexpected
+ results if there are ambiguous bases in the data.
+}
+\seealso{
+ \code{\link{base.freq}}, \code{\link[pegas]{theta.s}},
+ \code{\link[pegas]{nuc.div}}
+}
+\examples{
+data(woodmouse)
+y <- seg.sites(woodmouse)
+y
+length(y)
+}
+\keyword{univar}
diff --git a/man/skyline.Rd b/man/skyline.Rd
new file mode 100644
index 0000000..718ff22
--- /dev/null
+++ b/man/skyline.Rd
@@ -0,0 +1,150 @@
+\name{skyline}
+\alias{skyline}
+\alias{skyline.phylo}
+\alias{skyline.coalescentIntervals}
+\alias{skyline.collapsedIntervals}
+\alias{find.skyline.epsilon}
+
+\title{Skyline Plot Estimate of Effective Population Size}
+\usage{
+skyline(x, \dots)
+\method{skyline}{phylo}(x, \dots)
+\method{skyline}{coalescentIntervals}(x, epsilon=0, \dots)
+\method{skyline}{collapsedIntervals}(x, old.style=FALSE, \dots)
+find.skyline.epsilon(ci, GRID=1000, MINEPS=1e-6, \dots)
+}
+\arguments{
+ \item{x}{Either an ultrametric tree (i.e. an object of class
+ \code{"phylo"}), or coalescent intervals (i.e. an object of class
+ \code{"coalescentIntervals"}), or collapsed coalescent intervals
+ (i.e. an object of class \code{"collapsedIntervals"}).}
+ \item{epsilon}{collapsing parameter that controls the amount of smoothing
+ (allowed range: from \code{0} to \code{ci$total.depth}, default value: 0). This is the same parameter as in
+ \link{collapsed.intervals}.}
+
+ \item{old.style}{Parameter to choose between two slightly different variants of the
+ generalized skyline plot (Strimmer and Pybus, pers. comm.). The default value \code{FALSE} is
+ recommended.}
+
+ \item{ci}{coalescent intervals (i.e. an object of class \code{"coalescentIntervals"})}
+
+ \item{GRID}{Parameter for the grid search for \code{epsilon} in \code{find.skyline.epsilon}.}
+
+ \item{MINEPS}{Parameter for the grid search for \code{epsilon} in \code{find.skyline.epsilon}.}
+
+ \item{\dots}{Any of the above parameters.}
+
+}
+\description{
+
+ \code{skyline} computes the \emph{generalized skyline plot} estimate of effective population size
+ from an estimated phylogeny. The demographic history is approximated by
+ a step-function. The number of parameters of the skyline plot (i.e. its smoothness)
+ is controlled by a parameter \code{epsilon}.
+
+ \code{find.skyline.epsilon} searches for an optimal value of the \code{epsilon} parameter,
+ i.e. the value that maximizes the AICc-corrected log-likelihood (\code{logL.AICc}).
+}
+
+\details{
+\code{skyline} implements the \emph{generalized skyline plot} introduced in
+Strimmer and Pybus (2001). For \code{epsilon = 0} the
+generalized skyline plot degenerates to the
+\emph{classic skyline plot} described in
+Pybus et al. (2000). The latter is in turn directly related to lineage-through-time plots
+(Nee et al., 1995).
+}
+
+\value{
+\code{skyline} returns an object of class \code{"skyline"} with the following entries:
+
+ \item{time}{ A vector with the time at the end of each coalescent
+ interval (i.e. the accumulated interval lengths from the beginning of the first interval
+ to the end of an interval)}
+
+ \item{interval.length}{ A vector with the length of each
+ interval.}
+
+ \item{population.size}{A vector with the effective population size of each interval.}
+
+ \item{parameter.count}{ Number of free parameters in the skyline plot.}
+ \item{epsilon}{The value of the underlying smoothing parameter.}
+
+ \item{logL}{Log-likelihood of skyline plot (see Strimmer and Pybus, 2001).}
+
+ \item{logL.AICc}{AICc corrected log-likelihood (see Strimmer and Pybus, 2001).}
+
+\code{find.skyline.epsilon} returns the value of the \code{epsilon} parameter
+ that maximizes \code{logL.AICc}.
+}
+
+\author{Korbinian Strimmer (\url{http://www.stat.uni-muenchen.de/~strimmer/})}
+
+\seealso{
+\code{\link{coalescent.intervals}}, \code{\link{collapsed.intervals}},
+\code{\link{skylineplot}}, \code{\link{ltt.plot}}.
+}
+
+
+\references{
+ Strimmer, K. and Pybus, O. G. (2001) Exploring the demographic history
+ of DNA sequences using the generalized skyline plot. \emph{Molecular
+ Biology and Evolution}, \bold{18}, 2298--2305.
+
+ Pybus, O. G, Rambaut, A. and Harvey, P. H. (2000) An integrated
+ framework for the inference of viral population history from
+ reconstructed genealogies. \emph{Genetics}, \bold{155}, 1429--1437.
+
+ Nee, S., Holmes, E. C., Rambaut, A. and Harvey, P. H. (1995) Inferring
+ population history from molecular phylogenies. \emph{Philosophical
+ Transactions of the Royal Society of London. Series B. Biological
+ Sciences}, \bold{349}, 25--31.
+}
+
+\examples{
+# get tree
+data("hivtree.newick") # example tree in NH format
+tree.hiv <- read.tree(text = hivtree.newick) # load tree
+
+# corresponding coalescent intervals
+ci <- coalescent.intervals(tree.hiv) # from tree
+
+# collapsed intervals
+cl1 <- collapsed.intervals(ci,0)
+cl2 <- collapsed.intervals(ci,0.0119)
+
+
+#### classic skyline plot ####
+sk1 <- skyline(cl1) # from collapsed intervals
+sk1 <- skyline(ci) # from coalescent intervals
+sk1 <- skyline(tree.hiv) # from tree
+sk1
+
+plot(skyline(tree.hiv))
+skylineplot(tree.hiv) # shortcut
+
+plot(sk1, show.years=TRUE, subst.rate=0.0023, present.year = 1997)
+
+#### generalized skyline plot ####
+
+sk2 <- skyline(cl2) # from collapsed intervals
+sk2 <- skyline(ci, 0.0119) # from coalescent intervals
+sk2 <- skyline(tree.hiv, 0.0119) # from tree
+sk2
+
+plot(sk2)
+
+
+# classic and generalized skyline plot together in one plot
+plot(sk1, show.years=TRUE, subst.rate=0.0023, present.year = 1997, col=c(grey(.8),1))
+lines(sk2, show.years=TRUE, subst.rate=0.0023, present.year = 1997)
+legend(.15,500, c("classic", "generalized"), col=c(grey(.8),1),lty=1)
+
+
+# find optimal epsilon parameter using AICc criterion
+find.skyline.epsilon(ci)
+
+sk3 <- skyline(ci, -1) # negative epsilon also triggers estimation of epsilon
+sk3$epsilon
+}
+\keyword{manip}
diff --git a/man/skylineplot.Rd b/man/skylineplot.Rd
new file mode 100644
index 0000000..f9e7166
--- /dev/null
+++ b/man/skylineplot.Rd
@@ -0,0 +1,93 @@
+\name{skylineplot}
+\alias{skylineplot}
+\alias{plot.skyline}
+\alias{lines.skyline}
+\alias{skylineplot.deluxe}
+
+\title{Drawing Skyline Plot Graphs}
+\usage{
+\method{plot}{skyline}(x, show.years=FALSE, subst.rate, present.year, \dots)
+\method{lines}{skyline}(x, show.years=FALSE, subst.rate, present.year, \dots)
+skylineplot(z, \dots)
+skylineplot.deluxe(tree, \dots)
+}
+\arguments{
+ \item{x}{skyline plot data (i.e. an object of class \code{"skyline"}).}
+
+ \item{z}{Either an ultrametric tree (i.e. an object of class \code{"phylo"}),
+ or coalescent intervals (i.e. an object of class \code{"coalescentIntervals"}), or
+ collapsed coalescent intervals (i.e. an object of class \code{"collapsedIntervals"}).}
+
+
+ \item{tree}{ultrametric tree (i.e. an object of class \code{"phylo"}).}
+
+
+ \item{show.years}{option that determines whether the time is plotted in units of
+ of substitutions (default) or in years (requires specification of substution rate
+ and year of present).}
+
+
+ \item{subst.rate}{substitution rate (see option show.years).}
+ \item{present.year}{present year (see option show.years).}
+
+ \item{\dots}{further arguments to be passed on to \code{skyline()} and \code{plot()}.}
+
+}
+\description{
+
+ These functions provide various ways to draw \emph{skyline plot} graphs
+ on the current graphical device. Note that \code{skylineplot(z, \dots)} is simply
+ a shortcut for \code{plot(skyline(z, \dots))}.
+ The skyline plot itself is an estimate of effective population size through time,
+ and is computed using the function \code{\link{skyline}}.
+}
+
+\details{
+ See \code{\link{skyline}} for more details (incl. references) about the skyline plot method.
+}
+
+
+\author{Korbinian Strimmer (\url{http://www.stat.uni-muenchen.de/~strimmer/})}
+
+\seealso{
+\code{\link[graphics]{plot}} and \code{\link[graphics]{lines}} for the basic plotting
+function in R, \code{\link{coalescent.intervals}}, \code{\link{skyline}}
+}
+
+\examples{
+# get tree
+data("hivtree.newick") # example tree in NH format
+tree.hiv <- read.tree(text = hivtree.newick) # load tree
+
+
+#### classic skyline plot
+skylineplot(tree.hiv) # shortcut
+
+
+#### plot classic and generalized skyline plots and estimate epsilon
+sk.opt <- skylineplot.deluxe(tree.hiv)
+sk.opt$epsilon
+
+
+#### classic and generalized skyline plot ####
+sk1 <- skyline(tree.hiv)
+sk2 <- skyline(tree.hiv, 0.0119)
+
+# use years rather than substitutions as unit for the time axis
+plot(sk1, show.years=TRUE, subst.rate=0.0023, present.year = 1997, col=c(grey(.8),1))
+lines(sk2, show.years=TRUE, subst.rate=0.0023, present.year = 1997)
+legend(.15,500, c("classic", "generalized"), col=c(grey(.8),1),lty=1)
+
+
+#### various skyline plots for different epsilons
+layout(mat= matrix(1:6,2,3,byrow=TRUE))
+ci <- coalescent.intervals(tree.hiv)
+plot(skyline(ci, 0.0));title(main="0.0")
+plot(skyline(ci, 0.007));title(main="0.007")
+plot(skyline(ci, 0.0119),col=4);title(main="0.0119")
+plot(skyline(ci, 0.02));title(main="0.02")
+plot(skyline(ci, 0.05));title(main="0.05")
+plot(skyline(ci, 0.1));title(main="0.1")
+layout(mat= matrix(1:1,1,1,byrow=TRUE))
+}
+\keyword{hplot}
diff --git a/man/slowinskiguyer.test.Rd b/man/slowinskiguyer.test.Rd
new file mode 100644
index 0000000..0d2c90c
--- /dev/null
+++ b/man/slowinskiguyer.test.Rd
@@ -0,0 +1,64 @@
+\name{slowinskiguyer.test}
+\alias{slowinskiguyer.test}
+\title{Slowinski-Guyer Test of Homogeneous Diversification}
+\description{
+ This function performs the Slowinski--Guyer test that a trait or
+ variable does not increase diversification rate.
+}
+\usage{
+slowinskiguyer.test(x, detail = FALSE)
+}
+\arguments{
+ \item{x}{a matrix or a data frame with at least two columns: the first
+ one gives the number of species in clades with a trait supposed to
+ increase diversification rate, and the second one the number of
+ species in the corresponding sister-clade without the trait. Each
+ row represents a pair of sister-clades.}
+ \item{detail}{if \code{TRUE}, the individual P-values are appended.}
+}
+\details{
+ The Slowinski--Guyer test compares a series of sister-clades where one
+ of the two is characterized by a trait supposed to increase
+ diversification rate. The null hypothesis is that the trait does not
+ affect diversification. If the trait decreased diversification rate,
+ then the null hypothesis cannot be rejected.
+
+ The present function has mainly a historical interest. The
+ Slowinski--Guyer test generally performs poorly: see Paradis (2012)
+ alternatives and the functions cited below.
+}
+\value{
+ a data frame with the \eqn{\chi^2}{chi2}, the number of degrees of
+ freedom, and the \emph{P}-value. If \code{detail = TRUE}, a list is
+ returned with the data frame and a vector of individual
+ \emph{P}-values for each pair of sister-clades.
+}
+\references{
+ Paradis, E. (2012) Shift in diversification in sister-clade
+ comparisons: a more powerful test. \emph{Evolution}, \bold{66},
+ 288--295.
+
+ Slowinski, J. B. and Guyer, C. (1993) Testing whether certain traits
+ have caused amplified diversification: an improved method based on a
+ model of random speciation and extinction. \emph{American Naturalist},
+ \bold{142}, 1019--1024.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{balance}}, \code{\link{mcconwaysims.test}},
+ \code{\link{diversity.contrast.test}},
+ \code{\link{richness.yule.test}},
+ \code{\link[geiger]{rc}} in \pkg{geiger},
+ \code{\link[apTreeshape]{shift.test}} in \pkg{apTreeshape}
+}
+\examples{
+### from Table 1 in Slowinski and Guyer(1993):
+viviparous <- c(98, 8, 193, 36, 7, 128, 2, 3, 23, 70)
+oviparous <- c(234, 17, 100, 4, 1, 12, 6, 1, 481, 11)
+x <- data.frame(viviparous, oviparous)
+slowinskiguyer.test(x, TRUE) # 'P ~ 0.32' in the paper
+xalt <- x
+xalt[3, 2] <- 1
+slowinskiguyer.test(xalt)
+}
+\keyword{htest}
diff --git a/man/speciesTree.Rd b/man/speciesTree.Rd
new file mode 100644
index 0000000..f977f3b
--- /dev/null
+++ b/man/speciesTree.Rd
@@ -0,0 +1,57 @@
+\name{speciesTree}
+\alias{speciesTree}
+\title{Species Tree Estimation}
+\description{
+ This function calculates the species tree from a set of gene trees.
+}
+\usage{
+speciesTree(x, FUN = min)
+}
+\arguments{
+ \item{x}{a list of trees, e.g., an object of class
+ \code{"multiPhylo"}.}
+ \item{FUN}{a function used to compute the divergence times of each
+ pair of tips.}
+}
+\details{
+ For all trees in \code{x}, the divergence time of each pair of tips is
+ calculated: these are then `summarized' with \code{FUN} to build a new
+ distance matrix used to calculate the species tree with a
+ single-linkage hierarchical clustering. The default for \code{FUN}
+ computes the maximum tree (maxtree) of Liu et al. (2010). Using
+ \code{FUN = mean} gives the shallowest divergence tree of Maddison and
+ Knowles (2006).
+}
+\value{
+ an object of class \code{"phylo"}.
+}
+\references{
+ Liu, L., Yu, L. and Pearl, D. K. (2010) Maximum tree: a consistent
+ estimator of the species tree. \emph{Journal of Mathematical Biology},
+ \bold{60}, 95--106.
+
+ Maddison, W. P. and Knowles, L. L. (2006) Inferring phylogeny despite
+ incomplete lineage sorting. \emph{Systematic Biology}, \bold{55}, 21--30.
+}
+\author{Emmanuel Paradis}
+\examples{
+### example in Liu et al. (2010):
+tr1 <- read.tree(text = "(((B:0.05,C:0.05):0.01,D:0.06):0.04,A:0.1);")
+tr2 <- read.tree(text = "(((A:0.07,C:0.07):0.02,D:0.09):0.03,B:0.12);")
+TR <- c(tr1, tr2)
+TSmax <- speciesTree(TR) # MAXTREE
+TSsha <- speciesTree(TR, mean) # shallowest divergence
+
+layout(matrix(1:4, 1))
+## playing with 'x.lim' is not so complicated
+## but this will be improved someday
+plot(tr1, "c", d = "u", y.lim = c(-0.07, 0.1), font = 1)
+axisPhylo(4); title("Gene tree 1")
+plot(tr2, "c", d = "u", y.lim = c(-0.05, 0.12), font = 1)
+axisPhylo(4); title("Gene tree 2")
+plot(TSmax, "c", d = "u", y.lim = c(-0.1, 0.07), font = 1)
+axisPhylo(4); title("Species tree inferred\nby MAXTREE")
+plot(TSsha, "c", d = "u", y.lim = c(0, 0.17), font = 1)
+axisPhylo(4); title("Species tree inferred\nby Shallowest Divergence")
+}
+\keyword{models}
diff --git a/man/stree.Rd b/man/stree.Rd
new file mode 100644
index 0000000..51d19dd
--- /dev/null
+++ b/man/stree.Rd
@@ -0,0 +1,45 @@
+\name{stree}
+\alias{stree}
+\title{Generates Systematic Regular Trees}
+\usage{
+stree(n, type = "star", tip.label = NULL)
+}
+\arguments{
+ \item{n}{an integer giving the number of tips in the tree.}
+ \item{type}{a character string specifying the type of tree to
+ generate; four choices are possible: \code{"star"},
+ \code{"balanced"}, \code{"left"}, \code{"right"}, or any unambiguous
+ abbreviation of these.}
+ \item{tip.label}{a character vector giving the tip labels; if not
+ specified, the tips "t1", "t2", ..., are given.}
+}
+\description{
+ This function generates trees with regular shapes.
+}
+\details{
+ The types of trees generated are:
+
+ \itemize{
+ \item{``star''}{a star (or comb) tree with a single internal node.}
+ \item{``balanced''}{a fully balanced dichotomous rooted tree;
+ \code{n} must be a power of 2 (2, 4, 8, \dots).}
+ \item{``left''}{a fully unbalanced rooted tree where the largest
+ clade is on the left-hand side when the tree is plotted upwards.}
+ \item{``right''}{same than above but in the other direction.}
+ }
+}
+\value{
+ An object of class \code{"phylo"}.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{compute.brlen}}, \code{\link{rtree}}
+}
+\examples{
+layout(matrix(1:4, 2, 2))
+plot(stree(100))
+plot(stree(128, "balanced"))
+plot(stree(100, "left"))
+plot(stree(100, "right"))
+}
+\keyword{datagen}
diff --git a/man/subtreeplot.Rd b/man/subtreeplot.Rd
new file mode 100644
index 0000000..33f8469
--- /dev/null
+++ b/man/subtreeplot.Rd
@@ -0,0 +1,41 @@
+\name{subtreeplot}
+\alias{subtreeplot}
+\title{Zoom on a Portion of a Phylogeny by Successive Clicks}
+\description{
+ This function plots simultaneously a whole phylogenetic tree
+ (supposedly large) and a portion of it determined by clicking on the nodes of the phylogeny. On exit, returns the last subtree visualized.
+}
+\usage{
+subtreeplot(x, wait=FALSE, ...)
+}
+
+\arguments{
+ \item{x}{an object of class \code{"phylo"}.}
+ \item{wait}{a logical indicating whether the node beeing processed should be printed (useful for big phylogenies).}
+ \item{\dots}{further arguments passed to \code{plot.phylo}.}
+}
+\details{
+ This function aims at easily exploring very large trees. The main argument is
+ a phylogenetic tree, and the second one is a logical indicating whether a waiting message should be printed while the calculation is being processed.
+
+ The whole tree is plotted on the left-hand side in half of the device. The
+ subtree is plotted on the right-hand side in the other half. The user clicks on the nodes in the complete tree and the subtree corresponding to this node is ploted in the right-hand side. There is no limit for the number of clicks that can be done. On exit, the subtree on the right hand side is returned.
+
+ To use a subtree as the new tree in which to zoom, the user has to use the function many times. This can however be done in a single command line (see example 2).
+}
+\author{Damien de Vienne \email{damien.de-vienne at u-psud.fr}}
+\seealso{
+ \code{\link{plot.phylo}}, \code{\link{drop.tip}}, \code{\link{subtrees}}
+}
+\examples{
+\dontrun{
+#example 1: simple
+tree1 <- rtree(50)
+tree2 <- subtreeplot(tree1, wait = TRUE) # on exit, tree2 will be a subtree of tree1
+
+#example 2: more than one zoom
+tree1 <- rtree(60)
+tree2 <- subtreeplot(subtreeplot(subtreeplot(tree1))) # allow three succssive zooms
+}
+}
+\keyword{hplot}
diff --git a/man/subtrees.Rd b/man/subtrees.Rd
new file mode 100644
index 0000000..bc171a8
--- /dev/null
+++ b/man/subtrees.Rd
@@ -0,0 +1,41 @@
+\name{subtrees}
+\alias{subtrees}
+\title{All subtrees of a Phylogenetic Tree}
+\usage{
+subtrees(tree, wait=FALSE)
+}
+\arguments{
+ \item{tree}{an object of class \code{"phylo"}.}
+ \item{wait}{a logical indicating whether the node beeing processed should be printed (useful for big phylogenies).}
+}
+\description{
+ This function returns a list of all the subtrees of a phylogenetic tree.
+}
+\author{Damien de Vienne \email{damien.de-vienne at u-psud.fr}}
+\seealso{
+ \code{\link{zoom}}, \code{\link{subtreeplot}} for functions extracting particular subtrees.
+}
+\value{
+ \code{subtrees} returns a list of trees of class \code{"phylo"} and
+ returns invisibly for each subtree a list with the following
+ components:
+
+ \item{tip.label}{}
+ \item{node.label}{}
+ \item{Ntip}{}
+ \item{Nnode}{}
+}
+\examples{
+### Random tree with 12 leaves
+phy<-rtree(12)
+par(mfrow=c(4,3))
+plot(phy, sub="Complete tree")
+
+### Extract the subtrees
+l<-subtrees(phy)
+
+### plot all the subtrees
+for (i in 1:11) plot(l[[i]], sub=paste("Node", l[[i]]$node.label[1]))
+par(mfrow=c(1,1))
+}
+\keyword{manip}
diff --git a/man/summary.phylo.Rd b/man/summary.phylo.Rd
new file mode 100644
index 0000000..984b65a
--- /dev/null
+++ b/man/summary.phylo.Rd
@@ -0,0 +1,53 @@
+\name{summary.phylo}
+\alias{summary.phylo}
+\alias{Ntip}
+\alias{Nnode}
+\alias{Nedge}
+\title{Print Summary of a Phylogeny}
+\usage{
+\method{summary}{phylo}(object, \dots)
+Ntip(phy)
+Nnode(phy, internal.only = TRUE)
+Nedge(phy)
+}
+\arguments{
+ \item{object, phy}{an object of class \code{"phylo"}.}
+ \item{\dots}{further arguments passed to or from other methods.}
+ \item{internal.only}{a logical indicating whether to return the number
+ of internal nodes only (the default), or of internal and terminal
+ (tips) nodes (if \code{FALSE}).}
+}
+\description{
+ The first function prints a compact summary of a phylogenetic tree (an
+ object of class \code{"phylo"}). The three other functions return the
+ number of tips, nodes, or edges, respectively.
+}
+\details{
+ The summary includes the numbers of tips and of nodes, summary
+ statistics of the branch lengths (if they are available) with mean,
+ variance, minimum, first quartile, median, third quartile, and
+ maximum, listing of the first ten tip labels, and (if available) of
+ the first ten node labels. It is also printed whether some of these
+ optional elements (branch lengths, node labels, and root edge) are not
+ found in the tree.
+
+ \code{summary} simply prints its results on the standard output and is
+ not meant for programming.
+}
+\value{
+ A NULL value in the case of \code{summary}, a single numeric value for
+ the three other functions.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{read.tree}}, \code{\link[base]{summary}} for the generic R
+ function, \code{\link{multiphylo}}, \code{\link{c.phylo}}
+}
+\examples{
+data(bird.families)
+summary(bird.families)
+Ntip(bird.families)
+Nnode(bird.families)
+Nedge(bird.families)
+}
+\keyword{manip}
diff --git a/man/treePop.Rd b/man/treePop.Rd
new file mode 100644
index 0000000..1262414
--- /dev/null
+++ b/man/treePop.Rd
@@ -0,0 +1,19 @@
+\name{treePop}
+\alias{treePop}
+\title{Tree Popping}
+\description{
+ Method for reconstructing phylogenetic trees from an object of class
+ splits using tree popping.
+}
+\usage{
+treePop(obj)
+}
+\arguments{
+ \item{obj}{an object of class \code{"bitsplit"}.}
+}
+\value{
+ an object of class "phylo" which displays all the splits
+ in the input object.
+}
+\author{Andrei Popescu \email{niteloserpopescu at gmail.com}}
+\keyword{models}
diff --git a/man/trex.Rd b/man/trex.Rd
new file mode 100644
index 0000000..d1c7752
--- /dev/null
+++ b/man/trex.Rd
@@ -0,0 +1,69 @@
+\name{trex}
+\alias{trex}
+\title{Tree Explorer With Multiple Devices}
+\description{
+ This function requires a plotted tree: the user is invited to click
+ close to a node and the corresponding subtree (or clade) is plotted on
+ a new window.
+}
+\usage{
+trex(phy, title = TRUE, subbg = "lightyellow3",
+ return.tree = FALSE, ...)
+}
+\arguments{
+ \item{phy}{an object of class \code{"phylo"}.}
+ \item{title}{a logical or a character string (see details).}
+ \item{subbg}{a character string giving the background colour for the
+ subtree.}
+ \item{return.tree}{a logical: if \code{TRUE}, the subtree is returned
+ after being plotted and the operation is stopped.}
+ \item{\dots}{further arguments to pass to \code{plot.phylo}.}
+}
+\details{
+ This function works with a tree (freshly) plotted on an interactive
+ graphical device (i.e., not a file). After calling \code{trex}, the
+ user clicks close to a node of the tree, then the clade from this node
+ is plotted on a \emph{new} window. The user can click as many times on
+ the main tree: the clades are plotted successively on the \emph{same}
+ new window. The process is stopped by a right-click. If the user clicks
+ too close to the tips, a message ``Try again!'' is printed.
+
+ Each time \code{trex} is called, the subtree is plotted on a new
+ window without closing or deleting those possibly already
+ plotted. They may be distinguished with the options \code{title}
+ and/or \code{subbg}.
+
+ In all cases, the device where \code{phy} is plotted is the active
+ window after the operation. It should \emph{not} be closed during the
+ whole process.
+
+ If \code{title = TRUE}, a default title is printed on the new window
+ using the node label, or the node number if there are no node labels
+ in the tree. If \code{title = FALSE}, no title is printed. If
+ \code{title} is a character string, it is used for the title.
+}
+\value{
+ an object of class \code{"phylo"} if \code{return.tree = TRUE}
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{plot.phylo}}, \code{\link{identify.phylo}}
+}
+\examples{
+\dontrun{
+tr <- rcoal(1000)
+plot(tr, show.tip.label = FALSE)
+trex(tr) # left-click as many times as you want, then right-click
+tr <- makeNodeLabel(tr)
+trex(tr, subbg = "lightgreen") # id.
+
+## generate a random colour with control on the darkness:
+rRGB <- function(a, b)
+ rgb(runif(1, a, b), runif(1, a, b), runif(1, a, b))
+
+### with a random pale background:
+trex(tr, subbg = rRGB(0.8, 1))
+## the above can be called many times...
+graphics.off() # close all graphical devices
+}}
+\keyword{hplot}
diff --git a/man/triangMtd.Rd b/man/triangMtd.Rd
new file mode 100644
index 0000000..5a6f28d
--- /dev/null
+++ b/man/triangMtd.Rd
@@ -0,0 +1,32 @@
+\name{triangMtd}
+\alias{triangMtd}
+\alias{triangMtds}
+\title{Tree Reconstruction Based on the Triangles Method}
+\usage{
+triangMtd(X)
+triangMtds(X)
+}
+\arguments{
+ \item{X}{a distance matrix}.
+}
+\description{
+ Fast distance-based construction method. Should only be used when
+ distance measures are fairly reliable.
+}
+\value{
+ an object of class \code{"phylo"}.
+}
+\references{
+ \url{http://archive.numdam.org/ARCHIVE/RO/RO_2001__35_2/RO_2001__35_2_283_0/RO_2001__35_2_283_0.pdf}
+}
+\author{Andrei Popescu \email{niteloserpopescu at gmail.com}}
+\seealso{
+ \code{\link{nj}}, \code{\link{bionj}}, \code{\link{fastme}},
+ \code{\link{njs}}, \code{\link{mvrs}}, \code{\link{SDM}}
+}
+\examples{
+data(woodmouse)
+tr <- triangMtd(dist.dna(woodmouse))
+plot(tr)
+}
+\keyword{models}
diff --git a/man/unique.multiPhylo.Rd b/man/unique.multiPhylo.Rd
new file mode 100644
index 0000000..d893feb
--- /dev/null
+++ b/man/unique.multiPhylo.Rd
@@ -0,0 +1,38 @@
+\name{unique.multiPhylo}
+\alias{unique.multiPhylo}
+\title{Revomes Duplicate Trees}
+\description{
+ This function scans a list of trees, and returns a list with the
+ duplicate trees removed. By default the labelled topologies are
+ compared.
+}
+\usage{
+\method{unique}{multiPhylo}(x, incomparables = FALSE,
+ use.edge.length = FALSE,
+ use.tip.label = TRUE, ...)
+}
+\arguments{
+ \item{x}{an object of class \code{"multiPhylo"}.}
+ \item{incomparables}{unused (for compatibility with the generic).}
+ \item{use.edge.length}{a logical specifying whether to consider the edge
+ lengths in the comparisons; the default is \code{FALSE}.}
+ \item{use.tip.label}{a logical specifying whether to consider the tip
+ labels in the comparisons; the default is \code{TRUE}.}
+ \item{\dots}{further arguments passed to or from other methods.}
+}
+\value{
+ an object of class \code{"multiPhylo"} with an attribute
+ \code{"old.index"} indicating which trees of the original list are
+ similar (the tree of smaller index is taken as reference).
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{all.equal.phylo}, \code{\link[base]{unique}} for the generic R
+ function, \code{read.tree}, \code{read.nexus}
+}
+\examples{
+TR <- rmtree(50, 4)
+length(unique(TR)) # not always 15...
+howmanytrees(4)
+}
+\keyword{manip}
diff --git a/man/varCompPhylip.Rd b/man/varCompPhylip.Rd
new file mode 100644
index 0000000..77a5136
--- /dev/null
+++ b/man/varCompPhylip.Rd
@@ -0,0 +1,68 @@
+\name{varCompPhylip}
+\alias{varCompPhylip}
+\title{Variance Components with Orthonormal Contrasts}
+\description{
+ This function calls Phylip's contrast program and returns the
+ phylogenetic and phenotypic variance-covariance components for one or
+ several traits. There can be several observations per species.
+}
+\usage{
+varCompPhylip(x, phy, exec = NULL)
+}
+\arguments{
+ \item{x}{a numeric vector, a matrix (or data frame), or a list.}
+ \item{phy}{an object of class \code{"phylo"}.}
+ \item{exec}{a character string giving the name of the executable
+ contrast program (see details).}
+}
+\details{
+ The data \code{x} can be in several forms: (i) a numeric vector if
+ there is single trait and one observation per species; (ii) a
+ matrix or data frame if there are several traits (as columns) and a
+ single observation of each trait for each species; (iii) a list of
+ vectors if there is a single trait and several observations per
+ species; (iv) a list of matrices or data frames: same than (ii) but
+ with several traits and the rows are individuals.
+
+ If \code{x} has names, its values are matched to the tip labels of
+ \code{phy}, otherwise its values are taken to be in the same order
+ than the tip labels of \code{phy}.
+
+ Phylip (version 3.68 or higher) must be accessible on your computer. If
+ you have a Unix-like operating system, the executable name is assumed
+ to be \code{"phylip contrast"} (as in Debian); otherwise it is set
+ to \code{"contrast"}. If this doesn't suit your system, use the
+ option \code{exec} accordingly. If the executable is not in the path, you
+ may need to specify it, e.g., \code{exec = "C:/Program Files/Phylip/contrast"}.
+}
+\value{
+ a list with elements \code{varA} and \code{varE} with the phylogenetic
+ (additive) and phenotypic (environmental) variance-covariance
+ matrices. If a single trait is analyzed, these contains its variances.
+}
+\references{
+ Felsenstein, J. (2004) Phylip (Phylogeny Inference Package) version
+ 3.68. Department of Genetics, University of Washington, Seattle, USA.
+ \url{http://evolution.genetics.washington.edu/phylip/phylip.html}.
+
+ Felsenstein, J. (2008) Comparative methods with sampling error and
+ within-species variation: Contrasts revisited and revised.
+ \emph{American Naturalist}, \bold{171}, 713--725.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{pic}}, \code{\link{pic.ortho}}, \code{\link{compar.lynch}}
+}
+\examples{
+\dontrun{
+tr <- rcoal(30)
+### Five traits, one observation per species:
+x <- replicate(5, rTraitCont(tr, sigma = 1))
+varCompPhylip(x, tr) # varE is small
+x <- replicate(5, rnorm(30))
+varCompPhylip(x, tr) # varE is large
+### Five traits, ten observations per species:
+x <- replicate(30, replicate(5, rnorm(10)), simplify = FALSE)
+varCompPhylip(x, tr)
+}}
+\keyword{regression}
diff --git a/man/varcomp.Rd b/man/varcomp.Rd
new file mode 100644
index 0000000..4bd30e7
--- /dev/null
+++ b/man/varcomp.Rd
@@ -0,0 +1,35 @@
+\name{varcomp}
+\alias{varcomp}
+\title{Compute Variance Component Estimates}
+\description{
+ Get variance component estimates from a fitted \code{lme} object.
+}
+\usage{
+varcomp(x, scale = FALSE, cum = FALSE)
+}
+\arguments{
+ \item{x}{A fitted \code{lme} object}
+ \item{scale}{Scale all variance so that they sum to 1}
+ \item{cum}{Send cumulative variance components.}
+}
+\details{
+ Variance computations is done as in Venables and Ripley (2002).
+}
+\value{
+ A named vector of class \code{varcomp} with estimated variance components.
+}
+\references{
+ Venables, W. N. and Ripley, B. D. (2002) \emph{Modern Applied Statistics
+ with S (Fourth Edition)}. New York: Springer-Verlag.
+}
+\author{Julien Dutheil \email{julien.dutheil at univ-montp2.fr}}
+\seealso{\code{\link[nlme]{lme}}}
+\examples{
+data(carnivora)
+library(nlme)
+m <- lme(log10(SW) ~ 1, random = ~ 1|Order/SuperFamily/Family/Genus, data=carnivora)
+v <- varcomp(m, TRUE, TRUE)
+plot(v)
+}
+\keyword{regression}
+\keyword{dplot}
diff --git a/man/vcv.phylo.Rd b/man/vcv.phylo.Rd
new file mode 100644
index 0000000..f48e574
--- /dev/null
+++ b/man/vcv.phylo.Rd
@@ -0,0 +1,56 @@
+\name{vcv}
+\alias{vcv}
+\alias{vcv.phylo}
+\alias{vcv.corPhyl}
+\title{Phylogenetic Variance-covariance or Correlation Matrix}
+\usage{
+vcv(phy, ...)
+\method{vcv}{phylo}(phy, model = "Brownian", corr = FALSE, ...)
+\method{vcv}{corPhyl}(phy, corr = FALSE, ...)
+}
+\arguments{
+ \item{phy}{an object of the correct class (see above).}
+ \item{model}{a character giving the model used to compute the
+ variances and covariances; only \code{"Brownian"} is available (for
+ other models, a correlation structure may be used).}
+ \item{corr}{a logical indicating whether the correlation matrix should
+ be returned (\code{TRUE}); by default the variance-covariance matrix
+ is returned (\code{FALSE}).}
+ \item{\dots}{further arguments to be passed to or from other methods.}
+}
+\description{
+ This function computes the expected variances and covariances of a
+ continuous trait assuming it evolves under a given model.
+
+ This is a generic function with methods for objects of class
+ \code{"phylo"} and \code{"corPhyl"}.
+}
+\value{
+ a numeric matrix with the names of the tips as colnames and rownames.
+}
+\references{
+ Garland, T. Jr. and Ives, A. R. (2000) Using the past to predict the
+ present: confidence intervals for regression equations in phylogenetic
+ comparative methods. \emph{American Naturalist}, \bold{155}, 346--364.
+}
+
+\author{Emmanuel Paradis}
+\note{
+ Do not confuse this function with \code{\link[stats]{vcov}} which
+ computes the variance-covariance matrix among parameters of a fitted
+ model object.
+}
+\seealso{
+ \code{\link{corBrownian}}, \code{\link{corMartins}},
+ \code{\link{corGrafen}}, \code{\link{corPagel}},
+ \code{\link{corBlomberg}}
+}
+\examples{
+tr <- rtree(5)
+## all are the same:
+vcv(tr)
+vcv(corBrownian(1, tr))
+vcv(corPagel(1, tr))
+}
+\keyword{manip}
+\keyword{multivariate}
diff --git a/man/weight.taxo.Rd b/man/weight.taxo.Rd
new file mode 100644
index 0000000..5d47407
--- /dev/null
+++ b/man/weight.taxo.Rd
@@ -0,0 +1,34 @@
+\name{weight.taxo}
+\alias{weight.taxo}
+\alias{weight.taxo2}
+\title{Define Similarity Matrix}
+\usage{
+ weight.taxo(x)
+ weight.taxo2(x, y)
+}
+\arguments{
+ \item{x, y}{a vector or a factor.}
+}
+\description{
+ \code{weight.taxo} computes a matrix whose entries [i, j] are set to 1
+ if x[i] == x[j], 0 otherwise.
+
+ \code{weight.taxo2} computes a matrix whose entries [i, j] are set to 1
+ if x[i] == x[j] AND y[i] != y[j], 0 otherwise.
+
+ The diagonal [i, i] is always set to 0.
+
+ The returned matrix can be used as a weight matrix in
+ \code{\link{Moran.I}}. \code{x} and \code{y} may be vectors of
+ factors.
+
+ See further details in \code{vignette("MoranI")}.
+}
+\value{
+ a square numeric matrix.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{Moran.I}}, \code{\link{correlogram.formula}}
+}
+\keyword{manip}
diff --git a/man/where.Rd b/man/where.Rd
new file mode 100644
index 0000000..09e0ab8
--- /dev/null
+++ b/man/where.Rd
@@ -0,0 +1,35 @@
+\name{where}
+\alias{where}
+\title{Find Patterns in DNA Sequences}
+\description{
+ This function finds patterns in a single or a set of DNA sequences.
+}
+\usage{
+where(x, pattern)
+}
+\arguments{
+ \item{x}{an object of class \code{"DNAbin"}.}
+ \item{pattern}{a character string to be searched in \code{x}.}
+}
+\details{
+ If \code{x} is a vector, the function returns a single vector giving
+ the position(s) where the pattern was found. If \code{x} is a matrix
+ or a list, it returns a list with the positions of the pattern for
+ each sequence.
+
+ Patterns may be overlapping. For instance, if \code{pattern = "tata"}
+ and the sequence starts with `tatata', then the vector returned will
+ be c(1, 3).
+}
+\value{
+ a vector of integers or a list of such vectors.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{DNAbin}}, \code{\link{image.DNAbin}}
+}
+\examples{
+data(woodmouse)
+where(woodmouse, "tata")
+}
+\keyword{manip}
diff --git a/man/which.edge.Rd b/man/which.edge.Rd
new file mode 100644
index 0000000..c2a782e
--- /dev/null
+++ b/man/which.edge.Rd
@@ -0,0 +1,31 @@
+\name{which.edge}
+\alias{which.edge}
+\title{Identifies Edges of a Tree}
+\usage{
+which.edge(phy, group)
+}
+\arguments{
+ \item{phy}{an object of class \code{"phylo"}.}
+ \item{group}{a vector of mode numeric or character specifying the tips
+ for which the edges are to be identified.}
+}
+\description{
+ This function identifies the edges that belong to a group (possibly
+ non-monophyletic) specified as a set of tips.
+}
+\details{
+ The group of tips specified in `group' may be non-monophyletic
+ (paraphyletic or polyphyletic), in which case all edges from the tips
+ to their most recent common ancestor are identified.
+
+ The identification is made with the indices of the rows of the matrix
+ `edge' of the "phylo" object.
+}
+\value{
+ a numeric vector.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{bind.tree}}, \code{\link{drop.tip}}, \code{\link{root}}
+}
+\keyword{manip}
diff --git a/man/woodmouse.Rd b/man/woodmouse.Rd
new file mode 100644
index 0000000..d90ce66
--- /dev/null
+++ b/man/woodmouse.Rd
@@ -0,0 +1,31 @@
+\name{woodmouse}
+\alias{woodmouse}
+\title{Cytochrome b Gene Sequences of Woodmice}
+\description{
+ This is a set of 15 sequences of the mitochondrial gene cytochrome
+ \emph{b} of the woodmouse (\emph{Apodemus sylvaticus}) which is a
+ subset of the data analysed by Michaux et al. (2003). The full data
+ set is available through GenBank (accession numbers AJ511877 to
+ AJ511987).
+}
+\usage{
+data(woodmouse)
+}
+\format{
+ The data are stored in an ASCII file using the sequential format for
+ DNA sequences which is read with `read.dna()'.
+}
+\source{
+ Michaux, J. R., Magnanou, E., Paradis, E., Nieberding, C. and Libois,
+ R. (2003) Mitochondrial phylogeography of the Woodmouse
+ (\emph{Apodemus sylvaticus}) in the Western Palearctic region.
+ \emph{Molecular Ecology}, \bold{12}, 685--697.
+}
+\seealso{
+ \code{\link{read.dna}}, \code{\link{DNAbin}}, \code{\link{dist.dna}}
+}
+\examples{
+data(woodmouse)
+str(woodmouse)
+}
+\keyword{datasets}
diff --git a/man/write.dna.Rd b/man/write.dna.Rd
new file mode 100644
index 0000000..2ff245d
--- /dev/null
+++ b/man/write.dna.Rd
@@ -0,0 +1,93 @@
+\name{write.dna}
+\alias{write.dna}
+\title{Write DNA Sequences in a File}
+\usage{
+write.dna(x, file, format = "interleaved", append = FALSE,
+ nbcol = 6, colsep = " ", colw = 10, indent = NULL,
+ blocksep = 1)
+}
+\arguments{
+ \item{x}{a list or a matrix of DNA sequences.}
+ \item{file}{a file name specified by either a variable of mode character,
+ or a double-quoted string.}
+ \item{format}{a character string specifying the format of the DNA
+ sequences. Three choices are possible: \code{"interleaved"},
+ \code{"sequential"}, or \code{"fasta"}, or any unambiguous
+ abbreviation of these.}
+ \item{append}{a logical, if \code{TRUE} the data are appended to the
+ file without erasing the data possibly existing in the file,
+ otherwise the file (if it exists) is overwritten (\code{FALSE} the
+ default).}
+ \item{nbcol}{a numeric specifying the number of columns per row (6 by
+ default); may be negative implying that the nucleotides are printed
+ on a single line.}
+ \item{colsep}{a character used to separate the columns (a single
+ space by default).}
+ \item{colw}{a numeric specifying the number of nucleotides per column
+ (10 by default).}
+ \item{indent}{a numeric or a character specifying how the blocks of
+ nucleotides are indented (see details).}
+ \item{blocksep}{a numeric specifying the number of lines between the
+ blocks of nucleotides (this has an effect only if `format =
+ "interleaved"').}
+}
+\description{
+ This function writes in a file a list of DNA sequences in sequential,
+ interleaved, or FASTA format.
+}
+\details{
+ Three formats are supported in the present function: see the help page
+ of \code{\link{read.dna}} and the references below for a description.
+
+ If the sequences have no names, then they are given "1", "2", ... as
+ names in the file.
+
+ With the interleaved and sequential formats, the sequences must be all
+ of the same length. The names of the sequences are not truncated.
+
+ The argument \code{indent} specifies how the rows of nucleotides are
+ indented. In the interleaved and sequential formats, the rows with
+ the taxon names are never indented; the subsequent rows are indented
+ with 10 spaces by default (i.e., if \code{indent = NULL}). In the FASTA
+ format, the rows are not indented by default. This default behaviour
+ can be modified by specifying a value to \code{indent}: the rows are then
+ indented with ``indent'' (if it is a character) or `indent' spaces (if
+ it is a numeric). For example, specifying \code{indent = " "} or
+ \code{indent = 3} will have the same effect (use \code{indent = "\\t"}
+ for a tabulation).
+
+ The different options are intended to give flexibility in formatting
+ the sequences. For instance, if the sequences are very long it may be
+ judicious to remove all the spaces beween columns (colsep = ""), in
+ the margins (indent = 0), and between the blocks (blocksep = 0) to
+ produce a smaller file.
+}
+\note{
+ Specifying a negative value for `nbcol' (meaning that the nucleotides
+ are printed on a single line) gives the same output for the
+ interleaved and sequential formats.
+
+ The names of the sequences may be truncated with the function
+ \code{\link{makeLabel}}. In particular, Clustal is limited to 30
+ characters, and PHYML seems limited to 99 characters.
+}
+\value{
+ None (invisible `NULL').
+}
+\author{Emmanuel Paradis}
+\references{
+ Anonymous. FASTA format description.
+ \url{http://www.ncbi.nlm.nih.gov/BLAST/fasta.html}
+
+ Anonymous. IUPAC ambiguity codes.
+ \url{http://www.ncbi.nlm.nih.gov/SNP/iupac.html}
+
+ Felsenstein, J. (1993) Phylip (Phylogeny Inference Package) version
+ 3.5c. Department of Genetics, University of Washington.
+ \url{http://evolution.genetics.washington.edu/phylip/phylip.html}
+}
+\seealso{
+ \code{\link{read.dna}}, \code{\link{read.GenBank}},
+ \code{\link{makeLabel}}
+}
+\keyword{IO}
diff --git a/man/write.nexus.Rd b/man/write.nexus.Rd
new file mode 100644
index 0000000..b9713ad
--- /dev/null
+++ b/man/write.nexus.Rd
@@ -0,0 +1,43 @@
+\name{write.nexus}
+\alias{write.nexus}
+\title{Write Tree File in Nexus Format}
+\usage{
+write.nexus(..., file = "", translate = TRUE)
+}
+\arguments{
+ \item{\dots}{either (i) a single object of class \code{"phylo"}, (ii) a
+ series of such objects separated by commas, or (iii) a list
+ containing such objects.}
+ \item{file}{a file name specified by either a variable of mode character,
+ or a double-quoted string; if \code{file = ""} (the default) then the
+ tree is written on the standard output connection.}
+ \item{translate}{a logical, if \code{TRUE} (the default) a translation
+ of the tip labels is done which are replaced in the parenthetic
+ representation with tokens.}
+}
+\description{
+ This function writes trees in a file with the NEXUS format.
+}
+\details{
+ If several trees are given, they must all have the same tip labels.
+
+ If among the objects given some are not trees of class \code{"phylo"},
+ they are simply skipped and not written in the file.
+}
+\value{
+ None (invisible `NULL').
+}
+\references{
+ Maddison, D. R., Swofford, D. L. and Maddison, W. P. (1997) NEXUS: an
+ extensible file format for systematic information. \emph{Systematic
+ Biology}, \bold{46}, 590--621.
+}
+
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{read.nexus}}, \code{\link{read.tree}},
+ \code{\link{write.tree}}, \code{\link{read.nexus.data}},
+ \code{\link{write.nexus.data}}
+}
+\keyword{manip}
+\keyword{IO}
diff --git a/man/write.nexus.data.Rd b/man/write.nexus.data.Rd
new file mode 100644
index 0000000..186866b
--- /dev/null
+++ b/man/write.nexus.data.Rd
@@ -0,0 +1,78 @@
+\name{write.nexus.data}
+\alias{write.nexus.data}
+\title{
+ Write Character Data in NEXUS Format
+}
+\description{
+ This function writes in a file a list of sequences in the NEXUS
+ format.The names of the vectors of the list are used as taxon names.
+}
+\usage{
+write.nexus.data(x, file, format = "dna", datablock = TRUE,
+ interleaved = TRUE, charsperline = NULL,
+ gap = NULL, missing = NULL)
+}
+\arguments{
+ \item{x}{a list of sequences each made of a single vector of mode
+ character where each element is a character state (e.g. \dQuote{A},
+ \dQuote{C}, ...).}
+ \item{file}{a file name specified by either a variable of mode
+ character, or a double-quoted string.}
+ \item{format}{a character string specifying the format of the
+ sequences. Two choices are possible: \code{dna}, or \code{protein},
+ or any unambiguous abbreviation of these. Default is
+ \dQuote{\code{dna}}.}
+ \item{datablock}{a logical, if \code{TRUE} the data are written in a
+ single DATA block. If \code{FALSE} data is written in TAXA and
+ CHARACTER blocks. Default is \code{TRUE}.}
+ \item{interleaved}{a logical, if \code{TRUE} the data is written in
+ interleaved format with number of characters per line as specified
+ with \code{charsperline = numerical_value}. If \code{FALSE}, data is
+ written in sequential format. Default is \code{TRUE}.}
+ \item{charsperline}{a numeric specifying the number of characters per
+ line when used with \code{interleaved = TRUE}. Default is
+ \code{80}.}
+ \item{gap}{a character specifying the symbol for gap. Default is
+ \dQuote{\code{-}}.}
+ \item{missing}{a character specifying the symbol for missing
+ data. Default is \dQuote{\code{?}}.}
+}
+\details{
+ If the sequences have no names, then they are given \dQuote{1},
+ \dQuote{2}, ..., as names in the file.
+
+ Sequences must be all of the same length (i.e., aligned).
+
+ Default symbols for missing data and gaps can be changed by using the
+ \code{missing} and \code{gap} commands.
+
+ Please see files \file{data.nex} and \file{taxacharacters.nex} for
+ examples of output formats.
+}
+\value{
+ None (invisible \sQuote{NULL}).
+}
+\references{
+ Maddison, D. R., Swofford, D. L. and Maddison, W. P. (1997) NEXUS: an
+ extensible file format for systematic information. \emph{Systematic
+ Biology}, \bold{46}, 590--621.
+}
+\note{...}
+
+\author{Johan Nylander \email{nylander at scs.fsu.edu}}
+\seealso{
+ \code{\link{read.nexus}},\code{\link{write.nexus}},
+ \code{\link{read.nexus.data}}
+}
+\examples{
+\dontrun{
+## Write interleaved DNA data with 100 characters per line in a DATA block
+data("woodmouse")
+write.nexus.data(woodmouse, file= "wood.ex.nex", interleaved = TRUE, charsperline = 100)
+## Write sequential DNA data in TAXA and CHARACTERS blocks
+data("cynipids")
+write.nexus.data(cynipids, file = "cyn.ex.nex", format = "protein",
+ datablock = FALSE, interleaved = FALSE)
+unlink(c("wood.ex.nex", "cyn.ex.nex"))
+}}
+\keyword{file}
diff --git a/man/write.tree.Rd b/man/write.tree.Rd
new file mode 100644
index 0000000..7a51244
--- /dev/null
+++ b/man/write.tree.Rd
@@ -0,0 +1,57 @@
+\name{write.tree}
+\alias{write.tree}
+\title{Write Tree File in Parenthetic Format}
+\usage{
+write.tree(phy, file = "", append = FALSE,
+ digits = 10, tree.names = FALSE)
+}
+\arguments{
+ \item{phy}{an object of class \code{"phylo"} or \code{"multiPhylo"}.}
+ \item{file}{a file name specified by either a variable of mode character,
+ or a double-quoted string; if \code{file = ""} (the default) then the
+ tree is written on the standard output connection (i.e. the console).}
+ \item{append}{a logical, if \code{TRUE} the tree is appended to the file
+ without erasing the data possibly existing in the file, otherwise
+ the file (if it exists) is overwritten (\code{FALSE} the default).}
+ \item{digits}{a numeric giving the number of digits used for printing
+ branch lengths.}
+ \item{tree.names}{either a logical or a vector of mode character. If
+ \code{TRUE} then any tree names will be written prior to the tree on
+ each line. If character, specifies the name of \code{"phylo"}
+ objects which can be written to the file.}
+}
+\description{
+ This function writes in a file a tree in parenthetic format using the
+ Newick (also known as New Hampshire) format.
+}
+\value{
+ a vector of mode character if \code{file = ""}, none (invisible
+ \code{NULL}) otherwise.
+}
+\details{
+ The node labels and the root edge length, if available, are written in
+ the file.
+
+ If \code{tree.names == TRUE} then a variant of the Newick format is
+ written for which the name of a tree precedes the Newick format tree
+ (parentheses are eventually deleted beforehand). The tree names are
+ taken from the \code{names} attribute if present (they are ignored if
+ \code{tree.names} is a character vector).
+}
+\references{
+ Felsenstein, J. The Newick tree format.
+ \url{http://evolution.genetics.washington.edu/phylip/newicktree.html}
+
+ Olsen, G. Interpretation of the "Newick's 8:45" tree format standard.
+ \url{http://evolution.genetics.washington.edu/phylip/newick_doc.html}
+}
+
+\author{Emmanuel Paradis, Daniel Lawson
+ \email{dan.lawson at bristol.ac.uk}, and Klaus Schliep
+ \email{kschliep at snv.jussieu.fr}}
+\seealso{
+ \code{\link{read.tree}}, \code{\link{read.nexus}},
+ \code{\link{write.nexus}}
+}
+\keyword{manip}
+\keyword{IO}
\ No newline at end of file
diff --git a/man/yule.Rd b/man/yule.Rd
new file mode 100644
index 0000000..c9a07de
--- /dev/null
+++ b/man/yule.Rd
@@ -0,0 +1,49 @@
+\name{yule}
+\alias{yule}
+\title{Fits the Yule Model to a Phylogenetic Tree}
+\usage{
+yule(phy, use.root.edge = FALSE)
+}
+\arguments{
+ \item{phy}{an object of class \code{"phylo"}.}
+ \item{use.root.edge}{a logical specifying whether to consider the root
+ edge in the calculations.}
+}
+\description{
+ This function fits by maximum likelihood a Yule model, i.e., a
+ birth-only model to the branching times computed from a phylogenetic
+ tree.
+}
+\details{
+ The tree must be fully dichotomous.
+
+ The maximum likelihood estimate of the speciation rate is obtained by
+ the ratio of the number of speciation events on the cumulative number
+ of species through time; these two quantities are obtained with the
+ number of nodes in the tree, and the sum of the branch lengths,
+ respectively.
+
+ If there is a `root.edge' element in the phylogenetic tree, and
+ \code{use.root.edge = TRUE}, then it is assumed that it has a
+ biological meaning and is counted as a branch length, and the root is
+ counted as a speciation event; otherwise the number of speciation
+ events is the number of nodes - 1.
+
+ The standard-error of lambda is computed with the second derivative of
+ the log-likelihood function.
+}
+\value{
+ An object of class "yule" which is a list with the following
+ components:
+ \item{lambda}{the maximum likelihood estimate of the speciation
+ (birth) rate.}
+ \item{se}{the standard-error of lambda.}
+ \item{loglik}{the log-likelihood at its maximum.}
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{branching.times}}, \code{\link{diversi.gof}},
+ \code{\link{diversi.time}}, \code{\link{ltt.plot}},
+ \code{\link{birthdeath}}, \code{\link{bd.ext}}, \code{\link{yule.cov}}
+}
+\keyword{models}
diff --git a/man/yule.cov.Rd b/man/yule.cov.Rd
new file mode 100644
index 0000000..9710a94
--- /dev/null
+++ b/man/yule.cov.Rd
@@ -0,0 +1,99 @@
+\name{yule.cov}
+\alias{yule.cov}
+\title{Fits the Yule Model With Covariates}
+\usage{
+yule.cov(phy, formula, data = NULL)
+}
+\arguments{
+ \item{phy}{an object of class \code{"phylo"}.}
+ \item{formula}{a formula specifying the model to be fitted.}
+ \item{data}{the name of the data frame where the variables in
+ \code{formula} are to be found; by default, the variables are looked
+ for in the global environment.}
+}
+\description{
+ This function fits by maximum likelihood the Yule model with
+ covariates, that is a birth-only model where speciation rate is
+ determined by a generalized linear model.
+}
+\details{
+ The model fitted is a generalization of the Yule model where the
+ speciation rate is determined by:
+
+ \deqn{\ln\frac{\lambda_i}{1 - \lambda_i} = \beta_1 x_{i1} + \beta_2 x_{i2}
+ + \dots + \alpha }{ln(li / (1 - li)) = b1 xi1 + b2 xi2 + ... a}
+
+ where \eqn{\lambda_i}{li} is the speciation rate for species i,
+ \eqn{x_{i1}, x_{i2}, \dots}{xi1, xi2, ...} are species-specific
+ variables, and \eqn{\beta_1, \beta_2, \dots, \alpha}{b1, b2, ..., a}
+ are parameters to be estimated. The term on the left-hand side above
+ is a logit function often used in generalized linear models for
+ binomial data (see \code{\link[stats]{family}}). The above model can
+ be written in matrix form:
+
+ \deqn{\mathrm{logit} \lambda_i = x_i' \beta}{logit li = xi' b}
+
+ The standard-errors of the parameters are computed with the second
+ derivatives of the log-likelihood function. (See References for other
+ details on the estimation procedure.)
+
+ The function needs three things:
+
+\itemize{
+ \item a phylogenetic tree which may contain multichotomies;
+
+ \item a formula which specifies the predictors of the model described
+ above: this is given as a standard \R formula and has no response (no
+ left-hand side term), for instance: \code{~ x + y}, it can include
+ interactions (\code{~ x + a * b}) (see \code{\link[stats]{formula}}
+ for details);
+
+ \item the predictors specified in the formula must be accessible to
+ the function (either in the global space, or though the \code{data}
+ option); they can be numeric vectors or factors. The length and the
+ order of these data are important: the number of values (length) must
+ be equal to the number of tips of the tree + the number of nodes. The
+ order is the following: first the values for the tips in the same
+ order than for the labels, then the values for the nodes sequentially
+ from the root to the most terminal nodes (i.e., in the order given by
+ \code{phy$edge}).
+}
+
+The user must obtain the values for the nodes separately.
+
+Note that the method in its present implementation assumes that the
+change in a species trait is more or less continuous between two nodes
+or between a node and a tip. Thus reconstructing the ancestral values
+with a Brownian motion model may be consistent with the present
+method. This can be done with the function \code{\link{ace}}.
+}
+\value{
+ A NULL value is returned, the results are simply printed. The output
+ includes the deviance of the null (intercept-only) model and a
+ likelihood-ratio test of the fitted model against the null model.
+ Note that the deviance of the null model is different from the one
+ returned by \code{\link{yule}} because of the different parametrizations.
+}
+\references{
+ Paradis, E. (2005) Statistical analysis of diversification with
+ species traits. \emph{Evolution}, \bold{59}, 1--12.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{branching.times}}, \code{\link{diversi.gof}},
+ \code{\link{diversi.time}}, \code{\link{ltt.plot}},
+ \code{\link{birthdeath}}, \code{\link{bd.ext}}, \code{\link{yule}}
+}
+\examples{
+### a simple example with some random data
+data(bird.orders)
+x <- rnorm(45) # the tree has 23 tips and 22 nodes
+### the standard-error for x should be as large as
+### the estimated parameter
+yule.cov(bird.orders, ~ x)
+### another example with a tree that has a multichotomy
+data(bird.families)
+y <- rnorm(272) # 137 tips + 135 nodes
+yule.cov(bird.families, ~ y)
+}
+\keyword{models}
diff --git a/man/yule.time.Rd b/man/yule.time.Rd
new file mode 100644
index 0000000..be82f70
--- /dev/null
+++ b/man/yule.time.Rd
@@ -0,0 +1,86 @@
+\name{yule.time}
+\alias{yule.time}
+\title{Fits the Time-Dependent Yule Model}
+\usage{
+yule.time(phy, birth, BIRTH = NULL, root.time = 0, opti = "nlm", start = 0.01)
+}
+\arguments{
+ \item{phy}{an object of class \code{"phylo"}.}
+ \item{birth}{a (vectorized) function specifying how the birth
+ (speciation) probability changes through time (see details).}
+ \item{BIRTH}{a (vectorized) function giving the primitive of
+ \code{birth}.}
+ \item{root.time}{a numeric value giving the time of the root node
+ (time is measured from the past towards the present).}
+ \item{opti}{a character string giving the function used for
+ optimisation of the likelihood function. Three choices are possible:
+ \code{"nlm"}, \code{"nlminb"}, or \code{"optim"}, or any unambiguous
+ abbreviation of these.}
+ \item{start}{the initial values used in the optimisation.}
+}
+\description{
+ This function fits by maximum likelihood the time-dependent Yule
+ model. The time is measured from the past (\code{root.time}) to the
+ present.
+}
+\details{
+ The model fitted is a straightforward extension of the Yule model with
+ covariates (see \code{\link{yule.cov}}). Rather than having
+ heterogeneity among lineages, the speciation probability is the same
+ for all lineages at a given time, but can change through time.
+
+ The function \code{birth} \emph{must} meet these two requirements: (i)
+ the parameters to be estimated are the formal arguments; (ii) time is
+ named \code{t} in the body of the function. However, this is the
+ opposite for the primitive \code{BIRTH}: \code{t} is the formal
+ argument, and the parameters are used in its body. See the examples.
+
+ It is recommended to use \code{BIRTH} if possible, and required if
+ speciation probability is constant on some time interval. If this
+ primitive cannot be provided, a numerical integration is done with
+ \code{\link[stats]{integrate}}.
+
+ The standard-errors of the parameters are computed with the Hessian of
+ the log-likelihood function.
+}
+\value{
+ An object of class \code{"yule"} (see \code{\link{yule}}).
+}
+\author{Emmanuel Paradis}
+\references{
+ Hubert, N., Paradis, E., Bruggemann, H. and Planes, S. (2011) Community
+ assembly and diversification in Indo-Pacific coral reef
+ fishes. \emph{Ecology and Evolution}, \bold{1}, 229--277.
+}
+\seealso{
+ \code{\link{branching.times}}, \code{\link{ltt.plot}},
+ \code{\link{birthdeath}}, \code{\link{yule}}, \code{\link{yule.cov}},
+ \code{\link{bd.time}}
+}
+\examples{
+### define two models...
+birth.logis <- function(a, b) 1/(1 + exp(-a*t - b)) # logistic
+birth.step <- function(l1, l2, Tcl) { # 2 rates with one break-point
+ ans <- rep(l1, length(t))
+ ans[t > Tcl] <- l2
+ ans
+}
+### ... and their primitives:
+BIRTH.logis <- function(t) log(exp(-a*t) + exp(b))/a + t
+BIRTH.step <- function(t)
+{
+ out <- numeric(length(t))
+ sel <- t <= Tcl
+ if (any(sel)) out[sel] <- t[sel] * l1
+ if (any(!sel)) out[!sel] <- Tcl * l1 + (t[!sel] - Tcl) * l2
+ out
+}
+data(bird.families)
+### fit both models:
+yule.time(bird.families, birth.logis)
+yule.time(bird.families, birth.logis, BIRTH.logis) # same but faster
+\dontrun{yule.time(bird.families, birth.step)} # fails
+yule.time(bird.families, birth.step, BIRTH.step,
+ opti = "nlminb", start = c(.01, .01, 100))
+}
+\keyword{models}
diff --git a/man/zoom.Rd b/man/zoom.Rd
new file mode 100644
index 0000000..7c02013
--- /dev/null
+++ b/man/zoom.Rd
@@ -0,0 +1,55 @@
+\name{zoom}
+\alias{zoom}
+\title{Zoom on a Portion of a Phylogeny}
+\description{
+ This function plots simultaneously a whole phylogenetic tree
+ (supposedly large) and a portion of it.
+}
+\usage{
+zoom(phy, focus, subtree = FALSE, col = rainbow, ...)
+}
+\arguments{
+ \item{phy}{an object of class \code{"phylo"}.}
+ \item{focus}{a vector, either numeric or character, or a list of
+ vectors specifying the tips to be focused on.}
+ \item{subtree}{a logical indicating whether to show the context of the
+ extracted subtrees.}
+ \item{col}{a vector of colours used to show where the subtrees are in
+ the main tree, or a function .}
+ \item{\dots}{further arguments passed to \code{plot.phylo}.}
+}
+\details{
+ This function aims at exploring very large trees. The main argument is
+ a phylogenetic tree, and the second one is a vector or a list of
+ vectors specifying the tips to be focused on. The vector(s) can be
+ either numeric and thus taken as the indices of the tip labels, or
+ character in which case it is taken as the corresponding tip labels.
+
+ The whole tree is plotted on the left-hand side in a narrower
+ sub-window (about a quarter of the device) without tip labels. The
+ subtrees consisting of the tips in `focus' are extracted and plotted
+ on the right-hand side starting from the top left corner and
+ successively column-wise.
+
+ If the argument `col' is a vector of colours, as many colours as the
+ number of subtrees must be given. The alternative is to give a
+ function that will create colours or grey levels from the number of
+ subtrees: see \code{\link[grDevices]{rainbow}} for some possibilities
+ with colours.
+}
+\author{Emmanuel Paradis}
+\seealso{
+ \code{\link{plot.phylo}}, \code{\link{drop.tip}},
+ \code{\link[graphics]{layout}}, \code{\link[grDevices]{rainbow}},
+ \code{\link[grDevices]{grey}}
+}
+\examples{
+\dontrun{
+data(chiroptera)
+zoom(chiroptera, 1:20, subtree = TRUE)
+zoom(chiroptera, grep("Plecotus", chiroptera$tip.label))
+zoom(chiroptera, list(grep("Plecotus", chiroptera$tip.label),
+ grep("Pteropus", chiroptera$tip.label)))
+}
+}
+\keyword{hplot}
diff --git a/src/BIONJ.c b/src/BIONJ.c
new file mode 100644
index 0000000..8b7b8b6
--- /dev/null
+++ b/src/BIONJ.c
@@ -0,0 +1,341 @@
+/* BIONJ.c 2012-04-30 */
+
+/* Copyright 2007-2008 Olivier Gascuel, Hoa Sien Cuong,
+ R port by Vincent Lefort and Emmanuel Paradis */
+
+/* This file is part of the R-package `ape'. */
+/* See the file ../COPYING for licensing issues. */
+
+/* BIONJ program
+
+ Olivier Gascuel
+
+ GERAD - Montreal- Canada
+ olivierg at crt.umontreal.ca
+
+ LIRMM - Montpellier- France
+ gascuel at lirmm.fr
+
+ UNIX version, written in C
+ by Hoa Sien Cuong (Univ. Montreal) */
+
+#include "me.h"
+
+void Initialize(float **delta, double *X, int n);
+void C_bionj(double *X, int *N, int *edge1, int *edge2, double *el);
+float Distance(int i, int j, float **delta);
+float Variance(int i, int j, float **delta);
+int Emptied(int i, float **delta);
+float Sum_S(int i, float **delta);
+void Compute_sums_Sx(float **delta, int n);
+void Best_pair(float **delta, int r, int *a, int *b, int n);
+float Agglomerative_criterion(int i, int j, float **delta, int r);
+float Branch_length(int a, int b, float **delta, int r);
+float Reduction4(int a, float la, int b, float lb, int i, float lamda, float **delta);
+float Reduction10(int a, int b, int i, float lamda, float vab, float **delta);
+float Lamda(int a, int b, float vab, float **delta, int n, int r);
+
+/* INPUT, OUTPUT, INITIALIZATION
+
+ The lower-half of the delta matrix is occupied by
+ dissimilarities. The upper-half of the matrix is
+ occupied by variances. The first column
+ is initialized as 0; during the algorithm some
+ indices are no more used, and the corresponding
+ positions in the first column are set to 1. */
+
+/* -- Initialize --
+
+ This function reads an input data and returns the delta matrix
+
+ input: float **delta : delta matrix
+ double *X : distances sent from R as a lower triangle matrix
+ int n : number of taxa
+
+ output: float **delta : delta matrix initialized */
+
+void Initialize(float **delta, double *X, int n)
+{
+ int i, j; /* matrix line and column indices */
+ int k = 0; /* index along X */
+
+ for (i = 1; i < n; i++)
+ for (j = i + 1; j <= n; j++)
+ delta[i][j] = delta[j][i] = X[k++];
+
+ for (i = 1; i <= n; i++)
+ delta[i][i] = delta[i][0] = 0;
+}
+
+void C_bionj(double *X, int *N, int *edge1, int *edge2, double *el)
+{
+ int *a, *b; /* pair to be agglomerated */
+ float **delta; /* delta matrix */
+ float la; /* first taxon branch-length */
+ float lb; /* second taxon branch-length */
+ float vab; /* variance of Dab */
+ float lamda = 0.5;
+
+ int r; /* number of subtrees */
+ int n; /* number of taxa */
+ int i, x, y, curnod, k;
+
+ int *ilab; /* indices of the tips (used as "labels") */
+
+ a = (int*)R_alloc(1, sizeof(int));
+ b = (int*)R_alloc(1, sizeof(int));
+
+ n = *N;
+
+ /* Create the delta matrix */
+ delta = (float **)R_alloc(n + 1, sizeof(float*));
+ for (i = 1; i <= n; i++)
+ delta[i] = (float *)R_alloc(n + 1, sizeof(float));
+
+ /* initialise */
+ r = n;
+ *a = *b = 0;
+ Initialize(delta, X, n);
+
+ ilab = (int *)R_alloc(n + 1, sizeof(int));
+ for (i = 1; i <= n; i++) ilab[i] = i;
+
+ curnod = 2 * n - 2;
+ k = 0;
+
+ while (r > 3) {
+
+ Compute_sums_Sx(delta, n); /* compute the sum Sx */
+ Best_pair(delta, r, a, b, n); /* find the best pair by */
+ vab = Variance(*a, *b, delta); /* minimizing (1) */
+ la = Branch_length(*a, *b, delta, r); /* compute branch-lengths */
+ lb = Branch_length(*b, *a, delta, r); /* using formula (2) */
+
+ lamda = Lamda(*a, *b, vab, delta, n, r); /* compute lambda* using (9)*/
+
+ edge1[k] = edge1[k + 1] = curnod;
+ edge2[k] = ilab[*a];
+ edge2[k + 1] = ilab[*b];
+ el[k] = la;
+ el[k + 1] = lb;
+ k = k + 2;
+
+ for (i = 1; i <= n; i++) {
+ if (Emptied(i,delta) || (i == *a) || (i == *b)) continue;
+ if(*a > i) {
+ x = *a;
+ y = i;
+ } else {
+ x = i;
+ y = *a;
+ }
+
+ /* apply reduction formulae 4 and 10 to delta */
+ delta[x][y] = Reduction4(*a, la, *b, lb, i, lamda, delta);
+ delta[y][x] = Reduction10(*a, *b, i, lamda, vab, delta);
+ }
+
+ delta[*b][0] = 1.0; /* make the b line empty */
+ ilab[*a] = curnod;
+ curnod--;
+ r = r - 1;
+ }
+
+ /* finalise the three basal edges */
+ int last[3];
+ i = 1;
+ k = 0;
+ while (k < 3) {
+ if (!Emptied(i, delta)) last[k++] = i;
+ i++;
+ }
+
+ for (i = 0, k = 2 * n - 4; i < 3; i++, k--) {
+ edge1[k] = curnod; /* <- the root at this stage */
+ edge2[k] = ilab[last[i]];
+ }
+
+ double D[3];
+ D[0] = Distance(last[0], last[1], delta);
+ D[1] = Distance(last[0], last[2], delta);
+ D[2] = Distance(last[1], last[2], delta);
+
+ el[2 * n - 4] = (D[0] + D[1] - D[2])/2;
+ el[2 * n - 5] = (D[0] + D[2] - D[1])/2;
+ el[2 * n - 6] = (D[2] + D[1] - D[0])/2;
+}
+
+/* -- Distance --
+
+ This function retrieves and returns the distance between taxa
+ i and j from the delta matrix.
+
+ input: int i : taxon i
+ int j : taxon j
+ float **delta : the delta matrix
+
+ output: float distance : dissimilarity between the two taxa */
+
+float Distance(int i, int j, float **delta)
+{
+ if (i > j) return(delta[i][j]);
+ else return(delta[j][i]);
+}
+
+/* -- Variance --
+
+ This function retrieves and returns the variance of the
+ distance between i and j, from the delta matrix.
+
+ input: int i : taxon i
+ int j : taxon j
+ float **delta : the delta matrix
+
+ output: float distance : the variance of Dij */
+
+float Variance(int i, int j, float **delta)
+{
+ if (i > j) return(delta[j][i]);
+ else return(delta[i][j]);
+}
+
+
+/* -- Emptied --
+
+ This function tests if a line is emptied or not.
+
+ input: int i : subtree (or line) i
+ float **delta : the delta matrix
+
+ output: 0 : if not emptied
+ 1 : if emptied */
+
+int Emptied(int i, float **delta)
+{
+ return((int)delta[i][0]);
+}
+
+/* -- Sum_S --
+
+ This function retrieves the sum Sx from the diagonal
+ of the delta matrix
+
+ input: int i : subtree i
+ float **delta : the delta matrix
+
+ output: float delta[i][i] : sum Si */
+
+float Sum_S(int i, float **delta)
+{
+ return(delta[i][i]);
+}
+
+/* -- Compute_sums_Sx --
+
+ This function computes the sums Sx and stores them in the
+ diagonal the delta matrix.
+
+ input: float **delta : the delta matrix
+ int n : the number of taxa */
+
+
+void Compute_sums_Sx(float **delta, int n)
+{
+ float sum;
+ int i, j;
+
+ for (i = 1; i <= n ; i++) {
+ if (Emptied(i, delta)) continue;
+ sum = 0;
+ for (j = 1; j <= n; j++) {
+ if (i == j || Emptied(j, delta)) continue;
+ sum += Distance(i, j, delta); /* compute the sum Si */
+ }
+ delta[i][i] = sum;
+ }
+}
+
+
+/* -- Best_pair --
+
+ This function finds the best pair to be agglomerated by
+ minimizing the agglomerative criterion (1).
+
+ input: float **delta : the delta matrix
+ int r : number of subtrees
+ int *a : contain the first taxon of the pair
+ int *b : contain the second taxon of the pair
+ int n : number of taxa
+
+ output: int *a : the first taxon of the pair
+ int *b : the second taxon of the pair */
+
+
+void Best_pair(float **delta, int r, int *a, int *b, int n)
+{
+ float Qxy; /* value of the criterion calculated */
+ int x, y; /* the pair which is tested */
+ float Qmin; /* current minimun of the criterion */
+
+ Qmin = 1.0e30;
+ for (x = 1; x <= n; x++) {
+ if (Emptied(x, delta)) continue;
+ for (y = 1; y < x; y++) {
+ if (Emptied(y, delta)) continue;
+ Qxy = Agglomerative_criterion(x, y, delta, r);
+ if (Qxy < Qmin - 0.000001) {
+ Qmin = Qxy;
+ *a = x;
+ *b = y;
+ }
+ }
+ }
+}
+
+/* Formulae */
+
+/* Formula (1) */
+float Agglomerative_criterion(int i, int j, float **delta, int r)
+{
+ return((r - 2) * Distance(i, j, delta) -
+ Sum_S(i, delta) - Sum_S(j, delta));
+}
+
+/* Formula (2) */
+float Branch_length(int a, int b, float **delta, int r)
+{
+ return(0.5 * (Distance(a, b, delta) +
+ (Sum_S(a, delta) - Sum_S(b, delta))/(r - 2)));
+}
+
+/* Formula (4) */
+float Reduction4(int a, float la, int b, float lb, int i, float lamda, float **delta)
+{
+ return(lamda * (Distance(a, i, delta) - la) +
+ (1 - lamda) * (Distance(b, i, delta) - lb));
+}
+
+/* Formula (10) */
+float Reduction10(int a, int b, int i, float lamda, float vab, float **delta)
+{
+ return(lamda * Variance(a, i, delta) + (1 - lamda) * Variance(b, i, delta)
+ - lamda * (1 - lamda) * vab);
+}
+
+float Lamda(int a, int b, float vab, float **delta, int n, int r)
+{
+ float lamda = 0.0;
+ int i;
+
+ if (vab == 0.0) lamda = 0.5; else {
+ for (i = 1; i <= n ; i++) {
+ if (a == i || b == i || Emptied(i, delta)) continue;
+ lamda += (Variance(b, i, delta) - Variance(a, i, delta));
+ }
+ lamda = 0.5 + lamda/(2 * (r - 2) * vab); /* Formula (9) */
+ }
+ if (lamda > 1.0) lamda = 1.0; /* force 0 < lamda < 1 */
+ if (lamda < 0.0) lamda = 0.0;
+ return(lamda);
+}
+
diff --git a/src/Makevars b/src/Makevars
new file mode 100644
index 0000000..22ebc63
--- /dev/null
+++ b/src/Makevars
@@ -0,0 +1 @@
+PKG_LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS)
diff --git a/src/NNI.c b/src/NNI.c
new file mode 100644
index 0000000..08df539
--- /dev/null
+++ b/src/NNI.c
@@ -0,0 +1,387 @@
+/* NNI.c 2007-09-05 */
+
+/* Copyright 2007 Vincent Lefort */
+
+/* This file is part of the R-package `ape'. */
+/* See the file ../COPYING for licensing issues. */
+
+#include "me.h"
+
+//boolean leaf(node *v);
+/*edge *siblingEdge(edge *e);
+edge *depthFirstTraverse(tree *T, edge *e);
+edge *findBottomLeft(edge *e);
+edge *topFirstTraverse(tree *T, edge *e);
+edge *moveUpRight(edge *e);
+double wf(double lambda, double D_LR, double D_LU, double D_LD,
+ double D_RU, double D_RD, double D_DU);*/
+/*NNI functions for unweighted OLS topological switches*/
+
+/*fillTableUp fills all the entries in D associated with
+ e->head,f->head and those edges g->head above e->head*/
+void fillTableUp(edge *e, edge *f, double **A, double **D, tree *T)
+{
+ edge *g,*h;
+ if (T->root == f->tail)
+ {
+ if (leaf(e->head))
+ A[e->head->index][f->head->index] =
+ A[f->head->index][e->head->index] =
+ D[e->head->index2][f->tail->index2];
+ else
+ {
+ g = e->head->leftEdge;
+ h = e->head->rightEdge;
+ A[e->head->index][f->head->index] =
+ A[f->head->index][e->head->index] =
+ (g->bottomsize*A[f->head->index][g->head->index]
+ + h->bottomsize*A[f->head->index][h->head->index])
+ /e->bottomsize;
+ }
+ }
+ else
+ {
+ g = f->tail->parentEdge;
+ fillTableUp(e,g,A,D,T); /*recursive call*/
+ h = siblingEdge(f);
+ A[e->head->index][f->head->index] =
+ A[f->head->index][e->head->index] =
+ (g->topsize*A[e->head->index][g->head->index]
+ + h->bottomsize*A[e->head->index][h->head->index])/f->topsize;
+ }
+}
+
+
+void makeOLSAveragesTable(tree *T, double **D, double **A);
+
+double **buildAveragesTable(tree *T, double **D)
+{
+ int i,j;
+ double **A;
+ A = (double **) malloc(T->size*sizeof(double *));
+ for(i = 0; i < T->size;i++)
+ {
+ A[i] = (double *) malloc(T->size*sizeof(double));
+ for(j=0;j<T->size;j++)
+ A[i][j] = 0.0;
+ }
+ makeOLSAveragesTable(T,D,A);
+ return(A);
+}
+
+double wf2(double lambda, double D_AD, double D_BC, double D_AC, double D_BD,
+ double D_AB, double D_CD)
+{
+ double weight;
+ weight = 0.5*(lambda*(D_AC + D_BD) + (1 - lambda)*(D_AD + D_BC)
+ + (D_AB + D_CD));
+ return(weight);
+}
+
+int NNIEdgeTest(edge *e, tree *T, double **A, double *weight)
+{
+ int a,b,c,d;
+ edge *f;
+ double *lambda;
+ double D_LR, D_LU, D_LD, D_RD, D_RU, D_DU;
+ double w1,w2,w0;
+
+ if ((leaf(e->tail)) || (leaf(e->head)))
+ return(NONE);
+ lambda = (double *)malloc(3*sizeof(double));
+ a = e->tail->parentEdge->topsize;
+ f = siblingEdge(e);
+ b = f->bottomsize;
+ c = e->head->leftEdge->bottomsize;
+ d = e->head->rightEdge->bottomsize;
+
+ lambda[0] = ((double) b*c + a*d)/((a + b)*(c+d));
+ lambda[1] = ((double) b*c + a*d)/((a + c)*(b+d));
+ lambda[2] = ((double) c*d + a*b)/((a + d)*(b+c));
+
+ D_LR = A[e->head->leftEdge->head->index][e->head->rightEdge->head->index];
+ D_LU = A[e->head->leftEdge->head->index][e->tail->index];
+ D_LD = A[e->head->leftEdge->head->index][f->head->index];
+ D_RU = A[e->head->rightEdge->head->index][e->tail->index];
+ D_RD = A[e->head->rightEdge->head->index][f->head->index];
+ D_DU = A[e->tail->index][f->head->index];
+
+ w0 = wf2(lambda[0],D_RU,D_LD,D_LU,D_RD,D_DU,D_LR);
+ w1 = wf2(lambda[1],D_RU,D_LD,D_DU,D_LR,D_LU,D_RD);
+ w2 = wf2(lambda[2],D_DU,D_LR,D_LU,D_RD,D_RU,D_LD);
+ free(lambda);
+ if (w0 <= w1)
+ {
+ if (w0 <= w2) /*w0 <= w1,w2*/
+ {
+ *weight = 0.0;
+ return(NONE);
+ }
+ else /*w2 < w0 <= w1 */
+ {
+ *weight = w2 - w0;
+/* if (verbose)
+ {
+ printf("Swap across %s. ",e->label);
+ printf("Weight dropping by %lf.\n",w0 - w2);
+ printf("New weight should be %lf.\n",T->weight + w2 - w0);
+ }*/
+ return(RIGHT);
+ }
+ }
+ else if (w2 <= w1) /*w2 <= w1 < w0*/
+ {
+ *weight = w2 - w0;
+/* if (verbose)
+ {
+ printf("Swap across %s. ",e->label);
+ printf("Weight dropping by %lf.\n",w0 - w2);
+ printf("New weight should be %lf.\n",T->weight + w2 - w0);
+ }*/
+ return(RIGHT);
+ }
+ else /*w1 < w2, w0*/
+ {
+ *weight = w1 - w0;
+/* if (verbose)
+ {
+ printf("Swap across %s. ",e->label);
+ printf("Weight dropping by %lf.\n",w0 - w1);
+ printf("New weight should be %lf.\n",T->weight + w1 - w0);
+ }*/
+ return(LEFT);
+ }
+}
+
+int *initPerm(int size);
+
+void NNIupdateAverages(double **A, edge *e, edge *par, edge *skew,
+ edge *swap, edge *fixed, tree *T)
+{
+ node *v;
+ edge *elooper;
+ v = e->head;
+ /*first, v*/
+ A[e->head->index][e->head->index] =
+ (swap->bottomsize*
+ ((skew->bottomsize*A[skew->head->index][swap->head->index]
+ + fixed->bottomsize*A[fixed->head->index][swap->head->index])
+ / e->bottomsize) +
+ par->topsize*
+ ((skew->bottomsize*A[skew->head->index][par->head->index]
+ + fixed->bottomsize*A[fixed->head->index][par->head->index])
+ / e->bottomsize)
+ ) / e->topsize;
+
+ elooper = findBottomLeft(e); /*next, we loop over all the edges
+ which are below e*/
+ while (e != elooper)
+ {
+ A[e->head->index][elooper->head->index] =
+ A[elooper->head->index][v->index]
+ = (swap->bottomsize*A[elooper->head->index][swap->head->index] +
+ par->topsize*A[elooper->head->index][par->head->index])
+ / e->topsize;
+ elooper = depthFirstTraverse(T,elooper);
+ }
+ elooper = findBottomLeft(swap); /*next we loop over all the edges below and
+ including swap*/
+ while (swap != elooper)
+ {
+ A[e->head->index][elooper->head->index] =
+ A[elooper->head->index][e->head->index]
+ = (skew->bottomsize * A[elooper->head->index][skew->head->index] +
+ fixed->bottomsize*A[elooper->head->index][fixed->head->index])
+ / e->bottomsize;
+ elooper = depthFirstTraverse(T,elooper);
+ }
+ /*now elooper = skew */
+ A[e->head->index][elooper->head->index] =
+ A[elooper->head->index][e->head->index]
+ = (skew->bottomsize * A[elooper->head->index][skew->head->index] +
+ fixed->bottomsize* A[elooper->head->index][fixed->head->index])
+ / e->bottomsize;
+
+ /*finally, we loop over all the edges in the tree
+ on the far side of parEdge*/
+ elooper = T->root->leftEdge;
+ while ((elooper != swap) && (elooper != e)) /*start a top-first traversal*/
+ {
+ A[e->head->index][elooper->head->index] =
+ A[elooper->head->index][e->head->index]
+ = (skew->bottomsize * A[elooper->head->index][skew->head->index]
+ + fixed->bottomsize* A[elooper->head->index][fixed->head->index])
+ / e->bottomsize;
+ elooper = topFirstTraverse(T,elooper);
+ }
+
+ /*At this point, elooper = par.
+ We finish the top-first traversal, excluding the subtree below par*/
+ elooper = moveUpRight(par);
+ while (NULL != elooper)
+ {
+ A[e->head->index][elooper->head->index]
+ = A[elooper->head->index][e->head->index]
+ = (skew->bottomsize * A[elooper->head->index][skew->head->index] +
+ fixed->bottomsize* A[elooper->head->index][fixed->head->index])
+ / e->bottomsize;
+ elooper = topFirstTraverse(T,elooper);
+ }
+}
+
+
+void NNItopSwitch(tree *T, edge *e, int direction, double **A)
+{
+ edge *par, *fixed;
+ edge *skew, *swap;
+
+/* if (verbose)
+ printf("Branch swap across edge %s.\n",e->label);*/
+
+ if (LEFT == direction)
+ swap = e->head->leftEdge;
+ else
+ swap = e->head->rightEdge;
+ skew = siblingEdge(e);
+ fixed = siblingEdge(swap);
+ par = e->tail->parentEdge;
+
+/* if (verbose)
+ {
+ printf("Branch swap: switching edges %s and %s.\n",skew->label,swap->label);
+ }*/
+ /*perform topological switch by changing f from (u,b) to (v,b)
+ and g from (v,c) to (u,c), necessitatates also changing parent fields*/
+
+ swap->tail = e->tail;
+ skew->tail = e->head;
+
+ if (LEFT == direction)
+ e->head->leftEdge = skew;
+ else
+ e->head->rightEdge = skew;
+ if (skew == e->tail->rightEdge)
+ e->tail->rightEdge = swap;
+ else
+ e->tail->leftEdge = swap;
+
+ /*both topsize and bottomsize change for e, but nowhere else*/
+
+ e->topsize = par->topsize + swap->bottomsize;
+ e->bottomsize = fixed->bottomsize + skew->bottomsize;
+ NNIupdateAverages(A, e, par, skew, swap, fixed,T);
+
+} /*end NNItopSwitch*/
+
+void reHeapElement(int *p, int *q, double *v, int length, int i);
+void pushHeap(int *p, int *q, double *v, int length, int i);
+void popHeap(int *p, int *q, double *v, int length, int i);
+
+
+void NNIRetestEdge(int *p, int *q, edge *e,tree *T, double **avgDistArray,
+ double *weights, int *location, int *possibleSwaps)
+{
+ int tloc;
+ tloc = location[e->head->index+1];
+ location[e->head->index+1] =
+ NNIEdgeTest(e,T,avgDistArray,weights + e->head->index+1);
+ if (NONE == location[e->head->index+1])
+ {
+ if (NONE != tloc)
+ popHeap(p,q,weights,(*possibleSwaps)--,q[e->head->index+1]);
+ }
+ else
+ {
+ if (NONE == tloc)
+ pushHeap(p,q,weights,(*possibleSwaps)++,q[e->head->index+1]);
+ else
+ reHeapElement(p,q,weights,*possibleSwaps,q[e->head->index+1]);
+ }
+}
+
+void permInverse(int *p, int *q, int length);
+
+int makeThreshHeap(int *p, int *q, double *v, int arraySize, double thresh);
+
+
+//void NNI(tree *T, double **avgDistArray, int *count)
+void NNI(tree *T, double **avgDistArray, int *count, double **D, int numSpecies)
+{
+ edge *e, *centerEdge;
+ edge **edgeArray;
+ int *location;
+ int *p,*q;
+ int i,j;
+ int possibleSwaps;
+ double *weights;
+ p = initPerm(T->size+1);
+ q = initPerm(T->size+1);
+ edgeArray = (edge **) malloc((T->size+1)*sizeof(double));
+ weights = (double *) malloc((T->size+1)*sizeof(double));
+ location = (int *) malloc((T->size+1)*sizeof(int));
+
+ double epsilon = 0.0;
+ for (i=0; i<numSpecies; i++)
+ for (j=0; j<numSpecies; j++)
+ epsilon += D[i][j];
+ epsilon = (epsilon / (numSpecies * numSpecies)) * EPSILON;
+
+ for (i=0;i<T->size+1;i++)
+ {
+ weights[i] = 0.0;
+ location[i] = NONE;
+ }
+ e = findBottomLeft(T->root->leftEdge);
+ /* *count = 0; */
+ while (NULL != e)
+ {
+ edgeArray[e->head->index+1] = e;
+ location[e->head->index+1] =
+ NNIEdgeTest(e,T,avgDistArray,weights + e->head->index + 1);
+ e = depthFirstTraverse(T,e);
+ }
+ possibleSwaps = makeThreshHeap(p,q,weights,T->size+1,0.0);
+ permInverse(p,q,T->size+1);
+ /*we put the negative values of weights into a heap, indexed by p
+ with the minimum value pointed to by p[1]*/
+ /*p[i] is index (in edgeArray) of edge with i-th position
+ in the heap, q[j] is the position of edge j in the heap */
+ while (weights[p[1]] + epsilon < 0)
+ {
+ centerEdge = edgeArray[p[1]];
+ (*count)++;
+ T->weight = T->weight + weights[p[1]];
+ NNItopSwitch(T,edgeArray[p[1]],location[p[1]],avgDistArray);
+ location[p[1]] = NONE;
+ weights[p[1]] = 0.0; /*after the NNI, this edge is in optimal
+ configuration*/
+ popHeap(p,q,weights,possibleSwaps--,1);
+ /*but we must retest the other four edges*/
+ e = centerEdge->head->leftEdge;
+ NNIRetestEdge(p,q,e,T,avgDistArray,weights,location,&possibleSwaps);
+ e = centerEdge->head->rightEdge;
+ NNIRetestEdge(p,q,e,T,avgDistArray,weights,location,&possibleSwaps);
+ e = siblingEdge(centerEdge);
+ NNIRetestEdge(p,q,e,T,avgDistArray,weights,location,&possibleSwaps);
+ e = centerEdge->tail->parentEdge;
+ NNIRetestEdge(p,q,e,T,avgDistArray,weights,location,&possibleSwaps);
+ }
+ free(p);
+ free(q);
+ free(location);
+ free(edgeArray);
+}
+/*
+void NNIwithoutMatrix(tree *T, double **D, int *count)
+{
+ double **avgDistArray;
+ avgDistArray = buildAveragesTable(T,D);
+ NNI(T,avgDistArray,count);
+}
+
+void NNIWithPartialMatrix(tree *T,double **D,double **A,int *count)
+{
+ makeOLSAveragesTable(T,D,A);
+ NNI(T,A,count);
+}
+*/
diff --git a/src/SPR.c b/src/SPR.c
new file mode 100644
index 0000000..00a6886
--- /dev/null
+++ b/src/SPR.c
@@ -0,0 +1,420 @@
+/* SPR.c 2013-09-26 */
+
+/* Copyright 2009 Richard Desper */
+
+/* This file is part of the R-package `ape'. */
+/* See the file ../COPYING for licensing issues. */
+
+#include "me.h"
+
+/*functions from bNNI.c*/
+void makeBMEAveragesTable(tree *T, double **D, double **A);
+void assignBMEWeights(tree *T, double **A);
+
+/*from me.c*/
+edge *siblingEdge(edge *e);
+void weighTree(tree *T);
+void freeMatrix(double **D, int size);
+edge *depthFirstTraverse(tree *T, edge *e);
+double **initDoubleMatrix(int d);
+
+/*from below*/
+node *indexedNode(tree *T, int i);
+edge *indexedEdge(tree *T, int i);
+void assignSPRWeights(node *v, double **A, double ***swapWeights);
+void SPRTopShift(tree *T, node *vmove, edge *esplit, int UpOrDown);
+void assignDownWeightsUp(edge *etest, node *vtest, node *va, edge *back, node *cprev, double oldD_AB, double coeff, double **A, double ***swapWeights);
+void assignDownWeightsSkew(edge *etest, node *vtest, node *va, edge *back, node *cprev, double oldD_AB, double coeff, double **A, double ***swapWeights);
+void assignDownWeightsDown(edge *etest, node *vtest, node *va, edge *back, node *cprev, double oldD_AB, double coeff, double **A, double ***swapWeights);
+void assignUpWeights(edge *etest, node *vtest, node *va, edge *back, node *cprve, double oldD_AB, double coeff, double **A, double ***swapWeights);
+
+void zero3DMatrix(double ***X, int h, int l, int w)
+{
+ int i,j,k;
+ for(i=0;i<h;i++)
+ for(j=0;j<l;j++)
+ for(k=0;k<w;k++)
+ X[i][j][k] = 0.0;
+}
+
+
+void findTableMin(int *imin, int *jmin, int *kmin, int n, double ***X, double *min)
+{
+ int i,j,k;
+ for(i=0;i<2;i++)
+ for(j=0;j<n;j++)
+ for(k=0;k<n;k++)
+ {
+ if (X[i][j][k] < *min)
+ {
+ *min = X[i][j][k];
+ *imin = i;
+ *jmin = j;
+ *kmin = k;
+ }
+ }
+}
+
+
+void SPR(tree *T, double **D, double **A, int *count)
+{
+ int i,j,k;
+ node *v;
+ /*FILE *treefile;*/
+ edge *e,*f;
+ /* char filename[MAX_LABEL_LENGTH];*/
+ double ***swapWeights;
+ double swapValue = 0.0;
+ swapWeights = (double ***)malloc(2*sizeof(double **));
+ makeBMEAveragesTable(T,D,A);
+ assignBMEWeights(T,A);
+ weighTree(T);
+ /*if (verbose)
+ printf("Before SPRs: tree length is %lf.\n",T->weight);*/
+ for(i=0;i<2;i++)
+ swapWeights[i] = initDoubleMatrix(T->size);
+ do
+ {
+ swapValue=0.0;
+ zero3DMatrix(swapWeights,2,T->size,T->size);
+ i = j = k = 0;
+ for(e=depthFirstTraverse(T,NULL);NULL!=e;e=depthFirstTraverse(T,e))
+ assignSPRWeights(e->head,A,swapWeights);
+ findTableMin(&i,&j,&k,T->size,swapWeights,&swapValue);
+ swapValue = swapWeights[i][j][k];
+ if (swapValue < -EPSILON)
+ {
+// if (verbose)
+// printf("New tree weight should be %lf.\n",T->weight + 0.25*swapValue);
+ v = indexedNode(T,j);
+ f = indexedEdge(T,k);
+// if (verbose)
+// printf("Swapping tree below %s to split edge %s with head %s and tail %s\n",
+// v->parentEdge->label,f->label,f->head->label,f->tail->label);
+ SPRTopShift(T,v,f,2-i);
+ makeBMEAveragesTable(T,D,A);
+ assignBMEWeights(T,A);
+ weighTree(T);
+ (*count)++;
+ /*sprintf(filename,"tree%d.new",*count);*/
+// if (verbose)
+// printf("After %d SPRs, tree weight is %lf.\n\n",*count,T->weight);
+ /*treefile = fopen(filename,"w");
+ NewickPrintTree(T,treefile);
+ fclose(treefile);*/
+ }
+ } while (swapValue < -EPSILON);
+ for(i=0;i<2;i++)
+ freeMatrix(swapWeights[i],T->size);
+ free(swapWeights);
+ /*if (verbose)
+ readOffTree(T);*/
+}
+
+/*assigns values to array swapWeights*/
+/*swapWeights[0][j][k] will be the value of removing the tree below the edge whose head node has index j
+and reattaching it to split the edge whose head has the index k*/
+/*swapWeights[1][j][k] will be the value of removing the tree above the edge whose head node has index j
+and reattaching it to split the edge whose head has the index k*/
+void assignSPRWeights(node *vtest, double **A, double ***swapWeights)
+{
+ edge *etest, *left, *right, *sib, *par;
+ etest = vtest->parentEdge;
+ left = vtest->leftEdge;
+ right = vtest->rightEdge;
+ par = etest->tail->parentEdge;
+ sib = siblingEdge(etest);
+ if (NULL != par)
+ assignDownWeightsUp(par,vtest,sib->head,NULL,NULL,0.0,1.0,A,swapWeights);
+ if (NULL != sib)
+ assignDownWeightsSkew(sib,vtest,sib->tail,NULL,NULL,0.0,1.0,A,swapWeights);
+ /*assigns values for moving subtree rooted at vtest, starting with edge
+ parental to tail of edge parental to vtest*/
+ if (NULL != left)
+ {
+ assignUpWeights(left,vtest,right->head,NULL,NULL,0.0,1.0,A,swapWeights);
+ assignUpWeights(right,vtest,left->head,NULL,NULL,0.0,1.0,A,swapWeights);
+ }
+}
+
+
+/*recall NNI formula: change in tree length from AB|CD split to AC|BD split is
+proportional to D_AC + D_BD - D_AB - D_CD*/
+/*in our case B is the tree being moved (below vtest), A is the tree backwards below back, but
+ with the vtest subtree removed, C is the sibling tree of back and D is the tree above etest*/
+/*use va to denote the root of the sibling tree to B in the original tree*/
+/*please excuse the multiple uses of the same letters: A,D, etc.*/
+void assignDownWeightsUp(edge *etest, node *vtest, node *va, edge *back, node *cprev, double oldD_AB, double coeff, double **A, double ***swapWeights)
+{
+ edge *par, *sib, *skew;
+ double D_AC, D_BD, D_AB, D_CD;
+ par = etest->tail->parentEdge;
+ skew = siblingEdge(etest);
+ if (NULL == back) /*first recursive call*/
+ {
+ if (NULL == par)
+ return;
+ else /*start the process of assigning weights recursively*/
+ {
+ assignDownWeightsUp(par,vtest,va,etest,va,A[va->index][vtest->index],0.5,A,swapWeights);
+ assignDownWeightsSkew(skew,vtest,va,etest,va,A[va->index][vtest->index],0.5,A,swapWeights);
+ }
+ }
+ else /*second or later recursive call*/
+ {
+ sib = siblingEdge(back);
+ D_BD = A[vtest->index][etest->head->index]; /*straightforward*/
+ D_CD = A[sib->head->index][etest->head->index]; /*this one too*/
+ D_AC = A[sib->head->index][back->head->index] + coeff*(A[sib->head->index][va->index]
+ - A[sib->head->index][vtest->index]);
+ D_AB = 0.5*(oldD_AB + A[vtest->index][cprev->index]);
+ swapWeights[0][vtest->index][etest->head->index] = swapWeights[0][vtest->index][back->head->index] + (D_AC + D_BD - D_AB - D_CD);
+ if (NULL != par)
+ {
+ assignDownWeightsUp(par,vtest,va,etest,sib->head,D_AB,0.5*coeff,A,swapWeights);
+ assignDownWeightsSkew(skew,vtest,va,etest,sib->head,D_AB,0.5*coeff,A,swapWeights);
+ }
+ }
+}
+
+void assignDownWeightsSkew(edge *etest, node *vtest, node *va, edge *back, node *cprev, double oldD_AB, double coeff, double **A, double ***swapWeights)
+{
+ /*same general idea as assignDownWeights, except needing to keep track of things a bit differently*/
+ edge *par, *left, *right;
+ /*par here = sib before
+ left, right here = par, skew before*/
+ double D_AB, D_CD, D_AC, D_BD;
+ /*B is subtree being moved - below vtest
+ A is subtree remaining fixed - below va, unioned with all trees already passed by B*/
+ /*C is subtree being passed by B, in this case above par
+ D is subtree below etest, fixed on other side*/
+ par = etest->tail->parentEdge;
+ left = etest->head->leftEdge;
+ right = etest->head->rightEdge;
+ if (NULL == back)
+ {
+ if (NULL == left)
+ return;
+ else
+ {
+ assignDownWeightsDown(left,vtest,va,etest,etest->tail,A[vtest->index][etest->tail->index],0.5,A,swapWeights);
+ assignDownWeightsDown(right,vtest,va,etest,etest->tail,A[vtest->index][etest->tail->index],0.5,A,swapWeights);
+ }
+ }
+ else
+ {
+ D_BD = A[vtest->index][etest->head->index];
+ D_CD = A[par->head->index][etest->head->index];
+ D_AC = A[back->head->index][par->head->index] + coeff*(A[va->index][par->head->index] - A[vtest->index][par->head->index]);
+ D_AB = 0.5*(oldD_AB + A[vtest->index][cprev->index]);
+ swapWeights[0][vtest->index][etest->head->index] = swapWeights[0][vtest->index][back->head->index] + (D_AC + D_BD - D_AB - D_CD);
+ if (NULL != left)
+ {
+ assignDownWeightsDown(left,vtest, va, etest, etest->tail, D_AB, 0.5*coeff, A, swapWeights);
+ assignDownWeightsDown(right,vtest, va, etest, etest->tail, D_AB, 0.5*coeff, A, swapWeights);
+ }
+ }
+}
+
+void assignDownWeightsDown(edge *etest, node *vtest, node *va, edge *back, node *cprev, double oldD_AB, double coeff, double **A, double ***swapWeights)
+{
+ /*again the same general idea*/
+ edge *sib, *left, *right;
+ /*sib here = par in assignDownWeightsSkew
+ rest is the same as assignDownWeightsSkew*/
+ double D_AB, D_CD, D_AC, D_BD;
+ /*B is below vtest, A is below va unioned with all trees already passed by B*/
+ /*C is subtree being passed - below sib*/
+ /*D is tree below etest*/
+ sib = siblingEdge(etest);
+ left = etest->head->leftEdge;
+ right = etest->head->rightEdge;
+ D_BD = A[vtest->index][etest->head->index];
+ D_CD = A[sib->head->index][etest->head->index];
+ D_AC = A[sib->head->index][back->head->index] + coeff*(A[sib->head->index][va->index] - A[sib->head->index][vtest->index]);
+ D_AB = 0.5*(oldD_AB + A[vtest->index][cprev->index]);
+ swapWeights[0][vtest->index][etest->head->index] = swapWeights[0][vtest->index][back->head->index] + ( D_AC + D_BD - D_AB - D_CD);
+ if (NULL != left)
+ {
+ assignDownWeightsDown(left,vtest, va, etest, sib->head, D_AB, 0.5*coeff, A, swapWeights);
+ assignDownWeightsDown(right,vtest, va, etest, sib->head, D_AB, 0.5*coeff, A, swapWeights);
+ }
+}
+
+void assignUpWeights(edge *etest, node *vtest, node *va, edge *back, node *cprev, double oldD_AB, double coeff, double **A,
+ double ***swapWeights)
+{
+ /*SPR performed on tree above vtest...*/
+ /*same idea as above, with appropriate selections of edges and nodes*/
+ edge *sib, *left, *right;
+ /*B is above vtest, A is other tree below vtest unioned with trees in path to vtest*/
+ /*sib is tree C being passed by B*/
+ /*D is tree below etest*/
+ double D_AB, D_CD, D_AC, D_BD;
+ // double thisWeight; deleted by EP, 2013-09-16, also below
+ sib = siblingEdge(etest);
+ left = etest->head->leftEdge;
+ right = etest->head->rightEdge;
+ if (NULL == back) /*first recursive call*/
+ {
+ if (NULL == left)
+ return;
+ else /*start the process of assigning weights recursively*/
+ {
+ assignUpWeights(left,vtest,va,etest,va,A[va->index][vtest->index],0.5,A,swapWeights);
+ assignUpWeights(right,vtest,va,etest,va,A[va->index][vtest->index],0.5,A,swapWeights);
+ }
+ }
+ else /*second or later recursive call*/
+ {
+ D_BD = A[vtest->index][etest->head->index];
+ D_CD = A[sib->head->index][etest->head->index];
+ D_AC = A[back->head->index][sib->head->index] + coeff*(A[va->index][sib->head->index] - A[vtest->index][sib->head->index]);
+ D_AB = 0.5*(oldD_AB + A[vtest->index][cprev->index]);
+ // thisWeight = deleted by EP, 2013-09-16
+ swapWeights[1][vtest->index][etest->head->index] = swapWeights[1][vtest->index][back->head->index] + (D_AC + D_BD - D_AB - D_CD);
+ if (NULL != left)
+ {
+ assignUpWeights(left,vtest, va, etest, sib->head, D_AB, 0.5*coeff, A, swapWeights);
+ assignUpWeights(right,vtest, va, etest, sib->head, D_AB, 0.5*coeff, A, swapWeights);
+ }
+ }
+}
+
+void pruneSubtree(edge *p, edge *u, edge *d)
+/*starting with edge u above edges p, d*/
+/*removes p, d from tree, u connects to d->head to compensate*/
+{
+ p->tail->parentEdge = NULL;/*remove p subtree*/
+ u->head = d->head;
+ d->head->parentEdge = u; /*u connected to d->head*/
+ d->head = NULL; /*d removed from tree*/
+}
+
+void SPRsplitEdge(edge *e, edge *p, edge *d)
+/*splits edge e to make it parental to p,d. d is parental to what
+ previously was below e*/
+{
+ d->head = e->head;
+ e->head = p->tail;
+ p->tail->parentEdge = e;
+ d->head->parentEdge = d;
+}
+
+
+/*topological shift function*/
+/*removes subtree rooted at v and re-inserts to spilt e*/
+void SPRDownShift(tree *T, node *v, edge *e)
+{
+ edge *vup, *vdown, *vpar;
+ vpar = v->parentEdge;
+ vdown = siblingEdge(vpar);
+ vup = vpar->tail->parentEdge;
+ /*topological shift*/
+ pruneSubtree(vpar,vup,vdown);
+ /*removes v subtree and vdown, extends vup*/
+ SPRsplitEdge(e,vpar,vdown); /*splits e to make e sibling edge to vpar,
+ both below vup*/
+}
+
+void SPRUpShift(tree *T, node *vmove, edge *esplit)
+/*an inelegant iterative version*/
+{
+ edge *f;
+ edge **EPath;
+ edge **sib;
+ node **v;
+ int i;
+ int pathLength;
+ for(f=esplit->tail->parentEdge,pathLength=1;f->tail != vmove;f=f->tail->parentEdge)
+ pathLength++;
+ /*count number of edges to vmove*/
+ /*note that pathLength > 0 will hold*/
+
+ EPath = (edge **)malloc(pathLength*sizeof(edge *));
+ v = (node **)malloc(pathLength*sizeof(edge *));
+ sib = (edge **)malloc((pathLength+1)*sizeof(edge *));
+ /*there are pathLength + 1 side trees, one at the head and tail of each edge in the path*/
+
+ sib[pathLength] = siblingEdge(esplit);
+ i = pathLength;
+ f = esplit->tail->parentEdge;
+ while (i > 0)
+ {
+ i--;
+ EPath[i] = f;
+ sib[i] = siblingEdge(f);
+ v[i] = f->head;
+ f = f->tail->parentEdge;
+ }
+ /*indexed so head of Epath is v[i], tail is v[i-1] and sibling edge is sib[i]*/
+ /*need to assign head, tail of each edge in path
+ as well as have proper values for the left and right fields*/
+
+ if (esplit == esplit->tail->leftEdge)
+ {
+ vmove->leftEdge = esplit;
+ vmove->rightEdge = EPath[pathLength-1];
+ }
+ else
+ {
+ vmove->rightEdge = esplit;
+ vmove->leftEdge = EPath[pathLength-1];
+ }
+ esplit->tail = vmove;
+ /*espilt->head remains unchanged*/
+ /*vmove has the proper fields for left, right, and parentEdge*/
+
+ for(i=0;i<(pathLength-1);i++)
+ EPath[i]->tail = v[i+1];
+
+ /*this bit flips the orientation along the path
+ the tail of Epath[i] is now v[i+1] instead of v[i-1]*/
+
+ EPath[pathLength-1]->tail = vmove;
+
+ for(i=1;i<pathLength;i++)
+ {
+ if (sib[i+1] == v[i]->leftEdge)
+ v[i]->rightEdge = EPath[i-1];
+ else
+ v[i]->leftEdge = EPath[i-1];
+ }
+ if (sib[1] == v[0]->leftEdge)
+ v[0]->rightEdge = sib[0];
+ else
+ v[0]->leftEdge = sib[0];
+ sib[0]->tail = v[0];
+ free(EPath);
+ free(v);
+ free(sib);
+}
+
+
+void SPRTopShift(tree *T, node *vmove, edge *esplit, int UpOrDown)
+{
+ if (DOWN == UpOrDown)
+ SPRDownShift(T,vmove,esplit);
+ else
+ SPRUpShift(T,vmove,esplit);
+}
+
+node *indexedNode(tree *T, int i)
+{
+ edge *e;
+ for(e = depthFirstTraverse(T,NULL);NULL!=e;e=depthFirstTraverse(T,e))
+ if (i == e->head->index)
+ return(e->head);
+ if (i == T->root->index)
+ return(T->root);
+ return(NULL);
+}
+
+edge *indexedEdge(tree *T, int i)
+{
+ edge *e;
+ for(e = depthFirstTraverse(T,NULL);NULL!=e;e=depthFirstTraverse(T,e))
+ if (i == e->head->index)
+ return(e);
+ return(NULL);
+}
diff --git a/src/TBR.c b/src/TBR.c
new file mode 100644
index 0000000..3993e6e
--- /dev/null
+++ b/src/TBR.c
@@ -0,0 +1,454 @@
+/* TBR.c 2014-03-04 */
+
+/* Copyright 2009 Richard Desper */
+
+/* This file is part of the R-package `ape'. */
+/* See the file ../COPYING for licensing issues. */
+
+#include "me.h"
+
+/*functions from me_balanced.c*/
+void makeBMEAveragesTable(tree *T, double **D, double **A);
+void assignBMEWeights(tree *T, double **A);
+
+/*from me.c*/
+edge *siblingEdge(edge *e);
+double **initDoubleMatrix(int d);
+void freeMatrix(double **D, int size);
+edge *depthFirstTraverse(tree *T, edge *e);
+edge *findBottomLeft(edge *e);
+
+/*from bnni.c*/
+void weighTree(tree *T);
+
+void freeTree(tree *T);
+
+/*from SPR.c*/
+void zero3DMatrix(double ***X, int h, int l, int w);
+
+void assignTBRDownWeightsUp(edge *etest, node *vtest, node *va, edge *back, node *cprev, double oldD_AB, double coeff, double **A, double ***swapWeights,
+ double *bestWeight, edge **eBestSplit, edge **eBestTop, edge **eBestBottom);
+void assignTBRDownWeightsSkew(edge *etest, node *vtest, node *va, edge *back, node *cprev, double oldD_AB, double coeff, double **A, double ***swapWeights,
+ double *bestWeight, edge **eBestSplit, edge **eBestTop, edge **eBestBototm);
+void assignTBRDownWeightsDown(edge *etest, node *vtest, node *va, edge *back, node *cprev, double oldD_AB, double coeff, double **A, double ***swapWeights,
+ double *bestWeight, edge **eBestSplit, edge **eBestTop, edge **eBestBottom);
+
+void assignTBRUpWeights(edge *ebottom, node *vtest, node *va, edge *back, node *cprev, double oldD_AB, double coeff, double **A,
+ double **dXTop, double ***swapWeights, edge *etop, double *bestWeight,
+ edge **bestSplit, edge **bestTop, edge **bestBottom)
+ /*function assigns the value for etop if the tree below vtest is moved to be below etop*/
+ /*and SPR for tree bottom tree splits ebottom*/
+ /*recursive function searching over values of ebottom*/
+ /*minor variant of SPR.c's assignUpWeights
+ difference is the index assignment in the array swapWeights, which has a different meaning
+ for the TBR routines*/
+/*also using dXTop to assign value of average distance to tree above vtest*/
+{ /*SPR performed on tree above vtest...*/
+ edge *sib, *left, *right;
+ /*B is above vtest, A is other tree below vtest unioned with trees in path to vtest*/
+ /*sib is tree C being passed by B*/
+ /*D is tree below etest*/
+ double D_AB, D_CD, D_AC, D_BD;
+ sib = siblingEdge(ebottom);
+ left = ebottom->head->leftEdge;
+ right = ebottom->head->rightEdge;
+ if (NULL == etop)
+ {
+ if (NULL == back) /*first recursive call*/
+ {
+ if (NULL == left)
+ return; /*no subtree below for SPR*/
+ else /*NULL == back and NULL == etop*/
+ {
+ assignTBRUpWeights(left,vtest,va,ebottom,va,A[va->index][vtest->index],0.5,A,dXTop,swapWeights,NULL,bestWeight,bestSplit,bestTop,bestBottom);
+ assignTBRUpWeights(right,vtest,va,ebottom,va,A[va->index][vtest->index],0.5,A,dXTop,swapWeights,NULL,bestWeight,bestSplit,bestTop,bestBottom);
+ }
+ }
+ else /*NULL != back*/
+ {
+ D_BD = A[ebottom->head->index][vtest->index];
+ /*B is tree above vtest, D is tree below ebottom*/
+ D_CD = A[sib->head->index][ebottom->head->index]; /*C is tree below sib*/
+ D_AC = A[back->head->index][sib->head->index] +
+ coeff*(A[va->index][sib->head->index] - A[vtest->index][sib->head->index]);
+ /*va is root of subtree skew back at vtest*/
+ /*A is union of tree below va and all subtrees already passed in path from vtest to ebottom*/
+ D_AB = 0.5*(oldD_AB + A[vtest->index][cprev->index]);
+ swapWeights[vtest->index][ebottom->head->index][ebottom->head->index] = swapWeights[vtest->index][back->head->index][back->head->index] + (D_AC + D_BD - D_AB - D_CD);
+ if (swapWeights[vtest->index][ebottom->head->index][ebottom->head->index] < *bestWeight)
+ {
+ *bestSplit = vtest->parentEdge;
+ *bestTop = NULL;
+ *bestBottom = ebottom;
+ *bestWeight = swapWeights[vtest->index][ebottom->head->index][ebottom->head->index];
+ }
+ if (NULL != left)
+ {
+ assignTBRUpWeights(left,vtest,va,ebottom,sib->head,D_AB,0.5*coeff,A,dXTop,swapWeights,NULL,bestWeight,bestSplit,bestTop,bestBottom);
+ assignTBRUpWeights(right,vtest,va,ebottom,sib->head,D_AB,0.5*coeff,A,dXTop,swapWeights,NULL,bestWeight,bestSplit,bestTop,bestBottom);
+ }
+ }
+ }
+ else /*NULL != etop*/
+ {
+ if (NULL == back) /*first recursive call*/
+ {
+ if (swapWeights[vtest->index][etop->head->index][etop->head->index]< *bestWeight)
+ /*this represents value of SPR from esplit to etop, with no SPR in bottom tree*/
+ {
+ *bestSplit = vtest->parentEdge;
+ *bestTop = etop;
+ *bestBottom = NULL;
+ *bestWeight = swapWeights[vtest->index][etop->head->index][etop->head->index];
+ }
+ if (NULL == left)
+ return; /*no subtree below for SPR*/
+ else if (NULL != etop)/*start the process of assigning weights recursively*/
+ {
+ assignTBRUpWeights(left,vtest,va,ebottom,va,dXTop[va->index][etop->head->index],0.5,A,dXTop,swapWeights,etop,bestWeight,bestSplit,bestTop,bestBottom);
+ assignTBRUpWeights(right,vtest,va,ebottom,va,dXTop[va->index][etop->head->index],0.5,A,dXTop,swapWeights,etop,bestWeight,bestSplit,bestTop,bestBottom);
+ }
+ } /*NULL == back*/
+ /*in following bit, any average distance of form A[vtest->index][x->index] is
+ replaced by dXTop[x->index][etop->head->index]*/
+ else /*second or later recursive call, NULL != etop*/
+ {
+ D_BD = dXTop[ebottom->head->index][etop->head->index]; /*B is tree above vtest - it is in configuration
+ indexed by etop*/
+ /*D is tree below ebottom*/
+ D_CD = A[sib->head->index][ebottom->head->index]; /*C is tree below sib*/
+ D_AC = A[back->head->index][sib->head->index] +
+ coeff*(A[va->index][sib->head->index] - A[sib->head->index][vtest->index]);
+ /*it is correct to use A[][] here because the bad average distances involving B from the first term will
+ be cancelled by the bad average distances involving B in the subtracted part*/
+ /*va is root of subtree skew back at vtest*/
+ /*A is union of tree below va and all subtrees already passed in path from vtest to ebottom*/
+ D_AB = 0.5*(oldD_AB + dXTop[cprev->index][etop->head->index]);
+ swapWeights[vtest->index][ebottom->head->index][etop->head->index] = swapWeights[vtest->index][back->head->index][etop->head->index] + (D_AC + D_BD - D_AB - D_CD);
+ if (swapWeights[vtest->index][ebottom->head->index][etop->head->index] + swapWeights[vtest->index][etop->head->index][etop->head->index]< *bestWeight)
+ /*first term is contribution of second SPR, second term is contribution of first SPR*/
+ {
+ *bestSplit = vtest->parentEdge;
+ *bestTop = etop;
+ *bestBottom = ebottom;
+ *bestWeight = swapWeights[vtest->index][ebottom->head->index][etop->head->index] + swapWeights[vtest->index][etop->head->index][etop->head->index];
+ }
+ if (NULL != left)
+ {
+ assignTBRUpWeights(left,vtest, va, ebottom, sib->head, D_AB, 0.5*coeff, A, dXTop, swapWeights,etop,bestWeight,bestSplit,bestTop,bestBottom);
+ assignTBRUpWeights(right,vtest, va, ebottom, sib->head, D_AB, 0.5*coeff, A, dXTop, swapWeights,etop,bestWeight,bestSplit,bestTop,bestBottom);
+ }
+ } /*else NULL != back, etop*/
+ }
+}
+
+/*recall NNI formula: change in tree length from AB|CD split to AC|BD split is
+proportional to D_AC + D_BD - D_AB - D_CD*/
+/*in our case B is the tree being moved (below vtest), A is the tree backwards below back, but
+with the vtest subtree removed, C is the sibling tree of back and D is the tree above vtest*/
+/*use va to denote the root of the sibling tree to B in the original tree*/
+/*please excuse the multiple uses of the same letters: A,D, etc.*/
+void assignTBRDownWeightsUp(edge *etest, node *vtest, node *va, edge *back, node *cprev, double oldD_AB, double coeff, double **A, double ***swapWeights,
+ double *bestWeight, edge **bestSplitEdge, edge **bestTop, edge **bestBottom)
+{
+ edge *par, *sib, *skew;
+ double D_AC, D_BD, D_AB, D_CD;
+ par = etest->tail->parentEdge;
+ skew = siblingEdge(etest);
+ if (NULL == back) /*first recursive call*/
+ {
+ if (NULL == par)
+ return;
+ else /*start the process of assigning weights recursively*/
+ {
+ assignTBRDownWeightsUp(par,vtest,va,etest,va,A[va->index][vtest->index],0.5,A,swapWeights,bestWeight,bestSplitEdge,bestTop,bestBottom);
+ assignTBRDownWeightsSkew(skew,vtest,va,etest,va,A[va->index][vtest->index],0.5,A,swapWeights,bestWeight,bestSplitEdge,bestTop,bestBottom);
+ }
+ }
+ else /*second or later recursive call*/
+ {
+ sib = siblingEdge(back);
+ D_BD = A[vtest->index][etest->head->index]; /*straightforward*/
+ D_CD = A[sib->head->index][etest->head->index]; /*this one too*/
+ D_AC = A[sib->head->index][back->head->index] + coeff*(A[sib->head->index][va->index]
+ - A[sib->head->index][vtest->index]);
+ D_AB = 0.5*(oldD_AB + A[vtest->index][cprev->index]);
+ swapWeights[vtest->index][etest->head->index][etest->head->index] = swapWeights[vtest->index][back->head->index][back->head->index] + (D_AC + D_BD - D_AB - D_CD);
+ /*using diagonal to store values for SPR swaps above the split edge*/
+ /*this is value of swapping tree below vtest to break etest*/
+ if (swapWeights[vtest->index][etest->head->index][etest->head->index] < *bestWeight)
+ {
+ *bestWeight = swapWeights[vtest->index][etest->head->index][etest->head->index];
+ *bestSplitEdge = vtest->parentEdge;
+ *bestTop = etest;
+ *bestBottom = NULL;
+ }
+ if (NULL != par)
+ {
+ assignTBRDownWeightsUp(par,vtest,va,etest,sib->head,D_AB,0.5*coeff,A,swapWeights,bestWeight,bestSplitEdge,bestTop,bestBottom);
+ assignTBRDownWeightsSkew(skew,vtest,va,etest,sib->head,D_AB,0.5*coeff,A,swapWeights,bestWeight,bestSplitEdge,bestTop,bestBottom);
+ }
+ }
+}
+
+
+void assignTBRDownWeightsSkew(edge *etest, node *vtest, node *va, edge *back, node *cprev, double oldD_AB, double coeff, double **A, double ***swapWeights,
+ double *bestWeight, edge **bestSplitEdge, edge **bestTop, edge **bestBottom)
+{
+ /*same general idea as assignDownWeights, except needing to keep track of things a bit differently*/
+ edge *par, *left, *right;
+ /*par here = sib before
+ left, right here = par, skew before*/
+ double D_AB, D_CD, D_AC, D_BD;
+ /*B is subtree being moved - below vtest
+ A is subtree remaining fixed - below va, unioned with all trees already passed by B*/
+ /*C is subtree being passed by B, in this case above par
+ D is subtree below etest, fixed on other side*/
+ par = etest->tail->parentEdge;
+ left = etest->head->leftEdge;
+ right = etest->head->rightEdge;
+ if (NULL == back)
+ {
+ if (NULL == left)
+ return;
+ else
+ {
+ assignTBRDownWeightsDown(left,vtest,va,etest,etest->tail,A[vtest->index][etest->tail->index],0.5,A,swapWeights,bestWeight,bestSplitEdge,bestTop,bestBottom);
+ assignTBRDownWeightsDown(right,vtest,va,etest,etest->tail,A[vtest->index][etest->tail->index],0.5,A,swapWeights,bestWeight,bestSplitEdge,bestTop,bestBottom);
+ }
+ }
+ else
+ {
+ D_BD = A[vtest->index][etest->head->index];
+ D_CD = A[par->head->index][etest->head->index];
+ D_AC = A[back->head->index][par->head->index] + coeff*(A[va->index][par->head->index] - A[vtest->index][par->head->index]);
+ D_AB = 0.5*(oldD_AB + A[vtest->index][cprev->index]);
+ swapWeights[vtest->index][etest->head->index][etest->head->index] = swapWeights[vtest->index][back->head->index][back->head->index] + (D_AC + D_BD - D_AB - D_CD);
+ if (swapWeights[vtest->index][etest->head->index][etest->head->index] < *bestWeight)
+ {
+ *bestWeight = swapWeights[vtest->index][etest->head->index][etest->head->index];
+ *bestSplitEdge = vtest->parentEdge;
+ *bestTop = etest;
+ *bestBottom = NULL;
+ }
+ if (NULL != left)
+ {
+ assignTBRDownWeightsDown(left,vtest, va, etest, etest->tail, D_AB, 0.5*coeff, A, swapWeights,bestWeight,bestSplitEdge,bestTop,bestBottom);
+ assignTBRDownWeightsDown(right,vtest, va, etest, etest->tail, D_AB, 0.5*coeff, A, swapWeights,bestWeight,bestSplitEdge,bestTop,bestBottom);
+ }
+ }
+}
+
+void assignTBRDownWeightsDown(edge *etest, node *vtest, node *va, edge *back, node *cprev, double oldD_AB, double coeff, double **A, double ***swapWeights,
+ double *bestWeight, edge **bestSplitEdge, edge **bestTop, edge **bestBottom)
+{
+ /*again the same general idea*/
+ edge *sib, *left, *right;
+ /*sib here = par in assignDownWeightsSkew
+ rest is the same as assignDownWeightsSkew*/
+ double D_AB, D_CD, D_AC, D_BD;
+ /*B is below vtest, A is below va unioned with all trees already passed by B*/
+ /*C is subtree being passed - below sib*/
+ /*D is tree below etest*/
+ sib = siblingEdge(etest);
+ left = etest->head->leftEdge;
+ right = etest->head->rightEdge;
+ D_BD = A[vtest->index][etest->head->index];
+ D_CD = A[sib->head->index][etest->head->index];
+ D_AC = A[sib->head->index][back->head->index] + coeff*(A[sib->head->index][va->index] - A[sib->head->index][vtest->index]);
+ D_AB = 0.5*(oldD_AB + A[vtest->index][cprev->index]);
+ swapWeights[vtest->index][etest->head->index][etest->head->index] = swapWeights[vtest->index][back->head->index][back->head->index] + ( D_AC + D_BD - D_AB - D_CD);
+ if (swapWeights[vtest->index][etest->head->index][etest->head->index] < *bestWeight)
+ {
+ *bestWeight = swapWeights[vtest->index][etest->head->index][etest->head->index];
+ *bestSplitEdge = vtest->parentEdge;
+ *bestTop = etest;
+ *bestBottom = NULL;
+ }
+ if (NULL != left)
+ {
+ assignTBRDownWeightsDown(left,vtest, va, etest, sib->head, D_AB, 0.5*coeff, A, swapWeights,bestWeight,bestSplitEdge,bestTop,bestBottom);
+ assignTBRDownWeightsDown(right,vtest, va, etest, sib->head, D_AB, 0.5*coeff, A, swapWeights,bestWeight,bestSplitEdge,bestTop,bestBottom);
+ }
+}
+
+/*general idea is to have a double loop for a given edge, testing all SPRs for the subtrees above and below a given edge.
+ Then that function loops over all the edges of a tree*/
+
+void TBRswitch(tree *T, edge *e1, edge *e2, edge *e3);
+
+/*vbottom is node below esplit for average calculations in matrix dXTop, A is matrix of average
+ distances from original tree, dXout is average distance from vbottom to tree rooted at far edge
+ of eback, if SPR breaking eback, UpOrDown indicates whether etop is in path above split edge
+ (Up) or not (Down)*/
+void calcTBRTopBottomAverage(node *vbottom, double **A, double **dXTop, double dXOut,
+ edge *esplit, edge *etop, edge *eback, int UpOrDown)
+{
+ edge *enew1, *enew2, *emove;
+ double newdXOut;
+ if (esplit == eback) /*top level call - means trivial SPR*/
+ dXTop[vbottom->index][etop->head->index] = A[vbottom->index][esplit->head->index];
+ else
+ dXTop[vbottom->index][etop->head->index] = dXTop[vbottom->index][eback->head->index] +
+ 0.25*(A[vbottom->index][etop->head->index] - dXOut);
+ /*by moving etop past the vbottom tree, everything in the etop tree is closer by coefficient of
+ 0.25, while everything in the old back tree is further by a coefficient of 0.25*/
+ /*everything in the tree that is being moved (emove) keeps the same relative weight in the average
+ distance calculation*/
+ if (UP == UpOrDown)
+ {
+ enew1 = etop->tail->parentEdge;
+ if (NULL != enew1) /*need to do recursive calls*/
+ {
+ enew2 = siblingEdge(etop);
+ emove = siblingEdge(eback); /*emove is third edge meeting at vertex with eback, etest*/
+ if (esplit == eback)
+ newdXOut = A[vbottom->index][emove->head->index];
+ else
+ newdXOut = 0.5*(dXOut + A[vbottom->index][emove->head->index]);
+ calcTBRTopBottomAverage(vbottom,A,dXTop,newdXOut,esplit, enew1,etop,UP); /*old etop is new value for back*/
+ calcTBRTopBottomAverage(vbottom,A,dXTop,newdXOut,esplit, enew2,etop,DOWN);
+ }
+ }
+ else /*moving down*/
+ {
+ enew1 = etop->head->leftEdge;
+ if (NULL != enew1)
+ {
+ enew2 = etop->head->rightEdge;
+ if (eback == siblingEdge(etop))
+ emove = etop->tail->parentEdge;
+ else
+ emove = siblingEdge(etop);
+ if (esplit == eback)
+ newdXOut = A[vbottom->index][emove->head->index];
+ else
+ newdXOut = 0.5*(dXOut + A[vbottom->index][emove->head->index]);
+ calcTBRTopBottomAverage(vbottom,A,dXTop,newdXOut,esplit,enew1,etop,DOWN);
+ calcTBRTopBottomAverage(vbottom,A,dXTop,newdXOut,esplit,enew2,etop,DOWN);
+ }
+ }
+}
+
+void calcTBRaverages(tree *T, edge *esplit, double **A, double **dXTop)
+{
+ edge *ebottom, *par, *sib;
+ for (ebottom = findBottomLeft(esplit); ebottom != esplit; ebottom = depthFirstTraverse(T,ebottom))
+ {
+ par = esplit->tail->parentEdge;
+ sib = siblingEdge(esplit);
+ calcTBRTopBottomAverage(ebottom->head,A, dXTop, 0.0, esplit, par,esplit,UP);
+ calcTBRTopBottomAverage(ebottom->head,A, dXTop, 0.0, esplit, sib,esplit,DOWN);
+ }
+}
+
+void TBR(tree *T, double **D, double **A)
+{
+ int i;
+ edge *esplit, *etop, *eBestTop, *eBestBottom, *eBestSplit;
+ edge *eout, *block;
+ edge *left, *right, *par, *sib;
+ double **dXTop; /*dXTop[i][j] is average distance from subtree rooted at i to tree above split edge, if
+ SPR above split edge cuts edge whose head has index j*/
+ double bestWeight;
+ double ***TBRWeights;
+ dXTop = initDoubleMatrix(T->size);
+ weighTree(T);
+ TBRWeights = (double ***)calloc(T->size,sizeof(double **));
+ for(i=0;i<T->size;i++)
+ TBRWeights[i] = initDoubleMatrix(T->size);
+ do
+ {
+ zero3DMatrix(TBRWeights,T->size,T->size,T->size);
+ bestWeight = 0.0;
+ eBestSplit = eBestTop = eBestBottom = NULL;
+ for(esplit=depthFirstTraverse(T,NULL);NULL!=esplit;esplit=depthFirstTraverse(T,esplit))
+ {
+ par = esplit->tail->parentEdge;
+ if (NULL != par)
+ {
+ sib = siblingEdge(esplit);
+ /*next two lines calculate the possible improvements for any SPR above esplit*/
+ assignTBRDownWeightsUp(par,esplit->head,sib->head,NULL,NULL,0.0,1.0,A,TBRWeights,&bestWeight,&eBestSplit,&eBestTop,&eBestBottom);
+ assignTBRDownWeightsSkew(sib,esplit->head,sib->tail,NULL,NULL,0.0,1.0,A,TBRWeights,&bestWeight,&eBestSplit,&eBestTop,&eBestBottom);
+ calcTBRaverages(T,esplit,A,dXTop); /*calculates the average distance from any subtree
+ below esplit to the entire subtree above esplit,
+ after any possible SPR above*/
+ /*for etop above esplit, we loop using information from above to calculate values
+ for all possible SPRs below esplit*/
+ }
+
+ right = esplit->head->rightEdge;
+ if (NULL != right)
+ {
+ left = esplit->head->leftEdge;
+ /*test case: etop = null means only do bottom SPR*/
+ assignTBRUpWeights(left,esplit->head,right->head,NULL,NULL,0.0,1.0,A,dXTop,TBRWeights,NULL,&bestWeight,&eBestSplit,&eBestTop,&eBestBottom);
+ assignTBRUpWeights(right,esplit->head,left->head,NULL,NULL,0.0,1.0,A,dXTop,TBRWeights,NULL,&bestWeight,&eBestSplit,&eBestTop,&eBestBottom);
+
+ block = esplit;
+ while (NULL != block)
+ {
+ if (block != esplit)
+ {
+ etop = block;
+ assignTBRUpWeights(left,esplit->head,right->head,NULL,NULL,0.0,1.0,A,dXTop,TBRWeights,etop,&bestWeight,&eBestSplit,&eBestTop,&eBestBottom);
+ assignTBRUpWeights(right,esplit->head,left->head,NULL,NULL,0.0,1.0,A,dXTop,TBRWeights,etop,&bestWeight,&eBestSplit,&eBestTop,&eBestBottom);
+ }
+ eout = siblingEdge(block);
+ if (NULL != eout)
+ {
+ etop = findBottomLeft(eout);
+ while (etop->tail != eout->tail)
+ {
+ /*for ebottom below esplit*/
+
+ assignTBRUpWeights(left,esplit->head,right->head,NULL,NULL,0.0,1.0,A,dXTop,TBRWeights,etop,&bestWeight,&eBestSplit,&eBestTop,&eBestBottom);
+ assignTBRUpWeights(right,esplit->head,left->head,NULL,NULL,0.0,1.0,A,dXTop,TBRWeights,etop,&bestWeight,&eBestSplit,&eBestTop,&eBestBottom);
+ etop = depthFirstTraverse(T,etop);
+ }
+
+ /*etop == eout*/
+
+ assignTBRUpWeights(left,esplit->head,right->head,NULL,NULL,0.0,1.0,A,dXTop,TBRWeights,etop,&bestWeight,&eBestSplit,&eBestTop,&eBestBottom);
+ assignTBRUpWeights(right,esplit->head,left->head,NULL,NULL,0.0,1.0,A,dXTop,TBRWeights,etop,&bestWeight,&eBestSplit,&eBestTop,&eBestBottom);
+ }
+ block = block->tail->parentEdge;
+ }
+ } /*if NULL != right*/
+ } /*for esplit*/
+ /*find bestWeight, best split edge, etc.*/
+ if (bestWeight < -EPSILON)
+ {
+// if (verbose)
+// {
+// printf("TBR #%d: Splitting edge %s: top edge %s, bottom edge %s\n",*count+1,
+// eBestSplit->label, eBestTop->label,eBestBottom->label);
+// printf("Old tree weight is %lf, new tree weight should be %lf\n",T->weight, T->weight + 0.25*bestWeight);
+// }
+ TBRswitch(T,eBestSplit,eBestTop,eBestBottom);
+ makeBMEAveragesTable(T,D,A);
+ assignBMEWeights(T,A);
+ weighTree(T);
+// if (verbose)
+// printf("TBR: new tree weight is %lf\n\n",T->weight);<
+// (*count)++;
+ }
+ else
+ bestWeight = 1.0;
+ } while (bestWeight < -EPSILON);
+ for(i=0;i<T->size;i++)
+ freeMatrix(TBRWeights[i],T->size);
+ freeMatrix(dXTop,T->size);
+ free(TBRWeights); /* added by EP 2014-03-04 */
+}
+
+void SPRTopShift(tree *T, node *v, edge *e, int UpOrDown);
+
+void TBRswitch(tree *T, edge *es, edge *et, edge *eb)
+{
+ if (NULL != et)
+ SPRTopShift(T,es->head,et,DOWN); /*DOWN because tree being moved is below split edge*/
+ if (NULL != eb)
+ SPRTopShift(T,es->head,eb,UP); /*UP because tree being moved is above split edge*/
+}
diff --git a/src/additive.c b/src/additive.c
new file mode 100644
index 0000000..425bdc4
--- /dev/null
+++ b/src/additive.c
@@ -0,0 +1,66 @@
+/* additive.c 2011-10-11 */
+
+/* Copyright 2011 Andrei-Alin Popescu */
+
+/* This file is part of the R-package `ape'. */
+/* See the file ../COPYING for licensing issues. */
+
+#include "ape.h"
+
+void C_additive(double *dd, int* np, int* mp, double *ret)//d received as dist object, -1 for missing entries
+{
+ int n=*np;
+ int m=*mp;
+ int i=0,j=0;
+ double max=dd[0];
+ double d[n][n];
+ for(i=1;i<n;i++)
+ {d[i-1][i-1]=0;
+ for(j=i+1;j<=n;j++)
+ {
+ d[i-1][j-1]=d[j-1][i-1]=dd[give_index(i,j,n)];
+ if(dd[give_index(i,j,n)]>max)
+ {
+ max=dd[give_index(i,j,n)];
+ }
+ }
+ }
+ d[n-1][n-1]=0;
+
+ int entrCh=0;
+ do{
+ entrCh=0;
+ for(i=0;i<n-1;i++)
+ for(j=i+1;j<n;j++)
+ {
+ if(d[i][j]!=-1)continue;
+ double minimax=max;
+ int k=0;
+ int sw=0;
+ for(k=0;k<n;k++)
+ {int l=0;
+ if(d[i][k]==-1 || d[j][k]==-1)continue;
+ for(l=0;l<n;l++)
+ {
+ if(k==l || d[k][l]==-1 || d[i][l]==-1 || d[j][l]==-1)continue;
+ sw=1;
+ double mx=(((d[i][k]+d[j][l])>(d[i][l]+d[j][k]))?(d[i][k]+d[j][l]):(d[i][l]+d[j][k]));
+ mx-=d[k][l];
+ if(mx<minimax){minimax=mx;}
+ }
+ }
+ if(sw==1)
+ {
+ d[i][j]=d[j][i]=minimax;
+ m--;
+ entrCh=1;
+ }
+ }
+ }while(entrCh==1);
+ int ij=0;
+ for(i=0;i<n;i++)
+ for(j=0;j<n;j++)
+ {
+ ret[ij++]=d[i][j];
+ }
+}
diff --git a/src/ape.c b/src/ape.c
new file mode 100644
index 0000000..81f10c9
--- /dev/null
+++ b/src/ape.c
@@ -0,0 +1,139 @@
+/* ape.c 2014-01-02 */
+
+/* Copyright 2011-2014 Emmanuel Paradis, and 2007 R Development Core Team */
+
+/* This file is part of the R-package `ape'. */
+/* See the file ../COPYING for licensing issues. */
+
+#include <R_ext/Rdynload.h>
+#include "ape.h"
+
+int give_index(int i, int j, int n)
+{
+ if (i > j) return(DINDEX(j, i));
+ else return(DINDEX(i, j));
+}
+
+/* From R-ext manual
+ (not the same than in library/stats/src/nls.c) */
+SEXP getListElement(SEXP list, char *str)
+{
+ SEXP elmt = R_NilValue, names = getAttrib(list, R_NamesSymbol);
+ int i;
+
+ for (i = 0; i < length(list); i++)
+ if(strcmp(CHAR(STRING_ELT(names, i)), str) == 0) {
+ elmt = VECTOR_ELT(list, i);
+ break;
+ }
+ return elmt;
+}
+
+/* declare functions here to register them below */
+
+void C_additive(double *dd, int* np, int* mp, double *ret);
+void BaseProportion(unsigned char *x, int *n, double *BF);
+void C_bionj(double *X, int *N, int *edge1, int *edge2, double *el);
+void C_bionjs(double *D, int *N, int *edge1, int *edge2, double *edge_length, int* fsS);
+void delta_plot(double *D, int *size, int *nbins, int *counts, double *deltabar);
+void dist_dna(unsigned char *x, int *n, int *s, int *model, double *d,
+ double *BF, int *pairdel, int *variance, double *var,
+ int *gamma, double *alpha);
+void dist_nodes(int *n, int *m, int *e1, int *e2, double *el, int *N, double *D);
+void C_ewLasso(double *D, int *N, int *e1, int *e2);
+void GlobalDeletionDNA(unsigned char *x, int *n, int *s, int *keep);
+void mat_expo(double *P, int *nr);
+void me_b(double *X, int *N, int *labels,
+ int *nni, int *spr, int *tbr,
+ int *edge1, int *edge2, double *el);
+void me_o(double *X, int *N, int *labels, int *nni,
+ int *edge1, int *edge2, double *el);
+void C_mvr(double *D, double* v,int *N, int *edge1, int *edge2, double *edge_length);
+void C_mvrs(double *D, double* v, int *N, int *edge1, int *edge2, double *edge_length, int* fsS);
+void neworder_phylo(int *n, int *e1, int *e2, int *N, int *neworder, int *order);
+void neworder_pruningwise(int *ntip, int *nnode, int *edge1,
+ int *edge2, int *nedge, int *neworder);
+void C_nj(double *D, int *N, int *edge1, int *edge2, double *edge_length);
+void C_njs(double *D, int *N, int *edge1, int *edge2, double *edge_length, int *fsS);
+void node_depth(int *ntip, int *nnode, int *e1, int *e2,
+ int *nedge, double *xx, int *method);
+void node_depth_edgelength(int *ntip, int *nnode, int *edge1, int *edge2,
+ int *nedge, double *edge_length, double *xx);
+void node_height(int *ntip, int *nnode, int *edge1, int *edge2,
+ int *nedge, double *yy);
+void node_height_clado(int *ntip, int *nnode, int *edge1, int *edge2,
+ int *nedge, double *xx, double *yy);
+void C_pic(int *ntip, int *nnode, int *edge1, int *edge2,
+ double *edge_len, double *phe, double *contr,
+ double *var_contr, int *var, int *scaled);
+void C_rTraitCont(int *model, int *Nedge, int *edge1, int *edge2, double *el,
+ double *sigma, double *alpha, double *theta, double *x);
+void SegSites(unsigned char *x, int *n, int *s, int *seg);
+void C_treePop(int* splits, double* w,int* ncolp,int* np, int* ed1, int* ed2, double* edLen);
+void C_triangMtd(double* d, int* np, int* ed1,int* ed2, double* edLen);
+void C_triangMtds(double* d, int* np, int* ed1,int* ed2, double* edLen);
+void C_ultrametric(double *dd, int* np, int* mp, double *ret);
+void C_where(unsigned char *x, unsigned char *pat, int *s, int *p,
+ int *ans, int *n);
+void bitsplits_phylo(int *n, int *m, int *e, int *N, int *nr, unsigned char *mat);
+void CountBipartitionsFromTrees(int *n, int *m, int *e, int *N, int *nr, int *nc,
+ unsigned char *mat, double *freq);
+
+SEXP bipartition(SEXP edge, SEXP nbtip, SEXP nbnode);
+SEXP prop_part(SEXP TREES, SEXP nbtree, SEXP keep_partitions);
+SEXP rawStreamToDNAbin(SEXP x);
+SEXP seq_root2tip(SEXP edge, SEXP nbtip, SEXP nbnode);
+SEXP treeBuildWithTokens(SEXP nwk);
+SEXP bitsplits_multiPhylo(SEXP x, SEXP n, SEXP nr);
+
+static R_CMethodDef C_entries[] = {
+ {"C_additive", (DL_FUNC) &C_additive, 4},
+ {"BaseProportion", (DL_FUNC) &BaseProportion, 3},
+ {"C_bionj", (DL_FUNC) &C_bionj, 5},
+ {"C_bionjs", (DL_FUNC) &C_bionjs, 6},
+ {"delta_plot", (DL_FUNC) &delta_plot, 5},
+ {"dist_dna", (DL_FUNC) &dist_dna, 11},
+ {"dist_nodes", (DL_FUNC) &dist_nodes, 7},
+ {"C_ewLasso", (DL_FUNC) &C_ewLasso, 4},
+ {"GlobalDeletionDNA", (DL_FUNC) &GlobalDeletionDNA, 4},
+ {"mat_expo", (DL_FUNC) &mat_expo, 2},
+ {"me_b", (DL_FUNC) &me_b, 9},
+ {"me_o", (DL_FUNC) &me_o, 7},
+ {"C_mvr", (DL_FUNC) &C_mvr, 6},
+ {"C_mvrs", (DL_FUNC) &C_mvrs, 7},
+ {"neworder_phylo", (DL_FUNC) &neworder_phylo, 6},
+ {"neworder_pruningwise", (DL_FUNC) &neworder_pruningwise, 6},
+ {"C_nj", (DL_FUNC) &C_nj, 5},
+ {"C_njs", (DL_FUNC) &C_njs, 6},
+ {"node_depth", (DL_FUNC) &node_depth, 7},
+ {"node_depth_edgelength", (DL_FUNC) &node_depth_edgelength, 7},
+ {"node_height", (DL_FUNC) &node_height, 6},
+ {"node_height_clado", (DL_FUNC) &node_height_clado, 7},
+ {"C_pic", (DL_FUNC) &C_pic, 10},
+ {"C_rTraitCont", (DL_FUNC) &C_rTraitCont, 9},
+ {"SegSites", (DL_FUNC) &SegSites, 4},
+ {"C_treePop", (DL_FUNC) &C_treePop, 7},
+ {"C_triangMtd", (DL_FUNC) &C_triangMtd, 5},
+ {"C_triangMtds", (DL_FUNC) &C_triangMtds, 5},
+ {"C_ultrametric", (DL_FUNC) &C_ultrametric, 4},
+ {"C_where", (DL_FUNC) &C_where, 6},
+ {"bitsplits_phylo", (DL_FUNC) &bitsplits_phylo, 6},
+ {"CountBipartitionsFromTrees", (DL_FUNC) &CountBipartitionsFromTrees, 8},
+ {NULL, NULL, 0}
+};
+
+static R_CallMethodDef Call_entries[] = {
+ {"bipartition", (DL_FUNC) &bipartition, 3},
+ {"prop_part", (DL_FUNC) &prop_part, 3},
+ {"rawStreamToDNAbin", (DL_FUNC) &rawStreamToDNAbin, 1},
+ {"seq_root2tip", (DL_FUNC) &seq_root2tip, 3},
+ {"treeBuildWithTokens", (DL_FUNC) &treeBuildWithTokens, 1},
+ {"bitsplits_multiPhylo", (DL_FUNC) &bitsplits_multiPhylo, 3},
+ {NULL, NULL, 0}
+};
+
+void R_init_ape(DllInfo *info)
+{
+ R_registerRoutines(info, C_entries, Call_entries, NULL, NULL);
+ R_useDynamicSymbols(info, FALSE);
+}
diff --git a/src/ape.h b/src/ape.h
new file mode 100644
index 0000000..2f6dd3d
--- /dev/null
+++ b/src/ape.h
@@ -0,0 +1,28 @@
+/* ape.h 2014-01-02 */
+
+/* Copyright 2011-2014 Emmanuel Paradis */
+
+/* This file is part of the R-package `ape'. */
+/* See the file ../COPYING for licensing issues. */
+
+#include <R.h>
+#include <Rinternals.h>
+
+#define DINDEX(i, j) n*(i - 1) - i*(i - 1)/2 + j - i - 1
+
+/* in ape.c */
+int give_index(int i, int j, int n);
+SEXP getListElement(SEXP list, char *str);
+
+/* in njs.c */
+void choosePair(double* D, int n, double* R, int* s, int* sw, int* x, int* y, int fS);
+double cnxy(int x, int y, int n, double* D);
+int mxy(int x,int y, int n, double* D);
+double nxy(int x, int y, int n, double* D);
+int cxy(int x, int y, int n, double* D);
+
+/* in triangMtd.c */
+void C_triangMtd(double* d, int* np, int* ed1, int* ed2, double* edLen);
+int * getPathBetween(int x, int y, int n, int* ed1, int* ed2, int numEdges);
+int give_indexx(int i, int j, int n); /* a variant of the above */
+
diff --git a/src/bNNI.c b/src/bNNI.c
new file mode 100644
index 0000000..7997819
--- /dev/null
+++ b/src/bNNI.c
@@ -0,0 +1,329 @@
+/* bNNI.c 2013-09-26 */
+
+/* Copyright 2007 Vincent Lefort */
+
+/* This file is part of the R-package `ape'. */
+/* See the file ../COPYING for licensing issues. */
+
+#include "me.h"
+
+/*boolean leaf(node *v);
+edge *siblingEdge(edge *e);
+edge *depthFirstTraverse(tree *T, edge *e);
+edge *findBottomLeft(edge *e);
+edge *topFirstTraverse(tree *T, edge *e);
+edge *moveUpRight(edge *e);*/
+
+void limitedFillTableUp(edge *e, edge *f, double **A, edge *trigger);
+void assignBMEWeights(tree *T, double **A);
+//void updateAveragesMatrix(tree *T, double **A, node *v,int direction);
+void bNNItopSwitch(tree *T, edge *e, int direction, double **A);
+int bNNIEdgeTest(edge *e, tree *T, double **A, double *weight);
+void updatePair(double **A, edge *nearEdge, edge *farEdge, node *closer, node *further, double dcoeff, int direction);
+
+int *initPerm(int size);
+
+void reHeapElement(int *p, int *q, double *v, int length, int i);
+void pushHeap(int *p, int *q, double *v, int length, int i);
+void popHeap(int *p, int *q, double *v, int length, int i);
+
+
+void bNNIRetestEdge(int *p, int *q, edge *e,tree *T, double **avgDistArray,
+ double *weights, int *location, int *possibleSwaps)
+{
+ int tloc;
+ tloc = location[e->head->index+1];
+ location[e->head->index+1] =
+ bNNIEdgeTest(e,T,avgDistArray,weights + e->head->index+1);
+ if (NONE == location[e->head->index+1])
+ {
+ if (NONE != tloc)
+ popHeap(p,q,weights,(*possibleSwaps)--,q[e->head->index+1]);
+ }
+ else
+ {
+ if (NONE == tloc)
+ pushHeap(p,q,weights,(*possibleSwaps)++,q[e->head->index+1]);
+ else
+ reHeapElement(p,q,weights,*possibleSwaps,q[e->head->index+1]);
+ }
+}
+
+int makeThreshHeap(int *p, int *q, double *v, int arraySize, double thresh);
+
+void permInverse(int *p, int *q, int length);
+
+void weighTree(tree *T)
+{
+ edge *e;
+ T->weight = 0;
+ for(e = depthFirstTraverse(T,NULL);NULL!=e;e=depthFirstTraverse(T,e))
+ T->weight += e->distance;
+}
+
+//void bNNI(tree *T, double **avgDistArray, int *count)
+void bNNI(tree *T, double **avgDistArray, int *count, double **D, int numSpecies)
+{
+ edge *e;//, *centerEdge deleted by EP, 2013-09-26, see also below
+ edge **edgeArray;
+ int *p, *location, *q;
+ int i,j;
+ int possibleSwaps;
+ double *weights;
+ p = initPerm(T->size+1);
+ q = initPerm(T->size+1);
+ edgeArray = (edge **) malloc((T->size+1)*sizeof(double));
+ weights = (double *) malloc((T->size+1)*sizeof(double));
+ location = (int *) malloc((T->size+1)*sizeof(int));
+
+ double epsilon = 0.0;
+ for (i=0; i<numSpecies; i++)
+ for (j=0; j<numSpecies; j++)
+ epsilon += D[i][j];
+ epsilon = (epsilon / (numSpecies * numSpecies)) * EPSILON;
+
+ for (i=0;i<T->size+1;i++)
+ {
+ weights[i] = 0.0;
+ location[i] = NONE;
+ }
+/* if (verbose)
+ {
+ assignBMEWeights(T,avgDistArray);
+ weighTree(T);
+ }*/
+ e = findBottomLeft(T->root->leftEdge);
+ while (NULL != e)
+ {
+ edgeArray[e->head->index+1] = e;
+ location[e->head->index+1] =
+ bNNIEdgeTest(e,T,avgDistArray,weights + e->head->index + 1);
+ e = depthFirstTraverse(T,e);
+ }
+ possibleSwaps = makeThreshHeap(p,q,weights,T->size+1,0.0);
+ permInverse(p,q,T->size+1);
+ /*we put the negative values of weights into a heap, indexed by p
+ with the minimum value pointed to by p[1]*/
+ /*p[i] is index (in edgeArray) of edge with i-th position
+ in the heap, q[j] is the position of edge j in the heap */
+ while (weights[p[1]] + epsilon < 0)
+ {
+ /* centerEdge = edgeArray[p[1]]; apparently unused later, deleted by EP, 2013-09-26 */
+ (*count)++;
+/* if (verbose)
+ {
+ T->weight = T->weight + weights[p[1]];
+ printf("New tree weight is %lf.\n",T->weight);
+ }*/
+ bNNItopSwitch(T,edgeArray[p[1]],location[p[1]],avgDistArray);
+ location[p[1]] = NONE;
+ weights[p[1]] = 0.0; /*after the bNNI, this edge is in optimal
+ configuration*/
+ popHeap(p,q,weights,possibleSwaps--,1);
+ /*but we must retest the other edges of T*/
+ /*CHANGE 2/28/2003 expanding retesting to _all_ edges of T*/
+ e = depthFirstTraverse(T,NULL);
+ while (NULL != e)
+ {
+ bNNIRetestEdge(p,q,e,T,avgDistArray,weights,location,&possibleSwaps);
+ e = depthFirstTraverse(T,e);
+ }
+ }
+ free(p);
+ free(q);
+ free(location);
+ free(edgeArray);
+ free(weights);
+ assignBMEWeights(T,avgDistArray);
+}
+
+
+/*This function is the meat of the average distance matrix recalculation*/
+/*Idea is: we are looking at the subtree rooted at rootEdge. The subtree
+rooted at closer is closer to rootEdge after the NNI, while the subtree
+rooted at further is further to rootEdge after the NNI. direction tells
+the direction of the NNI with respect to rootEdge*/
+void updateSubTreeAfterNNI(double **A, node *v, edge *rootEdge, node *closer, node *further,
+ double dcoeff, int direction)
+{
+ edge *sib;
+ switch(direction)
+ {
+ case UP: /*rootEdge is below the center edge of the NNI*/
+ /*recursive calls to subtrees, if necessary*/
+ if (NULL != rootEdge->head->leftEdge)
+ updateSubTreeAfterNNI(A, v, rootEdge->head->leftEdge, closer, further, 0.5*dcoeff,UP);
+ if (NULL != rootEdge->head->rightEdge)
+ updateSubTreeAfterNNI(A, v, rootEdge->head->rightEdge, closer, further, 0.5*dcoeff,UP);
+ updatePair(A, rootEdge, rootEdge, closer, further, dcoeff, UP);
+ sib = siblingEdge(v->parentEdge);
+ A[rootEdge->head->index][v->index] =
+ A[v->index][rootEdge->head->index] =
+ 0.5*A[rootEdge->head->index][sib->head->index] +
+ 0.5*A[rootEdge->head->index][v->parentEdge->tail->index];
+ break;
+ case DOWN: /*rootEdge is above the center edge of the NNI*/
+ sib = siblingEdge(rootEdge);
+ if (NULL != sib)
+ updateSubTreeAfterNNI(A, v, sib, closer, further, 0.5*dcoeff, SKEW);
+ if (NULL != rootEdge->tail->parentEdge)
+ updateSubTreeAfterNNI(A, v, rootEdge->tail->parentEdge, closer, further, 0.5*dcoeff, DOWN);
+ updatePair(A, rootEdge, rootEdge, closer, further, dcoeff, DOWN);
+ A[rootEdge->head->index][v->index] =
+ A[v->index][rootEdge->head->index] =
+ 0.5*A[rootEdge->head->index][v->leftEdge->head->index] +
+ 0.5*A[rootEdge->head->index][v->rightEdge->head->index];
+ break;
+ case SKEW: /*rootEdge is in subtree skew to v*/
+ if (NULL != rootEdge->head->leftEdge)
+ updateSubTreeAfterNNI(A, v, rootEdge->head->leftEdge, closer, further, 0.5*dcoeff,SKEW);
+ if (NULL != rootEdge->head->rightEdge)
+ updateSubTreeAfterNNI(A, v, rootEdge->head->rightEdge, closer, further, 0.5*dcoeff,SKEW);
+ updatePair(A, rootEdge, rootEdge, closer, further, dcoeff, UP);
+ A[rootEdge->head->index][v->index] =
+ A[v->index][rootEdge->head->index] =
+ 0.5*A[rootEdge->head->index][v->leftEdge->head->index] +
+ 0.5*A[rootEdge->head->index][v->rightEdge->head->index];
+ break;
+ }
+}
+
+/*swapping across edge whose head is v*/
+void bNNIupdateAverages(double **A, node *v, edge *par, edge *skew,
+ edge *swap, edge *fixed)
+{
+ A[v->index][v->index] = 0.25*(A[fixed->head->index][par->head->index] +
+ A[fixed->head->index][swap->head->index] +
+ A[skew->head->index][par->head->index] +
+ A[skew->head->index][swap->head->index]);
+ updateSubTreeAfterNNI(A, v, fixed, skew->head, swap->head, 0.25, UP);
+ updateSubTreeAfterNNI(A, v, par, swap->head, skew->head, 0.25, DOWN);
+ updateSubTreeAfterNNI(A, v, skew, fixed->head, par->head, 0.25, UP);
+ updateSubTreeAfterNNI(A, v, swap, par->head, fixed->head, 0.25, SKEW);
+}
+
+
+void bNNItopSwitch(tree *T, edge *e, int direction, double **A)
+{
+ edge *down, *swap, *fixed;
+ node *u, *v;
+/* if (verbose)
+ {
+ printf("Performing branch swap across edge %s ",e->label);
+ printf("with ");
+ if (LEFT == direction)
+ printf("left ");
+ else printf("right ");
+ printf("subtree.\n");
+ }*/
+ down = siblingEdge(e);
+ u = e->tail;
+ v = e->head;
+ if (LEFT == direction)
+ {
+ swap = e->head->leftEdge;
+ fixed = e->head->rightEdge;
+ v->leftEdge = down;
+ }
+ else
+ {
+ swap = e->head->rightEdge;
+ fixed = e->head->leftEdge;
+ v->rightEdge = down;
+ }
+ swap->tail = u;
+ down->tail = v;
+ if(e->tail->leftEdge == e)
+ u->rightEdge = swap;
+ else
+ u->leftEdge = swap;
+ bNNIupdateAverages(A, v, e->tail->parentEdge, down, swap, fixed);
+}
+
+double wf5(double D_AD, double D_BC, double D_AC, double D_BD,
+ double D_AB, double D_CD)
+{
+ double weight;
+ weight = 0.25*(D_AC + D_BD + D_AD + D_BC) + 0.5*(D_AB + D_CD);
+ return(weight);
+}
+
+int bNNIEdgeTest(edge *e, tree *T, double **A, double *weight)
+{
+ edge *f;
+ double D_LR, D_LU, D_LD, D_RD, D_RU, D_DU;
+ double w1,w2,w0;
+/* if (verbose)
+ printf("Branch swap: testing edge %s.\n",e->label);*/
+ if ((leaf(e->tail)) || (leaf(e->head)))
+ return(NONE);
+
+ f = siblingEdge(e);
+
+ D_LR = A[e->head->leftEdge->head->index][e->head->rightEdge->head->index];
+ D_LU = A[e->head->leftEdge->head->index][e->tail->index];
+ D_LD = A[e->head->leftEdge->head->index][f->head->index];
+ D_RU = A[e->head->rightEdge->head->index][e->tail->index];
+ D_RD = A[e->head->rightEdge->head->index][f->head->index];
+ D_DU = A[e->tail->index][f->head->index];
+
+ w0 = wf5(D_RU,D_LD,D_LU,D_RD,D_DU,D_LR); /*weight of current config*/
+ w1 = wf5(D_RU,D_LD,D_DU,D_LR,D_LU,D_RD); /*weight with L<->D switch*/
+ w2 = wf5(D_DU,D_LR,D_LU,D_RD,D_RU,D_LD); /*weight with R<->D switch*/
+ if (w0 <= w1)
+ {
+ if (w0 <= w2) /*w0 <= w1,w2*/
+ {
+ *weight = 0.0;
+ return(NONE);
+ }
+ else /*w2 < w0 <= w1 */
+ {
+ *weight = w2 - w0;
+/* if (verbose)
+ {
+ printf("Possible swap across %s. ",e->label);
+ printf("Weight dropping by %lf.\n",w0 - w2);
+ printf("New weight would be %lf.\n",T->weight + w2 - w0);
+ }*/
+ return(RIGHT);
+ }
+ }
+ else if (w2 <= w1) /*w2 <= w1 < w0*/
+ {
+ *weight = w2 - w0;
+/* if (verbose)
+ {
+ printf("Possible swap across %s. ",e->label);
+ printf("Weight dropping by %lf.\n",w0 - w2);
+ printf("New weight should be %lf.\n",T->weight + w2 - w0);
+ }*/
+ return(RIGHT);
+ }
+ else /*w1 < w2, w0*/
+ {
+ *weight = w1 - w0;
+/* if (verbose)
+ {
+ printf("Possible swap across %s. ",e->label);
+ printf("Weight dropping by %lf.\n",w0 - w1);
+ printf("New weight should be %lf.\n",T->weight + w1 - w0);
+ }*/
+ return(LEFT);
+ }
+}
+
+/*limitedFillTableUp fills all the entries in D associated with
+ e->head,f->head and those edges g->head above e->head, working
+ recursively and stopping when trigger is reached*/
+void limitedFillTableUp(edge *e, edge *f, double **A, edge *trigger)
+{
+ edge *g,*h;
+ g = f->tail->parentEdge;
+ if (f != trigger)
+ limitedFillTableUp(e,g,A,trigger);
+ h = siblingEdge(f);
+ A[e->head->index][f->head->index] =
+ A[f->head->index][e->head->index] =
+ 0.5*(A[e->head->index][g->head->index] + A[e->head->index][h->head->index]);
+}
diff --git a/src/bionjs.c b/src/bionjs.c
new file mode 100644
index 0000000..1a9c66c
--- /dev/null
+++ b/src/bionjs.c
@@ -0,0 +1,403 @@
+/* bionjs.c 2013-09-26 */
+
+/* Copyright 2011-2012 Andrei-Alin Popescu */
+
+/* This file is part of the R-package `ape'. */
+/* See the file ../COPYING for licensing issues. */
+
+#include "ape.h"
+
+void C_bionjs(double *D, int *N, int *edge1, int *edge2, double *edge_length, int* fsS)
+{ //assume missing values are denoted by -1
+ double *S,*R , *v,*new_v, Sdist, Ndist, *new_dist, A, B, smallest_S;
+ int n, i, j, k, ij, OTU1, OTU2, cur_nod, o_l, *otu_label;
+ /*for(i=0;i<n*(n-1)/2;i++)
+ {if(isNA(D[i])){D[i]=-1;}
+ }*/
+ int *s;//s contains |Sxy|, which is all we need for agglomeration
+ double *newR;
+ int *newS;
+ int fS=*fsS;
+
+ R = &Sdist;
+ new_dist = &Ndist;
+ otu_label = &o_l;
+ n = *N;
+ cur_nod = 2*n - 2;
+
+ R = (double*)R_alloc(n*(n - 1)/2, sizeof(double));
+ v = (double*)R_alloc(n*(n - 1)/2, sizeof(double));
+ new_v = (double*)R_alloc(n*(n - 1)/2, sizeof(double));
+ S = (double*)R_alloc(n + 1, sizeof(double));
+ newR = (double*)R_alloc(n*(n - 1)/2, sizeof(double));
+ new_dist = (double*)R_alloc(n*(n - 1)/2, sizeof(double));
+ otu_label = (int*)R_alloc(n + 1, sizeof(int));
+ s = (int*)R_alloc(n*(n - 1)/2, sizeof(int));
+ newS = (int*)R_alloc(n*(n - 1)/2, sizeof(int));
+
+ for (i = 1; i <= n; i++) otu_label[i] = i; /* otu_label[0] is not used */
+
+ k = 0;
+ //populate the v matrix
+ for(i=1;i<n;i++)
+ for(j=i+1;j<=n;j++)
+ {
+ v[give_index(i,j,n)]=D[give_index(i,j,n)];
+ }
+ //compute Sxy and Rxy
+ for(i=0;i<n*(n-1)/2;i++)
+ {newR[i]=0;
+ newS[i]=0;
+ s[i]=0;
+ R[i]=0;
+ }
+
+ for(i=1;i<n;i++)
+ for(j=i+1;j<=n;j++)
+ {//algorithm assumes i,j /in Sij, so skip pair if it is not known
+ if(D[give_index(i,j,n)]==-1)
+ {
+ continue;
+ }
+ for(k=1;k<=n;k++)
+ {//ij is the pair for which we compute
+ //skip k if we do not know the distances between it and i AND j
+
+ if(k==i || k==j)
+ {
+ /* added 2012-04-02: */
+ if(i!=k)R[give_index(i,j,n)]+=D[give_index(i,k,n)];
+ if(j!=k)R[give_index(i,j,n)]+=D[give_index(j,k,n)];
+ /* end of addition */
+ s[give_index(i,j,n)]++;
+ continue;
+ }
+ if(D[give_index(i,k,n)]==-1 || D[give_index(j,k,n)]==-1)continue;
+ //Rprintf("%i\n",k);
+ s[give_index(i,j,n)]++;
+ R[give_index(i,j,n)]+=D[give_index(i,k,n)];
+ R[give_index(i,j,n)]+=D[give_index(j,k,n)];
+ }
+ }
+
+ /*for(i=1;i<n;i++)
+ {
+ for(j=i+1;j<=n;j++)
+ {
+ Rprintf("R[%i,%i]=%f ",i,j,R[give_index(i,j,n)]);
+ }
+ Rprintf("\n");
+ }
+
+ for(i=1;i<n;i++)
+ {
+ for(j=i+1;j<=n;j++)
+ {
+ Rprintf("s[%i,%i]=%i ",i,j,s[give_index(i,j,n)]);
+ }
+ Rprintf("\n");
+ }*/
+
+ k=0;
+ int sw=1;//if 1 then incomplete
+ while (n > 3) {
+
+ ij = 0;
+ for(i=1;i<n;i++)
+ for(j=i+1;j<=n;j++)
+ {newR[give_index(i,j,n)]=0;
+ newS[give_index(i,j,n)]=0;
+ }
+ smallest_S = -1e50;
+ if(sw==0)
+ for(i=1;i<=n;i++)
+ {S[i]=0;
+ }
+
+ B=n-2;
+ if(sw==1)
+ {
+ choosePair(D,n,R,s,&sw,&OTU1,&OTU2,fS);
+ }
+ else{ //Rprintf("distance matrix is now complete\n");
+ for (i=1;i<=n;i++)
+ for(j=1;j<=n;j++)
+ {if(i==j)continue;
+ //Rprintf("give_index(%i,%i)=%i\n",i,j,give_index(i,j,n));
+ //Rprintf("D[%i,%i]=%f\n",i,j,D[give_index(i,j,n)]);
+ S[i]+=D[give_index(i,j,n)];
+ }
+ B=n-2;
+ //Rprintf("n=%i,B=%f",n,B);
+ for (i = 1; i < n; i++) {
+ for (j = i + 1; j <= n; j++) {
+ //Rprintf("S[%i]=%f, S[%i]=%f, D[%i,%i]=%f, B=%f",i,S[i],j,S[j],i,j,D[give_index(i,j,n)],B);
+ A=S[i]+S[j]-B*D[give_index(i,j,n)];
+ //Rprintf("Q[%i,%i]=%f\n",i,j,A);
+ if (A > smallest_S) {
+ OTU1 = i;
+ OTU2 = j;
+ smallest_S = A;
+ /* smallest = ij; */
+ }
+ ij++;
+ }
+ }
+ }
+
+ //Rprintf("agglomerating %i and %i, Q=%f \n",OTU1,OTU2,smallest_S);
+
+ /*for(i=1;i<n;i++)
+ {
+ for(j=i+1;j<=n;j++)
+ {
+ Rprintf("R[%i,%i]=%f ",i,j,R[give_index(i,j,n)]);
+ }
+ Rprintf("\n");
+ }
+
+ for(i=1;i<n;i++)
+ {
+ for(j=i+1;j<=n;j++)
+ {
+ Rprintf("s[%i,%i]=%i ",i,j,s[give_index(i,j,n)]);
+ }
+ Rprintf("\n");
+ }
+
+ for(i=1;i<n;i++)
+ {
+ for(j=i+1;j<=n;j++)
+ {
+ Rprintf("d[%i,%i]=%f ",i,j,D[give_index(i,j,n)]);
+ }
+ Rprintf("\n");
+ }*/
+ //update R and S, only if matrix still incomplete
+ if(sw==1)
+ for(i=1;i<n;i++)
+ {if(i==OTU1 || i==OTU2)continue;
+ for(j=i+1;j<=n;j++)
+ {if(j==OTU1 || j==OTU2)continue;
+ if(D[give_index(i,j,n)]==-1)continue;
+ if(D[give_index(i,OTU1,n)]!=-1 && D[give_index(j,OTU1,n)]!=-1)
+ {//OTU1 was considered for Rij, so now subtract
+ R[give_index(i,j,n)]-=(D[give_index(i,OTU1,n)]+D[give_index(j,OTU1,n)]);
+ s[give_index(i,j,n)]--;
+ }
+ if(D[give_index(i,OTU2,n)]!=-1 && D[give_index(j,OTU2,n)]!=-1)
+ {//OTU2 was considered for Rij, so now subtract
+ R[give_index(i,j,n)]-=(D[give_index(i,OTU2,n)]+D[give_index(j,OTU2,n)]);
+ s[give_index(i,j,n)]--;
+ }
+ }
+ }
+
+ edge2[k] = otu_label[OTU1];
+ edge2[k + 1] = otu_label[OTU2];
+ edge1[k] = edge1[k + 1] = cur_nod;
+
+ double sum=0;
+ double lamb=0;//the parameter used for matrix reduction
+ double lambSum=0;
+ for(i=1;i<=n;i++)
+ {if(i==OTU1 || i==OTU2)continue;
+ if(D[give_index(OTU1,i,n)]==-1 || D[give_index(OTU2,i,n)]==-1)continue;
+ sum+=(D[give_index(OTU1,i,n)]-D[give_index(OTU2,i,n)]);
+ lambSum+=(v[give_index(OTU2,i,n)]-v[give_index(OTU1,i,n)]);
+ }
+ //if we stil have incomplete distances
+ if(sw==1)
+ {
+ lamb=0.5+(1/(2*(s[give_index(OTU1,OTU2,n)]-2)*v[give_index(OTU2,OTU1,n)]))*lambSum;
+ }else{
+ lamb=0.5+(1/(2*(n-2)*v[give_index(OTU2,OTU1,n)]))*lambSum;
+ }
+
+ //although s was updated above, s[otu1,otu2] has remained unchanged
+ //so it is safe to use it here
+ //if complete distanes, use N-2, else use S
+ int down=B;
+ if(sw==1){down=s[give_index(OTU1,OTU2,n)]-2;}
+ if(down<=0)
+ {error("distance information insufficient to construct a tree, leaves %i and %i isolated from tree",OTU1,OTU2);
+ }
+ //Rprintf("down=%f\n",B);
+ sum*=(1.0/(2*(down)));
+ //Rprintf("sum=%f\n",sum);
+ double dxy=D[give_index(OTU1,OTU2,n)]/2;
+
+ //Rprintf("R[%i,%i]:%f \n",OTU1,OTU2,sum);
+ edge_length[k] = dxy+sum;//OTU1
+ //Rprintf("l1:%f \n",edge_length[k]);
+ edge_length[k + 1] = dxy-sum;//OTU2
+ //Rprintf("l2:%f \n",edge_length[k+1]);
+ //no need to change distance matrix update for complete distance
+ //case, as pairs will automatically fall in the right cathegory
+
+ //OTU1=x, OTU2=y from formulas
+ A = D[give_index(OTU1,OTU2,n)];
+ ij = 0;
+ for (i = 1; i <= n; i++) {
+ if (i == OTU1 || i == OTU2) continue;
+ if(D[give_index(OTU1,i,n)]!=-1 && D[give_index(OTU2,i,n)]!=-1)
+ {
+ new_dist[ij]= lamb*(D[give_index(OTU1,i,n)]-edge_length[k])+(1-lamb)*(D[give_index(OTU2,i,n)]-edge_length[k+1]);
+ new_v[ij]=lamb*v[give_index(OTU1,i,n)]+(1-lamb)*v[give_index(OTU2,i,n)]-lamb*(1-lamb)*v[give_index(OTU1,OTU2,n)];
+ }else{
+ if(D[give_index(OTU1,i,n)]!=-1)
+ {
+ new_dist[ij]=D[give_index(OTU1,i,n)]-edge_length[k];
+ new_v[ij]=v[give_index(OTU1,i,n)];
+ }else{
+ if(D[give_index(OTU2,i,n)]!=-1)
+ {
+ new_dist[ij]=D[give_index(OTU2,i,n)]-edge_length[k+1];
+ new_v[ij]=v[give_index(OTU2,i,n)];
+ }else{new_dist[ij]=-1;new_v[ij]=-1;}
+ }
+ }
+
+ ij++;
+ }
+
+ for (i = 1; i < n; i++) {
+ if (i == OTU1 || i == OTU2) continue;
+ for (j = i + 1; j <= n; j++) {
+ if (j == OTU1 || j == OTU2) continue;
+ new_dist[ij] = D[DINDEX(i, j)];
+ new_v[ij]=v[give_index(i,j,n)];
+ ij++;
+ }
+ }
+
+ /*for(i=1;i<n-1;i++)
+ {
+ for(j=i+1;j<=n-1;j++)
+ {Rprintf("%f ",new_dist[give_index(i,j,n-1)]);
+ }
+ Rprintf("\n");
+ }*/
+ //compute Rui, only if distance matrix is still incomplete
+ ij=0;
+ if(sw==1)
+ for(i=2;i<n;i++)
+ {
+ ij++;
+ if(new_dist[give_index(i,1,n-1)]==-1)continue;
+
+ for(j=1;j<n;j++)
+ {
+ if(j==1 || j==i)
+ {
+ /* added 2012-04-02 */
+ if(i!=j)newR[give_index(1,i,n-1)]+=new_dist[give_index(i,j,n-1)];
+ if(1!=j)newR[give_index(1,i,n-1)]+=new_dist[give_index(1,j,n-1)];
+ /* end of addition */
+ newS[give_index(1,i,n-1)]++;
+ continue;
+ }
+ if(new_dist[give_index(i,j,n-1)]!=-1 && new_dist[give_index(1,j,n-1)]!=-1)
+ {
+ newS[give_index(1,i,n-1)]++;
+ newR[give_index(1,i,n-1)]+=new_dist[give_index(i,j,n-1)];
+ newR[give_index(1,i,n-1)]+=new_dist[give_index(1,j,n-1)];
+ }
+ }
+ }
+ //fill in the rest of R and S, again only if distance matrix still
+ //incomplete
+ if(sw==1)
+ for(i=1;i<n;i++)
+ {if(i==OTU1 || i==OTU2)continue;
+ for(j=i+1;j<=n;j++)
+ {if(j==OTU1 || j==OTU2)continue;
+ newR[ij]=R[give_index(i,j,n)];
+ newS[ij]=s[give_index(i,j,n)];
+ ij++;
+ }
+ }
+ //update newR and newS with the new taxa, again only if distance
+ //matrix is still incomplete
+ if(sw==1)
+ for(i=2;i<n-1;i++)
+ {if(new_dist[give_index(1,i,n-1)]==-1)continue;
+ for(j=i+1;j<=n-1;j++)
+ {if(new_dist[give_index(1,j,n-1)]==-1)continue;
+ if(new_dist[give_index(i,j,n-1)]==-1)continue; /* added 2012-04-02 */
+ newR[give_index(i,j,n-1)]+=(new_dist[give_index(1,i,n-1)]+new_dist[give_index(1,j,n-1)]);
+ newS[give_index(i,j,n-1)]++;
+ }
+ }
+ /* compute the branch lengths */
+
+
+
+ /* update before the next loop
+ (we are sure that OTU1 < OTU2) */
+ if (OTU1 != 1)
+ for (i = OTU1; i > 1; i--)
+ otu_label[i] = otu_label[i - 1];
+ if (OTU2 != n)
+ for (i = OTU2; i < n; i++)
+ otu_label[i] = otu_label[i + 1];
+ otu_label[1] = cur_nod;
+
+
+
+ n--;
+ for (i = 0; i < n*(n - 1)/2; i++)
+ {
+ D[i] = new_dist[i];
+ v[i] = new_v[i];
+ if(sw==1)
+ {
+ R[i] = newR[i];
+ s[i] = newS[i];
+ }
+ }
+ cur_nod--;
+ k = k + 2;
+ }
+ int dK=0;//number of known distances in final distance matrix
+ int iUK=-1;//index of unkown distance, if we have one missing distance
+ int iK=-1;//index of only known distance, only needed if dK==1
+ for (i = 0; i < 3; i++) {
+ edge1[*N*2 - 4 - i] = cur_nod;
+ edge2[*N*2 - 4 - i] = otu_label[i + 1];
+ if(D[i]!=-1){dK++;iK=i;}else{iUK=i;}
+ }
+ if(dK==2)
+ {//if two distances are known: assume our leaves are x,y,z, d(x,z) unknown
+ //and edge weights of three edges are a,b,c, then any b,c>0 that
+ //satisfy c-b=d(y,z)-d(x,y) a+c=d(y,z) are good edge weights, but for
+ //simplicity we assume a=c if d(yz)<d(xy) a=b otherwise, and after some
+ //algebra we get that we can set the missing distance equal to the
+ //maximum of the already present distances
+ double max=-1e50;
+ for(i=0;i<3;i++)
+ {if(i==iUK)continue;
+ if(D[i]>max)max=D[i];
+ }
+ D[iUK]=max;
+ }
+ if(dK==1)
+ {//through similar motivation as above, if we have just one known distance
+ //we set the other two distances equal to it
+ for(i=0;i<3;i++)
+ {if(i==iK)continue;
+ D[i]=D[iK];
+ }
+ }
+ if(dK==0)
+ {//no distances are known, we just set them to 1
+ for(i=0;i<3;i++)
+ {D[i]=1;
+ }
+ }
+ edge_length[*N*2 - 4] = (D[0] + D[1] - D[2])/2;
+ edge_length[*N*2 - 5] = (D[0] + D[2] - D[1])/2;
+ edge_length[*N*2 - 6] = (D[2] + D[1] - D[0])/2;
+}
+
+
diff --git a/src/bipartition.c b/src/bipartition.c
new file mode 100644
index 0000000..d2a682d
--- /dev/null
+++ b/src/bipartition.c
@@ -0,0 +1,213 @@
+/* bipartition.c 2014-01-02 */
+
+/* Copyright 2005-2014 Emmanuel Paradis */
+
+/* This file is part of the R-package `ape'. */
+/* See the file ../COPYING for licensing issues. */
+
+#include "ape.h"
+
+SEXP seq_root2tip(SEXP edge, SEXP nbtip, SEXP nbnode)
+{
+ int i, j, k, Nedge, *x, *done, dn, sumdone, lt, ROOT, Ntip, Nnode;
+ SEXP ans, seqnod, tmp_vec;
+
+ /* The following is needed only if we are not sure
+ that the storage mode of `edge' is "integer". */
+ PROTECT(edge = coerceVector(edge, INTSXP));
+ PROTECT(nbtip = coerceVector(nbtip, INTSXP));
+ PROTECT(nbnode = coerceVector(nbnode, INTSXP));
+ x = INTEGER(edge); /* copy the pointer */
+ Ntip = *INTEGER(nbtip);
+ Nnode = *INTEGER(nbnode);
+ Nedge = LENGTH(edge)/2;
+ ROOT = Ntip + 1;
+
+ PROTECT(ans = allocVector(VECSXP, Ntip));
+ PROTECT(seqnod = allocVector(VECSXP, Nnode));
+
+ done = &dn;
+ done = (int*)R_alloc(Nnode, sizeof(int));
+ for (i = 0; i < Nnode; i++) done[i] = 0;
+
+ tmp_vec = allocVector(INTSXP, 1);
+ INTEGER(tmp_vec)[0] = ROOT; /* sure ? */
+ SET_VECTOR_ELT(seqnod, 0, tmp_vec);
+ sumdone = 0;
+
+ while (sumdone < Nnode) {
+ for (i = 0; i < Nnode; i++) { /* loop through all nodes */
+ /* if the vector is not empty and its */
+ /* descendants are not yet found */
+ if (VECTOR_ELT(seqnod, i) == R_NilValue || done[i]) continue;
+ /* look for the descendants in 'edge': */
+ for (j = 0; j < Nedge; j++) {
+ /* skip the terminal edges, we look only for nodes now */
+ if (x[j] - Ntip != i + 1 || x[j + Nedge] <= Ntip) continue;
+ /* can now make the sequence from */
+ /* the root to the current node */
+ lt = LENGTH(VECTOR_ELT(seqnod, i));
+ tmp_vec = allocVector(INTSXP, lt + 1);
+ for (k = 0; k < lt; k++)
+ INTEGER(tmp_vec)[k] = INTEGER(VECTOR_ELT(seqnod, i))[k];
+ INTEGER(tmp_vec)[lt] = x[j + Nedge];
+ SET_VECTOR_ELT(seqnod, x[j + Nedge] - Ntip - 1, tmp_vec);
+ }
+ done[i] = 1;
+ sumdone++;
+ }
+ }
+
+ /* build the sequence from root to tip */
+ /* by simply looping through 'edge' */
+ for (i = 0; i < Nedge; i++) {
+ /* skip the internal edges */
+ if (x[i + Nedge] > Ntip) continue;
+ lt = LENGTH(VECTOR_ELT(seqnod, x[i] - Ntip - 1));
+ tmp_vec = allocVector(INTSXP, lt + 1);
+ for (j = 0; j < lt; j++)
+ INTEGER(tmp_vec)[j] = INTEGER(VECTOR_ELT(seqnod, x[i] - Ntip - 1))[j];
+ INTEGER(tmp_vec)[lt] = x[i + Nedge];
+ SET_VECTOR_ELT(ans, x[i + Nedge] - 1, tmp_vec);
+ }
+
+ UNPROTECT(5);
+ return ans;
+} /* EOF seq_root2tip */
+
+SEXP bipartition(SEXP edge, SEXP nbtip, SEXP nbnode)
+{
+ int i, j, k, lt, lt2, inod, Ntip, Nnode;
+ SEXP ans, seqnod, tmp_vec;
+
+ PROTECT(edge = coerceVector(edge, INTSXP));
+ PROTECT(nbtip = coerceVector(nbtip, INTSXP));
+ PROTECT(nbnode = coerceVector(nbnode, INTSXP));
+ Ntip = *INTEGER(nbtip);
+ Nnode = *INTEGER(nbnode);
+
+ PROTECT(ans = allocVector(VECSXP, Nnode));
+ PROTECT(seqnod = seq_root2tip(edge, nbtip, nbnode));
+
+ for (i = 0; i < LENGTH(seqnod); i++) { /* for each tip */
+ lt = LENGTH(VECTOR_ELT(seqnod, i));
+ for (j = 0; j < lt - 1; j++) {
+ inod = INTEGER(VECTOR_ELT(seqnod, i))[j] - Ntip - 1;
+ if (VECTOR_ELT(ans, inod) == R_NilValue) {
+ tmp_vec = allocVector(INTSXP, 1);
+ INTEGER(tmp_vec)[0] = i + 1;
+ } else {
+ lt2 = LENGTH(VECTOR_ELT(ans, inod));
+ tmp_vec = allocVector(INTSXP, lt2 + 1);
+ for (k = 0; k < lt2; k++)
+ INTEGER(tmp_vec)[k] = INTEGER(VECTOR_ELT(ans, inod))[k];
+ INTEGER(tmp_vec)[lt2] = i + 1;
+ }
+ SET_VECTOR_ELT(ans, inod, tmp_vec);
+ }
+ }
+
+ UNPROTECT(5);
+ return ans;
+} /* bipartition */
+
+int SameClade(SEXP clade1, SEXP clade2)
+{
+ int i, n = LENGTH(clade1), *c1, *c2;
+
+ if (n != LENGTH(clade2)) return 0;
+
+ c1 = INTEGER(clade1);
+ c2 = INTEGER(clade2);
+ for (i = 0; i < n; i++)
+ if (c1[i] != c2[i]) return 0;
+
+ return 1;
+}
+
+SEXP prop_part(SEXP TREES, SEXP nbtree, SEXP keep_partitions)
+{
+ int i, j, k, KeepPartition, Ntree, Ntip, Nnode, Npart, NpartCurrent, *no;
+ SEXP bp, ans, nbtip, nbnode, number;
+
+ PROTECT(nbtree = coerceVector(nbtree, INTSXP));
+ PROTECT(keep_partitions = coerceVector(keep_partitions, INTSXP));
+ Ntree = *INTEGER(nbtree);
+ KeepPartition = *INTEGER(keep_partitions);
+
+
+ Ntip = LENGTH(getListElement(VECTOR_ELT(TREES, 0), "tip.label"));
+ Nnode = *INTEGER(getListElement(VECTOR_ELT(TREES, 0), "Nnode"));
+
+ PROTECT(nbtip = allocVector(INTSXP, 1));
+ PROTECT(nbnode = allocVector(INTSXP, 1));
+ INTEGER(nbtip)[0] = Ntip;
+ INTEGER(nbnode)[0] = Nnode;
+
+ if (KeepPartition) Npart = Ntree * (Ntip - 2) + 1;
+ else Npart = Ntip - 1;
+
+ PROTECT(number = allocVector(INTSXP, Npart));
+ no = INTEGER(number); /* copy the pointer */
+ /* The first partition in the returned list has all tips,
+ so it is observed in all trees: */
+ no[0] = Ntree;
+ /* The partitions in the first tree are obviously observed once: */
+ for (i = 1; i < Nnode; i++) no[i] = 1;
+
+ if (KeepPartition) {
+ for (i = Nnode; i < Npart; i++) no[i] = 0;
+
+ PROTECT(ans = allocVector(VECSXP, Npart));
+ PROTECT(bp = bipartition(getListElement(VECTOR_ELT(TREES, 0), "edge"),
+ nbtip, nbnode));
+ for (i = 0; i < Nnode; i++)
+ SET_VECTOR_ELT(ans, i, VECTOR_ELT(bp, i));
+ UNPROTECT(1);
+ } else {
+ PROTECT(ans = bipartition(getListElement(VECTOR_ELT(TREES, 0), "edge"),
+ nbtip, nbnode));
+ }
+
+ NpartCurrent = Nnode;
+
+ /* We start on the 2nd tree: */
+ for (k = 1; k < Ntree; k++) {
+
+/* in case there are trees with multichotomies: */
+ nbnode = getListElement(VECTOR_ELT(TREES, k), "Nnode");
+ Nnode = INTEGER(nbnode)[0];
+
+ PROTECT(bp = bipartition(getListElement(VECTOR_ELT(TREES, k), "edge"),
+ nbtip, nbnode));
+ for (i = 1; i < Nnode; i++) {
+ j = 1;
+next_j:
+ if (SameClade(VECTOR_ELT(bp, i), VECTOR_ELT(ans, j))) {
+ no[j]++;
+ continue;
+ }
+ j++;
+ if (j < NpartCurrent) goto next_j;
+ if (KeepPartition) {
+ no[NpartCurrent]++;
+ SET_VECTOR_ELT(ans, NpartCurrent, VECTOR_ELT(bp, i));
+ NpartCurrent++;
+ }
+ }
+ UNPROTECT(1);
+ }
+
+ if (KeepPartition && NpartCurrent < Npart) {
+ PROTECT(bp = allocVector(VECSXP, NpartCurrent));
+ for (i = 0; i < NpartCurrent; i++)
+ SET_VECTOR_ELT(bp, i, VECTOR_ELT(ans, i));
+ setAttrib(bp, install("number"), number);
+ UNPROTECT(7);
+ return bp;
+ } else {
+ setAttrib(ans, install("number"), number);
+ UNPROTECT(6);
+ return ans;
+ }
+} /* prop_part */
diff --git a/src/bitsplits.c b/src/bitsplits.c
new file mode 100644
index 0000000..cb3afbb
--- /dev/null
+++ b/src/bitsplits.c
@@ -0,0 +1,268 @@
+/* bitsplits.c 2014-01-02 */
+
+/* Copyright 2005-2014 Emmanuel Paradis */
+
+/* This file is part of the R-package `ape'. */
+/* See the file ../COPYING for licensing issues. */
+
+#include "ape.h"
+
+/* the following array stores the 8 mask values:
+ [0] = 0000 0001
+ [1] = 1000 0000
+ [2] = 0100 0000
+ [3] = 0010 0000
+ [4] = 0001 0000
+ [5] = 0000 1000
+ [6] = 0000 0100
+ [7] = 0000 0010
+ so that mask81[y % 8] gives the corresponding mask (note that 8 % 8 is 0) */
+static const unsigned char mask81[8] = {0x01, 0x80, 0x40, 0x20, 0x10, 0x08, 0x04, 0x02};
+
+void OneWiseBitsplits(unsigned char *mat, int nr, int nc, int rest)
+{
+ /* the following array stores the 8 mask values:
+ [0] = 0000 0000
+ [1] = 1000 0000
+ [2] = 1100 0000
+ [3] = 1110 0000
+ [4] = 1111 0000
+ [5] = 1111 1000
+ [6] = 1111 1100
+ [7] = 1111 1110
+ to set the trailing bits to zero when appropriate */
+ const unsigned char trailzeros[8] = {0x00, 0x80, 0xc0, 0xe0, 0xf0, 0xf8, 0xfc, 0xfe};
+
+ int i, j;
+
+ for (i = 0; i < nc; i++) {
+ j = nr * i;
+ if (mat[j] & mask81[1]) continue;
+ while (j < nr * (i + 1)) {
+ mat[j] = ~mat[j];
+ j++;
+ }
+ if (rest) mat[j - 1] &= trailzeros[rest];
+ }
+}
+
+#define update_L(x)\
+ k = e[i] - *n - 1;\
+ L[k + *m * pos[k]] = x;\
+ pos[k]++
+
+void bitsplits_phylo(int *n, int *m, int *e, int *N, int *nr, unsigned char *mat)
+/* n: nb of tips, m: nb of nodes, N: nb of edges,
+ nr: number of rows in mat */
+{
+ int ii, i, j, k, d, y, *L, *pos, inod;
+
+ L = (int*)R_alloc(*n * *m, sizeof(int));
+ pos = (int*)R_alloc(*m, sizeof(int));
+ memset(pos, 0, *m * sizeof(int));
+
+ ii = 0;
+ for (i = 0; i < *N; i++) {
+ d = e[i + *N];
+/* Rprintf("d = %d\n", d); */
+ if (d <= *n) { /* trivial split from a terminal branch */
+ update_L(d); /* update L */
+ } else {
+ inod = d - *n - 1;
+ for (j = 0; j < pos[inod]; j++) {
+ y = L[inod + *m * j];
+/* Rprintf("\ty = %d\n", y); */
+/* Rprintf("\t\ty / 9 + *nr * ii = %d\n", y / 9 + *nr * ii); */
+/* Rprintf("\t\ty % 8 = %d\n", y % 8); */
+ mat[(y -1) / 8 + *nr * ii] |= mask81[y % 8];
+ update_L(y); /* update L */
+ }
+ ii++;
+ }
+ }
+ OneWiseBitsplits(mat, *nr, ii, *n % 8);
+}
+
+void CountBipartitionsFromTrees(int *n, int *m, int *e, int *N, int *nr, int *nc, unsigned char *mat, double *freq)
+{
+ int i, j, k, d, y, *L, *pos, inod;
+ unsigned char *split;
+
+ L = (int*)R_alloc(*n * *m, sizeof(int));
+ pos = (int*)R_alloc(*m, sizeof(int));
+ memset(pos, 0, *m * sizeof(int));
+ split = (unsigned char*)R_alloc(*nr, sizeof(unsigned char));
+
+ for (i = 0; i < *N; i++) {
+ memset(split, 0, *nr * sizeof(unsigned char));
+ d = e[i + *N];
+ if (d <= *n) { /* trivial split from a terminal branch */
+ update_L(d);
+ } else {
+ inod = d - *n - 1;
+ for (j = 0; j < pos[inod]; j++) {
+ y = L[inod + *m * j];
+ split[(y - 1) / 8] |= mask81[y % 8];
+ update_L(y);
+ }
+ }
+ OneWiseBitsplits(split, *nr, 1, *n % 8);
+ j = 0; /* column of mat */
+ k = 0; /* row */
+ y = 0; /* number of columns of mat to shift */
+ while (j < *nc) {
+ if (split[k] != mat[k + y]) { /* the two splits are different so move to the next col of mat */
+ j++;
+ k = 0;
+ y += *nr;
+ } else k++;
+ if (k == *nr) { /* the two splits are the same so stop here */
+ freq[j]++;
+ break;
+ }
+ }
+ }
+}
+
+#undef update_L
+
+static int iii;
+
+void bar_reorder2(int node, int n, int m, int Nedge, int *e, int *neworder, int *L, int *pos)
+{
+ int i = node - n - 1, j, k;
+
+ for (j = pos[i] - 1; j >= 0; j--)
+ neworder[iii--] = L[i + m * j] + 1;
+
+ for (j = 0; j < pos[i]; j++) {
+ k = e[L[i + m * j] + Nedge];
+ if (k > n)
+ bar_reorder2(k, n, m, Nedge, e, neworder, L, pos);
+ }
+}
+
+#define update_L(x)\
+ k = e_reord[i] - Ntip - 1;\
+ L[k + Nnode * pos[k]] = x;\
+ pos[k]++
+
+SEXP bitsplits_multiPhylo(SEXP x, SEXP n, SEXP nr)
+{
+ int Ntip, Nnode, Nr, Ntrees, itr, Nc, *e, *e_reord, Nedge, *L, *pos, i, j, k, ispl, *newor, d, inod, y, *rfreq, new_split;
+ unsigned char *split, *rmat;
+ SEXP mat, freq, ans, EDGE, final_nc;
+
+ PROTECT(x = coerceVector(x, VECSXP));
+ PROTECT(n = coerceVector(n, INTSXP)); /* nb of tips */
+ PROTECT(nr = coerceVector(nr, INTSXP)); /* nb of rows in the matrix of splits */
+ Ntrees = LENGTH(x);
+ Ntip = *INTEGER(n);
+ Nr = *INTEGER(nr);
+
+ Nc = (Ntip - 3) * Ntrees; /* the maximum number of splits that can be found */
+
+/* Rprintf("Nc = %d\n", Nc); */
+
+ PROTECT(mat = allocVector(RAWSXP, Nr * Nc));
+ PROTECT(freq = allocVector(INTSXP, Nc));
+ rmat = RAW(mat);
+ rfreq = INTEGER(freq);
+
+ memset(rmat, 0, Nr * Nc * sizeof(unsigned char));
+ /* memset(rfreq, 0, Nc * sizeof(int)); */
+
+ split = (unsigned char*)R_alloc(Nr, sizeof(unsigned char));
+
+ ispl = 0; /* nb of splits already stored */
+
+ for (itr = 0; itr < Ntrees; itr++) {
+
+/* Rprintf("itr = %d\n", itr); */
+
+ Nnode = *INTEGER(getListElement(VECTOR_ELT(x, itr), "Nnode"));
+ PROTECT(EDGE = getListElement(VECTOR_ELT(x, itr), "edge"));
+ e = INTEGER(EDGE);
+ Nedge = LENGTH(EDGE)/2;
+
+/* Rprintf("Nedge = %d\n", Nedge); */
+
+ /* see explanations in ape/src/reorder_phylo.c */
+ L = (int*)R_alloc(Nnode * (Nedge - Ntip + 1), sizeof(int));
+ pos = (int*)R_alloc(Nnode, sizeof(int));
+ memset(pos, 0, Nnode * sizeof(int));
+ for (i = 0; i < Nedge; i++) {
+ k = e[i] - Ntip - 1;
+ j = pos[k];
+ pos[k]++;
+ L[k + Nnode * j] = i;
+ }
+ iii = Nedge - 1;
+ newor = (int*)R_alloc(Nedge, sizeof(int));
+ bar_reorder2(Ntip + 1, Ntip, Nnode, Nedge, e, newor, L, pos);
+ e_reord = (int*)R_alloc(2 * Nedge, sizeof(int));
+ for (i = 0; i < Nedge; i++) newor[i]--; /* change R indices into C indices */
+ for (i = 0; i < Nedge; i++) {
+ e_reord[i] = e[newor[i]];
+ e_reord[i + Nedge] = e[newor[i] + Nedge];
+ }
+ /* the tree is now reordered */
+
+ /* reallocate L and reinitialize pos */
+ L = (int*)R_alloc(Nnode * Ntip, sizeof(int));
+ memset(pos, 0, Nnode * sizeof(int));
+
+ for (i = 0; i < Nedge; i++) {
+ memset(split, 0, Nr * sizeof(unsigned char));
+ d = e_reord[i + Nedge];
+
+ if (d <= Ntip) { /* trivial split from a terminal branch */
+ update_L(d);
+ continue;
+ }
+
+ inod = d - Ntip - 1;
+ for (j = 0; j < pos[inod]; j++) {
+ y = L[inod + Nnode * j];
+/* Rprintf("itr = %d\ty = %d\n", itr, y); */
+ split[(y - 1) / 8] |= mask81[y % 8];
+ update_L(y); /* update L */
+ }
+ OneWiseBitsplits(split, Nr, 1, Ntip % 8);
+ new_split = 1;
+ if (itr > 0) { /* if we are handling the 1st tree, no need to check cause all splits are new */
+ j = 0; /* column of rmat */
+ k = 0; /* row */
+ y = 0; /* number of columns of rmat to shift */
+ while (j < ispl) {
+ if (split[k] != rmat[k + y]) { /* the two splits are different so move to the next col of rmat */
+ j++;
+ k = 0;
+ y += Nr;
+ } else k++;
+
+ if (k == Nr) { /* the two splits are the same, so stop here */
+ rfreq[j]++;
+ new_split = 0;
+ break;
+ }
+ }
+ }
+ if (new_split) {
+/* Rprintf("ispl = %d\n", ispl); */
+ for (j = 0; j < Nr; j++) rmat[j + ispl * Nr] = split[j];
+ rfreq[ispl] = 1;
+ ispl++;
+ }
+ }
+ UNPROTECT(1);
+ }
+ PROTECT(ans = allocVector(VECSXP, 3));
+ PROTECT(final_nc = allocVector(INTSXP, 1));
+ INTEGER(final_nc)[0] = ispl;
+ SET_VECTOR_ELT(ans, 0, mat);
+ SET_VECTOR_ELT(ans, 1, freq);
+ SET_VECTOR_ELT(ans, 2, final_nc);
+ UNPROTECT(7);
+ return ans;
+}
diff --git a/src/delta_plot.c b/src/delta_plot.c
new file mode 100644
index 0000000..4df27fc
--- /dev/null
+++ b/src/delta_plot.c
@@ -0,0 +1,49 @@
+/* delta_plot.c 2011-06-23 */
+
+/* Copyright 2010-2011 Emmanuel Paradis */
+
+/* This file is part of the R-package `ape'. */
+/* See the file ../COPYING for licensing issues. */
+
+#include <R.h>
+
+void delta_plot(double *D, int *size, int *nbins, int *counts, double *deltabar)
+{
+ int x, y, u, v; /* same notation than in Holland et al. 2002 */
+ int n = *size, nb = *nbins;
+ double dxy, dxu, dxv, dyu, dyv, duv, A, B, C, delta;
+ int xy, xu, xv, yu, yv, uv, i;
+
+ for (x = 0; x < n - 3; x++) {
+ xy = x*n - x*(x + 1)/2; /* do NOT factorize */
+ for (y = x + 1; y < n - 2; y++, xy++) {
+ yu = y*n - y*(y + 1)/2; /* do NOT factorize */
+ dxy = D[xy];
+ xu = xy + 1;
+ for (u = y + 1; u < n - 1; u++, xu++, yu++) {
+ uv = u*n - u*(u + 1)/2; /* do NOT factorize */
+ dxu = D[xu]; dyu = D[yu];
+ xv = xu + 1; yv = yu + 1;
+ for (v = u + 1; v < n; v++, xv++, yv++, uv++) {
+ dxv = D[xv]; dyv = D[yv]; duv = D[uv];
+ A = dxv + dyu; B = dxu + dyv; C = dxy + duv;
+ if (A == B && B == C) delta = 0; else while (1) {
+ if (C <= B && B <= A) {delta = (A - B)/(A - C); break;}
+ if (B <= C && C <= A) {delta = (A - C)/(A - B); break;}
+ if (A <= C && C <= B) {delta = (B - C)/(B - A); break;}
+ if (C <= A && A <= B) {delta = (B - A)/(B - C); break;}
+ if (A <= B && B <= C) {delta = (C - B)/(C - A); break;}
+ if (B <= A && A <= C) {delta = (C - A)/(C - B); break;}
+ }
+ /* if (delta == 1) i = nb - 1; else */
+ i = delta * nb;
+ counts[i] += 1;
+ deltabar[x] += delta;
+ deltabar[y] += delta;
+ deltabar[u] += delta;
+ deltabar[v] += delta;
+ }
+ }
+ }
+ }
+}
diff --git a/src/dist_dna.c b/src/dist_dna.c
new file mode 100644
index 0000000..8adcb68
--- /dev/null
+++ b/src/dist_dna.c
@@ -0,0 +1,1166 @@
+/* dist_dna.c 2013-08-20 */
+
+/* Copyright 2005-2013 Emmanuel Paradis */
+
+/* This file is part of the R-package `ape'. */
+/* See the file ../COPYING for licensing issues. */
+
+#include <R_ext/Lapack.h>
+#include "ape.h"
+
+/* from R: print(log(4), d = 22) */
+#define LN4 1.386294361119890572454
+
+/* returns 8 if the base is known surely, 0 otherwise */
+#define KnownBase(a) (a & 8)
+
+/* returns 1 if the base is adenine surely, 0 otherwise */
+#define IsAdenine(a) a == 136
+
+/* returns 1 if the base is guanine surely, 0 otherwise */
+#define IsGuanine(a) a == 72
+
+/* returns 1 if the base is cytosine surely, 0 otherwise */
+#define IsCytosine(a) a == 40
+
+/* returns 1 if the base is thymine surely, 0 otherwise */
+#define IsThymine(a) a == 24
+
+/* returns 1 if the base is a purine surely, 0 otherwise */
+#define IsPurine(a) a > 63
+
+/* returns 1 if the base is a pyrimidine surely, 0 otherwise */
+#define IsPyrimidine(a) a < 64
+
+/* returns 1 if both bases are different surely, 0 otherwise */
+#define DifferentBase(a, b) (a & b) < 16
+
+/* returns 1 if both bases are the same surely, 0 otherwise */
+#define SameBase(a, b) KnownBase(a) && a == b
+
+/* computes directly the determinant of a 4x4 matrix */
+double detFourByFour(double *x)
+{
+ double det, a33a44, a34a43, a34a42, a32a44, a32a43, a33a42, a34a41, a31a44, a31a43, a33a41, a31a42, a32a41;
+
+ a33a44 = x[10]*x[15]; a34a43 = x[14]*x[11];
+ a34a42 = x[14]*x[7]; a32a44 = x[6]*x[15];
+ a32a43 = x[6]*x[11]; a33a42 = x[10]*x[7];
+ a34a41 = x[14]*x[3]; a31a44 = x[2]*x[15];
+ a31a43 = x[2]*x[11]; a33a41 = x[10]*x[3];
+ a31a42 = x[2]*x[7]; a32a41 = x[6]*x[3];
+
+ det = x[0]*x[5]*(a33a44 - a34a43) + x[0]*x[9]*(a34a42 - a32a44) +
+ x[0]*x[13]*(a32a43 - a33a42) + x[4]*x[9]*(a31a44 - a34a41) +
+ x[4]*x[13]*(a33a41 - a31a43) + x[4]*x[1]*(a34a43 - a33a44) +
+ x[8]*x[13]*(a31a42 - a32a41) + x[8]*x[1]*(a32a44 - a34a42) +
+ x[8]*x[5]*(a34a41 - a31a44) + x[12]*x[1]*(a33a42 - a32a43) +
+ x[12]*x[5]*(a31a43 - a33a41) + x[12]*x[9]*(a32a41 - a31a42);
+
+ return det;
+}
+
+#define CHECK_PAIRWISE_DELETION\
+ if (KnownBase(x[s1]) && KnownBase(x[s2])) L++;\
+ else continue;
+
+#define COUNT_TS_TV\
+ if (SameBase(x[s1], x[s2])) continue;\
+ Nd++;\
+ if (IsPurine(x[s1]) && IsPurine(x[s2])) {\
+ Ns++;\
+ continue;\
+ }\
+ if (IsPyrimidine(x[s1]) && IsPyrimidine(x[s2])) Ns++;
+
+void distDNA_indel(unsigned char *x, int *n, int *s, double *d)
+{
+ int i1, i2, s1, s2, target, N;
+
+ target = 0;
+ for (i1 = 1; i1 < *n; i1++) {
+ for (i2 = i1 + 1; i2 <= *n; i2++) {
+ N = 0;
+
+ for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n)
+ if ((x[s1] ^ x[s2]) & 4) N++;
+
+ d[target] = ((double) N);
+ target++;
+ }
+ }
+}
+
+#define X(i, j) i - 1 + *n * (j - 1)
+
+void distDNA_indelblock(unsigned char *x, int *n, int *s, double *d)
+{
+ int i1, i2, s1, s2, target, start_block, end_block;
+
+ for (i1 = 1; i1 <= *n; i1++) {
+
+/* find a block of one or more '-' */
+
+ s1 = 1;
+ while (s1 < *s) {
+ if (x[X(i1, s1)] == 4) {
+ start_block = s1;
+ while (x[X(i1, s1)] == 4) s1++;
+ end_block = s1 - 1;
+
+/* then look if the same block is present in all the other sequences */
+
+ for (i2 = 1; i2 <= *n; i2++) {
+ if (i2 == i1) continue;
+
+ target = give_index(i1, i2, *n);
+
+ if (start_block > 1) {
+ if (x[X(i2, start_block - 1)] == 4) {
+ d[target]++;
+ continue;
+ }
+ }
+ if (end_block < *s) {
+ if (x[X(i2, end_block + 1)] == 4) {
+ d[target]++;
+ continue;
+ }
+ }
+ for (s2 = start_block; s2 <= end_block; s2++) {
+ if (x[X(i2, s2)] != 4) {
+ d[target]++;
+ continue;
+ }
+ }
+ }
+ s1 = end_block + 1;
+ }
+ s1++;
+ }
+ }
+}
+
+#undef X
+
+void distDNA_TsTv(unsigned char *x, int *n, int *s, double *d, int Ts, int pairdel)
+{
+ int i1, i2, s1, s2, target, Nd, Ns;
+
+ target = 0;
+ for (i1 = 1; i1 < *n; i1++) {
+ for (i2 = i1 + 1; i2 <= *n; i2++) {
+ Nd = Ns = 0;
+ for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) {
+ if (pairdel && !(KnownBase(x[s1]) && KnownBase(x[s2]))) continue;
+ COUNT_TS_TV
+ }
+ if (Ts) d[target] = ((double) Ns); /* output number of transitions */
+ else d[target] = ((double) Nd - Ns); /* output number of transversions */
+ target++;
+ }
+ }
+}
+
+void distDNA_raw(unsigned char *x, int *n, int *s, double *d, int scaled)
+{
+ int i1, i2, s1, s2, target, Nd;
+
+ target = 0;
+ for (i1 = 1; i1 < *n; i1++) {
+ for (i2 = i1 + 1; i2 <= *n; i2++) {
+ Nd = 0;
+ for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n)
+ if (DifferentBase(x[s1], x[s2])) Nd++;
+ if (scaled) d[target] = ((double) Nd / *s);
+ else d[target] = ((double) Nd);
+ target++;
+ }
+ }
+}
+
+void distDNA_raw_pairdel(unsigned char *x, int *n, int *s, double *d, int scaled)
+{
+ int i1, i2, s1, s2, target, Nd, L;
+
+ target = 0;
+ for (i1 = 1; i1 < *n; i1++) {
+ for (i2 = i1 + 1; i2 <= *n; i2++) {
+ Nd = L = 0;
+ for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) {
+ CHECK_PAIRWISE_DELETION
+ if (DifferentBase(x[s1], x[s2])) Nd++;
+ }
+ if (scaled) d[target] = ((double) Nd/L);
+ else d[target] = ((double) Nd);
+ target++;
+ }
+ }
+}
+
+#define COMPUTE_DIST_JC69\
+ p = ((double) Nd/L);\
+ if (*gamma)\
+ d[target] = 0.75 * *alpha*(pow(1 - 4*p/3, -1/ *alpha) - 1);\
+ else d[target] = -0.75*log(1 - 4*p/3);\
+ if (*variance) {\
+ if (*gamma) var[target] = p*(1 - p)/(pow(1 - 4*p/3, -2/(*alpha + 1)) * L);\
+ else var[target] = p*(1 - p)/(pow(1 - 4*p/3, 2)*L);\
+ }
+
+void distDNA_JC69(unsigned char *x, int *n, int *s, double *d,
+ int *variance, double *var, int *gamma, double *alpha)
+{
+ int i1, i2, s1, s2, target, Nd, L;
+ double p;
+
+ L = *s;
+
+ target = 0;
+ for (i1 = 1; i1 < *n; i1++) {
+ for (i2 = i1 + 1; i2 <= *n; i2++) {
+ Nd = 0;
+ for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n)
+ if (DifferentBase(x[s1], x[s2])) Nd++;
+ COMPUTE_DIST_JC69
+ target++;
+ }
+ }
+}
+
+void distDNA_JC69_pairdel(unsigned char *x, int *n, int *s, double *d,
+ int *variance, double *var, int *gamma, double *alpha)
+{
+ int i1, i2, s1, s2, target, Nd, L;
+ double p;
+
+ target = 0;
+ for (i1 = 1; i1 < *n; i1++) {
+ for (i2 = i1 + 1; i2 <= *n; i2++) {
+ Nd = L = 0;
+ for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1+= *n, s2 += *n) {
+ CHECK_PAIRWISE_DELETION
+ if (DifferentBase(x[s1], x[s2])) Nd++;
+ }
+ COMPUTE_DIST_JC69
+ target++;
+ }
+ }
+}
+
+#define COMPUTE_DIST_K80\
+ P = ((double) Ns/L);\
+ Q = ((double) (Nd - Ns)/L);\
+ a1 = 1 - 2*P - Q;\
+ a2 = 1 - 2*Q;\
+ if (*gamma) {\
+ b = -1 / *alpha;\
+ d[target] = *alpha * (pow(a1, b) + 0.5*pow(a2, b) - 1.5)/2;\
+ }\
+ else d[target] = -0.5 * log(a1 * sqrt(a2));\
+ if (*variance) {\
+ if (*gamma) {\
+ b = -(1 / *alpha + 1);\
+ c1 = pow(a1, b);\
+ c2 = pow(a2, b);\
+ c3 = (c1 + c2)/2;\
+ } else {\
+ c1 = 1/a1;\
+ c2 = 1/a2;\
+ c3 = (c1 + c2)/2;\
+ }\
+ var[target] = (c1*c1*P + c3*c3*Q - pow(c1*P + c3*Q, 2))/L;\
+ }
+
+void distDNA_K80(unsigned char *x, int *n, int *s, double *d,
+ int *variance, double *var, int *gamma, double *alpha)
+{
+ int i1, i2, s1, s2, target, Nd, Ns, L;
+ double P, Q, a1, a2, b, c1, c2, c3;
+
+ L = *s;
+
+ target = 0;
+ for (i1 = 1; i1 < *n; i1++) {
+ for (i2 = i1 + 1; i2 <= *n; i2++) {
+ Nd = Ns = 0;
+ for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1+= *n, s2 += *n) {
+ COUNT_TS_TV
+ }
+ COMPUTE_DIST_K80
+ target++;
+ }
+ }
+}
+
+void distDNA_K80_pairdel(unsigned char *x, int *n, int *s, double *d,
+ int *variance, double *var, int *gamma, double *alpha)
+{
+ int i1, i2, s1, s2, target, Nd, Ns, L;
+ double P, Q, a1, a2, b, c1, c2, c3;
+
+ target = 0;
+ for (i1 = 1; i1 < *n; i1++) {
+ for (i2 = i1 + 1; i2 <= *n; i2++) {
+ Nd = Ns = L = 0;
+ for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) {
+ CHECK_PAIRWISE_DELETION
+ COUNT_TS_TV
+ }
+ COMPUTE_DIST_K80
+ target++;
+ }
+ }
+}
+
+#define COMPUTE_DIST_F81\
+ p = ((double) Nd/L);\
+ if (*gamma) d[target] = E * *alpha * (pow(1 - p/E, -1/ *alpha) - 1);\
+ else d[target] = -E*log(1 - p/E);\
+ if (*variance) {\
+ if (*gamma) var[target] = p*(1 - p)/(pow(1 - p/E, -2/(*alpha + 1)) * L);\
+ else var[target] = p*(1 - p)/(pow(1 - p/E, 2)*L);\
+ }
+
+void distDNA_F81(unsigned char *x, int *n, int *s, double *d, double *BF,
+ int *variance, double *var, int *gamma, double *alpha)
+{
+ int i1, i2, s1, s2, target, Nd, L;
+ double p, E;
+
+ L = *s;
+ E = 1 - BF[0]*BF[0] - BF[1]*BF[1] - BF[2]*BF[2] - BF[3]*BF[3];
+
+ target = 0;
+ for (i1 = 1; i1 < *n; i1++) {
+ for (i2 = i1 + 1; i2 <= *n; i2++) {
+ Nd = 0;
+ for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1+= *n, s2 += *n)
+ if (DifferentBase(x[s1], x[s2])) Nd++;
+ COMPUTE_DIST_F81
+ target++;
+ }
+ }
+}
+
+void distDNA_F81_pairdel(unsigned char *x, int *n, int *s, double *d, double *BF,
+ int *variance, double *var, int *gamma, double *alpha)
+{
+ int i1, i2, s1, s2, target, Nd, L;
+ double p, E;
+
+ E = 1 - BF[0]*BF[0] - BF[1]*BF[1] - BF[2]*BF[2] - BF[3]*BF[3];
+
+ target = 0;
+ for (i1 = 1; i1 < *n; i1++) {
+ for (i2 = i1 + 1; i2 <= *n; i2++) {
+ Nd = L = 0;
+ for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) {
+ CHECK_PAIRWISE_DELETION
+ if (DifferentBase(x[s1], x[s2])) Nd++;
+ }
+ COMPUTE_DIST_F81
+ target++;
+ }
+ }
+}
+
+#define COUNT_TS_TV1_TV2\
+ if (SameBase(x[s1], x[s2])) continue;\
+ Nd++;\
+ if ((x[s1] | x[s2]) == 152 || (x[s1] | x[s2]) == 104) {\
+ Nv1++;\
+ continue;\
+ }\
+ if ((x[s1] | x[s2]) == 168 || (x[s1] | x[s2]) == 88) Nv2++;
+
+
+#define COMPUTE_DIST_K81\
+ P = ((double) (Nd - Nv1 - Nv2)/L);\
+ Q = ((double) Nv1/L);\
+ R = ((double) Nv2/L);\
+ a1 = 1 - 2*P - 2*Q;\
+ a2 = 1 - 2*P - 2*R;\
+ a3 = 1 - 2*Q - 2*R;\
+ d[target] = -0.25*log(a1*a2*a3);\
+ if (*variance) {\
+ a = (1/a1 + 1/a2)/2;\
+ b = (1/a1 + 1/a3)/2;\
+ c = (1/a2 + 1/a3)/2;\
+ var[target] = (a*a*P + b*b*Q + c*c*R - pow(a*P + b*Q + c*R, 2))/2;\
+ }
+
+void distDNA_K81(unsigned char *x, int *n, int *s, double *d,
+ int *variance, double *var)
+{
+ int i1, i2, Nd, Nv1, Nv2, L, s1, s2, target;
+ double P, Q, R, a1, a2, a3, a, b, c;
+
+ L = *s;
+
+ target = 0;
+ for (i1 = 1; i1 < *n; i1++) {
+ for (i2 = i1 + 1; i2 <= *n; i2++) {
+ Nd = Nv1 = Nv2 = 0;
+ for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) {
+ COUNT_TS_TV1_TV2
+ }
+ COMPUTE_DIST_K81
+ target++;
+ }
+ }
+}
+
+void distDNA_K81_pairdel(unsigned char *x, int *n, int *s, double *d,
+ int *variance, double *var)
+{
+ int i1, i2, Nd, Nv1, Nv2, L, s1, s2, target;
+ double P, Q, R, a1, a2, a3, a, b, c;
+
+ target = 0;
+ for (i1 = 1; i1 < *n; i1++) {
+ for (i2 = i1 + 1; i2 <= *n; i2++) {
+ Nd = Nv1 = Nv2 = L = 0;
+ for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) {
+ CHECK_PAIRWISE_DELETION
+ COUNT_TS_TV1_TV2
+ }
+ COMPUTE_DIST_K81
+ target++;
+ }
+ }
+}
+
+#define PREPARE_BF_F84\
+ A = (BF[0]*BF[2])/(BF[0] + BF[2]) + (BF[1]*BF[3])/(BF[1] + BF[3]);\
+ B = BF[0]*BF[2] + BF[1]*BF[3];\
+ C = (BF[0] + BF[2])*(BF[1] + BF[3]);
+
+#define COMPUTE_DIST_F84\
+ P = ((double) Ns/L);\
+ Q = ((double) (Nd - Ns)/L);\
+ d[target] = -2*A*log(1 - P/(2*A) - (A - B)*Q/(2*A*C)) + 2*(A - B - C)*log(1 - Q/(2*C));\
+ if (*variance) {\
+ t1 = A*C;\
+ t2 = C*P/2;\
+ t3 = (A - B)*Q/2;\
+ a = t1/(t1 - t2 - t3);\
+ b = A*(A - B)/(t1 - t2 - t3) - (A - B - C)/(C - Q/2);\
+ var[target] = (a*a*P + b*b*Q - pow(a*P + b*Q, 2))/L;\
+ }
+
+void distDNA_F84(unsigned char *x, int *n, int *s, double *d,
+ double *BF, int *variance, double *var)
+{
+ int i1, i2, Nd, Ns, L, target, s1, s2;
+ double P, Q, A, B, C, a, b, t1, t2, t3;
+
+ PREPARE_BF_F84
+ L = *s;
+
+ target = 0;
+ for (i1 = 1; i1 < *n; i1++) {
+ for (i2 = i1 + 1; i2 <= *n; i2++) {
+ Nd = Ns = 0;
+ for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) {
+ COUNT_TS_TV
+ }
+ COMPUTE_DIST_F84
+ target++;
+ }
+ }
+}
+
+void distDNA_F84_pairdel(unsigned char *x, int *n, int *s, double *d,
+ double *BF, int *variance, double *var)
+{
+ int i1, i2, Nd, Ns, L, target, s1, s2;
+ double P, Q, A, B, C, a, b, t1, t2, t3;
+
+ PREPARE_BF_F84
+
+ target = 0;
+ for (i1 = 1; i1 < *n; i1++) {
+ for (i2 = i1 + 1; i2 <= *n; i2++) {
+ Nd = Ns = L = 0;
+ for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) {
+ CHECK_PAIRWISE_DELETION
+ COUNT_TS_TV
+ }
+ COMPUTE_DIST_F84
+ target++;
+ }
+ }
+}
+
+#define COMPUTE_DIST_T92\
+ P = ((double) Ns/L);\
+ Q = ((double) (Nd - Ns)/L);\
+ a1 = 1 - P/wg - Q;\
+ a2 = 1 - 2*Q;\
+ d[target] = -wg*log(a1) - 0.5*(1 - wg)*log(a2);\
+ if (*variance) {\
+ c1 = 1/a1;\
+ c2 = 1/a2;\
+ c3 = wg*(c1 - c2) + c2;\
+ var[target] = (c1*c1*P + c3*c3*Q - pow(c1*P + c3*Q, 2))/L;\
+ }
+
+void distDNA_T92(unsigned char *x, int *n, int *s, double *d,
+ double *BF, int *variance, double *var)
+{
+ int i1, i2, Nd, Ns, L, target, s1, s2;
+ double P, Q, wg, a1, a2, c1, c2, c3;
+
+ L = *s;
+ wg = 2 * (BF[1] + BF[2]) * (1 - (BF[1] + BF[2]));
+
+ target = 0;
+ for (i1 = 1; i1 < *n; i1++) {
+ for (i2 = i1 + 1; i2 <= *n; i2++) {
+ Nd = Ns = 0;
+ for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) {
+ COUNT_TS_TV
+ }
+ COMPUTE_DIST_T92
+ target++;
+ }
+ }
+}
+
+void distDNA_T92_pairdel(unsigned char *x, int *n, int *s, double *d,
+ double *BF, int *variance, double *var)
+{
+ int i1, i2, Nd, Ns, L, target, s1, s2;
+ double P, Q, wg, a1, a2, c1, c2, c3;
+
+ wg = 2 * (BF[1] + BF[2]) * (1 - (BF[1] + BF[2]));
+
+ target = 0;
+ for (i1 = 1; i1 < *n; i1++) {
+ for (i2 = i1 + 1; i2 <= *n; i2++) {
+ Nd = Ns = L = 0;
+ for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) {
+ CHECK_PAIRWISE_DELETION
+ COUNT_TS_TV
+ }
+ COMPUTE_DIST_T92
+ target++;
+ }
+ }
+}
+
+/* returns 1 if one of the base is adenine and
+ the other one is guanine surely, 0 otherwise */
+#define AdenineAndGuanine(a, b) (a | b) == 200
+
+/* returns 1 if one of the base is cytosine and
+ the other one is thymine surely, 0 otherwise */
+#define CytosineAndThymine(a, b) (a | b) == 56
+
+#define PREPARE_BF_TN93\
+ gR = BF[0] + BF[2];\
+ gY = BF[1] + BF[3];\
+ k1 = 2 * BF[0] * BF[2] / gR;\
+ k2 = 2 * BF[1] * BF[3] / gY;\
+ k3 = 2 * (gR * gY - BF[0]*BF[2]*gY/gR - BF[1]*BF[3]*gR/gY);
+
+#define COUNT_TS1_TS2_TV\
+ if (DifferentBase(x[s1], x[s2])) {\
+ Nd++;\
+ if (AdenineAndGuanine(x[s1], x[s2])) {\
+ Ns1++;\
+ continue;\
+ }\
+ if (CytosineAndThymine(x[s1], x[s2])) Ns2++;\
+ }
+
+#define COMPUTE_DIST_TN93\
+ P1 = ((double) Ns1/L);\
+ P2 = ((double) Ns2/L);\
+ Q = ((double) (Nd - Ns1 - Ns2)/L);\
+ w1 = 1 - P1/k1 - Q/(2*gR);\
+ w2 = 1 - P2/k2 - Q/(2*gY);\
+ w3 = 1 - Q/(2*gR*gY);\
+ if (*gamma) {\
+ k4 = 2*(BF[0]*BF[2] + BF[1]*BF[3] + gR*gY);\
+ b = -1 / *alpha;\
+ c1 = pow(w1, b);\
+ c2 = pow(w2, b);\
+ c3 = pow(w3, b);\
+ c4 = k1*c1/(2*gR) + k2*c2/(2*gY) + k3*c3/(2*gR*gY);\
+ d[target] = *alpha * (k1*pow(w1, b) + k2*pow(w2, b) + k3*pow(w3, b) - k4);\
+ } else {\
+ k4 = 2*((BF[0]*BF[0] + BF[2]*BF[2])/(2*gR*gR) + (BF[2]*BF[2] + BF[3]*BF[3])/(2*gY*gY));\
+ c1 = 1/w1;\
+ c2 = 1/w2;\
+ c3 = 1/w3;\
+ c4 = k1 * c1/(2 * gR) + k2 * c2/(2 * gY) + k4 * c3;\
+ d[target] = -k1*log(w1) - k2*log(w2) - k3*log(w3);\
+ }\
+ if (*variance)\
+ var[target] = (c1*c1*P1 + c2*c2*P2 + c4*c4*Q - pow(c1*P1 + c2*P2 + c4*Q, 2))/L;
+
+void distDNA_TN93(unsigned char *x, int *n, int *s, double *d,
+ double *BF, int *variance, double *var,
+ int *gamma, double *alpha)
+{
+ int i1, i2, Nd, Ns1, Ns2, L, target, s1, s2;
+ double P1, P2, Q, gR, gY, k1, k2, k3, k4, w1, w2, w3, c1, c2, c3, c4, b;
+
+ L = *s;
+
+ PREPARE_BF_TN93
+
+ target = 0;
+ for (i1 = 1; i1 < *n; i1++) {
+ for (i2 = i1 + 1; i2 <= *n; i2++) {
+ Nd = Ns1 = Ns2 = 0;
+ for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) {
+ COUNT_TS1_TS2_TV
+ }
+ COMPUTE_DIST_TN93
+ target++;
+ }
+ }
+}
+
+void distDNA_TN93_pairdel(unsigned char *x, int *n, int *s, double *d,
+ double *BF, int *variance, double *var,
+ int *gamma, double *alpha)
+{
+ int i1, i2, Nd, Ns1, Ns2, L, target, s1, s2;
+ double P1, P2, Q, gR, gY, k1, k2, k3, k4, w1, w2, w3, c1, c2, c3, c4, b;
+
+ PREPARE_BF_TN93
+
+ target = 0;
+ for (i1 = 1; i1 < *n; i1++) {
+ for (i2 = i1 + 1; i2 <= *n; i2++) {
+ Nd = Ns1 = Ns2 = L = 0;
+ for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) {
+ CHECK_PAIRWISE_DELETION
+ COUNT_TS1_TS2_TV
+ }
+ COMPUTE_DIST_TN93
+ target++;
+ }
+ }
+}
+
+void distDNA_GG95(unsigned char *x, int *n, int *s, double *d,
+ int *variance, double *var)
+{
+ int i1, i2, s1, s2, target, GC, Nd, Ns, tl, npair;
+ double *theta, gcprop, *P, pp, *Q, qq, *tstvr, svr, A, sum, ma /* mean alpha */, K1, K2;
+
+ theta = &gcprop;
+ P = &pp;
+ Q = &qq;
+ tstvr = &svr;
+
+ npair = *n * (*n - 1) / 2;
+
+ theta = (double*)R_alloc(*n, sizeof(double));
+ P = (double*)R_alloc(npair, sizeof(double));
+ Q = (double*)R_alloc(npair, sizeof(double));
+ tstvr = (double*)R_alloc(npair, sizeof(double));
+
+ /* get the proportion of GC (= theta) in each sequence */
+ for (i1 = 1; i1 <= *n; i1++) {
+ GC = 0;
+ for (s1 = i1 - 1; s1 < i1 + *n*(*s - 1); s1 += *n)
+ if (IsCytosine(x[s1]) || IsGuanine(x[s1])) GC += 1;
+ theta[i1 - 1] = ((double) GC / *s);
+ }
+
+ /* get the proportions of transitions and transversions,
+ and the estimates of their ratio for each pair */
+ target = 0;
+ for (i1 = 1; i1 < *n; i1++) {
+ for (i2 = i1 + 1; i2 <= *n; i2++) {
+ Nd = Ns = 0;
+ for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) {
+ COUNT_TS_TV
+ }
+ P[target] = ((double) Ns / *s);
+ Q[target] = ((double) (Nd - Ns) / *s);
+ A = log(1 - 2*Q[target]);
+ tstvr[target] = 2*(log(1 - 2*P[target] - Q[target]) - 0.5*A)/A;
+ target++;
+ }
+ }
+
+ /* compute the mean alpha (ma) = mean Ts/Tv */
+ sum = 0;
+ tl = 0;
+ for (i1 = 0; i1 < npair; i1++)
+ /* some values of tstvr are -Inf if there is no
+ transversions observed: we exclude them */
+ if (R_FINITE(tstvr[i1])) {
+ sum += tstvr[i1];
+ tl += 1;
+ }
+ ma = sum/tl;
+
+ /* compute the distance for each pair */
+ target = 0;
+ for (i1 = 1; i1 < *n; i1++) {
+ for (i2 = i1 + 1; i2 <= *n; i2++) {
+ A = 1 - 2*Q[target];
+ K1 = 1 + ma*(theta[i1 - 1]*(1 - theta[i1 - 1]) + theta[i2 - 1]*(1 - theta[i2 - 1]));
+ K2 = ma*pow(theta[i1 - 1] - theta[i2 - 1], 2)/(ma + 1);
+ d[target] = -0.5*K1*log(A) + K2*(1 - pow(A, 0.25*(ma + 1)));
+ if (*variance)
+ var[target] = pow(K1 + K2*0.5*(ma + 1)*pow(A, 0.25*(ma + 1)), 2)*Q[target]*(1 - Q[target])/(A*A * *s);
+ target++;
+ }
+ }
+}
+
+void distDNA_GG95_pairdel(unsigned char *x, int *n, int *s, double *d,
+ int *variance, double *var)
+{
+ int i1, i2, s1, s2, target, *L, length, GC, Nd, Ns, tl, npair;
+ double *theta, gcprop, *P, pp, *Q, qq, *tstvr, svr, A, sum, ma /* mean alpha */, K1, K2;
+
+ theta = &gcprop;
+ L = &length;
+ P = &pp;
+ Q = &qq;
+ tstvr = &svr;
+
+ npair = *n * (*n - 1) / 2;
+
+ theta = (double*)R_alloc(*n, sizeof(double));
+ L = (int*)R_alloc(npair, sizeof(int));
+ P = (double*)R_alloc(npair, sizeof(double));
+ Q = (double*)R_alloc(npair, sizeof(double));
+ tstvr = (double*)R_alloc(npair, sizeof(double));
+
+ /* get the proportion of GC (= theta) in each sequence */
+ for (i1 = 1; i1 <= *n; i1++) {
+ tl = GC = 0;
+ for (s1 = i1 - 1; s1 < i1 + *n*(*s - 1); s1 += *n) {
+ if (KnownBase(x[s1])) tl++;
+ else continue;
+ if (IsCytosine(x[s1]) || IsGuanine(x[s1])) GC += 1;
+ }
+ theta[i1 - 1] = ((double) GC / tl);
+ }
+
+ /* get the proportions of transitions and transversions,
+ and the estimates of their ratio for each pair; we
+ also get the sample size for each pair in L */
+ target = 0;
+ for (i1 = 1; i1 < *n; i1++) {
+ for (i2 = i1 + 1; i2 <= *n; i2++) {
+ Nd = Ns = L[target] = 0;
+ for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) {
+ if (KnownBase(x[s1]) && KnownBase(x[s2])) L[target]++;
+ else continue;
+ COUNT_TS_TV
+ }
+ P[target] = ((double) Ns/L[target]);
+ Q[target] = ((double) (Nd - Ns)/L[target]);
+ A = log(1 - 2*Q[target]);
+ tstvr[target] = 2*(log(1 - 2*P[target] - Q[target]) - 0.5*A)/A;
+ target++;
+ }
+ }
+
+ /* compute the mean alpha (ma) = mean Ts/Tv */
+ sum = 0;
+ tl = 0;
+ for (i1 = 0; i1 < npair; i1++)
+ /* some values of tstvr are -Inf if there is no
+ transversions observed: we exclude them */
+ if (R_FINITE(tstvr[i1])) {
+ sum += tstvr[i1];
+ tl += 1;
+ }
+ ma = sum/tl;
+
+ /* compute the distance for each pair */
+ target = 0;
+ for (i1 = 1; i1 < *n; i1++) {
+ for (i2 = i1 + 1; i2 <= *n; i2++) {
+ A = 1 - 2*Q[target];
+ K1 = 1 + ma*(theta[i1 - 1]*(1 - theta[i1 - 1]) + theta[i2 - 1]*(1 - theta[i2 - 1]));
+ K2 = ma*pow(theta[i1 - 1] - theta[i2 - 1], 2)/(ma + 1);
+ d[target] = -0.5*K1*log(A) + K2*(1 - pow(A, 0.25*(ma + 1)));
+ if (*variance)
+ var[target] = pow(K1 + K2*0.5*(ma + 1)*pow(A, 0.25*(ma + 1)), 2)*Q[target]*(1 - Q[target])/(A*A*L[target]);
+ target++;
+ }
+ }
+}
+
+#define DO_CONTINGENCY_NUCLEOTIDES\
+ switch (x[s1]) {\
+ case 136 : m = 0; break;\
+ case 72 : m = 1; break;\
+ case 40 : m = 2; break;\
+ case 24 : m = 3; break;\
+ }\
+ switch (x[s2]) {\
+ case 72 : m += 4; break;\
+ case 40 : m += 8; break;\
+ case 24 : m += 12; break;\
+ }\
+ Ntab[m]++;
+
+#define COMPUTE_DIST_LogDet\
+ for (k = 0; k < 16; k++) Ftab[k] = ((double) Ntab[k]/L);\
+ d[target] = -log(detFourByFour(Ftab))/4 - LN4;\
+ if (*variance) {\
+ /* For the inversion, we first make U an identity matrix */\
+ for (k = 1; k < 15; k++) U[k] = 0;\
+ U[0] = U[5] = U[10] = U[15] = 1;\
+ /* The matrix is not symmetric, so we use 'dgesv'. */\
+ /* This subroutine puts the result in U. */\
+ F77_CALL(dgesv)(&ndim, &ndim, Ftab, &ndim, ipiv, U, &ndim, &info);\
+ var[target] = (U[0]*U[0]*Ftab[0] + U[1]*U[1]*Ftab[4] +\
+ U[2]*U[2]*Ftab[8] + U[3]*U[3]*Ftab[12] +\
+ U[4]*U[4]*Ftab[1] + U[5]*U[5]*Ftab[5] +\
+ U[6]*U[6]*Ftab[9] + U[7]*U[7]*Ftab[13] +\
+ U[8]*U[8]*Ftab[2] + U[9]*U[9]*Ftab[6] +\
+ U[10]*U[10]*Ftab[10] + U[11]*U[11]*Ftab[14] +\
+ U[12]*U[12]*Ftab[3] + U[13]*U[13]*Ftab[7] +\
+ U[14]*U[14]*Ftab[11] + U[15]*U[15]*Ftab[15] - 16)/(L*16);\
+ }
+
+void distDNA_LogDet(unsigned char *x, int *n, int *s, double *d,
+ int *variance, double *var)
+{
+ int i1, i2, k, m, s1, s2, target, L, Ntab[16], ndim = 4, info, ipiv[16];
+ double Ftab[16], U[16];
+
+ L = *s;
+
+ target = 0;
+ for (i1 = 1; i1 < *n; i1++) {
+ for (i2 = i1 + 1; i2 <= *n; i2++) {
+ for (k = 0; k < 16; k++) Ntab[k] = 0;
+ for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) {
+ DO_CONTINGENCY_NUCLEOTIDES
+ }
+ COMPUTE_DIST_LogDet
+ target++;
+ }
+ }
+}
+
+void distDNA_LogDet_pairdel(unsigned char *x, int *n, int *s, double *d,
+ int *variance, double *var)
+{
+ int i1, i2, k, m, s1, s2, target, L, Ntab[16], ndim = 4, info, ipiv[16];
+ double Ftab[16], U[16];
+
+ target = 0;
+ for (i1 = 1; i1 < *n; i1++) {
+ for (i2 = i1 + 1; i2 <= *n; i2++) {
+ for (k = 0; k < 16; k++) Ntab[k] = 0;
+ L = 0;
+ for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) {
+ CHECK_PAIRWISE_DELETION
+ DO_CONTINGENCY_NUCLEOTIDES
+ }
+ COMPUTE_DIST_LogDet
+ target++;
+ }
+ }
+}
+
+void distDNA_BH87(unsigned char *x, int *n, int *s, double *d,
+ int *variance, double *var)
+/* <FIXME>
+ For the moment there is no need to check for pairwise deletions
+ since DO_CONTINGENCY_NUCLEOTIDES considers only the known nucleotides.
+ In effect the pairwise deletion has possibly been done before.
+ The sequence length(s) are used only to compute the variances, which is
+ currently not available.
+ </FIXME> */
+{
+ int i1, i2, k, kb, s1, s2, m, Ntab[16], ROWsums[4];
+ double P12[16], P21[16];
+
+ for (i1 = 1; i1 < *n; i1++) {
+ for (i2 = i1 + 1; i2 <= *n; i2++) {
+ for (k = 0; k < 16; k++) Ntab[k] = 0;
+ for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) {
+ DO_CONTINGENCY_NUCLEOTIDES
+ }
+
+ /* get the rowwise sums of Ntab */
+ ROWsums[0] = Ntab[0] + Ntab[4] + Ntab[8] + Ntab[12];
+ ROWsums[1] = Ntab[1] + Ntab[5] + Ntab[9] + Ntab[13];
+ ROWsums[2] = Ntab[2] + Ntab[6] + Ntab[10] + Ntab[14];
+ ROWsums[3] = Ntab[3] + Ntab[7] + Ntab[11] + Ntab[15];
+
+ for (k = 0; k < 16; k++)
+ P12[k] = ((double) Ntab[k]);
+
+ /* scale each element of P12 by its rowwise sum */
+ for (k = 0; k < 4; k++)
+ for (kb = 0; kb < 16; kb += 4)
+ P12[k + kb] = P12[k + kb]/ROWsums[k];
+
+ d[*n*(i2 - 1) + i1 - 1] = -log(detFourByFour(P12))/4;
+
+ /* compute the columnwise sums of Ntab: these
+ are the rowwise sums of its transpose */
+ ROWsums[0] = Ntab[0] + Ntab[1] + Ntab[2] + Ntab[3];
+ ROWsums[1] = Ntab[4] + Ntab[5] + Ntab[6] + Ntab[7];
+ ROWsums[2] = Ntab[8] + Ntab[9] + Ntab[10] + Ntab[11];
+ ROWsums[3] = Ntab[12] + Ntab[13] + Ntab[14] + Ntab[15];
+
+ /* transpose Ntab and store the result in P21 */
+ for (k = 0; k < 4; k++)
+ for (kb = 0; kb < 4; kb++)
+ P21[kb + 4*k] = Ntab[k + 4*kb];
+
+ /* scale as above */
+ for (k = 0; k < 4; k++)
+ for (kb = 0; kb < 16; kb += 4)
+ P21[k + kb] = P21[k + kb]/ROWsums[k];
+
+ d[*n*(i1 - 1) + i2 - 1] = -log(detFourByFour(P21))/4;
+ }
+ }
+}
+
+#define COMPUTE_DIST_ParaLin\
+ for (k = 0; k < 16; k++) Ftab[k] = ((double) Ntab[k]/L);\
+ d[target] = -log(detFourByFour(Ftab)/\
+ sqrt(find[0][i1 - 1]*find[1][i1 - 1]*find[2][i1 - 1]*find[3][i1 - 1]*\
+ find[0][i2 - 1]*find[1][i2 - 1]*find[2][i2 - 1]*find[3][i2 - 1]))/4;\
+ if (*variance) {\
+ /* For the inversion, we first make U an identity matrix */\
+ for (k = 1; k < 15; k++) U[k] = 0;\
+ U[0] = U[5] = U[10] = U[15] = 1;\
+ /* The matrix is not symmetric, so we use 'dgesv'. */\
+ /* This subroutine puts the result in U. */\
+ F77_CALL(dgesv)(&ndim, &ndim, Ftab, &ndim, ipiv, U, &ndim, &info);\
+ var[target] = (U[0]*U[0]*Ftab[0] + U[1]*U[1]*Ftab[4] +\
+ U[2]*U[2]*Ftab[8] + U[3]*U[3]*Ftab[12] +\
+ U[4]*U[4]*Ftab[1] + U[5]*U[5]*Ftab[5] +\
+ U[6]*U[6]*Ftab[9] + U[7]*U[7]*Ftab[13] +\
+ U[8]*U[8]*Ftab[2] + U[9]*U[9]*Ftab[6] +\
+ U[10]*U[10]*Ftab[10] + U[11]*U[11]*Ftab[14] +\
+ U[12]*U[12]*Ftab[3] + U[13]*U[13]*Ftab[7] +\
+ U[14]*U[14]*Ftab[11] + U[15]*U[15]*Ftab[15] -\
+ 4*(1/sqrt(find[0][i1 - 1]*find[0][i2 - 1]) +\
+ 1/sqrt(find[1][i1 - 1]*find[1][i2 - 1]) +\
+ 1/sqrt(find[2][i1 - 1]*find[2][i2 - 1]) +\
+ 1/sqrt(find[3][i1 - 1]*find[3][i2 - 1])))/(L*16);\
+ }
+
+void distDNA_ParaLin(unsigned char *x, int *n, int *s, double *d,
+ int *variance, double *var)
+{
+ int i1, i2, k, s1, s2, m, target, L, Ntab[16], ndim = 4, info, ipiv[16];
+ double Ftab[16], U[16], *find[4];
+
+ L = *s;
+
+ for (k = 0; k < 4; k++)
+ find[k] = (double*)R_alloc(*n, sizeof(double));
+
+ for (i1 = 0; i1 < *n; i1++)
+ for (k = 0; k < 4; k++) find[k][i1] = 0.0;
+
+ for (i1 = 0; i1 < *n; i1++) {
+ for (s1 = i1; s1 < i1 + *n*(*s - 1) + 1; s1+= *n) {
+ switch (x[s1]) {
+ case 136 : find[0][i1]++; break;
+ case 40 : find[1][i1]++; break;
+ case 72 : find[2][i1]++; break;
+ case 24 : find[3][i1]++; break;
+ }
+ }
+ for (k = 0; k < 4; k++) find[k][i1] /= L;
+ }
+
+ target = 0;
+ for (i1 = 1; i1 < *n; i1++) {
+ for (i2 = i1 + 1; i2 <= *n; i2++) {
+ for (k = 0; k < 16; k++) Ntab[k] = 0;
+ for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) {
+ DO_CONTINGENCY_NUCLEOTIDES
+ }
+ COMPUTE_DIST_ParaLin
+ target++;
+ }
+ }
+}
+
+void distDNA_ParaLin_pairdel(unsigned char *x, int *n, int *s, double *d,
+ int *variance, double *var)
+{
+ int i1, i2, k, s1, s2, m, target, L, Ntab[16], ndim = 4, info, ipiv[16];
+ double Ftab[16], U[16], *find[4];
+
+ L = 0;
+
+ for (k = 0; k < 4; k++)
+ find[k] = (double*)R_alloc(*n, sizeof(double));
+
+ for (i1 = 0; i1 < *n; i1++)
+ for (k = 0; k < 4; k++) find[k][i1] = 0.0;
+
+ for (i1 = 0; i1 < *n; i1++) {
+ L = 0;
+ for (s1 = i1; s1 < i1 + *n*(*s - 1) + 1; s1+= *n) {
+ if (KnownBase(x[s1])) {
+ L++;
+ switch (x[s1]) {
+ case 136 : find[0][i1]++; break;
+ case 40 : find[1][i1]++; break;
+ case 72 : find[2][i1]++; break;
+ case 24 : find[3][i1]++; break;
+ }
+ }
+ }
+ for (k = 0; k < 4; k++) find[k][i1] /= L;
+ }
+
+ target = 0;
+ for (i1 = 1; i1 < *n; i1++) {
+ for (i2 = i1 + 1; i2 <= *n; i2++) {
+ L = 0;
+ for (k = 0; k < 16; k++) Ntab[k] = 0;
+ for (s1 = i1 - 1, s2 = i2 - 1; s1 < i1 + *n*(*s - 1); s1 += *n, s2 += *n) {
+ CHECK_PAIRWISE_DELETION
+ DO_CONTINGENCY_NUCLEOTIDES
+ }
+ COMPUTE_DIST_ParaLin
+ target++;
+ }
+ }
+}
+
+/* a hash table is much faster than switch (2012-01-10) */
+void BaseProportion(unsigned char *x, int *n, double *BF)
+{
+ int i;
+ double count[256];
+
+ memset(count, 0, 256*sizeof(double));
+
+ for (i = 0; i < *n; i++) count[x[i]]++;
+
+ BF[0] = count[136];
+ BF[1] = count[40];
+ BF[2] = count[72];
+ BF[3] = count[24];
+ BF[4] = count[192];
+ BF[5] = count[160];
+ BF[6] = count[144];
+ BF[7] = count[96];
+ BF[8] = count[80];
+ BF[9] = count[48];
+ BF[10] = count[224];
+ BF[11] = count[176];
+ BF[12] = count[208];
+ BF[13] = count[112];
+ BF[14] = count[240];
+ BF[15] = count[4];
+ BF[16] = count[2];
+}
+
+void SegSites(unsigned char *x, int *n, int *s, int *seg)
+{
+ int i, j;
+ unsigned char basis;
+
+ for (j = 0; j < *s; j++) {
+ i = *n * j;
+ while (!KnownBase(x[i])) i++;
+ basis = x[i];
+ i++;
+ while (i < *n * (j + 1)) {
+ if (!KnownBase(x[i]) || x[i] == basis) i++;
+ else {
+ seg[j] = 1;
+ break;
+ }
+ }
+ }
+}
+
+void GlobalDeletionDNA(unsigned char *x, int *n, int *s, int *keep)
+{
+ int i, j;
+
+ for (j = 0; j < *s; j++) {
+ i = *n * j;
+ while (i < *n * (j + 1)) {
+ if (KnownBase(x[i])) i++;
+ else {
+ keep[j] = 0;
+ break;
+ }
+ }
+ }
+}
+
+void dist_dna(unsigned char *x, int *n, int *s, int *model, double *d,
+ double *BF, int *pairdel, int *variance, double *var,
+ int *gamma, double *alpha)
+{
+ switch (*model) {
+ case 1 : if (pairdel) distDNA_raw_pairdel(x, n, s, d, 1);
+ else distDNA_raw(x, n, s, d, 1); break;
+ case 2 : if (pairdel) distDNA_JC69_pairdel(x, n, s, d, variance, var, gamma, alpha);
+ else distDNA_JC69(x, n, s, d, variance, var, gamma, alpha); break;
+ case 3 : if (pairdel) distDNA_K80_pairdel(x, n, s, d, variance, var, gamma, alpha);
+ else distDNA_K80(x, n, s, d, variance, var, gamma, alpha); break;
+ case 4 : if (pairdel) distDNA_F81_pairdel(x, n, s, d, BF, variance, var, gamma, alpha);
+ else distDNA_F81(x, n, s, d, BF, variance, var, gamma, alpha); break;
+ case 5 : if (pairdel) distDNA_K81_pairdel(x, n, s, d, variance, var);
+ else distDNA_K81(x, n, s, d, variance, var); break;
+ case 6 : if (pairdel) distDNA_F84_pairdel(x, n, s, d, BF, variance, var);
+ else distDNA_F84(x, n, s, d, BF, variance, var); break;
+ case 7 : if (pairdel) distDNA_T92_pairdel(x, n, s, d, BF, variance, var);
+ else distDNA_T92(x, n, s, d, BF, variance, var); break;
+ case 8 : if (pairdel) distDNA_TN93_pairdel(x, n, s, d, BF, variance, var, gamma, alpha);
+ else distDNA_TN93(x, n, s, d, BF, variance, var, gamma, alpha); break;
+ case 9 : if (pairdel) distDNA_GG95_pairdel(x, n, s, d, variance, var);
+ else distDNA_GG95(x, n, s, d, variance, var); break;
+ case 10 : if (pairdel) distDNA_LogDet_pairdel(x, n, s, d, variance, var);
+ else distDNA_LogDet(x, n, s, d, variance, var); break;
+ case 11 : distDNA_BH87(x, n, s, d, variance, var); break;
+ case 12 : if (pairdel) distDNA_ParaLin_pairdel(x, n, s, d, variance, var);
+ else distDNA_ParaLin(x, n, s, d, variance, var); break;
+ case 13 : if (pairdel) distDNA_raw_pairdel(x, n, s, d, 0);
+ else distDNA_raw(x, n, s, d, 0); break;
+ case 14 : if (pairdel) distDNA_TsTv(x, n, s, d, 1, 1);
+ else distDNA_TsTv(x, n, s, d, 1, 0); break;
+ case 15 : if (pairdel) distDNA_TsTv(x, n, s, d, 0, 1);
+ else distDNA_TsTv(x, n, s, d, 0, 0); break;
+ case 16 : distDNA_indel(x, n, s, d); break;
+ case 17 : distDNA_indelblock(x, n, s, d); break;
+ }
+}
+
+void C_where(unsigned char *x, unsigned char *pat, int *s, int *p,
+ int *ans, int *n)
+{
+ int i, j, k, ln;
+
+ ln = 0; /* local n */
+
+ for (i = 0; i <= *s - *p; i++) {
+ k = i; j = 0;
+ while (1) {
+ if (x[k] != pat[j]) break;
+ j++; k++;
+ if (j == *p) {
+ ans[ln++] = k - 1;
+ break;
+ }
+ }
+ }
+ *n = ln;
+}
diff --git a/src/dist_nodes.c b/src/dist_nodes.c
new file mode 100644
index 0000000..d091cb9
--- /dev/null
+++ b/src/dist_nodes.c
@@ -0,0 +1,41 @@
+/* dist_nodes.c 2012-08-14 */
+
+/* Copyright 2012 Emmanuel Paradis */
+
+/* This file is part of the R-package `ape'. */
+/* See the file ../COPYING for licensing issues. */
+
+#include <R.h>
+
+#define DINDEX2(i, j) i + NM * j
+
+/* The algorithm is pretty simple: the tree must be in cladewise order
+ because the edges are visited contiguously. Each edge gives trivially
+ one distance, then by moving up along the edge matrix, one finds nodes
+ that have already been visited and the distance matrix can be updated. */
+
+void dist_nodes(int *n, int *m, int *e1, int *e2, double *el, int *N, double *D)
+/* n: nb of tips, m: nb of nodes, N: nb of edges */
+{
+ int i, j, k, a, d, NM = *n + *m, ROOT;
+ double x;
+
+ ROOT = e1[0]; d = e2[0]; /* the 2 nodes of the 1st edge */
+ D[DINDEX2(ROOT, d)] = D[DINDEX2(d, ROOT)] = el[0]; /* the 1st edge gives the 1st distance */
+
+/* go down along the edge matrix
+ starting at the 2nd edge: */
+ for (i = 1; i < *N; i++) {
+ a = e1[i]; d = e2[i]; x = el[i]; /* get the i-th nodes and branch length */
+ D[DINDEX2(a, d)] = D[DINDEX2(d, a)] = x;
+ /* then go up along the edge matrix from the i-th edge
+ to visit the nodes already visited and update the distances: */
+ for (j = i - 1; j >= 0; j--) {
+ k = e2[j];
+ if (k == a) continue;
+ D[DINDEX2(k, d)] = D[DINDEX2(d, k)] = D[DINDEX2(a, k)] + x;
+ }
+ if (k != ROOT)
+ D[DINDEX2(ROOT, d)] = D[DINDEX2(d, ROOT)] = D[DINDEX2(ROOT, a)] + x;
+ }
+}
diff --git a/src/ewLasso.c b/src/ewLasso.c
new file mode 100644
index 0000000..826a56a
--- /dev/null
+++ b/src/ewLasso.c
@@ -0,0 +1,239 @@
+/* ewLasso.c 2013-03-30 */
+
+/* Copyright 2013 Andrei-Alin Popescu */
+
+/* This file is part of the R-package `ape'. */
+/* See the file ../COPYING for licensing issues. */
+
+#include "ape.h"
+
+int isTripletCover(int nmb, int n, int** s, int stat, int sSoFar[n], int* a)//number of sides, number of leaves, sides, side under consideration, set so far, lasso
+{
+ int ret=0;
+ if(stat==nmb)return 1;
+ int i=0;
+
+ for(i=1;i<=n;i++)
+ {
+ if(!s[stat][i])continue;//not in set
+ int sw=1, j;
+
+ for(j=1;j<=n;j++)//check if all distances to previous candidates are present
+ {
+ if(!sSoFar[j])continue;//not in set so far
+ if(!a[i*(n+1)+j]){//if not, then i is not a good candidate for this side
+ //Rprintf("failed to find distance between %i and %i, a[%i][%i]=%i \n",i,j,i,j,a[i*(n+1)+j]);
+ sw=0;
+ }
+ }
+
+ if(!sw)continue;//not all required distances are present
+
+ sSoFar[i]=1;//try choosing i as representative for the side
+ ret+=isTripletCover(nmb,n,s,stat+1,sSoFar,a)>0?1:0;//see if, with i chosen, we can find leaves in other sides to satisfy the triplet cover condition
+ sSoFar[i]=0;
+ }
+ return ret;
+}
+
+void C_ewLasso(double *D, int *N, int *e1, int *e2)
+{
+ int n, i, j, k;
+
+ n=*N;
+ int tCov=1;
+ int* a = (int*)R_alloc((n+1)*(n+1), sizeof(int));//adjacency matrix of G_{\cL} graph
+
+ for(i=1;i<=n;i++)
+ {
+ for(j=1;j<=n;j++)
+ {
+ if(D[give_index(i,j,n)]==-1)//if missing value then no edge between pair of taxa (i,j) in G
+ {
+ a[i*(n+1)+j]=a[j*(n+1)+i]=0;
+ }
+ else
+ {
+ a[i*(n+1)+j]=a[j*(n+1)+i]=1;// otherwise edge between pair of taxa (i,j) in G
+ }
+ }
+ }
+ //check for connectedness of G
+
+ int *q = (int*)R_alloc(2*n-1, sizeof(int));//BFS queue
+ int *v = (int*)R_alloc(2*n-1, sizeof(int));//visited?
+
+ int p=0,u=1;//p-head of queue, u- position after last loaded element
+
+ for(i=1;i<=n;i++)v[i]=-1;
+
+ int stNBipartite=1, con=1, comp=1;
+ int ini=1;
+
+ /*for(i=1;i<=n;i++)
+ {
+ for(j=1;j<=n;j++)
+ {
+ Rprintf("a[%i][%i]=%i ",i,j,a[i*(n+1)+j]);
+ }
+ Rprintf("\n");
+ }*/
+
+ while(comp)
+ {
+ q[p]=ini;
+ v[ini]=1;
+ comp=0;
+ int stNBipartiteLoc=0;//check if current connected component is bipartite
+ while(p<u)//BFS
+ {
+ int head=q[p];
+ //Rprintf("head: %i\n",head);
+ //Rprintf("unvisited neighbours: \n");
+ for(i=1;i<=n;i++)
+ {
+ if(i==head)continue;
+ if(a[i*(n+1)+head]==0)continue;
+ if(v[i]==v[head])//same color as vertex from which we visit-> not bipartite
+ {
+ stNBipartiteLoc=1;
+ }
+ if(v[i]!=-1)continue;
+ //Rprintf("vertex %i \n",i);
+ q[u++]=i;
+ v[i]=1-v[head];
+ }
+ p++;
+ }
+ stNBipartite*=stNBipartiteLoc;//anding strngly-non-bipartite over all connected components
+
+
+
+ //check if all vertices have been visited
+ for(int i=1;i<=n;i++)
+ {
+ if(v[i]==-1)
+ {
+ comp=1;
+ p=0;
+ u=1;
+ ini=i;
+ con=0;
+ break;
+ }
+ }
+ }
+
+ Rprintf("connected: %i\n",con);
+ Rprintf("strongly non-bipartite: %i\n",stNBipartite);
+
+ //finally check if \cL is triplet cover of T
+
+ //adjencency matrix of tree, 1 to n are leaves
+
+ int *at= (int*)R_alloc((2*n-1)*(2*n-1), sizeof(int));
+
+ for(i=1;i<=2*n-2;i++)
+ {
+ for(j=1;j<=2*n-2;j++)at[i*(2*n-1)+j]=0;
+ }
+
+ for(i=0;i<2*n-3;i++)
+ {
+ //Rprintf("e1[%i]=%i e2[%i]=%i \n",i,e1[i],i,e2[i]);
+ at[e1[i]*(2*n-1)+e2[i]]=at[e2[i]*(2*n-1)+e1[i]]=1;
+ }
+
+ /*for(i=1;i<2*n-1;i++)
+ {
+ for(j=1;j<2*n-1;j++)
+ {
+ Rprintf("at[%i][%i]=%i ",i,j,at[i*(2*n-1)+j]);
+ }
+ Rprintf("\n");
+ }*/
+
+ for(i=n+1;i<=2*n-2;i++)//for each interior vertex
+ {
+ for(j=1;j<2*n-1;j++)//reset queue and visited veectors
+ {
+ v[j]=-1;
+ q[j]=0;
+ }
+
+ v[i]=1;//'disconnect' graph at i
+ int *l=(int*)R_alloc(2*n-2, sizeof(int));//vertices adjacent to i
+
+ int nmb=0;//number of found adjacent vertices of i
+
+ for(j=1;j<=2*n-2;j++)//find adjacent vertices
+ {
+ if(at[i*(2*n-1)+j]==1)
+ {
+ l[nmb++]=j;
+ }
+ }
+
+ int** s=(int**)R_alloc(nmb,sizeof(int*));//set of leaves in each side, stored as presence/absence
+
+ for(j=0;j<nmb;j++)s[j]=(int*)R_alloc(n+1,sizeof(int));
+
+ for(j=0;j<nmb;j++)
+ {
+ for(k=1;k<=n;k++)s[j][k]=0;
+ }
+
+ /*Rprintf("for %i \n",i);
+
+ for(j=0;j<nmb;j++)Rprintf("l[%i]= %i ",j,l[j]);
+
+ Rprintf("\n");*/
+
+ for(j=0;j<nmb;j++)//for each adjancet vertex, find its leafset
+ {
+ p=0;
+ u=1;
+ ini=l[j];
+ q[p]=ini;
+ v[ini]=1;
+ if(ini<=n)s[j][ini]=1;
+ comp=0;
+ int nbr=0;
+ while(p<u)//BFS
+ {
+ int head=q[p];
+ //Rprintf("head: %i\n",head);
+ //Rprintf("unvisited neighbours: \n");
+ for(nbr=1;nbr<=2*n-1;nbr++)
+ {
+ if(nbr==head)continue;
+ if(at[nbr*(2*n-1)+head]==0)continue;
+ if(v[nbr]!=-1)continue;
+ //Rprintf("vertex %i \n",nbr);
+ if(nbr<=n)s[j][nbr]=1;//if leaf, then set visited to true
+ q[u++]=nbr;
+ v[nbr]=1;
+ }
+ p++;
+ }
+ }
+
+ /*Rprintf("sides for %i\n",i);
+ for(j=0;j<nmb;j++)
+ {
+ int ii;
+ for(ii=1;ii<=n;ii++)
+ {
+ if(s[j][ii])Rprintf("%i ",ii);
+ }
+ Rprintf("\n");
+ }*/
+
+ int* sSoFar= (int*)R_alloc(n+1,sizeof(int));
+
+ for(j=1;j<=n;j++)sSoFar[j]=0;
+
+ tCov*=isTripletCover(nmb,n,s,0,sSoFar,a)>0?1:0;
+ }
+ Rprintf("is triplet cover? %i \n",tCov);
+}
diff --git a/src/heap.c b/src/heap.c
new file mode 100644
index 0000000..ddc1e84
--- /dev/null
+++ b/src/heap.c
@@ -0,0 +1,112 @@
+/* heap.c 2007-09-05 */
+
+/* Copyright 2007 Vincent Lefort */
+
+/* This file is part of the R-package `ape'. */
+/* See the file ../COPYING for licensing issues. */
+
+#include "me.h"
+
+int *initPerm(int size)
+{
+ int *p;
+ int i;
+ p = (int *) malloc(size*sizeof(int));
+ for(i = 0;i<size;i++)
+ p[i] = i;
+ return(p);
+}
+
+void permInverse(int *p, int *q, int length)
+{
+ int i;
+ for(i=0;i<length;i++)
+ q[p[i]] = i;
+}
+
+/*swaps two values of a permutation*/
+void swap(int *p, int *q, int i, int j)
+{
+ int temp;
+ temp = p[i];
+ p[i] = p[j];
+ p[j] = temp;
+ q[p[i]] = i;
+ q[p[j]] = j;
+}
+
+/*The usual Heapify function, tailored for our use with a heap of scores*/
+/*will use array p to keep track of indexes*/
+/*after scoreHeapify is called, the subtree rooted at i
+ will be a heap*/
+
+/*p goes from heap to array, q goes from array to heap*/
+
+void heapify(int *p, int *q, double *HeapArray, int i, int n)
+{
+ int moreswap = 1;
+
+ do {
+ int left = 2 * i;
+ int right = 2* i + 1;
+ int smallest;
+ if ((left <= n) && (HeapArray[p[left]] < HeapArray[p[i]]))
+ smallest = left;
+ else
+ smallest = i;
+ if ((right <= n) && (HeapArray[p[right]] < HeapArray[p[smallest]]))
+ smallest = right;
+ if (smallest != i){
+ swap(p,q,i, smallest);
+ /*push smallest up the heap*/
+ i = smallest; /*check next level down*/
+ }
+ else
+ moreswap = 0;
+ } while(moreswap);
+}
+
+/*heap is of indices of elements of v,
+ popHeap takes the index at position i and pushes it out of the heap
+ (by pushing it to the bottom of the heap, where it is not noticed)*/
+
+void reHeapElement(int *p, int *q, double *v, int length, int i)
+{
+ int up, here;
+ here = i;
+ up = i / 2;
+ if ((up > 0) && (v[p[here]] < v[p[up]]))
+ while ((up > 0) && (v[p[here]] < v[p[up]])) /*we push the new
+ value up the heap*/
+ {
+ swap(p,q,up,here);
+ here = up;
+ up = here / 2;
+ }
+ else
+ heapify(p,q,v,i,length);
+}
+
+void popHeap(int *p, int *q, double *v, int length, int i)
+{
+ swap(p,q,i,length); /*puts new value at the last position in the heap*/
+ reHeapElement(p,q, v,length-1,i); /*put the swapped guy in the right place*/
+}
+
+void pushHeap(int *p, int *q, double *v, int length, int i)
+{
+ swap(p,q,i,length+1); /*puts new value at the last position in the heap*/
+ reHeapElement(p,q, v,length+1,length+1); /*put that guy in the right place*/
+}
+
+
+
+int makeThreshHeap(int *p, int *q, double *v, int arraySize, double thresh)
+{
+ int i, heapsize;
+ heapsize = 0;
+ for(i = 1; i < arraySize;i++)
+ if(v[q[i]] < thresh)
+ pushHeap(p,q,v,heapsize++,i);
+ return(heapsize);
+}
diff --git a/src/mat_expo.c b/src/mat_expo.c
new file mode 100644
index 0000000..c47f5d8
--- /dev/null
+++ b/src/mat_expo.c
@@ -0,0 +1,61 @@
+/* matexpo.c 2011-06-23 */
+
+/* Copyright 2007-2011 Emmanuel Paradis */
+
+/* This file is part of the R-package `ape'. */
+/* See the file ../COPYING for licensing issues. */
+
+#include <R.h>
+#include <R_ext/Lapack.h>
+
+void mat_expo(double *P, int *nr)
+/* This function computes the exponential of a nr x nr matrix */
+{
+ double *U, *vl, *WR, *Uinv, *WI, *work;
+ int i, j, k, l, info, *ipiv, n = *nr, nc = n*n, lw = nc << 1;
+ char yes = 'V', no = 'N';
+
+ U = (double *)R_alloc(nc, sizeof(double));
+ vl = (double *)R_alloc(n, sizeof(double));
+ WR = (double *)R_alloc(n, sizeof(double));
+ Uinv = (double *)R_alloc(nc, sizeof(double));
+ WI = (double *)R_alloc(n, sizeof(double));
+ work = (double *)R_alloc(lw, sizeof(double));
+
+ ipiv = (int *)R_alloc(nc, sizeof(int));
+
+/* The matrix is not symmetric, so we use 'dgeev'.
+ We take the real part of the eigenvalues -> WR
+ and the right eigenvectors (vr) -> U */
+ F77_CALL(dgeev)(&no, &yes, &n, P, &n, WR, WI, vl, &n,
+ U, &n, work, &lw, &info);
+
+/* It is not necessary to sort the eigenvalues...
+ Copy U -> P */
+ memcpy(P, U, nc*sizeof(double));
+
+/* For the inversion, we first make Uinv an identity matrix */
+ memset(Uinv, 0, nc*sizeof(double));
+ for (i = 0; i < nc; i += n + 1) Uinv[i] = 1;
+
+/* The matrix is not symmetric, so we use 'dgesv'.
+ This subroutine puts the result in Uinv (B)
+ (P [= U] is erased) */
+ F77_CALL(dgesv)(&n, &n, P, &n, ipiv, Uinv, &n, &info);
+
+/* The matrix product of U with the eigenvalues diagonal matrix: */
+ for (i = 0; i < n; i++)
+ for (j = 0; j < n; j++)
+ U[j + i*n] *= exp(WR[i]);
+
+/* The second matrix product with U^-1 */
+ memset(P, 0, nc*sizeof(double));
+
+ for (k = 0; k < n; k++) {
+ for (l = 0; l < n; l++) {
+ lw = l + k*n;
+ for (i = 0 + n*k, j = l; j < nc; i++, j += n)
+ P[lw] += U[j]*Uinv[i];
+ }
+ }
+}
diff --git a/src/me.c b/src/me.c
new file mode 100644
index 0000000..ea6ee4e
--- /dev/null
+++ b/src/me.c
@@ -0,0 +1,502 @@
+/* me.c 2014-03-04 */
+
+/* Copyright 2007-2008 Olivier Gascuel, Rick Desper,
+ R port by Vincent Lefort and Emmanuel Paradis */
+
+/* This file is part of the R-package `ape'. */
+/* See the file ../COPYING for licensing issues. */
+
+#include "me.h"
+
+//functions from me_balanced.c
+tree *BMEaddSpecies(tree *T, node *v, double **D, double **A);
+void assignBMEWeights(tree *T, double **A);
+void makeBMEAveragesTable(tree *T, double **D, double **A);
+//functions from me_ols.c
+tree *GMEaddSpecies(tree *T, node *v, double **D, double **A);
+void assignOLSWeights(tree *T, double **A);
+void makeOLSAveragesTable(tree *T, double **D, double **A);
+//functions from bNNI.c
+void bNNI(tree *T, double **avgDistArray, int *count, double **D, int numSpecies);
+//functions from NNI.c
+void NNI(tree *T, double **avgDistArray, int *count, double **D, int numSpecies);
+//functions from SPR.c
+void SPR(tree *T, double **D, double **A, int *count);
+//functions from TBR.c
+void TBR(tree *T, double **D, double **A);
+
+
+void me_b(double *X, int *N, int *labels,
+ int *nni, int *spr, int *tbr,
+ int *edge1, int *edge2, double *el)
+{
+ double **D, **A;
+ set *species, *slooper;
+ node *addNode;
+ tree *T;
+ int n, nniCount;
+
+ n = *N;
+ T = NULL;
+ nniCount = 0;
+ species = (set *) malloc(sizeof(set));
+ species->firstNode = NULL;
+ species->secondNode = NULL;
+ D = loadMatrix(X, labels, n, species);
+ A = initDoubleMatrix(2*n - 2);
+
+ for(slooper = species; NULL != slooper; slooper = slooper->secondNode)
+ {
+ addNode = copyNode(slooper->firstNode);
+ T = BMEaddSpecies(T, addNode, D, A);
+ }
+ // Compute bNNI
+ if (*nni) bNNI(T, A, &nniCount, D, n);
+ assignBMEWeights(T,A);
+
+ if (*spr) SPR(T, D, A, &nniCount);
+ if (*tbr) TBR(T, D, A);
+
+ tree2phylo(T, edge1, edge2, el, labels, n);
+
+ freeMatrix(D,n);
+ freeMatrix(A,2*n - 2);
+ freeSet(species);
+ freeTree(T);
+ T = NULL;
+}
+
+void me_o(double *X, int *N, int *labels, int *nni,
+ int *edge1, int *edge2, double *el)
+{
+ double **D, **A;
+ set *species, *slooper;
+ node *addNode;
+ tree *T;
+ int n, nniCount;
+
+ n = *N;
+ T = NULL;
+ nniCount = 0;
+ species = (set *) malloc(sizeof(set));
+ species->firstNode = NULL;
+ species->secondNode = NULL;
+
+ D = loadMatrix (X, labels, n, species);
+ A = initDoubleMatrix(2 * n - 2);
+
+ for(slooper = species; NULL != slooper; slooper = slooper->secondNode)
+ {
+ addNode = copyNode(slooper->firstNode);
+ T = GMEaddSpecies(T,addNode,D,A);
+ }
+ makeOLSAveragesTable(T,D,A);
+ // Compute NNI
+ if (*nni)
+ NNI(T,A,&nniCount,D,n);
+ assignOLSWeights(T,A);
+
+ tree2phylo(T, edge1, edge2, el, labels, n);
+
+ freeMatrix(D,n);
+ freeMatrix(A,2*n - 2);
+ freeSet(species);
+ freeTree(T);
+ T = NULL;
+}
+
+/*
+
+ -- MATRIX FUNCTIONS --
+
+*/
+
+double **initDoubleMatrix(int d)
+{
+ int i,j;
+ double **A;
+ A = (double **) malloc(d*sizeof(double *));
+ for(i=0;i<d;i++)
+ {
+ A[i] = (double *) malloc(d*sizeof(double));
+ for(j=0;j<d;j++)
+ A[i][j] = 0.0;
+ }
+ return(A);
+}
+
+//double **loadMatrix (double *X, char **labels, int n, set *S)
+double **loadMatrix (double *X, int *labels, int n, set *S)
+{
+// char nextString[MAX_LABEL_LENGTH];
+ node *v;
+ double **table;
+ int i, j, a, b;
+
+ table = (double **) calloc(n,sizeof(double *));
+ for(i=0; i<n; i++)
+ table[i] = (double *) calloc(n,sizeof(double));
+
+ for(i=0; i<n; i++)
+ {
+// strncpy (nextString, labels[i], MAX_LABEL_LENGTH);
+// ReplaceForbiddenChars (nextString, '_');
+// v = makeNewNode(nextString,-1);
+ v = makeNewNode(labels[i], -1);
+ v->index2 = i;
+ S = addToSet(v,S);
+ for (j=i; j<n; j++) {
+ a=i+1;
+ b=j+1;
+ table[j][i] = X[XINDEX(a,b)];
+ table[i][j] = X[XINDEX(a,b)];
+ if (i==j)
+ table[i][j] = 0;
+ }
+ }
+ return (table);
+}
+
+/*
+
+ -- GRAPH FUNCTIONS --
+
+*/
+
+set *addToSet(node *v, set *X)
+{
+ if (NULL == X)
+ {
+ X = (set *) malloc(sizeof(set));
+ X->firstNode = v;
+ X->secondNode = NULL;
+ }
+ else if (NULL == X->firstNode)
+ X->firstNode = v;
+ else
+ X->secondNode = addToSet(v,X->secondNode);
+ return(X);
+}
+
+//node *makeNewNode(char *label, int i)
+node *makeNewNode(int label, int i)
+{
+ return(makeNode(label,NULL,i));
+}
+
+//node *makeNode(char *label, edge *parentEdge, int index)
+node *makeNode(int label, edge *parentEdge, int index)
+{
+ node *newNode; /*points to new node added to the graph*/
+ newNode = (node *) malloc(sizeof(node));
+// strncpy(newNode->label,label,NODE_LABEL_LENGTH);
+ newNode->label = label;
+ newNode->index = index;
+ newNode->index2 = -1;
+ newNode->parentEdge = parentEdge;
+ newNode->leftEdge = NULL;
+ newNode->middleEdge = NULL;
+ newNode->rightEdge = NULL;
+ /*all fields have been initialized*/
+ return(newNode);
+}
+
+/*copyNode returns a copy of v which has all of the fields identical to those
+of v, except the node pointer fields*/
+node *copyNode(node *v)
+{
+ node *w;
+ w = makeNode(v->label,NULL,v->index);
+ w->index2 = v->index2;
+ return(w);
+}
+
+edge *siblingEdge(edge *e)
+{
+ if(e == e->tail->leftEdge)
+ return(e->tail->rightEdge);
+ else
+ return(e->tail->leftEdge);
+}
+
+edge *makeEdge(char *label, node *tail, node *head, double weight)
+{
+ edge *newEdge;
+ newEdge = (edge *) malloc(sizeof(edge));
+ strncpy(newEdge->label,label,EDGE_LABEL_LENGTH);
+ newEdge->tail = tail;
+ newEdge->head = head;
+ newEdge->distance = weight;
+ newEdge->totalweight = 0.0;
+ return(newEdge);
+}
+
+tree *newTree()
+{
+ tree *T;
+ T = (tree *) malloc(sizeof(tree));
+ T->root = NULL;
+ T->size = 0;
+ T->weight = -1;
+ return(T);
+}
+
+void updateSizes(edge *e, int direction)
+{
+ edge *f;
+ switch(direction)
+ {
+ case UP:
+ f = e->head->leftEdge;
+ if (NULL != f)
+ updateSizes(f,UP);
+ f = e->head->rightEdge;
+ if (NULL != f)
+ updateSizes(f,UP);
+ e->topsize++;
+ break;
+ case DOWN:
+ f = siblingEdge(e);
+ if (NULL != f)
+ updateSizes(f,UP);
+ f = e->tail->parentEdge;
+ if (NULL != f)
+ updateSizes(f,DOWN);
+ e->bottomsize++;
+ break;
+ }
+}
+
+/*detrifurcate takes the (possibly trifurcated) input tree
+ and reroots the tree to a leaf*/
+/*assumes tree is only trifurcated at root*/
+tree *detrifurcate(tree *T)
+{
+ node *v, *w;
+ edge *e, *f;
+ v = T->root;
+ if(leaf(v))
+ return(T);
+ if (NULL != v->parentEdge)
+ {
+ error("root %d is poorly rooted.", v->label);
+ }
+ for(e = v->middleEdge, v->middleEdge = NULL; NULL != e; e = f )
+ {
+ w = e->head;
+ v = e->tail;
+ e->tail = w;
+ e->head = v;
+ f = w->leftEdge;
+ v->parentEdge = e;
+ w->leftEdge = e;
+ w->parentEdge = NULL;
+ }
+ T->root = w;
+ return(T);
+}
+
+void compareSets(tree *T, set *S)
+{
+ edge *e;
+ node *v,*w;
+ set *X;
+ e = depthFirstTraverse(T,NULL);
+ while (NULL != e)
+ {
+ v = e->head;
+ for(X = S; NULL != X; X = X->secondNode)
+ {
+ w = X->firstNode;
+// if (0 == strcmp(v->label,w->label))
+ if (v->label == w->label)
+ {
+ v->index2 = w->index2;
+ w->index2 = -1;
+ break;
+ }
+ }
+ e = depthFirstTraverse(T,e);
+ }
+ v = T->root;
+ for(X = S; NULL != X; X = X->secondNode)
+ {
+ w = X->firstNode;
+// if (0 == strcmp(v->label,w->label))
+ if (v->label == w->label)
+ {
+ v->index2 = w->index2;
+ w->index2 = -1;
+ break;
+ }
+ }
+ if (-1 == v->index2)
+ {
+ error("leaf %d in tree not in distance matrix.", v->label);
+ }
+ e = depthFirstTraverse(T,NULL);
+ while (NULL != e)
+ {
+ v = e->head;
+ if ((leaf(v)) && (-1 == v->index2))
+ {
+ error("leaf %d in tree not in distance matrix.", v->label);
+ }
+ e = depthFirstTraverse(T,e);
+ }
+ for(X = S; NULL != X; X = X->secondNode)
+ if (X->firstNode->index2 > -1)
+ {
+ error("node %d in matrix but not a leaf in tree.", X->firstNode->label);
+ }
+ return;
+}
+
+void partitionSizes(tree *T)
+{
+ edge *e;
+ e = depthFirstTraverse(T,NULL);
+ while (NULL != e)
+ {
+ if (leaf(e->head))
+ e->bottomsize = 1;
+ else
+ e->bottomsize = e->head->leftEdge->bottomsize
+ + e->head->rightEdge->bottomsize;
+ e->topsize = (T->size + 2)/2 - e->bottomsize;
+ e = depthFirstTraverse(T,e);
+ }
+}
+
+/*************************************************************************
+
+ TRAVERSE FUNCTIONS
+
+*************************************************************************/
+
+edge *depthFirstTraverse(tree *T, edge *e)
+ /*depthFirstTraverse returns the edge f which is least in T according
+ to the depth-first order, but which is later than e in the search
+ pattern. If e is null, f is the least edge of T*/
+{
+ edge *f;
+ if (NULL == e)
+ {
+ f = T->root->leftEdge;
+ if (NULL != f)
+ f = findBottomLeft(f);
+ return(f); /*this is the first edge of this search pattern*/
+ }
+ else /*e is non-null*/
+ {
+ if (e->tail->leftEdge == e)
+ /*if e is a left-oriented edge, we skip the entire
+ tree cut below e, and find least edge*/
+ f = moveRight(e);
+ else /*if e is a right-oriented edge, we have already looked at its
+ sibling and everything below e, so we move up*/
+ f = e->tail->parentEdge;
+ }
+ return(f);
+}
+
+edge *findBottomLeft(edge *e)
+ /*findBottomLeft searches by gottom down in the tree and to the left.*/
+{
+ edge *f;
+ f = e;
+ while (NULL != f->head->leftEdge)
+ f = f->head->leftEdge;
+ return(f);
+}
+
+edge *moveRight(edge *e)
+{
+ edge *f;
+ f = e->tail->rightEdge; /*this step moves from a left-oriented edge
+ to a right-oriented edge*/
+ if (NULL != f)
+ f = findBottomLeft(f);
+ return(f);
+}
+
+edge *topFirstTraverse(tree *T, edge *e)
+ /*topFirstTraverse starts from the top of T, and from there moves stepwise
+ down, left before right*/
+ /*assumes tree has been detrifurcated*/
+{
+ edge *f;
+ if (NULL == e)
+ return(T->root->leftEdge); /*first Edge searched*/
+ else if (!(leaf(e->head)))
+ return(e->head->leftEdge); /*down and to the left is preferred*/
+ else /*e->head is a leaf*/
+ {
+ f = moveUpRight(e);
+ return(f);
+ }
+}
+
+edge *moveUpRight(edge *e)
+{
+ edge *f;
+ f = e;
+ while ((NULL != f) && ( f->tail->leftEdge != f))
+ f = f->tail->parentEdge;
+ /*go up the tree until f is a leftEdge*/
+ if (NULL == f)
+ return(f); /*triggered at end of search*/
+ else
+ return(f->tail->rightEdge);
+ /*and then go right*/
+}
+
+/*************************************************************************
+
+ FREE FUNCTIONS
+
+*************************************************************************/
+
+void freeMatrix(double **D, int size)
+{
+ int i;
+ for(i=0;i<size;i++)
+ free(D[i]);
+ free(D);
+}
+
+void freeSet(set *S)
+{
+ if (NULL != S) {
+ free(S->firstNode); /* added by EP 2014-03-04 */
+ freeSet(S->secondNode);
+ }
+ free(S);
+}
+
+void freeTree(tree *T)
+{
+ node *v;
+ v = T->root;
+ if (NULL != v->leftEdge)
+ freeSubTree(v->leftEdge);
+ free(T->root);
+ free(T);
+}
+
+void freeSubTree(edge *e)
+{
+ node *v;
+ edge *e1, *e2;
+ v = e->head;
+ e1 = v->leftEdge;
+ if (NULL != e1)
+ freeSubTree(e1);
+ e2 = v->rightEdge;
+ if (NULL != e2)
+ freeSubTree(e2);
+ free(v);
+ e->tail = NULL;
+ e->head = NULL;
+ free(e);
+}
diff --git a/src/me.h b/src/me.h
new file mode 100644
index 0000000..dc5e3ee
--- /dev/null
+++ b/src/me.h
@@ -0,0 +1,141 @@
+/* me.h 2012-04-30 */
+
+/* Copyright 2007-2008 Vincent Lefort, modified by Emmanuel Paradis */
+
+/* This file is part of the R-package `ape'. */
+/* See the file ../COPYING for licensing issues. */
+
+#include <R.h>
+
+#ifndef NONE
+#define NONE 0
+#endif
+#ifndef UP
+#define UP 1
+#endif
+#ifndef DOWN
+#define DOWN 2
+#endif
+#ifndef LEFT
+#define LEFT 3
+#endif
+#ifndef RIGHT
+#define RIGHT 4
+#endif
+#ifndef SKEW
+#define SKEW 5
+#endif
+#ifndef MAX_LABEL_LENGTH
+#define MAX_LABEL_LENGTH 30
+#endif
+//#ifndef NODE_LABEL_LENGTH
+//#define NODE_LABEL_LENGTH 30
+//#endif
+#ifndef EDGE_LABEL_LENGTH
+#define EDGE_LABEL_LENGTH 30
+#endif
+#ifndef MAX_DIGITS
+#define MAX_DIGITS 20
+#endif
+/* #ifndef INPUT_SIZE */
+/* #define INPUT_SIZE 100 */
+/* #endif */
+#ifndef MAX_INPUT_SIZE
+#define MAX_INPUT_SIZE 100000
+#endif
+#ifndef EPSILON
+#define EPSILON 1.E-06
+#endif
+#ifndef ReadOpenParenthesis
+#define ReadOpenParenthesis 0
+#endif
+#ifndef ReadSubTree
+#define ReadSubTree 1
+#endif
+#ifndef ReadLabel
+#define ReadLabel 2
+#endif
+#ifndef ReadWeight
+#define ReadWeight 3
+#endif
+#ifndef AddEdge
+#define AddEdge 4
+#endif
+
+#define XINDEX(i, j) n*(i - 1) - i*(i - 1)/2 + j - i - 1
+
+typedef struct word
+{
+ char name[MAX_LABEL_LENGTH];
+ struct word *suiv;
+} WORD;
+
+typedef struct pointers
+{
+ WORD *head;
+ WORD *tail;
+} POINTERS;
+
+typedef struct node {
+ int label; /* char label[NODE_LABEL_LENGTH]; */
+ struct edge *parentEdge;
+ struct edge *leftEdge;
+ struct edge *middleEdge;
+ struct edge *rightEdge;
+ int index;
+ int index2;
+} node;
+
+typedef struct edge {
+ char label[EDGE_LABEL_LENGTH];
+ struct node *tail; /*for edge (u,v), u is the tail, v is the head*/
+ struct node *head;
+ int bottomsize; /*number of nodes below edge */
+ int topsize; /*number of nodes above edge */
+ double distance;
+ double totalweight;
+} edge;
+
+typedef struct tree {
+ char name[MAX_LABEL_LENGTH];
+ struct node *root;
+ int size;
+ double weight;
+} tree;
+
+typedef struct set
+{
+ struct node *firstNode;
+ struct set *secondNode;
+} set;
+
+void me_b(double *X, int *N, int *labels, int *nni, int *spr, int *tbr, int *edge1, int *edge2, double *el);
+void me_o(double *X, int *N, int *labels, int *nni, int *edge1, int *edge2, double *el);
+double **initDoubleMatrix(int d);
+double **loadMatrix (double *X, int *labels, int n, set *S);
+set *addToSet(node *v, set *X);
+node *makeNewNode(int label, int i);
+node *makeNode(int label, edge *parentEdge, int index);
+node *copyNode(node *v);
+edge *siblingEdge(edge *e);
+edge *makeEdge(char *label, node *tail, node *head, double weight);
+tree *newTree();
+void updateSizes(edge *e, int direction);
+tree *detrifurcate(tree *T);
+void compareSets(tree *T, set *S);
+void partitionSizes(tree *T);
+edge *depthFirstTraverse(tree *T, edge *e);
+edge *findBottomLeft(edge *e);
+edge *moveRight(edge *e);
+edge *topFirstTraverse(tree *T, edge *e);
+edge *moveUpRight(edge *e);
+void freeMatrix(double **D, int size);
+void freeSet(set *S);
+void freeTree(tree *T);
+void freeSubTree(edge *e);
+int leaf(node *v);
+/* int whiteSpace(char c); */
+/* node *decodeNewickSubtree(char *treeString, tree *T, int *uCount); */
+/* tree *readNewickString (char *str, int numLeaves); */
+void subtree2phylo(node *parent, int *edge1, int *edge2, double *el, int *ilab);
+void tree2phylo(tree *T, int *edge1, int *edge2, double *el, int *ilab, int n);
diff --git a/src/me_balanced.c b/src/me_balanced.c
new file mode 100644
index 0000000..defd23b
--- /dev/null
+++ b/src/me_balanced.c
@@ -0,0 +1,444 @@
+/* me_balanced.c 2012-04-30 */
+
+/* Copyright 2007 Vincent Lefort
+ BMEsplitEdge() modified by Emmanuel Paradis */
+
+/* This file is part of the R-package `ape'. */
+/* See the file ../COPYING for licensing issues. */
+
+#include "me.h"
+
+void BalWFext(edge *e, double **A) /*works except when e is the one edge
+ inserted to new vertex v by firstInsert*/
+{
+ edge *f, *g;
+ if ((leaf(e->head)) && (leaf(e->tail)))
+ e->distance = A[e->head->index][e->head->index];
+ else if (leaf(e->head))
+ {
+ f = e->tail->parentEdge;
+ g = siblingEdge(e);
+ e->distance = 0.5*(A[e->head->index][g->head->index]
+ + A[e->head->index][f->head->index]
+ - A[g->head->index][f->head->index]);
+ }
+ else
+ {
+ f = e->head->leftEdge;
+ g = e->head->rightEdge;
+ e->distance = 0.5*(A[g->head->index][e->head->index]
+ + A[f->head->index][e->head->index]
+ - A[f->head->index][g->head->index]);
+ }
+}
+
+void BalWFint(edge *e, double **A)
+{
+ int up, down, left, right;
+ up = e->tail->index;
+ down = (siblingEdge(e))->head->index;
+ left = e->head->leftEdge->head->index;
+ right = e->head->rightEdge->head->index;
+ e->distance = 0.25*(A[up][left] + A[up][right] + A[left][down] + A[right][down]) - 0.5*(A[down][up] + A[left][right]);
+}
+
+void assignBMEWeights(tree *T, double **A)
+{
+ edge *e;
+ e = depthFirstTraverse(T,NULL);
+ while (NULL != e) {
+ if ((leaf(e->head)) || (leaf(e->tail)))
+ BalWFext(e,A);
+ else
+ BalWFint(e,A);
+ e = depthFirstTraverse(T,e);
+ }
+}
+
+void BMEcalcDownAverage(tree *T, node *v, edge *e, double **D, double **A)
+{
+ edge *left, *right;
+ if (leaf(e->head))
+ A[e->head->index][v->index] = D[v->index2][e->head->index2];
+ else
+ {
+ left = e->head->leftEdge;
+ right = e->head->rightEdge;
+ A[e->head->index][v->index] = 0.5 * A[left->head->index][v->index]
+ + 0.5 * A[right->head->index][v->index];
+ }
+}
+
+void BMEcalcUpAverage(tree *T, node *v, edge *e, double **D, double **A)
+{
+ edge *up,*down;
+ if (T->root == e->tail)
+ A[v->index][e->head->index] = D[v->index2][e->tail->index2];
+ /*for now, use convention
+ v->index first => looking up
+ v->index second => looking down */
+ else
+ {
+ up = e->tail->parentEdge;
+ down = siblingEdge(e);
+ A[v->index][e->head->index] = 0.5 * A[v->index][up->head->index]
+ +0.5 * A[down->head->index][v->index];
+ }
+}
+
+
+void BMEcalcNewvAverages(tree *T, node *v, double **D, double **A)
+{
+ /*loop over edges*/
+ /*depth-first search*/
+ edge *e;
+ e = NULL;
+ e = depthFirstTraverse(T,e); /*the downward averages need to be
+ calculated from bottom to top */
+ while(NULL != e)
+ {
+ BMEcalcDownAverage(T,v,e,D,A);
+ e = depthFirstTraverse(T,e);
+ }
+
+ e = topFirstTraverse(T,e); /*the upward averages need to be calculated
+ from top to bottom */
+ while(NULL != e)
+ {
+ BMEcalcUpAverage(T,v,e,D,A);
+ e = topFirstTraverse(T,e);
+ }
+}
+
+
+/*update Pair updates A[nearEdge][farEdge] and makes recursive call to subtree
+ beyond farEdge*/
+/*root is head or tail of edge being split, depending on direction toward
+ v*/
+void updatePair(double **A, edge *nearEdge, edge *farEdge, node *v,
+ node *root, double dcoeff, int direction)
+{
+ edge *sib;
+ switch(direction) /*the various cases refer to where the new vertex has
+ been inserted, in relation to the edge nearEdge*/
+ {
+ case UP: /*this case is called when v has been inserted above
+ or skew to farEdge*/
+ /*do recursive calls first!*/
+ if (NULL != farEdge->head->leftEdge)
+ updatePair(A,nearEdge,farEdge->head->leftEdge,v,root,dcoeff,UP);
+ if (NULL != farEdge->head->rightEdge)
+ updatePair(A,nearEdge,farEdge->head->rightEdge,v,root,dcoeff,UP);
+ A[farEdge->head->index][nearEdge->head->index] =
+ A[nearEdge->head->index][farEdge->head->index]
+ = A[farEdge->head->index][nearEdge->head->index]
+ + dcoeff*A[farEdge->head->index][v->index]
+ - dcoeff*A[farEdge->head->index][root->index];
+ break;
+ case DOWN: /*called when v has been inserted below farEdge*/
+ if (NULL != farEdge->tail->parentEdge)
+ updatePair(A,nearEdge,farEdge->tail->parentEdge,v,root,dcoeff,DOWN);
+ sib = siblingEdge(farEdge);
+ if (NULL != sib)
+ updatePair(A,nearEdge,sib,v,root,dcoeff,UP);
+ A[farEdge->head->index][nearEdge->head->index] =
+ A[nearEdge->head->index][farEdge->head->index]
+ = A[farEdge->head->index][nearEdge->head->index]
+ + dcoeff*A[v->index][farEdge->head->index]
+ - dcoeff*A[farEdge->head->index][root->index];
+ }
+}
+
+void updateSubTree(double **A, edge *nearEdge, node *v, node *root,
+ node *newNode, double dcoeff, int direction)
+{
+ edge *sib;
+ switch(direction)
+ {
+ case UP: /*newNode is above the edge nearEdge*/
+ A[v->index][nearEdge->head->index] = A[nearEdge->head->index][v->index];
+ A[newNode->index][nearEdge->head->index] =
+ A[nearEdge->head->index][newNode->index] =
+ A[nearEdge->head->index][root->index];
+ if (NULL != nearEdge->head->leftEdge)
+ updateSubTree(A, nearEdge->head->leftEdge, v, root, newNode, 0.5*dcoeff, UP);
+ if (NULL != nearEdge->head->rightEdge)
+ updateSubTree(A, nearEdge->head->rightEdge, v, root, newNode, 0.5*dcoeff, UP);
+ updatePair(A, nearEdge, nearEdge, v, root, dcoeff, UP);
+ break;
+ case DOWN: /*newNode is below the edge nearEdge*/
+ A[nearEdge->head->index][v->index] = A[v->index][nearEdge->head->index];
+ A[newNode->index][nearEdge->head->index] =
+ A[nearEdge->head->index][newNode->index] =
+ 0.5*(A[nearEdge->head->index][root->index]
+ + A[v->index][nearEdge->head->index]);
+ sib = siblingEdge(nearEdge);
+ if (NULL != sib)
+ updateSubTree(A, sib, v, root, newNode, 0.5*dcoeff, SKEW);
+ if (NULL != nearEdge->tail->parentEdge)
+ updateSubTree(A, nearEdge->tail->parentEdge, v, root, newNode, 0.5*dcoeff, DOWN);
+ updatePair(A, nearEdge, nearEdge, v, root, dcoeff, DOWN);
+ break;
+ case SKEW: /*newNode is neither above nor below nearEdge*/
+ A[v->index][nearEdge->head->index] = A[nearEdge->head->index][v->index];
+ A[newNode->index][nearEdge->head->index] =
+ A[nearEdge->head->index][newNode->index] =
+ 0.5*(A[nearEdge->head->index][root->index] +
+ A[nearEdge->head->index][v->index]);
+ if (NULL != nearEdge->head->leftEdge)
+ updateSubTree(A, nearEdge->head->leftEdge, v, root, newNode, 0.5*dcoeff,SKEW);
+ if (NULL != nearEdge->head->rightEdge)
+ updateSubTree(A, nearEdge->head->rightEdge, v, root, newNode, 0.5*dcoeff,SKEW);
+ updatePair(A, nearEdge, nearEdge, v, root, dcoeff, UP);
+ }
+}
+
+
+/*we update all the averages for nodes (u1,u2), where the insertion point of
+ v is in "direction" from both u1 and u2 */
+/*The general idea is to proceed in a direction from those edges already corrected
+ */
+
+/*r is the root of the tree relative to the inserted node*/
+
+void BMEupdateAveragesMatrix(double **A, edge *e, node *v,node *newNode)
+{
+ edge *sib, *par, *left, *right;
+ /*first, update the v,newNode entries*/
+ A[newNode->index][newNode->index] = 0.5*(A[e->head->index][e->head->index]
+ + A[v->index][e->head->index]);
+ A[v->index][newNode->index] = A[newNode->index][v->index] =
+ A[v->index][e->head->index];
+ A[v->index][v->index] =
+ 0.5*(A[e->head->index][v->index] + A[v->index][e->head->index]);
+ left = e->head->leftEdge;
+ right = e->head->rightEdge;
+ if (NULL != left)
+ updateSubTree(A,left,v,e->head,newNode,0.25,UP); /*updates left and below*/
+ if (NULL != right)
+ updateSubTree(A,right,v,e->head,newNode,0.25,UP); /*updates right and below*/
+ sib = siblingEdge(e);
+ if (NULL != sib)
+ updateSubTree(A,sib,v,e->head,newNode,0.25,SKEW); /*updates sib and below*/
+ par = e->tail->parentEdge;
+ if (NULL != par)
+ updateSubTree(A,par,v,e->head,newNode,0.25,DOWN); /*updates par and above*/
+
+ /*must change values A[e->head][*] last, as they are used to update
+ the rest of the matrix*/
+ A[newNode->index][e->head->index] = A[e->head->index][newNode->index]
+ = A[e->head->index][e->head->index];
+ A[v->index][e->head->index] = A[e->head->index][v->index];
+
+ updatePair(A,e,e,v,e->head,0.5,UP); /*updates e->head fields only*/
+}
+
+/*A is tree below sibling, B is tree below edge, C is tree above edge*/
+double wf3(double D_AB, double D_AC, double D_kB, double D_kC)
+{
+ return(D_AC + D_kB - D_AB - D_kC);
+}
+
+void BMEtestEdge(edge *e, node *v, double **A)
+{
+ edge *up, *down;
+ down = siblingEdge(e);
+ up = e->tail->parentEdge;
+ e->totalweight = wf3(A[e->head->index][down->head->index],
+ A[down->head->index][e->tail->index],
+ A[e->head->index][v->index],
+ A[v->index][e->tail->index])
+ + up->totalweight;
+}
+
+void BMEsplitEdge(tree *T, node *v, edge *e, double **A)
+{
+ edge *newPendantEdge;
+ edge *newInternalEdge;
+ node *newNode;
+ int nodeLabel = 0;//char nodeLabel[NODE_LABEL_LENGTH];
+ char edgeLabel1[EDGE_LABEL_LENGTH];
+ char edgeLabel2[EDGE_LABEL_LENGTH];
+ //snprintf(nodeLabel,1,"");
+ //sprintf(edgeLabel1,"E%d",T->size);
+ //sprintf(edgeLabel2,"E%d",T->size+1);
+ snprintf(edgeLabel1,EDGE_LABEL_LENGTH,"E%d",T->size);
+ snprintf(edgeLabel2,EDGE_LABEL_LENGTH,"E%d",T->size+1);
+
+ /*make the new node and edges*/
+ newNode = makeNewNode(nodeLabel,T->size+1);
+ newPendantEdge = makeEdge(edgeLabel1,newNode,v,0.0);
+ newInternalEdge = makeEdge(edgeLabel2,newNode,e->head,0.0);
+
+ /*update the matrix of average distances*/
+ BMEupdateAveragesMatrix(A,e,v,newNode);
+
+ /*put them in the correct topology*/
+ newNode->parentEdge = e;
+ e->head->parentEdge = newInternalEdge;
+ v->parentEdge = newPendantEdge;
+ e->head = newNode;
+
+ T->size = T->size + 2;
+
+ if (e->tail->leftEdge == e)
+ /*actually this is totally arbitrary and probably unnecessary*/
+ {
+ newNode->leftEdge = newInternalEdge;
+ newNode->rightEdge = newPendantEdge;
+ }
+ else
+ {
+ newNode->leftEdge = newInternalEdge;
+ newNode->rightEdge = newPendantEdge;
+ }
+}
+
+tree *BMEaddSpecies(tree *T,node *v, double **D, double **A)
+ /*the key function of the program addSpeices inserts
+ the node v to the tree T. It uses testEdge to see what the relative
+ weight would be if v split a particular edge. Once insertion point
+ is found, v is added to T, and A is updated. Edge weights
+ are not assigned until entire tree is build*/
+
+{
+ tree *T_e;
+ edge *e; /*loop variable*/
+ edge *e_min; /*points to best edge seen thus far*/
+ double w_min = 0.0; /*used to keep track of tree weights*/
+
+ /*initialize variables as necessary*/
+
+ /*CASE 1: T is empty, v is the first node*/
+ if (NULL == T) /*create a tree with v as only vertex, no edges*/
+ {
+ T_e = newTree();
+ T_e->root = v;
+ /*note that we are rooting T arbitrarily at a leaf.
+ T->root is not the phylogenetic root*/
+ v->index = 0;
+ T_e->size = 1;
+ return(T_e);
+ }
+ /*CASE 2: T is a single-vertex tree*/
+ if (1 == T->size)
+ {
+ v->index = 1;
+ e = makeEdge("",T->root,v,0.0);
+ //sprintf(e->label,"E1");
+ snprintf(e->label,EDGE_LABEL_LENGTH,"E1");
+ A[v->index][v->index] = D[v->index2][T->root->index2];
+ T->root->leftEdge = v->parentEdge = e;
+ T->size = 2;
+ return(T);
+ }
+ /*CASE 3: T has at least two nodes and an edge. Insert new node
+ by breaking one of the edges*/
+
+ v->index = T->size;
+ BMEcalcNewvAverages(T,v,D,A);
+ /*calcNewvAverages will update A for the row and column
+ include the node v. Will do so using pre-existing averages in T and
+ information from A,D*/
+ e_min = T->root->leftEdge;
+ e = e_min->head->leftEdge;
+ while (NULL != e)
+ {
+ BMEtestEdge(e,v,A);
+ /*testEdge tests weight of tree if loop variable
+ e is the edge split, places this value in the e->totalweight field */
+ if (e->totalweight < w_min)
+ {
+ e_min = e;
+ w_min = e->totalweight;
+ }
+ e = topFirstTraverse(T,e);
+ }
+ /*e_min now points at the edge we want to split*/
+/* if (verbose)
+ printf("Inserting %s between %s and %s on %s\n",v->label,e_min->tail->label,
+ e_min->head->label,e_min->label);*/
+ BMEsplitEdge(T,v,e_min,A);
+ return(T);
+}
+
+/*calcUpAverages will ensure that A[e->head->index][f->head->index] is
+ filled for any f >= g. Works recursively*/
+void calcUpAverages(double **D, double **A, edge *e, edge *g)
+{
+ node *u,*v;
+ edge *s;
+ if (!(leaf(g->tail)))
+ {
+ calcUpAverages(D,A,e,g->tail->parentEdge);
+ s = siblingEdge(g);
+ u = g->tail;
+ v = s->head;
+ A[e->head->index][g->head->index] = A[g->head->index][e->head->index]
+ = 0.5*(A[e->head->index][u->index] + A[e->head->index][v->index]);
+ }
+}
+
+void makeBMEAveragesTable(tree *T, double **D, double **A)
+{
+ edge *e, *f, *exclude;
+ node *u,*v;
+ /*first, let's deal with the averages involving the root of T*/
+ e = T->root->leftEdge;
+ f = depthFirstTraverse(T,NULL);
+ while (NULL != f) {
+ if (leaf(f->head)) {
+ A[e->head->index][f->head->index] = A[f->head->index][e->head->index]
+ = D[e->tail->index2][f->head->index2];
+ }
+ else
+ {
+ u = f->head->leftEdge->head;
+ v = f->head->rightEdge->head;
+ A[e->head->index][f->head->index] = A[f->head->index][e->head->index]
+ = 0.5*(A[e->head->index][u->index] + A[e->head->index][v->index]);
+ }
+ f = depthFirstTraverse(T,f);
+ }
+ e = depthFirstTraverse(T,NULL);
+ while (T->root->leftEdge != e) {
+ f = exclude = e;
+ while (T->root->leftEdge != f) {
+ if (f == exclude)
+ exclude = exclude->tail->parentEdge;
+ else if (leaf(e->head))
+ {
+ if (leaf(f->head))
+ A[e->head->index][f->head->index] =
+ A[f->head->index][e->head->index]
+ = D[e->head->index2][f->head->index2];
+ else
+ {
+ u = f->head->leftEdge->head; /*since f is chosen using a
+ depth-first search, other values
+ have been calculated*/
+ v = f->head->rightEdge->head;
+ A[e->head->index][f->head->index]
+ = A[f->head->index][e->head->index]
+ = 0.5*(A[e->head->index][u->index] + A[e->head->index][v->index]);
+ }
+ }
+ else
+ {
+ u = e->head->leftEdge->head;
+ v = e->head->rightEdge->head;
+ A[e->head->index][f->head->index] = A[f->head->index][e->head->index] = 0.5*(A[f->head->index][u->index] + A[f->head->index][v->index]);
+ }
+ f = depthFirstTraverse(T,f);
+ }
+ e = depthFirstTraverse(T,e);
+ }
+ e = depthFirstTraverse(T,NULL);
+ while (T->root->leftEdge != e)
+ {
+ calcUpAverages(D,A,e,e); /*calculates averages for
+ A[e->head->index][g->head->index] for
+ any edge g in path from e to root of tree*/
+ e = depthFirstTraverse(T,e);
+ }
+} /*makeAveragesMatrix*/
diff --git a/src/me_ols.c b/src/me_ols.c
new file mode 100644
index 0000000..cd15644
--- /dev/null
+++ b/src/me_ols.c
@@ -0,0 +1,641 @@
+/* me_ols.c 2012-04-30 */
+
+/* Copyright 2007 Vincent Lefort
+ GMEsplitEdge() modified by Emmanuel Paradis */
+
+/* This file is part of the R-package `ape'. */
+/* See the file ../COPYING for licensing issues. */
+
+#include "me.h"
+
+/*from NNI.c*/
+void fillTableUp(edge *e, edge *f, double **A, double **D, tree *T);
+
+/*OLSint and OLSext use the average distance array to calculate weights
+ instead of using the edge average weight fields*/
+
+void OLSext(edge *e, double **A)
+{
+ edge *f, *g;
+ if(leaf(e->head))
+ {
+ f = siblingEdge(e);
+ e->distance = 0.5*(A[e->head->index][e->tail->index]
+ + A[e->head->index][f->head->index]
+ - A[f->head->index][e->tail->index]);
+ }
+ else
+ {
+ f = e->head->leftEdge;
+ g = e->head->rightEdge;
+ e->distance = 0.5*(A[e->head->index][f->head->index]
+ + A[e->head->index][g->head->index]
+ - A[f->head->index][g->head->index]);
+ }
+}
+
+double wf(double lambda, double D_LR, double D_LU, double D_LD,
+ double D_RU, double D_RD, double D_DU)
+{
+ double weight;
+ weight = 0.5*(lambda*(D_LU + D_RD) + (1 -lambda)*(D_LD + D_RU)
+ - (D_LR + D_DU));
+ return(weight);
+}
+
+void OLSint(edge *e, double **A)
+{
+ double lambda;
+ edge *left, *right, *sib;
+ left = e->head->leftEdge;
+ right = e->head->rightEdge;
+ sib = siblingEdge(e);
+ lambda = ((double) sib->bottomsize*left->bottomsize +
+ right->bottomsize*e->tail->parentEdge->topsize) /
+ (e->bottomsize*e->topsize);
+ e->distance = wf(lambda,A[left->head->index][right->head->index],
+ A[left->head->index][e->tail->index],
+ A[left->head->index][sib->head->index],
+ A[right->head->index][e->tail->index],
+ A[right->head->index][sib->head->index],
+ A[sib->head->index][e->tail->index]);
+}
+
+
+void assignOLSWeights(tree *T, double **A)
+{
+ edge *e;
+ e = depthFirstTraverse(T,NULL);
+ while (NULL != e) {
+ if ((leaf(e->head)) || (leaf(e->tail)))
+ OLSext(e,A);
+ else
+ OLSint(e,A);
+ e = depthFirstTraverse(T,e);
+ }
+}
+
+/*makes table of average distances from scratch*/
+void makeOLSAveragesTable(tree *T, double **D, double **A)
+{
+ edge *e, *f, *g, *h;
+ edge *exclude;
+ e = f = NULL;
+ e = depthFirstTraverse(T,e);
+ while (NULL != e)
+ {
+ f = e;
+ exclude = e->tail->parentEdge;
+ /*we want to calculate A[e->head][f->head] for all edges
+ except those edges which are ancestral to e. For those
+ edges, we will calculate A[e->head][f->head] to have a
+ different meaning, later*/
+ if(leaf(e->head))
+ while (NULL != f)
+ {
+ if (exclude != f)
+ {
+ if (leaf(f->head))
+ A[e->head->index][f->head->index] = A[f->head->index][e->head->index] = D[e->head->index2][f->head->index2];
+ else
+ {
+ g = f->head->leftEdge;
+ h = f->head->rightEdge;
+ A[e->head->index][f->head->index] = A[f->head->index][e->head->index] = (g->bottomsize*A[e->head->index][g->head->index] + h->bottomsize*A[e->head->index][h->head->index])/f->bottomsize;
+ }
+ }
+ else /*exclude == f*/
+ exclude = exclude->tail->parentEdge;
+ f = depthFirstTraverse(T,f);
+ }
+ else
+ /*e->head is not a leaf, so we go recursively to values calculated for
+ the nodes below e*/
+ while(NULL !=f )
+ {
+ if (exclude != f)
+ {
+ g = e->head->leftEdge;
+ h = e->head->rightEdge;
+ A[e->head->index][f->head->index] = A[f->head->index][e->head->index] = (g->bottomsize*A[f->head->index][g->head->index] + h->bottomsize*A[f->head->index][h->head->index])/e->bottomsize;
+ }
+ else
+ exclude = exclude->tail->parentEdge;
+ f = depthFirstTraverse(T,f);
+ }
+
+ /*now we move to fill up the rest of the table: we want
+ A[e->head->index][f->head->index] for those cases where e is an
+ ancestor of f, or vice versa. We'll do this by choosing e via a
+ depth first-search, and the recursing for f up the path to the
+ root*/
+ f = e->tail->parentEdge;
+ if (NULL != f)
+ fillTableUp(e,f,A,D,T);
+ e = depthFirstTraverse(T,e);
+ }
+
+ /*we are indexing this table by vertex indices, but really the
+ underlying object is the edge set. Thus, the array is one element
+ too big in each direction, but we'll ignore the entries involving the root,
+ and instead refer to each edge by the head of that edge. The head of
+ the root points to the edge ancestral to the rest of the tree, so
+ we'll keep track of up distances by pointing to that head*/
+
+ /*10/13/2001: collapsed three depth-first searces into 1*/
+}
+
+void GMEcalcDownAverage(node *v, edge *e, double **D, double **A)
+{
+ edge *left, *right;
+ if (leaf(e->head))
+ A[e->head->index][v->index] = D[v->index2][e->head->index2];
+ else
+ {
+ left = e->head->leftEdge;
+ right = e->head->rightEdge;
+ A[e->head->index][v->index] =
+ ( left->bottomsize * A[left->head->index][v->index] +
+ right->bottomsize * A[right->head->index][v->index])
+ / e->bottomsize;
+ }
+}
+
+void GMEcalcUpAverage(node *v, edge *e, double **D, double **A)
+{
+ edge *up, *down;
+ if (NULL == e->tail->parentEdge)
+ A[v->index][e->head->index] = D[v->index2][e->tail->index2];
+ else
+ {
+ up = e->tail->parentEdge;
+ down = siblingEdge(e);
+ A[v->index][e->head->index] =
+ (up->topsize * A[v->index][up->head->index] +
+ down->bottomsize * A[down->head->index][v->index])
+ / e->topsize;
+ }
+}
+
+/*this function calculates average distance D_Xv for each X which is
+ a set of leaves of an induced subtree of T*/
+void GMEcalcNewvAverages(tree *T, node *v, double **D, double **A)
+{
+ /*loop over edges*/
+ /*depth-first search*/
+ edge *e;
+ e = NULL;
+ e = depthFirstTraverse(T,e); /*the downward averages need to be
+ calculated from bottom to top */
+ while(NULL != e)
+ {
+ GMEcalcDownAverage(v,e,D,A);
+ e = depthFirstTraverse(T,e);
+ }
+
+ e = topFirstTraverse(T,e); /*the upward averages need to be calculated
+ from top to bottom */
+ while(NULL != e)
+ {
+ GMEcalcUpAverage(v,e,D,A);
+ e = topFirstTraverse(T,e);
+ }
+}
+
+double wf4(double lambda, double lambda2, double D_AB, double D_AC,
+ double D_BC, double D_Av, double D_Bv, double D_Cv)
+{
+ return(((1 - lambda) * (D_AC + D_Bv) + (lambda2 - 1)*(D_AB + D_Cv)
+ + (lambda - lambda2)*(D_BC + D_Av)));
+}
+
+
+/*testEdge cacluates what the OLS weight would be if v were inserted into
+ T along e. Compare against known values for inserting along
+ f = e->parentEdge */
+/*edges are tested by a top-first, left-first scheme. we presume
+ all distances are fixed to the correct weight for
+ e->parentEdge, if e is a left-oriented edge*/
+void testEdge(edge *e, node *v, double **A)
+{
+ double lambda, lambda2;
+ edge *par, *sib;
+ sib = siblingEdge(e);
+ par = e->tail->parentEdge;
+ /*C is set above e->tail, B is set below e, and A is set below sib*/
+ /*following the nomenclature of Desper & Gascuel*/
+ lambda = (((double) (sib->bottomsize + e->bottomsize*par->topsize))
+ / ((1 + par->topsize)*(par->bottomsize)));
+ lambda2 = (((double) (sib->bottomsize + e->bottomsize*par->topsize))
+ / ((1 + e->bottomsize)*(e->topsize)));
+ e->totalweight = par->totalweight
+ + wf4(lambda,lambda2,A[e->head->index][sib->head->index],
+ A[sib->head->index][e->tail->index],
+ A[e->head->index][e->tail->index],
+ A[sib->head->index][v->index],A[e->head->index][v->index],
+ A[v->index][e->tail->index]);
+}
+
+void printDoubleTable(double **A, int d)
+{
+ int i,j;
+ for(i=0;i<d;i++)
+ {
+ for(j=0;j<d;j++)
+ Rprintf("%lf ", A[i][j]);
+ Rprintf("\n");
+ }
+}
+
+void GMEsplitEdge(tree *T, node *v, edge *e, double **A);
+
+tree *GMEaddSpecies(tree *T,node *v, double **D, double **A)
+ /*the key function of the program addSpeices inserts
+ the node v to the tree T. It uses testEdge to see what the
+ weight would be if v split a particular edge. Weights are assigned by
+ OLS formula*/
+{
+ tree *T_e;
+ edge *e; /*loop variable*/
+ edge *e_min; /*points to best edge seen thus far*/
+ double w_min = 0.0; /*used to keep track of tree weights*/
+
+/* if (verbose)
+ printf("Adding %s.\n",v->label);*/
+
+ /*initialize variables as necessary*/
+ /*CASE 1: T is empty, v is the first node*/
+ if (NULL == T) /*create a tree with v as only vertex, no edges*/
+ {
+ T_e = newTree();
+ T_e->root = v;
+ /*note that we are rooting T arbitrarily at a leaf.
+ T->root is not the phylogenetic root*/
+ v->index = 0;
+ T_e->size = 1;
+ return(T_e);
+ }
+ /*CASE 2: T is a single-vertex tree*/
+ if (1 == T->size)
+ {
+ v->index = 1;
+ e = makeEdge("",T->root,v,0.0);
+ //sprintf(e->label,"E1");
+ snprintf(e->label,EDGE_LABEL_LENGTH,"E1");
+ e->topsize = 1;
+ e->bottomsize = 1;
+ A[v->index][v->index] = D[v->index2][T->root->index2];
+ T->root->leftEdge = v->parentEdge = e;
+ T->size = 2;
+ return(T);
+ }
+ /*CASE 3: T has at least two nodes and an edge. Insert new node
+ by breaking one of the edges*/
+
+ v->index = T->size;
+ /*if (!(T->size % 100))
+ printf("T->size is %d\n",T->size);*/
+ GMEcalcNewvAverages(T,v,D,A);
+ /*calcNewvAverges will assign values to all the edge averages of T which
+ include the node v. Will do so using pre-existing averages in T and
+ information from A,D*/
+ e_min = T->root->leftEdge;
+ e = e_min->head->leftEdge;
+ while (NULL != e)
+ {
+ testEdge(e,v,A);
+ /*testEdge tests weight of tree if loop variable
+ e is the edge split, places this weight in e->totalweight field */
+ if (e->totalweight < w_min)
+ {
+ e_min = e;
+ w_min = e->totalweight;
+ }
+ e = topFirstTraverse(T,e);
+ }
+ /*e_min now points at the edge we want to split*/
+ GMEsplitEdge(T,v,e_min,A);
+ return(T);
+}
+
+void updateSubTreeAverages(double **A, edge *e, node *v, int direction);
+
+/*the ME version of updateAveragesMatrix does not update the entire matrix
+ A, but updates A[v->index][w->index] whenever this represents an average
+ of 1-distant or 2-distant subtrees*/
+
+void GMEupdateAveragesMatrix(double **A, edge *e, node *v, node *newNode)
+{
+ edge *sib, *par, *left, *right;
+ sib = siblingEdge(e);
+ left = e->head->leftEdge;
+ right = e->head->rightEdge;
+ par = e->tail->parentEdge;
+
+ /*we need to update the matrix A so all 1-distant, 2-distant, and
+ 3-distant averages are correct*/
+
+ /*first, initialize the newNode entries*/
+ /*1-distant*/
+ A[newNode->index][newNode->index] =
+ (e->bottomsize*A[e->head->index][e->head->index]
+ + A[v->index][e->head->index])
+ / (e->bottomsize + 1);
+ /*1-distant for v*/
+ A[v->index][v->index] =
+ (e->bottomsize*A[e->head->index][v->index]
+ + e->topsize*A[v->index][e->head->index])
+ / (e->bottomsize + e->topsize);
+
+ /*2-distant for v,newNode*/
+ A[v->index][newNode->index] = A[newNode->index][v->index] =
+ A[v->index][e->head->index];
+
+ /*second 2-distant for newNode*/
+ A[newNode->index][e->tail->index] = A[e->tail->index][newNode->index]
+ = (e->bottomsize*A[e->head->index][e->tail->index]
+ + A[v->index][e->tail->index])/(e->bottomsize + 1);
+ /*third 2-distant for newNode*/
+ A[newNode->index][e->head->index] = A[e->head->index][newNode->index]
+ = A[e->head->index][e->head->index];
+
+ if (NULL != sib)
+ {
+ /*fourth and last 2-distant for newNode*/
+ A[newNode->index][sib->head->index] =
+ A[sib->head->index][newNode->index] =
+ (e->bottomsize*A[sib->head->index][e->head->index]
+ + A[sib->head->index][v->index]) / (e->bottomsize + 1);
+ updateSubTreeAverages(A,sib,v,SKEW); /*updates sib and below*/
+ }
+ if (NULL != par)
+ {
+ if (e->tail->leftEdge == e)
+ updateSubTreeAverages(A,par,v,LEFT); /*updates par and above*/
+ else
+ updateSubTreeAverages(A,par,v,RIGHT);
+ }
+ if (NULL != left)
+ updateSubTreeAverages(A,left,v,UP); /*updates left and below*/
+ if (NULL != right)
+ updateSubTreeAverages(A,right,v,UP); /*updates right and below*/
+
+ /*1-dist for e->head*/
+ A[e->head->index][e->head->index] =
+ (e->topsize*A[e->head->index][e->head->index]
+ + A[e->head->index][v->index]) / (e->topsize+1);
+ /*2-dist for e->head (v,newNode,left,right)
+ taken care of elsewhere*/
+ /*3-dist with e->head either taken care of elsewhere (below)
+ or unchanged (sib,e->tail)*/
+
+ /*symmetrize the matrix (at least for distant-2 subtrees) */
+ A[v->index][e->head->index] = A[e->head->index][v->index];
+ /*and distant-3 subtrees*/
+ A[e->tail->index][v->index] = A[v->index][e->tail->index];
+ if (NULL != left)
+ A[v->index][left->head->index] = A[left->head->index][v->index];
+ if (NULL != right)
+ A[v->index][right->head->index] = A[right->head->index][v->index];
+ if (NULL != sib)
+ A[v->index][sib->head->index] = A[sib->head->index][v->index];
+
+}
+
+void GMEsplitEdge(tree *T, node *v, edge *e, double **A)
+{
+ int nodelabel = 0;//char nodelabel[NODE_LABEL_LENGTH];
+ char edgelabel[EDGE_LABEL_LENGTH];
+ edge *newPendantEdge;
+ edge *newInternalEdge;
+ node *newNode;
+
+ //snprintf(nodelabel,1,"");
+ newNode = makeNewNode(nodelabel,T->size + 1);
+
+ //sprintf(edgelabel,"E%d",T->size);
+ snprintf(edgelabel,EDGE_LABEL_LENGTH,"E%d",T->size);
+ newPendantEdge = makeEdge(edgelabel,newNode,v,0.0);
+
+ //sprintf(edgelabel,"E%d",T->size+1);
+ snprintf(edgelabel,EDGE_LABEL_LENGTH,"E%d",T->size+1);
+ newInternalEdge = makeEdge(edgelabel,newNode,e->head,0.0);
+
+/* if (verbose)
+ printf("Inserting node %s on edge %s between nodes %s and %s.\n",
+ v->label,e->label,e->tail->label,e->head->label);*/
+ /*update the matrix of average distances*/
+ /*also updates the bottomsize, topsize fields*/
+
+ GMEupdateAveragesMatrix(A,e,v,newNode);
+
+ newNode->parentEdge = e;
+ e->head->parentEdge = newInternalEdge;
+ v->parentEdge = newPendantEdge;
+ e->head = newNode;
+
+ T->size = T->size + 2;
+
+ if (e->tail->leftEdge == e)
+ {
+ newNode->leftEdge = newInternalEdge;
+ newNode->rightEdge = newPendantEdge;
+ }
+ else
+ {
+ newNode->leftEdge = newInternalEdge;
+ newNode->rightEdge = newPendantEdge;
+ }
+
+ /*assign proper topsize, bottomsize values to the two new Edges*/
+
+ newPendantEdge->bottomsize = 1;
+ newPendantEdge->topsize = e->bottomsize + e->topsize;
+
+ newInternalEdge->bottomsize = e->bottomsize;
+ newInternalEdge->topsize = e->topsize; /*off by one, but we adjust
+ that below*/
+
+ /*and increment these fields for all other edges*/
+ updateSizes(newInternalEdge,UP);
+ updateSizes(e,DOWN);
+}
+
+void updateSubTreeAverages(double **A, edge *e, node *v, int direction)
+ /*the monster function of this program*/
+{
+ edge *sib, *left, *right, *par;
+ left = e->head->leftEdge;
+ right = e->head->rightEdge;
+ sib = siblingEdge(e);
+ par = e->tail->parentEdge;
+ switch(direction)
+ {
+ /*want to preserve correctness of
+ all 1-distant, 2-distant, and 3-distant averages*/
+ /*1-distant updated at edge splitting the two trees*/
+ /*2-distant updated:
+ (left->head,right->head) and (head,tail) updated at
+ a given edge. Note, NOT updating (head,sib->head)!
+ (That would lead to multiple updating).*/
+ /*3-distant updated: at edge in center of quartet*/
+ case UP: /*point of insertion is above e*/
+ /*1-distant average of nodes below e to
+ nodes above e*/
+ A[e->head->index][e->head->index] =
+ (e->topsize*A[e->head->index][e->head->index] +
+ A[e->head->index][v->index])/(e->topsize + 1);
+ /*2-distant average of nodes below e to
+ nodes above parent of e*/
+ A[e->head->index][par->head->index] =
+ A[par->head->index][e->head->index] =
+ (par->topsize*A[par->head->index][e->head->index]
+ + A[e->head->index][v->index]) / (par->topsize + 1);
+ /*must do both 3-distant averages involving par*/
+ if (NULL != left)
+ {
+ updateSubTreeAverages(A, left, v, UP); /*and recursive call*/
+ /*3-distant average*/
+ A[par->head->index][left->head->index]
+ = A[left->head->index][par->head->index]
+ = (par->topsize*A[par->head->index][left->head->index]
+ + A[left->head->index][v->index]) / (par->topsize + 1);
+ }
+ if (NULL != right)
+ {
+ updateSubTreeAverages(A, right, v, UP);
+ A[par->head->index][right->head->index]
+ = A[right->head->index][par->head->index]
+ = (par->topsize*A[par->head->index][right->head->index]
+ + A[right->head->index][v->index]) / (par->topsize + 1);
+ }
+ break;
+ case SKEW: /*point of insertion is skew to e*/
+ /*1-distant average of nodes below e to
+ nodes above e*/
+ A[e->head->index][e->head->index] =
+ (e->topsize*A[e->head->index][e->head->index] +
+ A[e->head->index][v->index])/(e->topsize + 1);
+ /*no 2-distant averages to update in this case*/
+ /*updating 3-distant averages involving sib*/
+ if (NULL != left)
+ {
+ updateSubTreeAverages(A, left, v, UP);
+ A[sib->head->index][left->head->index]
+ = A[left->head->index][sib->head->index]
+ = (sib->bottomsize*A[sib->head->index][left->head->index]
+ + A[left->head->index][v->index]) / (sib->bottomsize + 1);
+ }
+ if (NULL != right)
+ {
+ updateSubTreeAverages(A, right, v, UP);
+ A[sib->head->index][right->head->index]
+ = A[right->head->index][sib->head->index]
+ = (sib->bottomsize*A[par->head->index][right->head->index]
+ + A[right->head->index][v->index]) / (sib->bottomsize + 1);
+ }
+ break;
+
+
+ case LEFT: /*point of insertion is below the edge left*/
+ /*1-distant average*/
+ A[e->head->index][e->head->index] =
+ (e->bottomsize*A[e->head->index][e->head->index] +
+ A[v->index][e->head->index])/(e->bottomsize + 1);
+ /*2-distant averages*/
+ A[e->head->index][e->tail->index] =
+ A[e->tail->index][e->head->index] =
+ (e->bottomsize*A[e->head->index][e->tail->index] +
+ A[v->index][e->tail->index])/(e->bottomsize + 1);
+ A[left->head->index][right->head->index] =
+ A[right->head->index][left->head->index] =
+ (left->bottomsize*A[right->head->index][left->head->index]
+ + A[right->head->index][v->index]) / (left->bottomsize+1);
+ /*3-distant avereages involving left*/
+ if (NULL != sib)
+ {
+ updateSubTreeAverages(A, sib, v, SKEW);
+ A[left->head->index][sib->head->index]
+ = A[sib->head->index][left->head->index]
+ = (left->bottomsize*A[left->head->index][sib->head->index]
+ + A[sib->head->index][v->index]) / (left->bottomsize + 1);
+ }
+ if (NULL != par)
+ {
+ if (e->tail->leftEdge == e)
+ updateSubTreeAverages(A, par, v, LEFT);
+ else
+ updateSubTreeAverages(A, par, v, RIGHT);
+ A[left->head->index][par->head->index]
+ = A[par->head->index][left->head->index]
+ = (left->bottomsize*A[left->head->index][par->head->index]
+ + A[v->index][par->head->index]) / (left->bottomsize + 1);
+ }
+ break;
+ case RIGHT: /*point of insertion is below the edge right*/
+ /*1-distant average*/
+ A[e->head->index][e->head->index] =
+ (e->bottomsize*A[e->head->index][e->head->index] +
+ A[v->index][e->head->index])/(e->bottomsize + 1);
+ /*2-distant averages*/
+ A[e->head->index][e->tail->index] =
+ A[e->tail->index][e->head->index] =
+ (e->bottomsize*A[e->head->index][e->tail->index] +
+ A[v->index][e->tail->index])/(e->bottomsize + 1);
+ A[left->head->index][right->head->index] =
+ A[right->head->index][left->head->index] =
+ (right->bottomsize*A[right->head->index][left->head->index]
+ + A[left->head->index][v->index]) / (right->bottomsize+1);
+ /*3-distant avereages involving right*/
+ if (NULL != sib)
+ {
+ updateSubTreeAverages(A, sib, v, SKEW);
+ A[right->head->index][sib->head->index]
+ = A[sib->head->index][right->head->index]
+ = (right->bottomsize*A[right->head->index][sib->head->index]
+ + A[sib->head->index][v->index]) / (right->bottomsize + 1);
+ }
+ if (NULL != par)
+ {
+ if (e->tail->leftEdge == e)
+ updateSubTreeAverages(A, par, v, LEFT);
+ else
+ updateSubTreeAverages(A, par, v, RIGHT);
+ A[right->head->index][par->head->index]
+ = A[par->head->index][right->head->index]
+ = (right->bottomsize*A[right->head->index][par->head->index]
+ + A[v->index][par->head->index]) / (right->bottomsize + 1);
+ }
+
+ break;
+ }
+}
+
+void assignBottomsize(edge *e)
+{
+ if (leaf(e->head))
+ e->bottomsize = 1;
+ else
+ {
+ assignBottomsize(e->head->leftEdge);
+ assignBottomsize(e->head->rightEdge);
+ e->bottomsize = e->head->leftEdge->bottomsize
+ + e->head->rightEdge->bottomsize;
+ }
+}
+
+void assignTopsize(edge *e, int numLeaves)
+{
+ if (NULL != e)
+ {
+ e->topsize = numLeaves - e->bottomsize;
+ assignTopsize(e->head->leftEdge,numLeaves);
+ assignTopsize(e->head->rightEdge,numLeaves);
+ }
+}
+
+void assignAllSizeFields(tree *T)
+{
+ assignBottomsize(T->root->leftEdge);
+ assignTopsize(T->root->leftEdge,T->size/2 + 1);
+}
diff --git a/src/mvr.c b/src/mvr.c
new file mode 100644
index 0000000..cefca41
--- /dev/null
+++ b/src/mvr.c
@@ -0,0 +1,188 @@
+/* mvr.c 2012-05-02 */
+
+/* Copyright 2011-2012 Andrei-Alin Popescu */
+
+/* This file is part of the R-package `ape'. */
+/* See the file ../COPYING for licensing issues. */
+
+#include "ape.h"
+
+void C_mvr(double *D, double* v,int *N, int *edge1, int *edge2, double *edge_length)
+{
+ double *S, Sdist, *new_v, Ndist, *new_dist, A, B, smallest_S;
+ int n, i, j, k, ij, smallest, OTU1, OTU2, cur_nod, o_l, *otu_label;
+
+ S = &Sdist;
+ new_dist = &Ndist;
+ otu_label = &o_l;
+ n = *N;
+ cur_nod = 2*n - 2;
+
+ S = (double*)R_alloc(n + 1, sizeof(double));
+ new_dist = (double*)R_alloc(n*(n - 1)/2, sizeof(double));
+ new_v = (double*)R_alloc(n*(n - 1)/2, sizeof(double));
+ otu_label = (int*)R_alloc(n + 1, sizeof(int));
+
+ for (i = 1; i <= n; i++) otu_label[i] = i; /* otu_label[0] is not used */
+
+ k = 0;
+
+ while (n > 3) {
+
+ /*for(i=1;i<n;i++)
+ {
+ for(j=i+1;j<=n;j++)
+ {
+ Rprintf("d[%i,%i]=%f ",i,j,D[give_index(i,j,n)]);
+ }
+ Rprintf("\n");
+ } */
+
+ for (i = 1; i <= n; i++)
+ {double sum=0;
+ for( j=1;j<=n;j++)
+ {if(i==j)continue;
+ //Rprintf("index(%i,%i)=%i\n",i,j,give_index(i,j,n));
+ //Rprintf("D[%i,%i]=%f\n",i,j,D[give_index(i,j,n)]);
+ sum+=D[give_index(i,j,n)];
+ }
+ S[i]=sum;
+ //Rprintf("\n");
+ //Rprintf("S[%i]=%f\n",i,S[i]);
+ //Rprintf("\n");
+ }
+ ij = 0;
+ smallest_S = 1e50;
+ B = n - 2;
+ for (i = 1; i < n; i++) {
+ for (j = i + 1; j <= n; j++) {
+
+ A = B*D[ij] - S[i] - S[j];
+ /*Rprintf("D[ij]=%f\n",D[ij]);
+ Rprintf("S[%i]=%f\n",i,S[i]);
+ Rprintf("S[%i]=%f\n",j,S[j]);
+ Rprintf("B=%f\n",B);
+ Rprintf("A=%f\n",(B*D[ij] - S[i] - S[j]));
+ Rprintf("Q[%i,%i]=%f\n",i,j,A);*/
+ if (A < smallest_S) {
+ OTU1 = i;
+ OTU2 = j;
+ smallest_S = A;
+ smallest = ij;
+ }
+ ij++;
+ }
+ }
+
+ //Rprintf("agglomerating %i and %i, Q=%f \n",OTU1,OTU2,smallest_S);
+
+ /*for(i=1;i<n;i++)
+ {
+ for(j=i+1;j<=n;j++)
+ {
+ Rprintf("d[%i,%i]=%f ",i,j,D[give_index(i,j,n)]);
+ }
+ Rprintf("\n");
+ }
+
+ for(i=1;i<n;i++)
+ {
+ for(j=i+1;j<=n;j++)
+ {
+ Rprintf("v[%i,%i]=%f ",i,j,v[give_index(i,j,n)]);
+ }
+ Rprintf("\n");
+ }*/
+
+ edge2[k] = otu_label[OTU1];
+ edge2[k + 1] = otu_label[OTU2];
+ edge1[k] = edge1[k + 1] = cur_nod;
+
+ /* get the distances between all OTUs but the 2 selected ones
+ and the latter:
+ a) get the sum for both
+ b) compute the distances for the new OTU */
+ double miu=0;
+ double miuSum=0;
+ for(i=1;i<=n;i++)
+ {
+ if(i == OTU1 || i==OTU2)continue;
+ //Rprintf("index(%i,%i)=%i index(%i,%i)=%i",i,OTU1,give_index(i,OTU1,n),i,OTU2,give_index(i,OTU2,n));
+ miuSum+=(1/(v[give_index(i,OTU1,n)]+v[give_index(i,OTU2,n)]));
+ }
+ miuSum=1/miuSum;
+ miu=miuSum/2;
+
+ double eLenSum=0;
+ for(i=1;i<=n;i++)
+ {
+ if(i == OTU1 || i==OTU2)continue;
+
+ double wi=miu/(v[give_index(i,OTU1,n)]+v[give_index(i,OTU2,n)]);
+ eLenSum+=wi*(D[give_index(i,OTU1,n)]-D[give_index(i,OTU2,n)]);
+ }
+
+ edge_length[k]=D[give_index(OTU1,OTU2,n)]/2 + eLenSum;
+
+ eLenSum=0;
+ /*for(i=1;i<=n;i++)
+ {
+ if(i == OTU1 || i==OTU2)continue;
+
+ double wi=miu/(v[give_index(i,OTU1,n)]+v[give_index(i,OTU2,n)]);
+ eLenSum+=wi*(D[give_index(i,OTU2,n)]-D[give_index(i,OTU1,n)]);
+ }*/
+
+ edge_length[k+1]=D[give_index(OTU1,OTU2,n)] - edge_length[k];
+
+ A = D[smallest];
+ ij = 0;
+ for (i = 1; i <= n; i++) {
+ if (i == OTU1 || i == OTU2) continue;
+ double xi = D[give_index(i, OTU1, n)]; /* dist between OTU1 and i */
+ double yi = D[give_index(i, OTU2, n)]; /* dist between OTU2 and i */
+ double lamb=v[give_index(i,OTU2,n)]/(v[give_index(i,OTU2,n)]+v[give_index(i,OTU1,n)]);
+ new_dist[ij] = lamb*(xi-edge_length[k])+(1-lamb)*(yi-edge_length[k+1]);
+ new_v[ij]=(v[give_index(i,OTU2,n)]*v[give_index(i,OTU1,n)])/(v[give_index(i,OTU2,n)]+v[give_index(i,OTU1,n)]);
+ ij++;
+ }
+ /* compute the branch lengths */
+ //Rprintf("l2:%f \n",edge_length[k+1]);
+ /* update before the next loop
+ (we are sure that OTU1 < OTU2) */
+ if (OTU1 != 1)
+ for (i = OTU1; i > 1; i--)
+ otu_label[i] = otu_label[i - 1];
+ if (OTU2 != n)
+ for (i = OTU2; i < n; i++)
+ otu_label[i] = otu_label[i + 1];
+ otu_label[1] = cur_nod;
+
+ for (i = 1; i < n; i++) {
+ if (i == OTU1 || i == OTU2) continue;
+ for (j = i + 1; j <= n; j++) {
+ if (j == OTU1 || j == OTU2) continue;
+ new_dist[ij] = D[DINDEX(i, j)];
+ new_v[ij]=v[give_index(i,j,n)];
+ ij++;
+ }
+ }
+
+ n--;
+ for (i = 0; i < n*(n - 1)/2; i++)
+ {D[i] = new_dist[i];
+ v[i] = new_v[i];
+ }
+ cur_nod--;
+ k = k + 2;
+ }
+
+ for (i = 0; i < 3; i++) {
+ edge1[*N*2 - 4 - i] = cur_nod;
+ edge2[*N*2 - 4 - i] = otu_label[i + 1];
+ }
+
+ edge_length[*N*2 - 4] = (D[0] + D[1] - D[2])/2;
+ edge_length[*N*2 - 5] = (D[0] + D[2] - D[1])/2;
+ edge_length[*N*2 - 6] = (D[2] + D[1] - D[0])/2;
+}
diff --git a/src/mvrs.c b/src/mvrs.c
new file mode 100644
index 0000000..ac27667
--- /dev/null
+++ b/src/mvrs.c
@@ -0,0 +1,399 @@
+/* mvrs.c 2013-09-26 */
+
+/* Copyright 2011-2012 Andrei-Alin Popescu */
+
+/* This file is part of the R-package `ape'. */
+/* See the file ../COPYING for licensing issues. */
+
+#include "ape.h"
+
+void C_mvrs(double *D, double* v,int *N, int *edge1, int *edge2, double *edge_length,int* fsS)
+{ //assume missing values are denoted by -1
+
+ double *S,*R ,*new_v, Sdist, Ndist, *new_dist, A, B, smallest_S;
+ int n, i, j, k, ij, OTU1, OTU2, cur_nod, o_l, *otu_label;
+ /*for(i=0;i<n*(n-1)/2;i++)
+ {if(isNA(D[i])){D[i]=-1;}
+ }*/
+ int *s;//s contains |Sxy|, which is all we need for agglomeration
+ double *newR;
+ int *newS;
+ int fS=*fsS;
+
+ R = &Sdist;
+ new_dist = &Ndist;
+ otu_label = &o_l;
+ n = *N;
+ cur_nod = 2*n - 2;
+
+ R = (double*)R_alloc(n*(n - 1)/2, sizeof(double));
+ new_v = (double*)R_alloc(n*(n - 1)/2, sizeof(double));
+ S = (double*)R_alloc(n + 1, sizeof(double));
+ newR = (double*)R_alloc(n*(n - 1)/2, sizeof(double));
+ new_dist = (double*)R_alloc(n*(n - 1)/2, sizeof(double));
+ otu_label = (int*)R_alloc(n + 1, sizeof(int));
+ s = (int*)R_alloc(n*(n - 1)/2, sizeof(int));
+ newS = (int*)R_alloc(n*(n - 1)/2, sizeof(int));
+
+ for (i = 1; i <= n; i++) otu_label[i] = i; /* otu_label[0] is not used */
+
+ k = 0;
+ //compute Sxy and Rxy
+
+ for(i=0;i<n*(n-1)/2;i++)
+ {newR[i]=0;
+ newS[i]=0;
+ s[i]=0;
+ R[i]=0;
+ }
+
+ for(i=1;i<n;i++)
+ for(j=i+1;j<=n;j++)
+ {//algorithm assumes i,j /in Sij, so skip pair if it is not known
+ if(D[give_index(i,j,n)]==-1)
+ {
+ continue;
+ }
+ for(k=1;k<=n;k++)
+ {//ij is the pair for which we compute
+ //skip k if we do not know the distances between it and i AND j
+
+ if(k==i || k==j)
+ {
+ if(i!=k)R[give_index(i,j,n)]+=D[give_index(i,k,n)];
+ if(j!=k)R[give_index(i,j,n)]+=D[give_index(j,k,n)];
+ s[give_index(i,j,n)]++;
+ //Rprintf("%i",s[give_index(i,j,n)]);
+
+ continue;
+ }
+ if(D[give_index(i,k,n)]==-1 || D[give_index(j,k,n)]==-1)continue;
+ //Rprintf("%i\n",k);
+ s[give_index(i,j,n)]++;
+ R[give_index(i,j,n)]+=D[give_index(i,k,n)];
+ R[give_index(i,j,n)]+=D[give_index(j,k,n)];
+ //Rprintf("%i",s[give_index(i,j,n)]);
+ //Rprintf("%f",R[give_index(i,j,n)]);
+
+ }
+ }
+
+ /*for(i=1;i<n;i++)
+ {
+ for(j=i+1;j<=n;j++)
+ {
+ Rprintf("R[%i,%i]=%f ",i,j,R[give_index(i,j,n)]);
+ }
+ Rprintf("\n");
+ }
+
+ for(i=1;i<n;i++)
+ {
+ for(j=i+1;j<=n;j++)
+ {
+ Rprintf("s[%i,%i]=%i ",i,j,s[give_index(i,j,n)]);
+ }
+ Rprintf("\n");
+ }*/
+ k=0;
+ int sw=1;//if 1 then incomplete
+ while (n > 3) {
+
+ ij = 0;
+ for(i=1;i<n;i++)
+ for(j=i+1;j<=n;j++)
+ {newR[give_index(i,j,n)]=0;
+ newS[give_index(i,j,n)]=0;
+ }
+
+ smallest_S = -1e50;
+ if(sw==0)
+ for(i=1;i<=n;i++)
+ {S[i]=0;
+ }
+
+ B=n-2;
+ if(sw==1)
+ {
+ choosePair(D,n,R,s,&sw,&OTU1,&OTU2,fS);
+ }
+ else{ //Rprintf("distance matrix is now complete\n");
+ for (i=1;i<=n;i++)
+ for(j=1;j<=n;j++)
+ {if(i==j)continue;
+ //Rprintf("give_index(%i,%i)=%i\n",i,j,give_index(i,j,n));
+ //Rprintf("D[%i,%i]=%f\n",i,j,D[give_index(i,j,n)]);
+ S[i]+=D[give_index(i,j,n)];
+ }
+ B=n-2;
+ //Rprintf("n=%i,B=%f",n,B);
+ for (i = 1; i < n; i++) {
+ for (j = i + 1; j <= n; j++) {
+ //Rprintf("S[%i]=%f, S[%i]=%f, D[%i,%i]=%f, B=%f",i,S[i],j,S[j],i,j,D[give_index(i,j,n)],B);
+ A=S[i]+S[j]-B*D[give_index(i,j,n)];
+ //Rprintf("Q[%i,%i]=%f\n",i,j,A);
+ if (A > smallest_S) {
+ OTU1 = i;
+ OTU2 = j;
+ smallest_S = A;
+ /* smallest = ij; */
+ }
+ ij++;
+ }
+ }
+ }
+ if(s[give_index(OTU1,OTU2,n)]<=2)
+ {error("distance information insufficient to construct a tree, leaves %i and %i isolated from tree",OTU1,OTU2);
+ }
+ //Rprintf("agglomerating %i and %i, Q=%f \n",OTU1,OTU2,smallest_S);
+
+ /*for(i=1;i<n;i++)
+ {
+ for(j=i+1;j<=n;j++)
+ {
+ Rprintf("R[%i,%i]=%f ",i,j,R[give_index(i,j,n)]);
+ }
+ Rprintf("\n");
+ }
+
+ for(i=1;i<n;i++)
+ {
+ for(j=i+1;j<=n;j++)
+ {
+ Rprintf("s[%i,%i]=%i ",i,j,s[give_index(i,j,n)]);
+ }
+ Rprintf("\n");
+ }
+
+ for(i=1;i<n;i++)
+ {
+ for(j=i+1;j<=n;j++)
+ {
+ Rprintf("d[%i,%i]=%f ",i,j,D[give_index(i,j,n)]);
+ }
+ Rprintf("\n");
+ }*/
+
+ //update R and S, only if matrix still incomplete
+ if(sw==1)
+ for(i=1;i<n;i++)
+ {if(i==OTU1 || i==OTU2)continue;
+ for(j=i+1;j<=n;j++)
+ {if(j==OTU1 || j==OTU2)continue;
+ if(D[give_index(i,j,n)]==-1)continue;
+ if(D[give_index(i,OTU1,n)]!=-1 && D[give_index(j,OTU1,n)]!=-1)
+ {//OTU1 was considered for Rij, so now subtract
+ R[give_index(i,j,n)]-=(D[give_index(i,OTU1,n)]+D[give_index(j,OTU1,n)]);
+ s[give_index(i,j,n)]--;
+ }
+ if(D[give_index(i,OTU2,n)]!=-1 && D[give_index(j,OTU2,n)]!=-1)
+ {//OTU2 was considered for Rij, so now subtract
+ R[give_index(i,j,n)]-=(D[give_index(i,OTU2,n)]+D[give_index(j,OTU2,n)]);
+ s[give_index(i,j,n)]--;
+ }
+ }
+ }
+
+ edge2[k] = otu_label[OTU1];
+ edge2[k + 1] = otu_label[OTU2];
+ edge1[k] = edge1[k + 1] = cur_nod;
+
+ double miu=0;
+ double miuSum=0;
+ for(i=1;i<=n;i++)
+ {
+ if(i == OTU1 || i==OTU2)continue;
+ if(D[give_index(i,OTU1,n)]==-1 || D[give_index(i,OTU2,n)]==-1)continue;
+ //Rprintf("index(%i,%i)=%i index(%i,%i)=%i",i,OTU1,give_index(i,OTU1,n),i,OTU2,give_index(i,OTU2,n));
+ miuSum+=(1/(v[give_index(i,OTU1,n)]+v[give_index(i,OTU2,n)]));
+ }
+ miuSum=1/miuSum;
+ miu=miuSum/2;
+
+ double eLenSum=0;
+ for(i=1;i<=n;i++)
+ {
+ if(i == OTU1 || i==OTU2)continue;
+ if(D[give_index(i,OTU1,n)]==-1 || D[give_index(i,OTU2,n)]==-1)continue;
+ double wi=miu/(v[give_index(i,OTU1,n)]+v[give_index(i,OTU2,n)]);
+ eLenSum+=wi*(D[give_index(i,OTU1,n)]-D[give_index(i,OTU2,n)]);
+ }
+
+ edge_length[k]=D[give_index(OTU1,OTU2,n)]/2 + eLenSum;
+
+ eLenSum=0;
+ for(i=1;i<=n;i++)
+ {
+ if(i == OTU1 || i==OTU2)continue;
+ if(D[give_index(i,OTU1,n)]==-1 || D[give_index(i,OTU2,n)]==-1)continue;
+ double wi=miu/(v[give_index(i,OTU1,n)]+v[give_index(i,OTU2,n)]);
+ eLenSum+=wi*(D[give_index(i,OTU2,n)]-D[give_index(i,OTU1,n)]);
+ }
+
+ edge_length[k+1]=D[give_index(OTU1,OTU2,n)]/2 + eLenSum;
+
+ //no need to change distance matrix update for complete distance
+ //case, as pairs will automatically fall in the right cathegory
+
+ //OTU1=x, OTU2=y from formulas
+ A = D[give_index(OTU1,OTU2,n)];
+ ij = 0;
+ for (i = 1; i <= n; i++) {
+ if (i == OTU1 || i == OTU2) continue;
+ if(D[give_index(OTU1,i,n)]!=-1 && D[give_index(OTU2,i,n)]!=-1)
+ { double lamb=v[give_index(i,OTU2,n)]/(v[give_index(i,OTU2,n)]+v[give_index(i,OTU1,n)]);
+ new_dist[ij]= lamb*(D[give_index(OTU1,i,n)]-edge_length[k])+(1-lamb)*(D[give_index(OTU2,i,n)]-edge_length[k+1]);
+ new_v[ij]=(v[give_index(i,OTU2,n)]*v[give_index(i,OTU1,n)])/(v[give_index(i,OTU2,n)]+v[give_index(i,OTU1,n)]);
+ }else{
+ if(D[give_index(OTU1,i,n)]!=-1)
+ {
+ new_dist[ij]=D[give_index(OTU1,i,n)]-edge_length[k];
+ new_v[ij]=v[give_index(OTU1,i,n)];
+ }else{
+ if(D[give_index(OTU2,i,n)]!=-1)
+ {
+ new_dist[ij]=D[give_index(OTU2,i,n)]-edge_length[k+1];
+ new_v[ij]=v[give_index(OTU2,i,n)];
+ }else{new_dist[ij]=-1;new_v[ij]=-1;}
+ }
+ }
+
+ ij++;
+ }
+
+ for (i = 1; i < n; i++) {
+ if (i == OTU1 || i == OTU2) continue;
+ for (j = i + 1; j <= n; j++) {
+ if (j == OTU1 || j == OTU2) continue;
+ new_dist[ij] = D[DINDEX(i, j)];
+ new_v[ij]=v[give_index(i,j,n)];
+ ij++;
+ }
+ }
+
+ /*for(i=1;i<n-1;i++)
+ {
+ for(j=i+1;j<=n-1;j++)
+ {Rprintf("%f ",new_dist[give_index(i,j,n-1)]);
+ }
+ Rprintf("\n");
+ }*/
+ //compute Rui, only if distance matrix is still incomplete
+ ij=0;
+ if(sw==1)
+ for(i=2;i<n;i++)
+ {
+ ij++;
+ if(new_dist[give_index(i,1,n-1)]==-1)continue;
+
+ for(j=1;j<n;j++)
+ {
+ if(j==1 || j==i)
+ {
+ if(i!=j)newR[give_index(1,i,n-1)]+=new_dist[give_index(i,j,n-1)];
+ if(1!=j)newR[give_index(1,i,n-1)]+=new_dist[give_index(1,j,n-1)];
+ newS[give_index(1,i,n-1)]++;
+ continue;
+ }
+ if(new_dist[give_index(i,j,n-1)]!=-1 && new_dist[give_index(1,j,n-1)]!=-1)
+ {
+ newS[give_index(1,i,n-1)]++;
+ newR[give_index(1,i,n-1)]+=new_dist[give_index(i,j,n-1)];
+ newR[give_index(1,i,n-1)]+=new_dist[give_index(1,j,n-1)];
+ }
+ }
+ }
+ //fill in the rest of R and S, again only if distance matrix still
+ //incomplete
+ if(sw==1)
+ for(i=1;i<n;i++)
+ {if(i==OTU1 || i==OTU2)continue;
+ for(j=i+1;j<=n;j++)
+ {if(j==OTU1 || j==OTU2)continue;
+ newR[ij]=R[give_index(i,j,n)];
+ newS[ij]=s[give_index(i,j,n)];
+ ij++;
+ }
+ }
+ //update newR and newS with the new taxa, again only if distance
+ //matrix is still incomplete
+ if(sw==1)
+ for(i=2;i<n-1;i++)
+ {if(new_dist[give_index(1,i,n-1)]==-1)continue;
+ for(j=i+1;j<=n-1;j++)
+ {if(new_dist[give_index(1,j,n-1)]==-1)continue;
+ if(new_dist[give_index(i,j,n-1)]==-1)continue;
+ newR[give_index(i,j,n-1)]+=(new_dist[give_index(1,i,n-1)]+new_dist[give_index(1,j,n-1)]);
+ newS[give_index(i,j,n-1)]++;
+ }
+ }
+ /* compute the branch lengths */
+
+
+
+ /* update before the next loop
+ (we are sure that OTU1 < OTU2) */
+ if (OTU1 != 1)
+ for (i = OTU1; i > 1; i--)
+ otu_label[i] = otu_label[i - 1];
+ if (OTU2 != n)
+ for (i = OTU2; i < n; i++)
+ otu_label[i] = otu_label[i + 1];
+ otu_label[1] = cur_nod;
+
+
+
+ n--;
+ for (i = 0; i < n*(n - 1)/2; i++)
+ {
+ D[i] = new_dist[i];
+ v[i] = new_v[i];
+ if(sw==1)
+ {
+ R[i] = newR[i];
+ s[i] = newS[i];
+ }
+ }
+ cur_nod--;
+ k = k + 2;
+ }
+ int dK=0;//number of known distances in final distance matrix
+ int iUK=-1;//index of unkown distance, if we have one missing distance
+ int iK=-1;//index of only known distance, only needed if dK==1
+ for (i = 0; i < 3; i++) {
+ edge1[*N*2 - 4 - i] = cur_nod;
+ edge2[*N*2 - 4 - i] = otu_label[i + 1];
+ if(D[i]!=-1){dK++;iK=i;}else{iUK=i;}
+ }
+ if(dK==2)
+ {//if two distances are known: assume our leaves are x,y,z, d(x,z) unknown
+ //and edge weights of three edges are a,b,c, then any b,c>0 that
+ //satisfy c-b=d(y,z)-d(x,y) a+c=d(y,z) are good edge weights, but for
+ //simplicity we assume a=c if d(yz)<d(xy) a=b otherwise, and after some
+ //algebra we get that we can set the missing distance equal to the
+ //maximum of the already present distances
+ double max=-1e50;
+ for(i=0;i<3;i++)
+ {if(i==iUK)continue;
+ if(D[i]>max)max=D[i];
+ }
+ D[iUK]=max;
+ }
+ if(dK==1)
+ {//through similar motivation as above, if we have just one known distance
+ //we set the other two distances equal to it
+ for(i=0;i<3;i++)
+ {if(i==iK)continue;
+ D[i]=D[iK];
+ }
+ }
+ if(dK==0)
+ {//no distances are known, we just set them to 1
+ for(i=0;i<3;i++)
+ {D[i]=1;
+ }
+ }
+ edge_length[*N*2 - 4] = (D[0] + D[1] - D[2])/2;
+ edge_length[*N*2 - 5] = (D[0] + D[2] - D[1])/2;
+ edge_length[*N*2 - 6] = (D[2] + D[1] - D[0])/2;
+}
diff --git a/src/nj.c b/src/nj.c
new file mode 100644
index 0000000..3b9cdab
--- /dev/null
+++ b/src/nj.c
@@ -0,0 +1,151 @@
+/* nj.c 2011-10-20 */
+
+/* Copyright 2006-2011 Emmanuel Paradis */
+
+/* This file is part of the R-package `ape'. */
+/* See the file ../COPYING for licensing issues. */
+
+#include "ape.h"
+
+double sum_dist_to_i(int n, double *D, int i)
+/* returns the sum of all distances D_ij between i and j
+ with j = 1...n and j != i */
+{
+/* we use the fact that the distances are arranged sequentially
+ in the lower triangle, e.g. with n = 6 the 15 distances are
+ stored as (the C indices are indicated):
+
+ i
+ 1 2 3 4 5
+
+ 2 0
+ 3 1 5
+j 4 2 6 9
+ 5 3 7 10 12
+ 6 4 8 11 13 14
+
+ so that we sum the values of the ith column--1st loop--and those of
+ (i - 1)th row (labelled 'i')--2nd loop */
+
+ double sum = 0;
+ int j, start, end;
+
+ if (i < n) {
+ /* the expression below CANNOT be factorized
+ because of the integer operations (it took
+ me a while to find out...) */
+ start = n*(i - 1) - i*(i - 1)/2;
+ end = start + n - i;
+ for (j = start; j < end; j++) sum += D[j];
+ }
+
+ if (i > 1) {
+ start = i - 2;
+ for (j = 1; j <= i - 1; j++) {
+ sum += D[start];
+ start += n - j - 1;
+ }
+ }
+
+ return(sum);
+}
+
+void C_nj(double *D, int *N, int *edge1, int *edge2, double *edge_length)
+{
+ double *S, Sdist, Ndist, *new_dist, A, B, smallest_S, x, y;
+ int n, i, j, k, ij, smallest, OTU1, OTU2, cur_nod, o_l, *otu_label;
+
+ S = &Sdist;
+ new_dist = &Ndist;
+ otu_label = &o_l;
+
+ n = *N;
+ cur_nod = 2*n - 2;
+
+ S = (double*)R_alloc(n + 1, sizeof(double));
+ new_dist = (double*)R_alloc(n*(n - 1)/2, sizeof(double));
+ otu_label = (int*)R_alloc(n + 1, sizeof(int));
+
+ for (i = 1; i <= n; i++) otu_label[i] = i; /* otu_label[0] is not used */
+
+ k = 0;
+
+ while (n > 3) {
+
+ for (i = 1; i <= n; i++)
+ S[i] = sum_dist_to_i(n, D, i); /* S[0] is not used */
+
+ ij = 0;
+ smallest_S = 1e50;
+ B = n - 2;
+ for (i = 1; i < n; i++) {
+ for (j = i + 1; j <= n; j++) {
+ A = B*D[ij] - S[i] - S[j];
+ if (A < smallest_S) {
+ OTU1 = i;
+ OTU2 = j;
+ smallest_S = A;
+ smallest = ij;
+ }
+ ij++;
+ }
+ }
+
+ edge2[k] = otu_label[OTU1];
+ edge2[k + 1] = otu_label[OTU2];
+ edge1[k] = edge1[k + 1] = cur_nod;
+
+ /* get the distances between all OTUs but the 2 selected ones
+ and the latter:
+ a) get the sum for both
+ b) compute the distances for the new OTU */
+
+ A = D[smallest];
+ ij = 0;
+ for (i = 1; i <= n; i++) {
+ if (i == OTU1 || i == OTU2) continue;
+ x = D[give_index(i, OTU1, n)]; /* dist between OTU1 and i */
+ y = D[give_index(i, OTU2, n)]; /* dist between OTU2 and i */
+ new_dist[ij] = (x + y - A)/2;
+ ij++;
+ }
+ /* compute the branch lengths */
+ B = (S[OTU1] - S[OTU2])/B; /* don't need B anymore */
+ edge_length[k] = (A + B)/2;
+ edge_length[k + 1] = (A - B)/2;
+
+ /* update before the next loop
+ (we are sure that OTU1 < OTU2) */
+ if (OTU1 != 1)
+ for (i = OTU1; i > 1; i--)
+ otu_label[i] = otu_label[i - 1];
+ if (OTU2 != n)
+ for (i = OTU2; i < n; i++)
+ otu_label[i] = otu_label[i + 1];
+ otu_label[1] = cur_nod;
+
+ for (i = 1; i < n; i++) {
+ if (i == OTU1 || i == OTU2) continue;
+ for (j = i + 1; j <= n; j++) {
+ if (j == OTU1 || j == OTU2) continue;
+ new_dist[ij] = D[DINDEX(i, j)];
+ ij++;
+ }
+ }
+
+ n--;
+ for (i = 0; i < n*(n - 1)/2; i++) D[i] = new_dist[i];
+
+ cur_nod--;
+ k = k + 2;
+ }
+
+ for (i = 0; i < 3; i++) {
+ edge1[*N*2 - 4 - i] = cur_nod;
+ edge2[*N*2 - 4 - i] = otu_label[i + 1];
+ }
+
+ edge_length[*N*2 - 4] = (D[0] + D[1] - D[2])/2;
+ edge_length[*N*2 - 5] = (D[0] + D[2] - D[1])/2;
+ edge_length[*N*2 - 6] = (D[2] + D[1] - D[0])/2;
+}
diff --git a/src/njs.c b/src/njs.c
new file mode 100644
index 0000000..6071602
--- /dev/null
+++ b/src/njs.c
@@ -0,0 +1,681 @@
+/* njs.c 2013-09-26 */
+
+/* Copyright 2011-2013 Andrei-Alin Popescu */
+
+/* This file is part of the R-package `ape'. */
+/* See the file ../COPYING for licensing issues. */
+
+#include "ape.h"
+
+int H(double t)
+{
+ if (t >= 0 - 1e-10) return 1;
+ return 0;
+}
+
+void choosePair(double* D,int n,double* R,int* s, int* sw, int* x, int* y, int fS)
+{
+ int i=0,j=0,k=0;
+ int sww=0;
+ double cFS[fS];
+ int iFS[fS];
+ int jFS[fS];
+ for(k=0;k<fS;k++)
+ {cFS[k]=-1e50;
+ iFS[k]=0;
+ jFS[k]=0;
+ }
+ double max=-1e50;
+ for (i = 1; i < n; i++)
+ {
+ for (j = i + 1; j <= n; j++)
+ {if(D[give_index(i,j,n)]==-1){sww=1;continue;}
+ if(s[give_index(i,j,n)]<=2)continue;
+ //Rprintf("R[%i,%i]=%f\n",i,j,R[give_index(i,j,n)]);
+ //Rprintf("s[%i,%i]=%i\n",i,j,s[give_index(i,j,n)]);
+ //Rprintf("D[%i,%i]=%f\n",i,j,D[give_index(i,j,n)]);
+ int tr=0;
+ double numb=((R[give_index(i,j,n)])/(s[give_index(i,j,n)]-2))-D[give_index(i,j,n)];
+ //Rprintf("numb(%i,%i)=%f\n",i,j,numb);
+ for(k=0;k<fS && cFS[k]>numb;k++);
+ //Rprintf("k=%i ",k);
+ for(tr=fS-1;tr>k;tr--)
+ {cFS[tr]=cFS[tr-1];
+ iFS[tr]=iFS[tr-1];
+ jFS[tr]=jFS[tr-1];
+ }
+
+ if(k<fS){cFS[k]=numb;
+ iFS[k]=i;
+ jFS[k]=j;
+ }
+ }
+ }
+
+ //no missing distances, just return the one with maximal Q-criterion
+ if(sww==0){*x=iFS[0];*y=jFS[0];*sw=0;return;
+ }
+ /*for(k=0;k<fS;k++)
+ {Rprintf("value[%i]=%f ",k,cFS[k]);
+ Rprintf("i=%i ",iFS[k]);
+ Rprintf("j=%i ",jFS[k]);
+ Rprintf("\n");
+ }*/
+ //calculate N*(x,y)
+ for(i=0;i<fS;i++)
+ {
+ if(iFS[i]==0 || jFS[i]==0)continue;
+ double nb=nxy(iFS[i],jFS[i],n,D);
+ if(nb>max){max=nb;}
+ cFS[i]=nb;
+ }
+ /*Rprintf("all N*(x,y)\n");
+ for(k=0;k<fS;k++)
+ {Rprintf("value[%i]=%f ",k,cFS[k]);
+ Rprintf("i=%i ",iFS[k]);
+ Rprintf("j=%i ",jFS[k]);
+ Rprintf("\n");
+ }*/
+ int dk=0;
+ //shift the max N*xy to the front of the array
+ for(i=0;i<fS;i++)
+ {
+ if(cFS[i]==max)
+ {
+ cFS[dk]=cFS[i];
+ iFS[dk]=iFS[i];
+ jFS[dk]=jFS[i];
+ dk++;
+ }
+ }
+ //if just one pair realises max N*xy, return it
+ if(dk==1){*x=iFS[0];*y=jFS[0];return;}
+ fS=dk;
+ /*Rprintf("max n*xy values\n");
+ for(k=0;k<fS;k++)
+ {Rprintf("value[%i]=%f ",k,cFS[k]);
+ Rprintf("i=%i ",iFS[k]);
+ Rprintf("j=%i ",jFS[k]);
+ Rprintf("\n");
+ }*/
+ max=-1e50;
+ //on the front of the array containing max N*xy values compute cxy
+ for(i=0;i<fS;i++)
+ {
+ if(iFS[i]==0 || jFS[i]==0)continue;
+ double nb=cxy(iFS[i],jFS[i],n,D);
+ if(nb>max){max=nb;}
+ cFS[i]=nb;
+ }
+ /*Rprintf("all c*xy values\n");
+ for(k=0;k<fS;k++)
+ {Rprintf("value[%i]=%f ",k,cFS[k]);
+ Rprintf("i=%i ",iFS[k]);
+ Rprintf("j=%i ",jFS[k]);
+ Rprintf("\n");
+ }*/
+ //and again shift maximal C*xy values at the fron of the array
+ dk=0;
+ for(i=0;i<fS;i++)
+ {
+ if(cFS[i]==max)
+ {
+ cFS[dk]=cFS[i];
+ iFS[dk]=iFS[i];
+ jFS[dk]=jFS[i];
+ dk++;
+ }
+ }
+ //if just one C*xy with maximal value, return pair realising it
+ if(dk==1){*x=iFS[0];*y=jFS[0];return;}
+ fS=dk;
+ /*Rprintf("max c*xy values\n");
+ for(k=0;k<fS;k++)
+ {Rprintf("value[%i]=%f ",k,cFS[k]);
+ Rprintf("i=%i ",iFS[k]);
+ Rprintf("j=%i ",jFS[k]);
+ Rprintf("\n");
+ }*/
+ max=-1e50;
+ //on the front of the array containing max C*xy compute m*xy
+ for(i=0;i<fS;i++)
+ {
+ if(iFS[i]==0 || jFS[i]==0)continue;
+ double nb=mxy(iFS[i],jFS[i],n,D);
+ if(nb>max){max=nb;}
+ cFS[i]=nb;
+ }
+ /*Rprintf("all m*xy values\n");
+ for(k=0;k<fS;k++)
+ {Rprintf("value[%i]=%f ",k,cFS[k]);
+ Rprintf("i=%i ",iFS[k]);
+ Rprintf("j=%i ",jFS[k]);
+ Rprintf("\n");
+ }*/
+ //again shift maximal m*xy values to the fron of the array
+ dk=0;
+ for(i=0;i<fS;i++)
+ {
+ if(cFS[i]==max)
+ {
+ cFS[dk]=cFS[i];
+ iFS[dk]=iFS[i];
+ jFS[dk]=jFS[i];
+ dk++;
+ }
+ }
+ //if just one maximal value for m*xy return the pair realising it, found at 0
+ if(dk==1){*x=iFS[0];*y=jFS[0];return;}
+ fS=dk;
+ /*Rprintf("max m*xy values\n");
+ for(k=0;k<fS;k++)
+ {Rprintf("value[%i]=%f ",k,cFS[k]);
+ Rprintf("i=%i ",iFS[k]);
+ Rprintf("j=%i ",jFS[k]);
+ Rprintf("\n");
+ }*/
+ //and calculate cnxy on these values, but this time we do not shift, but simply
+ //return the pair realising the maximum, stored at iPos
+ max=-1e50;
+ int iPos=0;
+ for(i=0;i<fS;i++)
+ {
+ if(iFS[i]==0 || jFS[i]==0)continue;
+ double nb=cnxy(iFS[i],jFS[i],n,D);
+ if(nb>max){max=nb;iPos=i;}
+ cFS[i]=nb;
+ }
+ /*Rprintf("cN*xy\n");
+ Rprintf("value[%i]=%f ",0,cFS[0]);
+ Rprintf("i=%i ",iFS[0]);
+ Rprintf("j=%i ",jFS[0]);
+ Rprintf("\n");*/
+ if(iFS[iPos]==0 || jFS[iPos]==0)
+ {
+ error("distance information insufficient to construct a tree, cannot calculate agglomeration criterion");
+ }
+ *x=iFS[iPos];*y=jFS[iPos];
+}
+
+double cnxy(int x, int y, int n,double* D)
+{
+ int i=0;
+ int j=0;
+ double nMeanXY=0;
+ //Rprintf("cN[%i,%i]\n",x,y);
+ for(i=1;i<=n;i++)
+ {
+ for(j=1;j<=n;j++)
+ {if(i==j)continue;
+ if((i==x && j==y) || (j==x && i==y))continue;
+ double n1=0;
+ double n2=0;
+ if(i!=x)n1=D[give_index(i,x,n)];
+ if(j!=y)n2=D[give_index(j,y,n)];
+ if(n1==-1 || n2==-1 || D[give_index(i,j,n)]==-1)continue;
+ nMeanXY+=(n1+n2-D[give_index(x,y,n)]-D[give_index(i,j,n)]);
+ //Rprintf("cnMeanXY after (%i,%i)=%f\n",i,j,nMeanXY);
+ }
+ }
+ return nMeanXY;
+}
+
+int mxy(int x,int y,int n,double* D)
+{
+ int i=0;
+ int mx[n+1];
+ int my[n+1];
+ for(i=1;i<=n;i++)
+ {
+ mx[i]=0;my[i]=0;
+ }
+ for(i=1;i<=n;i++)
+ {
+ if(i!=x && D[give_index(x,i,n)]==-1)
+ {
+ mx[i]=1;
+ }
+ if(i!=y && D[give_index(y,i,n)]==-1)
+ {
+ my[i]=1;
+ }
+ }
+ /*for(i=1;i<=n;i++)
+ {
+ Rprintf("mx[%i]=%i ",i,mx[i]);
+ }
+ Rprintf("\n");
+
+ for(i=1;i<=n;i++)
+ {
+ Rprintf("my[%i]=%i ",i,my[i]);
+ }
+ Rprintf("\n");*/
+
+ int xmy=0;
+ int ymx=0;
+ for(i=1;i<=n;i++)
+ {
+ if(i!=x && mx[i]==1 && my[i]==0)
+ {
+ xmy++;
+ }
+ if(i!=y && my[i]==1 && mx[i]==0)
+ {
+ ymx++;
+ }
+ }
+ //Rprintf("xmy=%i, ymx=%i, xmy+ymx=%i\n",xmy,ymx,xmy+ymx);
+ return xmy+ymx;
+}
+double nxy(int x, int y, int n,double* D)
+{
+ int sCXY=0;
+ int i=0;
+ int j=0;
+ double nMeanXY=0;
+ //Rprintf("N[%i,%i]\n",x,y);
+ for(i=1;i<=n;i++)
+ {
+ for(j=1;j<=n;j++)
+ {if(i==j)continue;
+ if((i==x && j==y) || (j==x && i==y))continue;
+ double n1=0;
+ double n2=0;
+ if(i!=x)n1=D[give_index(i,x,n)];
+ if(j!=y)n2=D[give_index(j,y,n)];
+ if(n1==-1 || n2==-1 || D[give_index(i,j,n)]==-1)continue;
+ sCXY++;
+ //Rprintf("considered pair (%i,%i)\n",i,j);
+ nMeanXY+=H(n1+n2-D[give_index(x,y,n)]-D[give_index(i,j,n)]);
+ //Rprintf("nMeanXY after (%i,%i)=%f\n",i,j,nMeanXY);
+ }
+ }
+ //Rprintf("sCXY=%i",sCXY);
+ if(sCXY==0) return 0;
+ return nMeanXY/sCXY;
+}
+
+int cxy(int x, int y, int n,double* D)
+{
+ int sCXY=0;
+ int i=0;
+ int j=0;
+
+ for(i=1;i<=n;i++)
+ {
+ for(j=1;j<=n;j++)
+ {if(i==j)continue;
+ if((i==x && j==y) || (j==x && i==y))continue;
+ double n1=0;
+ double n2=0;
+ if(i!=x)n1=D[give_index(i,x,n)];
+ if(j!=y)n2=D[give_index(j,y,n)];
+ if(n1==-1 || n2==-1 || D[give_index(i,j,n)]==-1)continue;
+ sCXY++;
+ }
+ }
+ return sCXY;
+}
+
+void C_njs(double *D, int *N, int *edge1, int *edge2, double *edge_length, int *fsS)
+{ //assume missing values are denoted by -1
+ double *S,*R, Sdist, Ndist, *new_dist, A, B, smallest_S;
+ int n, i, j, k, ij, OTU1, OTU2, cur_nod, o_l, *otu_label;
+ /*for(i=0;i<n*(n-1)/2;i++)
+ {if(isNA(D[i])){D[i]=-1;}
+ }*/
+ int *s;//s contains |Sxy|, which is all we need for agglomeration
+ double *newR;
+ int *newS;
+ int fS=*fsS;
+
+ R = &Sdist;
+ new_dist = &Ndist;
+ otu_label = &o_l;
+ n = *N;
+ cur_nod = 2*n - 2;
+
+ R = (double*)R_alloc(n*(n - 1)/2, sizeof(double));
+ S = (double*)R_alloc(n + 1, sizeof(double));
+ newR = (double*)R_alloc(n*(n - 1)/2, sizeof(double));
+ new_dist = (double*)R_alloc(n*(n - 1)/2, sizeof(double));
+ otu_label = (int*)R_alloc(n + 1, sizeof(int));
+ s = (int*)R_alloc(n*(n - 1)/2, sizeof(int));
+ newS = (int*)R_alloc(n*(n - 1)/2, sizeof(int));
+
+ for (i = 1; i <= n; i++) otu_label[i] = i; /* otu_label[0] is not used */
+
+ k = 0;
+
+ //compute Sxy and Rxy
+ for(i=0;i<n*(n-1)/2;i++)
+ {newR[i]=0;
+ newS[i]=0;
+ s[i]=0;
+ R[i]=0;
+ }
+
+ for(i=1;i<n;i++)
+ for(j=i+1;j<=n;j++)
+ {//algorithm assumes i,j /in Sij, so skip pair if it is not known
+ if(D[give_index(i,j,n)]==-1)
+ {
+ continue;
+ }
+ //Rprintf("for %i and %i :\n",i,j);
+ for(k=1;k<=n;k++)
+ {//ij is the pair for which we compute
+ //skip k if we do not know the distances between it and i AND j
+ if(k==i || k==j)
+ {
+ s[give_index(i,j,n)]++;
+ if(i!=k)R[give_index(i,j,n)]+=D[give_index(i,k,n)];
+ if(j!=k)R[give_index(i,j,n)]+=D[give_index(j,k,n)];
+ continue;
+ }
+ if(D[give_index(i,k,n)]==-1 || D[give_index(j,k,n)]==-1)continue;
+ //Rprintf("%i\n",k);
+ s[give_index(i,j,n)]++;
+ R[give_index(i,j,n)]+=D[give_index(i,k,n)];
+ R[give_index(i,j,n)]+=D[give_index(j,k,n)];
+ }
+ }
+
+ /*for(i=1;i<n;i++)
+ {
+ for(j=i+1;j<=n;j++)
+ {
+ Rprintf("R[%i,%i]=%f ",i,j,R[give_index(i,j,n)]);
+ }
+ Rprintf("\n");
+ }
+
+ for(i=1;i<n;i++)
+ {
+ for(j=i+1;j<=n;j++)
+ {
+ Rprintf("s[%i,%i]=%i ",i,j,s[give_index(i,j,n)]);
+ }
+ Rprintf("\n");
+ }*/
+
+ k=0;
+ int sw=1;//if 1 then incomplete
+ while (n > 3) {
+ ij = 0;
+ for(i=1;i<n;i++)
+ for(j=i+1;j<=n;j++)
+ {newR[give_index(i,j,n)]=0;
+ newS[give_index(i,j,n)]=0;
+ }
+ smallest_S = -1e50;
+ if(sw==0)
+ for(i=1;i<=n;i++)
+ {S[i]=0;
+ }
+ B=n-2;
+ if(sw==1)
+ {
+ choosePair(D,n,R,s,&sw,&OTU1,&OTU2,fS);
+ }
+ else{ //Rprintf("distance matrix is now complete\n");
+ for (i=1;i<=n;i++)
+ for(j=1;j<=n;j++)
+ {if(i==j)continue;
+ //Rprintf("give_index(%i,%i)=%i\n",i,j,give_index(i,j,n));
+ //Rprintf("D[%i,%i]=%f\n",i,j,D[give_index(i,j,n)]);
+ S[i]+=D[give_index(i,j,n)];
+ }
+ B=n-2;
+ //Rprintf("n=%i,B=%f",n,B);
+ for (i = 1; i < n; i++) {
+ for (j = i + 1; j <= n; j++) {
+ //Rprintf("S[%i]=%f, S[%i]=%f, D[%i,%i]=%f, B=%f",i,S[i],j,S[j],i,j,D[give_index(i,j,n)],B);
+ A=S[i]+S[j]-B*D[give_index(i,j,n)];
+ //Rprintf("Q[%i,%i]=%f\n",i,j,A);
+ if (A > smallest_S) {
+ OTU1 = i;
+ OTU2 = j;
+ smallest_S = A;
+ /* smallest = ij; */
+ }
+ ij++;
+ }
+ }
+ }
+
+ /*Rprintf("agglomerating %i and %i, Q=%f \n",OTU1,OTU2,smallest_S);
+
+ for(i=1;i<n;i++)
+ {
+ for(j=i+1;j<=n;j++)
+ {
+ Rprintf("R[%i,%i]=%f ",i,j,R[give_index(i,j,n)]);
+ }
+ Rprintf("\n");
+ }
+
+ for(i=1;i<n;i++)
+ {
+ for(j=i+1;j<=n;j++)
+ {
+ Rprintf("s[%i,%i]=%i ",i,j,s[give_index(i,j,n)]);
+ }
+ Rprintf("\n");
+ }
+
+ for(i=1;i<n;i++)
+ {
+ for(j=i+1;j<=n;j++)
+ {
+ Rprintf("d[%i,%i]=%f ",i,j,D[give_index(i,j,n)]);
+ }
+ Rprintf("\n");
+ }*/
+ //update Rxy and Sxy, only if matrix still incomplete
+ if(sw==1)
+ for(i=1;i<n;i++)
+ {if(i==OTU1 || i==OTU2)continue;
+ for(j=i+1;j<=n;j++)
+ {if(j==OTU1 || j==OTU2)continue;
+ if(D[give_index(i,j,n)]==-1)continue;
+ if(D[give_index(i,OTU1,n)]!=-1 && D[give_index(j,OTU1,n)]!=-1)
+ {//OTU1 was considered for Rij, so now subtract
+ R[give_index(i,j,n)]-=(D[give_index(i,OTU1,n)]+D[give_index(j,OTU1,n)]);
+ s[give_index(i,j,n)]--;
+ }
+ if(D[give_index(i,OTU2,n)]!=-1 && D[give_index(j,OTU2,n)]!=-1)
+ {//OTU2 was considered for Rij, so now subtract
+ R[give_index(i,j,n)]-=(D[give_index(i,OTU2,n)]+D[give_index(j,OTU2,n)]);
+ s[give_index(i,j,n)]--;
+ }
+ }
+ }
+
+ edge2[k] = otu_label[OTU1];
+ edge2[k + 1] = otu_label[OTU2];
+ edge1[k] = edge1[k + 1] = cur_nod;
+
+ /* get the distances between all OTUs but the 2 selected ones
+ and the latter:
+ a) get the sum for both
+ b) compute the distances for the new OTU */
+
+ double sum=0;
+
+ for(i=1;i<=n;i++)
+ {if(i==OTU1 || i==OTU2)continue;
+ if(D[give_index(OTU1,i,n)]==-1 || D[give_index(OTU2,i,n)]==-1)continue;
+ sum+=(D[give_index(OTU1,i,n)]-D[give_index(OTU2,i,n)]);
+ }
+ //although s was updated above, s[otu1,otu2] has remained unchanged
+ //so it is safe to use it here
+ //if complete distanes, use N-2, else use S
+ int down=B;
+ if(sw==1){down=s[give_index(OTU1,OTU2,n)]-2;}
+ if(down<=0)
+ {error("distance information insufficient to construct a tree, leaves %i and %i isolated from tree",OTU1,OTU2);
+ }
+ //Rprintf("down=%i\n",down);
+ sum*=(1.0/(2*(down)));
+ //Rprintf("sum=%f\n",sum);
+ double dxy=D[give_index(OTU1,OTU2,n)]/2;
+
+ //Rprintf("R[%i,%i]:%f \n",OTU1,OTU2,sum);
+ edge_length[k] = dxy+sum;//OTU1
+ //Rprintf("l1:%f \n",edge_length[k]);
+ edge_length[k + 1] = dxy-sum;//OTU2
+ //Rprintf("l2:%f \n",edge_length[k+1]);
+ //no need to change distance matrix update for complete distance
+ //case, as pairs will automatically fall in the right cathegory
+ A = D[give_index(OTU1,OTU2,n)];
+ ij = 0;
+ for (i = 1; i <= n; i++) {
+ if (i == OTU1 || i == OTU2) continue;
+ if(D[give_index(OTU1,i,n)]!=-1 && D[give_index(OTU2,i,n)]!=-1)
+ {
+ new_dist[ij]=0.5*(D[give_index(OTU1,i,n)]-edge_length[k]+D[give_index(OTU2,i,n)]-edge_length[k+1]);
+ }else{
+ if(D[give_index(OTU1,i,n)]!=-1)
+ {
+ new_dist[ij]=D[give_index(OTU1,i,n)]-edge_length[k];
+ }else{
+ if(D[give_index(OTU2,i,n)]!=-1)
+ {
+ new_dist[ij]=D[give_index(OTU2,i,n)]-edge_length[k+1];
+ }else{new_dist[ij]=-1;}
+ }
+ }
+
+ ij++;
+ }
+
+ for (i = 1; i < n; i++) {
+ if (i == OTU1 || i == OTU2) continue;
+ for (j = i + 1; j <= n; j++) {
+ if (j == OTU1 || j == OTU2) continue;
+ new_dist[ij] = D[DINDEX(i, j)];
+ ij++;
+ }
+ }
+
+ /*for(i=1;i<n-1;i++)
+ {
+ for(j=i+1;j<=n-1;j++)
+ {Rprintf("%f ",new_dist[give_index(i,j,n-1)]);
+ }
+ Rprintf("\n");
+ }*/
+ //compute Rui, only if distance matrix is still incomplete
+ ij=0;
+ if(sw==1)
+ for(i=2;i<n;i++)
+ {
+ ij++;
+ if(new_dist[give_index(i,1,n-1)]==-1)continue;
+
+ for(j=1;j<n;j++)
+ { if(j==1 || j==i)
+ {
+ if(i!=j)newR[give_index(1,i,n-1)]+=new_dist[give_index(i,j,n-1)];
+ if(j!=1)newR[give_index(1,i,n-1)]+=new_dist[give_index(1,j,n-1)];
+ newS[give_index(1,i,n-1)]++;
+ continue;
+ }
+ if(new_dist[give_index(i,j,n-1)]!=-1 && new_dist[give_index(1,j,n-1)]!=-1)
+ {
+ newS[give_index(1,i,n-1)]++;
+ newR[give_index(1,i,n-1)]+=new_dist[give_index(i,j,n-1)];
+ newR[give_index(1,i,n-1)]+=new_dist[give_index(1,j,n-1)];
+ }
+ }
+ }
+ //fill in the rest of R and S, again only if distance matrix still
+ //incomplete
+ if(sw==1) /* added 2012-04-02 */
+ for(i=1;i<n;i++)
+ {if(i==OTU1 || i==OTU2)continue;
+ for(j=i+1;j<=n;j++)
+ {if(j==OTU1 || j==OTU2)continue;
+ newR[ij]=R[give_index(i,j,n)];
+ newS[ij]=s[give_index(i,j,n)];
+ ij++;
+ }
+ }
+ //update newR and newS with the new taxa, again only if distance
+ //matrix is still incomplete
+ if(sw==1)
+ for(i=2;i<n-1;i++)
+ {if(new_dist[give_index(1,i,n-1)]==-1)continue;
+ for(j=i+1;j<=n-1;j++)
+ {if(new_dist[give_index(1,j,n-1)]==-1)continue;
+ if(new_dist[give_index(i,j,n-1)]==-1)continue;
+ newR[give_index(i,j,n-1)]+=(new_dist[give_index(1,i,n-1)]+new_dist[give_index(1,j,n-1)]);
+ newS[give_index(i,j,n-1)]++;
+ }
+ }
+
+ /* update before the next loop
+ (we are sure that OTU1 < OTU2) */
+ if (OTU1 != 1)
+ for (i = OTU1; i > 1; i--)
+ otu_label[i] = otu_label[i - 1];
+ if (OTU2 != n)
+ for (i = OTU2; i < n; i++)
+ otu_label[i] = otu_label[i + 1];
+ otu_label[1] = cur_nod;
+
+ n--;
+ for (i = 0; i < n*(n - 1)/2; i++)
+ {
+ D[i] = new_dist[i];
+ if(sw==1)
+ {
+ R[i] = newR[i];
+ s[i] = newS[i];
+ }
+ }
+ cur_nod--;
+ k = k + 2;
+ }
+ int dK=0;//number of known distances in final distance matrix
+ int iUK=-1;//index of unkown distance, if we have one missing distance
+ int iK=-1;//index of only known distance, only needed if dK==1
+ for (i = 0; i < 3; i++) {
+ edge1[*N*2 - 4 - i] = cur_nod;
+ edge2[*N*2 - 4 - i] = otu_label[i + 1];
+ if(D[i]!=-1){dK++;iK=i;}else{iUK=i;}
+ }
+ if(dK==2)
+ {//if two distances are known: assume our leaves are x,y,z, d(x,z) unknown
+ //and edge weights of three edges are a,b,c, then any b,c>0 that
+ //satisfy c-b=d(y,z)-d(x,y) a+c=d(y,z) are good edge weights, but for
+ //simplicity we assume a=c if d(yz)<d(xy) a=b otherwise, and after some
+ //algebra we get that we can set the missing distance equal to the
+ //maximum of the already present distances
+ double max=-1e50;
+ for(i=0;i<3;i++)
+ {if(i==iUK)continue;
+ if(D[i]>max)max=D[i];
+ }
+ D[iUK]=max;
+ }
+ if(dK==1)
+ {//through similar motivation as above, if we have just one known distance
+ //we set the other two distances equal to it
+ for(i=0;i<3;i++)
+ {if(i==iK)continue;
+ D[i]=D[iK];
+ }
+ }
+ if(dK==0)
+ {//no distances are known, we just set them to 1
+ for(i=0;i<3;i++)
+ {D[i]=1;
+ }
+ }
+ edge_length[*N*2 - 4] = (D[0] + D[1] - D[2])/2;
+ edge_length[*N*2 - 5] = (D[0] + D[2] - D[1])/2;
+ edge_length[*N*2 - 6] = (D[2] + D[1] - D[0])/2;
+}
diff --git a/src/pic.c b/src/pic.c
new file mode 100644
index 0000000..c06310c
--- /dev/null
+++ b/src/pic.c
@@ -0,0 +1,37 @@
+/* pic.c 2006-11-13 */
+
+/* Copyright 2006 Emmanuel Paradis */
+
+/* This file is part of the R-package `ape'. */
+/* See the file ../COPYING for licensing issues. */
+
+#include <R.h>
+
+void C_pic(int *ntip, int *nnode, int *edge1, int *edge2,
+ double *edge_len, double *phe, double *contr,
+ double *var_contr, int *var, int *scaled)
+{
+/* The tree must be in pruningwise order */
+ int anc, d1, d2, ic, i, j, k;
+ double sumbl;
+
+ for (i = 0; i < *ntip * 2 - 3; i += 2) {
+ j = i + 1;
+ anc = edge1[i];
+ d1 = edge2[i] - 1;
+ d2 = edge2[j] - 1;
+ sumbl = edge_len[i] + edge_len[j];
+ ic = anc - *ntip - 1;
+ contr[ic] = phe[d1] - phe[d2];
+ if (*scaled) contr[ic] = contr[ic]/sqrt(sumbl);
+ if (*var) var_contr[ic] = sumbl;
+ phe[anc - 1] = (phe[d1]*edge_len[j] + phe[d2]*edge_len[i])/sumbl;
+ /* find the edge where `anc' is a descendant (except if at the root):
+ it is obviously below the j'th edge */
+ if (j != *ntip * 2 - 3) {
+ k = j + 1;
+ while (edge2[k] != anc) k++;
+ edge_len[k] = edge_len[k] + edge_len[i]*edge_len[j]/sumbl;
+ }
+ }
+}
diff --git a/src/plot_phylo.c b/src/plot_phylo.c
new file mode 100644
index 0000000..b63d995
--- /dev/null
+++ b/src/plot_phylo.c
@@ -0,0 +1,105 @@
+/* plot_phylo.c (2014-03-05) */
+
+/* Copyright 2004-2014 Emmanuel Paradis */
+
+/* This file is part of the R-package `ape'. */
+/* See the file ../COPYING for licensing issues. */
+
+#include <R.h>
+
+void node_depth_edgelength(int *ntip, int *nnode, int *edge1, int *edge2,
+ int *nedge, double *edge_length, double *xx)
+{
+ int i;
+
+ /* We do a preorder tree traversal starting from the bottom */
+ /* of `edge'; we assume `xx' has 0 for the root and the tree */
+ /* is in pruningwise order. */
+ for (i = *nedge - 1; i >= 0; i--)
+ xx[edge2[i] - 1] = xx[edge1[i] - 1] + edge_length[i];
+}
+
+void node_depth(int *ntip, int *nnode, int *e1, int *e2,
+ int *nedge, double *xx, int *method)
+/* method == 1: the node depths are proportional to the number of tips
+ method == 2: the node depths are evenly spaced */
+{
+ int i;
+
+ /* First set the coordinates for all tips */
+ for (i = 0; i < *ntip; i++) xx[i] = 1;
+
+ /* Then compute recursively for the nodes; we assume `xx' has */
+ /* been initialized with 0's which is true if it has been */
+ /* created in R (the tree must be in pruningwise order) */
+ if (*method == 1) {
+ for (i = 0; i < *nedge; i++)
+ xx[e1[i] - 1] = xx[e1[i] - 1] + xx[e2[i] - 1];
+ } else { /* *method == 2 */
+ for (i = 0; i < *nedge; i++) {
+ /* if a value > 0 has already been assigned to the ancestor
+ node of this edge, check that the descendant node is not
+ at the same level or more */
+ if (xx[e1[i] - 1])
+ if (xx[e1[i] - 1] >= xx[e2[i] - 1] + 1) continue;
+ xx[e1[i] - 1] = xx[e2[i] - 1] + 1;
+ }
+ }
+}
+
+void node_height(int *ntip, int *nnode, int *edge1, int *edge2,
+ int *nedge, double *yy)
+{
+ int i, n;
+ double S;
+
+ /* The coordinates of the tips have been already computed */
+
+ S = 0;
+ n = 0;
+ for (i = 0; i < *nedge - 1; i++) {
+ S += yy[edge2[i] - 1];
+ n++;
+ if (edge1[i + 1] != edge1[i]) {
+ yy[edge1[i] - 1] = S/n;
+ S = 0;
+ n = 0;
+ }
+ }
+ /* do the last edge */
+ /* i = *nedge - 1; */
+ S += yy[edge2[i] - 1];
+ n++;
+ yy[edge1[i] - 1] = S/n;
+}
+
+void node_height_clado(int *ntip, int *nnode, int *edge1, int *edge2,
+ int *nedge, double *xx, double *yy)
+{
+ int i, j, n;
+ double S;
+
+ i = 1;
+ node_depth(ntip, nnode, edge1, edge2, nedge, xx, &i);
+
+ /* The coordinates of the tips have been already computed */
+
+ S = 0;
+ n = 0;
+ for (i = 0; i < *nedge - 1; i++) {
+ j = edge2[i] - 1;
+ S += yy[j] * xx[j];
+ n += xx[j];
+ if (edge1[i + 1] != edge1[i]) {
+ yy[edge1[i] - 1] = S/n;
+ S = 0;
+ n = 0;
+ }
+ }
+ /* do the last edge */
+ /* i = *nedge - 1; */
+ j = edge2[i] - 1;
+ S += yy[j] * xx[j];
+ n += xx[j];
+ yy[edge1[i] - 1] = S/n;
+}
diff --git a/src/rTrait.c b/src/rTrait.c
new file mode 100644
index 0000000..2960ac1
--- /dev/null
+++ b/src/rTrait.c
@@ -0,0 +1,39 @@
+/* rTrait.c 2011-06-25 */
+
+/* Copyright 2010-2011 Emmanuel Paradis */
+
+/* This file is part of the R-package `ape'. */
+/* See the file ../COPYING for licensing issues. */
+
+#include <R.h>
+
+void C_rTraitCont(int *model, int *Nedge, int *edge1, int *edge2, double *el,
+ double *sigma, double *alpha, double *theta, double *x)
+{
+/* The tree must be in pruningwise order */
+ int i;
+ double alphaT, M, S;
+
+ switch(*model) {
+ case 1 : for (i = *Nedge - 1; i >= 0; i--) {
+ GetRNGstate();
+ x[edge2[i]] = x[edge1[i]] + sqrt(el[i]) * sigma[i] * norm_rand();
+ PutRNGstate();
+ }
+ break;
+ case 2 : for (i = *Nedge - 1; i >= 0; i--) {
+ if (alpha[i]) {
+ alphaT = alpha[i] * el[i];
+ M = exp(-alphaT);
+ S = sigma[i] * sqrt((1 - exp(-2 * alphaT))/(2 * alpha[i]));
+ } else { /* same than if (alpha[i] == 0) */
+ M = 1;
+ S = sqrt(el[i]) * sigma[i];
+ }
+ GetRNGstate();
+ x[edge2[i]] = x[edge1[i]] * M + theta[i] * (1 - M) + S * norm_rand();
+ PutRNGstate();
+ }
+ break;
+ }
+}
diff --git a/src/read_dna.c b/src/read_dna.c
new file mode 100644
index 0000000..1edc4f8
--- /dev/null
+++ b/src/read_dna.c
@@ -0,0 +1,150 @@
+/* read_dna.c 2014-03-05 */
+
+/* Copyright 2013-2014 Emmanuel Paradis */
+
+/* This file is part of the R-package `ape'. */
+/* See the file ../COPYING for licensing issues. */
+
+#include <R.h>
+#include <Rinternals.h>
+
+// The initial code defining and initialising the translation table:
+//
+// for (i = 0; i < 122; i++) tab_trans[i] = 0x00;
+//
+// tab_trans[65] = 0x88; /* A */
+// tab_trans[71] = 0x48; /* G */
+// tab_trans[67] = 0x28; /* C */
+// tab_trans[84] = 0x18; /* T */
+// tab_trans[82] = 0xc0; /* R */
+// tab_trans[77] = 0xa0; /* M */
+// tab_trans[87] = 0x90; /* W */
+// tab_trans[83] = 0x60; /* S */
+// tab_trans[75] = 0x50; /* K */
+// tab_trans[89] = 0x30; /* Y */
+// tab_trans[86] = 0xe0; /* V */
+// tab_trans[72] = 0xb0; /* H */
+// tab_trans[68] = 0xd0; /* D */
+// tab_trans[66] = 0x70; /* B */
+// tab_trans[78] = 0xf0; /* N */
+//
+// tab_trans[97] = 0x88; /* a */
+// tab_trans[103] = 0x48; /* g */
+// tab_trans[99] = 0x28; /* c */
+// tab_trans[116] = 0x18; /* t */
+// tab_trans[114] = 0xc0; /* r */
+// tab_trans[109] = 0xa0; /* m */
+// tab_trans[119] = 0x90; /* w */
+// tab_trans[115] = 0x60; /* s */
+// tab_trans[107] = 0x50; /* k */
+// tab_trans[121] = 0x30; /* y */
+// tab_trans[118] = 0xe0; /* v */
+// tab_trans[104] = 0xb0; /* h */
+// tab_trans[100] = 0xd0; /* d */
+// tab_trans[98] = 0x70; /* b */
+// tab_trans[110] = 0xf0; /* n */
+//
+// tab_trans[45] = 0x04; /* - */
+// tab_trans[63] = 0x02; /* ? */
+
+static const unsigned char tab_trans[] = {
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 0-9 */
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 10-19 */
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 20-29 */
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 30-39 */
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x04, 0x00, 0x00, 0x00, 0x00, /* 40-49 */
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 50-59 */
+ 0x00, 0x00, 0x00, 0x02, 0x00, 0x88, 0x70, 0x28, 0xd0, 0x00, /* 60-69 */
+ 0x00, 0x48, 0xb0, 0x00, 0x00, 0x50, 0x00, 0xa0, 0xf0, 0x00, /* 70-79 */
+ 0x00, 0x00, 0xc0, 0x60, 0x18, 0x00, 0xe0, 0x90, 0x00, 0x30, /* 80-89 */
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x88, 0x70, 0x28, /* 90-99 */
+ 0xd0, 0x00, 0x00, 0x48, 0xb0, 0x00, 0x00, 0x50, 0x00, 0xa0, /* 100-109 */
+ 0xf0, 0x00, 0x00, 0x00, 0xc0, 0x60, 0x18, 0x00, 0xe0, 0x90, /* 110-119 */
+ 0x00, 0x30, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 120-129 */
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 130-139 */
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 140-149 */
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 150-159 */
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 160-169 */
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 170-179 */
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 180-189 */
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 190-199 */
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 200-209 */
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 210-219 */
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 220-229 */
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 230-239 */
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, 0x00, /* 240-249 */
+ 0x00, 0x00, 0x00, 0x00, 0x00, 0x00}; /* 250-255 */
+
+static const unsigned char hook = 0x3e;
+static const unsigned char lineFeed = 0x0a;
+/* static const unsigned char space = 0x20; */
+
+SEXP rawStreamToDNAbin(SEXP x)
+{
+ int N, i, j, k, n, startOfSeq;
+ unsigned char *xr, *rseq, *buffer, tmp;
+ SEXP obj, nms, seq;
+
+ PROTECT(x = coerceVector(x, RAWSXP));
+ N = LENGTH(x);
+ xr = RAW(x);
+
+/* do a 1st pass to find the number of sequences
+
+ this code should be robust to '>' present inside
+ a label or in the header text before the sequences */
+
+ n = j = 0; /* use j as a flag */
+ if (xr[0] == hook) {
+ j = 1;
+ startOfSeq = 0;
+ }
+ i = 1;
+ for (i = 1; i < N; i++) {
+ if (j && xr[i] == lineFeed) {
+ n++;
+ j = 0;
+ } else if (xr[i] == hook) {
+ if (!n) startOfSeq = i;
+ j = 1;
+ }
+ }
+
+ PROTECT(obj = allocVector(VECSXP, n));
+ PROTECT(nms = allocVector(STRSXP, n));
+
+/* Refine the way the size of the buffer is set? */
+ buffer = (unsigned char *)R_alloc(N, sizeof(unsigned char *));
+
+ i = startOfSeq;
+ j = 0; /* gives the index of the sequence */
+ while (i < N) {
+ /* 1st read the label... */
+ i++;
+ k = 0;
+ while (xr[i] != lineFeed) buffer[k++] = xr[i++];
+ buffer[k] = '\0';
+ SET_STRING_ELT(nms, j, mkChar((char *)buffer));
+ /* ... then read the sequence */
+ n = 0;
+ while (i < N && xr[i] != hook) {
+ tmp = tab_trans[xr[i++]];
+/* If we are sure that the FASTA file is correct (ie, the sequence on
+ a single line and only the IUAPC code (plus '-' and '?') is used,
+ then the following check would not be needed; additionally the size
+ of tab_trans could be restriced to 0-121. This check has the
+ advantage that all invalid characters are simply ignored without
+ causing error -- except if '>' occurs in the middle of a sequence. */
+ if (tmp) buffer[n++] = tmp;
+ }
+ PROTECT(seq = allocVector(RAWSXP, n));
+ rseq = RAW(seq);
+ for (k = 0; k < n; k++) rseq[k] = buffer[k];
+ SET_VECTOR_ELT(obj, j, seq);
+ UNPROTECT(1);
+ j++;
+ }
+ setAttrib(obj, R_NamesSymbol, nms);
+ UNPROTECT(3);
+ return obj;
+}
diff --git a/src/reorder_phylo.c b/src/reorder_phylo.c
new file mode 100644
index 0000000..c76fb27
--- /dev/null
+++ b/src/reorder_phylo.c
@@ -0,0 +1,152 @@
+/* reorder_phylo.c 2012-09-03 */
+
+/* Copyright 2008-2012 Emmanuel Paradis */
+
+/* This file is part of the R-package `ape'. */
+/* See the file ../COPYING for licensing issues. */
+
+#include <R.h>
+
+static int iii;
+
+void foo_reorder(int node, int n, int m, int *e1, int *e2, int *neworder, int *L, int *pos)
+{
+ int i = node - n - 1, j, k;
+
+/* 'i' is the C index corresponding to 'node' */
+
+ for (j = 0; j < pos[i]; j++) {
+ k = L[i + m * j];
+ neworder[iii++] = k + 1;
+ if (e2[k] > n) /* is it an internal edge? */
+ foo_reorder(e2[k], n, m, e1, e2, neworder, L, pos);
+ }
+}
+
+void bar_reorder(int node, int n, int m, int *e1, int *e2, int *neworder, int *L, int *pos)
+{
+ int i = node - n - 1, j, k;
+
+ for (j = pos[i] - 1; j >= 0; j--)
+ neworder[iii--] = L[i + m * j] + 1;
+
+ for (j = 0; j < pos[i]; j++) {
+ k = e2[L[i + m * j]];
+ if (k > n)
+ bar_reorder(k, n, m, e1, e2, neworder, L, pos);
+ }
+}
+
+void neworder_phylo(int *n, int *e1, int *e2, int *N, int *neworder, int *order)
+/* n: nb of tips
+ m: nb of nodes
+ N: nb of edges */
+{
+ int i, j, k, *L, *pos, m = *N - *n + 1, degrmax = *n - m + 1;
+
+/* degrmax is the largest value that a node degree can be */
+
+/* L is a 1-d array storing, for each node, the C indices of the rows of
+ the edge matrix where the node is ancestor (i.e., present in the 1st
+ column). It is used in the same way than a matrix (which is actually
+ a vector) is used in R as a 2-d structure. */
+
+ L = (int*)R_alloc(m * degrmax, sizeof(int));
+
+/* pos gives the position for each 'row' of L, that is the number of elements
+ which have already been stored for that 'row'. */
+
+ pos = (int*)R_alloc(m, sizeof(int));
+ memset(pos, 0, m * sizeof(int));
+
+/* we now go down along the edge matrix */
+
+ for (i = 0; i < *N; i++) {
+ k = e1[i] - *n - 1; /* k is the 'row' index in L corresponding to node e1[i] */
+ j = pos[k]; /* the current 'column' position corresponding to k */
+ pos[k]++; /* increment in case the same node is found in another row of the edge matrix */
+ L[k + m * j] = i;
+ }
+
+/* L is now ready: we can start the recursive calls. */
+/* We start with the root 'n + 1': its index will be changed into
+ the corresponding C index inside the recursive function. */
+
+ switch(*order) {
+ case 1 : iii = 0;
+ foo_reorder(*n + 1, *n, m, e1, e2, neworder, L, pos);
+ break;
+ case 2 : iii = *N - 1;
+ bar_reorder(*n + 1, *n, m, e1, e2, neworder, L, pos);
+ break;
+ }
+}
+
+#define DO_NODE_PRUNING\
+ /* go back down in `edge' to set `neworder' */\
+ for (j = 0; j <= i; j++) {\
+ /* if find the edge where `node' is */\
+ /* the descendant, make as ready */\
+ if (edge2[j] == node) ready[j] = 1;\
+ if (edge1[j] != node) continue;\
+ neworder[nextI] = j + 1;\
+ ready[j] = 0; /* mark the edge as done */\
+ nextI++;\
+ }
+
+void neworder_pruningwise(int *ntip, int *nnode, int *edge1,
+ int *edge2, int *nedge, int *neworder)
+{
+ int *ready, *Ndegr, i, j, node, nextI, n;
+
+ nextI = *ntip + *nnode;
+ Ndegr = (int*)R_alloc(nextI, sizeof(int));
+ memset(Ndegr, 0, nextI*sizeof(int));
+ for (i = 0; i < *nedge; i++) (Ndegr[edge1[i] - 1])++;
+
+ ready = (int*)R_alloc(*nedge, sizeof(int));
+
+ /* `ready' indicates whether an edge is ready to be */
+ /* collected; only the terminal edges are initially ready */
+ for (i = 0; i < *nedge; i++)
+ ready[i] = (edge2[i] <= *ntip) ? 1 : 0;
+
+ /* `n' counts the number of times a node has been seen. */
+ /* This algo will work if the tree is in cladewise order, */
+ /* so that the nodes of "cherries" will be contiguous in `edge'. */
+ n = 0;
+ nextI = 0;
+ while (nextI < *nedge - Ndegr[*ntip]) {
+ for (i = 0; i < *nedge; i++) {
+ if (!ready[i]) continue;
+ if (!n) {
+ /* if found an edge ready, initialize `node' and start counting */
+ node = edge1[i];
+ n = 1;
+ } else { /* else counting has already started */
+ if (edge1[i] == node) n++;
+ else {
+ /* if the node has changed we checked that all edges */
+ /* from `node' have been found */
+ if (n == Ndegr[node - 1]) {
+ DO_NODE_PRUNING
+ }
+ /* in all cases reset `n' and `node' and carry on */
+ node = edge1[i];
+ n = 1;
+ }
+ } /* go to the next edge */
+ /* if at the end of `edge', check that we can't do a node */
+ if (n == Ndegr[node - 1]) {
+ DO_NODE_PRUNING
+ n = 0;
+ }
+ }
+ }
+ for (i = 0; i < *nedge; i++) {
+ if (!ready[i]) continue;
+ neworder[nextI] = i + 1;
+ nextI++;
+ }
+}
+
diff --git a/src/treePop.c b/src/treePop.c
new file mode 100644
index 0000000..b27c05d
--- /dev/null
+++ b/src/treePop.c
@@ -0,0 +1,242 @@
+/* treePop.c 2013-09-19 */
+
+/* Copyright 2011-2013 Andrei-Alin Popescu */
+
+/* This file is part of the R-package `ape'. */
+/* See the file ../COPYING for licensing issues. */
+
+#include <math.h>
+#include <R.h>
+#include <stdint.h>
+
+int lsb(uint8_t * a)
+{
+ int i = 0;
+ while (a[i] == 0) i++; /* count number of elements = 0 */
+
+ int b = 7;
+ while ((a[i] & (1 << b)) == 0) b--;
+
+ return i*8 + (8 - b);
+}
+
+short count_bits(uint8_t n)
+{
+ short c; /* c accumulates the total bits set in v */
+ for (c = 0; n; c++)
+ n &= n - 1; /* clear the least significant bit set */
+ return c;
+}
+
+/* Print n as a binary number */
+/*void printbits(uint8_t n)
+{
+ uint8_t i;
+ i = 1 << (sizeof(n) * 8 - 1);
+
+ while (i > 0) {
+ if (n & i) Rprintf("1");
+ else Rprintf("0");
+ i >>= 1;
+ }
+}*/
+
+uint8_t* setdiff(uint8_t* x, uint8_t *y, int nrow) //x-y
+{
+ int i = 0;
+ uint8_t* ret = (uint8_t*)R_alloc(nrow, sizeof(uint8_t));
+ for (i = 0; i < nrow; i++) {
+ uint8_t tmp = (~y[i]);
+
+/* Rprintf("x[%i]=",i);
+ printbits(x[i]);
+ Rprintf("\n");
+ Rprintf("y[%i]=",i);
+ printbits(y[i]);
+ Rprintf("\n");
+ Rprintf("tmp=\n");
+ printbits(tmp);
+ Rprintf("\n"); */
+
+ ret[i] = (x[i] & tmp);
+ }
+ return ret;
+}
+
+void C_treePop(int* splits, double* w,int* ncolp,int* np, int* ed1, int* ed2, double* edLen)
+ {
+ int n=*np;
+ int ncol=*ncolp;
+ int nrow=ceil(n/(double)8);
+ uint8_t split[nrow][ncol];
+ int i=0,j=0;
+
+ /*Rprintf("n=%i nrow=%i ncol=%i\n",n,nrow,ncol);
+ Rprintf("got\n");
+ for(i=0;i<ncol;i++)
+ {
+ for(j=0;j<nrow;j++)
+ {
+ Rprintf("%i ",splits[i*nrow+j]);
+ }
+ Rprintf("\n");
+ }*/
+
+ for(i=0;i<ncol;i++)
+ {
+ for(j=0;j<nrow;j++)
+ {
+ split[j][i]=(uint8_t)splits[i*nrow+j];
+ }
+ }
+ /*Rprintf("short-ed\n");
+ for(i=0;i<nrow;i++)
+ {
+ for(j=0;j<ncol;j++)
+ {
+ printbits(split[i][j]);
+ Rprintf("\n");
+ }
+ Rprintf("\n");
+ }*/
+
+ uint8_t vlabs[2*n-1][nrow];
+ for(i=0;i<nrow-1;i++)
+ {
+ vlabs[n+1][i]=255;
+ }
+ vlabs[n+1][nrow-1]=~((uint8_t)(pow(2,8-(n%8))-1));
+
+ int bitt_count[ncol];
+ uint8_t msk=~((uint8_t)(pow(2,8-(n%8))-1));//mask out trailing bits
+ //printbits(msk);
+ for(i=0;i<ncol;i++)
+ {
+ int sum=0;
+ for(j=0;j<nrow-1;j++)
+ { //Rprintf("countbits(%i)=%i ",split[j][i],count_bits(split[j][i]));
+ sum+=count_bits(split[j][i]);
+ }
+ uint8_t bt=split[nrow-1][i];
+ bt&=msk;
+ //Rprintf("countbits(%i)=%i ",bt,count_bits(bt));
+ sum+=count_bits(bt);
+ // Rprintf("bit_count[%i]=%i ",i,sum);
+ //Rprintf("\n");
+ if(sum>n/2)
+ {
+ for(j=0;j<nrow;j++)
+ {
+ split[j][i]=~split[j][i];
+ }
+ split[nrow-1][i]&=msk;
+ sum=n-sum;
+ }
+ bitt_count[i]=sum;
+ }
+ int ind[ncol];
+ for(i=0;i<ncol;i++)
+ {
+ ind[i]=i;
+ }
+
+ for(i=0;i<ncol-1;i++)
+ {
+ for(j=i+1;j<ncol;j++)
+ {
+ if(bitt_count[i]<bitt_count[j])
+ { int aux;
+ aux=bitt_count[i];
+ bitt_count[i]=bitt_count[j];
+ bitt_count[j]=aux;
+ aux=ind[i];
+ ind[i]=ind[j];
+ ind[j]=aux;
+ }
+ }
+ }
+ int nNodes=n+1;
+ int numEdges=0;
+ for(i=0;i<ncol;i++)
+ { int ii=0;
+ //Rprintf("split %i\n",i);
+ uint8_t sp[nrow];
+ for(ii=0;ii<nrow;ii++)
+ {//copy split into sp
+ sp[ii]=split[ii][ind[i]];
+ }
+ //search for node whose labellings are a superset of the current split
+ for(j=n+1;j<=nNodes;j++)
+ {
+ uint8_t vl[nrow];
+ for(ii=0;ii<nrow;ii++)
+ {//copy vertex labeling into vl
+ vl[ii]=vlabs[j][ii];
+ }
+ int sw=0;//print current split
+ for(ii=0;ii<nrow;ii++)
+ {
+ //Rprintf("sp[%i]= ",ii);
+ //printbits(sp[ii]);
+ }
+ //Rprintf("\n");//print current label
+ for(ii=0;ii<nrow;ii++)
+ {
+ // Rprintf("vl[%i]= ",ii);
+ // printbits(vl[ii]);
+ }
+ //Rprintf("\n");
+ uint8_t* sd=setdiff(sp,vl,nrow);
+ //print the setdifference
+ for(ii=0;ii<nrow/*-1*/;ii++)
+ { //Rprintf("sd[%i]=%i ",ii,sd[ii]);
+ if(sd[ii]!=0)sw=1;
+ }
+ // Rprintf("\n");
+
+ sd[nrow-1]&=msk;
+ //Rprintf("sd[%i]=%i ",nrow-1,sd[nrow-1]);
+ if(sd[nrow-1]!=0)sw=1;
+ if(sw==0)//setdiff==0, so we split vertex j
+ { // Rprintf("vertex %i",j);
+ ed1[numEdges]=j;
+
+ int gn=-1;
+ // Rprintf("bitt_count[%i]=%i\n",i,bitt_count[i]);
+ if(bitt_count[i]>=2)//if not trivial split
+ {nNodes++;
+ gn=nNodes;
+ }
+ else
+ {
+ gn=lsb(sp);
+ }
+ // Rprintf("gn=%i\n",gn);
+ ed2[numEdges]=gn;
+ edLen[numEdges]=w[ind[i]];
+ numEdges++;
+ uint8_t* sdd=setdiff(vl,sp,nrow);
+ for(ii=0;ii<nrow;ii++)//label current vertex byset difference
+ //and new vertex by actual split
+ {
+ vlabs[j][ii]=sdd[ii];
+ vlabs[gn][ii]=sp[ii];
+ }
+ //print new labels
+ // Rprintf("new v\n");
+ int jj=0;
+ for(ii=1;ii<=nNodes;ii++)
+ {//Rprintf("node %i : ",ii);
+ for(jj=0;jj<nrow;jj++)
+ {
+ //printbits(vlabs[ii][jj]);
+ // Rprintf(" ");
+ }
+ // Rprintf("\n");
+ }
+ break;
+ }
+
+ }
+ }
+ }
diff --git a/src/tree_build.c b/src/tree_build.c
new file mode 100644
index 0000000..5ac3f86
--- /dev/null
+++ b/src/tree_build.c
@@ -0,0 +1,198 @@
+/* tree_build.c 2011-06-23 */
+
+/* Copyright 2008-2011 Emmanuel Paradis */
+
+/* This file is part of the R-package `ape'. */
+/* See the file ../COPYING for licensing issues. */
+
+#include <R.h>
+#include <Rinternals.h>
+
+static int str2int(char *x, int n)
+{
+ int i, k = 1, ans = 0;
+
+ for (i = n - 1; i >= 0; i--, k *= 10)
+ ans += ((int)x[i] - 48) * k;
+
+ return ans;
+}
+
+void extract_portion_Newick(const char *x, int a, int b, char *y)
+{
+ int i, j;
+
+ for (i = a, j = 0; i <= b; i++, j++) y[j] = x[i];
+
+ y[j] = '\0';
+}
+
+void decode_terminal_edge_token(const char *x, int a, int b, int *node, double *w)
+{
+ int co = a;
+ char *endstr, str[100];
+
+ while (x[co] != ':') co++;
+
+ extract_portion_Newick(x, a, co - 1, str);
+ *node = str2int(str, co - a);
+ extract_portion_Newick(x, co + 1, b, str);
+ *w = R_strtod(str, &endstr);
+}
+
+void decode_internal_edge(const char *x, int a, int b, char *lab, double *w)
+{
+ int co = a;
+ char *endstr, str[100];
+
+ while (x[co] != ':') co++;
+
+ if (a == co) lab[0] = '\0'; /* if no node label */
+ else extract_portion_Newick(x, a, co - 1, lab);
+
+ extract_portion_Newick(x, co + 1, b, str);
+ *w = R_strtod(str, &endstr);
+}
+
+#define ADD_INTERNAL_EDGE \
+ e[j] = curnode; \
+ e[j + nedge] = curnode = ++node; \
+ stack_internal[k++] = j; \
+ j++
+
+#define ADD_TERMINAL_EDGE \
+ e[j] = curnode; \
+ decode_terminal_edge_token(x, pr + 1, ps - 1, &tmpi, &tmpd); \
+ e[j + nedge] = tmpi; \
+ el[j] = tmpd; \
+ j++
+
+#define GO_DOWN \
+ decode_internal_edge(x, ps + 1, pt - 1, lab, &tmpd); \
+ SET_STRING_ELT(node_label, curnode - 1 - ntip, mkChar(lab)); \
+ l = stack_internal[--k]; \
+ el[l] = tmpd; \
+ curnode = e[l]
+
+SEXP treeBuildWithTokens(SEXP nwk)
+{
+ const char *x;
+ int n, i, ntip = 1, nnode = 0, nedge, *e, curnode, node, j, *skeleton, nsk = 0, ps, pr, pt, tmpi, l, k, stack_internal[10000];
+ double *el, tmpd;
+ char lab[512];
+ SEXP edge, edge_length, Nnode, node_label, phy;
+
+ PROTECT(nwk = coerceVector(nwk, STRSXP));
+ x = CHAR(STRING_ELT(nwk, 0));
+ n = strlen(x);
+ skeleton = (int *)R_alloc(n, sizeof(int *));
+
+/* first pass on the Newick string to localize parentheses and commas */
+ for (i = 0; i < n; i++) {
+ if (x[i] == '(') {
+ skeleton[nsk] = i;
+ nsk++;
+ continue;
+ }
+ if (x[i] == ',') {
+ skeleton[nsk] = i;
+ nsk++;
+ ntip++;
+ continue;
+ }
+ if (x[i] == ')') {
+ skeleton[nsk] = i;
+ nsk++;
+ nnode++;
+ }
+ }
+
+ nedge = ntip + nnode - 1;
+
+ PROTECT(Nnode = allocVector(INTSXP, 1));
+ PROTECT(edge = allocVector(INTSXP, nedge*2));
+ PROTECT(edge_length = allocVector(REALSXP, nedge));
+ PROTECT(node_label = allocVector(STRSXP, nnode));
+ INTEGER(Nnode)[0] = nnode;
+
+ e = INTEGER(edge);
+ el = REAL(edge_length);
+
+ curnode = node = ntip + 1;
+ k = j = 0;
+/* j: index of the current position in the edge matrix */
+/* k: index of the current position in stack_internal */
+/* stack_internal is a simple array storing the indices of the
+ successive internal edges from the root; it's a stack so it is
+ incremented every time an internal edge is added, and decremented
+ every GO_DOWN step. This makes easy to the index of the
+ subtending edge. */
+
+/* second pass on the Newick string to build the "phylo" object elements */
+ for (i = 1; i < nsk - 1; i++) {
+ ps = skeleton[i];
+// Rprintf(""); /* <- again !!!! */
+ if (x[ps] == '(') {
+ ADD_INTERNAL_EDGE;
+ continue;
+ }
+ pr = skeleton[i - 1];
+ if (x[ps] == ',') {
+ if (x[pr] != ')') {
+ /* !!! accolades indispensables !!! */
+ ADD_TERMINAL_EDGE;
+ }
+ continue;
+ }
+ if (x[ps] == ')') {
+ pt = skeleton[i + 1]; // <- utile ???
+ if (x[pr] == ',') {
+ ADD_TERMINAL_EDGE;
+ GO_DOWN;
+ continue;
+ }
+ if (x[pr] == ')') {
+ GO_DOWN;
+ }
+ }
+ }
+
+ pr = skeleton[nsk - 2];
+ ps = skeleton[nsk - 1];
+/* is the last edge terminal? */
+ if (x[pr] == ',' && x[ps] == ')') {
+ ADD_TERMINAL_EDGE;
+ }
+
+/* is there a root edge and/or root label? */
+ if (ps < n - 2) {
+ i = ps + 1;
+ while (i < n - 2 && x[i] != ':') i++;
+ if (i < n - 2) {
+ PROTECT(phy = allocVector(VECSXP, 5));
+ SEXP root_edge;
+ decode_internal_edge(x, ps + 1, n - 2, lab, &tmpd);
+ PROTECT(root_edge = allocVector(REALSXP, 1));
+ REAL(root_edge)[0] = tmpd;
+ SET_VECTOR_ELT(phy, 4, root_edge);
+ UNPROTECT(1);
+ SET_STRING_ELT(node_label, 0, mkChar(lab));
+ } else {
+ extract_portion_Newick(x, ps + 1, n - 2, lab);
+ SET_STRING_ELT(node_label, 0, mkChar(lab));
+ PROTECT(phy = allocVector(VECSXP, 4));
+ }
+ } else PROTECT(phy = allocVector(VECSXP, 4));
+
+ SET_VECTOR_ELT(phy, 0, edge);
+ SET_VECTOR_ELT(phy, 1, edge_length);
+ SET_VECTOR_ELT(phy, 2, Nnode);
+ SET_VECTOR_ELT(phy, 3, node_label);
+
+ UNPROTECT(6);
+ return phy;
+}
+
+#undef ADD_INTERNAL_EDGE
+#undef ADD_TERMINAL_EDGE
+#undef GO_DOWN
diff --git a/src/tree_phylo.c b/src/tree_phylo.c
new file mode 100644
index 0000000..17badca
--- /dev/null
+++ b/src/tree_phylo.c
@@ -0,0 +1,79 @@
+/* tree_phylo.c 2012-04-30 */
+
+/* Copyright 2008-2012 Emmanuel Paradis */
+
+/* This file is part of the R-package `ape'. */
+/* See the file ../COPYING for licensing issues. */
+
+#include "me.h"
+
+static int curnod, curtip, iedge;
+
+#define DO_EDGE\
+ el[iedge] = EDGE->distance;\
+ if (leaf(EDGE->head)) {\
+ edge2[iedge] = curtip;\
+ ilab[curtip - 1] = EDGE->head->label;\
+ iedge++;\
+ curtip++;\
+ } else {\
+ edge2[iedge] = curnod;\
+ iedge++;\
+ subtree2phylo(EDGE->head, edge1, edge2, el, ilab);\
+ }
+
+int leaf(node *v)
+{
+ int count = 0;
+ if (NULL != v->parentEdge) count++;
+ if (NULL != v->leftEdge) count++;
+ if (NULL != v->rightEdge) count++;
+ if (NULL != v->middleEdge) count++;
+ if (count > 1) return(0);
+ return(1);
+}
+
+void subtree2phylo(node *parent, int *edge1, int *edge2, double *el, int *ilab)
+{
+ edge *EDGE; int localnode;
+
+ EDGE = parent->leftEdge;
+/* 'localnode' keeps a copy of the node ancestor # between
+ the two (recursive) calls of subtree2phylo */
+ localnode = edge1[iedge] = curnod;
+ curnod++;
+ DO_EDGE
+
+ EDGE = parent->rightEdge;
+ edge1[iedge] = localnode;
+ DO_EDGE
+}
+
+/*
+transforms a 'tree' struc of pointers into an object of class "phylo"
+assumes the tree is unrooted and binary, so there are 2n - 3 edges
+assumes labels are int
+*/
+void tree2phylo(tree *T, int *edge1, int *edge2, double *el, int *ilab, int n)
+{
+ edge *EDGE;
+ curnod = n + 1; /* the root for ape */
+
+/* there's in fact only one edge from the "root" which is
+ a tip in ape's terminology (i.e., a node of degree 1) */
+
+ EDGE = T->root->leftEdge;
+ edge1[0] = curnod;
+ edge2[0] = 1; /* <- the 1st tip */
+ ilab[0] = T->root->label;
+ el[0] = EDGE->distance;
+ /* now can initialize these two: */
+ curtip = 2; /* <- the 2nd tip */
+ iedge = 1; /* <- the 2nd edge */
+ edge1[iedge] = curnod;
+
+/* 'T->root->leftEdge->head' is the root for ape,
+ so don't need to test if it's a leaf */
+
+ subtree2phylo(EDGE->head, edge1, edge2, el, ilab);
+}
diff --git a/src/triangMtd.c b/src/triangMtd.c
new file mode 100644
index 0000000..872b79d
--- /dev/null
+++ b/src/triangMtd.c
@@ -0,0 +1,357 @@
+/* triangMtd.c 2012-04-02 */
+
+/* Copyright 2011-2012 Andrei-Alin Popescu */
+
+/* This file is part of the R-package `ape'. */
+/* See the file ../COPYING for licensing issues. */
+
+/*
+ * leafs labelled 1 to n. root labelled n+1. other nodes labelled n+1 to m
+ */
+
+#include <R.h>
+
+int give_indexx(int i, int j, int n)
+{ if (i == j) return 0;
+ if (i > j) return(n*(j - 1) - j*(j - 1)/2 + i - j - 1);
+ else return(n*(i - 1) - i*(i - 1)/2 + j - i - 1);
+}
+
+int pred(int k, int* ed1, int* ed2, int numEdges)
+/* find the predecesor of vertex k */
+{
+ int i = 0;
+ for (i = 0; i <= numEdges; i++)
+ if (ed2[i] == k) return ed1[i];
+ return -1;
+}
+
+int* getPathBetween(int x, int y, int n, int* ed1, int* ed2, int numEdges)
+//get the path between vertices x and y in an array ord.
+//ord[i]=j means that we go between i and j on the path between x and y
+ { int i=0;
+ int k=x;
+ int ch[2*n-1];//ch[i]==1 implies {k,pred(k)} on path between x and y
+ for(i=1;i<=2*n-2;i++)
+ {ch[i]=0;
+ }
+
+ while(k!=n+1)
+ {
+ ch[k]=1;
+ k=pred(k,ed1,ed2,numEdges);
+ }
+ k=y;
+
+ while(k!=n+1)
+ {
+ ch[k]++;
+ k=pred(k,ed1,ed2,numEdges);
+ }
+ int *ord=(int*)malloc(sizeof(int)*(2*n-1));
+ //starting from x, fill ord
+
+
+ int p=x;
+
+ while(ch[p]==1)
+ {
+ int aux=p;
+ p=pred(p,ed1,ed2,numEdges);
+ ord[aux]=p;
+ }
+ p=y;
+
+ while(ch[p]==1)
+ {
+ int aux=p;
+ p=pred(p,ed1,ed2,numEdges);
+ ord[p]=aux;//other way
+ }
+
+ return ord;
+ }
+
+int getLength(int x, int y, int* ed1, int* ed2, int numEdges, int* edLen)
+/* get length of edge {x,y}, -1 if edge does not exist */
+{
+ int i = 0;
+ for (i = 0; i <= numEdges; i++)
+ if ((ed1[i] == x && ed2[i] == y) || (ed1[i] == y && ed2[i] == x))
+ return edLen[i];
+ return -1;
+}
+
+void C_triangMtd(double* d, int* np, int* ed1,int* ed2, double* edLen)
+{
+ int n=*np;
+ int i=0;
+ int j=0;
+ int ij=-1;
+
+ for(i=0;i<n-1;i++)
+ {
+ for(j=i+1;j<n;j++)
+ {ij++;
+ //error("%f ,giveindex= %f",d[ij],d[give_indexx(i,j,n)]);
+ }
+ }
+
+ /*double d[n*n];
+
+
+ for(i=0;i<n;i++)
+ {d[i*n+i]=0;
+ for(j=i;j<n;j++)
+ {d[i*n+j]=d[j*n+i];
+ }
+ }
+ for(i=0;i<n;i++)
+ {
+ for(j=0;j<n;j++)
+ {error("%f ",d[i*n+j]);
+ }
+ error("\n");
+ }*/
+
+ double minW=0;
+ int x=-1,y=-1,numEdges=0;
+ int st[n+1];//array holding at position i the starting point of attachment path of leaf i
+ int ed[n+1];//array holding at position i the ending point of attachment path of leaf i
+ double l[n+1];//array holding at position i the distance of leaf i from the partially constructed tree
+ int w[n+1];//presence array:w[i]=1 if leaf i is added to the tree, 0 otherwise
+ int wSize=0;//number of leaves added so far
+
+ for(i=1;i<=n;i++){w[i]=0;}
+ //find the minimum distance in our matrix
+
+ int sw=0;
+ //choose two leaves x,y such that d[x][y] is minimal
+ for(i=1;i<n;i++)
+ {
+ for(j=i+1;j<=n;j++)
+ {if(d[give_indexx(i,j,n)]<=0)continue;
+ minW=d[give_indexx(i,j,n)];
+ x=i;
+ y=j;
+ sw=1;
+ break;
+ }
+ if(sw)break;
+ }
+ for(i=1;i<n;i++)
+ for(j=i+1;j<=n;j++)
+ { if(i==j)continue;
+ if(d[give_indexx(i,j,n)]<minW)
+ {
+ minW=d[give_indexx(i,j,n)];
+ x=i;
+ y=j;
+ }
+ }
+
+ w[x]=1; w[y]=1;//mark x and y as added
+
+ //calculate the distance between leaves not in w and leaves in w
+ for(i=1;i<=n;i++)
+ {
+ if(w[i]){continue;}
+ st[i]=x;ed[i]=y;
+ l[i]=0.5*(d[give_indexx(i,x,n)]+d[give_indexx(i,y,n)]-d[give_indexx(x,y,n)]);//distance of leaf i from the
+//initial tree
+ }
+
+
+ wSize+=3;//since we construct a star tree on three leaves
+ int nv=n+1;//since first n numbers are reserved for leaves
+ double minDist=1000;
+ int x3=1;
+ //search for x3 that is closest to the tree
+ for(i=1;i<=n;i++)
+ {if(w[i])continue;//skip if leaf already added
+ if(l[i]<minDist)
+ {
+ minDist=l[i];
+ x3=i;
+ }
+ }
+ //construct initial star tree on three leaves:x,y,x3. nv is the interior
+ //vertex and also the root of the tree
+ ed1[numEdges]=nv;
+ ed2[numEdges]=x;
+ edLen[numEdges]=0.5*(d[give_indexx(x3,x,n)]+d[give_indexx(y,x,n)]-d[give_indexx(y,x3,n)]);
+ numEdges++;
+ ed1[numEdges]=nv;
+ ed2[numEdges]=y;
+ edLen[numEdges]=0.5*(d[give_indexx(y,x3,n)]+d[give_indexx(y,x,n)]-d[give_indexx(x,x3,n)]);
+ numEdges++;
+ ed1[numEdges]=nv;
+ ed2[numEdges]=x3;
+ edLen[numEdges]=0.5*(d[give_indexx(x3,x,n)]+d[give_indexx(y,x3,n)]-d[give_indexx(y,x,n)]);
+ w[x3]=1;
+
+ /*Rprintf("new tree\n");
+ for(i=0;i<2*n-3;i++)
+ {
+ Rprintf("%i->%i of length:%f \n",ed1[i],ed2[i],edLen[i]);
+ }
+ Rprintf("end new tree\n");*/
+
+ //calculate distance of leaves not yet added to the star tree
+ int s;
+ for(s=1;s<=n;s++)
+ {if(w[s])continue;
+ for(i=1;i<=n;i++)
+ { if(i==x3)continue;
+ if(!w[i])continue;
+ double newL=0.5*(d[give_indexx(i,s,n)]+d[give_indexx(s,x3,n)]-d[give_indexx(i,x3,n)]);
+ if(newL<l[s])
+ {
+ l[s]=newL;
+ st[s]=i;
+ ed[s]=x3;
+ }
+ }
+ }
+
+ //partial tree construction begins here
+
+ while(wSize<n)
+ { double minDist=1e50;
+ int z=1;
+
+ //search for leaf z which is closest to partial tree
+ for(i=1;i<=n;i++)
+ {if(w[i])continue;//skip if leaf already added
+ if(l[i]<minDist)
+ {
+ minDist=l[i];
+ z=i;
+ }
+ }
+ //x and y are the leaves on the path between which z is attached
+ x=st[z];y=ed[z];
+
+
+ int* ord=getPathBetween(x,y,n,ed1,ed2,numEdges);
+ /* Rprintf("ord\n");
+ for(i=1;i<=2*n-2;i++)
+ {Rprintf("ord[%i]=%i ",i,ord[i]);
+ }
+ Rprintf("\n");*/
+ //order the path from x to y, in an array ord, ord[i]=j means vertex i comes before j
+ //first count number of edges on path (i.e count all i s.t ch[i]==1)
+
+
+ //look for the edge on the path x to y to subdivide
+ int p=x;
+ double sum=0;
+ double prevSum=0;
+ int aux=0;
+ int subdiv=-1;//index of edge to subdivide
+ //error("d[y,x]=%f,d[z,x]=%f,d[z,y]=%f\n",d[give_indexx(y,x,n)],d[give_indexx(z,x,n)],d[give_indexx(z,y,n)]);
+ double lx=0.5*(d[give_indexx(y,x,n)]+d[give_indexx(z,x,n)]-d[give_indexx(z,y,n)]);//distance of attachment
+ // Rprintf("adding %i on the path between %i and %i at a distance from x of %f and a distance of %f from tree",z,x,y,lx,minDist);
+ //point from x
+ //Rprintf("Adding leaf %i, between %i and %i\n",z,x,y);
+ // Rprintf("%i situated at a distance of %d from tree",z,minDist);
+ int sw=0;
+ //Rprintf("path between %i and %i\n",x,y);
+
+ while(p!=y && sum<lx)
+ {
+ aux=p;
+ //error("%i -> %i ",p,ord[p]);
+ p=ord[p];
+ prevSum=sum;
+ for(i=0;i<=numEdges;i++)
+ {
+ if((ed1[i]==aux && ed2[i]==p)||(ed2[i]==aux && ed1[i]==p))
+ {
+ if(ed1[i]==aux && ed2[i]==p){sw=1;}
+ subdiv=i;
+ sum+=edLen[i];
+ }
+ }
+ }
+
+ nv++;
+ //subdivide subdiv with a node labelled nv
+ //length calculation
+ //multifurcating vertices
+
+ int edd=ed2[subdiv];
+ ed2[subdiv]=nv;
+ edLen[subdiv]= (sw==1)?(lx-prevSum):(sum-lx);//check which 'half' of the
+ //path the leaf belongs to
+ //and updates accordingly
+ //error("sum=%f, prevsum=%f\n",sum,prevSum);
+ //error("lx-prevSum=%f, sum-lx=%f, minDist=%f",lx-prevSum,sum-lx,minDist);
+ numEdges++;
+ ed1[numEdges]=nv;
+ ed2[numEdges]=edd;
+ edLen[numEdges]= (sw==1)?(sum-lx):(lx-prevSum);
+ numEdges++;
+ edLen[numEdges]=minDist;
+ ed1[numEdges]=nv;
+ ed2[numEdges]=z;
+
+ wSize++;
+ w[z]=1;
+
+ /*update distance matrix, only needed for incomplete distances
+ int ii;
+ for(ii=0;ii<n;ii++)
+ {if(!w[ii])continue;
+ error("path between %i and %i\n",ii,z);
+ int* ord=getPathBetween(ii,z,n,ed1,ed2,numEdges);
+
+ p=ii;
+ int newDist=0;
+ error("path");
+ for(i=0;i<2*n-2;i++)
+ {error("ord[%i]=%i ",i,ord[i]);
+ }
+ error("\n");
+ error("innn\n");
+ while(p!=z)
+ { //error("p=%i\n",p);
+ int aux=p;
+ p=ord[p];
+ newDist+=getLength(ii,z,ed1,ed2,numEdges,edLen);
+ }
+
+ error("outt\n");
+
+ d[ii][z]=d[z][ii]=newDist;
+ }*/
+ //update l[s] for all s not yet added
+ int s;
+ for(s=1;s<=n;s++)
+ {if(w[s])continue;
+ for(i=1;i<=n;i++)
+ {if(i==z)continue;
+ if(i!=x && i!=y)continue;//we only consider x and y as being other leaf
+ //and take the minimum of them as being new distance
+ double newL=0.5*(d[give_indexx(i,s,n)]+d[give_indexx(z,s,n)]-d[give_indexx(i,z,n)]);//one of leaves is
+ //z, since
+ //all pairs not cotaining z
+ //will remain unchanged
+ if(newL<l[s])
+ {
+ l[s]=newL;
+ st[s]=i;
+ ed[s]=z;
+ }
+ }
+ }
+ free(ord);
+ /*Rprintf("new tree\n");
+ for(i=0;i<2*n-3;i++)
+ {
+ Rprintf("%i->%i of length:%f \n",ed1[i],ed2[i],edLen[i]);
+ }
+ Rprintf("end new tree\n");*/
+ }
+ //for(i=0;i<=numEdges;i++){ed1[i]++;ed2[i]++;}
+ }
diff --git a/src/triangMtds.c b/src/triangMtds.c
new file mode 100644
index 0000000..a4f41df
--- /dev/null
+++ b/src/triangMtds.c
@@ -0,0 +1,223 @@
+/* triangMtds.c 2012-04-02 */
+
+/* Copyright 2011-2012 Andrei-Alin Popescu */
+
+/* This file is part of the R-package `ape'. */
+/* See the file ../COPYING for licensing issues. */
+
+#include "ape.h"
+
+void C_triangMtds(double* d, int* np, int* ed1,int* ed2, double* edLen)
+ {
+ int n=*np;
+ int k=0;
+ int i=0;
+ int j=0;
+ int ij=-1;
+ int m[n+1];
+ int c[n+1];
+ int s[n+1];
+ int o[n+1];
+ for(i=1;i<=n;i++)
+ {m[i]=0;
+ c[i]=i;
+ s[i]=0;
+ for(j=1;j<=n;j++)
+ {
+ if(i==j){m[i]++;continue;}
+ if(d[give_index(i,j,n)]==-1)continue;
+ m[i]++;
+ }
+ }
+
+ for(i=1;i<n;i++)
+ for(j=i+1;j<=n;j++)
+ {
+ if(m[i]<m[j])
+ {
+ int aux=m[i];
+ m[i]=m[j];
+ m[j]=aux;
+ aux=c[i];
+ c[i]=c[j];
+ c[j]=aux;
+ }
+ }
+ ij=1;
+ while(m[ij]==n){ij++;}
+ for(i=ij;i<n;i++)
+ {if(s[c[i]]==1)continue;
+ for(j=i+1;j<=n;j++)
+ {
+ if(s[c[j]]==1)continue;
+ if(d[give_index(c[i],c[j],n)]==-1)
+ {s[c[j]]=1;
+ }
+ }
+ }
+
+ for(i=1;i<=n;i++)
+ {
+ if(s[i]==0)
+ {
+ k++;
+ o[k]=i;
+ }
+ }
+ double* sub_d=(double*)R_alloc(k*(k - 1)/2, sizeof(double));
+ ij=0;
+ for(i=1;i<n;i++)
+ {if(s[i]==1)continue;
+ for(j=i+1;j<=n;j++)
+ {
+ if(s[j]==1)continue;
+ sub_d[ij++]=d[give_index(i,j,n)];
+ }
+ }
+
+ C_triangMtd(sub_d,&k,ed1,ed2,edLen);
+ for(i=0;i<2*k-3;i++)
+ {
+ if(ed1[i]>k)
+ {
+ ed1[i]+=(n-k);
+ }
+ if(ed2[i]>k)
+ {
+ ed2[i]+=(n-k);
+ }
+ }
+ for(i=0;i<2*k-3;i++)
+ {
+ if(ed2[i]<=k)
+ {
+ ed2[i]=o[ed2[i]];
+ }
+ }
+ for(i=1;i<=n;i++)
+ {
+ if(s[i]==0)continue;//take only leaves not in Y
+ m[i]=0;
+ for(j=1;j<=n;j++)
+ {
+ if(s[j]==1)continue;//take only leaves already in Y
+ if(d[give_index(i,j,n)]==-1)continue;//igonore if distance unknown
+ m[i]++;
+ }
+ }
+ int numEdges=2*k-4;//0-based, so subtract 1
+ //Rprintf("numEdge=%i",numEdges);
+ int nv=(k-2)+n;
+ while(k<n)
+ {
+ //now find element in X\Y such that it has most known distances to already
+ //built tree until all leaves are added or we can not find a place to attach
+ //the new element
+ //s[i]=1 => i not added to tree
+ int max=-1;
+ int maxPos=-1;
+ for(i=1;i<=n;i++)
+ {
+ if(s[i]==0)continue;
+ if(m[i]>max)
+ {
+ max=m[i];
+ maxPos=i;
+ }
+ }
+ s[maxPos]=0;//mark maxPos as added
+ //calculate new m values for leaves not added, i.e we just increment any
+ //already present value by 1 if we know the distance between i and maxPos
+ for(i=1;i<=n;i++)
+ {
+ if(s[i]==0)continue;
+ if(d[give_index(i,maxPos,n)]==-1)continue;
+ m[i]++;
+ }
+
+ //find path to attach maxPos to, grow tree
+ double minDist=1e50;
+ int z=maxPos;
+ int x=-1,y=-1;
+ for(i=1;i<n;i++)
+ {if(s[i]==1 || d[give_index(i,z,n)]==-1 || i==z)continue;
+ for(j=i+1;j<=n;j++)
+ {
+ if(s[j]==1 || d[give_index(j,z,n)]==-1 || j==z)continue;
+ double tDist=(d[give_index(i,z,n)]+d[give_index(j,z,n)]-d[give_index(i,j,n)])/2;
+ if(tDist<minDist)
+ {
+ minDist=tDist;
+ x=i;
+ y=j;
+ }
+ }
+ }
+ if(x==-1 || y==-1)
+ {error("could not build tree from given distance matrix");
+ }
+ int* ord=getPathBetween(x,y,n,ed1,ed2,numEdges);
+ /*for(i=1;i<=2*n-2;i++)
+ {Rprintf("ord[%i]=%i ",i,ord[i]);
+ }
+ Rprintf("\n");*/
+ //look for the edge on the path x to y to subdivide
+
+ int p=x;
+ double sum=0;
+ double prevSum=0;
+ int aux=0;
+
+ int subdiv=-1;//index of edge to subdivide
+ //error("d[y,x]=%f,d[z,x]=%f,d[z,y]=%f\n",d[give_indexx(y,x,n)],d[give_indexx(z,x,n)],d[give_indexx(z,y,n)]);
+ double lx=0.5*(d[give_indexx(y,x,n)]+d[give_indexx(z,x,n)]-d[give_indexx(z,y,n)]);//distance of attachment
+ // Rprintf("adding %i on the path between %i and %i at a distance from x of %f and a distance of %f from tree",z,x,y,lx,minDist);
+ //point from x
+ //Rprintf("Adding leaf %i, between %i and %i\n",z,x,y);
+ // Rprintf("%i situated at a distance of %d from tree",z,minDist);
+ int sw=0;
+ //Rprintf("path between %i and %i\n",x,y);
+ //int cc=0;
+ while(p!=y && sum<lx)
+ { //cc++;
+ aux=p;
+ //error("%i -> %i ",p,ord[p]);
+ p=ord[p];
+ prevSum=sum;
+ for(i=0;i<=numEdges;i++)
+ {
+ if((ed1[i]==aux && ed2[i]==p)||(ed2[i]==aux && ed1[i]==p))
+ {
+ if(ed1[i]==aux && ed2[i]==p){sw=1;}
+ subdiv=i;
+ sum+=edLen[i];
+ }
+ }
+ //if(cc>1000)error("failed to follow path between x=%i y=%i\n",x,y);
+ }
+
+
+ nv++;
+ //subdivide subdiv with a node labelled nv
+ //length calculation
+
+ int edd=ed2[subdiv];
+ ed2[subdiv]=nv;
+ edLen[subdiv]= (sw==1)?(lx-prevSum):(sum-lx);//check which 'half' of the
+ //path the leaf belongs to
+ //and updates accordingly
+ //error("sum=%f, prevsum=%f\n",sum,prevSum);
+ //error("lx-prevSum=%f, sum-lx=%f, minDist=%f",lx-prevSum,sum-lx,minDist);
+ //Rprintf("adding %i on path %i %i, at distance %f from %i, and %f from tree\n",z,x,y,lx,x,minDist);
+ // Rprintf("subdividing edge %i\n",subdiv);
+ numEdges++;
+ ed1[numEdges]=nv;
+ ed2[numEdges]=edd;
+ edLen[numEdges]= (sw==1)?(sum-lx):(lx-prevSum);
+ numEdges++;
+ edLen[numEdges]=minDist;
+ ed1[numEdges]=nv;
+ ed2[numEdges]=z;
+ k++;
+ }
+ }
diff --git a/src/ultrametric.c b/src/ultrametric.c
new file mode 100644
index 0000000..f21f78d
--- /dev/null
+++ b/src/ultrametric.c
@@ -0,0 +1,61 @@
+/* ultrametric.c 2011-10-11 */
+
+/* Copyright 2011 Andrei-Alin Popescu */
+
+/* This file is part of the R-package `ape'. */
+/* See the file ../COPYING for licensing issues. */
+
+#include "ape.h"
+
+void C_ultrametric(double *dd, int* np, int* mp, double *ret)//d received as dist object, -1 for missing entries
+{
+ int n=*np;
+ int m=*mp;
+ int i=0,j=0;
+ double max=dd[0];
+ double d[n][n];
+ for(i=1;i<n;i++)
+ {d[i-1][i-1]=0;
+ for(j=i+1;j<=n;j++)
+ {
+ d[i-1][j-1]=d[j-1][i-1]=dd[give_index(i,j,n)];
+ if(dd[give_index(i,j,n)]>max)
+ {
+ max=dd[give_index(i,j,n)];
+ }
+ }
+ }
+ d[n-1][n-1]=0;
+
+ int entrCh=0;
+ do{
+ entrCh=0;
+ for(i=0;i<n-1;i++)
+ for(j=i+1;j<n;j++)
+ {
+ if(d[i][j]!=-1)continue;
+ double minimax=max;
+ int k=0;
+ int sw=0;
+ for(k=0;k<n;k++)
+ {
+ if(d[i][k]==-1 || d[j][k]==-1)continue;
+ sw=1;
+ double mx = d[i][k] > d[j][k] ? d[i][k] : d[j][k];
+ if(mx<minimax){minimax=mx;}
+ }
+ if(sw==1)
+ {
+ d[i][j]=d[j][i]=minimax;
+ m--;
+ entrCh=1;
+ }
+ }
+ }while(entrCh==1);
+ int ij=0;
+ for(i=0;i<n;i++)
+ for(j=0;j<n;j++)
+ {
+ ret[ij++]=d[i][j];
+ }
+}
diff --git a/vignettes/MoranI.Rnw b/vignettes/MoranI.Rnw
new file mode 100644
index 0000000..04de862
--- /dev/null
+++ b/vignettes/MoranI.Rnw
@@ -0,0 +1,351 @@
+\documentclass[a4paper]{article}
+%\VignetteIndexEntry{Moran's I}
+%\VignettePackage{ape}
+\usepackage{fancyvrb}
+\usepackage{color}
+
+\newcommand{\code}{\texttt}
+\newcommand{\pkg}{\textsf}
+\newcommand{\ape}{\pkg{ape}}
+\newcommand{\ade}{\pkg{ade4}}
+\newcommand{\spatial}{\pkg{spatial}}
+\renewcommand{\sp}{\pkg{sp}}
+
+\author{Emmanuel Paradis}
+\title{Moran's Autocorrelation Coefficient in Comparative Methods}
+
+\begin{document}
+
+\maketitle
+
+<<echo=false,quiet=true>>=
+options(width=60)
+@
+
+This document clarifies the use of Moran's autocorrelation coefficient
+to quantify whether the distribution of a trait among a set of species
+is affected or not by their phylogenetic relationships.
+
+\section{Theoretical Background}
+
+Moran's autocorrelation coefficient (often denoted as $I$) is an
+extension of Pearson product-moment correlation coefficient to a univariate
+series \cite{Cliff1973, Moran1950}. Recall that Pearson's correlation
+(denoted as $\rho$) between two variables $x$ and $y$ both of length $n$ is:
+
+\begin{displaymath}
+\rho = \frac{\displaystyle\sum_{i=1}^n(x_i - \bar{x})(y_i -
+ \bar{y})}{\displaystyle\left[{\sum_{i=1}^n(x_i - \bar{x})^2\sum_{i=1}^n(y_i - \bar{y})^2}\right]^{1/2}},
+\end{displaymath}
+where $\bar{x}$ and $\bar{y}$ are the sample means of both
+variables. $\rho$ measures whether, on average, $x_i$ and $y_i$ are
+associated. For a single variable, say $x$, $I$ will
+measure whether $x_i$ and $x_j$, with $i\ne j$, are associated. Note
+that with $\rho$, $x_i$ and $x_j$ are {\em not} associated since the
+pairs $(x_i,y_i)$ are assumed to be independent of each other.
+
+In the study of spatial patterns and processes, we may logically
+expect that close observations are more likely to be similar than
+those far apart. It is usual to associate a {\em weight} to each
+pair $(x_i,x_j)$ which quantifies this \cite{Cliff1981}. In its simplest
+form, these weights will take values 1 for close neighbours, and 0
+otherwise. We also set $w_{ii}=0$. These weights are sometimes
+referred to as a {\em neighbouring function}.
+
+$I$'s formula is:
+
+\begin{equation}
+I = \frac{n}{S_0}
+\frac{\displaystyle\sum_{i=1}^n \sum_{j=1}^n w_{ij}(x_i - \bar{x})(x_j -
+ \bar{x})}{\displaystyle\sum_{i=1}^n (x_i - \bar{x})^2},\label{eq:morani}
+\end{equation}
+where $w_{ij}$ is the weight between observation $i$ and $j$, and
+$S_0$ is the sum of all $w_{ij}$'s:
+
+\begin{displaymath}
+S_0 = \sum_{i=1}^n \sum_{j=1}^n w_{ij}.
+\end{displaymath}
+
+Quite not so intuitively, the expected value of $I$ under the null
+hypothesis of no autocorrelation is not equal to zero but given by
+$I_0 = -1/(n-1)$. The expected variance of $I_0$ is also known, and
+so we can make a test of the null hypothesis. If the observed value
+of $I$ (denoted $\hat{I}$) is significantly greater than $I_0$, then
+values of $x$ are positively autocorrelated, whereas if $\hat{I}<I_0$,
+this will indicate negative autocorrelation. This allows us to design
+one- or two-tailed tests in the standard way.
+
+Gittleman \& Kot \cite{Gittleman1990} proposed to use Moran's $I$ to
+test for ``phylogenetic effects''. They considered two ways to
+calculate the weights $w$:
+
+\begin{itemize}
+\item With phylogenetic distances among species, e.g., $w_{ij} =
+ 1/d_{ij}$, where $d_{ij}$ are distances measured on a tree.
+\item With taxonomic levels where $w_{ij} = 1$ if species $i$ and $j$
+ belong to the same group, 0 otherwise.
+\end{itemize}
+
+Note that in the first situation, there are quite a lot of
+possibilities to set the weights. For instance, Gittleman \& Kot also proposed:
+
+\[\begin{array}{ll}
+w_{ij} = 1/d_{ij}^\alpha & \mathrm{if}\ d_{ij} \le c\\
+w_{ij} = 0 & \mathrm{if}\ d_{ij} > c,\\
+\end{array}\]
+where $c$ is a cut-off phylogenetic distance above which the species
+are considered to have evolved completely independently, and $\alpha$
+is a coefficient (see \cite{Gittleman1990} for details).
+By analogy to the use of a spatial correlogram where coefficients are
+calculated assuming different sizes of the ``neighbourhood'' and then
+plotted to visualize the spatial extent of autocorrelation, they
+proposed to calculate $I$ at different taxonomic levels.
+
+\section{Implementation in \ape}
+
+From version 1.2-6, \ape\ has functions \code{Moran.I} and
+\code{correlogram.formula} implementing the approach developed by Gittleman \&
+Kot. There was an error in the help pages of \code{?Moran.I}
+(corrected in ver.\ 2.1) where the weights were referred to as
+``distance weights''. This has been wrongly interpreted in my book
+\cite[pp.~139--142]{Paradis2006}. The analyses below aim to correct
+this.
+
+\subsection{Phylogenetic Distances}
+
+The data, taken from \cite{Cheverud1985}, are the log-transformed
+body mass and longevity of five species of primates:
+
+<<>>=
+body <- c(4.09434, 3.61092, 2.37024, 2.02815, -1.46968)
+longevity <- c(4.74493, 3.3322, 3.3673, 2.89037, 2.30259)
+names(body) <- names(longevity) <- c("Homo", "Pongo", "Macaca", "Ateles", "Galago")
+@
+
+The tree has branch lengths scaled so that the root age is one. We
+read the tree with \ape, and plot it:
+
+<<fig=true>>=
+library(ape)
+trnwk <- "((((Homo:0.21,Pongo:0.21):0.28,Macaca:0.49):0.13,Ateles:0.62)"
+trnwk[2] <- ":0.38,Galago:1.00);"
+tr <- read.tree(text = trnwk)
+plot(tr)
+axisPhylo()
+@
+
+We choose the weights as $w_{ij}=1/d_{ij}$, where the $d$'s is the
+distances measured on the tree:
+
+<<>>=
+w <- 1/cophenetic(tr)
+w
+@
+Of course, we must set the diagonal to zero:
+
+<<>>=
+diag(w) <- 0
+@
+We can now perform the analysis with Moran's $I$:
+
+<<>>=
+Moran.I(body, w)
+@
+
+Not surprisingly, the results are opposite to those in
+\cite{Paradis2006} since, there, the distances (given by
+\code{cophenetic(tr)}) were used as weights. (Note that the argument
+\code{dist} has been since renamed \code{weight}.\footnote{The older
+ code was actually correct; nevertheless, it has been rewritten, and
+ is now much faster. The documentation has been clarified.
+ The function \code{correlogram.phylo}, which computed
+ Moran's $I$ for a tree given as argument using the distances among
+ taxa, has been removed.}) We can now conclude for a slighly
+significant positive phylogenetic correlation among body mass values
+for these five species.
+
+The new version of \code{Moran.I} gains the option \code{alternative}
+which specifies the alternative hypothesis (\code{"two-sided"} by
+default, i.e., H$_1$: $I \ne I_0$). As expected from the above result, we divide the $P$-value
+be two if we define H$_1$ as $I > I_0$:
+
+<<>>=
+Moran.I(body, w, alt = "greater")
+@
+
+The same analysis with \code{longevity} gives:
+
+<<>>=
+Moran.I(longevity, w)
+@
+
+As for \code{body}, the results are nearly mirrored compared to
+\cite{Paradis2006} where a non-significant negative phylogenetic
+correlation was found: it is now positive but still largely not
+significant.
+
+\subsection{Taxonomic Levels}
+
+The function \code{correlogram.formula} provides an interface to
+calculate Moran's $I$ for one or several variables giving a series of
+taxonomic levels. An example of its use was provided in
+\cite[pp.~141--142]{Paradis2006}. The code of this function has been
+simplified, and the graphical presentation of the results have been improved.
+
+\code{correlogram.formula}'s main argument is a formula which is ``sliced'',
+and \code{Moran.I} is called for each of these elements. Two things
+have been changed for the end-user at this level:
+
+\begin{enumerate}
+\item In the old version, the rhs of the formula was given in the
+ order of the taxonomic hierarchy: e.g.,
+ \code{Order/SuperFamily/Family/Genus}. Not respecting this order
+ resulted in an error. In the new version, any order is accepted, but
+ the order given it is then respected when plotted the correlogram.
+\item Variable transformations (e.g., log) were allowed on the lhs of
+ the formula. Because of the simplification of the code, this is no
+ more possible. So it is the responsibility of the user to apply any
+ tranformation before the analysis.
+\end{enumerate}
+
+Following Gittleman \& Kot \cite{Gittleman1990}, the autocorrelation at a higher level
+(e.g., family) is calculated among species belonging to the same
+category and to different categories at the level below (genus).
+To formalize this, let us write the different levels as
+$X^1/X^2/X^3/\dots/X^n$ with $X^n$ being the lowest one (\code{Genus} in the
+above formula):
+
+\begin{displaymath}
+\begin{array}{l}
+\left.\begin{array}{ll}
+w_{ij}=1 & \mathrm{if}\ X_i^k = X_j^k\ \mathrm{and}\ X_i^{k+1} \ne X_j^{k+1}\\
+w_{ij}=0 & \mathrm{otherwise}\\
+\end{array} \right\} k < n
+\\\\
+\left.\begin{array}{ll}
+w_{ij}=1 & \mathrm{if}\ X_i^k = X_j^k\\
+w_{ij}=0 & \mathrm{otherwise}\\
+\end{array} \right\} k = n
+\end{array}
+\end{displaymath}
+This is thus different from the idea of a ``neighbourhood'' of
+different sizes, but rather similar to the idea of partial correlation
+where the influence of the lowest level is removed when considering
+the highest ones \cite{Gittleman1990}.
+
+To repeat the analyses on the \code{carnivora} data set, we first
+log$_{10}$-transform the variables mean body mass (\code{SW}) and the
+mean female body mass (\code{FW}):
+
+<<>>=
+data(carnivora)
+carnivora$log10SW <- log10(carnivora$SW)
+carnivora$log10FW <- log10(carnivora$FW)
+@
+We first consider a single variable analysis (as in \cite{Paradis2006}):
+
+<<fig=true>>=
+fm1.carn <- log10SW ~ Order/SuperFamily/Family/Genus
+co1 <- correlogram.formula(fm1.carn, data = carnivora)
+plot(co1)
+@
+
+A legend now appears by default, but can be removed with \code{legend
+= FALSE}. Most of the appearance of the graph can be customized via
+the option of the plot method (see \code{?plot.correlogram} for
+details). This is the same analysis than the one displayed on Fig.~6.3
+of \cite{Paradis2006}.
+
+When a single variable is given in the lhs in
+\code{correlogram.formula}, an object of class \code{"correlogram"} is
+returned as above. If several variables are analysed simultaneously,
+the object returned is of class \code{"correlogramList"}, and the
+correlograms can be plotted together with the appropriate plot method:
+
+<<fig=true>>=
+fm2.carn <- log10SW + log10FW ~ Order/SuperFamily/Family/Genus
+co2 <- correlogram.formula(fm2.carn, data = carnivora)
+print(plot(co2))
+@
+
+By default, lattice is used to plot the correlograms on separate
+panels; using \code{lattice = FALSE} (actually the second argument,
+see \code{?plot.correlogramList}) makes a standard graph superimposing
+the different correlograms:
+
+<<fig=true>>=
+plot(co2, FALSE)
+@
+
+The options are roughly the same than above, but do not have always
+the same effect since lattice and base graphics do not have the same
+graphical parameters. For instance, \code{legend = FALSE} has no
+effect if \code{lattice = TRUE}.
+
+\section{Implementation in \ade}
+
+The analysis done with \ade\ in \cite{Paradis2006} suffers from the
+same error than the one done with \code{Moran.I} since it was also
+done with a distance matrix. So I correct this below:
+
+\begin{Schunk}
+\begin{Sinput}
+> library(ade4)
+> gearymoran(w, data.frame(body, longevity))
+\end{Sinput}
+\begin{Soutput}
+class: krandtest
+Monte-Carlo tests
+Call: as.krandtest(sim = matrix(res$result, ncol = nvar, byr = TRUE),
+ obs = res$obs, alter = alter, names = test.names)
+
+Test number: 2
+Permutation number: 999
+Alternative hypothesis: greater
+
+ Test Obs Std.Obs Pvalue
+1 body -0.06256789 2.1523342 0.001
+2 longevity -0.22990437 0.3461414 0.414
+
+other elements: NULL
+\end{Soutput}
+\end{Schunk}
+
+The results are wholly consistent with those from \ape, but the
+estimated coefficients are substantially different. This is because
+the computational methods are not the same in both packages. In \ade,
+the weight matrix is first transformed as a relative frequency matrix with
+$\tilde{w}_{ij} = w_{ij}/S_0$. The weights are further transformed with:
+
+\begin{displaymath}
+p_{ij} = \tilde{w}_{ij} - \sum_{i=1}^n\tilde{w}_{ij}\sum_{j=1}^n\tilde{w}_{ij},
+\end{displaymath}
+with $p_{ij}$ being the elements of the matrix denoted as $P$. Moran's
+$I$ is finally computed with $x^\mathrm{T}Px$. In \ape, the weights
+are first row-normalized:
+
+\begin{displaymath}
+w_{ij} \Big/ \sum_{i=1}^n w_{ij},
+\end{displaymath}
+then eq.~\ref{eq:morani} is applied.
+
+Another difference between both packages, though less
+important, is that in \ade\ the weight matrix is forced to be
+symmetric with $(W+W^\mathrm{T})/2$. In \ape, this matrix is assumed
+to be symmetric, which is likely to be the case like in the examples above.
+
+\section{Other Implementations}
+
+Package \sp\ has several functions, including
+\code{moran.test}, that are more specifically targeted to the analysis
+of spatial data. Package \spatial\ has the function \code{correlogram}
+that computes and plots spatial correlograms.
+
+\section*{Acknowledgements}
+
+I am thankful to Thibaut Jombart for clarifications on Moran's $I$.
+
+\bibliographystyle{plain}
+\bibliography{ape}
+
+\end{document}
diff --git a/vignettes/ape.bib b/vignettes/ape.bib
new file mode 100644
index 0000000..6322943
--- /dev/null
+++ b/vignettes/ape.bib
@@ -0,0 +1,51 @@
+ at STRING{Ev = {Evolution}}
+ at STRING{SZ = {Systematic Zoology}}
+ at STRING{ny = {New York}}
+
+ at book{Cliff1973,
+ Author = {Cliff, A. D. and Ord, J. K.},
+ Title = {{Spatial Autocorrelation}},
+ Publisher = {Pion},
+ Address = {London},
+ Year = 1973}
+
+ at incollection{Cliff1981,
+ Author = {Cliff, A. D. and Ord, J. K.},
+ Title = {{Spatial and temporal analysis: autocorrelation in space and time}},
+ BookTitle = {{Quantitative Geography: A British View}},
+ Editor = {Wrigley, E. N. and Bennett, R. J.},
+ Publisher = {Routledge \& Kegan Paul},
+ Address = {London},
+ Pages = {104-110},
+ Year = 1981}
+
+ at article{Cheverud1985,
+ Author = {Cheverud, J. M. and Dow, M. M. and Leutenegger, W.},
+ Title = {{The quantitative assessment of phylogenetic constraints in comparative analyses: sexual dimorphism in body weight among primates}},
+ Journal = Ev,
+ Volume = {39},
+ Pages = {1335-1351},
+ Year = 1985}
+
+ at article{Gittleman1990,
+ Author = {Gittleman, J. L. and Kot, M.},
+ Title = {{Adaptation: statistics and a null model for estimating phylogenetic effects}},
+ Journal = SZ,
+ Volume = {39},
+ Pages = {227-241},
+ Year = 1990}
+
+ at article{Moran1950,
+ Author = {Moran, P. A. P.},
+ Title = {{Notes on continuous stochastic phenomena}},
+ Journal = {Biometrika},
+ Volume = {37},
+ Pages = {17-23},
+ Year = 1950}
+
+ at book{Paradis2006,
+ Author = {Paradis, E.},
+ Title = {{Analysis of Phylogenetics and Evolution with R}},
+ Publisher = {Springer},
+ Address = ny,
+ Year = 2006}
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/debian-med/r-cran-ape.git
More information about the debian-med-commit
mailing list