--- /dev/null
+Licence
+=======
+
+This is free software; you can redistribute it and/or modify
+it under the terms of the GNU General Public License as published by
+the Free Software Foundation; either version 2 of the License, or
+(at your option) any later version.
+
+This program is distributed in the hope that it will be useful,
+but WITHOUT ANY WARRANTY; without even the implied warranty of
+MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
+GNU General Public License for more details.
+
+You should have received a copy of the GNU General Public License
+along with this program; if not, write to the Free Software
+Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA.
\ No newline at end of file
--- /dev/null
+ 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 almost entirely rewritten, and should
+ much stabler now. 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 bug 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: a message 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 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 if
+ `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.
--- /dev/null
+Package: ape
+Version: 2.1
+Date: 2008-01-03
+Title: Analyses of Phylogenetics and Evolution
+Author: Emmanuel Paradis, Ben Bolker, Julien Claude, Hoa Sien Cuong,
+ Richard Desper, Benoit Durand, Julien Dutheil, Olivier Gascuel,
+ Gangolf Jobb, Christoph Heibl, Vincent Lefort, Jim Lemon,
+ Yvonnick Noel, Johan Nylander, Rainer Opgen-Rhein, Korbinian Strimmer
+Maintainer: Emmanuel Paradis <Emmanuel.Paradis@mpl.ird.fr>
+Depends: R (>= 2.0.0)
+Suggests: gee, nlme, lattice
+ZipData: no
+Description: ape provides functions for reading, writing, plotting,
+ and manipulating phylogenetic trees, analyses of comparative data
+ in a phylogenetic framework, analyses of diversification and
+ macroevolution, computing distances from allelic and nucleotide
+ data, reading nucleotide sequences, and several tools such as
+ Mantel's test, computation of minimum spanning tree, the population
+ parameter theta based on various approaches, nucleotide diversity,
+ generalized skyline plots, estimation of absolute evolutionary rates
+ and clock-like trees using mean path lengths, non-parametric rate
+ smoothing and penalized likelihood, classifying genes in trees using
+ the Klastorin-Misawa-Tajima approach. Phylogeny estimation can be done
+ with the NJ, BIONJ, ME, and ML methods.
+License: GPL (>= 2)
+URL: http://pbil.univ-lyon1.fr/R/ape/
--- /dev/null
+## 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)
+{
+ W <- W - diag(W) # ensure diagonal is zero
+ 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.real(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)
+
--- /dev/null
+## DNA.R (2007-12-21)
+
+## Manipulations and Comparisons of DNA Sequences
+
+## Copyright 2002-2007 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+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 = TRUE)
+{
+ class(x) <- NULL
+ if (is.matrix(x)) {
+ if (nargs() == 2 && !missing(i)) ans <- x[i]
+ else {
+ nd <- dim(x)
+ if (missing(i)) i <- 1:nd[1]
+ if (missing(j)) j <- 1:nd[2]
+ ans <- x[i, j, drop = drop]
+ }
+ } else {
+ if (missing(i)) i <- 1:length(x)
+ ans <- x[i]
+ }
+ structure(ans, class = "DNAbin")
+}
+
+as.matrix.DNAbin <- function(x, ...)
+{
+ if (is.matrix(x)) return(x)
+ if (is.list(x)) {
+ if (length(unique(unlist(lapply(x, length)))) != 1)
+ stop("DNA sequences in list not of the same length.")
+ nms <- names(x)
+ n <- length(x)
+ s <- length(x[[1]])
+ x <- matrix(unlist(x), n, s, byrow = TRUE)
+ rownames(x) <- nms
+ class(x) <- "DNAbin"
+ }
+ x
+}
+
+rbind.DNAbin <- function(...)
+### works only with matrices for the moment
+{
+ obj <- list(...)
+ nobj <- length(obj)
+ if (nobj == 1) stop("only one matrix to bind.")
+ NC <- ncol(obj[[1]])
+ for (i in 2:nobj)
+ if(ncol(obj[[i]]) != NC)
+ stop("matrices do not have the same number of columns.")
+ for (i in 1:nobj) class(obj[[i]]) <- NULL
+ ans <- obj[[1]]
+ for (i in 2:nobj) ans <- rbind(ans, obj[[i]])
+ structure(ans, class = "DNAbin")
+}
+
+cbind.DNAbin <- function(..., check.names = TRUE)
+### works only with matrices for the moment
+{
+ obj <- list(...)
+ nobj <- length(obj)
+ if (nobj == 1) stop("only one matrix to bind.")
+ NR <- nrow(obj[[1]])
+ for (i in 2:nobj)
+ if(nrow(obj[[i]]) != NR)
+ stop("matrices do not have the same number of rows.")
+ for (i in 1:nobj) class(obj[[i]]) <- NULL
+ nms <- rownames(obj[[1]])
+ if (check.names) {
+ for (i in 2:nobj)
+ if (all(rownames(obj[[i]]) %in% nms))
+ obj[[i]] <- obj[[i]][nms, ]
+ else stop("rownames do not match among matrices.")
+ }
+ ans <- matrix(unlist(obj), NR)
+ rownames(ans) <- nms
+ structure(ans, class = "DNAbin")
+}
+
+print.DNAbin <- function(x, ...)
+{
+ n <- 1 # <- if is.vector(x)
+ if (is.list(x)) n <- length(x)
+ else if (is.matrix(x)) n <- dim(x)[1]
+ if (n > 1) cat(n, "DNA sequences in binary format.\n")
+ else cat("1 DNA sequence in binary format.\n")
+}
+
+summary.DNAbin <- function(object, printlen = 6, digits = 3, ...)
+{
+ if (is.list(object)) {
+ n <- length(object)
+ nms <- names(object)
+ if (n == 1) {
+ cat("1 DNA sequence in binary format stored in a list.\n\n")
+ cat("Sequence length:", length(object[[1]]), "\n\n")
+ cat("Label:", nms, "\n\n")
+ } else {
+ cat(n, "DNA sequences in binary format stored in a list.\n\n")
+ cat("Summary of sequence lengths:\n")
+ print(summary(unlist(lapply(object, length))))
+ TAIL <- "\n\n"
+ if (printlen < n) {
+ nms <- nms[1:printlen]
+ TAIL <- "...\n\n"
+ }
+ cat("\nLabels:", paste(nms, collapse = " "), TAIL)
+ }
+ } else if (is.matrix(object)) {
+ nd <- dim(object)
+ nms <- rownames(object)
+ 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:", length(object), "\n\n")
+ }
+ cat("Base composition:\n")
+ print(round(base.freq(object), digits))
+}
+
+as.DNAbin <- function(x, ...) UseMethod("as.DNAbin")
+
+._cs_<- letters[c(1, 7, 3, 20, 18, 13, 23, 19, 11, 25, 22, 8, 4, 2, 14)]
+
+._bs_<- c(136, 72, 40, 24, 192, 160, 144, 96, 80, 48, 224, 176, 208, 112, 240)
+
+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)
+{
+ if (is.list(x)) x <- unlist(x)
+ n <- length(x)
+ BF <- .C("BaseProportion", as.raw(x), as.integer(n),
+ double(4), PACKAGE = "ape")[[3]]
+ names(BF) <- letters[c(1, 3, 7, 20)]
+ BF
+}
+
+GC.content <- function(x)
+{
+ BF <- base.freq(x)
+ sum(BF[2:3])
+}
+
+seg.sites <- function(x)
+{
+ n <- dim(x)
+ s <- n[2]
+ n <- n[1]
+ ans <- .C("SegSites", x, as.integer(n), as.integer(s),
+ integer(s), PACKAGE = "ape")
+ which(as.logical(ans[[4]]))
+}
+
+nuc.div <- function(x, variance = FALSE, pairwise.deletion = FALSE)
+{
+ if (pairwise.deletion && variance)
+ warning("cannot compute the variance of nucleotidic diversity\nwith pairwise deletion: try 'pairwise.deletion = FALSE' instead.")
+
+ n <- dim(x)
+ s <- n[2]
+ n <- n[1]
+
+ ## <FIXME> this should be safely deleted
+ if (!pairwise.deletion) {
+ keep <- .C("GlobalDeletionDNA", x, as.integer(n),
+ as.integer(s), as.integer(rep(1, s)),
+ PACKAGE = "ape")[[4]]
+ x <- x[, as.logical(keep)]
+ s <- dim(x)[2]
+ }
+ ## </FIXME>
+
+ ans <- .C("NucleotideDiversity", x, as.integer(n), as.integer(s),
+ as.integer(pairwise.deletion), double(1), PACKAGE = "ape")[[5]]
+
+ if (variance) {
+ var <- (n + 1)*ans/(3*(n + 1)*s) + 2*(n^2 + n + 3)*ans/(9*n*(n - 1))
+ ans <- c(ans, var)
+ }
+ ans
+}
+
+dist.dna <- function(x, model = "K80", variance = FALSE, gamma = FALSE,
+ pairwise.deletion = FALSE, base.freq = NULL,
+ as.matrix = FALSE)
+{
+ MODELS <- c("RAW", "JC69", "K80", "F81", "K81", "F84", "T92", "TN93",
+ "GG95", "LOGDET", "BH87", "PARALIN")
+ imod <- which(MODELS == toupper(model))
+ if (imod == 11 && variance) {
+ warning("computing variance temporarily not available for model BH87.")
+ variance <- FALSE
+ }
+ if (gamma && imod %in% c(1, 5:7, 9:12)) {
+ 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]
+ BF <- if (is.null(base.freq)) base.freq(x) else base.freq
+ if (!pairwise.deletion) {
+ keep <- .C("GlobalDeletionDNA", x, as.integer(n),
+ as.integer(s), as.integer(rep(1, s)),
+ PACKAGE = "ape")[[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 <- 1
+ d <- .C("dist_dna", x, as.integer(n), as.integer(s),
+ as.integer(imod), double(Ndist), BF,
+ as.integer(pairwise.deletion), as.integer(variance),
+ var, as.integer(gamma), alpha, PACKAGE = "ape")
+ 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
+}
--- /dev/null
+## MoranI.R (2007-12-26)
+
+## Moran's I Autocorrelation Index
+
+## Copyright 2004 Julien Dutheil, 2007 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)
+ #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)
+ }
+ }
+}
--- /dev/null
+## PGLS.R (2006-10-12)
+
+## Phylogenetic Generalized Least Squares
+
+## Copyright 2004 Julien Dutheil, and 2006 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 (!("phylo" %in% class(phy))) stop("ERROR!!! 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")
+ return(value)
+}
+
+corMartins <- function(value, phy, form=~1, fixed=FALSE)
+{
+ if(length(value) > 1) stop("ERROR!!! Only one parameter is allowed in corPGLS structure.")
+ if(value < 0) stop("ERROR!!! Parameter alpha must be positive.")
+ if (!("phylo" %in% class(phy))) stop("ERROR!!! 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")
+ return(value)
+}
+
+corGrafen <- function(value, phy, form=~1, fixed=FALSE)
+{
+ if(length(value) > 1) stop("ERROR!!! Only one parameter is allowed in corGrafen structure.")
+ if(value < 0) stop("ERROR!!! Parameter rho must be positive.")
+ value <- log(value) # Optimization under constraint, use exponential transform.
+ if (!("phylo" %in% class(phy))) stop("ERROR!!! 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")
+ return(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 row names supplied in dataframe, data taken to be in the same order as in tree.")
+ attr(object, "index") <- 1:dim(data)[1]
+ } else {
+ index <- match(rownames(data), phy$tip.label)
+ if(any(is.na(index))) {
+ warning("Row names in dataframe 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
+ }
+ }
+ return(object)
+}
+
+corMatrix.corBrownian <- function(object, covariate = getCovariate(object), corr = TRUE, ...)
+{
+ if (!("corBrownian" %in% class(object))) stop("ERROR!!! Object is not of class \"corBrownian\".")
+ if(!any(attr(object, "index"))) stop("ERROR!!! object have not been initialized.")
+ tree <- attr(object, "tree")
+ mat <- vcv.phylo(tree, cor = corr)
+ n <- dim(mat)[1]
+ # reorder matrix:
+ matr <- matrix(nrow=n, ncol=n)
+ index <- attr(object, "index")
+ for(i in 1:n)
+ for(j in i:n)
+ matr[i,j] <- matr[j,i] <- mat[index[i], index[j]]
+ return(matr)
+}
+
+corMatrix.corMartins <- function(object, covariate = getCovariate(object), corr = TRUE, ...)
+{
+ if (!("corMartins" %in% class(object))) stop("ERROR!!! Object is not of class \"corMartins\".")
+ if(!any(attr(object, "index"))) stop("ERROR!!! object have 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:
+ matr <- matrix(nrow=n, ncol=n)
+ index <- attr(object, "index")
+ for(i in 1:n)
+ for(j in i:n)
+ matr[i,j] <- matr[j,i] <- mat[index[i], index[j]]
+ return(matr)
+}
+
+corMatrix.corGrafen <- function(object, covariate = getCovariate(object), corr = TRUE, ...)
+{
+ if (!("corGrafen" %in% class(object))) stop("ERROR!!! Object is not of class \"corGrafen\".")
+ if(!any(attr(object, "index"))) stop("ERROR!!! object have not been initialized.")
+ tree <- compute.brlen(attr(object, "tree"), method = "Grafen", power = exp(object[1]))
+ mat <- vcv.phylo(tree, cor = corr)
+ n <- dim(mat)[1]
+ # reorder matrix:
+ matr <- matrix(nrow=n, ncol=n)
+ index <- attr(object, "index")
+ for(i in 1:n)
+ for(j in i:n)
+ matr[i,j] <- matr[j,i] <- mat[index[i], index[j]]
+ return(matr)
+}
+
+coef.corBrownian <- function(object, unconstrained = TRUE, ...)
+{
+ if (!("corBrownian" %in% class(object))) stop("ERROR!!! Object is not of class \"corBrownian\".")
+ return(numeric(0))
+}
+
+coef.corMartins <- function(object, unconstrained = TRUE, ...)
+{
+ if (!("corMartins" %in% class(object))) stop("ERROR!!! 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"
+ return(aux)
+}
+
+coef.corGrafen <- function(object, unconstrained = TRUE, ...)
+{
+ if (!("corGrafen" %in% class(object))) stop("ERROR!!! 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"
+ return(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 (!"phylo" %in% class(phy))
+ 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, "pruningwise")
+ 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),
+ DUP = FALSE, PACKAGE = "ape")[[6]] - 1
+ m <- Ntip - 1
+ phy$edge.length <-
+ (xx[phy$edge[, 1]]/m)^power - (xx[phy$edge[, 2]]/m)^power
+ return(phy)
+ }
+}
--- /dev/null
+## ace.R (2007-12-14)
+
+## Ancestral Character Estimation
+
+## Copyright 2005-2007 Emmanuel Paradis and Ben Bolker
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+ace <- function(x, phy, type = "continuous", method = "ML", CI = TRUE,
+ model = if (type == "continuous") "BM" else "ER",
+ scaled = TRUE, kappa = 1, corStruct = NULL, ip = 0.1)
+{
+ if (class(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 argument "x" and the tip labels of the tree
+did not match: the former were ignored in the analysis.')
+ }
+ obj <- list()
+ if (kappa != 1) phy$edge.length <- phy$edge.length^kappa
+ if (type == "continuous") {
+ if (method == "pic") {
+ if (model != "BM")
+ stop('the "pic" method can be used only with model = "BM".')
+ ## See pic.R for some annotations.
+ phy <- reorder(phy, "pruningwise")
+ 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("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),
+ PACKAGE = "ape")
+ obj$ace <- ans[[6]][-(1:nb.tip)]
+ names(obj$ace) <- (nb.tip + 1):(nb.tip + nb.node)
+ if (CI) {
+ se <- sqrt(ans[[8]])
+ CI95 <- matrix(NA, nb.node, 2)
+ CI95[, 1] <- obj$ace + se * qnorm(0.025)
+ CI95[, 2] <- obj$ace - se * qnorm(0.025)
+ obj$CI95 <- CI95
+ }
+ }
+ if (method == "ML") {
+ if (model == "BM") {
+ tip <- phy$edge[, 2] <= nb.tip
+ dev.BM <- function(p) {
+ 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 <- sqrt(diag(solve(out$hessian)))
+ obj$sigma2 <- c(out$estimate[1], se[1])
+ se <- se[-1]
+ if (CI) {
+ CI95 <- matrix(NA, nb.node, 2)
+ CI95[, 1] <- obj$ace + se * qt(0.025, nb.node)
+ CI95[, 2] <- obj$ace - se * qt(0.025, nb.node)
+ obj$CI95 <- CI95
+ }
+ }
+ }
+ if (method == "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)
+ obj$ace <- varAY %*% invV %*% x
+ if (CI) {
+ CI95 <- matrix(NA, nb.node, 2)
+ se <- sqrt((varA - varAY %*% invV %*% t(varAY))[cbind(1:nb.node, 1:nb.node)])
+ CI95[, 1] <- obj$ace + se * qnorm(0.025)
+ CI95[, 2] <- obj$ace - se * qnorm(0.025)
+ obj$CI95 <- CI95
+ }
+ }
+ } else { # type == "discrete"
+ if (method != "ML")
+ stop("only ML estimation is possible for discrete characters.")
+ 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)
+ if (model == "ER") np <- rate[] <- 1
+ if (model == "ARD") {
+ np <- nl*(nl - 1)
+ rate[col(rate) != row(rate)] <- 1:np
+ }
+ if (model == "SYM") {
+ np <- nl * (nl - 1)/2
+ rate[col(rate) < row(rate)] <- 1:np
+ rate <- t(rate)
+ rate[col(rate) < row(rate)] <- 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
+ index.matrix[cbind(1:nl, 1:nl)] <- NA
+ rate[cbind(1:nl, 1:nl)] <- 0
+ rate[rate == 0] <- np + 1 # to avoid 0's since we will use this an numeric indexing
+
+ liks <- matrix(0, nb.tip + nb.node, nl)
+ for (i in 1:nb.tip) liks[i, x[i]] <- 1
+ phy <- reorder(phy, "pruningwise")
+
+ Q <- matrix(0, nl, nl)
+ dev <- function(p, output.liks = FALSE) {
+ Q[] <- c(p, 0)[rate]
+ diag(Q) <- -rowSums(Q)
+ for (i in seq(from = 1, by = 2, length.out = nb.node)) {
+ j <- i + 1
+ anc <- phy$edge[i, 1]
+ des1 <- phy$edge[i, 2]
+ des2 <- phy$edge[j, 2]
+ tmp <- eigen(Q * phy$edge.length[i], symmetric = FALSE)
+ P1 <- tmp$vectors %*% diag(exp(tmp$values)) %*% solve(tmp$vectors)
+ tmp <- eigen(Q * phy$edge.length[j], symmetric = FALSE)
+ P2 <- tmp$vectors %*% diag(exp(tmp$values)) %*% solve(tmp$vectors)
+ liks[anc, ] <- P1 %*% liks[des1, ] * P2 %*% liks[des2, ]
+ }
+ if (output.liks) return(liks[-(1:nb.tip), ])
+ - 2 * log(sum(liks[nb.tip + 1, ]))
+ }
+ out <- nlm(function(p) dev(p), p = rep(ip, length.out = np),
+ hessian = TRUE)
+ obj$loglik <- -out$minimum / 2
+ obj$rates <- out$estimate
+ if (any(out$gradient == 0))
+ warning("The likelihood gradient seems flat in at least one dimension (gradient null):\ncannot compute the standard-errors of the transition rates.\n")
+ else obj$se <- sqrt(diag(solve(out$hessian)))
+ obj$index.matrix <- index.matrix
+ if (CI) {
+ lik.anc <- dev(obj$rates, TRUE)
+ lik.anc <- lik.anc / rowSums(lik.anc)
+ colnames(lik.anc) <- lvls
+ obj$lik.anc <- lik.anc
+ }
+ }
+ obj$call <- match.call()
+ class(obj) <- "ace"
+ obj
+}
+
+logLik.ace <- function(object, ...) object$loglik
+
+deviance.ace <- function(object, ...) -2*object$loglik
+
+AIC.ace <- function(object, ..., k = 2)
+{
+ if (is.null(object$loglik)) return(NULL)
+ ## Trivial test of "type"; may need to be improved
+ ## if other models are included in ace(type = "c")
+ np <- if (!is.null(object$sigma2)) 1 else length(object$rates)
+ -2*object$loglik + np*k
+}
+
+### by BB:
+anova.ace <- function(object, ...)
+{
+ X <- c(list(object), list(...))
+ df <- 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", "Deviance",
+ "Pr(>|Chi|)"))
+ structure(table, heading = "Likelihood Ratio Test Table",
+ class = c("anova", "data.frame"))
+}
--- /dev/null
+## all.equal.phylo.R (2006-09-12)
+##
+## 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)
+ 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)
+}
--- /dev/null
+## as.matching.R (2007-12-23)
+
+## Conversion Between Phylo and Matching Objects
+
+## Copyright 2005-2007 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")
+ 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 <- cbind(t(apply(mat, 1, sort)), new.nodes, deparse.level = 0)
+
+ 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, ...)
+{
+ N <- 2*dim(x$matching)[1]
+ edge <- matrix(NA, N, 2)
+ nb.tip <- (N + 2)/2
+ nb.node <- nb.tip - 1
+ 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[x$matching[i, 3]]
+ 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)
+ class(obj) <- "phylo"
+ read.tree(text = write.tree(obj))
+}
--- /dev/null
+## as.phylo.R (2007-03-05)
+
+## Conversion Among Tree Objects
+
+## Copyright 2005-2007 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 (class(x) == "phylo") return(x)
+ UseMethod("as.phylo")
+}
+
+as.phylo.hclust <- function(x, ...)
+{
+ N <- dim(x$merge)[1]
+ edge <- matrix(NA, 2*N, 2)
+ edge.length <- numeric(2*N)
+ ## `node' gives the number of the node for the i-th row of x$merge
+ node <- numeric(N)
+ node[N] <- N + 2
+ cur.nod <- N + 3
+ j <- 1
+ for (i in N:1) {
+ edge[j:(j + 1), 1] <- node[i]
+ for (l in 1:2) {
+ k <- j + l - 1
+ if (x$merge[i, l] > 0) {
+ edge[k, 2] <- node[x$merge[i, l]] <- cur.nod
+ cur.nod <- cur.nod + 1
+ edge.length[k] <- x$height[i] - x$height[x$merge[i, l]]
+ } else {
+ edge[k, 2] <- -x$merge[i, l]
+ edge.length[k] <- x$height[i]
+ }
+ }
+ j <- j + 2
+ }
+ if (is.null(x$labels))
+ x$labels <- as.character(1:(N + 1))
+ obj <- list(edge = edge, edge.length = edge.length,
+ 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")
+ n <- length(x$tip.label)
+ bt <- rev(branching.times(x))
+ N <- length(bt)
+ nm <- as.numeric(names(bt))
+ merge <- matrix(NA, N, 2)
+ for (i in 1:N) {
+ ind <- which(x$edge[, 1] == nm[i])
+ for (k in 1:2)
+ merge[i, k] <- if (x$edge[ind[k], 2] <= n) -x$edge[ind[k], 2]
+ else which(nm == x$edge[ind[k], 2])
+ }
+ names(bt) <- NULL
+ obj <- list(merge = merge, height = bt, order = 1:(N + 1),
+ labels = x$tip.label, call = match.call(),
+ method = "unknown")
+ class(obj) <- "hclust"
+ obj
+}
--- /dev/null
+## 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)
+}
--- /dev/null
+## balance.R (2006-10-04)
+
+## Balance of a Dichotomous Phylogenetic Tree
+
+## Copyright 2002-2006 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 (class(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
+}
--- /dev/null
+## bind.tree.R (2007-12-21)
+
+## Bind Trees
+
+## Copyright 2003-2007 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+bind.tree <- function(x, y, where = "root", position = 0)
+{
+ nb.tip <- length(x$tip.label)
+ nb.node <- x$Nnode
+ ROOT <- nb.tip + 1
+ if (where == 0 || where == "root")
+ where <- ROOT
+ if (position < 0) position <- 0
+ if (where > nb.tip + nb.node) stop("node number out of range for tree 'x'")
+ nb.edge <- dim(x$edge)[1]
+ yHasNoRootEdge <- is.null(y$root.edge)
+ xHasNoRootEdge <- is.null(x$root.edge)
+
+ ## check whether both trees have branch lengths:
+ wbl <- TRUE
+ noblx <- is.null(x$edge.length)
+ nobly <- is.null(y$edge.length)
+ if (noblx && nobly) wbl <- FALSE
+ if (xor(noblx, nobly)) {
+ if (nobly) x$edge.length <- NULL
+ else y$edge.length <- NULL
+ wbl <- FALSE
+ warning("one tree has no branch lengths, they will be ignored")
+ }
+
+ ## To avoid problems with tips or nodes with indentical
+ ## labels we substitute the one where `y' is grafted:
+ if (where <= nb.tip) {
+ Tip.Label.where <- x$tip.label[where]
+ x$tip.label[where] <- "TheTipWhereToGraftY"
+ }
+ if (where > ROOT) {
+ xHasNoNodeLabel <- TRUE
+ if (is.null(x$node.label)) {
+ x$node.label <- paste("NODE", 1:nb.node, sep = "")
+ x$node.label[where - nb.tip] <- "TheNodeWhereToGraftY"
+ } else {
+ Node.Label.where <- x$node.label[where - nb.tip]
+ x$node.label[where - nb.tip] <- "TheNodeWhereToGraftY"
+ xHasNoNodeLabel <- FALSE
+ }
+ }
+
+ ## if we bind `y' under a node or tip of `y', we first
+ ## adjust the edge lengths if needed
+ if (position && wbl) {
+ if (where == ROOT) {
+ if (xHasNoRootEdge) stop("tree 'x' has no root edge")
+ if (x$root.edge < position)
+ stop("argument 'position' is larger than the root edge.")
+ x$root.edge <- x$root.edge - position
+ } else {
+ i <- which(x$edge[, 2] == where)
+ if (x$edge.length[i] < position)
+ stop("argument 'position' is larger than the specified edge.")
+ x$edge.length[i] <- x$edge.length[i] - position
+ }
+ if (yHasNoRootEdge ) y$root.edge <- position
+ else y$root.edge <- y$root.edge + position
+ }
+
+ X <- write.tree(x)
+ Y <- write.tree(y)
+ Y <- substr(Y, 1, nchar(Y) - 1)
+
+ if (where <= nb.tip) {
+ if (position)
+ X <- gsub("TheTipWhereToGraftY",
+ paste("(", "TheTipWhereToGraftY", ",", Y, ")",
+ sep = ""), X)
+ else
+ X <- gsub("TheTipWhereToGraftY", Y, X)
+ }
+ if (where == ROOT) {
+ rmvx <- if (xHasNoRootEdge) "\\);$" else ";$"
+ X <- gsub(rmvx, "", X)
+ Y <- gsub("^\\(", "", Y)
+ if (!xHasNoRootEdge) X <- paste("(", X, sep = "")
+ X <- paste(X, ",", Y, ";", sep = "")
+ }
+ if (where > ROOT) {
+ if (position) {
+ ## find where is the node in `X':
+ ## below 19 is: nchar("TheNodeWhereToGraftY") - 1
+ for (i in 1:nchar(X)) {
+ if ("TheNodeWhereToGraftY" == substr(X, i, i + 19))
+ break
+ i <- i + 1
+ }
+ ## now go back to find the left matching parentheses
+ n.paren <- 1
+ i <- i - 2
+ while (n.paren > 0) {
+ if (substr(X, i, i) == ")") n.paren <- n.paren + 1
+ if (substr(X, i, i) == "(") n.paren <- n.paren - 1
+ i <- i - 1
+ }
+ ## insert the left parenthesis:
+ ## here 21 is: nchar("TheNodeWhereToGraftY") + 1
+ X <- paste(substr(X, 1, i - 1), "(",
+ substr(X, i, 21), sep = "")
+ ## and insert `y':
+ X <- gsub("TheNodeWhereToGraftY",
+ paste("TheNodeWhereToGraftY", ",", Y,
+ sep = ""), X)
+ } else {
+ xx <- paste(")", "TheNodeWhereToGraftY", sep = "")
+ X <- gsub(xx, paste(",", Y, xx, sep = ""), X)
+ }
+ }
+ phy <- read.tree(text = X)
+ ## restore the labels:
+ if (where <= nb.tip)
+ phy$tip.label[which(phy$tip.label == "TheTipWhereToGraftY")] <-
+ Tip.Label.where
+ if (where > ROOT) {
+ if (xHasNoNodeLabel) phy$node.label <- NULL
+ else
+ phy$node.label[which(phy$node.label == "TheNodeWhereToGraftY")] <-
+ Node.Label.where
+ }
+ phy
+}
--- /dev/null
+## birthdeath.R (2007-10-30)
+
+## Estimation of Speciation and Extinction Rates
+## with Birth-Death Models
+
+## birthdeath: standard model
+## bd.ext: extended version
+
+## Copyright 2002-2007 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+birthdeath <- function(phy)
+{
+ if (class(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) {
+ -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)
+ se <- c(0, sqrt(diag(solve(out$hessian))))
+ }
+ else {
+ para <- out$estimate
+ se <- sqrt(diag(solve(out$hessian)))
+ }
+ Dev <- out$minimum
+ ## compute the 95 % profile likelihood CIs
+ ## (not very clean... but seems to work -- EP 2003-03-29)
+ CI <- matrix(NA, 2, 2)
+ foo <- function(p) dev(p, para[2]) - 3.84 - Dev
+ inc <- 1e-2
+ lo <- para[1] - inc
+ up <- para[1] + inc
+ while (foo(lo) < 0) lo <- lo - inc
+ while (foo(up) < 0) up <- up + inc
+ CI[1, 1] <- uniroot(foo, lower = lo, upper = para[1])$root
+ if (CI[1, 1] < 0) CI[1, 1] <- 0
+ CI[1, 2] <- uniroot(foo, lower = para[1], upper = up)$root
+ foo <- function(p) dev(para[1], p) - 3.84 - Dev
+ lo <- para[2] - inc
+ up <- para[2] + inc
+ while (foo(lo) < 0) lo <- lo - inc
+ while (foo(up) < 0) up <- up + inc
+ CI[2, 1] <- uniroot(foo, lower = lo, upper = para[2])$root
+ CI[2, 2] <- uniroot(foo, lower = para[2], upper = up)$root
+ 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)
+{
+ if (class(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 names of the tip labels
+did not match: the former were ignored in the analysis.')
+ }
+ N <- length(S)
+ x <- branching.times(phy)
+ x <- c(x[1], x)
+ trm.br <- phy$edge.length[phy$edge[, 2] <= N]
+ dev <- function(a, r)
+ {
+ -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, 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)
+ se <- c(0, sqrt(diag(solve(out$hessian))))
+ }
+ else {
+ 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")
+}
--- /dev/null
+## branching.times.R (2006-10-04)
+
+## Branching Times of a Phylogenetic Tree
+
+## Copyright 2002-2006 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+branching.times <- function(phy)
+{
+### the tree must be in cladewise order
+ if (class(phy) != "phylo")
+ stop('object "phy" is not of class "phylo"')
+ n <- length(phy$tip.label)
+ N <- dim(phy$edge)[1]
+ xx <- numeric(phy$Nnode)
+ interns <- which(phy$edge[, 2] > n)
+ ## we loop only on the internal edges, this assumes
+ ## that `xx' is already set with 0
+ for (i in interns)
+ xx[phy$edge[i, 2] - n] <- xx[phy$edge[i, 1] - n] + phy$edge.length[i]
+ depth <- xx[phy$edge[N, 1] - n] + phy$edge.length[N]
+ xx <- depth - xx
+ names(xx) <-
+ if (is.null(phy$node.label)) (n + 1):(n + phy$Nnode) else phy$node.label
+ xx
+}
--- /dev/null
+## cherry.R (2006-10-03)
+
+## Number of Cherries and Null Models of Trees
+
+## Copyright 2002-2006 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+cherry <- function(phy)
+{
+ if (class(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)
+{
+ P <- 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)
+ P
+}
+
+f.cherry.uniform <- function(n, k)
+{
+ P <- 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))
+ P
+}
--- /dev/null
+## 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, "pruningwise")
+ 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), DUP = FALSE,
+ PACKAGE = "ape")[[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
+}
--- /dev/null
+## chronopl.R (2007-01-17)
+
+## Molecular Dating With Penalized Likelihood
+
+## Copyright 2005-2007 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+chronopl <- function(phy, lambda, node.age = 1, node = "root",
+ CV = FALSE)
+{
+ n <- length(phy$tip.label)
+ n.node <- phy$Nnode
+ if (n != n.node + 1)
+ stop("the tree must be rooted AND dichotomous")
+ if (any(phy$edge.length == 0))
+ stop("some branch lengths are equal to zero;
+you must remove them beforehand.")
+ N <- dim(phy$edge)[1]
+ ROOT <- n + 1
+ if (node == "root") node <- ROOT
+ ini.rate <- phy$edge.length
+ ## `known.ages' contains the index of all nodes (internal and
+ ## terminal) of known age:
+ known.ages <- c(1:n, node)
+ ## `unknown.ages' contains the index of the nodes of unknown age:
+ unknown.ages <- ((n + 1):(n + n.node))[-(node - n)]
+ ## `basal' contains the indices of the basal edges (ie, linked to the root):
+ basal <- which(phy$edge[, 1] == ROOT)
+
+ ## `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(NA, N - 2, 2)
+ j <- 1
+ for (i in 1:N) {
+ if (phy$edge[i, 1] == ROOT) next
+ ind[j, 1] <- i
+ ind[j, 2] <- which(phy$edge[, 2] == phy$edge[i, 1])
+ j <- j + 1
+ }
+
+ age <- rep(0, 2*n - 1)
+ age[node] <- node.age
+
+ tmp <- reorder(phy, "pruningwise")
+ ini.time <- .C("node_depth", as.integer(n), as.integer(n.node),
+ as.integer(tmp$edge[, 1]), as.integer(tmp$edge[, 2]),
+ as.integer(N), double(n + n.node), DUP = FALSE,
+ PACKAGE = "ape")[[6]][-(1:n)] - 1
+ ini.time <- ini.time/max(ini.time)
+ ini.time <- ini.time*node.age/ini.time[known.ages[-(1:n)] - n]
+ ## check that there are no negative branch lengths:
+ ini.time[known.ages[-(1:n)] - n] <- node.age
+ it <- c(age[1:n], ini.time)
+ ibl <- it[phy$edge[, 1]] - it[phy$edge[, 2]]
+ if (any(ibl < 0)) {
+ for (i in which(ibl < 0))
+ if (phy$edge[i, 1] %in% node)
+ ini.time[phy$edge[i, 2]] <- ini.time[phy$edge[i, 1]] - 1e-3
+ else
+ ini.time[phy$edge[i, 1]] <- ini.time[phy$edge[i, 2]] + 1e-3
+ }
+
+ ploglik <- function(rate, node.time) {
+ age[unknown.ages] <- node.time
+ real.edge.length <- age[phy$edge[, 1]] - age[phy$edge[, 2]]
+ B <- rate*real.edge.length
+ loglik <- sum(-B + phy$edge.length*log(B) -
+ lfactorial(phy$edge.length))
+ loglik - lambda * (sum((rate[ind[, 1]] - rate[ind[, 2]])^2)
+ + var(rate[basal]))
+ }
+
+ out <- nlm(function(p) -ploglik(p[1:N], p[-(1:N)]),
+ p = c(ini.rate, ini.time[unknown.ages - n]),
+ iterlim = 500)
+
+ attr(phy, "ploglik") <- -out$minimum
+ attr(phy, "rates") <- out$estimate[1:N]
+ age[unknown.ages] <- out$estimate[-(1:N)]
+ if (CV) ophy <- phy
+ phy$edge.length <- age[phy$edge[, 1]] - age[phy$edge[, 2]]
+ if (CV)
+ attr(phy, "D2") <-
+ chronopl.cv(ophy, lambda, node.age, node, n)
+ phy
+}
+
+chronopl.cv <- function(ophy, lambda, node.age, nodes, n)
+### 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(" dropping tip", i, "\n")
+ 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])
+ nodes <- nodes[-k]
+ node.age <- node.age[-k]
+ }
+ if (length(nodes)) {
+ chr <- chronopl(tr, lambda, node.age, nodes)
+ ## <FIXME> à vérifier:
+ ## tmp <- BT[as.character(ophy$edge[j, 1])]
+ tmp <- BT[-(ophy$edge[j, 1] - n)]
+ ## </FIXME>
+ D2[i] <- sum((tmp - branching.times(chr))^2 / tmp)
+ } else D2[i] <- 0
+ }
+ D2
+}
--- /dev/null
+## 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)
+}
--- /dev/null
+## collapse.singles.R (2006-07-15)
+
+## 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
+ 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] - 1 ## adjust indices
+ ## END
+ elen[prev.node] <- elen[prev.node] + elen[next.node]
+ elen <- elen[-next.node]
+ }
+ }
+ tree$edge <- xmat
+ tree$edge.length <- elen
+ tree
+}
--- /dev/null
+## 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)
+}
--- /dev/null
+## compar.gee.R (2006-10-11)
+
+## Comparative Analysis with GEEs
+
+## Copyright 2002-2006 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,
+ scale.fix = FALSE, scale.value = 1)
+{
+ if (is.null(data)) data <- parent.frame() else {
+ if(!any(is.na(match(rownames(data), phy$tip.label))))
+ data <- data[phy$tip.label, ]
+ else warning("the rownames of the data.frame and the tip labels of the tree
+do not match: the former were ignored in the analysis.")
+ }
+ 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 (yet) be used directly with missing data: you may consider removing the species with missing data from your tree with the function `drop.tip'.")
+ }
+ if (is.null(phy$edge.length))
+ stop("the tree has no branch lengths.")
+ R <- vcv.phylo(phy, cor = TRUE)
+ 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
+ if (family == "binomial")
+ W <- summary(glm(formula, family = quasibinomial, data = data))$cov.scaled
+ N <- geemod$nobs
+ dfP <- sum(phy$edge.length)*N / sum(diag(vcv.phylo(phy)))
+ obj <- list(call = geemod$call,
+ effect.assign = effect.assign,
+ nobs = N,
+ coefficients = geemod$coefficients,
+ residuals = geemod$residuals,
+ 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("\nCall:\n")
+ cat(" formula: ")
+ print(x$call$formula)
+ cat("\nNumber of observations: ", x$nobs, "\n")
+ cat("\nModel:\n")
+ cat(" Link: ", x$link, "\n")
+ cat(" Variance to Mean Relation:", x$family, "\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") <- c("Single term deletions\n\nModel:\n",
+ as.character(as.expression(fm)))
+ ans
+}
--- /dev/null
+## 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))
+}
--- /dev/null
+## compar.ou.R (2006-10-05)
+
+## Ornstein--Uhlenbeck Model for Continuous Characters
+
+## Copyright 2005-2006 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 (class(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.')
+ }
+ nb.tip <- length(phy$tip.label)
+ root <- nb.tip + 1
+ if (is.null(node)) node <- numeric(0)
+ if (root %in% node) node <- node[node != root]
+ bt <- branching.times(phy)
+ Tmax <- bt[1]
+ Wend <- matrix(0, nb.tip, length(node) + 1)
+ colnames(Wend) <- c(names(sort(bt[node])), as.character(root))
+ Wstart <- Wend
+ Wstart[, ncol(Wstart)] <- Tmax
+ root2tip <- .Call("seq_root2tip", phy$edge, nb.tip,
+ phy$Nnode, PACKAGE = "ape")
+ for (i in 1:nb.tip) {
+ last.change <- names(Tmax)
+ for (j in root2tip[[i]]) {#[-1]) {# don't need to look at the root
+ 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) {
+ M <- rowSums(exp(-p[1] * Wstart) - exp(-p[1] * Wend) * p[-(1:2)])
+ V <- exp(-p[1]*W) * (1 - exp(-2*p[1]*(Tmax - W/2)))
+ nb.tip*log(2*pi*p[2]) + log(det(V)) +
+ (t(x - M) %*% chol2inv(V) %*% (x - M)) / p[2]
+ }
+ if (is.null(alpha))
+ out <- nlm(function(p) dev(p),
+ p = c(0.1, 1, rep(mean(x), ncol(Wstart))),
+ hessian = TRUE)
+ else
+ out <- nlm(function(p) dev(c(alpha, p)),
+ p = c(1, rep(mean(x), ncol(Wstart))),
+ hessian = TRUE)
+ para <- cbind(out$estimate, sqrt(diag(solve(out$hessian))))
+ 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
+}
--- /dev/null
+## cophenetic.phylo.R (2007-01-23)
+
+## Pairwise Distances from a Phylogenetic Tree
+
+## Copyright 2006-2007 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+dist.nodes <- function(x)
+{
+ if (is.null(x$edge.length))
+ stop("your tree has no branch lengths")
+
+ if (!is.binary.tree(x) || !is.rooted(x))
+ x <- multi2di(x, random = FALSE)
+ n <- length(x$tip.label)
+ n.node <- x$Nnode
+ N <- n + n.node
+ x <- reorder(x, order = "pruningwise")
+
+ res <- matrix(NA, N, N)
+ res[cbind(1:N, 1:N)] <- 0 # implicit mode conversion
+
+ ## I like the simplicity of this one:
+ res[x$edge] <- res[x$edge[, 2:1]] <- x$edge.length
+
+ ## compute the distances ...
+ for (i in seq(from = 1, by = 2, length.out = n.node)) {
+ j <- i + 1
+ anc <- x$edge[i, 1]
+ des1 <- x$edge[i, 2]
+ des2 <- x$edge[j, 2]
+
+ ## If `des1' is a node, we look for the nodes and tips for
+ ## which the distance up to `des1' has already been
+ ## computed, including `des1' itself. For all these, we can
+ ## compute the distance up to `anc' and all node(s) and
+ ## tip(s) in `des2'.
+ if (des1 > n) des1 <- which(!is.na(res[des1, ]))
+
+ ## id. for `des2'
+ if (des2 > n) des2 <- which(!is.na(res[des2, ]))
+
+ ## The following expression is vectorized only on `des2' and
+ ## not on `des1' because they may be of different lengths.
+ for (y in des1)
+ res[y, des2] <- res[des2, y] <- res[anc, y] + res[anc, des2]
+ ## compute the distances between the tip(s) and node(s)
+ ## in `des2' and the ancestor of `anc'; id. for `des2'
+ ## (only if it is not the root)
+ if (anc != n + 1) {
+ ind <- which(x$edge[, 2] == anc)
+ nod <- x$edge[ind, 1] # the ancestor of `anc'
+ l <- x$edge.length[ind]
+ res[des2, nod] <- res[nod, des2] <- res[anc, des2] + l
+ res[des1, nod] <- res[nod, des1] <- res[anc, des1] + l
+ }
+ }
+ dimnames(res)[1:2] <- list(1:N)
+ res
+}
+
+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
+}
--- /dev/null
+## dist.gene.R (2002-08-28)
+
+## Pairwise Distances from Genetic Data
+
+## Copyright 2002 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+dist.gene.pairwise <- function(x, variance = FALSE)
+{
+ if (is.data.frame(x)) x <- as.matrix(x)
+ L <- ncol(x)
+ n <- nrow(x)
+ D <- matrix(NA, n, n)
+ diag(D) <- 0
+ for (i in 1:(n - 1)) {
+ for (j in (i + 1):n) {
+ D[i, j] <- D[j, i] <- L - sum(x[i, ] == x[j, ])
+ }
+ }
+ if (!is.null(rownames(x))) rownames(D) <- colnames(D) <- rownames(x)
+ if (variance) {
+ var.D <- D * (L - D) / L
+ return(list(distances = D, variance = var.D))
+ }
+ else return(D)
+}
+
+dist.gene.percentage <- function(x, variance = FALSE)
+{
+ L <- ncol(x)
+ D <- dist.gene.pairwise(x) / L
+ if (variance) {
+ var.D <- D * (1 - D) / L
+ return(list(pairwise.distances = D, variance = var.D))
+ }
+ else return(D)
+}
+
+dist.gene <- function(x, method = "pairwise", variance = FALSE)
+{
+ if (method == "pairwise")
+ return(dist.gene.pairwise(x, variance = variance))
+ if (method == "percentage")
+ return(dist.gene.percentage(x, variance = variance))
+}
--- /dev/null
+## dist.topo.R (2007-07-04)
+
+## Topological Distances, Tree Bipartitions,
+## Consensus Trees, and Bootstrapping Phylogenies
+
+## Copyright 2005-2007 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 == "BHV01" && (is.null(x$edge.length) || is.null(y$edge.length)))
+ stop("trees must have branch lengths for Billera et al.'s distance.")
+ n <- length(x$tip.label)
+ bp1 <- .Call("bipartition", x$edge, n, x$Nnode, PACKAGE = "ape")
+ bp1 <- lapply(bp1, function(xx) sort(x$tip.label[xx]))
+ bp2 <- .Call("bipartition", y$edge, n, y$Nnode, PACKAGE = "ape")
+ bp2 <- lapply(bp2, function(xx) sort(y$tip.label[xx]))
+ q1 <- length(bp1)
+ q2 <- length(bp2)
+ if (method == "PH85") {
+ p <- 0
+ for (i in 1:q1) {
+ for (j in 1:q2) {
+ if (identical(all.equal(bp1[[i]], bp2[[j]]), TRUE)) {
+ p <- p + 1
+ break
+ }
+ }
+ }
+ dT <- if (q1 == q2) 2*(q1 - p) else 2*(min(q1, q2) - p) + abs(q1 - q2)
+ }
+ if (method == "BHV01") {
+ 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]])) {
+ dT <- dT + abs(x$edge.length[which(x$edge[, 2] == n + i)] -
+ y$edge.length[which(y$edge[, 2] == n + j)])
+ found1 <- found2[j] <- TRUE
+ break
+ }
+ }
+ if (found1) found1 <- FALSE
+ else dT <- dT + x$edge.length[which(x$edge[, 2] == n + i)]
+ }
+ if (!all(found2))
+ dT <- dT + sum(y$edge.length[y$edge[, 2] %in% (n + which(!found2))])
+ }
+ dT
+}
+
+prop.part <- function(..., check.labels = FALSE)
+{
+ obj <- list(...)
+ if (length(obj) == 1 && class(obj[[1]]) != "phylo")
+ obj <- unlist(obj, recursive = FALSE)
+ ntree <- length(obj)
+ if (!check.labels) {
+ for (i in 1:ntree) storage.mode(obj[[i]]$Nnode) <- "integer"
+ clades <- .Call("prop_part", obj, ntree, TRUE, PACKAGE = "ape")
+ attr(clades, "number") <- attr(clades, "number")[1:length(clades)]
+ attr(clades, "labels") <- obj[[1]]$tip.label
+ } else {
+ bp <- .Call("bipartition", obj[[1]]$edge, length(obj[[1]]$tip.label),
+ obj[[1]]$Nnode, PACKAGE = "ape")
+ clades <- lapply(bp, function(xx) sort(obj[[1]]$tip.label[xx]))
+ no <- rep(1, length(clades))
+
+ if (ntree > 1) {
+ for (k in 2:ntree) {
+ bp <- .Call("bipartition", obj[[k]]$edge,
+ length(obj[[k]]$tip.label), obj[[k]]$Nnode,
+ PACKAGE = "ape")
+ bp <- lapply(bp, function(xx) sort(obj[[k]]$tip.label[xx]))
+ for (i in 1:length(bp)) {
+ done <- FALSE
+ for (j in 1:length(clades)) {
+ if (identical(all.equal(bp[[i]], clades[[j]]), TRUE)) {
+ no[j] <- no[j] + 1
+ done <- TRUE
+ break
+ }
+ }
+ if (!done) {
+ clades <- c(clades, bp[i])
+ no <- c(no, 1)
+ }
+ }
+ }
+ }
+ attr(clades, "number") <- no
+ }
+ 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 = "Number", 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)
+{
+ if (is.null(part)) {
+ obj <- list(...)
+ if (length(obj) == 1 && class(obj[[1]]) != "phylo")
+ obj <- unlist(obj, recursive = FALSE)
+ part <- prop.part(obj, check.labels = TRUE)
+ }
+ bp <- .Call("bipartition", phy$edge, length(phy$tip.label),
+ phy$Nnode, PACKAGE = "ape")
+ if (!is.null(attr(part, "labels")))
+ for (i in 1:length(part))
+ part[[i]] <- sort(attr(part, "labels")[part[[i]]])
+ bp <- lapply(bp, function(xx) sort(phy$tip.label[xx]))
+ n <- numeric(phy$Nnode)
+ for (i in 1:phy$Nnode) {
+ for (j in 1:length(part)) {
+ if (identical(all.equal(bp[[i]], part[[j]]), TRUE)) {
+ n[i] <- attr(part, "number")[j]
+ done <- TRUE
+ break
+ }
+ }
+ }
+ n
+}
+
+boot.phylo <- function(phy, x, FUN, B = 100, block = 1)
+{
+ if (is.list(x)) {
+ nm <- names(x)
+ n <- length(x)
+ x <- unlist(x)
+ nL <- length(x)
+ x <- matrix(x, n, nL/n, byrow = TRUE)
+ rownames(x) <- nm
+ }
+ boot.tree <- vector("list", B)
+ for (i in 1:B) {
+ if (block > 1) {
+ y <- seq(block, ncol(x), block)
+ boot.i <- sample(y, replace = TRUE)
+ boot.samp <- numeric(ncol(x))
+ boot.samp[y] <- boot.i
+ for (j in 1:(block - 1))
+ boot.samp[y - j] <- boot.i - j
+ } else boot.samp <- sample(ncol(x), replace = TRUE)
+ boot.tree[[i]] <- FUN(x[, boot.samp])
+ }
+ for (i in 1:B) storage.mode(boot.tree[[i]]$Nnode) <- "integer"
+ storage.mode(phy$Nnode) <- "integer"
+ attr(.Call("prop_part", c(list(phy), boot.tree), B + 1, FALSE,
+ PACKAGE = "ape"), "number") - 1
+}
+
+consensus <- function(..., p = 1)
+{
+ obj <- list(...)
+ if (length(obj) == 1 && class(obj[[1]]) != "phylo")
+ obj <- unlist(obj, recursive = FALSE)
+ ntree <- length(obj)
+ ## Get all observed partitions and their frequencies:
+ pp <- prop.part(obj, check.labels = TRUE)
+ ## Drop the partitions whose frequency is less than 'p':
+ pp <- pp[attr(pp, "number") >= p * ntree]
+ ## Get the order of the remaining partitions by decreasing size:
+ ind <- rev(sort(unlist(lapply(pp, length)),
+ index.return = TRUE)$ix)
+ pp <- lapply(pp, function(xx) paste("IMPROBABLE_PREFIX", xx,
+ "IMPROBABLE_SUFFIX", sep = "_"))
+ STRING <- paste(pp[[1]], collapse = ",")
+ STRING <- paste("(", STRING, ");", sep = "")
+ for (i in ind[-1]) {
+ ## 1. Delete all tips in the focus partition:
+ STRING <- unlist(strsplit(STRING, paste(pp[[i]], collapse = "|")))
+ ## 2. Put the partition in any of the created gaps:
+ STRING <- c(STRING[1],
+ paste("(", paste(pp[[i]], collapse = ","), ")", sep = ""),
+ STRING[-1])
+ ## 3. Stick back the Newick string:
+ STRING <- paste(STRING, collapse = "")
+ }
+ ## Remove the extra commas:
+ STRING <- gsub(",{2,}", ",", STRING)
+ STRING <- gsub("\\(,", "\\(", STRING)
+ STRING <- gsub(",\\)", "\\)", STRING)
+ STRING <- gsub("IMPROBABLE_PREFIX_", "", STRING)
+ STRING <- gsub("_IMPROBABLE_SUFFIX", "", STRING)
+ read.tree(text = STRING)
+}
--- /dev/null
+## 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")
+ }
+}
--- /dev/null
+## 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")
+}
--- /dev/null
+## drop.tip.R (2007-12-21)
+
+## Remove Tips in a Phylogenetic Tree
+
+## Copyright 2003-2007 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+drop.tip <- function(phy, tip, trim.internal = TRUE, subtree = FALSE,
+ root.edge = 0)
+{
+ if (class(phy) != "phylo") stop("object \"phy\" is not of class \"phylo\"")
+ phy <- new2old.phylo(phy)
+ if (subtree) {
+ trim.internal <- TRUE
+ edge.bak <- phy$edge
+ }
+ tmp <- as.numeric(phy$edge)
+ nb.tip <- max(tmp)
+ nb.node <- -min(tmp)
+ nobr <- is.null(phy$edge.length)
+ if (is.numeric(tip)) tip <- phy$tip.label[tip]
+ ## find the tips to drop...:
+ del <- phy$tip.label %in% tip
+ ## ... and the corresponding terminal branches:
+ ind <- which(phy$edge[, 2] %in% as.character(which(del)))
+ ## drop them...:
+ phy$edge <- phy$edge[-ind, ]
+ ## ... and the lengths if applies:
+ if (!nobr) phy$edge.length <- phy$edge.length[-ind]
+ ## drop the tip labels:
+ phy$tip.label <- phy$tip.label[!del]
+ if (trim.internal) {
+ if (root.edge) {
+ ## find the MRCA of the remaining tips:
+ seq.nod <- list()
+ ## This is modified since some tips were deleted!!
+ for (i in phy$edge[, 2][as.numeric(phy$edge[, 2]) > 0]) {
+ vec <- i
+ j <- i
+ while (j != "-1") {
+ ind <- which(phy$edge[, 2] == j)
+ j <- phy$edge[ind, 1]
+ vec <- c(vec, j)
+ }
+ seq.nod[[i]] <- vec
+ }
+ sn <- lapply(seq.nod, rev)
+ i <- 1
+ x <- unlist(lapply(sn, function(x) x[i]))
+ while (length(unique(x)) == 1) {
+ x <- unlist(lapply(sn, function(x) x[i]))
+ i <- i + 1
+ }
+ MRCA <- sn[[1]][i - 2]
+ newrootedge <- if (is.null(phy$root.edge)) 0 else phy$root.edge
+ for (i in 1:root.edge) {
+ ind <- which(phy$edge[, 2] == MRCA)
+ newrootedge <- newrootedge + phy$edge.length[ind]
+ MRCA <- phy$edge[ind, 1]
+ if (MRCA == "-1" && i < root.edge) {
+ newrootedge <- newrootedge
+ break
+ }
+ }
+ phy$root.edge <- newrootedge
+ } else {
+ if (!is.null(phy$root.edge)) phy$root.edge <- NULL
+ }
+ while (!all(phy$edge[, 2][as.numeric(phy$edge[, 2]) < 0] %in% phy$edge[, 1])) {
+ temp <- phy$edge[, 2][as.numeric(phy$edge[, 2]) < 0]
+ k <- temp %in% phy$edge[, 1]
+ ind <- phy$edge[, 2] %in% temp[!k]
+ phy$edge <- phy$edge[!ind, ]
+ if (!nobr) phy$edge.length <- phy$edge.length[!ind]
+ }
+ } else {
+ temp <- phy$edge[, 2][as.numeric(phy$edge[, 2]) < 0]
+ k <- temp %in% phy$edge[, 1]
+ ind <- phy$edge[, 2] %in% temp[!k]
+ phy$edge[which(ind), 2] <- as.character(nb.tip + (1:sum(ind)))
+ if (is.null(phy$node.label)) new.tip.label <- rep("NA", sum(ind)) else {
+ new.tip.label <- phy$node.label[!k]
+ phy$node.label <- phy$node.label[k]
+ }
+ phy$tip.label <- c(phy$tip.label, new.tip.label)
+ }
+ useless.nodes <- names(which(table(phy$edge[, 1]) == 1))
+ if (subtree) {
+ if (!nobr) mnbr <- mean(phy$edge.length)
+ if (length(useless.nodes) == 1) n <- length(tip) else {
+ seq.nod <- list()
+ wh <- numeric(0)
+ for (i in as.character(which(del))) { # it is not needed to loop through all tips!
+ vec <- i
+ j <- i
+ while (!(j %in% useless.nodes)) {
+ ind <- which(edge.bak[, 2] == j)
+ wh <- c(wh, ind)
+ j <- edge.bak[ind, 1]
+ vec <- c(vec, j)
+ }
+ seq.nod[[i]] <- vec
+ }
+ n <- table(unlist(lapply(seq.nod, function(x) rev(x)[1])))
+ }
+ new.lab <- paste("[", n, "_tips]", sep = "")
+ for (i in 1:length(useless.nodes)) {
+ wh <- which(phy$edge[, 1] == useless.nodes[i])
+ phy$tip.label <- c(phy$tip.label, new.lab[i])
+ if (wh == dim(phy$edge)[1]) {
+ phy$edge <- rbind(phy$edge, c(useless.nodes[i], as.character(nb.tip + i)))
+ if (!nobr) phy$edge.length <- c(phy$edge.length, mnbr)
+ } else {
+ phy$edge <- rbind(phy$edge[1:wh, ],
+ c(useless.nodes[i], as.character(nb.tip + i)),
+ phy$edge[(wh + 1):dim(phy$edge)[1], ])
+ if (!nobr) phy$edge.length <- c(phy$edge.length[1:wh], mnbr,
+ phy$edge.length[(wh + 1):(dim(phy$edge)[1] - 1)])
+ }
+ }
+ } else {
+ for (i in useless.nodes) {
+ ind1 <- which(phy$edge[, 1] == i)
+ ind2 <- which(phy$edge[, 2] == i)
+ phy$edge[ind2, 2] <- phy$edge[ind1, 2]
+ phy$edge <- phy$edge[-ind1, ]
+ if (!nobr) {
+ phy$edge.length[ind2] <- phy$edge.length[ind2] + phy$edge.length[ind1]
+ phy$edge.length <- phy$edge.length[-ind1]
+ }
+ }
+ }
+ tmp <- as.numeric(phy$edge)
+ if (!is.null(phy$node.label)) {
+ x <- unique(tmp)
+ x <- x[x < 0]
+ phy$node.label <- phy$node.label[-x]
+ }
+ n <- length(tmp)
+ nodes <- tmp < 0
+ ind.nodes <- (1:n)[nodes]
+ ind.tips <- (1:n)[!nodes]
+ new.nodes <- -as.numeric(factor(-tmp[nodes]))
+ new.tips <- as.numeric(factor(tmp[!nodes]))
+ tmp[ind.nodes] <- new.nodes
+ tmp[ind.tips] <- new.tips
+ dim(tmp) <- c(n / 2, 2)
+ mode(tmp) <- "character"
+ phy$edge <- tmp
+ phy <- old2new.phylo(phy)
+ if (!trim.internal || subtree) {
+ S <- write.tree(phy)
+ phy <- if (nobr) clado.build(S) else tree.build(S)
+ }
+ phy
+}
--- /dev/null
+## evolve.tree.R (2005-12-04)
+
+## Character Simulation under a Brownian Model
+
+## Copyright 2005 Julien Dutheil
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+evolve.phylo <- function(phy, value, var) {
+ if (!("phylo" %in% class(phy)))
+ stop("object \"phy\" is not of class \"phylo\"")
+ if (is.null(phy$edge.length))
+ stop("tree \" phy\" must have branch lengths.")
+ nchar <- max(length(value), length(var))
+ value <- rep(value, length=nchar)
+ var <- rep(var, length=nchar)
+ char.names <- names(value);
+
+ ## added by EP for the new coding of "phylo" (2006-10-04):
+ phy <- new2old.phylo(phy)
+ ## End
+ edges <- phy$edge
+ nodes <- unique(as.vector(edges))
+ n <- length(nodes) # Number of nodes
+ root <- match("-1", nodes)
+ states<-list();
+ states[["-1"]] <- value
+ for(node in nodes[-root]) {
+ edge.index <- match(node, edges[,2])
+ edge.length <- phy$edge.length[edge.index]
+ ancestor <- edges[edge.index, 1]
+ ancestor.node.index <- match(ancestor, nodes)
+ ancestor.states <- states[[ancestor.node.index]]
+ index <- match(node, nodes)
+ x <- numeric(nchar)
+ for(i in 1:nchar) {
+ x[i] <- rnorm(1, mean=ancestor.states[i], sd=sqrt(var[i]*edge.length))
+ }
+ states[[index]] <- x;
+ }
+ nodes.states <- as.data.frame(matrix(ncol=nchar, nrow=0))
+ if(!is.null(char.names)) names(nodes.states) <- char.names
+ count <- 1
+ for(i in unique(edges[,1])) {
+ nodes.states[i,] <- states[[match(i, nodes)]]
+ count <- count + 1
+ }
+
+ nl <- length(phy$tip.label) #Number of leaves
+ leaves.states <- as.data.frame(matrix(ncol=nchar, nrow=0))
+ if(!is.null(char.names)) names(leaves.states) <- char.names
+ count <- 1
+ for(i in 1:nl) {
+ leaves.states[as.character(count),] <- states[[match(as.character(i), nodes)]]
+ count <- count + 1
+ }
+
+ phy[["node.character"]] <- nodes.states;
+ phy[["tip.character"]] <- leaves.states;
+ if(! "ancestral" %in% class(phy)) class(phy) <- c("ancestral", class(phy));
+ ## added by EP for the new coding of "phylo" (2006-10-04):
+ phy <- old2new.phylo(phy)
+ ## End
+ return(phy)
+}
--- /dev/null
+## 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)
+}
--- /dev/null
+## gammaStat.R (2006-10-04)
+
+## Gamma-Statistic of Pybus and Harvey
+
+## Copyright 2002-2006 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+gammaStat <- function(phy)
+{
+ if (class(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
+}
--- /dev/null
+## heterozygosity.R (2002-08-28)
+
+## Heterozygosity at a Locus Using Gene Frequencies
+
+## Copyright 2002 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+heterozygosity <- function(x, variance = FALSE)
+{
+ if (!is.factor(x)) {
+ if (is.numeric(x)) {
+ n <- sum(x)
+ k <- length(x)
+ freq <- x/n
+ }
+ else x <- factor(x)
+ }
+ if (is.factor(x)) { # ne pas remplacer par `else'...
+ n <- length(x)
+ k <- nlevels(x)
+ freq <- table(x)/n
+ }
+ sp2 <- sum(freq^2)
+ H <- n * (1 - sp2) / (n - 1)
+ if (variance) {
+ sp3 <- sum(freq^3)
+ var.H <- 2 * (2 * (n - 2) * (sp3 - sp2^2) + sp2 - sp2^2) / (n * (n - 1))
+ return(c(H, var.H))
+ }
+ else return(H)
+}
+
+H <- function(x, variance = FALSE) heterozygosity(x, variance)
--- /dev/null
+## 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
+}
--- /dev/null
+## identify.phylo.R (2007-12-14)
+
+## Graphical Identification of Nodes and Tips
+
+## Copyright 2007 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, ...)
+{
+ xy <- locator(1)
+ Ntip <- .last_plot.phylo$Ntip
+ d <- sqrt((xy$x - .last_plot.phylo$xx)^2 +
+ (xy$y - .last_plot.phylo$yy)^2)
+ NODE <- which.min(d)
+ print(NODE)
+ res <- list()
+ if (NODE <= Ntip) {
+ res$tips <- if (labels) x$tip.label[NODE] else NODE
+ return(res)
+ }
+ if (tips) {
+ TIPS <- prop.part(x)[[NODE - 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 - Ntip] else NODE
+ }
+ res
+}
--- /dev/null
+## is.binary.tree.R (2002-09-12) [modified by EP 2005-05-31, 2005-08-18,
+## 2006-10-04]
+
+## 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 (class(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)
+ }
+}
--- /dev/null
+## is.ultrametric.R (2007-12-18)
+
+## Test if a Tree is Ultrametric
+
+## Copyright 2003-2007 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)
+{
+### the tree must be in cladewise order
+ if (class(phy) != "phylo")
+ stop('object "phy" is not of class "phylo".')
+ if (is.null(phy$edge.length))
+ stop("the tree has no branch lengths.")
+ n <- length(phy$tip.label)
+ n.node <- phy$Nnode
+
+ ## xx: vecteur donnant la distance d'un
+ ## noeud ou tip à partir de la racine
+ xx <- numeric(n + n.node)
+
+ for (i in 1:dim(phy$edge)[1])
+ xx[phy$edge[i, 2]] <- xx[phy$edge[i, 1]] + phy$edge.length[i]
+
+ if (identical(all.equal.numeric(var(xx[1:n]),
+ 0, tolerance = tol), TRUE)) TRUE
+ else FALSE
+}
--- /dev/null
+## klastorin.R (2003-05-26)
+
+## Klastorin's (1982) classifification method, applied to
+## phylogenetic trees as suggested by Misawa and Tajima (2000)
+
+## Copyright 2003 Gangolf Jobb
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+########### PRIVATE ##############
+
+getMisawaTajima <- function()
+ .C("getMisawaTajima", result = integer(klastorin_nTips()),
+ PACKAGE = "ape")$result
+
+### functions to set and extract phylo tree ###
+
+buildTreeFromPhylo <- function(tree) {
+ lowerNodes <- tree$edge[,1]
+ upperNodes <- tree$edge[,2]
+ edgeLengths <- tree$edge.length
+ tipLabels <- tree$tip.label
+ .C("buildTreeFromPhylo", as.integer(lowerNodes),
+ as.integer(upperNodes), as.double(edgeLengths),
+ as.integer(length(edgeLengths)),
+ as.character(tipLabels),
+ as.integer(length(tipLabels)),
+ result = integer(1), PACKAGE = "ape"
+ )$result
+}
+
+destroyTree <- function()
+ .C("destroyTree", result = integer(1),
+ PACKAGE = "ape")$result
+
+getError <- function()
+ .C("getError", result = integer(1),
+ PACKAGE = "ape")$result
+
+klastorin_nTips <- function()
+ .C("nTips", result = integer(1),
+ PACKAGE = "ape")$result
+
+########### PUBLIC ##############
+
+klastorin <- function(phy)
+{
+ if (class(phy) != "phylo")
+ stop("object \"phy\" is not of class \"phylo\"")
+ ## added by EP for the new coding of "phylo" (2006-10-04):
+ phy <- new2old.phylo(phy)
+ ## End
+ buildTreeFromPhylo(phy)
+ if (getError() !=0) stop("Could not load \"phylo\" object")
+ tmp <- getMisawaTajima()
+ destroyTree()
+ tmp
+}
--- /dev/null
+## 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, "pruningwise")
+ 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),
+ DUP = FALSE, PACKAGE = "ape")[[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
+}
--- /dev/null
+## ltt.plot.R (2007-12-22)
+
+## Lineages Through Time Plot
+
+## Copyright 2002-2007 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+ltt.plot <- function(phy, xlab = "Time", ylab = "N", ...)
+{
+ if (class(phy) != "phylo") stop('object "phy" is not of class "phylo"')
+ time <- sort(branching.times(phy), decreasing = TRUE)
+ N <- 1:(length(time) + 1)
+ plot(-c(time, 0), N, xlab = xlab, ylab = ylab,
+ xaxs = "r", yaxs = "r", type = "S", ...)
+}
+
+ltt.lines <- function(phy, ...)
+{
+ time <- sort(branching.times(phy), decreasing = TRUE)
+ N <- 1:(length(time) + 1)
+ lines(-c(time, 0), N, type = "S", ...)
+}
+
+mltt.plot <- function(phy, ..., dcol = TRUE, dlty = FALSE, legend = TRUE,
+ xlab = "Time", ylab = "N")
+{
+ ltt.xy <- function(phy) {
+ x <- -c(sort(branching.times(phy), decreasing = TRUE), 0)
+ names(x) <- NULL
+ y <- 1:length(x)
+ cbind(x, y)
+ }
+ if (class(phy) == "phylo") {
+ TREES <- list(ltt.xy(phy))
+ names(TREES) <- deparse(substitute(phy))
+ } else { # a list of trees
+ TREES <- lapply(phy, ltt.xy)
+ names(TREES) <- names(phy)
+ }
+ dts <- list(...)
+ n <- length(dts)
+ if (n) {
+ mc <- as.character(match.call())[-(1:2)]
+ nms <- mc[1:n]
+ for (i in 1:n) {
+ if (class(dts[[i]]) == "phylo") {
+ a <- list(ltt.xy(dts[[i]]))
+ names(a) <- nms[i]
+ } else { # a list of trees
+ a <- lapply(dts[[i]], ltt.xy)
+ names(a) <- names(dts[[i]])
+ }
+ TREES <- c(TREES, a)
+ }
+ }
+ n <- length(TREES)
+ xl <- c(min(unlist(lapply(TREES, function(x) min(x[, 1])))), 0)
+ yl <- c(1, max(unlist(lapply(TREES, function(x) max(x[, 2])))))
+
+ plot(0, 0, type = "n", xlim = xl, ylim = yl, xaxs = "r", yaxs = "r",
+ xlab = xlab, ylab = ylab)
+
+ 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")
+}
--- /dev/null
+## mantel.test.R (2006-07-28)
+
+## Mantel Test for Similarity of Two Matrices
+
+## Copyright 2002-2006 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)
+{
+ d <- dim(m)
+ if (d[1] != d[2]) print("Warning: non-square matrix")
+ m[col(m) <= row(m)]
+}
+
+mantel.test <- function (m1, m2, nperm = 1000, graph = FALSE, ...)
+{
+ n <- nrow(m1)
+ realz <- mant.zstat(m1, m2)
+ nullstats <- replicate(nperm, mant.zstat(m1, perm.rowscols(m2, n)))
+ pval <- sum(nullstats > realz)/nperm
+ if (graph) {
+ plot(density(nullstats), type = "l", ...)
+ abline(v = realz)
+ }
+ list(z.stat = realz, p = pval)
+}
--- /dev/null
+## 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),
+ PACKAGE = "ape")[[1]]
+ dim(ans) <- c(nr, nr)
+ ans
+}
--- /dev/null
+## mcmc.popsize.R (2004-12-02)
+
+## Run reversible jump MCMC to sample demographic histories
+
+## Copyright 2004 Rainer Opgen-Rhein and Korbinian Strimmer
+
+## Portions of this function are adapted from rjMCMC code by
+## Karl Broman (see http://www.biostat.jhsph.edu/~kbroman/)
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+# public function
+
+# run rjMCMC chain
+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(attr(tree, "class")=="phylo")
+ {ci <- coalescent.intervals(tree)
+ sk1 <- skyline(ci)}
+ else if (attr(tree, "class")=="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){
+ return(mean(sk1$population.size))
+ }
+ prior.height.var<-function(position){
+ return((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
+
+ #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(data,pos,h,b.lin,sk1,ci)
+
+ count.i<-1
+
+ #set progress bar
+ if(progress.bar==TRUE)
+ {
+ X11(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)) {
+
+ #progress bar
+ 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}
+ }
+ 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)
+{
+# print("ht.move")
+ 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(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)
+{
+# print("pos.move")
+ if(length(pos)==3) j <- 2
+ else j <- sample(2:(length(pos)-1),1)
+ newpos <- pos
+ left <- pos[j-1]
+ right <- pos[j+1]
+ newpos[j] <- runif(1,left,right)
+
+ newloglik <- loglik(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)
+{
+# print("birth")
+ 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(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)
+{
+# print("death")
+ # 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(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
+ }
+
+ # Vektor 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
+}
--- /dev/null
+## me.R (2007-07-12)
+
+## Tree Estimation Based on Minimum Evolution Algorithm
+
+## Copyright 2007 Vincent Lefort
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+fastme.bal <- function(X, nni = TRUE)
+{
+ if (is.matrix(X)) X <- as.dist(X)
+ N <- attr(X, "Size")
+ labels <- attr(X, "Labels")
+ if (is.null(labels)) labels <- as.character(1:N)
+ ans <- .C("me_b", as.double(X), as.integer(N), as.character(labels),
+ "", as.integer(nni), PACKAGE = "ape")
+ read.tree(text = ans[[4]])
+}
+
+fastme.ols <- function(X, nni = TRUE)
+{
+ if (is.matrix(X)) X <- as.dist(X)
+ N <- attr(X, "Size")
+ labels <- attr(X, "Labels")
+ if (is.null(labels)) labels <- as.character(1:N)
+ ans <- .C("me_o", as.double(X), as.integer(N), as.character(labels),
+ "", as.integer(nni), PACKAGE = "ape")
+ read.tree(text = ans[[4]])
+}
+
+bionj <- function(X)
+{
+ if (is.matrix(X)) X <- as.dist(X)
+ N <- attr(X, "Size")
+ labels <- attr(X, "Labels")
+ if (is.null(labels)) labels <- as.character(1:N)
+ ans <- .C("bionj", as.double(X), as.integer(N),
+ as.character(labels), "", PACKAGE = "ape")
+ read.tree(text = ans[[4]])
+}
--- /dev/null
+## mlphylo.R (2008-01-03)
+
+## Estimating Phylogenies by Maximum Likelihood
+
+## Copyright 2006-2008 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+logLik.phylo <- function(object, ...) attr(object, "loglik")
+
+deviance.phylo <- function(object, ...) -2*attr(object, "loglik")
+
+AIC.phylo <- function(object, ..., k = 2)
+{
+ np <- length(object$edge.length) +
+ length(attr(object, "rates")) +
+ length(attr(object, "alpha")) +
+ length(attr(object, "invar")) +
+ length(attr(object, "xi"))
+ if (!attr(object, "model") %in% c("JC69", "F81"))
+ np <- np + 3
+ -2*attr(object, "loglik") + k*np
+}
+
+.subst.model <- structure(c(0, 1, 0, 1, 1, 1, 2, 5),
+ names = c("JC69", "K80", "F81", "F84",
+ "HKY85", "T92", "TN93", "GTR"))
+
+mlphylo <-
+ function(x, phy, model = DNAmodel(), search.tree = FALSE,
+ quiet = FALSE, value = NULL, fixed = FALSE)
+{
+ ## not yet generic....
+ if (class(x) != "DNAbin") stop("DNA sequences not in binary format")
+ if (!is.binary.tree(phy))
+ stop("the initial tree must be dichotomous.")
+ if (!quiet && is.rooted(phy)) {
+ warning("the initial tree is rooted: it will be unrooted.")
+ phy <- unroot(phy)
+ }
+ if (is.null(phy$edge.length))
+ stop("the initial tree must have branch lengths.")
+ if (any(phy$edge.length > 1))
+ stop("some branch lengths are greater than one.")
+ phy <- reorder(phy, "pruningwise")
+ if (!quiet) cat("Preparing the sequences...\n")
+ BF <- if (model$model %in% 1:2) rep(0.25, 4) else base.freq(x)
+ if (is.list(x)) x <- as.matrix(x)
+ if (is.null(rownames(x)))
+ stop("DNA sequences have no names") # safe...
+ if (!all(names(x) %in% phy$tip.label))
+ stop("the names of the DNA sequences and the tip labels
+of the tree do not match") # safe here also
+ x <- x[phy$tip.label, ]
+ Y <- prepareDNA(x, model)
+ S <- length(Y$weight)
+ npart <- dim(Y$partition)[2] # the number of overall partitions
+ ## in case of negative branch lengths:
+ phy$edge.length <- abs(phy$edge.length)
+ nb.tip <- length(phy$tip.label)
+ para <- if (Y$npara) rep(1, Y$npara) else 0
+ alpha <- if (Y$nalpha) rep(.5, Y$nalpha) else 0
+ invar <- if (Y$ninvar) rep(0.5, Y$ninvar) else 0
+
+ if (!is.null(value)) {
+ if (para && !is.null(value$rates))
+ para <- value$rates[1:Y$npara]
+ if (alpha && !is.null(value$alpha))
+ alpha <- value$alpha[1:Y$nalpha]
+ if (invar && !is.null(value$invar))
+ invar <- value$invar[1:Y$ninvar]
+ }
+
+ loglik <- 0
+ if (!quiet) cat("Fitting in progress... ")
+ res <- .C("mlphylo_DNAmodel", as.integer(nb.tip), as.integer(S),
+ as.raw(Y$SEQ), as.double(Y$ANC), as.double(Y$w),
+ as.integer(phy$edge[, 1]), as.integer(phy$edge[, 2]),
+ as.double(phy$edge.length), as.integer(npart),
+ as.integer(Y$partition), as.integer(Y$model),
+ as.double(Y$xi), as.double(para), as.integer(Y$npara),
+ as.double(alpha), as.integer(Y$nalpha),
+ as.integer(Y$ncat), as.double(invar), as.integer(Y$ninvar),
+ as.double(BF), as.integer(search.tree), as.integer(fixed),
+ as.double(loglik), NAOK = TRUE, PACKAGE = "ape")
+ if (!quiet) cat("DONE!\n")
+ phy$edge.length = res[[8]]
+ attr(phy, "loglik") <- res[[23]]
+ attr(phy, "npart") <- npart
+ attr(phy, "model") <- names(Y$npara)
+ if (para) attr(phy, "rates") <- res[[13]]
+ if (alpha) attr(phy, "alpha") <- res[[15]]
+ if (invar) attr(phy, "invar") <- res[[18]]
+ if (npart > 1) attr(phy, "xi") <- res[[12]]
+ phy
+}
+
+DNAmodel <- function(model = "K80", partition = 1,
+ ncat.isv = 1, invar = FALSE,
+ equal.isv = TRUE, equal.invar = 1)
+{
+ if (ncat.isv > 10)
+ stop("number of categories for inter-site variation cannot exceed 10")
+ structure(list(model = model, partition = partition,
+ ncat.isv = ncat.isv, invar = invar,
+ equal.isv = equal.isv, equal.invar = equal.invar),
+ class = "DNAmodel")
+}
+
+prepareDNA <- function(X, DNAmodel)
+{
+ L <- dim(X)[2] # already converted as a matrix in mlphylo()
+
+ npart <- length(unique(DNAmodel$partition))
+
+ ## find which substitution model:
+ mo <- which(names(.subst.model) == DNAmodel$model)
+ npara <- .subst.model[mo] # keeps the 'names'
+
+ ## inter-sites variation:
+ nalpha <- as.numeric(DNAmodel$ncat.isv > 1)
+ if (!DNAmodel$equal.isv) nalpha <- npart * nalpha
+
+ ## proportion of invariants:
+ ninvar <- as.numeric(DNAmodel$invar)
+ if (!DNAmodel$equal.invar) ninvar <- npart * ninvar
+
+ SEQ <- weight <- part <- NULL
+
+ ## For each partition...
+ for (i in 1:npart) {
+ ## extracts the sites in this partition:
+ M <- X[, DNAmodel$partition == i, drop = FALSE]
+ ## convert each column as a character string:
+ M <- apply(M, 2, rawToChar)
+ ## get their frequencies:
+ w <- table(M)
+ ## convert back to raw the unique(M):
+ M <- sapply(dimnames(w)[[1]], charToRaw)
+ ## remove useless attributes:
+ colnames(M) <- dimnames(w) <- NULL
+ w <- unclass(w)
+ ## bind everything:
+ SEQ <- cbind(SEQ, M)
+ weight <- c(weight, w)
+ part <- c(part, length(w)) # the length of each partition
+ }
+
+ class(SEQ) <- "DNAbin"
+ ANC <- array(1, c(nrow(SEQ) - 2, ncol(SEQ), 4))
+
+ ## 'partition' gives the start and end of each partition:
+ partition <- matrix(1, 2, npart)
+ partition[2, ] <- cumsum(part)
+ if (npart > 1) {
+ partition[1, 2:npart] <- partition[2, 1:(npart - 1)] + 1
+ partition[2, npart] <- length(weight)
+ xi <- rep(1, npart - 1)
+ } else xi <- 0
+ list(SEQ = SEQ, ANC = ANC, weight = weight, partition = partition,
+ model = mo, xi = xi, npara = npara, nalpha = nalpha,
+ ncat = DNAmodel$ncat.isv, ninvar = ninvar)
+}
--- /dev/null
+## mrca.R (2006-10-12)
+
+## Find Most Recent Common Ancestors Between Pairs
+
+## Copyright 2005-2006 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+mrca <- function(phy, full = FALSE)
+{
+ if (class(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, PACKAGE = "ape")
+ 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
+}
--- /dev/null
+## 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
+}
--- /dev/null
+## multi2di.R (2007-08-02)
+
+## Collapse and Resolve Multichotomies
+
+## Copyright 2005-2007 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]
+ nextnode <- length(phy$tip.label) + 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)
+ reorder(phy)
+ ##read.tree(text = write.tree(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])
+ phy
+}
--- /dev/null
+## nj.R (2006-09-15)
+
+## Neighbor-Joining Tree Estimation
+
+## Copyright 2004-2006 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)
+ N <- attr(X, "Size")
+ labels <- attr(X, "Labels")
+ if (is.null(labels)) labels <- as.character(1:N)
+ edge1 <- edge2 <- integer(2*N - 3)
+ edge.length <- numeric(2*N - 3)
+ ans <- .C("nj", as.double(X), as.integer(N), as.integer(edge1),
+ as.integer(edge2), as.double(edge.length), PACKAGE = "ape")
+ obj <- list(edge = cbind(ans[[3]], ans[[4]]),
+ edge.length = ans[[5]], tip.label = labels)
+ obj$Nnode <- N - 2
+ class(obj) <- "phylo"
+ reorder(obj)
+}
--- /dev/null
+## nodelabels.R (2007-03-05)
+
+## Labelling the Nodes and the Tips of a Tree
+
+## Copyright 2004-2007 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)) {
+ ## browser()
+ stop("floating.pie: x values must be non-negative")
+ }
+ x <- c(0, cumsum(x)/sum(x))
+ dx <- diff(x)
+ nx <- length(dx)
+ if (is.null(col)) col <- rainbow(nx)
+ else if (length(col) < nx) col <- rep(col, nx)
+ bc <- 2 * pi * (x[1:nx] + dx/2) + startpos
+ for (i in 1: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], ...)
+ ## t2p <- 2 * pi * mean(x[i + 0:1]) + startpos
+ ## xc <- cos(t2p) * radius
+ ## yc <- sin(t2p) * radius*asp
+ ## lines(c(1, 1.05) * xc, c(1, 1.05) * yc)
+ }
+ ## return(bc)
+}
+
+BOTHlabels <- function(text, sel, XX, YY, adj, frame, pch, thermo,
+ pie, piecol, col, bg, ...)
+{
+ 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")
+ width <- CEX * (parusr[2] - parusr[1]) / 40
+ height <- CEX * (parusr[4] - parusr[3]) / 15
+ if (is.vector(thermo)) thermo <- cbind(thermo, 1 - thermo)
+ thermo <- height * thermo
+ xl <- XX - width/2
+ xr <- xl + width
+ yb <- YY - height/2
+ if (is.null(piecol)) piecol <- rainbow(ncol(thermo))
+ ## 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])
+ rect(xl, yb, xr, yb + height, border = "black")
+ 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
+ for (i in 1:length(sel))
+ floating.pie.asp(XX[i], YY[i], pie[i, ],
+ radius = xrad, 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", ...)
+{
+ if (missing(node))
+ node <- (.last_plot.phylo$Ntip + 1):length(.last_plot.phylo$xx)
+ XX <- .last_plot.phylo$xx[node]
+ YY <- .last_plot.phylo$yy[node]
+ BOTHlabels(text, node, XX, YY, adj, frame, pch, thermo,
+ pie, piecol, col, bg, ...)
+}
+
+tiplabels <- function(text, tip, adj = c(0.5, 0.5), frame = "rect",
+ pch = NULL, thermo = NULL, pie = NULL, piecol = NULL,
+ col = "black", bg = "yellow", ...)
+{
+ if (missing(tip)) tip <- 1:.last_plot.phylo$Ntip
+ XX <- .last_plot.phylo$xx[tip]
+ YY <- .last_plot.phylo$yy[tip]
+ BOTHlabels(text, tip, XX, YY, adj, frame, pch, thermo,
+ pie, piecol, col, bg, ...)
+}
+
+edgelabels <- function(text, edge, adj = c(0.5, 0.5), frame = "rect",
+ pch = NULL, thermo = NULL, pie = NULL, piecol = NULL,
+ col = "black", bg = "lightgreen", ...)
+{
+ if (missing(edge)) {
+ sel <- 1:dim(.last_plot.phylo$edge)[1]
+ subedge <- .last_plot.phylo$edge
+ } else {
+ sel <- edge
+ subedge <- .last_plot.phylo$edge[sel, , drop = FALSE]
+ }
+ if (.last_plot.phylo$type == "phylogram") {
+ if(.last_plot.phylo$direction %in% c("rightwards", "leftwards")) {
+ XX <- (.last_plot.phylo$xx[subedge[, 1]] +
+ .last_plot.phylo$xx[subedge[, 2]]) / 2
+ YY <- .last_plot.phylo$yy[subedge[, 2]]
+ } else {
+ XX <- .last_plot.phylo$xx[subedge[, 2]]
+ YY <- (.last_plot.phylo$yy[subedge[, 1]] +
+ .last_plot.phylo$yy[subedge[, 2]]) / 2
+ }
+ } else {
+ XX <- (.last_plot.phylo$xx[subedge[, 1]] +
+ .last_plot.phylo$xx[subedge[, 2]]) / 2
+ YY <- (.last_plot.phylo$yy[subedge[, 1]] +
+ .last_plot.phylo$yy[subedge[, 2]]) / 2
+ }
+ BOTHlabels(text, sel, XX, YY, adj, frame, pch, thermo,
+ pie, piecol, col, bg, ...)
+}
--- /dev/null
+## nprs.R (2003-07-11)
+
+## Nonparametric Rate Smoothing Method by Sanderson
+
+## Copyright 2003 Gangolf Jobb and Korbinian Strimmer
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+setTree <-
+ function(lowerNodes,upperNodes,edgeLengths,minEdgeLength,tipLabels)
+ .C(
+ "setTree",
+ as.integer(lowerNodes),
+ as.integer(upperNodes),
+ as.double(edgeLengths),
+ as.double(minEdgeLength),
+ as.integer(length(edgeLengths)),
+ as.character(tipLabels),
+ as.integer(length(tipLabels)),
+ result=integer(1),
+ PACKAGE = "ape"
+ )$result
+
+getNFreeParams <-
+ function()
+ .C(
+ "getNFreeParams",
+ result=integer(1),
+ PACKAGE = "ape"
+ )$result
+
+getNEdges <-
+ function()
+ .C(
+ "getNEdges",
+ result=integer(1),
+ PACKAGE = "ape"
+ )$result
+
+getEdgeLengths <-
+ function()
+ .C(
+ "getEdgeLengths",
+ result=double(getNEdges()),
+ PACKAGE = "ape"
+ )$result
+
+objFuncLogScale <-
+ function(params,expo)
+ .C(
+ "objFuncLogScale",
+ as.double(params),
+ as.integer(expo),
+ result=double(1),
+ PACKAGE = "ape"
+ )$result
+
+getDurations <-
+ function(params,scale)
+ .C(
+ "getDurations",
+ as.double(params),
+ as.double(scale),
+ result=double(getNEdges()),
+ PACKAGE = "ape"
+ )$result
+
+getRates <-
+ function(params,scale)
+ .C(
+ "getRates",
+ as.double(params),
+ as.double(scale),
+ result=double(getNEdges()),
+ PACKAGE = "ape"
+ )$result
+
+getExternalParams <-
+ function()
+ .C(
+ "getExternalParams",
+ result=double(getNFreeParams()),
+ PACKAGE = "ape"
+ )$result
+
+### private functions
+
+prepareTree <- function(phy, minEdgeLength = 1e-06)
+{
+ len <- phy$edge.length
+ if (length(len) > 2048) stop("Only 2048 branches in tree allowed!")
+ low <- phy$edge[, 1] # edges in the tree
+ upp <- phy$edge[, 2]
+ setTree(low, upp, len, minEdgeLength, phy$tip.labels)
+}
+
+optimTree <- function(phy, expo = 2) # call prepareTree first
+{
+ dur <- rep(log(0.5), getNFreeParams() ) # start value
+ objL <- function(d) objFuncLogScale(d, expo)
+ opt <- optim(dur, objL, method = "BFGS")
+ return(opt)
+}
+
+### this is just for testing purposes, to get the tree we are
+### actually using when there are many small branch lengths
+phylogram <- function(phy, ...)
+{
+ if (class(phy) != "phylo") stop("object \"phy\" is not of class \"phylo\"")
+
+ ## added by EP for the new coding of "phylo" (2006-10-04):
+ phy <- new2old.phylo(phy)
+ ## End
+
+ prepareTree(phy, ...)
+ ##opt <- optimTree(phy, ...)
+
+ newTree <- phy
+ newTree$edge.length <- getEdgeLengths()
+
+ ans <- newTree
+ old2new.phylo(ans)
+}
+
+### public functions
+
+chronogram <- function(phy, scale = 1, expo = 2, minEdgeLength = 1e-06)
+{
+ if (class(phy) != "phylo") stop("object \"phy\" is not of class \"phylo\"")
+
+ ## added by EP for the new coding of "phylo" (2006-10-04):
+ phy <- new2old.phylo(phy)
+ ## End
+
+ prepareTree(phy, minEdgeLength = minEdgeLength)
+ opt <- optimTree(phy, expo = expo)
+
+ newTree <- phy
+ newTree$edge.length <- getDurations(opt$par, scale)
+
+ ans <- newTree
+ old2new.phylo(ans)
+}
+
+ratogram <- function(phy, scale = 1, expo = 2, minEdgeLength = 1e-06)
+{
+ if (class(phy) != "phylo")
+ stop("object \"phy\" is not of class \"phylo\"")
+
+ ## added by EP for the new coding of "phylo" (2006-10-04):
+ phy <- new2old.phylo(phy)
+ ## End
+
+ prepareTree(phy, minEdgeLength = minEdgeLength)
+ opt <- optimTree(phy, expo = expo)
+
+ newTree <- phy
+ newTree$edge.length <- getRates(opt$par, scale)
+
+ ans <- newTree
+ old2new.phylo(ans)
+}
+
+NPRS.criterion <- function(phy, chrono, expo = 2, minEdgeLength = 1e-06)
+{
+ if (!is.ultrametric(chrono))
+ stop("tree \"chrono\" is not ultrametric (clock-like)")
+
+ ## added by EP for the new coding of "phylo" (2006-10-04):
+ phy <- new2old.phylo(phy)
+ chrono <- new2old.phylo(chrono)
+ ## End
+
+ prepareTree(chrono, minEdgeLength = minEdgeLength)
+ parms <- getExternalParams()
+ prepareTree(phy, minEdgeLength = minEdgeLength)
+ objFuncLogScale(parms, expo)
+}
--- /dev/null
+## phymltest.R (2005-11-10)
+
+## Fits a Bunch of Models with PHYML
+
+## Copyright 2004-2005 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, path2exec = NULL)
+{
+ windoz <- .Platform$OS.type == "windows"
+ if (missing(execname)) {
+ if (windoz) execname <- "phyml_w32"
+ else stop("you must give an executable file name for PHYML")
+ }
+ outfile <- paste(seqfile, "_phyml_stat.txt", sep = "")
+ inp <- seqfile
+ if (file.exists(outfile)) inp <- c(inp, "A")
+ if (file.exists(paste(seqfile, "_phyml_tree.txt", sep = "")))
+ inp <- c(inp, "A")
+ if (format != "interleaved") inp <- c(inp, "I")
+ if (!is.null(itree)) inp <- c(inp, "U", itree)
+ N <- length(.phymltest.model)
+ input.model <- list(c(rep("M", 5), "Y"),
+ c(rep("M", 5), "V", rep("Y", 2)),
+ c(rep("M", 5), "R", "A", rep("Y", 2)),
+ c(rep("M", 5), "R", "A", "Y", "V", rep("Y", 2)),
+ c(rep("M", 6), "T", rep("Y", 2)),
+ c(rep("M", 6), "T", "Y", "V", rep("Y", 2)),
+ c(rep("M", 6), "T", "Y", "R", "A", rep("Y", 2)),
+ c(rep("M", 6), "T", "Y", "R", "A", "Y", "V", rep("Y", 2)),
+ c(rep("M", 7), "Y"),
+ c(rep("M", 7), "V", rep("Y", 2)),
+ c(rep("M", 7), "R", "A", rep("Y", 2)),
+ c(rep("M", 7), "V", "Y", "R", "A", rep("Y", 2)),
+ c("M", "T", rep("Y", 2)),
+ c("M", "T", "Y", "V", rep("Y", 2)),
+ c("M", "T", "Y", "R", "A", rep("Y", 2)),
+ c("M", "T", "Y", "V", "Y", "R", "A", rep("Y", 2)),
+ c("T", rep("Y", 2)),
+ c("T", "Y", "V", rep("Y", 2)),
+ c("T", "Y", "R", "A", rep("Y", 2)),
+ c("T", "Y", "V", "Y", "R", "A", rep("Y", 2)),
+ c(rep("M", 2), "T", rep("Y", 2)),
+ c(rep("M", 2), "T", "Y", "V", rep("Y", 2)),
+ c(rep("M", 2), "T", "Y", "R", "A", rep("Y", 2)),
+ c(rep("M", 2), "T", "Y", "R", "A", "Y", "V", rep("Y", 2)),
+ c(rep("M", 3), "Y"),
+ c(rep("M", 3), "V", rep("Y", 2)),
+ c(rep("M", 3), "R", "A", rep("Y", 2)),
+ c(rep("M", 3), "V", "Y", "R", "A", rep("Y", 2)))
+ loglik <- numeric(N)
+ names(input.model) <- names(loglik) <- .phymltest.model
+ if (is.null(path2exec)) exec <- execname
+ else exec <- paste(path2exec, execname, sep = "/")
+ imod <- if (is.null(exclude)) 1:N else (1:N)[!.phymltest.model %in% exclude]
+ for (i in imod) {
+ if (i == 2) {
+ if (length(inp) == 1) inp <- c(inp, rep("A", 2))
+ else if (inp[2] != "A") inp <- c(inp[1], rep("A", 2), inp[2:length(inp)])
+ }
+ if (windoz) system(exec, input = c(inp, input.model[[i]]))
+ else {
+ cat(c(inp, input.model[[i]]), file = "f", sep = "\n")
+ system(paste(exec, "f", sep = " < "))
+ }
+ loglik[i] <- scan(paste(seqfile, "_phyml_lk.txt", sep = ""), quiet = TRUE)
+ }
+ unlink("f")
+ loglik <- loglik[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)
+}
--- /dev/null
+## pic.R (2006-10-29)
+
+## Phylogenetically Independent Contrasts
+
+## Copyright 2002-2006 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)
+{
+ if (class(phy) != "phylo")
+ stop("object 'phy' is not of class \"phylo\"")
+ if (is.null(phy$edge.length))
+ stop("your tree has no branch lengths: you may consider setting them equal to one, or using the function `compute.brlen'.")
+ 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("the present method cannot (yet) be used directly with missing data: you may consider removing the species with missing data from your tree with the function `drop.tip'.")
+
+ phy <- reorder(phy, "pruningwise")
+ 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.
+ contr <- var.con <- numeric(nb.node)
+
+ ans <- .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(var.contrasts), as.integer(scaled),
+ PACKAGE = "ape")
+
+ ## The "old" R code:
+ ##for (i in seq(from = 1, by = 2, length.out = nb.node)) {
+ ## j <- i + 1
+ ## anc <- phy$edge[i, 1]
+ ## des1 <- phy$edge[i, 2]
+ ## des2 <- phy$edge[j, 2]
+ ## sumbl <- bl[i] + bl[j]
+ ## ic <- anc - nb.tip
+ ## contr[ic] <- phenotype[des1] - phenotype[des2]
+ ## if (scaled) contr[ic] <- contr[ic]/sqrt(sumbl)
+ ## if (var.contrasts) var.con[ic] <- sumbl
+ ## phenotype[anc] <- (phenotype[des1]*bl[j] + phenotype[des2]*bl[i])/sumbl
+ ## k <- which(phy$edge[, 2] == anc)
+ ## bl[k] <- bl[k] + bl[i]*bl[j]/sumbl
+ ##
+ ##}
+ contr <- ans[[7]]
+ if (var.contrasts) {
+ contr <- cbind(contr, ans[[8]])
+ dimnames(contr) <- list(1:nb.node + nb.tip, c("contrasts", "variance"))
+ } else names(contr) <- 1:nb.node + nb.tip
+ contr
+}
--- /dev/null
+## plot.ancestral.R (2005-12-04)
+
+## Plotting Ancestral Characters on a Tree
+
+## Copyright 2005 Julien Dutheil
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+plot.ancestral <- function(x, which=names(x$node.character),
+ n.col=10, col.fun=function(n) rainbow(n, start=0.4, end=0),
+ plot.node.values=FALSE,
+ ask = prod(par("mfcol")) < length(which) && dev.interactive(),
+ ...)
+{
+ if (!("ancestral" %in% class(x)))
+ stop("object \"phy\" is not of class \"ancestral\"")
+ states <- rbind(x$node.character, x$tip.character)
+ cols <- col.fun(n.col)
+ if(ask) {
+ op <- par(ask = TRUE)
+ on.exit(par(op))
+ }
+ for(state in which) {
+ a <- states[x$edge[,2],state]
+ b <- round((n.col-1)*(a-min(a))/(max(a)-min(a)))+1
+ if(plot.node.values) {
+ x$node.label <- x$node.character[,state]
+ plot.phylo(x, edge.color=cols[b], show.node.label=TRUE, sub=state, ...)
+ } else {
+ plot.phylo(x, edge.color=cols[b], sub=state, ...)
+ }
+ }
+}
--- /dev/null
+## plot.phylo.R (2007-12-22)
+
+## Plot Phylogenies
+
+## Copyright 2002-2007 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, 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", ...)
+{
+ 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
+ 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
+ if (type == "unrooted" || !use.edge.length) root.edge <- FALSE
+ phyloORclado <- type %in% c("phylogram", "cladogram")
+ horizontal <- direction %in% c("rightwards", "leftwards")
+ if (phyloORclado) {
+ ## we first compute the y-coordinates of the tips.
+ ## Fix from Klaus Schliep (2007-06-16):
+ if (!is.null(attr(x, "order")))
+ if (attr(x, "order") == "pruningwise")
+ x <- reorder(x)
+ ## End of fix
+ yy <- numeric(Ntip + Nnode)
+ TIPS <- x$edge[x$edge[, 2] <= Ntip, 2]
+ yy[TIPS] <- 1:Ntip
+ }
+ edge.color <- rep(edge.color, length.out = Nedge)
+ edge.width <- rep(edge.width, length.out = Nedge)
+ ## fix from Li-San Wang (2007-01-23):
+ xe <- x$edge
+ x <- reorder(x, order = "pruningwise")
+ ereorder <- match(x$edge[, 2], xe[, 2])
+ edge.color <- edge.color[ereorder]
+ edge.width <- edge.width[ereorder]
+ ## End of fix
+ 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),
+ DUP = FALSE, PACKAGE = "ape")[[6]]
+ 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(x$edge[, 1]),
+ as.integer(x$edge[, 2]), as.integer(Nedge),
+ double(Ntip + Nnode), as.double(yy),
+ DUP = FALSE, 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),
+ DUP = FALSE, 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),
+ DUP = FALSE, PACKAGE = "ape")[[7]]
+ }
+ }
+ if (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 <- 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))
+ ## rescale so that we have only positive values
+ 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
+ ## radius:
+ X <- 1 - X/Ntip
+ ## angle (1st compute the angles for the tips):
+ 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)
+ }
+ }
+ }
+ if (phyloORclado && 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)
+ tmp <-
+ if (show.tip.label) nchar(x$tip.label) * 0.018 * max(xx) * cex
+ else 0
+ x.lim[2] <-
+ if (direction == "leftwards") max(xx[ROOT] + tmp)
+ else max(xx[1:Ntip] + tmp)
+ } else x.lim <- c(1, Ntip)
+ }
+ if (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))
+ }
+ if (type == "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))
+ }
+ if (type == "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
+ }
+ if (is.null(y.lim)) {
+ if (phyloORclado) {
+ if (horizontal) y.lim <- c(1, Ntip) else {
+ y.lim <- c(0, NA)
+ tmp <-
+ if (show.tip.label) nchar(x$tip.label) * 0.018 * max(yy) * cex
+ else 0
+ y.lim[2] <-
+ if (direction == "downwards") max(yy[ROOT] + tmp)
+ else max(yy[1:Ntip] + tmp)
+ }
+ }
+ if (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))
+ }
+ if (type == "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))
+ }
+ if (type == "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
+ }
+ 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
+ }
+
+ plot(0, type = "n", xlim = x.lim, ylim = y.lim, xlab = "",
+ ylab = "", xaxt = "n", yaxt = "n", bty = "n", ...)
+ if (is.null(adj))
+ adj <- if (phyloORclado && direction == "leftwards") 1 else 0
+ if (phyloORclado) {
+ MAXSTRING <- max(strwidth(x$tip.label, cex = cex))
+ if (direction == "rightwards") {
+ lox <- label.offset + MAXSTRING * 1.05 * adj
+ loy <- 0
+ }
+ if (direction == "leftwards") {
+ lox <- -label.offset - MAXSTRING * 1.05 * (1 - adj)
+ loy <- 0
+ 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)
+ } else {
+ if (type == "fan")
+ circular.plot(x$edge, Ntip, Nnode, xx, yy, theta,
+ r, edge.color, edge.width)
+ else
+ cladogram.plot(x$edge, xx, yy, edge.color, edge.width)
+ }
+ 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 (!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 <- as.numeric(abs(XY$axe) > pi/2)
+ srt <- 180*XY$axe/pi
+ srt[as.logical(adj)] <- srt[as.logical(adj)] - 180
+ ## <FIXME> temporary check of the values of `srt':
+ ## set to 0 if "-0.000001 < srt < 0"
+ sel <- srt > -1e-6 & srt < 0
+ if (any(sel)) srt[sel] <- 0
+ ## </FIXME>
+ ## `srt' takes only a single value, so we cannot vectorize this:
+ for (i in 1:Ntip)
+ text(xx[i], yy[i], cex = cex, x$tip.label[i], adj = adj[i],
+ font = font, srt = srt[i], col = tip.color[i])
+ }
+ }
+ if (type %in% c("fan", "radial")) {
+ xx.scaled <- xx[1:Ntip]
+ if (type == "fan") { # no need if type == "radial"
+ maxx <- max(xx.scaled)
+ if (maxx > 1) xx.scaled <- xx.scaled/maxx
+ }
+ angle <- acos(xx.scaled)*180/pi
+ s1 <- angle > 90 & yy[1:Ntip] > 0
+ s2 <- angle < 90 & yy[1:Ntip] < 0
+ s3 <- angle > 90 & yy[1:Ntip] < 0
+ angle[s1] <- angle[s1] + 180
+ angle[s2] <- -angle[s2]
+ angle[s3] <- 180 - angle[s3]
+ adj <- numeric(Ntip)
+ adj[xx[1:Ntip] < 0] <- 1
+ ## `srt' takes only a single value, so we cannot vectorize this:
+ for (i in 1:Ntip)
+ text(xx[i], yy[i], x$tip.label[i], font = font, cex = cex,
+ 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, 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)
+ .last_plot.phylo <<- c(L, list(edge = xe, xx = xx, yy = yy))
+ invisible(L)
+}
+
+phylogram.plot <- function(edge, Ntip, Nnode, xx, yy,
+ horizontal, edge.color, edge.width)
+{
+ nodes <- (Ntip + 1):(Ntip + Nnode)
+ if (!horizontal) {
+ tmp <- yy
+ yy <- xx
+ xx <- tmp
+ }
+ ## un trait vertical à chaque noeud...
+ x0v <- xx[nodes]
+ y0v <- y1v <- numeric(Nnode)
+ for (i in nodes) {
+ j <- edge[which(edge[, 1] == i), 2]
+ y0v[i - Ntip] <- min(yy[j])
+ y1v[i - Ntip] <- max(yy[j])
+ }
+ ## ... et un trait horizontal partant de chaque tip et chaque noeud
+ ## vers la racine
+ sq <- if (Nnode == 1) 1:Ntip else c(1:Ntip, nodes[-1])
+ y0h <- yy[sq]
+ x1h <- xx[sq]
+ ## match() is very useful here becoz each element in edge[, 2] is
+ ## unique (not sure this is so useful in edge[, 1]; needs to be checked)
+ ## `pos' gives for each element in `sq' its index in edge[, 2]
+ pos <- match(sq, edge[, 2])
+ x0h <- xx[edge[pos, 1]]
+
+ e.w <- unique(edge.width)
+ if (length(e.w) == 1) width.v <- rep(e.w, Nnode)
+ else {
+ width.v <- rep(1, Nnode)
+ for (i in 1:Nnode) {
+ br <- edge[which(edge[, 1] == i + Ntip), 2]
+ width <- unique(edge.width[br])
+ if (length(width) == 1) width.v[i] <- width
+ }
+ }
+ e.c <- unique(edge.color)
+ if (length(e.c) == 1) color.v <- rep(e.c, Nnode)
+ else {
+ color.v <- rep("black", Nnode)
+ for (i in 1:Nnode) {
+ br <- which(edge[, 1] == i + Ntip)
+ #br <- edge[which(edge[, 1] == i + Ntip), 2]
+ color <- unique(edge.color[br])
+ if (length(color) == 1) color.v[i] <- color
+ }
+ }
+
+ ## we need to reorder `edge.color' and `edge.width':
+ edge.width <- edge.width[pos]
+ edge.color <- edge.color[pos]
+ if (horizontal) {
+ segments(x0v, y0v, x0v, y1v, col = color.v, lwd = width.v) # draws vertical lines
+ segments(x0h, y0h, x1h, y0h, col = edge.color, lwd = edge.width) # draws horizontal lines
+ } else {
+ segments(y0v, x0v, y1v, x0v, col = color.v, lwd = width.v) # draws horizontal lines
+ segments(y0h, x0h, y0h, x1h, col = edge.color, lwd = edge.width) # draws vertical lines
+ }
+}
+
+cladogram.plot <- function(edge, xx, yy, edge.color, edge.width)
+ segments(xx[edge[, 1]], yy[edge[, 1]], xx[edge[, 2]], yy[edge[, 2]],
+ col = edge.color, lwd = edge.width)
+
+circular.plot <- function(edge, Ntip, Nnode, xx, yy, theta,
+ r, edge.color, edge.width)
+{
+ r0 <- r[edge[, 1]]
+ r1 <- r[edge[, 2]]
+ theta0 <- theta[edge[, 2]]
+
+ x0 <- r0*cos(theta0)
+ y0 <- r0*sin(theta0)
+ x1 <- r1*cos(theta0)
+ y1 <- r1*sin(theta0)
+
+ segments(x0, y0, x1, y1, col = edge.color, lwd = edge.width)
+
+ tmp <- which(diff(edge[, 1]) != 0)
+ start <- c(1, tmp + 1)
+ end <- c(tmp, dim(edge)[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)
+ co <- if (edge.color[i] == edge.color[j]) edge.color[i] else "black"
+ lw <- if (edge.width[i] == edge.width[j]) edge.width[i] else 1
+ lines(X*cos(Y), X*sin(Y), col = co, lwd = lw)
+ }
+}
+
+unrooted.xy <- function(Ntip, Nnode, edge, edge.length)
+{
+ 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])
+ }
+ root <- Ntip + 1
+ Nedge <- dim(edge)[1]
+ yy <- xx <- numeric(Ntip + Nnode)
+ nb.sp <- .C("node_depth", as.integer(Ntip), as.integer(Nnode),
+ as.integer(edge[, 1]), as.integer(edge[, 2]),
+ as.integer(Nedge), double(Ntip + Nnode),
+ DUP = FALSE, PACKAGE = "ape")[[6]]
+ ## `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...
+ ## xx[root] <- yy[root] <- 0 # already set!
+ foo(root, 2*pi, 0)
+
+ 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)
+{
+ n <- length(phy$tip.label)
+ m <- phy$Nnode
+ N <- dim(phy$edge)[1]
+ phy <- reorder(phy, order = "pruningwise")
+ .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), DUP = FALSE, PACKAGE = "ape")[[6]]
+}
+
+plot.multiPhylo <- function(x, layout = 1, ...)
+{
+ if (layout > 1)
+ layout(matrix(1:layout, ceiling(sqrt(layout)), byrow = TRUE))
+ if (!par("ask")) {
+ par(ask = TRUE)
+ on.exit(par(ask = FALSE))
+ }
+ for (i in x) plot(i, ...)
+}
--- /dev/null
+## 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], ...)
+}
--- /dev/null
+## read.GenBank.R (2007-06-27)
+
+## Read DNA Sequences from GenBank via Internet
+
+## Copyright 2002-2007 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, 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", sep = "")
+ X <- c(X, scan(file = URL, what = "", sep = "\n", quiet = TRUE))
+ }
+ FI <- grep("^ {0,}ORIGIN", X) + 1
+ LA <- which(X == "//") - 1
+ obj <- list()
+ length(obj) <- 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)
+ }
+ obj
+}
--- /dev/null
+## 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)
+}
--- /dev/null
+## read.dna.R (2007-05-01)
+
+## Read DNA Sequences in a File
+
+## Copyright 2003-2007 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+read.dna <- function(file, format = "interleaved", skip = 0,
+ nlines = 0, comment.char = "#", seq.names = NULL,
+ as.character = FALSE)
+{
+ getTaxaNames <- function(x) {
+ x <- sub("^ +", "", x) # remove the leading spaces
+ x <- sub(" +$", "", x) # remove the trailing spaces
+ x <- sub("^['\"]", "", x) # remove the leading quotes
+ x <- sub("['\"]$", "", x) # remove the trailing quotes
+ x
+ }
+ format <- match.arg(format, c("interleaved", "sequential", "fasta"))
+ phylip <- if (format %in% c("interleaved", "sequential")) TRUE else FALSE
+ X <- scan(file = file, what = character(), sep = "\n", quiet = TRUE,
+ skip = skip, nlines = nlines, comment.char = comment.char)
+ if (phylip) {
+ fl <- X[1]
+ oop <- options(warn = -1)
+ ## need to remove the possible leading spaces in the first line
+ fl.num <- as.numeric(unlist(strsplit(gsub("^ +", "", fl), " +")))
+ options(oop)
+ if (all(is.na(fl.num)))
+ stop("the first line of the file must contain the dimensions of the data")
+ if (length(fl.num) != 2)
+ stop("the first line of the file must contain TWO numbers")
+ else {
+ n <- fl.num[1]
+ s <- fl.num[2]
+ }
+ X <- X[-1]
+ obj <- vector("character", n*s)
+ dim(obj) <- c(n, s)
+ }
+ if (format == "interleaved") {
+ fl <- X[1]
+ fl <- unlist(strsplit(fl, NULL))
+ bases <- grep("[-AaCcGgTtUuMmRrWwSsYyKkVvHhDdBbNn]", fl)
+ z <- diff(bases)
+ for (i in 1:length(z)) if (all(z[i:(i + 8)] == 1)) break
+ start.seq <- bases[i]
+ if (is.null(seq.names))
+ seq.names <- getTaxaNames(substr(X[1:n], 1, start.seq - 1))
+ X[1:n] <- substr(X[1:n], start.seq, nchar(X[1:n]))
+ X <- gsub(" ", "", X)
+ nl <- length(X)
+ for (i in 1:n)
+ obj[i, ] <- unlist(strsplit(X[seq(i, nl, n)], NULL))
+ }
+ if (format == "sequential") {
+ fl <- X[1]
+ taxa <- character(n)
+ j <- 1
+ for (i in 1:n) {
+ bases <- grep("[-AaCcGgTtUuMmRrWwSsYyKkVvHhDdBbNn]",
+ unlist(strsplit(X[j], NULL)))
+ z <- diff(bases)
+ for (k in 1:length(z)) if (all(z[k:(k + 8)] == 1)) break
+ start.seq <- bases[k]
+ taxa[i] <- substr(X[j], 1, start.seq - 1)
+ sequ <- substr(X[j], start.seq, nchar(X[j]))
+ sequ <- gsub(" ", "", sequ)
+ j <- j + 1
+ while (nchar(sequ) < s) {
+ sequ <- paste(sequ, gsub(" " , "", X[j]), sep = "")
+ j <- j + 1
+ }
+ obj[i, ] <- unlist(strsplit(sequ, NULL))
+ }
+ if (is.null(seq.names)) seq.names <- getTaxaNames(taxa)
+ }
+ if (format == "fasta") {
+ start <- grep("^ {0,}>", X)
+ taxa <- X[start]
+ n <- length(taxa)
+ obj <- vector("list", n)
+ if (is.null(seq.names)) {
+ taxa <- sub("^ {0,}>", "", taxa) # remove the hook and the spaces before
+ seq.names <- getTaxaNames(taxa)
+ }
+ start <- c(start, length(X) + 1) # this avoids the following to crash when `i = n'
+ for (i in 1:n)
+ obj[[i]] <- unlist(strsplit(gsub(" ", "",
+ X[(start[i] + 1):(start[i + 1] - 1)]),
+ NULL))
+ }
+ if (phylip) {
+ rownames(obj) <- seq.names
+ obj <- tolower(obj)
+ } else {
+ names(obj) <- seq.names
+ obj <- lapply(obj, tolower)
+ }
+ if (!as.character) obj <- as.DNAbin(obj)
+ obj
+}
--- /dev/null
+## read.nexus.R (2007-12-22)
+
+## Read Tree File in Nexus Format
+
+## Copyright 2003-2007 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+clado.build <- function(tp) {
+ add.internal <- function() {
+ edge[j, 1] <<- current.node
+ node <<- node + 1
+ edge[j, 2] <<- current.node <<- node
+ j <<- j + 1
+ }
+ add.terminal <- function() {
+ edge[j, 1] <<- current.node
+ edge[j, 2] <<- tip
+ tip.label[tip] <<- tpc[k]
+ k <<- k + 1
+ tip <<- tip + 1
+ j <<- j + 1
+ }
+ go.down <- function() {
+ l <- which(edge[, 2] == 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 (length(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 #
+
+ ## 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
+ }
+ }
+# if(node.label[1] == "NA") node.label[1] <- ""
+ 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"
+ return(obj)
+}
+
+read.nexus <- function(file, tree.names = NULL)
+{
+ X <- scan(file = file, what = character(), sep = "\n", quiet = TRUE)
+ ## first remove all the comments
+ LEFT <- grep("\\[", X)
+ RIGHT <- grep("\\]", X)
+ if (length(LEFT)) {
+ for (i in length(LEFT):1) {
+ if (LEFT[i] == RIGHT[i]) {
+ X[LEFT[i]] <- gsub("\\[.*\\]", "", X[LEFT[i]])
+ } else {
+ X[LEFT[i]] <- gsub("\\[.*", "", X[LEFT[i]])
+ X[RIGHT[i]] <- gsub(".*\\]", "", X[RIGHT[i]])
+ if (LEFT[i] < RIGHT[i] - 1) X <- X[-((LEFT[i] + 1):(RIGHT[i] - 1))]
+ }
+ }
+ }
+ X <- gsub("ENDBLOCK;", "END;", X, ignore.case = TRUE)
+ endblock <- grep("END;", X, ignore.case = TRUE)
+ semico <- grep(";", X)
+ i1 <- grep("BEGIN TREES;", X, ignore.case = TRUE)
+ i2 <- grep("TRANSLATE", X, ignore.case = TRUE)
+ translation <- FALSE
+ if (length(i2) == 1) if (i2 > i1) translation <- TRUE
+ if (translation) {
+ end <- semico[semico > i2][1]
+ x <- paste(X[i2:end], sep = "", collapse = "")
+ x <- gsub("TRANSLATE", "", x, ignore.case = TRUE)
+ x <- unlist(strsplit(x, "[,; \t]"))
+ x <- x[x != ""]
+ TRANS <- matrix(x, ncol = 2, byrow = TRUE)
+ TRANS[, 2] <- gsub("['\"]", "", TRANS[, 2])
+ }
+ start <- if (translation) semico[semico > i2][1] + 1 else semico[semico > i1][1]
+ end <- endblock[endblock > i1][1] - 1
+ tree <- paste(X[start:end], sep = "", collapse = "")
+ tree <- gsub(" ", "", tree)
+ tree <- unlist(strsplit(tree, "[=;]"))
+ tree <- tree[grep("[\\(\\)]", tree)]
+ nb.tree <- length(tree)
+ STRING <- as.list(tree)
+ trees <- list()
+ for (i in 1:nb.tree) {
+ obj <- if (length(grep(":", STRING[[i]]))) tree.build(STRING[[i]]) else clado.build(STRING[[i]])
+ if (translation) {
+ for (j in 1:length(obj$tip.label)) {
+ ind <- which(obj$tip.label[j] == TRANS[, 1])
+ obj$tip.label[j] <- TRANS[ind, 2]
+ }
+ if (!is.null(obj$node.label)) {
+ for (j in 1:length(obj$node.label)) {
+ ind <- which(obj$node.label[j] == TRANS[, 1])
+ obj$node.label[j] <- TRANS[ind, 2]
+ }
+ }
+ }
+ ## 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$tip.label) + 1
+ if (sum(obj$edge[, 1] == ROOT) == 1 && dim(obj$edge)[1] > 1) {
+ stop(paste("There is apparently two root edges in your file: cannot read tree file.\n Reading NEXUS file aborted at tree no.", i, sep = ""))
+ }
+ trees[[i]] <- obj
+ }
+ if (nb.tree == 1) trees <- trees[[1]] else {
+ names(trees) <- if (is.null(tree.names))
+ paste("tree", 1:nb.tree, sep = "") else tree.names
+ class(trees) <- "multiPhylo"
+ }
+ if (length(grep("[\\/]", file)) == 1) attr(trees, "origin") <- file
+ else attr(trees, "origin") <- paste(getwd(), file, sep = "/")
+ trees
+}
--- /dev/null
+"read.nexus.data" <- function (file)
+{
+ # Simplified NEXUS data parser.
+ #
+ # Version: 09/13/2006 01:01:59 PM CEST
+ #
+ # 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)
+ }
+
+ if(file.access(file, mode = 4)) {
+ stop("file could not be found")
+ }
+
+ 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
+}
+
--- /dev/null
+## read.tree.R (2007-12-22)
+
+## Read Tree Files in Parenthetic Format
+
+## Copyright 2002-2007 Emmanuel Paradis
+
+## 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 + 1
+ j <<- j + 1
+ }
+ add.terminal <- function() {
+ edge[j, 1] <<- current.node
+ edge[j, 2] <<- tip
+ X <- unlist(strsplit(tpc[k], ":"))
+ tip.label[tip] <<- X[1]
+ edge.length[j] <<- as.numeric(X[2])
+ k <<- k + 1
+ tip <<- tip + 1
+ j <<- j + 1
+ }
+ go.down <- function() {
+ l <- which(edge[, 2] == current.node)
+ X <- unlist(strsplit(tpc[k], ":"))
+ node.label[current.node - nb.tip] <<- X[1]
+ edge.length[l] <<- as.numeric(X[2])
+ k <<- k + 1
+ current.node <<- edge[l, 1]
+ }
+ if (!length(grep(",", tp))) {
+ obj <- list(edge = matrix(c(2, 1), 1, 2))
+ tp <- unlist(strsplit(tp, "[\\(\\):;]"))
+ obj$edge.length <- as.numeric(tp[3])
+ obj$Nnode <- 1
+ obj$tip.label <- tp[2]
+ if (length(tp) == 4) obj$node.label <- tp[4]
+ class(obj) <- "phylo"
+ return(obj)
+ }
+ tsp <- unlist(strsplit(tp, NULL))
+ tpc <- unlist(strsplit(tp, "[\\(\\),;]"))
+ tpc <- tpc[tpc != ""]
+ skeleton <- tsp[tsp == "(" | tsp == ")" | tsp == "," | tsp == ";"]
+ 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(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 #
+
+ ## 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
+ }
+ }
+ if (is.na(node.label[1])) node.label[1] <- ""
+ edge <- edge[-nb.edge, ]
+ root.edge <- edge.length[nb.edge]
+ edge.length <- edge.length[-nb.edge]
+ obj <- list(edge = edge, edge.length = edge.length, Nnode = nb.node,
+ tip.label = tip.label, node.label = node.label,
+ root.edge = root.edge)
+ if (all(obj$node.label == "")) obj$node.label <- NULL
+ if (is.na(obj$root.edge)) obj$root.edge <- NULL
+ if (all(is.na(obj$edge.length))) obj$edge.length <- NULL # added 2005-08-18
+ class(obj) <- "phylo"
+ obj
+}
+
+read.tree <- function(file = "", text = NULL, tree.names = NULL,
+ skip = 0, comment.char = "#", ...)
+{
+ if (!is.null(text)) {
+ if (!is.character(text))
+ stop("argument `text' must be of mode character")
+ tree <- text
+ } else {
+ tree <- scan(file = file, what = character(), 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)
+ tsp <- unlist(strsplit(tree, NULL))
+ ind <- which(tsp == ";")
+ nb.tree <- length(ind)
+ x <- c(1, ind[-nb.tree] + 1)
+ y <- ind - 1
+ ## Suggestion from Olivier François (added 2006-07-15):
+ if (is.na(y[1])) return(NULL)
+ else {
+ STRING <- vector("list", nb.tree)
+ for (i in 1:nb.tree)
+ STRING[[i]] <- paste(tsp[x[i]:y[i]], sep = "", collapse = "")
+ }
+ obj <- vector("list", nb.tree)
+ for (i in 1:nb.tree) {
+ obj[[i]] <- if (length(grep(":", STRING[[i]]))) tree.build(STRING[[i]]) else clado.build(STRING[[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
+ ROOT <- length(obj[[i]]$tip.label) + 1
+ if(sum(obj[[i]]$edge[, 1] == ROOT) == 1 && dim(obj[[i]]$edge)[1] > 1) {
+ stop(paste("There is apparently two root edges in your file: cannot read tree file.\n Reading Newick file aborted at tree no.", i, sep = ""))
+ }
+ }
+ if (nb.tree == 1) obj <- obj[[1]] else {
+ if (is.null(tree.names))
+ tree.names <- paste("tree", 1:nb.tree, sep = "")
+ names(obj) <- tree.names
+ class(obj) <- "multiPhylo"
+ }
+ obj
+}
--- /dev/null
+## reorder.phylo.R (2007-06-16)
+
+## Internal Reordering of Trees
+
+## Copyright 2006-2007 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+reorder.phylo <- function(x, order = "cladewise", ...)
+{
+ order <- match.arg(order, c("cladewise", "pruningwise"))
+ if (!is.null(attr(x, "order")))
+ if (attr(x, "order") == order) return(x)
+ nb.tip <- length(x$tip.label)
+ nb.node <- x$Nnode
+ nb.edge <- dim(x$edge)[1]
+ neworder <- if (order == "cladewise")
+ .C("neworder_cladewise", as.integer(nb.tip),
+ as.integer(x$edge[, 1]), as.integer(x$edge[, 2]),
+ as.integer(nb.edge), integer(nb.edge),
+ PACKAGE = "ape")[[5]]
+ else
+ .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), PACKAGE = "ape")[[6]]
+ x$edge <- x$edge[neworder, ]
+ if (!is.null(x$edge.length))
+ x$edge.length <- x$edge.length[neworder]
+ attr(x, "order") <- order
+ x
+}
--- /dev/null
+## root.R (2007-12-21)
+
+## Root of Phylogenetic Trees
+
+## Copyright 2004-2007 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+is.rooted <- function(phy)
+{
+ if (!"phylo" %in% class(phy))
+ stop('object "phy" is not of class "phylo"')
+ if (!is.null(phy$root.edge)) return(TRUE)
+ else
+ if (tabulate(phy$edge[, 1])[length(phy$tip.label) + 1] > 2)
+ return(FALSE)
+ else return(TRUE)
+}
+
+unroot <- function(phy)
+{
+ if (class(phy) != "phylo")
+ stop('object "phy" is not of class "phylo"')
+ if (dim(phy$edge)[1] < 3)
+ stop("cannot unroot a tree with two 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)
+ ## 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).
+ nb.tip <- length(phy$tip.label)
+ ROOT <- nb.tip + 1
+ EDGEROOT <- which(phy$edge[, 1] == ROOT)
+ ## j: the target where to stick the edge
+ ## i: the edge to delete
+ if (phy$edge[EDGEROOT[1], 2] == ROOT + 1) {
+ j <- EDGEROOT[2]
+ i <- EDGEROOT[1]
+ } else {
+ j <- EDGEROOT[1]
+ i <- EDGEROOT[2]
+ }
+ ## This should work whether the tree is in pruningwise or
+ ## cladewise order.
+ phy$edge <- phy$edge[-i, ]
+ nodes <- phy$edge > ROOT # renumber all nodes except the root
+ phy$edge[nodes] <- phy$edge[nodes] - 1
+ if (!is.null(phy$edge.length)) {
+ phy$edge.length[j] <- phy$edge.length[j] + phy$edge.length[i]
+ phy$edge.length <- phy$edge.length[-i]
+ }
+ phy$Nnode <- phy$Nnode - 1
+ if (!is.null(phy$node.label))
+ phy$node.label <- phy$node.label[-2]
+ phy
+}
+
+root <- function(phy, outgroup)
+{
+ if (class(phy) != "phylo")
+ stop('object "phy" is not of class "phylo"')
+ if (is.character(outgroup))
+ outgroup <- which(phy$tip.label %in% outgroup)
+ nb.tip <- length(phy$tip.label)
+ if (length(outgroup) == nb.tip) return(phy)
+
+ ## First check that the outgroup is monophyletic--
+ ## unless there's only one tip specified of course
+ ROOT <- nb.tip + 1
+ if (length(outgroup) > 1) {
+ msg <- "the specified outgroup is not monophyletic!"
+ ## If all tips in `tip' are not contiguous, then
+ ## no need to go further:
+ if (!all(diff(outgroup) == 1)) stop(msg)
+ seq.nod <- .Call("seq_root2tip", phy$edge, nb.tip,
+ phy$Nnode, PACKAGE = "ape")
+ sn <- seq.nod[outgroup]
+ ## We go from the root to the tips: the sequence of nodes
+ ## is identical until the MRCA:
+ newroot <- ROOT
+ i <- 2 # we start at the 2nd position since the root
+ # of the tree is a common ancestor to all tips
+ repeat {
+ x <- unique(unlist(lapply(sn, "[", i)))
+ if (length(x) != 1) break
+ newroot <- x
+ i <- i + 1
+ }
+ ## Check that all descendants of this node
+ ## are included in the outgroup
+ ## (1st solution... there may be something smarter)
+ desc <- which(unlist(lapply(seq.nod,
+ function(x) any(x %in% newroot))))
+ if (length(outgroup) != length(desc)) stop(msg)
+ if (!all(sort(outgroup) == sort(desc))) stop(msg)
+
+ } else newroot <- phy$edge[which(phy$edge[, 2] == outgroup), 1]
+
+ if (newroot == ROOT) return(phy)
+
+### <FIXME>
+### The remaining part of the code has not been improved; this
+### does not seem obvious. This is delayed... (2006-09-23)
+### </FIXME>
+
+ ## Invert all branches from the new root to the old one
+ i <- which(phy$edge[, 2] == newroot)
+ nod <- phy$edge[i, 1]
+ while (nod != ROOT) {
+ j <- which(phy$edge[, 2] == nod)
+ phy$edge[i, 1] <- phy$edge[i, 2]
+ phy$edge[i, 2] <- nod
+ i <- j
+ nod <- phy$edge[i, 1]
+ }
+
+ i.oroot <- which(phy$edge[, 1] == ROOT)
+ ## Unroot the tree if there's a basal dichotomy...
+ if (length(i.oroot) == 2) {
+ j <- i.oroot[which(i.oroot != i)]
+ phy$edge[j, 1] <- phy$edge[i, 2]
+ phy$edge <- phy$edge[-i, ]
+ if (!is.null(phy$edge.length)) {
+ phy$edge.length[j] <- phy$edge.length[j] + phy$edge.length[i]
+ phy$edge.length <- phy$edge.length[-i]
+ }
+ phy$edge[which(phy$edge == newroot)] <- ROOT
+ } else {
+ ## ... otherwise just invert the root with the newroot
+ phy$edge[which(phy$edge == newroot)] <- ROOT
+ phy$edge[i.oroot] <- newroot
+ ## ... and invert finally! (fixed 2005-11-07)
+ phy$edge[i, ] <- rev(phy$edge[i, ])
+ }
+ if (!is.null(phy$node.label))
+ ## It's important to not delete the label of the newroot
+ ## to keep the positions of the other nodes
+ phy$node.label[1] <- phy$node.label[newroot - nb.tip]
+ ## Not needed: phy$Nnode <- phy$Nnode - 1
+ read.tree(text = write.tree(phy))
+}
--- /dev/null
+### ROTATE
+### Last update CH on 09.08.2007
+
+# 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 (class(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])
+ }
+ }
+ S <- write.tree(phy)
+ phy <- if (!with.br.length) clado.build(S) else tree.build(S)
+ phy
+ }
--- /dev/null
+## rtree.R (2007-12-22)
+
+## Generates Random Trees
+
+## Copyright 2004-2007 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 <- .Internal(sample(n - 1, 1, FALSE, NULL))
+ n2 <- n - n1
+ po2 <- pos + 2*n1 - 1
+ edge[c(pos, po2), 1] <<- nod
+ nod <<- nod + 1
+ 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 + 1
+ }
+ 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 + 1
+ }
+ }
+
+ if (n < 2) stop("a tree must have at least 2 tips.")
+ nbr <- 2 * n - 2
+ if (!rooted) nbr <- nbr - 1
+ edge <- matrix(NA, nbr, 2)
+
+ if (n == 2) {
+ if (rooted) edge[] <- c(3, 3, 1, 2)
+ else stop("an unrooted tree must have at least 3 tips.")
+ } else if (n == 3) {
+ edge[] <-
+ if (rooted) c(4, 5, 5, 4, 5, 1:3)
+ else c(4, 4, 4, 1:3)
+ } else if (n == 4 && !rooted) {
+ edge[] <- c(5, 6, 6, 5, 5, 6, 1:4)
+ } else {
+ nod <- n + 1
+ 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 <- .Internal(sample(n - 2, 1, FALSE, NULL))
+ if (n1 == n - 2) {
+ n2 <- n3 <- 1
+ } else {
+ n2 <- .Internal(sample(n - n1 - 1, 1, FALSE, NULL))
+ n3 <- n - n1 - n2
+ }
+ po2 <- 2*n1
+ po3 <- 2*(n1 + n2) - 1
+ edge[c(1, po2, po3), 1] <- nod
+ nod <- nod + 1
+ if (n1 > 2) {
+ edge[1, 2] <- nod
+ foo(n1, 2)
+ } else if (n1 == 2) {
+ edge[2:3, 1] <- edge[1, 2] <- nod
+ nod <- nod + 1
+ }
+ 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 + 1
+ }
+ if (n3 > 2) {
+ edge[po3, 2] <- nod
+ foo(n3, po3 + 1)
+ } else if (n3 == 2) {
+ edge[c(po3 + 1, po3 + 2), 1] <- edge[po3, 2] <- nod
+ ## nod <- nod + 1
+ }
+ i <- which(is.na(edge[, 2]))
+ 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.function(br)) phy$edge.length <- br(nbr, ...)
+ phy$Nnode <- if (rooted) n - 1 else n - 2
+ class(phy) <- "phylo"
+ phy
+}
+
+rcoal <- function(n, tip.label = NULL, br = rexp, ...)
+{
+ nbr <- 2*n - 2
+ edge <- matrix(NA, nbr, 2)
+ x <- br(n - 1, ...) # coalescence times
+ if (n == 2) {
+ edge[] <- c(3, 3, 1:2)
+ edge.length <- rep(x, 2)
+ } else if (n == 3) {
+ edge[] <- c(4, 5, 5, 4, 5, 1:3)
+ edge.length <- c(x[2], x[1], x[1], sum(x))
+ } else {
+ edge.length <- numeric(nbr)
+ h <- numeric(2*n - 1) # initialized with 0's
+ node.height <- cumsum(x)
+ pool <- 1:n
+ nextnode <- 2*n - 1
+ 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 - 1
+ }
+ }
+ phy <- list(edge = edge, edge.length = edge.length)
+ phy$tip.label <-
+ if (is.null(tip.label)) paste("t", 1:n, sep = "")
+ else tip.label
+ phy$Nnode <- n - 1
+ class(phy) <- "phylo"
+ ##reorder(phy)
+ ## to avoid crossings when converting with as.hclust:
+ read.tree(text = write.tree(phy))
+}
--- /dev/null
+## scales.R (2004-12-18)
+
+## 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-2004 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+add.scale.bar <- function(x = 0, y = 1, length = NULL, ...)
+{
+ if (is.null(length)) {
+ nb.digit <- ceiling(log10(mean(.last_plot.phylo$xx))) - 2
+ length <- eval(parse(text = paste("1e", nb.digit, sep = "")))
+ }
+ segments(x, y, x + length, y)
+ text(x + length * 1.1, y, as.character(length), adj = c(0, 0.5), ...)
+}
+
+axisPhylo <- function(side = 1, ...)
+{
+ if (.last_plot.phylo$type %in% c("phylogram", "cladogram")) {
+ if (.last_plot.phylo$direction %in% c("rightwards", "leftwards")) {
+ x <- pretty(.last_plot.phylo$xx)
+ if (.last_plot.phylo$direction == "rightwards")
+ maxi <- max(.last_plot.phylo$xx)
+ else {
+ maxi <- min(.last_plot.phylo$xx)
+ x <- -x
+ }
+ } else {
+ x <- pretty(.last_plot.phylo$yy)
+ if (.last_plot.phylo$direction == "upwards")
+ maxi <- max(.last_plot.phylo$yy)
+ else {
+ maxi <- min(.last_plot.phylo$yy)
+ x <- -x
+ }
+ }
+ }
+ axis(side = side, at = c(maxi - x), labels = abs(x), ...)
+}
--- /dev/null
+## sh.test.R (2006-07-06)
+
+## Shimodaira-Hasegawa Test
+
+## Copyright 2006 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+sh.test <- function(..., x, model = DNAmodel(), B = 100)
+{
+ ## Prepare the list of trees:
+ phy <- list(...)
+ if (length(phy) == 1 && class(phy[[1]]) != "phylo")
+ phy <- unlist(phy, recursive = FALSE)
+ ntree <- length(phy)
+
+ ## Arrange the sequences as a matrix:
+ if (is.list(x)) {
+ nm <- names(x)
+ n <- length(x)
+ x <- unlist(x)
+ nL <- length(x)
+ x <- matrix(x, n, nL/n, byrow = TRUE)
+ rownames(x) <- nm
+ }
+
+ ## Step 1:
+ foo <- function(PHY)
+ attr(mlphylo(model, x, PHY, search.tree = FALSE, quiet = TRUE), "loglik")
+ Talpha <- sapply(phy, foo)
+ Talpha <- max(Talpha) - Talpha
+
+ ## Do the bootstrap resampling (Step 2):
+ M <- matrix(NA, ntree, B)
+ for (i in 1:B) {
+ boot.samp <- x[, sample(ncol(x), replace = TRUE)]
+ for (j in 1:ntree)
+ M[j, i] <- attr(mlphylo(model, boot.samp, phy[[j]],
+ search.tree = FALSE, quiet = TRUE),
+ "loglik")
+ }
+ M <- M - rowMeans(M) # Step 3
+ ## Step 4: <FIXME> This can greatly simplified </FIXME>
+ for (i in 1:B)
+ for (j in 1:ntree)
+ M[j, i] <- max(M[j, i] - M[, i])
+ ## Step 5:
+ count <- numeric(ntree)
+ for (j in 1:ntree)
+ count[j] <- sum(M[j, ] > Talpha[j])
+ count <- count/B
+ names(count) <- names(phy)
+ count
+}
--- /dev/null
+## 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
+}
+
--- /dev/null
+## 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)
+}
+
+
+
--- /dev/null
+## summary.phylo.R (2007-12-29)
+
+## Print Summary of a Phylogeny
+
+## Copyright 2003-2007 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 (class(phy) != "phylo")
+ stop('object "phy" is not of class "phylo"')
+ length(phy$tip.label)
+}
+
+Nnode <- function(phy, internal.only = TRUE)
+{
+ if (class(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 (class(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")
+
+ }
+ }
+ if (!is.null(attr(object, "loglik"))) {
+ cat("Phylogeny estimated by maximum likelihood.\n")
+ cat(" log-likelihood:", attr(object, "loglik"), "\n\n")
+ npart <- length(attr(object, "para"))
+ for (i in 1:npart) {
+ cat("partition ", i, ":\n", sep = "")
+ print(attr(object, "para")[[i]])
+ if (i == 1) next
+ else cat(" contrast parameter (xi):",
+ attr(object, "xi")[i - 1], "\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("\tNode 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")
+ cat("\n")
+}
+
+"[.multiPhylo" <- function(x, i)
+{
+ class(x) <- NULL
+ structure(x[i], class = "multiPhylo")
+}
--- /dev/null
+## theta.R (2002-08-28)
+
+## Population Parameter THETA
+
+## theta.h: using homozigosity
+## theta.k: using expected number of alleles
+## theta.s: using segregating sites in DNA sequences
+
+## Copyright 2002 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+theta.h <- function(x, standard.error = FALSE)
+{
+ HE <- H(x, variance = TRUE)
+ sdH <- HE[2]
+ HE <- HE[1]
+ f <- function(th) HE - th * (1 + (2 * (1 + th)) / ((2 + th) * (3 + th)))
+ th <- uniroot(f, interval = c(0, 1))$root
+ if (standard.error) {
+ SE <- (2 + th)^2 * (2 + th)^3 * sdH /
+ HE^2 * (1 + th) * ((2 + th) * (3 + th) * (4 + th) + 10 * (2 + th) + 4)
+ return(c(th, SE))
+ }
+ else return(th)
+}
+
+theta.k <- function(x, n = NULL, k = NULL)
+{
+ if (is.null(n)) {
+ if (!is.factor(x)) {
+ if (is.numeric(x)) {
+ n <- sum(x)
+ k <- length(x)
+ }
+ else x <- factor(x)
+ }
+ if (is.factor(x)) { # ne pas remplacer par `else'...
+ n <- length(x)
+ k <- nlevels(x)
+ }
+ }
+ f <- function(th) th * sum(1 / (th + (0:(n - 1)))) - k
+ th <- uniroot(f, interval = c(1e-8, 100))$root
+ return(th)
+}
+
+theta.s <- function(s, n, variance = FALSE)
+{
+ a1 <- sum(1 / (1:(n - 1)))
+ th <- s / a1
+ if (variance) {
+ a2 <- sum(1 / (1:(n - 1))^2)
+ var.th <- (a1^2 * s + a2 * s^2) / (a1^2 * (a1^2 + a2))
+ return(c(th, var.th))
+ }
+ else return(th)
+}
--- /dev/null
+## unique.multiPhylo.R (2007-11-16)
+
+## Revomes Duplicate Trees from a List
+
+## Copyright 2007 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 <- !logical(n)
+ for (i in 2:n) {
+ j <- 1
+ while (j < i) {
+ if (all.equal(x[[j]], x[[i]],
+ use.edge.length = use.edge.length,
+ use.tip.label = use.tip.label)) {
+ keep[i] <- FALSE
+ break
+ }
+ j <- j + 1
+ }
+ }
+ structure(x[keep], class = "multiPhylo")
+}
--- /dev/null
+## 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)
+
--- /dev/null
+## vcv.phylo.R (2006-10-04)
+
+## Phylogenetic Variance-Covariance or Correlation Matrix
+
+## Copyright 2002-2006 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+vcv.phylo <- function(phy, model = "Brownian", cor = FALSE)
+{
+ if (class(phy) != "phylo")
+ stop('object "phy" is not of class "phylo"')
+ if (is.null(phy$edge.length))
+ stop("the tree has no branch lengths")
+
+ foo <- function(node, var, endofclade) {
+ ## First, get the extent of clade descending
+ ## from `node' in the matrix `edge':
+ from <- which(phy$edge[, 1] == node)
+ to <- c(from[-1] - 1, endofclade)
+ ## Get the #'s of the descendants of `node':
+ desc <- phy$edge[from, 2]
+ ## The variance of each of these is easy:
+ vcv[desc, desc] <<- var + phy$edge.length[from]
+ nd <- length(desc)
+ ## The variance of `node' is equal to the covariance of
+ ## each possible pair among its descendant clades.
+ for (i in 1:(nd - 1))
+ for (j in (i + 1):nd)
+ for (k in phy$edge[from[i]:to[i], 2])
+ for (l in phy$edge[from[j]:to[j], 2])
+ vcv[k, l] <<- vcv[l, k] <<- var
+ for (i in 1:nd) {
+ if (desc[i] <= n) next
+ foo(desc[i], vcv[desc[i], desc[i]], to[i])
+ }
+ }
+
+ n <- length(phy$tip.label)
+ n.node <- phy$Nnode
+ N <- n.node + n
+ vcv <- matrix(0, N, N)
+ foo(n + 1, 0, dim(phy$edge)[1])
+
+ vcv <- vcv[1:n, 1:n]
+ if (cor) {
+ ## This is inspired from the code of `cov2cor' (2005-09-08):
+ M <- vcv
+ Is <- sqrt(1/M[1 + 0:(n - 1)*(n + 1)])
+ vcv[] <- Is * M * rep(Is, each = n)
+ vcv[1 + 0:(n - 1)*(n + 1)] <- 1
+ }
+ rownames(vcv) <- colnames(vcv) <- phy$tip.label
+ vcv
+}
--- /dev/null
+## which.edge.R (2007-09-11)
+
+## Identifies Edges of a Tree
+
+## Copyright 2004-2007 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)
+{
+ Ntip <- length(phy$tip.label)
+ seq.nod <- .Call("seq_root2tip", phy$edge, Ntip,
+ phy$Nnode, PACKAGE = "ape")
+ 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 (class(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
+}
--- /dev/null
+## write.dna.R (2003-12-29)
+
+## Write DNA Sequences in a File
+
+## Copyright 2003-2006 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 (class(x) == "DNAbin") x <- as.character(x)
+ if (is.matrix(x)) {
+ N <- dim(x)[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)
+ if (is.null(names(x))) names(x) <- as.character(1:N)
+ if (is.null(indent))
+ indent <- if (phylip) 10 else 0
+ if (indent == "") indent <- 0
+ if (is.numeric(indent)) indent <- paste(rep(" ", indent), collapse = "")
+ if (format == "interleaved") {
+ if (blocksep) {
+ blockseparation <- TRUE
+ blocksep <- paste(rep("\n", blocksep), collapse = "")
+ } else blockseparation <- FALSE
+ if (nbcol < 0) format <- "sequential"
+ }
+ zz <- if (append) file(file, "a") else file(file, "w")
+ if (phylip) {
+ S <- unique(unlist(lapply(x, length)))
+ ## check that all sequences have the same length
+ if (length(S) != 1)
+ stop("sequences must have the same length for interleaved or sequential format.")
+ ## truncate names if necessary
+ if (any(nchar(names(x)) > 10)) {
+ warning("at least one name was longer than 10 characters;\nthey will be truncated which may lead to some redundancy.\n")
+ names(x) <- substr(names(x), 1, 10)
+ }
+ ## left justify
+ names(x) <- sprintf("%-10s", names(x))
+ 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(NA, N, totalcol)
+ mode(SEQ) <- "character"
+ 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)
+ }
+ }
+ if (format == "interleaved") {
+ ## Write the first block with the taxon names
+ 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)
+ }
+ }
+ ## Write the other blocks
+ if (nb.block > 1) {
+ for (k in 2:nb.block) {
+ if (blockseparation) cat(blocksep, file = zz)
+ if (k == nb.block) {
+ for (i in 1:N) {
+ cat(indent, file = zz)
+ cat(SEQ[i, (1 + (k - 1)*nbcol):ncol(SEQ)], sep = colsep, file = zz)
+ cat("\n", file = zz)
+ }
+ } else {
+ for (i in 1:N) {
+ cat(indent, file = zz)
+ cat(SEQ[i, (1 + (k - 1)*nbcol):(nbcol + (k - 1)*nbcol)], sep = colsep, file = zz)
+ cat("\n", file = zz)
+ }
+ }
+ }
+ }
+ }
+ if (format == "sequential") {
+ if (nb.block == 1) {
+ for (i in 1:N) {
+ cat(names(x)[i], file = zz)
+ cat(SEQ[i, 1:nbcol], 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) {
+ if (k == nb.block) {
+ cat(indent, file = zz)
+ cat(SEQ[i, (1 + (k - 1)*nbcol):ncol(SEQ)], sep = colsep, file = zz)
+ cat("\n", file = zz)
+ } else {
+ cat(indent, file = zz)
+ cat(SEQ[i, (1 + (k - 1)*nbcol):(nbcol + (k - 1)*nbcol)], sep = colsep, file = zz)
+ cat("\n", file = zz)
+ }
+ }
+ }
+ }
+ }
+ if (format == "fasta") {
+ for (i in 1:N) {
+ cat(">", names(x)[i], file = zz)
+ cat("\n", file = zz)
+ X <- paste(x[[i]], collapse= "")
+ S <- length(x[[i]])
+ if (nbcol < 0) {
+ nb.block <- 1
+ nbcol <- totalcol <- ceiling(S / colw)
+ } else {
+ totalcol <- ceiling(S / colw)
+ nb.block <- 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.block) {
+ if (k == nb.block) {
+ cat(indent, file = zz)
+ cat(SEQ[(1 + (k - 1)*nbcol):length(SEQ)], sep = colsep, file = zz)
+ cat("\n", file = zz)
+ } else {
+ cat(indent, file = zz)
+ cat(SEQ[(1 + (k - 1)*nbcol):(nbcol + (k - 1)*nbcol)], sep = colsep, file = zz)
+ cat("\n", file = zz)
+ }
+ }
+ }
+ }
+ close(zz)
+}
--- /dev/null
+## write.nexus.R (2006-09-09)
+
+## Write Tree File in Nexus Format
+
+## Copyright 2003-2006 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+write.nexus <- function(..., file = "", translate = TRUE, original.data = 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 <- unlist(obj, recursive = FALSE)
+ 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)
+ if (original.data) {
+ if (!is.null(attr(obj[[1]], "origin"))) {
+ if (!file.exists(attr(obj[[1]], "origin"))) {
+ warning(paste("the file", attr(obj[[1]], "origin"),
+ "cannot be found,
+the original data won't be written with the tree."))
+ original.data <- FALSE
+ }
+ else {
+ ORI <- scan(file = attr(obj[[1]], "origin"), what = character(),
+ sep = "\n", skip = 1)
+ start <- grep("BEGIN TAXA;", ORI)
+ ORI <- ORI[-(1:(start - 1))]
+ ORI <- gsub("ENDBLOCK;", "END;", ORI)
+ endblock <- grep("END;", ORI)
+ start <- grep("BEGIN TREES;", ORI)
+ end <- endblock[endblock > start][1]
+ cat(ORI[1:(start - 1)], file = file, append = TRUE, sep = "\n")
+ ORI <- ORI[-(1:end)]
+ }
+ }
+ else original.data <- FALSE
+ }
+ N <- length(obj[[1]]$tip.label)
+ if (!original.data) {
+ 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) {
+ ## We take arbitrarily the labels of the first tree, and
+ ## translate them as "1", "2", "3", ...
+ cat("\tTRANSLATE\n", file = file, append = TRUE)
+ tmp <- checkLabel(obj[[1]]$tip.label)
+ X <- paste("\t\t", 1:N, "\t", tmp, ",", 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)
+ token <- as.character(1:N)
+ names(token) <- obj[[1]]$tip.label
+ obj[[1]]$tip.label <- token
+ if (ntree > 1)
+ for (i in 2:ntree)
+ obj[[i]]$tip.label <- token[obj[[i]]$tip.label]
+ } else {
+ for (i in 1:ntree)
+ obj[[i]]$tip.label <- checkLabel(obj[[i]]$tip.label)
+ }
+ for (i in 1:ntree) {
+ if (class(obj[[i]]) != "phylo") next
+ if (is.rooted(obj[[i]]))
+ cat("\tTREE * UNTITLED = [&R] ", file = file, append = TRUE)
+ else cat("\tTREE * UNTITLED = [&U] ", file = file, append = TRUE)
+ cat(write.tree(obj[[i]], file = ""),
+ "\n", sep = "", file = file, append = TRUE)
+ }
+ cat("END;\n", file = file, append = TRUE)
+ if(original.data) cat(ORI, file = file, append = TRUE, sep = "\n")
+}
--- /dev/null
+"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", " ", MISSING, " ", GAP, " ", DATATYPE, " ", INTERLEAVE, ";\n")
+ }
+ 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)
+}
+
--- /dev/null
+## write.tree.R (2007-12-22)
+
+## Write Tree File in Parenthetic Format
+
+## Copyright 2002-2007 Emmanuel Paradis
+
+## 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)
+{
+ if (class(phy) == "multiPhylo") {
+ write.tree(phy[[1]], file = file,
+ append = append, digits = digits)
+ if (length(phy) > 1)
+ for (i in 2:length(phy))
+ write.tree(phy[[i]], file = file,
+ append = TRUE, digits = digits)
+ return(invisible(NULL))
+ }
+
+ if (class(phy) != "phylo")
+ stop('object "phy" is not of class "phylo"')
+
+ brl <- !is.null(phy$edge.length)
+
+### Ne serait-il pas plus efficace de créer des node labels vides
+### "" et d'éviter l'évaluation if (nodelab) ????
+### Autre possibilité : créer plusieurs variants de ces fonctions
+### (au moins deux avec/sans edge.length)
+
+### Encore autre chose: les appels à which ne peuvent-ils pas
+### être évités ??? surtout si l'arbre est en cladewise order...
+
+ 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(s) STRING <<- paste(STRING, s, sep = "")
+ add.internal <- function(i) {
+ cp("(")
+ br <- which(phy$edge[, 1] == i)
+ for (j in br) {
+ desc <- phy$edge[j, 2]
+ if (desc > n) add.internal(desc) else add.terminal(j)
+ if (j != br[length(br)]) cp(",")
+ }
+ cp(")")
+ if (nodelab) cp(phy$node.label[i - n])
+ if (brl) {
+ cp(":")
+ cp(sprintf(f.d, phy$edge.length[which(phy$edge[, 2] == 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)
+ STRING <- "("
+ br <- which(phy$edge[, 1] == n + 1)
+ for (j in br) {
+ desc <- phy$edge[j, 2]
+ if (desc > n) add.internal(desc) else add.terminal(j)
+ if (j != br[length(br)]) 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(";")
+ }
+ if (file == "") return(STRING)
+ else cat(STRING, file = file, append = append, sep = "\n")
+}
--- /dev/null
+## yule.R (2007-10-18)
+
+## Fits Yule Model to a Phylogenetic Tree
+
+## yule: standard Yule model (constant birth rate)
+## yule.cov: Yule model with covariates
+
+## Copyright 2003-2007 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.")
+ bt <- rev(sort(branching.times(phy))) # branching times from past to present
+ ni <- cumsum(rev(table(bt))) + 1
+ X <- sum(phy$edge.length)
+ nb.node <- phy$Nnode
+ if (!is.null(phy$root.edge) && use.root.edge) {
+ X <- X + phy$root.edge
+ ni <- c(1, ni)
+ } 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], ]
+ Xj <- X[phy$edge[, 2], ]
+ 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)), ] %*% 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 transition rates.\n")
+ else para[, 2] <- sqrt(diag(solve(out$hessian)))
+ rownames(para) <- colnames(X)
+ colnames(para) <- c("Estimate", "StdErr")
+ 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")
+}
--- /dev/null
+## zoom.R (2004-12-17)
+
+## Zoom on a Portion of a Phylogeny
+
+## Copyright 2003-2004 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 == focus[[i]])
+ if (is.function(col))
+ if (deparse(substitute(col)) == "grey")
+ col <- grey(1:n/n) else col <- col(n)
+ ext <- list()
+ length(ext) <- n
+ for (i in 1:n)
+ ext[[i]] <- drop.tip(phy, phy$tip.label[-focus[[i]]],
+ subtree = subtree)
+ 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], ...)
+}
--- /dev/null
+## zzz.R (2003-05-05)
+
+## Library Loading
+
+## Copyright 2003 Emmanuel Paradis
+
+## This file is part of the R-package `ape'.
+## See the file ../COPYING for licensing issues.
+
+.First.lib <- function(lib, pkg) {
+ require(gee)
+ require(nlme)
+ require(lattice)
+ library.dynam("ape", pkg, lib)
+}
--- /dev/null
+The following persons and institutions helped in the development of
+APE at one stage or another.
+
+ Many users gave important feed-back with their encouragements,
+ comments, or bug reports: thanks to all of you!
+
+ Significant bug fixes were provided by James Bullard, Éric Durand,
+ Olivier François, Bret Larget, Klaus Schliep, and Li-San Wang.
+ Contact me if I forgot someone.
+
+ Kurt Hornik, of the R Core Team, helped in several occasions to
+ fix some problems and bugs.
+
+ Financial support was provided in the early development of APE by
+ the French "Programme inter-EPST Bioinformatique" (2001-2003).
+
+ Financial support was provided by the Department of Information
+ Systems of IRD in form a "SPIRALES" project (2006).
--- /dev/null
+"bird.families" <-
+structure(list(edge = structure(c(138, 139, 140, 141, 142, 142,
+141, 143, 143, 140, 139, 144, 145, 146, 146, 145, 147, 148, 148,
+147, 144, 149, 150, 150, 149, 151, 151, 138, 152, 152, 153, 154,
+155, 155, 154, 156, 156, 157, 157, 153, 158, 159, 160, 160, 159,
+161, 162, 163, 163, 162, 164, 164, 165, 165, 161, 166, 166, 167,
+168, 168, 167, 169, 169, 170, 170, 171, 171, 172, 172, 173, 173,
+158, 174, 174, 175, 176, 177, 178, 178, 177, 176, 179, 179, 180,
+180, 175, 181, 181, 182, 183, 184, 185, 185, 184, 183, 186, 186,
+187, 188, 188, 187, 189, 189, 190, 191, 191, 190, 192, 193, 193,
+192, 194, 194, 182, 195, 196, 196, 197, 198, 199, 199, 200, 200,
+201, 202, 203, 203, 202, 201, 201, 198, 197, 204, 205, 205, 206,
+207, 208, 209, 209, 208, 207, 210, 210, 206, 211, 212, 212, 213,
+213, 211, 214, 214, 204, 215, 216, 217, 217, 216, 215, 218, 218,
+219, 219, 220, 221, 222, 222, 221, 220, 223, 223, 224, 224, 225,
+225, 226, 226, 227, 228, 228, 227, 229, 229, 230, 230, 231, 231,
+195, 232, 233, 233, 234, 235, 235, 234, 236, 236, 237, 237, 238,
+238, 239, 239, 240, 240, 232, 241, 242, 243, 243, 244, 244, 242,
+245, 246, 246, 247, 247, 245, 248, 248, 249, 249, 250, 250, 251,
+251, 252, 252, 253, 253, 241, 254, 255, 255, 256, 256, 257, 257,
+254, 258, 259, 260, 260, 259, 261, 261, 262, 262, 263, 263, 264,
+264, 265, 265, 266, 266, 267, 267, 258, 268, 268, 269, 270, 271,
+271, 272, 272, 270, 269, 139, 140, 141, 142, 1, 2, 143, 3, 4,
+5, 144, 145, 146, 6, 7, 147, 148, 8, 9, 10, 149, 150, 11, 12,
+151, 13, 14, 152, 15, 153, 154, 155, 16, 17, 156, 18, 157, 19,
+20, 158, 159, 160, 21, 22, 161, 162, 163, 23, 24, 164, 25, 165,
+26, 27, 166, 28, 167, 168, 29, 30, 169, 31, 170, 32, 171, 33,
+172, 34, 173, 35, 36, 174, 37, 175, 176, 177, 178, 38, 39, 40,
+179, 41, 180, 42, 43, 181, 44, 182, 183, 184, 185, 45, 46, 47,
+186, 48, 187, 188, 49, 50, 189, 51, 190, 191, 52, 53, 192, 193,
+54, 55, 194, 56, 57, 195, 196, 58, 197, 198, 199, 59, 200, 60,
+201, 202, 203, 61, 62, 63, 64, 65, 66, 204, 205, 67, 206, 207,
+208, 209, 68, 69, 70, 210, 71, 72, 211, 212, 73, 213, 74, 75,
+214, 76, 77, 215, 216, 217, 78, 79, 80, 218, 81, 219, 82, 220,
+221, 222, 83, 84, 85, 223, 86, 224, 87, 225, 88, 226, 89, 227,
+228, 90, 91, 229, 92, 230, 93, 231, 94, 95, 232, 233, 96, 234,
+235, 97, 98, 236, 99, 237, 100, 238, 101, 239, 102, 240, 103,
+104, 241, 242, 243, 105, 244, 106, 107, 245, 246, 108, 247, 109,
+110, 248, 111, 249, 112, 250, 113, 251, 114, 252, 115, 253, 116,
+117, 254, 255, 118, 256, 119, 257, 120, 121, 258, 259, 260, 122,
+123, 261, 124, 262, 125, 263, 126, 264, 127, 265, 128, 266, 129,
+267, 130, 131, 268, 132, 269, 270, 271, 133, 272, 134, 135, 136,
+137), .Dim = c(271, 2)), edge.length = c(2.1, 4.1, 3.9, 0.8,
+17.1, 17.1, 8.4, 9.5, 9.5, 21.8, 3, 1.3, 1.8, 19.8, 19.8, 6.5,
+2.3, 12.8, 12.8, 15.1, 6.8, 3.7, 12.4, 12.4, 6.3, 9.8, 9.8, 1,
+27, 0.7, 9.8, 5.5, 11, 11, 3.7, 12.8, 1.3, 11.5, 11.5, 1.3, 0.6,
+6.9, 17.5, 17.5, 1, 2.6, 11.6, 9.2, 9.2, 3.8, 17, 6.8, 10.2,
+10.2, 1.3, 22.1, 1.1, 7.1, 13.9, 13.9, 1.3, 19.7, 2, 17.7, 1.2,
+16.5, 1, 15.5, 3.5, 12, 12, 0.5, 24.5, 0.8, 6.1, 3.1, 1.5, 13,
+13, 14.5, 1.2, 16.4, 1.9, 14.5, 14.5, 0.6, 23.1, 0.6, 0.6, 0.6,
+11.8, 9.5, 9.5, 21.3, 1.5, 20.4, 1.3, 5.5, 13.6, 13.6, 0.3, 18.8,
+0.9, 7.6, 10.3, 10.3, 1, 1.1, 15.8, 15.8, 4.6, 12.3, 12.3, 0.9,
+0.8, 20.8, 0.7, 1, 1.6, 17.5, 0.6, 16.9, 1.9, 2.3, 3.5, 9.2,
+9.2, 12.7, 15, 15, 19.1, 1.4, 1.6, 17.1, 1.5, 1.5, 0.8, 3, 10.3,
+10.3, 13.3, 1.6, 12.5, 12.5, 2.8, 1.3, 11.5, 0.7, 10.8, 10.8,
+4.7, 8.1, 8.1, 2.3, 1.2, 4.8, 10.4, 10.4, 15.2, 1.5, 14.9, 0.9,
+14, 0.7, 1.2, 1.1, 11, 11, 12.1, 0.9, 12.4, 0.5, 11.9, 0.4, 11.5,
+0.4, 11.1, 0.2, 0.8, 10.1, 10.1, 0.2, 10.7, 0.3, 10.4, 0.4, 10,
+10, 1.9, 1.8, 17.9, 2.1, 3.7, 12.1, 12.1, 2, 13.8, 0.3, 13.5,
+1.4, 12.1, 0.7, 11.4, 0.7, 10.7, 10.7, 6.9, 1.1, 1.3, 10.4, 0.5,
+9.9, 9.9, 0.3, 0.2, 11.2, 2, 9.2, 9.2, 0.8, 10.6, 0.4, 10.2,
+0.2, 10, 0.4, 9.6, 0.5, 9.1, 0.3, 8.8, 8.8, 1.1, 1.1, 10.6, 0.9,
+9.7, 0.6, 9.1, 9.1, 0.6, 0.3, 0.8, 10, 10, 0.2, 10.6, 0.2, 10.4,
+0.3, 10.1, 0.4, 9.7, 0.2, 9.5, 0.1, 9.4, 0.3, 9.1, 9.1, 0.7,
+10.4, 0.4, 0.2, 0.2, 9.6, 0.3, 9.3, 9.3, 9.8, 10), tip.label = c("Struthionidae",
+"Rheidae", "Casuariidae", "Apterygidae", "Tinamidae", "Cracidae",
+"Megapodiidae", "Phasianidae", "Numididae", "Odontophoridae",
+"Anhimidae", "Anseranatidae", "Dendrocygnidae", "Anatidae", "Turnicidae",
+"Indicatoridae", "Picidae", "Megalaimidae", "Lybiidae", "Ramphastidae",
+"Galbulidae", "Bucconidae", "Bucerotidae", "Bucorvidae", "Upupidae",
+"Phoeniculidae", "Rhinopomastidae", "Trogonidae", "Coraciidae",
+"Leptosomidae", "Meropidae", "Momotidae", "Todidae", "Alcedinidae",
+"Dacelonidae", "Cerylidae", "Coliidae", "Cuculidae", "Centropidae",
+"Coccyzidae", "Opisthocomidae", "Crotophagidae", "Neomorphidae",
+"Psittacidae", "Apodidae", "Hemiprocnidae", "Trochilidae", "Musophagidae",
+"Tytonidae", "Strigidae", "Aegothelidae", "Podargidae", "Batrachostomidae",
+"Steatornithidae", "Nyctibiidae", "Eurostopodidae", "Caprimulgidae",
+"Columbidae", "Eurypygidae", "Otididae", "Gruidae", "Heliornithidae",
+"Psophiidae", "Cariamidae", "Rhynochetidae", "Rallidae", "Pteroclidae",
+"Thinocoridae", "Pedionomidae", "Scolopacidae", "Rostratulidae",
+"Jacanidae", "Chionididae", "Burhinidae", "Charadriidae", "Glareolidae",
+"Laridae", "Accipitridae", "Sagittariidae", "Falconidae", "Podicipedidae",
+"Phaethontidae", "Sulidae", "Anhingidae", "Phalacrocoracidae",
+"Ardeidae", "Scopidae", "Phoenicopteridae", "Threskiornithidae",
+"Pelecanidae", "Ciconiidae", "Fregatidae", "Spheniscidae", "Gaviidae",
+"Procellariidae", "Acanthisittidae", "Pittidae", "Eurylaimidae",
+"Tyrannidae", "Thamnophilidae", "Furnariidae", "Formicariidae",
+"Conopophagidae", "Rhinocryptidae", "Climacteridae", "Menuridae",
+"Ptilonorhynchidae", "Maluridae", "Meliphagidae", "Pardalotidae",
+"Eopsaltriidae", "Irenidae", "Orthonychidae", "Pomatostomidae",
+"Laniidae", "Vireonidae", "Corvidae", "Bombycillidae", "Cinclidae",
+"Muscicapidae", "Sturnidae", "Sittidae", "Certhiidae", "Paridae",
+"Aegithalidae", "Hirundinidae", "Regulidae", "Pycnonotidae",
+"Cisticolidae", "Zosteropidae", "Sylviidae", "Alaudidae", "Nectariniidae",
+"Melanocharitidae", "Paramythiidae", "Passeridae", "Fringillidae"
+), Nnode = 135), .Names = c("edge", "edge.length", "tip.label",
+"Nnode"), class = "phylo")
--- /dev/null
+"bird.orders" <-
+structure(list(edge = structure(c(24, 25, 26, 26, 25, 27, 28,
+28, 27, 24, 29, 29, 30, 30, 31, 32, 32, 33, 34, 34, 33, 35, 35,
+31, 36, 36, 37, 37, 38, 38, 39, 40, 41, 41, 40, 42, 42, 39, 43,
+44, 44, 45, 45, 43, 25, 26, 1, 2, 27, 28, 3, 4, 5, 29, 6, 30,
+7, 31, 32, 8, 33, 34, 9, 10, 35, 11, 12, 36, 13, 37, 14, 38,
+15, 39, 40, 41, 16, 17, 42, 18, 19, 43, 44, 20, 45, 21, 22, 23
+), .Dim = c(44, 2)), edge.length = c(2.1, 4.1, 21.8, 21.8, 3,
+1.3, 21.6, 21.6, 22.9, 1, 27, 0.7, 26.3, 1.3, 0.6, 24.4, 1, 2.6,
+20.8, 20.8, 1.3, 22.1, 22.1, 0.5, 24.5, 0.8, 23.7, 0.6, 23.1,
+0.6, 0.6, 0.6, 21.3, 21.3, 1.5, 20.4, 20.4, 0.9, 0.8, 20.8, 0.7,
+20.1, 20.1, 21.6), tip.label = c("Struthioniformes", "Tinamiformes",
+"Craciformes", "Galliformes", "Anseriformes", "Turniciformes",
+"Piciformes", "Galbuliformes", "Bucerotiformes", "Upupiformes",
+"Trogoniformes", "Coraciiformes", "Coliiformes", "Cuculiformes",
+"Psittaciformes", "Apodiformes", "Trochiliformes", "Musophagiformes",
+"Strigiformes", "Columbiformes", "Gruiformes", "Ciconiiformes",
+"Passeriformes"), Nnode = 22), .Names = c("edge", "edge.length",
+"tip.label", "Nnode"), class = "phylo")
--- /dev/null
+"Order";"SuperFamily";"Family";"Genus";"Species";"FW";"SW";"FB";"SB";"LS";"GL";"BW";"WA";"AI";"LY";"AM";"IB"
+"Carnivora";"Caniformia";"Canidae";"Canis";"Canis lupus";31.1;33.1;130;132.3;5.5;63;425;35;;177;913;12
+"Carnivora";"Caniformia";"Canidae";"Canis";"Canis latrans";9.7;10.6;84.5;88.3;6.2;61.5;225;98;;;365;12
+"Carnivora";"Caniformia";"Canidae";"Canis";"Canis adustus";10.6;11.3;53.5;51.8;4.3;63.3;;;;127;;
+"Carnivora";"Caniformia";"Canidae";"Canis";"Canis mesomelas";7.2;7.7;52;56.8;3.8;60;;61;270;;392;
+"Carnivora";"Caniformia";"Canidae";"Lycaon";"Lycaon pictus";22.2;22;128;129;8.8;70.5;365;77;390;132;"t 132";13
+"Carnivora";"Caniformia";"Canidae";"Cuon";"Cuon alpinus";13.8;15.8;95;95;4.3;62;275;;;186;;
+"Carnivora";"Caniformia";"Canidae";"Alopex";"Alopex lagopus";2.9;3.2;37;35.5;7.1;53.3;66;21;165;108;293;12
+"Carnivora";"Caniformia";"Canidae";"Vulpes";"Vulpes vulpes";3.9;4.1;43;43.5;4.8;54.5;105;56;225;144;;12
+"Carnivora";"Caniformia";"Canidae";"Vulpes";"Vulpes bengalensis";1.8;2.4;24.5;25.8;3.5;52;;;;;;
+"Carnivora";"Caniformia";"Canidae";"Vulpes";"Vulpes chama";3.1;3.1;33;33.5;4;;;;;;;
+"Carnivora";"Caniformia";"Canidae";"Fennecus";"Fennecus zerda";1.5;1.5;17.5;17.3;2.8;54.3;34.8;66;;141;;12
+"Carnivora";"Caniformia";"Canidae";"Otocyon";"Otocyon megalotis";3.9;3.9;24.5;26.8;3.5;62.5;;105;;;;
+"Carnivora";"Caniformia";"Canidae";"Urocyon";"Urocyon cinereoargenteus";3.3;3.7;39.5;40.8;3.8;63;107.5;;;;365;12
+"Carnivora";"Caniformia";"Canidae";"Dusicyon";"Dusicyon culpaeus";6.7;7.4;51;51.5;5;57.5;168;;;;365;12
+"Carnivora";"Caniformia";"Canidae";"Dusicyon";"Dusicyon gylnnocercus";4.2;4.4;40;40;4;58;;;;;;12
+"Carnivora";"Caniformia";"Canidae";"Cerdocyon";"Cerdocyon thous";6;6;40.5;41.8;3.1;56;140;90;195;;365;8
+"Carnivora";"Caniformia";"Canidae";"Chrysocyon";"Chrysocyon brachyurus";23;23;116;120;1.8;63.3;360;;;162;;
+"Carnivora";"Caniformia";"Canidae";"Speothos";"Speothos venalicus";8;8;41.5;40.5;3.5;65;;;;;;
+"Carnivora";"Caniformia";"Ursidae";"Ursus";"Ursus arctos";298.5;298.5;339;338.3;2;63;1000;730;648;304;1338;30
+"Carnivora";"Caniformia";"Ursidae";"Ursus";"Ursus americanus";97;110.5;228;259;2.5;91;285;168;483;270;1834;27
+"Carnivora";"Caniformia";"Ursidae";"Thalarctos";"Thalarctos maritimus";320;365;365;459.5;1.9;;641.6;;821;408;1734;24
+"Carnivora";"Caniformia";"Ursidae";"Selenarctos";"Selenarctos thibetanus";77.5;103.8;298;312.5;2;;;119;913;396;1186;
+"Carnivora";"Caniformia";"Procyonidae";"Bassariscus";"Bassariscus astutus";0.87;0.95;16;16.5;3;52;28;120;;96;300;
+"Carnivora";"Caniformia";"Procyonidae";"Polos";"Polos flavus";2;2.1;24;25.5;1.5;106.5;170.5;;;228;;
+"Carnivora";"Caniformia";"Procyonidae";"Nasua";"Nasua narica";5;5;37;37;4;73.5;140;;;;;12
+"Carnivora";"Caniformia";"Procyonidae";"Procyon";"Procyon lotor";6.7;6.4;39;40;3.8;64.7;105.9;119;;120;540;12
+"Carnivora";"Caniformia";"Ailuridae";"Ailuropoda";"Ailuropoda melanoleuca";120;135;205;234.3;1.5;;104.8;180;180;216;2312;12
+"Carnivora";"Caniformia";"Mustelidae";"Mustela";"Mustela erminea";0.62;0.95;3;4;4.5;70;1.7;;;;336;12
+"Carnivora";"Caniformia";"Mustelidae";"Mustela";"Mustela nivalis";0.06;0.08;2;2;5.8;42;3;32;;;;6
+"Carnivora";"Caniformia";"Mustelidae";"Mustela";"Mustela rixosa";0.05;0.05;1;1;4.8;37;0.01;24;;;;6
+"Carnivora";"Caniformia";"Mustelidae";"Mustela";"Mustelafrenata";0.23;2.33;4;4;6;23.5;3.1;30;84;;252;12
+"Carnivora";"Caniformia";"Mustelidae";"Mustela";"Mustela altaica";0.13;0.19;4.5;4.5;4;40;;56;56;;;
+"Carnivora";"Caniformia";"Mustelidae";"Mustela";"Mustela sibirica";0.4;0.57;6;6.75;5;29;;56;;;;
+"Carnivora";"Caniformia";"Mustelidae";"Mustela";"Mustela lutreola";0.44;0.59;8;8.5;4.5;38.5;;70;;;365;
+"Carnivora";"Caniformia";"Mustelidae";"Mustela";"Mustela vison";0.61;0.91;7;8.5;5;29;;;;;420;12
+"Carnivora";"Caniformia";"Mustelidae";"Mustela";"Mustela putorius";0.8;1.03;7;8.3;6;41;;;70;;;12
+"Carnivora";"Caniformia";"Mustelidae";"Vormela";"Vormela peregusna";0.53;0.6;4;4.8;6;61.5;;;;;;
+"Carnivora";"Caniformia";"Mustelidae";"Martes";"Martes martes";1.2;1.2;18;20;3.3;30;;;;;;
+"Carnivora";"Caniformia";"Mustelidae";"Martes";"Martes amerkana";0.77;0.87;14.5;15.8;2.6;26.5;28;46;;150;365;12
+"Carnivora";"Caniformia";"Mustelidae";"Martes";"Martes pennanti";2.25;3.75;29;31.8;2.7;77;28;46;;;730;
+"Carnivora";"Caniformia";"Mustelidae";"Martes";"Martes zibellina";1.03;1.18;17;18.5;3;28;32.5;49;;;600;
+"Carnivora";"Caniformia";"Mustelidae";"Gulo";"Gulo gulo";10.35;11.6;72.5;78.5;2.8;35;99.2;70;639;186;630;27
+"Carnivora";"Caniformia";"Mustelidae";"Tavra";"Tavra barbara";4.4;4.4;35;35.8;3.5;64;;;;144;;
+"Carnivora";"Caniformia";"Mustelidae";"Grison";"Grison vittatus";1.8;2.6;23.5;24.3;2;;;;;;;
+"Carnivora";"Caniformia";"Mustelidae";"Ictonyx";"Ictonyx striatus";0.63;0.77;8.5;9.8;2.3;36;15;56;;;;
+"Carnivora";"Caniformia";"Mustelidae";"Poecilogale";"Poecilogale albinucha";0.25;0.3;4.5;4.8;2;32;4;77;;;;
+"Carnivora";"Caniformia";"Mustelidae";"Mellivora";"Mellivora capensis";7.59;8.08;64;72.8;2.5;168;;;;288;;6
+"Carnivora";"Caniformia";"Mustelidae";"Meles";"Meles meles";10.9;11.6;45.5;50.5;3;42;103.5;95;210;180;525;12
+"Carnivora";"Caniformia";"Mustelidae";"Taxidea";"Taxidea taxus";4.1;4.05;48.5;49;4;42;;42;;156;395;
+"Carnivora";"Caniformia";"Mustelidae";"Mephistis";"Mephitis mephitis";2;2.4;10;10.3;6;63;33;46;84;120;308;12
+"Carnivora";"Caniformia";"Mustelidae";"Spilogale";"Spilogale putorius";0.43;0.55;5;5;4.3;30;15.9;56;;;;8
+"Carnivora";"Caniformia";"Mustelidae";"Lutra";"Lutra lutra";7.1;8.9;39;42;2.5;66.5;285;112;238;;913;
+"Carnivora";"Caniformia";"Mustelidae";"Lutra";"Lutra cauadensis";7.8;8.2;50.5;52.8;3;112;;93;;;730;
+"Carnivora";"Caniformia";"Mustelidae";"Lutra";"Lutra maculicollis";3.5;4.04;33;40;3;56;;;;;730;
+"Carnivora";"Caniformia";"Mustelidae";"Lutrogale";"Lutrogale perspicillata";7.3;8.78;61;65;1.5;62;;126;;180;;
+"Carnivora";"Caniformia";"Mustelidae";"Aonyx";"Aonyx capensis";18;19;93;95;3;63;;;;;;
+"Carnivora";"Caniformia";"Mustelidae";"Enhydra";"Enhvdra lutris";24.4;28.3;119;125.5;1;120;210;364;;;1095;12
+"Carnivora";"Feliformia";"Viverridae";"Viverra";"Viverra zihetha";9;9.3;36.5;37;2.8;77;;;;;;
+"Carnivora";"Feliformia";"Viverridae";"Civettictis";"Civettictis iietta";12.24;12.02;39;37;3;68.5;;140;;;;9
+"Carnivora";"Feliformia";"Viverridae";"Viverricula";"Viverricula indica";2.49;2.66;17;16.8;3.8;;;;;102;;
+"Carnivora";"Feliformia";"Viverridae";"Genetta";"Genetta genetta";1.8;1.9;14;14;3.5;71.8;;175;;;;6
+"Carnivora";"Feliformia";"Viverridae";"Genetta";"Genetta tigrina";2.02;2.06;15.5;15.3;2.5;70;;56;;180;;
+"Carnivora";"Feliformia";"Viverridae";"Prionodon";"Prionodon linsang";0.72;0.67;8;8.5;;;40;;;102;;
+"Carnivora";"Feliformia";"Viverridae";"Nandinia";"Nandinia hinotata";3.2;3.2;17;17.3;1.8;64;56;;;;720;6
+"Carnivora";"Feliformia";"Viverridae";"Actogalidia";"Arctogalidia trivirgata";2.4;2.4;21;22;2.8;45;;;;132;;6
+"Carnivora";"Feliformia";"Viverridae";"Paradoxurus";"Paradoxurus hermaphroditus";2.7;3;18.5;18.5;3.3;;95.5;;;168;;6
+"Carnivora";"Feliformia";"Viverridae";"Paradoxurus";"Paradoxurus zeylonensis";2.3;2.8;17.5;17.8;2.5;;" ";;;;;
+"Carnivora";"Feliformia";"Viverridae";"Paguma";"Paguma Iarvata";5;4.7;29.5;30.8;3;;" ";;;180;;
+"Carnivora";"Feliformia";"Viverridae";"Acrctictis";"Arctictis binturong";13;13;38;40.8;3;90.3;319;56;;216;;
+"Carnivora";"Feliformia";"Viverridae";"Hemigalus";"Hemigalus derbyanus";0.86;0.83;16;19;;;125;70;;;;
+"Carnivora";"Feliformia";"Viverridae";"Fossa";"Fossa fossa";1.6;1.8;18;19.8;1;85;82.5;52;365;;;12
+"Carnivora";"Feliformia";"Viverridae";"Eupleres";"Eupleres goudoti";2.1;2.1;17;17;1.5;;150;63;;;;
+"Carnivora";"Feliformia";"Viverridae";"Galidea";"Galidea elegans";0.81;0.81;10;10.8;1;83;47.5;56;;;730;12
+"Carnivora";"Feliformia";"Viverridae";"Herpetes";"Herpestes ichneumon";2.9;3.05;23;23.3;2.5;63;" ";;;156;;
+"Carnivora";"Feliformia";"Viverridae";"Herpetes";"Herpestes sanguineus";0.44;0.49;9;8.75;2.5;;" ";;;;365;6
+"Carnivora";"Feliformia";"Viverridae";"Herpetes";"Herpestes auropunctatus";0.53;0.78;7;7.25;3.2;46;" ";32;;120;365;6
+"Carnivora";"Feliformia";"Viverridae";"Herpetes";"Herpestes edwardsi";1.04;1.28;10;10.5;3;60.5;" ";;;;270;" S"
+"Carnivora";"Feliformia";"Viverridae";"Herpetes";"Herpestes smithi";1.25;1.7;13.5;13.8;2.5;;" ";;;;;
+"Carnivora";"Feliformia";"Viverridae";"Herpetes";"Herpestesfuscus";0.79;1.19;11;12.5;3.5;;" ";;;;;
+"Carnivora";"Feliformia";"Viverridae";"Herpetes";"Herpestes vitticollis";1.7;2.38;26;25.8;3;;" ";;;;;
+"Carnivora";"Feliformia";"Viverridae";"Herpetes";"Herpestes urva";2.04;2.38;20;21;3;63;" ";;;120;;
+"Carnivora";"Feliformia";"Viverridae";"Mungos";"Mungos mungo";1.23;1.26;10;10.5;3.8;59;20;;;108;323;
+"Carnivora";"Feliformia";"Viverridae";"Crossarchus";"Crossarchus obscurus";1.31;1.31;9.5;9.8;4;70;" ";;;;;4
+"Carnivora";"Feliformia";"Viverridae";"Helogale";"Helogale parvula";0.27;0.27;5;4.75;3.6;51;" ";;;;450;4
+"Carnivora";"Feliformia";"Viverridae";"Ichneumia";"Ichneumia albicauda";3.53;3.89;22.5;24.3;2.5;;" ";;;;;
+"Carnivora";"Feliformia";"Viverridae";"Atilax";"Atilax paludinosus";3.3;3.7;27;28.5;2.5;;" ";;;;;6
+"Carnivora";"Feliformia";"Viverridae";"Cynictus";"Cynictus penicillata";0.6;0.6;10;10.5;2.5;54.5;" ";42;;;;12
+"Carnivora";"Feliformia";"Viverridae";"Paracynictis";"Paracynictis selousi";1.64;1.7;15.5;15.8;1.5;;" ";;;;;
+"Carnivora";"Feliformia";"Viverridae";"Suricata";"Suricata suricatta";0.72;0.73;10;10.3;4;77;30.5;56;;;;
+"Carnivora";"Feliformia";"Hyaenidae";"Hyaena";"Hyaena hyaena";26.6;26.8;98;97.8;2.5;87;" ";60;;282;821;
+"Carnivora";"Feliformia";"Hyaenidae";"Hyaena";"Hyaena brunnea";43.9;43.3;110;107;2.3;;693;360;900;150;;
+"Carnivora";"Feliformia";"Hyaenidae";"Crocuta";"Crocuta crocuta";55.3;52;153;143.5;2;110;1500;390;913;276;913;17
+"Carnivora";"Feliformia";"Hyaenidae";"Proteles";"Proteles cristatus";8.36;8.34;36.5;35.3;2.8;100;" ";;;144;;
+"Carnivora";"Feliformia";"Felidae";"Felis";"Felis silvestris";4.33;4.67;35.5;37.5;3.3;67;137;84;140;;313;6
+"Carnivora";"Feliformia";"Felidae";"Felis";"Felis Iibyca";3.85;4.3;33.5;36.3;2.8;57;" ";;140;180;280;
+"Carnivora";"Feliformia";"Felidae";"Felis";"Felis chaus";6.65;6.65;37;39.3;2.9;65;135.5;102;;144;330;6
+"Carnivora";"Feliformia";"Felidae";"Leptailurus";"Leptailurus serval";10.4;11.7;57;56.8;2.4;71;143.5;;;180;;6
+"Carnivora";"Feliformia";"Felidae";"Prionailurus";"Prionailurus bengalensis";3.3;5.5;28.5;29.3;2.5;67.3;83;25;;150;750;12
+"Carnivora";"Feliformia";"Felidae";"Prionailurus";"Prionailurus rubiginosa";1.25;1.43;19;19;2.5;;;;;;;
+"Carnivora";"Feliformia";"Felidae";"Prionailurus";"Prionailurus viverrinus";6.3;8.8;45.5;46.5;2.5;92.5;92.5;53;;;;
+"Carnivora";"Feliformia";"Felidae";"Caracal";"Caracal caracal";9.68;11.59;53.5;55.3;3;73.5;;123;365;204;450;12
+"Carnivora";"Feliformia";"Felidae";"Puma";"Puma concolor";39.6;51.8;119;125.5;2.5;90;400;;420;;913;19
+"Carnivora";"Feliformia";"Felidae";"Leopardus";"Leopardus pardalis";10.75;11.88;60;63.8;2.5;72.5;250;49;;;653;
+"Carnivora";"Feliformia";"Felidae";"Leopardus";"Leopardus geoffroyi";2.2;2.2;35.5;34;2;69.5;65;63;;;480;12
+"Carnivora";"Feliformia";"Felidae";"Lynx";"Lynx lynx";17.8;19.3;68.5;70;2.3;67.8;70;113;240;162;690;12
+"Carnivora";"Feliformia";"Felidae";"Lynx";"Lynx rufus";5.2;6.2;58.5;58.3;3.2;63;311.5;60;365;156;593;12
+"Carnivora";"Feliformia";"Felidae";"Panthera";"Panthera leo";135.5;155.8;219;223.5;2.6;105.5;1650;150;1080;216;1620;25
+"Carnivora";"Feliformia";"Felidae";"Panthera";"Panthera tigris";131;161;247;279.3;2.5;104.1;1255;165;570;207;1643;32
+"Carnivora";"Feliformia";"Felidae";"Panthera";"Panthera pardus";39.3;52.4;112;125.5;2.6;98;549.3;139;600;264;1187;24
+"Carnivora";"Feliformia";"Felidae";"Panthera";"Panthera onca";77.6;86.2;149;151.5;2.5;104.5;816.6;115;;;1110;
+"Carnivora";"Feliformia";"Felidae";"Panthera";"Panthera uncia";32.5;32.5;98;102;2.8;96.8;442.6;;;;730;
+"Carnivora";"Feliformia";"Felidae";"Acinonyx";"Acinonyx jubatus";60;58.8;106;111;3.8;91;287.5;109;465;;645;18
--- /dev/null
+require(ape, quietly = TRUE, save = FALSE)
+cynipids <- read.nexus.data("cynipids.txt")
+
--- /dev/null
+#NEXUS
+[LWRh data from Rokas et al. 2002. Molecular Phylogenetics and Evolution 22:206-219]
+BEGIN DATA;
+ DIMENSIONS NTAX=8 NCHAR=159;
+ FORMAT MISSING=? GAP=- DATATYPE=PROTEIN INTERLEAVE=YES;
+ MATRIX
+ Barbotinia_oraniensis LGPFICEIYAMLGSLFGCGSIWTMCMIAFDRYNVIVKGLAGKPLTISGAI
+ Synergus_gallaepomiformis LGPFICEMYGMFGSLFGCGSIWTMCMIAFDRYNVIVKGLVGKPLTISGAI
+ Periclistus_brandtii LGPFMCEIYAMLGSLFGCGSIWTMCMIAFDRYNVIVKGLAGKPLSISGAI
+ Panteliella_bicolor LGPFLCEMYGMFGSLFGCGSIWTMCMIAFDRYNVIVKGLAGKPLTITGAI
+ Plagiotrochus_quercusilicis HGPFMCEMYAMFGSLFGCGSIWTMCMIAFDRYNVIVKGLAGKPLTISGAI
+ Andricus_curvator LGPFMCEIYAMLGSLFGCGSIWTMCMIAFDRYNVIVKGLAGKPLTISGAI
+ Andricus_kollari LGPFMCEIYAMLGSLFGCVSIWTMCMIAFDRYNVIVKGLAGKPLTISGAI
+ Diplolepis_rosae -GPFLCEIYALLGSLFGCGSIWTMCMIAFDRYNVIVKGLAGKPLTITGAI
+
+ Barbotinia_oraniensis LRIVFLWVWAVVWTIAPMIGWNRYVPEGNMTACGTDYLTKDWFSRSYILV
+ Synergus_gallaepomiformis LRIAFLWIWAVIWTIAPMIGWNRYVPEGNMTACGTDYLSKDWFSRSYIIV
+ Periclistus_brandtii LRIVGLWVWAVIWTIAPMIGWNRYVPEGNLTACGTDYLSKDWLSRSYILV
+ Panteliella_bicolor LRIVGLWVWAVIWTIAPMIGWNRYVPEGNMTACGTDYLNKDWFSRSYILI
+ Plagiotrochus_quercusilicis LRIVGLWVWAVIWTIAPMLGWNRYVPEGNMTACGTDYLTKDWFSRSYILV
+ Andricus_curvator LRIVGLWVWAVIWTIAPMLGWNRYVPEGNMTACGTDYLSKDWFSRSYILV
+ Andricus_kollari LRIVGLWVWAIIWTIAPMLGWNRYVPEGNMTACGTDYLSKDWFSRSYIIV
+ Diplolepis_rosae IRIIGLWVWAIIWTIAPMFGWNRYVPEGNMTACGTDYLSKDWFSRSYILV
+
+ Barbotinia_oraniensis YSVFVYFMPLFLIIYSYYFIIAAVSAHEKAMREQAKKMNVASLRSSDNQN
+ Synergus_gallaepomiformis YSVFVYFMPLFLIIYSYYFIIAAVSAHEKAMREQAKKMNVASLRSSDNQN
+ Periclistus_brandtii YSVFVYFMPLFLIIYSYYFIIAAVSAHEKAMREQAKKMNVASLRSSDNQN
+ Panteliella_bicolor YSVFVYFMPLFLIIYSYYFIIAAVSAHEKAMREQAKKMNVASLRSSDNQN
+ Plagiotrochus_quercusilicis YSVFVYFMPLFLIIYSYYFIIAAVTAHEKAMREQAKKMNVASLRSSDNQN
+ Andricus_curvator YSIFVYFMPLFLIIYSYYFIIAAVTAHEKAMREQAKKMNVASLRSSDNQN
+ Andricus_kollari YSIFVYFMPLFLIIYSYYFIIAAVTAHEKAMREQAKKMNVASLRSSDNQN
+ Diplolepis_rosae YSIFVYYMPLFLIIYSYYFIISAVSAHEKAMREQAKKMNVASLRSSDNAN
+
+ Barbotinia_oraniensis TSAEHKLAK
+ Synergus_gallaepomiformis TSAEHKLAK
+ Periclistus_brandtii TSAEHKLAK
+ Panteliella_bicolor TSAEHKLAK
+ Plagiotrochus_quercusilicis TSAEHKLAK
+ Andricus_curvator TSAEHKLAK
+ Andricus_kollari TSAEHKLAK
+ Diplolepis_rosae TSAEHKLAK
+ ;
+END;
+
--- /dev/null
+hivtree.newick <- "(((((((((((A97DCA1EQTB52:0.077166,A97DCA1MBFE185:0.077166):0.008836,(A97DCA1MBS12:0.049821,A97DCA1MBS30:0.049821):0.036182):0.010266,A97DCA1SJDS17:0.096270):0.003116,(A97DCA1KCD9:0.083123,A97DCA1KTB185:0.083123):0.016262):0.002506,A97DCA1KFE58:0.101892):0.046439,(A97DCA1KP18:0.119083,(A97DCA1KP28:0.092297,(A97DCA1KP78:0.090247,A97DCA1MBS63:0.090247):0.002049):0.026786):0.029248):0.003031,(((A97DCA2KP82:0.050058,A97DCA2KP86:0.050058):0.067136,A97DCA2MBCD5:0.117195):0.027195,((((A97DCEQS1:0.101879,A97DCKFE326:0.101879):0.014125,A97DCMBS32:0.116003):0.019791,(A97DCEQS18:0.091575,A97DCKP72:0.091575):0.044219):0.000001,((((((A97DCEQS25:0.078087,A97DCKS34:0.078087):0.036307,A97DCKS47:0.114394):0.006016,(A97DCKMST147:0.103929,(A97DCKMST89:0.091417,A97DCKTB6:0.091417):0.012512):0.016482):0.000086,((((A97DCEQTB44:0.108703,((A97DCKDS85:0.080907,A97DCMBS26:0.080907):0.023577,A97DCKTB79:0.104485):0.004218):0.005284,(A97DCKTB118:0.090239,A97DCKTB132:0.090239):0.023749):0.000575,(A97DCKCC4:0.111547,(((A97DCKP25:0.087787,A97DCKTB7:0.087787):0.018267,A97DCMBS9:0.106055):0.001233,(A97DCKS36:0.094007,A97DCKTB37:0.094007):0.013281):0.004259):0.003015):0.004429,(((A97DCKCD6:0.082435,(A97DCMBFE149:0.069344,A97DCMBFE247:0.069344):0.013092):0.000001,((A97DCKFE198:0.065151,A97DCKP77:0.065151):0.013338,(A97DCKMST52:0.070506,A97DCKS7:0.070506):0.007982):0.003946):0.012315,A97DCKTB36:0.094750):0.024241):0.001504):0.007409,(((A97DCKP36:0.107066,A97DCKTB16:0.107066):0.009046,(A97DCMBS28:0.105021,A97DCMBTB54:0.105021):0.011089):0.011793,(((A97DCKP5:0.113319,(((A97DCMBFE155:0.079795,(A97DCMBFE244:0.057624,A97DCMBFE78:0.057624):0.022171):0.017550,A97DCMBS7:0.097346):0.000001,A97DCMBS341:0.097346):0.015975):0.000815,((A97DCKTB157:0.094386,(A97DCMBP2:0.070132,A97DCMBS4:0.070132):0.024254):0.005564,A97DCMBTB29:0.099950):0.014184):0.007922,A97DCMBDS17:0.122057):0.005848):0.000001):0.000001,((((((A97DCEQS45:0.059728,A97DCEQS49:0.059728):0.021193,A97DCKS56:0.080921):0.007725,A97DCEQTB14:0.088646):0.028870,A97DCKTB20:0.117516):0.000214,A97DCKTB44:0.117729):0.004694,((((((A97DCKCC2:0.021163,A97DCKCC3:0.021163):0.050237,A97DCKTB13:0.071400):0.033783,A97DCKMST140:0.105183):0.004152,(A97DCKMST121:0.101085,((A97DCKP43:0.069726,A97DCKP79:0.069726):0.025382,(A97DCKS55:0.094174,A97DCKTB124:0.094174):0.000933):0.005977):0.008249):0.004330,((A97DCKFE4:0.067768,A97DCKS10:0.067768):0.012439,A97DCKTB48:0.080208):0.033457):0.000001,((A97DCKFE288:0.080093,(A97DCMBFE5:0.063013,A97DCSJFE26:0.063013):0.017081):0.009386,(A97DCKMST50:0.082718,A97DCKS14:0.082718):0.006759):0.024185):0.008758):0.005482):0.007891):0.008594):0.006973):0.029972,(((U97DCKFE267:0.068246,U97DCKTB119:0.068246):0.012677,U97DCMBFE250:0.080923):0.085378,U97DCKMST91:0.166301):0.015033):0.015665,(((E97DCEQS21:0.083436,(E97DCEQS5:0.077774,E97DCKP14:0.077774):0.005662):0.007143,E97DCEQTB60:0.090579):0.044516,(U97DCKFE45:0.089540,U97DCKTB49:0.089540):0.045555):0.061904):0.000001,(((D97DCD1KCD4:0.088821,D97DCD1KMST126:0.088821):0.036417,((((((((((D97DCD1KS2:0.059334,D97DCKP54:0.059334):0.024482,D97DCKP44:0.083817):0.006959,D97DCKTB181:0.090775):0.006373,(D97DCMBS55:0.057578,D97DCMBS56:0.057578):0.039570):0.004811,(D97DCD2KTB23:0.096432,D97DCKMST66:0.096432):0.005529):0.000001,(D97DCKMST30:0.058580,D97DCKP1:0.058580):0.043380):0.002729,((D97DCKS11:0.081263,D97DCKTB27:0.081263):0.013417,(D97DCKTB4:0.094129,D97DCMBS35:0.094129):0.000553):0.010008):0.003638,(D97DCD2KS26:0.104385,D97DCKS15:0.104385):0.003943):0.010453,(D97DCKS39:0.103058,D97DCMBS342:0.103058):0.015722):0.001709,(D97DCKMST144:0.103877,D97DCKS29:0.103877):0.016613):0.004749):0.007051,D97DCKFE53:0.132289):0.064709):0.012112,((((C97DCKCD11:0.130468,((((C97DCKFE372:0.081730,C97DCMBFE92:0.081730):0.023286,((((C97DCKTB110:0.096163,(C97DCMBFE14:0.093774,(C97DCMBFE300:0.089218,(C97DCMBFE34:0.069633,C97DCMBS37:0.069633):0.019585):0.004557):0.002390):0.003304,(C97DCMBFE61:0.087463,C97DCMBTB58:0.087463):0.012005):0.002932,C97DCMBTB11:0.102399):0.002618,C97DCMBTB10:0.105017):0.000001):0.007562,C97DCSJFE59:0.112580):0.011703,((C97DCMBS20:0.065542,C97DCMBTB3:0.065542):0.019087,C97DCMBS33:0.084628):0.039654):0.006187):0.005444,(C97DCMBS80:0.114630,C97DCMBTB13:0.114630):0.021282):0.056420,(((F97DCF1EQS16:0.131458,((F97DCF1KP35:0.068281,((F97DCF1KP40:0.054440,F97DCF1KTB136:0.054440):0.007403,F97DCF1KTB50:0.061843):0.006438):0.027048,((F97DCF1KS50:0.079898,F97DCF1KTB165:0.079898):0.008707,F97DCF1MBFE183:0.088605):0.006724):0.036129):0.033308,(((((K97DCEQTB43:0.092859,K97DCKTB160:0.092859):0.006717,(K97DCKP13:0.083167,K97DCKTB111:0.083167):0.016410):0.014149,K97DCMBFE71:0.113728):0.006534,K97DCKTB1:0.120261):0.010952,U97DCKTB17:0.131213):0.033553):0.013338,U97DCEQS8:0.178107):0.014226):0.012566,(((((((G97DCKCC1:0.123110,(((G97DCKFE181:0.085712,G97DCKTB56:0.085712):0.021918,(G97DCKFE77:0.095370,G97DCKP74:0.095370):0.012260):0.011021,((((G97DCKMST100:0.084544,G97DCKMST85:0.084544):0.009980,G97DCMBTB7:0.094524):0.002757,G97DCKS4:0.097281):0.014591,(G97DCKTB142:0.092882,G97DCKTB18:0.092882):0.018988):0.006781):0.004459):0.005898,(((G97DCKMST10:0.084568,G97DCKS30:0.084568):0.015160,G97DCMBFE91:0.099729):0.008825,G97DCKS27:0.108553):0.020456):0.021182,U97DCKTB22:0.150192):0.016657,U97DCKMST135:0.166847):0.009855,U97DCEQS29:0.176702):0.002466,((((J97DCKFE339:0.095333,J97DCMBTB4:0.095333):0.027238,(((J97DCKS22:0.087519,J97DCMBS41:0.087519):0.016195,J97DCKTB147:0.103713):0.013596,J97DCKTB14:0.117310):0.005262):0.020483,J97DCKS16:0.143056):0.012649,U97DCKMST120:0.155705):0.023463):0.025732,(((H97DCEQTB1:0.130368,(H97DCEQTB80:0.130368,(((H97DCKP63:0.106197,H97DCKTB158:0.106197):0.012343,H97DCKS18:0.118539):0.009461,(H97DCKS42:0.114776,H97DCKTB176:0.114776):0.013225):0.002367):0.000001):0.009940,H97DCKTB62:0.140307):0.006118,(((H97DCKCD2:0.096561,(H97DCKMST43:0.088784,(H97DCKTB140:0.078438,H97DCKTB188:0.078438):0.010346):0.007777):0.006028,H97DCKS38:0.102590):0.010076,((H97DCKS43:0.095068,H97DCKTB32:0.095068):0.014928,H97DCKTB52:0.109996):0.002670):0.033759):0.058474):0.000001):0.004212);"
--- /dev/null
+interval size
+193 0.021163
+192 0.028658
+191 0.000237
+190 0.004382
+189 0.003138
+188 4.6e-05
+187 0.000956
+186 0.000754
+185 0.000394
+184 0.002115
+183 0.00117
+182 0.002138
+181 0.000391
+180 0.002226
+179 0.000478
+178 3.5e-05
+177 0.001063
+176 0.000289
+175 9.3e-05
+174 0.000406
+173 0.000374
+172 0.000894
+171 0.005766
+170 0.000608
+169 0.000313
+168 0.000351
+167 5.1e-05
+166 0.001306
+165 0.000103
+164 0.000196
+163 0.000114
+162 0.000699
+161 1.4e-05
+160 2e-06
+159 0.00034
+158 0.000467
+157 0.000706
+156 1e-06
+155 0.000281
+154 0.000405
+153 4.4e-05
+152 0.000269
+151 0.000381
+150 0.000727
+149 2.4e-05
+148 6.1e-05
+147 0.001083
+146 0.000291
+145 0.00146
+144 5.6e-05
+143 0.000268
+142 0.000818
+141 4.1e-05
+140 0.000138
+139 3.7e-05
+138 0.000397
+137 0.000262
+136 6e-05
+135 0.000699
+134 8e-06
+133 0.000332
+132 0.000197
+131 0.000641
+130 0.000158
+129 0.000722
+128 0.000562
+127 2.3e-05
+126 0.000893
+125 0.000232
+124 0.000122
+123 4.5e-05
+122 0.000212
+121 0.000138
+120 0.000158
+119 7e-05
+118 0.000316
+117 4e-05
+116 0.000221
+115 4e-06
+114 3.7e-05
+113 0.000795
+112 0.000105
+111 0.000162
+110 0.000129
+109 0.000588
+108 0.000132
+107 6.5e-05
+106 1e-06
+105 0.002039
+104 8.3e-05
+103 0.000108
+102 0.000152
+101 0.000221
+100 0.001135
+99 0.000794
+98 1.3e-05
+97 6.9e-05
+96 1e-06
+95 0.000439
+94 0.000189
+93 0.000468
+92 0.000656
+91 0.000163
+90 5.2e-05
+89 0.000456
+88 1e-04
+87 0.000206
+86 0.000328
+85 1e-06
+84 1e-06
+83 0.000162
+82 0.000872
+81 0.000142
+80 0.000869
+79 0.000222
+78 0.000342
+77 0.000699
+76 0.000225
+75 0.000149
+74 0.000632
+73 0.000661
+72 0.001551
+71 0.000325
+70 0.00071
+69 8.4e-05
+68 0.000656
+67 0.000343
+66 1e-06
+65 6.2e-05
+64 0.00026
+63 0.000149
+62 0.000257
+61 0.000169
+60 6.7e-05
+59 0.000146
+58 0.001228
+57 0.000108
+56 0.001083
+55 0.000115
+54 0.000206
+53 0.000214
+52 0.00081
+51 0.000113
+50 0.000129
+49 0.000211
+48 9e-05
+47 0.001179
+46 0.000149
+45 8e-05
+44 6e-06
+43 0.001562
+42 0.000365
+41 0.000148
+40 0.00054
+39 0.001173
+38 0.000955
+37 0.002667
+36 1e-06
+35 1e-06
+34 9.2e-05
+33 0.001009
+32 0.001358
+31 1e-06
+30 0.000103
+29 0.000742
+28 0.000244
+27 0.000833
+26 0.002804
+25 0.0007
+24 5e-06
+23 0.000116
+22 0.004393
+21 0.002747
+20 0.001338
+19 0.002033
+18 0.001904
+17 0.001861
+16 0.001175
+15 0.004338
+14 0.009062
+13 0.001534
+12 0.000548
+11 0.009855
+10 0.001403
+9 0.001063
+8 0.002169
+7 0.010997
+6 0.004668
+5 1e-06
+4 0.007897
+3 1e-06
+2 0.004214
--- /dev/null
+landplants.newick <- "(Marchantia:0.033817,(Lycopodium:0.040281,((Equisetum:0.048533,Osmunda:0.033640,Asplenium:0.036526):0.011806,(((Cycas:0.009460,Zamia:0.018847):0.005021,Ginkgo:0.014702,((Pinus:0.021500,(Podocarpac:0.015649,Taxus:0.021081):0.006473):0.002448,(Ephedra:0.029965,(Welwitsch:0.011298,Gnetum:0.014165):0.006883):0.016663):0.006309):0.010855,(Nymphaea:0.016835,(Saururus:0.019902,Chloranth:0.020151,((Araceae:0.020003,(Palmae:0.006005,Oryza:0.031555):0.002933):0.007654,Acorus:0.038488):0.007844,(Calycanth:0.013524,Lauraceae:0.035902):0.004656,((Magnolia:0.015119,Drimys:0.010172):0.005117,(Ranunculus:0.029027,(Nelumbo:0.006180,Platanus:0.002347):0.003958,(Buxaceae:0.013294,(Pisum:0.035675,(Fagus:0.009848,Carya:0.008236):0.001459):0.001994,(Ericaceae:0.019136,Solanaceae:0.041396):0.002619):0.004803):0.006457):0.002918):0.007348,Austrobail:0.019265,Amborella:0.019263):0.003527):0.021625):0.012469):0.019372);"
--- /dev/null
+opsin.newick <- "(K02315:1.0,(((K03494:0.01102,(Z22218:0.02551,M13305:0.01918):0.02568):0.0529,(M92036:0.10771,(((L11867:0.04787,M90075:0.04443):0.03804,(U12025:0.03546,U12024:0.03083):0.09483):0.01674,(U08131:0.03238,M62903:0.06372):0.03889):0.0225):0.02172):0.30285,((M92039:0.11603,M13299:0.09036):0.34447,((M92037:0.19778,(S66838:0.09894,L11864:0.12521):0.08389):0.18755,(((M92038:0.10886,M92035:0.11081):0.02094,(L11865:0.03836,L11866:0.05773):0.09929):0.02435,(M63632:0.07742,((S27231:0.04088,L07770:0.05902):0.03589,(D00702:0.05681,(((A48191:0.03454,L11863:0.06155):0.04872,U12328:0.09886):0.06074,((K00506:0.01815,A30407:0.01949):0.01219,(M55171:0.02431,(S32696:0.01388,K02281:0.02728):0.0016):0.00518):0.03677):0.00466):0.00811):0.05686):0.07065):0.1661):0.09599):0.1443):0.2164);"
--- /dev/null
+require(ape, quietly = TRUE, save = FALSE) # added line
+woodmouse <- read.dna("woodmouse.txt", format = "sequential")
--- /dev/null
+15 965
+No305 NTTCGAAAAACACACCCACTACTAAAANTTATCAGTCACTCCTTCATCGACTTACCAGCTCCATCTAACATTTCATCATGATGAAACTTCGGCTCATTACTAGGAGTCTGCCTAATAATCCAAATCCTCACAGGCTTATTCCTAGCAATACACTACACATCAGACACAATAACAGCATTCTCTTCAGTAACCCATATTTGTCGAGACGTAAATTATGGCTGACTAATTCGATACATACATGCAAACGGAGCCTCAATATTTTTTATTTGCCTATTTCTTCATGTAGGACGAGGAATGTATTACGGGTCATACATTTTCATAGAAACATGAAACATCGGTGTGGTCCTTTTATTCGCAGTAATAGCCACAGCATTCATAGGATATGTTCTTCCATGAGGACAAATATCCTTCTGAGGAGCTACAGTAATTACAAANTTACTATCAGCAATTCCATACATCGGAACTACCCTAGTAGAGTGAATCTGAGGAGGATTCTCAGTAGACAAAGCCACACTGACACGTTTTTTCGCTTTTCACTTTATCCTTCCATTTATCATTGCCGCCCTAGTAATTGTCCACCTCTTGTTTCTCCATGAAACTGGATCTAATAACCCAACAGGCCTTAACTCAGACGCCGATAAAATCCCATTTCACCCTTACTATACAATTAAAGATATTCTAGGTGTACTAATAATAGTTTCCTTCCTAATAACTTTAGTCCTTTTCTTTCCAGACCTTTTAGGTGACCCGGACAACTACATGCCTGCTAACCCACTTAACACCCCACCTCATATTAAACCAGAATGATATTTCCTATTTGCCTATGCAATCCTACGATCCATCCCCAATAAACTAGGCGGAGTCCTAGCCCTAATTCTATCAATCTTAATTTTAGCCTTATTACCATTTCTTCACACTTCCAAACAACGCAGCCTAATATTCCGCCCAATTACTCAGACCCTATA
+No304 ATTCGAAAAACACACCCACTACTAAAAATTATCAACCACTCCTTCATCGACTTACCAGCTCCATCTAACATTTCATCATGATGAAACTTCGGCTCATTACTAGGAATCTGCCTAATAATCCAAATCCTCACAGGCTTATTCCTAGCAATACACTACACATCAGACACAATAACAGCATTCTCTTCAGTAACCCATATTTGTCGAGACGTAAATTATGGCTGACTAATTCGATATATACATGCAAACGGAGCCTCAATATTTTTTATTTGCCTATTTCTTCATGTAGGACGAGGAATGTATTACGGGTCATACATTTTTATAGAAACATGAAACATCGGTGTAGTCCTTTTATTCGCAGTAATAGCCACAGCATTCATAGGATATGTTCTTCCATGAGGACAAATATCCTTCTGAGGAGCTACAGTAATTNCAAATTTACTNTCAGCAATTCCATACATCGGAACTACCCTAGTAGAATGAATCTGAGGAGGATTCTCAGTAGACAAAGCTACATTGACACGTTTTTTCGCTTTTCACTTCATCCTTCCATTTATCATTGCCGCCCTAGTAATTGTTCACCTCTTGTTTCTCCATGAAACTGGATCTAATAACCCAACAGGCCTTAACTCAGACGCCGATAAAATCCCATTTCACCCTTACTATACAATTAAAGATATTCTAGGTGTACTAATAATAGTTTCCTTCCTAATAACTCTAGTCCTTTTCTTTCCAGACCTTTTAGGTGACCCGGACAACTACATGCCTGCTAACCCACTTAACACCCCACCTCATATTAAACCAGAATGATACTTCCTATTTGCCTATGCAATCCTACGGTCCATCCCCAATAAACTAGGCGGAGTCCTAGCCCTAATTCTATCAATCTTAATTTTAGCCTTATTACCATTTCTTCACACTTCCAAACAACGCAGCCTAATATTCCGCCCAATTACTCAAACCCTGTN
+No306 ATTCGAAAAACACACCCACTACTAAAAATTATCAATCACTCCTTCATCGACTTACCAGCTCCATCTAACATTTCATCATGATGAAACTTCGGCTCATTACTAGGAATCTGCCTAATAATCCAAATCCTCACAGGCTTATTCCTAGCAATACACTACACATCAGACACAATAACAGCATTCTCTTCAGTAACCCATATTTGTCGAGACGTAAATTATGGCTGACTAATTCGATATATACATGCAAACGGAGCCTCAATATTTTTTATTTGCCTATTTCTTCATGTAGGACGAGGAATGTATTACGGGTCATACATTTTTATAGAAACATGAAACATCGGTGTGATCCTTTTATTCGCAGTAATAGCCACAGCATTCATAGGATATGTTCTTCCATGAGGACAAATATCCTTCTGAGGAGCTACAGTAATTACAAATTTACTATCAGCAATTCCATACATCGGAACTACCCTAGTAGAATGAATCTGAGGAGGATTCTCAGTAGACAAAGCTACATTGACACGTTTTTTCGCTTTTCACTTCATCCTTCCATTTATCATTGCCGCCCTAGTAATTGTTCACCTCTTGTTTCTCCATGAAACTGGATCTAATAACCCAACAGGCCTTAACTCAGACGCCGATAAAATCCCATTTCACCCTTACTATACAATTAAAGATATTCTAGGTGTACTAATAATAGTTTCCTTCCTAATAACTTTAGTCCTTTTCTTTCCAGACCTTTTAGGTGACCCGGACAACTACATGCCTGCTAACCCACTTAACACCCCACNNCATATTAAACCAGAATGATACTTCCTATTTGCCTATGCAATCCTACGGTCCATCCCCAATAAACTAGGCGGAGTCCTAGCCCTAATTCTATCAATCTTAATTTTAGCCTTATTACCATTTCTTCACACTTCCAAACAACGCAGCCTAATATTCCGCCCAATTACTCAAACCCTATA
+No0906S ATTCGAAAAACACACCCACTACTAAAAATCATCAATCACTCCTTCATCGATTTACCAGCTCCATCTAACATTTCATCATGATGAAACTTCGGCTCATTACTAGGAATCTGCCTAATAATCCAAATCCTCACAGGCTTATTCCTAGCAATACACTACACATCAGACACAATAACAGCATTCTCTTCAGTAACCCATATTTGTCGAGACGTAAATTATGGCTGACTAATTCGATATATACATGCAAACGGAGCCTCAATATTTTTTATTTGCCTATTTCTTCATGTAGGACGAGGAATGTATTACGGATCATACATTTTTATAGAAACATGAAACATCGGTATGATCCTTTTATTCGCAGTAATAGCCACAGCATTCATAGGATATGTTCTTCCATGAGGACAAATATCCTTCTGAGGAGCTACAGTAATTACAAATTTACTATCAGCAATTCCATACATCGGAACTACCCTAGTAGAGTGAATCTGAGGAGGATTCTCAGTAGACAAAGCTACATTGACACGTTTTTTCGCTTTTCACTTCATCCTTCCATTTATCATTGCCGCCCTAGTAATTGTTCACCTCTTGTTTCTCCATGAAACTGGATCTAATAACCCAACAGGCCTTAACTCAGACGCCGATAAAATCCCATTTCACCCTTACTATACAATTAAAGATATTCTAGGTGTACTAATAATAATTTCCTTCCTAATAACTTTAGTCCTTTTCTTTCCAGACCTTTTAGGTGACCCGGACAACTACATGCCTGCTAACCCACTTAACACCCCACCTCATATTAAACCAGAATGATACTTCCTATTTGCCTATGCAATCCTACGATCCATCCCCAATAAACTAGGCGGAGTCCTAGCCCTAATTCTATCAATCTTAATTTTAGCCTTATTACCATTTCTTCACACTTCCAAACAACGCAGCCTAATATTCCGCCCAATTACTCAAATACNNNN
+No0908S ATTCGAAAAACACACCCACTACTAAAAATTATCAATCACTCCTTCATCGACTTACCAGCCCCATCTAACATTTCATCATGATGAAACTTCGGCTCATTACTAGGAATCTGCCTAATAATCCAAATCCTCACAGGCTTATTCCTAGCAATACACTACACATCAGACACAATAACAGCATTCTCTTCAGTAACCCATATTTGTCGAGACGTAAATTATGGCTGACTAATTCGATATATACATGCAAACGGAGCCTCAATATTTTTTATTTGCCTATTTCTCCATGTAGGACGAGGAATGTATTACGGGTCATACATTTTTATAGAAACATGAAACATCGGTGTGATCCTTTTATTCGCAGTAATAGCCACAGCATTCATAGGATATGTTCTTCCATGAGGACAAATATCCTTCTGAGGGGCTACAGTAATTACAAATTTACTATCAGCAATTCCATATATCGGAACTACCCTAGTAGAGTGAATCTGAGGAGGATTCTCAGTAGACAAAGCTACATTGACACGTTTTTTCGCTTTTCACTTCATCCTCCCATTTATCATTGCCGCCCTAGTAATTGTTCACCTCTTGTTTCTCCATGAAACTGGATCTAATAACCCAACAGGCCTTAACTCAGACGCCGATAAAATCCCATTTCACCCTTACTATACAATTAAAGATATTCTAGGTGTACTAATAATAGTTTCCTTCCTAATAACTTTAGTCCTTTTCTTTCCAGACCTTTTAGGTGACCCGGACAACTACATGCCTGCTAACCCACTTAACACCCCACCTCATATTAAACCAGAATGATACTTCCTATTTGCCTATGCAATCCTACGATCCATCCCCAATAAACTAGGCGGAGTCCTAGCCCTAATTCTATCAATCTTAATTTTAGCCTTATTACCATTTCTTCACACTTCCAAACAACGCAGCCTAATATTCCGCCCAATTACTCAAACCCNNNN
+No0909S ATTCGAAAAACACACCCACTACTAAAAATTATCAATCACTCCTTCATCGACTTACCAGCTCCATCTAACATCTCATCATGATGAAACTTCGGCTCCTTACTAGGAATCTGCCTAATAATCCAAATCCTCACAGGCTTATTCCTAGCAATACACTACACATCAGACACAATAACAGCATTCTCTTCAGTAACCCATATTTGTCGAGACGTAAACTATGGCTGACTAATTCGATATATACATGCAAACGGAGCCTCAATATTTTTTATTTGCCTATTTCTTCATGTAGGACGAGGAATGTATTACGGGTCATACACTTTCATAGAAACATGAAACATCGGTGTGATCCTTCTATTCGCAGTAATAGCCACAGCATTCATAGGATATGTTCTTCCATGAGGACAAATATCCTTCTGAGGAGCTACAGTAATTACAAATTTACTATCAGCAATTCCATACATCGGGACTACCCTAGTAGAGTGAATCTGAGGAGGATTCTCAGTAGACAAAGCTACATTGACACGTTTTTTCGCTTTTCACTTTATCCTTCCATTTATCATTGCCGCCCTAGTAATTGTTCACCTCTTGTTTCTCCATGAAACTGGATCTAATAACCCAACAGGCCTTAACTCAGACGCCGATAAAATCCCATTTCACCCTTACTATACAATTAAAGATATTCTAGGTGTACTAATAATAGTTTCCTTCCTAATAACTTTAGTCCTTTTCTTTCCAGACCTTTTAGGTGACCCGGACAACTACATGCCTGCTAACCCACTTAACACCCCACCTCATATTAAACCAGAATGATACTTCCTATTTGCCTATGCAATCCTACGATCCATCCCCAATAAACTAGGCGGAGTCCTAGCCCTAATCCTATCAATCTTAATTTTAGCCTTATTACCATTTCTTCACACTTCCAAACAACGCAGCCTAATATTCCGCCCAATTACTCAAACCCNNNN
+No0910S ATTCGAAAAACACACCCACTACTAAAAATTATCAATCACTCTTTCATCGATTTACCAGCTCCATCTAACATTTCATCATGATGAAACTTCGGCTCATTACTAGGAATCTGCCTAATAATCCAGATCCTCACAGGCTTATTCCTAGCAATACACTACACATCAGACACAATAACAGCATTCTCTTCAGTAACCCATATTTGTCGAGACGTAAATTATGGCTGACTAATTCGATATATACATGCAAACGGAGCCTCAATATTTTTTATTTGCCTATTTCTTCATGTAGGACGAGGAATGTATTACGGATCATACATTTTTATAGAAACATGAAACATCGGTGTGATCCTTTTATTCGCAGTAATAGCCACAGCATTCATAGGATATGTTCTTCCATGAGGACAAATATCCTTCTGAGGAGCTACAGTAATTACAAATTTACTATCAGCAATTCCATACATCGGAACTACCCTAGTAGAGTGAATCTGAGGAGGATTCTCAGTAGACAAAGCTACATTGACACGTTTTTTCGCTTTTCACTTCATCCTTCCATTTATCATTGCCGCCCTAGTAATTGTTCACCTCTTGTTTCTCCATGAAACTGGATCTAATAACCCAACAGGCCTTAACTCAGACGCCGATAAAATCCCATTTCACCCTTACTATACAATTAAAGATATTCTAGGCGTACTAATAATAGTTTCCTTCCTAATAACTTTAGTCCTTTTCTTTCCAGACCTTTTAGGTGACCCGGACAACTACATGCCTGCTAACCCACTTAACACCCCACCTCATATTAAACCAGAATGATACTTCCTATTTGCCTATGCAATCCTACGATCCATCCCCAATAAACTAGGCGGAGTCCTAGCCCTAATTCTATCAATCTTAATTTTAGCCTTATTACCATTTCTTCACACTTGCAAACAACGCAGCCTAATATTCCGCCCAATTACTCAAACCCNNNN
+No0912S ATTCGAAAAACACACCCACTACTAAAAATTATCAATCACTCCTTCATCGACTTACCAGCTCCATCTAACATCTCATCATGATGAAACTTCGGCTCCTTACTAGGAATCTGCCTAATAATCCAAATCCTCACAGGCTTATTCCTAGCAATACACTACACATCAGACACAATAACAGCATTCTCTTCAGTAACCCATATTTGTCGAGACGTAAATTATGGCTGACTAATTCGATATATACATGCAAACGGAGCCTCAATATTTTTTATTTGCCTATTTCTTCATGTAGGACGGGGAATGTATTACGGGTCATACATTTTCATAGAAACATGAAACATCGGTGTGATCCTTTTATTCGCAGTAATAGCCACAGCATTCATAGGATATGTTCTTCCATGAGGACAAATATCCTTCTGAGGAGCTACAGTAATTACAAATTTACTATCAGCAATTCCATACATCGGAACTACCCTAGTAGAGTGAATCTGAGGAGGATTCTCAGTAGACAAAGCTACATTGACACGTTTTTTCGCTTTCCACTTCATCCTTCCATTTATCATTGCCGCCCTAGTAATTGTTCACCTCTTGTTTCTCCATGAAACTGGATCTAATAACCCAACAGGCCTTAACTCAGACGCCGATAAAATCCCATTTCACCCTTACTATACAATTAAAGACATTCTAGGTGTACTAATAATAGTTTCCTTCCTAATAACTTTAGTCCTTTTCTTTCCAGACCTTTTAGGTGACCCGGACAACTACATGCCTGCTAACCCACTTAACACCCCACCTCATATTAAACCAGAATGATATTTCCTATTTGCCTATGCAATCCTACGATCCATCCCCAATAAACTAGGCGGAGTCCTAGCCCTAATTCTATCAATCTTAATTTTAGCCTTATTACCATTTCTTCACACTTCCAAACAACGCAGCCTAATATTCCGCCCAATTACTCAAACCCNNNN
+No0913S ATTCGAAAAACACACCCACTACTAAAAATTATCAACCACTCCTTCATCGACTTACCAGCTCCATCTAACATTTCATCATGATGAAACTTCGGCTCATTACTAGGAATCTGCCTAATAATCCAAATCCTCACAGGCTTATTCCTAGCAATACACTACACATCAGACACAATAACAGCATTCTCTTCAGTAACCCATATTTGTCGAGACGTAAATTATGGCTGACTAATTCGATATATGCATGCAAACGGAGCCTCAATATTTTTTATTTGCCTATTTCTTCATGTAGGACGAGGAATGTATTACGGATCATACATTTTTATAGAAACATGAAACATCGGTGTGATCCTTTTATTCGCAGTAATAGCCACAGCATTCATAGGATATGTTCTTCCATGAGGACAAATATCCTTCTGAGGAGCTACAGTAATTACAAATTTACTATCAGCAATTCCATACATCGGAACTACCCTAGTAGAATGAATCTGAGGAGGATTCTCAGTAGACAAAGCTACATTGACACGTTTTTTCGCTTTTCACTTCATCCTTCCATTTATCATTGCCGCCCTAGTAATTGTTCACCTCTTGTTTCTCCATGAAACTGGATCTAATAACCCAACAGGCCTTAACTCAGACGCCGATAAAATCCCATTTCACCCTTACTATACAATTAAAGATATTCTAGGCGTACTAATAATAGTTTCCTTCCTAATAACTCTAGTCCTTTTCTTTCCAGACCTTTTAGGTGACCCGGACAACTACATGCCTGCTAACCCACTTAACACCCCACCTCATATTAAACCAGAATGATACTTCCTATTTGCCTATGCAATCCTACGGTCCATCCCCAATAAACTAGGCGGAGTCCTAGCCCTAATTCTATCAATCTTAATTTTAGCCTTATTACCATTTCTTCACACTTCCAAACAACGCAGCCTAATATTCCGCCCAATTACTCAAACCCNNNN
+No1103S ATTCGAAAAACACACCCACTACTAAAAATTATTAATCACTCCTTCATCGACTTACCAGCTCCATCTAACATCTCATCATGATGAAACTTCGGCTCCTTACTAGGAATCTGCCTAATAATCCAAATCCTCACAGGCTTATTCCTAGCAATACACTACACATCAGACACAATAACAGCATTCTCTTCAGTAACCCATATTTGTCGAGACGTAAATTATGGCTGACTAATTCGATATATACATGCAAACGGAGCCTCAATATTTTTTATTTGCCTATTTCTTCATGTAGGACGAGGAATGTATTACGGGTCATACATTTTCATAGAAACATGAAACATCGGTGTGATCCTTTTATTCGCAGTAATAGCCACAGCATTCATAGGATATGTTCTTCCATGAGGACAAATATCCTTCTGAGGAGCTACAGTAATTACAAATTTACTATCAGCAATTCCATACATCGGAACTACCCTAGTAGAGTGAATCTGAGGAGGATTCTCAGTAGACAAAGCTACATTGACACGTTTTTTCGCTTTTCACTTCATCCTTCCATTTATCATTGCCGCCCTAGTAATTGTTCACCTCTTGTTTCTCCATGAAACTGGATCTAATAACCCAACAGGCCTTAACTCAGACGCCGATAAAATCCCATTTCACCCTTACTATACAATTAAAGATATTCTAGGTGTACTAATAATAGTTTCCTTCCTAATAACTTTAGTCCTTTTCTTTCCAGACCTTTTAGGTGACCCGGACAACTACATGCCTGCTAACCCACTTAACACCCCACCTCATATTAAACCAGAATGATATTTCCTATTTGCCTATGCAATCCTACGATCCATCCCCAATAAACTAGGCGGAGTCCTAGCCCTAATTCTATCAATCTTAATTTTAGCCTTATTACCATTTCTTCACACTTCCAAACAACGCAGCCTAATATTCCGCCCAATTACTCAAACCCNNNN
+No1007S ATTCGAAAAACACACCCACTACTAAAAATTATCAATCACTCCTTCATCGACTTACCAGCTCCATCTAACATCTCATCATGATGAAACTTCGGCTCCTTACTAGGAATCTGCCTAATAATCCAAATCCTCACAGGCTTATTCCTAGCAATACACTACACATCAGACACAATAACAGCATTCTCTTCAGTAACCCATATTTGCCGAGACGTAAATTATGGCTGACTAATTCGATATATACATGCAAACGGAGCCTCAATATTTTTTATTTGCCTATTTCTTCATGTAGGACGAGGAATGTATTACGGGTCATACACTTTCATAGAAACATGAAACATCGGTGTGATCCTTCTATTCGCAGTAATAGCCACAGCATTCATAGGATATGTTCTTCCATGAGGACAAATATCCTTCTGAGGAGCTACAGTAATTACAAATTTACTATCAGCAATTCCATACATCGGGACTACCCTAGTAGAGTGAATCTGAGGAGGATTCTCAGTAGACAAAGCTACATTGACACGTTTTTTCGCTTTTCACTTTATCCTTCCATTTATCATTGCCGCCCTAGTAATTGTTCACCTCTTGTTTCTCCATGAAACTGGATCTAATAACCCAACAGGCCTTAACTCAGACGCCGATAAAATCCCATTTCACCCTTACTATACAATTAAAGATATTCTAGGTGTACTAATAATAGTTTCCTTCCTAATAACTTTAGTCCTTTTCTTTCCAGACCTTTTAGGTGACCCGGACAACTACATGCCTGCTAACCCACTTAACACCCCACCTCATATTAAACCAGAATGATACTTCCTATTTGCCTATGCAATCCTACGATCCATCCCCAATAAACTAGGCGGAGTCCTAGCCCTAATCCTATCAATCTTAATTTTAGCCTTATTACCATTTCTTCACACTTCCAAACAACGCAGCCTAATATTCCGCCCAATTACTCAAACCCNNNN
+No1114S NNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNNATCGACTTACCAGCTCCATCTAACATTTCATCATGATGAAACTTCGGCTCATTACTAGGAGTCTGCCTAATAATCCAAATCCTCACAGGCTTATTCCTAGCAATACACTACACATCAGACACAATAACAGCATTCTCTTCAGNAACCCATATTTGCCGAGACGTAAATTATGGCTGACTAATTCGATATATACATGCAAACGGAGCCTCAATATTTTTTATTTGCCTATTTCTTCATGTAGGACGAGGAATATATTACGGCTCATACATTCTCATAGAAACATGAAACATCGGTGTGGTCCTTTTATTCGCAGTAATAGTCACAGCATTCATAGGATATGTTCTTCCATGAGGACAAATATCCTTCTGAGGAGCTACAGTAATTACAAATTTCCTATCAGCAATTCCATACATCGGAACTACCCTAGTAGAGTGAATCTGAGGAGGATTCTCAGTAGACAAAGCTACATTGACACGTTTTTTCGCTTTTCACTTTATCCTTCCATTTATCATTGCCGCCCTAGTAATTGTTCACCTCTTGTTTCTCCATGAAACTGGATCTAATAACCCAACAGGCCTTAACTCAGACGCCGATAAAATCCCATTTCACCCTTACTATACAATTAAGGATATTCTAGGTGTACTAATAATAGTTTCCTTCCTAATAACTTTAGTCCTTTTCTTTCCAGACCTTTTAGGTGACCCGGACAACTACATGCCTGCTAACCCACTTAACACCCCACCTCATATTAAACCAGAATGATATTTCCTATTTGCCTATGCAATCCTACGGTCCATCCCCAATAAACTAGGCGGAGTCCTAGCCCTAATTCTATCAATCTTAATTTTAGCCTTATTACCATTCCTTCACACTTCCAAACAACGCAGCCTAATATTCCGCCCAATTACTCAAACCCNNNN
+No1202S ATTCGAAAAACACACCCACTACTAAAAATTATCAATCACTCCTTCATCGATTTACCAGCTCCATCTAACATTTCATCATGATGAAACTTCGGCTCATTACTAGGAATCTGCCTAATAATCCAGATCCTCACAGGCTTATTCCTAGCAATACACTACACATCAGACACAATAACAGCATTCTCTTCAGTAACCCATATTTGCCGAGACGTAAATTATGGCTGACTAATTCGATATATACATGCAAACGGAGCCTCAATATTTTTTATTTGCCTATTTCTTCATGTAGGACGAGGAATGTATTACGGATCATACATTTTTATAGAAACATGAAACATCGGTGTGATCCTTTTATTCGCAGTAATAGCCACAGCATTCATAGGATATGTTCTTCCATGAGGACAAATATCCTTCTGAGGAGCTACAGTAATTACAAATTTACTATCAGCAATTCCATACATCGGAACTACCCTAGTAGAGTGAATCTGAGGAGGATTCTCAGTAGACAAAGCTACATTGACACGTTTTTTCGCTTTTCACTTCATCCTTCCATTTATCATTGCCGCCCTAGTAATTGTTCACCTCTTGTTTCTCCATGAAACTGGATCTAATAACCCAACAGGCCTTAACTCAGACGCCGATAAAATCCCATTTCACCCTTACTATACAATTAAAGATATTCTAGGCGTACTAATAATAGTTTCCTTCCTAATAACTTTAGTCCTTTTCTTTCCAGACCTTTTAGGTGACCCGGACAACTACATGCCTGCTAACCCACTTAACACCCCACCTCATATTAAACCAGAATGATACTTCCTATTTGCCTATGCAATCCTACGATCCATCCCCAATAAACTAGGCGGAGTCCTAGCCCTAATTCTATCAATCTTAATTTTAGCCTTATTACCATTTCTTCACACTTCCAAACAACGCAGCCTAATATTCCGCCCAATTACTCAAACCCNNNN
+No1206S ATTCGAAAAACACACCCACTACTAAAAATTATCAATCACTCCTTCATCGATTTGCCAGCTCCATCTAACATTTCATCATGATGAAACTTCGGCTCATTACTAGGAATCTGCCTAATAATCCAAATCCTCACAGGCTTATTCCTAGCAATACACTACACATCAGACACAATAACAGCATTCTCTTCAGTAACCCATATTTGTCGAGACGTAAATTATGGCTGACTAATTCGATATATACATGCAAACGGAGCCTCAATATTTTTTATTTGCCTATTTCTCCATGTAGGACGAGGAATGTATTACGGGTCATACATTTTTATAGAAACATGAAACATCGGTGTGATCCTTTTATTCGCAGTAATAGCCACAGCATTCATAGGATATGTTCTTCCATGAGGACAAATATCCTTCTGAGGAGCTACAGTAATTACAAATTTACTATCAGCAATTCCATACATCGGAACTACCCTAGTAGAGTGAATCTGAGGAGGATTCTCAGTAGACAAAGCTACATTGACACGTTTTTTCGCTTTTCACTTCATCCTTCCATTTATCATTGCCGCCCTAGTAATTGTGCACCTCTTGTTTCTTCATGAAACTGGATCTAATAACCCAACAGGCCTTAACTCAGACGCCGATAAAATCCCATTTCACCCTTACTATACAATTAAAGATATTCTAGGTGTACTAATAATAGTTTCCTTCCTAATAACTTTAGTCCTTTTCTTTCCAGACCTCTTAGGTGACCCGGACAACTACATGCCTGCTAACCCACTTAACACCCCACCTCATATTAAACCAGAATGATACTTCCTATTTGCCTATGCAATCCTACGATCCATCCCCAATAAACTAGGCGGAGTCCTAGCCCTAATTCTATCAATCTTAATTTTAGCCTTATTACCATTTCTTCACACTTCCAAACAACGCAGCCTAATATTCCGCCCAATTACTCAAACCCNNNN
+No1208S NNNCGAAAAACACACCCACTACTAAAAATTATCAATCACTCCTTCATCGACTTACCAGCTCCATCTAACATCTCATCATGATGAAACTTCGGCTCCTTACTAGGAATCTGCCTAATAATCCAAATCCTCACAGGCTTATTCCTAGCAATACACTACACATCAGACACAATAACAGCATTCTCTTCAGTAACCCATATTTGCCGAGACGTAAACTATGGCTGACTAATTCGATATATACATGCAAACGGAGCCTCAATATTTTTTATTTGCCTATTTCTTCATGTAGGACGAGGAATGTATTACGGGTCATACACTTTCATAGAAACATGAAACATCGGTGTGATCCTTCTATTCGCAGTAATAGCCACAGCATTCATAGGATATGTTCTTCCATGAGGACAAATATCCCTCTGAGGAGCTACAGTAATTACAAATTTACTATCAGCAATTCCATACATCGGGACTACCCTAGTAGAGTGAATCTGAGGAGGATTCTCAGTAGACAAAGCTACATTGACACGTTTTTTCGCTTTTCACTTTATCCTTCCATTTATCATTGCCGCCCTAGTAATTGTTCACCTCTTGTTTCTCCATGAAACTGGATCTAATAACCCAACAGGCCTTAACTCAGACGCCGATAAAATCCCATTTCACCCTTACTATACAATTAAAGATATTCTAGGTGTACTAATAATAGTTTCCTTCCTAATAACTTTAGTCCTTTTCTTTCCAGACCTTTTAGGTGACCCGGACAACTACATGCCTGCTAACCCACTTAACACCCCACCTCATATTAAACCAGAATGATACTTCCTATTTGCCTATGCAATCCTACGATCCATCCCCAATAAACTAGGCGGAGTCCTAGCCCTAATCCTATCAATCTTAATTTTAGCCTTATTACCATTTCTTCACACTTCCAAACAACGCAGCCTAATATTCCGCCCAATTACTCAAACCCNNNN
\ No newline at end of file
--- /dev/null
+"xenarthra" <-
+structure(list(edge = structure(c(51, 51, 52, 52, 51, 53, 54,
+55, 56, 57, 57, 56, 58, 59, 59, 60, 60, 58, 61, 61, 62, 62, 55,
+63, 64, 64, 65, 65, 63, 66, 66, 54, 67, 68, 68, 69, 69, 67, 70,
+70, 71, 71, 72, 72, 53, 73, 74, 74, 75, 75, 76, 76, 77, 77, 78,
+79, 79, 80, 80, 78, 81, 81, 73, 82, 83, 83, 82, 84, 85, 86, 87,
+88, 88, 87, 89, 89, 86, 90, 90, 91, 91, 85, 92, 93, 93, 92, 94,
+94, 95, 95, 96, 96, 97, 97, 84, 98, 98, 1, 52, 2, 3, 53, 54,
+55, 56, 57, 4, 5, 58, 59, 6, 60, 7, 8, 61, 9, 62, 10, 11, 63,
+64, 12, 65, 13, 14, 66, 15, 16, 67, 68, 17, 69, 18, 19, 70, 20,
+71, 21, 72, 22, 23, 73, 74, 24, 75, 25, 76, 26, 77, 27, 78, 79,
+28, 80, 29, 30, 81, 31, 32, 82, 83, 33, 34, 84, 85, 86, 87, 88,
+35, 36, 89, 37, 38, 90, 39, 91, 40, 41, 92, 93, 42, 43, 94, 44,
+95, 45, 96, 46, 97, 47, 48, 98, 49, 50), .Dim = c(97, 2)), edge.length = c(0.109894,
+0.022173, 0.066834, 0.047474, 0.427827, 0.002024, 0.025857, 0.022981,
+0.026731, 0.007126, 0.008411, 0.006233, 0.017379, 0.002957, 0.001106,
+0.002583, 0.003687, 0.005152, 0.012123, 0.000671, 0.011783, 0.008738,
+0.008776, 0.011882, 0.035474, 0.038071, 0.012415, 0.012484, 0.025252,
+0.021598, 0.015425, 0.029149, 0.013247, 0.033688, 0.003945, 0.047081,
+0.123258, 0.004856, 0.082597, 0.002941, 0.156433, 0.006792, 0.097117,
+0.220728, 0.009689, 0.00691, 0.12952, 0.00221, 0.086326, 0.000742,
+0.06454, 0.00375, 0.140251, 0.012014, 0.006192, 0.266772, 0.204941,
+0.070565, 0.056994, 0.041168, 0.058614, 0.062632, 0.013307, 0.015539,
+0.112732, 0.168348, 0.003898, 0.00109, 0.014771, 0.001936, 0.050427,
+0.017972, 0.038131, 0.007296, 0.070184, 0.060133, 0.014944, 0.182596,
+0.010519, 0.055868, 0.040506, 0.000379, 0.015614, 0.035851, 0.045494,
+0.024393, 0.059475, 0.005829, 0.081795, 0.00852, 0.09217, 0.003101,
+0.051699, 0.038765, 0.006122, 0.082358, 0.082157), tip.label = c("Didelphis",
+"Macropus", "Vombatus", "Dasypus_no", "Dasypus_ka", "Zaedyus",
+"Chaetophractus", "Euphractus", "Priodontes", "Tolypeutes", "Cabassous",
+"Cyclopes", "Myrmecophaga", "Tamandua", "Bradypus", "Choloepus",
+"Dugong", "Elephas", "Procavia", "Orycteropus", "Macroscelides",
+"Amblysomus", "Echinops", "Tupaia", "Homo", "Cynocephalus", "Lepus",
+"Hystrix", "Mus", "Rattus", "Glaucomys", "Aplodontia", "Scalopus",
+"Erinaceus", "Pteropus", "Cynopterus", "Megaderma", "Hipposideros",
+"Tonatia", "Myotis", "Tadarida", "Diceros", "Equus", "Lama",
+"Sus", "Bos", "Hippopotamus", "Physeter", "Manis", "Felis"),
+ Nnode = 48), .Names = c("edge", "edge.length", "tip.label",
+"Nnode"), class = "phylo")
--- /dev/null
+citHeader("To cite ape in a publication use:")
+
+citEntry(entry="Article",
+ title = "APE: 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
--- /dev/null
+\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 $1/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}
--- /dev/null
+@STRING{Ev = {Evolution}}
+@STRING{SZ = {Systematic Zoology}}
+@STRING{ny = {New York}}
+
+@book{Cliff1973,
+ Author = {Cliff, A. D. and Ord, J. K.},
+ Title = {{Spatial Autocorrelation}},
+ Publisher = {Pion},
+ Address = {London},
+ Year = 1973}
+
+@incollection{Cliff1981,
+ Author = {Cliff, A. D. and Ord, J. K.},
+ Title = {{Spatial and temporal analysis: autocorrelation in space and time}},
+ BookTitle = {{Quantitative Geography: A British View}},
+ Editor = {Wrigley, E. N. and Bennett, R. J.},
+ Publisher = {Routledge \& Kegan Paul},
+ Address = {London},
+ Pages = {104-110},
+ Year = 1981}
+
+@article{Cheverud1985,
+ Author = {Cheverud, J. M. and Dow, M. M. and Leutenegger, W.},
+ Title = {{The quantitative assessment of phylogenetic constraints in comparative analyses: sexual dimorphism in body weight among primates}},
+ Journal = Ev,
+ Volume = {39},
+ Pages = {1335-1351},
+ Year = 1985}
+
+@article{Gittleman1990,
+ Author = {Gittleman, J. L. and Kot, M.},
+ Title = {{Adaptation: statistics and a null model for estimating phylogenetic effects}},
+ Journal = SZ,
+ Volume = {39},
+ Pages = {227-241},
+ Year = 1990}
+
+@article{Moran1950,
+ Author = {Moran, P. A. P.},
+ Title = {{Notes on continuous stochastic phenomena}},
+ Journal = {Biometrika},
+ Volume = {37},
+ Pages = {17-23},
+ Year = 1950}
+
+@book{Paradis2006,
+ Author = {Paradis, E.},
+ Title = {{Analysis of Phylogenetics and Evolution with R}},
+ Publisher = {Springer},
+ Address = ny,
+ Year = 2006}
--- /dev/null
+\name{DNAbin}
+\alias{DNAbin}
+\alias{print.DNAbin}
+\alias{summary.DNAbin}
+\alias{[.DNAbin}
+\alias{rbind.DNAbin}
+\alias{cbind.DNAbin}
+\alias{as.matrix.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, \dots)
+\method{summary}{DNAbin}(object, printlen = 6, digits = 3, \dots)
+\method{rbind}{DNAbin}(\dots)
+\method{cbind}{DNAbin}(\dots, check.names = TRUE)
+\method{[}{DNAbin}(x, i, j, drop = TRUE)
+\method{as.matrix}{DNAbin}(x, \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{summary}, and
+ \code{as.matrix}, or a series of objects of class \code{"DNAbin"} in
+ the case of \code{rbind} and \code{cbind}.}
+ \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{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 default), the returned object
+ is of the lowest possible dimension.}
+}
+\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.
+
+ 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}, if \code{"check.names = TRUE"}, the rownames of each
+ matrix are checked, and the rows are reordered if necessary. If the
+ rownames differ among matrices, an error occurs. If
+ \code{"check.names = FALSE"}, the matrices are simply binded and the
+ rownames of the first matrix are used.
+
+ \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.
+}
+\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://pbil.univ-lyon1.fr/R/ape/misc/BitLevelCodingScheme_20April2007.pdf}
+}
+\author{Emmanuel Paradis \email{Emmanuel.Paradis@mpl.ird.fr}}
+\seealso{
+ \code{\link{as.DNAbin}}, \code{\link{read.dna}},
+ \code{\link{read.GenBank}}, \code{\link{write.dna}}
+
+ The corresponding generic functions are documented in the package
+ \pkg{base}.
+}
+\examples{
+data(woodmouse)
+woodmouse
+summary(woodmouse)
+summary(woodmouse, 15, 6)
+summary(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, ])
+}
+\keyword{manip}
--- /dev/null
+\name{DNAmodel}
+\alias{DNAmodel}
+\title{Defines Models of DNA Evolution}
+\usage{
+DNAmodel(model = "K80", partition = 1,
+ ncat.isv = 1, invar = FALSE,
+ equal.isv = TRUE, equal.invar = 1)
+}
+\arguments{
+ \item{model}{a vector of mode character giving the substition model.}
+ \item{partition}{a vector of integers defining the partitions for the
+ substition models (eventually recycled).}
+ \item{ncat.isv}{the number of categories in each partition.}
+ \item{invar}{a logical value specifying whether there are invariants.}
+ \item{equal.isv}{a logical value specifying whether the `alpha'
+ parameter is the same in all partitions; has no effet if \code{ncat
+ = 1} or if \code{partition = 1}.}
+ \item{equal.invar}{similar to the argument above but for the
+ proportion of invariants.}
+}
+\description{
+ This function defines a model of evolution for a set of DNA sequences
+ with possible partitions.
+}
+\details{
+ \code{partition} is recycled along the sequence: thus by default there
+ is a single partition. For instance, to partition a sequence of 1000
+ sites into two partitions of equal length, one will use
+ \code{partition = c(rep(1, 500), rep(2, 500))}. The partitions must be
+ numbered with a series of integers (1, 2, 3, ...). To partition the
+ codon positions, one could do \code{partition = c(1, 1, 2)}.
+
+ The substition models are the same in all partitions. Branch lengths
+ are the same in all partitions up to a multiplying coefficient (the
+ contrast parameter, denoted 'xi').
+
+ The substitution models must be among the followings: \code{"JC69"}
+ \code{"K80"}, \code{"F81"}, \code{"F84"}, \code{"HKY85"},
+ \code{"T92"}, \code{"TN93"}, and \code{"GTR"}. These models (except
+ HKY85 and GTR) are described in the help page of
+ \code{\link{dist.dna}}.
+
+ Inter-sites variation in substitution rates (ISV) is allowed by
+ specifying \code{ncat.isv} greater than one.
+}
+\note{
+ The result of this function is not intended to be used by the user,
+ but rather to be passed to \code{\link{mlphylo}}.
+}
+\value{
+ an object of class \code{"DNAmodel"} with components defined by the
+ arguments of the function call.
+}
+\author{Emmanuel Paradis \email{Emmanuel.Paradis@mpl.ird.fr}}
+\seealso{
+ \code{\link{mlphylo}}, \code{\link{dist.dna}}
+}
+\examples{
+### the K80 model:
+mod <- DNAmodel()
+### the simplest substitution model:
+mod <- DNAmodel("JC69")
+### the classical GTR + G4 + I:
+mod <- DNAmodel("GTR", ncat.isv = 4, invar = TRUE)
+### codon-partitioning (with K80):
+mod <- DNAmodel(partition = c(1, 1, 2))
+### the same but adding inter-sites variation (the alpha parameter
+### is the same for both partitions):
+mod <- DNAmodel(partition = c(1, 1, 2), ncat.isv = 4)
+### ... and with different `alpha' for each partition:
+mod <- DNAmodel(partition = c(1, 1, 2), ncat.isv = 4, equal.isv = FALSE)
+}
+\keyword{models}
--- /dev/null
+\name{GC.content}
+\alias{GC.content}
+\title{Content in GC from DNA Sequences}
+\usage{
+GC.content(x)
+}
+\arguments{
+ \item{x}{a vector, a matrix, a data frame, or a list which contains
+ the DNA sequences.}
+}
+\description{
+ This function computes the percentage of G+C in a sample of DNA sequences.
+}
+\details{
+ The percentage of G+C is computed over all sequences in the
+ sample. All missing or unknown sites are discarded from the
+ computations. The present function actually uses the function
+ \code{base.freq}.
+}
+\value{
+ A single numeric value is returned.
+}
+\author{Emmanuel Paradis \email{Emmanuel.Paradis@mpl.ird.fr}}
+\seealso{
+ \code{\link{base.freq}}, \code{\link{seg.sites}},
+ \code{\link{nuc.div}}
+}
+\keyword{univar}
--- /dev/null
+\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{...}{some methods for this generic require additional arguments. None are used in this method.}
+}
+\description{
+ Initialize a \code{corPhyl} correlation structure object.
+ Does the same as \code{Initialize.corStruct}, but also checks the row names of data and builds an index.
+}
+\value{
+ An initialized object of same class as \code{object}.
+}
+\author{Julien Dutheil \email{julien.dutheil@univ-montp2.fr}}
+\seealso{
+ \code{\link{corClasses}}, \code{\link[nlme]{Initialize.corStruct}}.
+}
+\keyword{models}
+\keyword{manip}
--- /dev/null
+\name{Moran.I}
+\alias{Moran.I}
+\title{Moran's I Autocorrelation Index}
+\usage{
+ Moran.I(x, weight, scaled = FALSE, na.rm = FALSE,
+ alternative = "two.sided")
+}
+\arguments{
+ \item{x}{a numeric vector.}
+ \item{weight}{a matrix of weights.}
+ \item{scaled}{a logical indicating whether the coefficient should be
+ scaled so that it varies between -1 and +1 (default to
+ \code{FALSE}).}
+ \item{na.rm}{a logical indicating whether missing values should be
+ removed.}
+ \item{alternative}{a character string specifying the alternative
+ hypothesis that is tested against the null hypothesis of no
+ phylogenetic correlation; must be of one "two.sided", "less", or
+ "greater", or any unambiguous abbrevation of these.}
+}
+\description{
+ This function computes Moran's I autocorrelation coefficient of
+ \code{x} giving a matrix of weights using the method described by
+ Gittleman and Kot (1990).
+}
+\details{
+ The matrix \code{weight} is used as ``neighbourhood'' weights, and
+ Moran's I coefficient is computed using the formula:
+ \deqn{I = \frac{n}{S_0} \frac{\sum_{i=1}^n\sum_{j=1}^n w_{i,j}(y_i -
+ \overline{y})(y_j - \overline{y})}{\sum_{i=1}^n {(y_i -
+ \overline{y})}^2}}
+ {\code{I = n/S0 * (sum\{i=1..n\} sum\{j=1..n\} wij(yi - ym))(yj - ym)
+ / (sum\{i=1..n\} (yi - ym)^2)}}
+ with
+ \itemize{
+ \item \eqn{y_i}{yi} = observations
+ \item \eqn{w_{i,j}}{wij} = distance weight
+ \item \eqn{n} = number of observations
+ \item \eqn{S_0}{S0} = \eqn{\sum_{i=1}^n\sum_{j=1}^n wij}{\code{sum_{i=1..n} sum{j=1..n} wij}}
+ }
+
+ The null hypothesis of no phylogenetic correlation is tested assuming
+ normality of I under this null hypothesis. If the observed value
+ of I is significantly greater than the expected value, then the values
+ of \code{x} are positively autocorrelated, whereas if Iobserved <
+ Iexpected, this will indicate negative autocorrelation.
+}
+\value{
+ A list containing the elements:
+
+ \item{observed}{the computed Moran's I.}
+ \item{expected}{the expected value of I under the null hypothesis.}
+ \item{sd}{the standard deviation of I under the null hypothesis.}
+ \item{p.value}{the P-value of the test of the null hypothesis against
+ the alternative hypothesis specified in \code{alternative}.}
+}
+\references{
+ Gittleman, J. L. and Kot, M. (1990) Adaptation: statistics and a null
+ model for estimating phylogenetic effects. \emph{Systematic Zoology},
+ \bold{39}, 227--241.
+}
+\author{Julien Dutheil \email{julien.dutheil@univ-montp2.fr} and
+ Emmanuel Paradis \email{Emmanuel.Paradis@mpl.ird.fr}}
+\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}
--- /dev/null
+\name{NPRS.criterion}
+\alias{NPRS.criterion}
+\title{Objective Function Employed in Nonparametric Rate Smoothing}
+\usage{
+NPRS.criterion(phy, chrono, expo = 2, minEdgeLength = 1e-06)
+}
+\arguments{
+ \item{phy}{A non-clock-like phylogenetic tree (i.e. an object of class
+ \code{"phylo"}), where the branch lengths are measured in
+ substitutions.}
+ \item{chrono}{A chronogram, i.e. a clock-like tree (i.e. an object of
+ class \code{"phylo"}), where the branch lengths are measured in
+ absolute time.}
+ \item{expo}{Exponent in the objective function (default value: 2)}
+ \item{minEdgeLength}{Minimum edge length in the phylogram (default
+ value: 1e-06). If any branch lengths are smaller then they will be
+ set to this value.}
+}
+\description{
+ \code{NPRS.criterion} computes the objective function to be minimized
+ in the NPRS (nonparametric rate smoothing) algorithm described in
+ Sanderson (1997).
+}
+\details{
+ Please refer to Sanderson (1997) for mathematical details. Note that
+ is is not computationally efficient to optimize the branch lengths in
+ a chronogram by using \code{NPRS.criterion} - please use
+ \code{\link{chronogram}} instead.
+}
+\value{
+ \code{NPRS.criterion} returns the value of the objective function given
+ a phylogram and a chronogram.
+}
+\author{Gangolf Jobb (\url{http://www.treefinder.de}) and Korbinian
+ Strimmer (\url{http://www.stat.uni-muenchen.de/~strimmer/})
+}
+\seealso{
+ \code{\link{ratogram}}, \code{\link{chronogram}}
+}
+\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{
+# get tree
+data("landplants.newick") # example tree in NH format
+tree.landplants <- read.tree(text = landplants.newick)
+
+# plot tree
+tree.landplants
+plot(tree.landplants, label.offset = 0.001)
+
+# estimate chronogram
+chrono.plants <- chronogram(tree.landplants)
+
+# plot
+plot(chrono.plants, label.offset = 0.001)
+
+# value of NPRS function for our estimated chronogram
+NPRS.criterion(tree.landplants, chrono.plants)
+}
+\keyword{manip}
--- /dev/null
+\name{ace}
+\alias{ace}
+\alias{logLik.ace}
+\alias{deviance.ace}
+\alias{AIC.ace}
+\alias{anova.ace}
+\title{Ancestral Character Estimation}
+\usage{
+ace(x, phy, type = "continuous", method = "ML", CI = TRUE,
+ model = if (type == "continuous") "BM" else "ER",
+ scaled = TRUE, kappa = 1, corStruct = NULL, ip = 0.1)
+\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.}
+ \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. Three choices are possible: \code{"ML"}, \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{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{...}{further arguments passed to or from other methods.}
+}
+\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 (-2*logLik), or the
+ Akaike information criterion of a tree. If no such values are
+ available, \code{NULL} is returned.
+
+ \code{anova} is another generic function that 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.
+}
+\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 maximum likelihood (the default, Schluter et
+ al. 1997), least squares (\code{method = "pic"}, Felsenstein 1985), or
+ generalized least squares (\code{method = "GLS"}, Martins and Hansen
+ 1997). In the latter 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}.
+
+ For discrete characters (\code{type = "discrete"}), only maximum
+ likelihood estimation is available (Pagel 1994). 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.
+}
+\value{
+ a list 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{
+ 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.
+
+ 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 \email{Emmanuel.Paradis@mpl.ird.fr}, Ben Bolker
+\email{bolker@zoo.ufl.edu}}
+\seealso{
+ \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)
+### An example of the use of the argument `ip':
+tr <- character(4)
+tr[1] <- "((((t10:5.03,t2:5.03):2.74,(t9:4.17,"
+tr[2] <- "t5:4.17):3.60):2.80,(t3:4.05,t7:"
+tr[3] <- "4.05):6.53):2.32,((t6:4.38,t1:4.38):"
+tr[4] <- "2.18,(t8:2.17,t4:2.17):4.39):6.33);"
+tr <- read.tree(text = paste(tr, collapse = ""))
+y <- c(rep(1, 6), rep(2, 4))
+### The default `ip = 0.1' makes ace fails:
+ace(y, tr, type = "d")
+ace(y, tr, type = "d", ip = 0.01)
+### Surprisingly, using an initial value farther to the
+### MLE than the default one works:
+ace(y, tr, type = "d", ip = 0.3)
+}
+\keyword{models}
--- /dev/null
+\name{add.scale.bar}
+\alias{add.scale.bar}
+\title{Add a Scale Bar to a Phylogeny Plot}
+\usage{
+add.scale.bar(x = 0, y = 1, length = NULL, ...)
+}
+\arguments{
+ \item{x}{x location of the bar.}
+ \item{y}{y location of the bar.}
+ \item{length}{a numeric value giving the length of the scale bar. If
+ none is supplied, a value is calculated from the data.}
+ \item{...}{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{
+ As from version 1.4 of ape, the options of this function have been
+ redefined, and have now default values. By default, the scale bar is
+ plotted on the left bottom corner of the plot.
+
+ The further arguments (\code{...}) 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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+\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}
--- /dev/null
+\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{...}{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.
+
+ Only the labelled topologies are compared (i.e. branch lengths are not
+ considered.
+}
+\value{
+ A logical value, or a two-column matrix.
+}
+\author{\enc{Benoît}{Benoit} \email{b.durand@alfort.AFSSA.FR}}
+\seealso{
+ \code{\link[base]{all.equal}} for the generic R function
+}
+\examples{
+### maybe the simplest example of two representations
+### for the same rooted tree...:
+t1 <- read.tree(text = "(a:1,b:1);")
+t2 <- read.tree(text = "(b:1,a:1);")
+all.equal(t1, t2)
+### ... compare with this:
+identical(t1, t2)
+### one just slightly more complicated...:
+t3 <- read.tree(text = "((a:1,b:1):1,c:2);")
+t4 <- read.tree(text = "(c:2,(a:1,b:1):1);")
+all.equal(t3, t4) # == all.equal.phylo(t3, t4)
+### ... here we force the comparison as lists:
+all.equal.list(t3, t4)
+t5 <- read.tree(text = "(a:2,(c:1,b:1):1);")
+### note that this does NOT return FALSE...:
+all.equal(t3, t5)
+### ... do this instead:
+identical(all.equal(t3, t5), TRUE)
+}
+\keyword{manip}
--- /dev/null
+\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{getDurations}
+\alias{getEdgeLengths}
+\alias{getExternalParams}
+\alias{getNEdges}
+\alias{getNFreeParams}
+\alias{getRates}
+\alias{objFuncLogScale}
+\alias{optimTree}
+\alias{phylogram}
+\alias{prepareTree}
+\alias{setTree}
+\alias{buildTreeFromPhylo}
+\alias{destroyTree}
+\alias{getError}
+\alias{nEdges}
+\alias{nNodes}
+\alias{klastorin_nTips}
+\alias{getMisawaTajima}
+\alias{phylogram.plot}
+\alias{cladogram.plot}
+\alias{circular.plot}
+\alias{unrooted.plot}
+\alias{unrooted.xy}
+\alias{node.height}
+\alias{node.height.clado}
+\alias{birth.step}
+\alias{death.step}
+\alias{ht.move}
+\alias{loglik.pop}
+\alias{pos.move}
+\alias{BOTHlabels}
+\alias{chronopl.cv}
+\alias{prepareDNA}
+\alias{floating.pie.asp}
+\alias{checkLabel}
+\alias{getMRCA}
+\title{Internal Ape Functions}
+\description{
+ Internal ape functions.
+}
+\note{
+ These are not to be called by the user (or in some cases are just
+ waiting for proper documentation to be written).
+}
+\keyword{internal}
--- /dev/null
+\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{...}{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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+\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}
--- /dev/null
+\name{as.matching}
+\alias{as.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 three-column numeric matrix where the first two
+ columns represent the sibling pairs, and the third one the
+ corresponding ancestor.}
+ \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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+\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}
--- /dev/null
+\name{as.phylo}
+\alias{as.phylo}
+\alias{as.phylo.hclust}
+\alias{as.phylo.phylog}
+\alias{as.hclust.phylo}
+\alias{old2new.phylo}
+\alias{new2old.phylo}
+\title{Conversion Among Tree Objects}
+\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)
+}
+\arguments{
+ \item{x}{an object to be converted into another class.}
+ \item{...}{further arguments to be passed to or from other methods.}
+ \item{phy}{an object of class \code{"phylo"}.}
+}
+\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 this
+ generic 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{old2new.phylo} and \code{new2old.phylo} are utility functions
+ for converting between the old and new coding of the class
+ \code{"phylo"}.
+}
+\value{
+ An object of class \code{"hclust"} or \code{"phylo"}.
+}
+\author{Emmanuel Paradis \email{Emmanuel.Paradis@mpl.ird.fr}}
+\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)
+identical(bird.orders, tr) # FALSE, but...
+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, 1, 1))
+}
+\keyword{manip}
--- /dev/null
+\name{as.phylo.formula}
+\alias{as.phylo.formula}
+\title{ Conversion from Taxonomy Variables to Phylogenetic Trees }
+\description{
+ The function \code{as.phylo.formula} (short form \code{as.phylo})
+ builds a phylogenetic tree (an object of class \code{phylo}) from
+ a set of nested taxonomic variables.
+}
+\usage{
+\method{as.phylo}{formula}(x, data = parent.frame(), ...)
+}
+\arguments{
+ \item{x}{ a right-side formula describing the taxonomic relationship: \code{~C1/C2/.../Cn}. }
+ \item{data}{ the data.frame where to look for the variables (default to environment). }
+ \item{\dots}{ further arguments to be passed from other methods.}
+}
+\details{
+ Taxonomic variables must be nested and passed in the correct order: the higher clade must be on the left of the formula, for instance \code{~Order/Family/Genus/Species}.
+ In most cases, the resulting tree will be unresolved and contain polytomies.
+}
+\value{
+ An object of class \code{phylo}.
+}
+\author{Julien Dutheil \email{Julien.Dutheil@univ-montp2.fr}}
+\seealso{ \code{\link{as.phylo}}, \code{\link{read.tree}} for a description of \code{phylo} objects, \code{\link{multi2di}} }
+\examples{
+data(carnivora)
+plot(as.phylo(~SuperFamily/Family/Genus/Species, data=carnivora))
+}
+\keyword{manip}
--- /dev/null
+\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{...}{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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+\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}
--- /dev/null
+\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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+\keyword{manip}
--- /dev/null
+\name{base.freq}
+\alias{base.freq}
+\title{Base frequencies from DNA Sequences}
+\usage{
+base.freq(x)
+}
+\arguments{
+ \item{x}{a vector, a matrix, or a list which contains the DNA
+ sequences.}
+}
+\description{
+ This function computes the relative frequencies (i.e. percentages) of
+ the four DNA bases (adenine, cytosine, guanine, and thymidine) from a
+ sample of sequences.
+}
+\details{
+ The base frequencies are computed over all sequences in the
+ sample. All missing or unknown sites are discarded from the
+ computations.
+}
+\value{
+ A numeric vector stoting the relative frequencies with names
+ \code{c("a", "c", "g", "t")}.
+}
+\author{Emmanuel Paradis \email{Emmanuel.Paradis@mpl.ird.fr}}
+\seealso{
+ \code{\link{GC.content}}, \code{\link{seg.sites}},
+ \code{\link{nuc.div}}, \code{\link{DNAbin}}
+}
+\keyword{univar}
--- /dev/null
+\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)
+}
+\arguments{
+ \item{phy}{an object of class \code{"phylo"}.}
+ \item{S}{a numeric vector giving the number of species for each tip.}
+}
+\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.
+}
+\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.
+}
+\author{Emmanuel Paradis \email{Emmanuel.Paradis@mpl.ird.fr}}
+\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}}
+}
+\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)
+}
+\keyword{models}
--- /dev/null
+\name{bind.tree}
+\alias{bind.tree}
+\title{Binds Trees}
+\usage{
+bind.tree(x, y, where = "root", position = 0)
+}
+\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.}
+}
+\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 sticked 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.
+}
+\value{
+ an object of class \code{"phylo"}.
+}
+\note{
+ For the moment, this function handles only trees with branch lengths,
+ and does not handle node labels.
+
+ Further testing/improvements may be needed.
+}
+\author{Emmanuel Paradis \email{Emmanuel.Paradis@mpl.ird.fr}}
+\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 <- bind.tree(tree.bird1, tree.bird2, where = "root",
+ position = tree.bird1$root.edge)
+birds
+layout(matrix(c(1, 2, 3, 3), 2, 2))
+plot(tree.bird1)
+plot(tree.bird2)
+plot(birds)
+layout(matrix(1))
+}
+\keyword{manip}
--- /dev/null
+\name{BIONJ}
+\alias{bionj}
+\title{
+ Tree Estimation Based on an Improved Version of the NJ Algorithm
+}
+\description{
+ This function performs the BIONJ algorithm of Gascuel (1997).
+}
+\usage{
+bionj(X)
+}
+\arguments{
+ \item{X}{a distance matrix; may be an object of class \code{"dist"}.}
+}
+\value{
+ an object of class \code{"phylo"}.
+}
+\references{
+ Gascuel, O. (1997) BIONJ: an improved version of the NJ algorithm
+ based on a simple model of sequence data.
+ \emph{Molecular Biology and Evolution}, \bold{14:}, 685--695.
+}
+\author{
+ original C code by Hoa Sien Cuong and Olivier Gascuel; adapted and
+ ported to R by Vincent Lefort \email{vincent.lefort@lirmm.fr}
+}
+\seealso{
+ \code{\link{nj}}, \code{\link{fastme}},
+ \code{\link{write.tree}}, \code{\link{read.tree}},
+ \code{\link{dist.dna}}, \code{\link{mlphylo}}
+}
+\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[row(M) > col(M)] <- x
+M[row(M) < col(M)] <- x
+rownames(M) <- colnames(M) <- 1:8
+tr <- bionj(M)
+plot(tr, "u")
+### a less theoretical example
+data(woodmouse)
+trw <- bionj(dist.dna(woodmouse))
+plot(trw)
+}
+\keyword{models}
+
--- /dev/null
+\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}
--- /dev/null
+\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}
--- /dev/null
+\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{...}{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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+\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}}
+}
+\keyword{models}
--- /dev/null
+\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}
+\usage{
+boot.phylo(phy, x, FUN, B = 100, block = 1)
+prop.part(..., check.labels = FALSE)
+prop.clades(phy, ..., part = NULL)
+\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; this may be presented as a list; 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{\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} (the default), 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.}
+}
+\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}.
+
+ \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.
+}
+\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 (the default) \code{check.labels = FALSE} in \code{prop.part}
+ results in considerable decrease in 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)}.
+}
+\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}.
+
+ \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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+\seealso{
+ \code{\link{dist.topo}}, \code{\link{consensus}}, \code{\link{nodelabels}}
+}
+\examples{
+data(woodmouse)
+tr <- nj(dist.dna(woodmouse))
+### Are bootstrap values stable?
+for (i in 1:5)
+ print(boot.phylo(tr, woodmouse, function(xx) nj(dist.dna(xx))))
+### How many partitions in 100 random trees of 10 labels?...
+TR <- replicate(100, rtree(10), FALSE)
+pp10 <- prop.part(TR)
+length(pp10)
+### ... and in 100 random trees of 20 labels?
+TR <- replicate(100, rtree(20), FALSE)
+pp20 <- prop.part(TR)
+length(pp20)
+plot(pp10, pch = "x", col = 2)
+plot(pp20, pch = "x", col = 2)
+}
+\keyword{manip}
+\keyword{htest}
--- /dev/null
+\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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+\seealso{
+\code{\link{is.ultrametric}}
+}
+\keyword{manip}
--- /dev/null
+\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}
+
--- /dev/null
+\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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+\seealso{
+ \code{\link{gammaStat}}
+}
+\keyword{univar}
--- /dev/null
+\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}
--- /dev/null
+\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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+\seealso{
+ \code{\link{chronogram}}, \code{\link{ratogram}},
+ \code{\link{NPRS.criterion}}, \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}
--- /dev/null
+\name{chronogram}
+\alias{chronogram}
+
+\title{Chronogram Computed by Nonparametric Rate Smoothing}
+\usage{
+chronogram(phy, scale = 1, expo = 2, minEdgeLength = 1e-06)
+}
+\arguments{
+ \item{phy}{A phylogenetic tree (i.e. an object of class
+ \code{"phylo"}), where the branch lengths are measured in substitutions.}
+ \item{scale}{Age of the root in the inferred chronogram (default value: 0). }
+ \item{expo}{Exponent in the objective function (default value: 2)}
+ \item{minEdgeLength}{Minimum edge length in the phylogram (default
+ value: 1e-06). If any branch lengths are smaller then they will be
+ set to this value.}
+}
+\description{
+ \code{chronogram} computes a chronogram from a phylogram by applying the NPRS
+ (nonparametric rate smoothing) algorithm described in Sanderson (1997).
+}
+\details{
+ Please refer to Sanderson (1997) for mathematical details
+}
+\value{
+\code{chronogram} returns an object of class \code{"phylo"}. The branch lengths of this
+tree will be clock-like and scaled so that the root node has age 1 (or the value
+set by the option \code{scale}
+}
+\author{
+ Gangolf Jobb (\url{http://www.treefinder.de}) and
+Korbinian Strimmer (\url{http://www.stat.uni-muenchen.de/~strimmer/})
+}
+\seealso{
+\code{\link{ratogram}}, \code{\link{NPRS.criterion}}.
+}
+\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{
+# get tree
+data("landplants.newick") # example tree in NH format
+tree.landplants <- read.tree(text = landplants.newick)
+
+# plot tree
+tree.landplants
+plot(tree.landplants, label.offset = 0.001)
+
+# estimate chronogram
+chrono.plants <- chronogram(tree.landplants)
+
+# plot
+plot(chrono.plants, label.offset = 0.001)
+
+# value of NPRS function for our estimated chronogram
+NPRS.criterion(tree.landplants, chrono.plants)
+}
+\keyword{manip}
--- /dev/null
+\name{chronopl}
+\alias{chronopl}
+\title{Molecular Dating With Penalized Likelihood}
+\usage{
+chronopl(phy, lambda, node.age = 1, node = "root", CV = FALSE)
+}
+\arguments{
+ \item{phy}{an object of class \code{"phylo"}.}
+ \item{lambda}{value of the smoothng parameter.}
+ \item{node.age}{numeric values specifying the fixed node ages.}
+ \item{node}{the numbers of the nodes whose ages are given by
+ \code{node.age}; \code{"root"} is a short-cut the number of the
+ node.}
+ \item{CV}{whether to perform cross-validation.}
+}
+\description{
+ This function estimates the node ages of a tree using semi-parametric
+ method based on penalized likelihood (Sanderson 2002). The branch
+ lengths of the input tree are interpreted as (mean) numbers of
+ substitutions.
+}
+\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{node.age}, 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.
+
+ 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.
+}
+\value{
+ an object of class \code{"phylo"} with branch lengths as estimated by
+ the function. There are two or three further attributes:
+
+ \item{ploglik}{the maximum penalized log-likelihood.}
+ \item{rates}{the estimated rates for each branch.}
+ \item{D2}{the influence of each observation on overall date
+ estimates (if \code{CV = TRUE}).}
+}
+\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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+\seealso{
+ \code{\link{chronogram}}, \code{\link{ratogram}},
+ \code{\link{NPRS.criterion}}, \code{\link{chronoMPL}}
+}
+\keyword{models}
--- /dev/null
+\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}
--- /dev/null
+\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 \email{bolker@zoo.ufl.edu}}
+\seealso{
+ \code{\link{plot.phylo}}, \code{\link{read.tree}}
+}
+\keyword{manip}
--- /dev/null
+\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}
--- /dev/null
+\name{compar.cheverud}
+\alias{compar.cheverud}
+\title{Cheverud's Comparative Method}
+\description{
+ This function computes the phylogenetic variance component and the
+ residual deviation for continous characters, taking into account the
+ phylogenetic relationships among species, following the comparative
+ method described in Cheverud et al. (1985). The correction proposed by
+ Rholf (2001) is used.
+}
+\usage{
+compar.cheverud(y, W, tolerance = 1e-06, gold.tol = 1e-04)
+}
+\arguments{
+ \item{y}{A vector containing the data to analyse.}
+ \item{W}{The phylogenetic connectivity matrix. All diagonal elements
+ will be ignored.}
+ \item{tolerance}{Minimum difference allowed to consider eigenvalues as
+ distinct.}
+ \item{gold.tol}{Precision to use in golden section search alogrithm.}
+}
+\details{
+ Model: \deqn{y = \rho W y + e}{y = rho.W.y + e}
+
+ where \eqn{e}{e} is the error term, assumed to be normally distributed.
+ \eqn{\rho}{rho} is estimated by the maximum likelihood procedure given
+ in Rohlf (2001), using a golden section search algorithm. The code of
+ this function is indeed adapted from a MatLab code given in appendix
+ in Rohlf's article, to correct a mistake in Cheverud's original paper.
+}
+\value{
+ A list with the following components:
+
+ \item{rhohat}{The maximum likelihood estimate of \eqn{\rho}{rho}}
+ \item{Wnorm}{The normalized version of \code{W}}
+ \item{residuals}{Error terms (\eqn{e}{e})}
+}
+\references{
+ Cheverud, J. M., Dow, M. M. and Leutenegger, W. (1985) The quantitative
+ assessment of phylogenetic constraints in comparative analyses: sexual
+ dimorphism in body weight among primates. \emph{Evolution},
+ \bold{39}, 1335--1351.
+
+ Rohlf, F. J. (2001) Comparative methods for the analysis of continuous
+ variables: geometric interpretations. \emph{Evolution}, \bold{55},
+ 2143--2160.
+
+ Harvey, P. H. and Pagel, M. D. (1991) \emph{The comparative method in
+ evolutionary biology}. Oxford University Press.
+}
+\author{Julien Dutheil \email{julien.dutheil@univ-montp2.fr}}
+\seealso{\code{\link{compar.lynch}}}
+\examples{
+### Example from Harvey and Pagel's book:
+y<-c(10,8,3,4)
+W <- matrix(c(1,1/6,1/6,1/6,1/6,1,1/2,1/2,1/6,1/2,1,1,1/6,1/2,1,1), 4)
+compar.cheverud(y,W)
+
+### Example from Rohlf's 2001 article:
+W<- matrix(c(
+ 0,1,1,2,0,0,0,0,
+ 1,0,1,2,0,0,0,0,
+ 1,1,0,2,0,0,0,0,
+ 2,2,2,0,0,0,0,0,
+ 0,0,0,0,0,1,1,2,
+ 0,0,0,0,1,0,1,2,
+ 0,0,0,0,1,1,0,2,
+ 0,0,0,0,2,2,2,0
+),8)
+W <- 1/W
+W[W == Inf] <- 0
+y<-c(-0.12,0.36,-0.1,0.04,-0.15,0.29,-0.11,-0.06)
+compar.cheverud(y,W)
+}
+\keyword{regression}
--- /dev/null
+\name{compar.gee}
+\alias{compar.gee}
+\alias{print.compar.gee}
+\alias{drop1.compar.gee}
+\title{Comparative Analysis with GEEs}
+\usage{
+compar.gee(formula, data = NULL, family = "gaussian", phy,
+ scale.fix = FALSE, scale.value = 1)
+\method{drop1}{compar.gee}(object, scope, quiet = FALSE, ...)
+}
+\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 character string 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"}.}
+ \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{...}{further arguments to be passed to \code{drop1}.}
+}
+\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}.
+}
+\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}.
+}
+\value{
+ \code{compar.gee} returns an object of class \code{"compar.gee"} with
+ the following components:
+ \item{call}{the function call, including the formula.}
+ \code{effect.assign}{a vector of integers assigning the coefficients
+ to the effects (used by \code{drop1}).}
+ \item{nobs}{the number of observations.}
+ \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}"}.
+}
+\references{
+ 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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+
+\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)...)
+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)
+### 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)
+unlink("ex.tre") # delete the file "ex.tre"
+}
+\keyword{regression}
--- /dev/null
+\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@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}
--- /dev/null
+\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 character optimum) is assumed to change. 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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+\seealso{
+ \code{\link{ace}}, \code{\link{compar.lynch}},
+ \code{\link{corBrownian}}, \code{\link{corMartins}}, \code{\link{pic}}
+}
+\examples{
+\dontrun{
+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(rnorm(23), bird.orders)
+### Much better with a fixed alpha:
+compar.ou(rnorm(23), 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 = -2, 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
+## with follows a chi^2 with df = 1.
+}
+}
+\keyword{models}
--- /dev/null
+\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{...}{further argument(s) to be passed to \code{method} if it is
+ a function.}
+}
+\description{
+ This function computes branch lengths of a tree using different
+ methods.
+}
+\details{
+ Grafen's (1989) computation of branch lengths: each node is given a
+ `height', namely the number of leaves of the subtree minus one, 0 for
+ leaves. Each height is scaled so that root height is 1, and then
+ raised at power 'rho' (> 0). Branch lengths are then computed as the
+ difference between height of lower node and height of upper node.
+
+ If one or several numeric values are provided as \code{method}, they
+ are recycled if necessary. If a function is given instead, further
+ arguments are given in place of \code{...} (they must be named, see
+ examples).
+
+ Zero-length branches are not treated as multichotomies, and thus may
+ need to be collapsed (see \code{\link{di2multi}}).
+}
+\value{
+ An object of class \code{phylo} with branch lengths.
+}
+\author{Julien Dutheil \email{julien.dutheil@univ-montp2.fr} and
+ Emmanuel Paradis \email{Emmanuel.Paradis@mpl.ird.fr}}
+\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}
--- /dev/null
+\name{consensus}
+\alias{consensus}
+\title{Concensus Trees}
+\usage{
+consensus(..., p = 1)
+}
+\arguments{
+ \item{...}{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.}
+}
+\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.
+}
+\value{
+ an object of class \code{"phylo"}.
+}
+\author{Emmanuel Paradis \email{Emmanuel.Paradis@mpl.ird.fr}}
+\seealso{
+ \code{\link{prop.part}}, \code{\link{dist.topo}}
+}
+\keyword{manip}
--- /dev/null
+\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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+\seealso{
+ \code{\link{read.tree}} to read tree files in Newick format,
+ \code{\link[stats]{cophenetic}} for the generic function
+}
+\keyword{manip}
--- /dev/null
+\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{...}{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 coefficient from an object of this class (actually sends \code{numeric(0)}!)
+ or the correlation matrix of an initialized object of this class.
+}
+\author{Julien Dutheil \email{julien.dutheil@univ-montp2.fr}}
+\seealso{
+ \code{\link{corClasses}}.
+}
+\references{
+ Felsenstein, J. (1985) Phylogenies and the comparative method.
+ \emph{American Naturalist}, \bold{125}, 1--15.
+
+ Martins, E. P. and Hansen, T. F. (1997) Phylogenies and the comparative
+ method: a general approach to incorporating phylogenetic information
+ into the analysis of interspecific data. \emph{American Naturalist},
+ \bold{149}, 646--667.
+}
+\keyword{models}
--- /dev/null
+\name{corClasses}
+\alias{corClasses}
+\alias{corPhyl}
+\title{Phylogenetic Correlation Structures}
+\description{
+ Standard classes of phylogenetic correlation structures (\code{corPhyl}) available in \pkg{ape}.
+}
+\value{
+ Available standard classes:
+ \item{corBrownian}{Brownian model (Felsenstein 1985),}
+ \item{corMartins}{The covariance matrix defined in Martins and Hansen (1997),}
+ \item{corGrafen}{The covariance matrix defined in Grafen (1989).}
+ See classes documentation for reference 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}}.
+}
+\author{Julien Dutheil \email{julien.dutheil@univ-montp2.fr}}
+\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}
+
--- /dev/null
+\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{\alpha}{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{...}{some methods for these generics require additional
+ arguments. None are used in these methods.}
+}
+\description{
+ Grafen's (1989) covariance structure. Branch lengths are computed using
+ Grafen's method (see \code{\link{compute.brlen}}). The covariance
+ matrice is then the traditional variance-covariance matrix for a
+ phylogeny.
+}
+\value{
+ An object of class \code{corGrafen} or the rho coefficient from an
+ object of this class or the correlation matrix of an initialized
+ object of this class.
+}
+\author{Julien Dutheil \email{julien.dutheil@univ-montp2.fr}}
+\seealso{
+ \code{\link{corClasses}}, \code{\link{compute.brlen}}, \code{\link{vcv.phylo}}.
+}
+\references{
+ Grafen, A. (1989) The phylogenetic regression. \emph{Philosophical
+ Transactions of the Royal society of London. Series B. Biological
+ Sciences}, \bold{326}, 119--157.
+}
+\keyword{models}
--- /dev/null
+\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{...}{some methods for these generics require additional arguments.
+ None are used in these methods.}
+}
+\description{
+ Martins and Hansen's (1997) covariance structure:
+ \deqn{V_{ij} = \gamma \times e^{-\alpha t_{ij}}}{%
+ Vij = gamma . exp(-alpha . tij)}
+ where \eqn{t_{ij}}{tij} is the phylogenetic distance between taxa \eqn{i}{i} and \eqn{j}{j} and \eqn{\gamma}{gamma} is a constant.
+}
+\value{
+ An object of class \code{corMartins} or the alpha coefficient from an object of this class
+ or the correlation matrix of an initialized object of this class.
+}
+\author{Julien Dutheil \email{julien.dutheil@univ-montp2.fr}}
+\seealso{
+ \code{\link{corClasses}}.
+}
+\references{
+ Martins, E. P. and Hansen, T. F. (1997) Phylogenies and the comparative
+ method: a general approach to incorporating phylogenetic information
+ into the analysis of interspecific data. \emph{American Naturalist},
+ \bold{149}, 646--667.
+}
+\keyword{models}
--- /dev/null
+\name{correlogram.formula}
+\alias{correlogram.formula}
+\title{Phylogenetic Correlogram}
+\usage{
+ correlogram.formula(formula, data = NULL, use = "all.obs")
+}
+\arguments{
+ \item{formula}{a formula of the type \code{y1+..+yn ~ g1/../gn}, where
+ the \code{y}'s are the data to analyse and the \code{g}'s are the
+ taxonomic levels.}
+ \item{data}{a data frame containing the variables specified in the
+ formula. If \code{NULL}, the variables are sought in the user's
+ workspace.}
+ \item{use}{a character string specifying how to handle missing
+ values (i.e., \code{NA}). This must be one of "all.obs",
+ "complete.obs", or "pairwise.complete.obs", or any unambiguous
+ abbrevation of these. In the first case, the presence of missing
+ values produces an error. In the second case, all rows with missing
+ values will be removed before computation. In the last case, missing
+ values are removed on a case-by-case basis.}
+}
+\description{
+ This function computes a correlogram from taxonomic levels.
+}
+\details{
+ See the vignette in R: \code{vignette("MoranI")}.
+}
+\value{
+ An object of class \code{correlogram} which is a data frame with three
+ columns:
+
+ \item{obs}{the computed Moran's I}
+ \item{p.values}{the corresponding P-values}
+ \item{labels}{the names of each level}
+
+ or an object of class \code{correlogramList} containing a list of
+ objects of class \code{correlogram} if several variables are given as
+ response in \code{formula}.
+}
+\author{Julien Dutheil \email{julien.dutheil@univ-montp2.fr} and
+ Emmanuel Paradis \email{Emmanuel.Paradis@mpl.ird.fr}}
+\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}
--- /dev/null
+\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}
--- /dev/null
+\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.}
+ \item{model}{a character string specifying the evlutionary model to be
+ used; must be one of \code{"raw"}, \code{"JC69"}, \code{"K80"} (the
+ default), \code{"F81"}, \code{"K81"}, \code{"F84"}, \code{"BH87"},
+ \code{"T92"}, \code{"TN93"}, \code{"GG95"}, \code{"logdet"}, or
+ \code{"paralin"}.}
+ \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 which is possibly used to
+ apply a gamma correction to the distances (by default \code{gamma =
+ FALSE} so 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.}
+ \item{base.freq}{the base frequencies to be used in the computations
+ (if applicable, i.e. if \code{method = "F84"}). By default, the
+ base frequencies are computed from the whole sample 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.
+
+ \item{``raw''}{This is simply the proportion 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{``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{``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{``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{``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{``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{``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{``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{``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{``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{``logdet''}{The Log-Det distance, developed by Lockhart et
+ al. (1994), is related to BH87. However, this distance is symmetric.}
+
+ \item{``paralin''}{Lake (1994) developed the paralinear distance which
+ can be viewed as another variant of the Barry--Hartigan distance.}
+}
+\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.
+
+ 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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+\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}
--- /dev/null
+\name{dist.gene}
+\alias{dist.gene}
+\alias{dist.gene.pairwise}
+\alias{dist.gene.percentage}
+\title{Pairwise Distances from Genetic Data}
+\usage{
+dist.gene(x, method = "pairwise", variance = FALSE)
+dist.gene.pairwise(x, variance = FALSE)
+dist.gene.percentage(x, variance = FALSE)
+}
+\arguments{
+ \item{x}{a matrix or a data frame.}
+ \item{method}{a character string specifying the method used to compute
+ the distances; only two choices are available: \code{"pairwise"},
+ and \code{"percentage"}.}
+ \item{variance}{a logical, indicates whether the variance of the
+ distances should be returned (default to FALSE).}
+}
+\description{
+ These functions compute 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, DNA sequences, and so on). 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}.
+}
+\value{
+ either a numeric matrix with possibly the names of the individuals (as
+ given by the rownames of the argument \code{x}) as colnames and rownames
+ (if \code{variance = FALSE}, the default), or a list of two matrices names
+ \code{distances} and \code{variance}, respectively (if \code{variance =
+ TRUE}).
+}
+\author{Emmanuel Paradis \email{Emmanuel.Paradis@mpl.ird.fr}}
+\seealso{
+ \code{\link{dist.dna}}, \code{\link{cophenetic.phylo}}
+}
+\keyword{manip}
+
--- /dev/null
+\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{"BHV01"}.}
+}
+\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
+ one by Billera et al. (2001).
+
+ 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.
+
+ Billera et al. (2001) developed a distance from the geometry of a tree
+ space. The distance between two trees can be seen as the sum of the
+ branch lengths that need be erased to have two similar trees.
+}
+\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.
+
+ 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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+\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}
--- /dev/null
+\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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+\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}
--- /dev/null
+\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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+\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}
--- /dev/null
+\name{drop.tip}
+\alias{drop.tip}
+\title{Remove Tips in a Phylogenetic Tree}
+\usage{
+drop.tip(phy, tip, trim.internal = TRUE, subtree = FALSE,
+ root.edge = 0)
+}
+\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}.}
+}
+\description{
+ This function removes the terminal branches of a phylogenetic tree,
+ possibly removing the corresponding internal branches.
+}
+\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.
+
+ 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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+\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), font = 1)
+plot(drop.tip(bird.orders, c(1:5, 20:23), subtree = TRUE), font = 1)
+
+### 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}
--- /dev/null
+\name{evolve.phylo}
+\alias{evolve.phylo}
+\title{Ancestral Character Simulation}
+\description{
+ Simulate the (independent) evolution of one or several continuous
+ characters along a given phylogenetic tree under a homogeneous
+ Brownian model.
+}
+\usage{
+evolve.phylo(phy, value, var)
+}
+\arguments{
+ \item{phy}{an object of class 'phylo' with branch lengths.}
+ \item{value}{ancestral states, one by character. The (optional) names
+ of this vector will be used as character names.}
+ \item{var}{the variance of each character.}
+}
+\details{
+ Let x be a continuous character.
+ If it evolves according to a Brownian model, its value at time t follows a normal law with mean x0 and variance t*sigma\_x,
+ where x0 is the value of the character at time 0, and sigma\_x is the 'inner' variance of the character.
+ The evolution of a continuous character is performed by letting the character evolve on each branch, from its ancestral root state.
+ The final state of a branch is the ancestral states of the daughter branches, and so on.
+}
+\value{
+ An object of class 'ancestral', inheriting from the 'phylo' class. The
+ following components are added:
+
+ \item{node.character}{a data.frame with node ids as rownames and one
+ column by character, containing all the inner node values for each
+ character.}
+ \item{tip.character}{a data.frame with tip ids as rownames and one
+ column by character, containing all the tip values for each
+ character.}
+}
+\author{Julien Dutheil \email{julien.dutheil@univ-montp2.fr}}
+\seealso{
+ \code{\link{plot.ancestral}}, \code{\link{ace}}
+}
+\examples{
+data(bird.orders)
+x <- rep(0, 5)
+names(x) <- c("A", "B", "C", "D", "E")
+anc1 <- evolve.phylo(bird.orders, x, 1)
+anc2 <- evolve.phylo(bird.orders, x, 1)
+cor(anc1$tip.character, anc2$tip.character)
+}
+\keyword{models}
--- /dev/null
+\name{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)
+ 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).}
+}
+\value{
+ an object of class \code{"phylo"}.
+}
+\references{
+ Desper, R. and Gascuel, O. (2002) Fast and accurate phylogeny
+ reconstruction algorithms based on the minimum-evolution principle.
+ \emph{Journal of Computational Biology}, \bold{9(5)}, 687--705.
+}
+\author{
+ original C code by Richard Desper; adapted and ported to R
+ by Vincent Lefort \email{vincent.lefort@lirmm.fr}
+}
+\seealso{
+ \code{\link{nj}}, \code{\link{bionj}},
+ \code{\link{write.tree}}, \code{\link{read.tree}},
+ \code{\link{dist.dna}}, \code{\link{mlphylo}}
+}
+\examples{
+\dontrun{
+### 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[row(M) > col(M)] <- x
+M[row(M) < col(M)] <- x
+rownames(M) <- colnames(M) <- 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}
+
--- /dev/null
+\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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+\seealso{
+ \code{\link{branching.times}}, \code{\link{ltt.plot}}, \code{\link{skyline}}
+}
+\keyword{univar}
--- /dev/null
+\name{heterozygosity}
+\alias{heterozygosity}
+\alias{H}
+\title{Heterozygosity at a Locus Using Gene Frequencies}
+\usage{
+heterozygosity(x, variance = FALSE)
+H(x, variance = FALSE)
+}
+\arguments{
+ \item{x}{a vector or a factor.}
+ \item{variance}{a logical indicating whether the variance of the
+ estimated heterozygosity should be returned (\code{TRUE}), the
+ default being \code{FALSE}.}
+}
+\description{
+ This function computes the mean heterozygosity from gene frequencies,
+ and returns optionally the associated variance.
+}
+\value{
+ a numeric vector of length one with the estimated mean heterozygosity
+ (the default), or of length two if the variance is returned
+ \code{variance = TRUE}.
+}
+\details{
+ The argument \code{x} can be either a factor or a vector. If it is a
+ factor, then it is taken to give the individual alleles in the
+ population. If it is a numeric vector, then its values are taken to be
+ the numbers of each allele in the population. If it is a non-numeric
+ vector, it is a coerced as a factor.
+
+ The mean heterozygosity is estimated with:
+
+ \deqn{\hat{H} = \frac{n}{n-1} \left(1 - \sum_{i=1}^k p_i^2 \right)}{%
+ H = n(1 - SUM (FROM i=1 TO k) p_i^2)/(n - 1)}
+
+ where \eqn{n} is the number of genes in the sample, \eqn{k} is the
+ number of alleles, and \eqn{p_i} is the observed (relative) frequency
+ of the allele \eqn{i}.
+}
+\references{
+ Nei, M. (1987) \emph{Molecular evolutionary genetics}. New York:
+ Columbia University Press.
+}
+\author{Emmanuel Paradis \email{Emmanuel.Paradis@mpl.ird.fr}}
+\seealso{
+ \code{\link{theta.s}}
+}
+\keyword{manip}
+\keyword{univar}
--- /dev/null
+\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}
--- /dev/null
+\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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+\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}
--- /dev/null
+\name{identify.phylo}
+\alias{identify.phylo}
+\title{Graphical Identification of Nodes and Tips}
+\usage{
+\method{identify}{phylo}(x, nodes = TRUE, tips = FALSE,
+ labels = 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{...}{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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+\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}
--- /dev/null
+\name{is.binary.tree}
+\alias{is.binary.tree}
+\title{Test for Binary Tree}
+\usage{
+is.binary.tree(phy)
+}
+\arguments{
+ \item{phy}{phylogenetic tree (i.e. an object of class \code{"phylo"}).}
+}
+\description{
+ This function tests whether a phylogenetic tree is binary, i.e. whether every node
+ (including the root node) has exactly two descendant nodes. In this case the number
+ of edges in the tree equals 2 n - 2 where n is the number of taxa (tips) in the tree.
+}
+\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{read.tree}}, \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) # load tree
+
+is.binary.tree(tree.hiv)
+
+plot(tree.hiv)
+
+unlink("hivtree.phy") # delete the file "hivtree.phy"
+}
+\keyword{logic}
--- /dev/null
+\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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+\seealso{
+ \code{\link{is.binary.tree}}, \code{\link[base]{.Machine}}
+}
+\keyword{utilities}
--- /dev/null
+\name{klastorin}
+\alias{klastorin}
+\title{Klastorin's (1982) method for classifying genes as suggested by Misawa
+and Tajima (2000)}
+\usage{
+klastorin(phy)
+}
+\arguments{
+ \item{phy}{a phylogenetic tree, i.e. an object of class \code{"phy"}. The root of the tree should make
+ sense biologically.
+ }
+}
+\description{
+ The function \code{klastorin} uses the method by Klastorin's (1982) as
+ suggested by Misawa and Tajima (2000) for identifying groups within
+ gene trees.
+}
+\value{
+A vector indication the class affiliation for each sequence/taxon in the tree.
+}
+\seealso{
+\code{\link{opsin}}.
+}
+\references{
+ Klastorin T.D. (1982) An alternative method for hospital partition
+ determination using hierarchical cluster analysis. \emph{Operations
+ Research} \bold{30},1134--1147.
+
+ Misawa, K. (2000) A simple method for classifying genes and a bootstrap
+ test for classifications. \emph{Molecular Biology and Evolution},
+ \bold{17}, 1879--1884.
+}
+\author{Gangolf Jobb (\url{http://www.treefinder.de})}
+\examples{
+# find groups in landplant tree
+data("landplants.newick")
+tree1 <- read.tree(text = landplants.newick)
+plot(tree1, label.offset = 0.001)
+klastorin(tree1)
+tree1$tip.label
+
+# find groups in opsin tree
+data("opsin.newick")
+tree2 <- read.tree(text = opsin.newick)
+plot(tree2,label.offset = 0.01)
+groups <- klastorin(tree2)
+groups
+tree2$tip.label[groups==1]
+tree2$tip.label[groups==2]
+tree2$tip.label[groups==3]
+tree2$tip.label[groups==4]
+tree2$tip.label[groups==5]
+}
+\keyword{manip}
--- /dev/null
+\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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+\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}
--- /dev/null
+\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/}).
+}
+\seealso{
+\code{\link{chronogram}}, \code{\link{ratogram}}, \code{\link{NPRS.criterion}}.
+}
+\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}
+
--- /dev/null
+\name{ltt.plot}
+\alias{ltt.plot}
+\alias{ltt.lines}
+\alias{mltt.plot}
+\title{Lineages Through Time Plot}
+\usage{
+ltt.plot(phy, xlab = "Time", ylab = "N", ...)
+ltt.lines(phy, ...)
+mltt.plot(phy, ..., dcol = TRUE, dlty = FALSE,
+ legend = TRUE, xlab = "Time", ylab = "N")
+}
+\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 x-axis (default is "Time").}
+ \item{ylab}{idem for the y-axis (default is "N").}
+ \item{...}{in the cases of \code{ltt.plot()} and \code{ltt.lines()}
+ these are further (graphical) arguments to be passed to
+ \code{plot()} or \code{lines()}, respectively (see \code{Details:}
+ on how to transform the axes); in the case \code{mltt.plot()} these
+ are additional trees to be plotted (see \code{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.}
+}
+\description{
+ These functions plot, on the current graphical device, the minimum
+ numbers of lineages through time from phylogenetic trees.
+}
+\details{
+ \code{ltt.plot} does a simple lineages through time (LTT)
+ plot. Additional arguments (\code{...}) 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"}.
+
+ \code{ltt.lines} adds a LTT curve to an existing plot. Additional
+ arguments (\code{...}) may be used to change the settings of the added
+ line. Of course, the settings of the already existing LTT plot cannot
+ be altered this way.
+
+ \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) 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. For
+ more flexible settings of line drawings, it is probably better to
+ combine \code{ltt.plot()} with successive calls of \code{ltt.lines()}
+ (see \code{Examples:}).
+}
+\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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+\seealso{
+ \code{\link{skyline}}, \code{\link{branching.times}},
+ \code{\link{birthdeath}}, \code{\link{bd.ext}}, \code{\link{yule.cov}}
+ \code{\link[graphics]{plot}} for the basic plotting function in R
+}
+\examples{
+data(bird.families)
+data(bird.orders)
+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
+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(matrix(1))
+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(-10, 5, lwd = c(2, 1), lty = c(1, 2), bty = "n",
+ legend = c("Bird orders", "Random trees"))
+}
+\keyword{hplot}
+\keyword{aplot}
--- /dev/null
+\name{mantel.test}
+\alias{mantel.test}
+\title{Mantel Test for Similarity of Two Matrices}
+\usage{
+mantel.test(m1, m2, nperm = 1000, graph = FALSE, ...)
+}
+\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{...}{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 Z-statistic.
+}
+\details{
+ The function calculates a 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 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 Z-statistic as a
+ vertical line.
+
+ The \code{...} 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 Z-statistic (sum of rows*columns of lower triangle)
+ of the data matrices.}
+ \item{p}{P-value (quantile of the observed Z-statistic in the
+ permutation distribution).}
+}
+\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 \email{bolker@zoo.ufl.edu}, ported
+ to R by Julien Claude \email{claude@isem.univ-montp2.fr}
+}
+\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}
--- /dev/null
+\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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+\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}
--- /dev/null
+\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. (2004) for methodological details, and the help page of
+ \code{\link{skyline}} for information on a related approach.
+}
+
+
+\author{Rainer Opgen-Rhein (\url{http://www.stat.uni-muenchen.de/~opgen/}) and
+ Korbinian Strimmer (\url{http://www.stat.uni-muenchen.de/~strimmer/}).
+ Parts of the rjMCMC sampling procedure are adapted from R code by Karl Browman
+ (\url{http://www.biostat.jhsph.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}
--- /dev/null
+\name{mlphylo}
+\alias{mlphylo}
+\alias{logLik.phylo}
+\alias{deviance.phylo}
+\alias{AIC.phylo}
+\title{Estimating Phylogenies by Maximum Likelihood}
+\usage{
+mlphylo(x, phy, model = DNAmodel(), search.tree = FALSE,
+ quiet = FALSE, value = NULL, fixed = FALSE)
+\method{logLik}{phylo}(object, ...)
+\method{deviance}{phylo}(object, ...)
+\method{AIC}{phylo}(object, ..., k = 2)
+}
+\arguments{
+ \item{x}{an object of class \code{"DNAbin"} giving the (aligned) DNA
+ sequence data.}
+ \item{phy}{an object of class \code{"phylo"} giving the tree.}
+ \item{model}{an object of class \code{"DNAmodel"} giving the model to
+ be fitted.}
+ \item{search.tree}{a logical specifying whether to search for the best
+ tree (defaults to FALSE) (not functional for the moment).}
+ \item{quiet}{a logical specifying whether to display the progress of
+ the analysis.}
+ \item{value}{a list with elements named \code{rates}, \code{alpha},
+ and \code{invar}, or at least one of these, giving the initial
+ values of the parameters of the model. If \code{NULL}, some initial
+ values are given internally.}
+ \item{fixed}{a logical specifying whether to optimize parameters given
+ in \code{value}.}
+ \item{object}{an object of class \code{"phylo"}.}
+ \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{...}{further arguments passed to or from other methods.}
+}
+\description{
+ \code{mlphylo} estimates a phylogenetic tree by maximum likelihood
+ given a set of DNA sequences. The model of evolution is specified with
+ the function \code{\link{DNAmodel}}.
+
+ \code{logLik}, \code{deviance}, and \code{AIC} are generic functions
+ used to extract the log-likelihood, the deviance (-2*logLik), or the
+ Akaike information criterion of a tree. If no such values are
+ available, \code{NULL} is returned.
+}
+\details{
+ The model specified by \code{\link{DNAmodel}} is fitted using the
+ standard ``pruning'' algorithm of Felsenstein (1981).
+
+ The implementation of the inter-sites variation in substitution rates
+ follows the methodology developed by Yang (1994).
+
+ The difference among partitions is parametrized with a contrast
+ parameter (denoted \eqn{\xi}{xi}) that specifies the contrast in mean
+ susbtitution rate among the partitions. This methodology is inspired
+ from one introduced by Yang (1996).
+
+ The substitution rates are indexed column-wise in the rate matrix: the
+ first rate is set to one.
+}
+\note{
+ For the moment, it is not possible to estimate neither branch lengths,
+ nor the topology with \code{mlphylo}. The function may estimate all other
+ parameters: substitution rates, shape (\eqn{\alpha}{alpha}) of the
+ inter-sites variation in substitution rates, the proportion of
+ invariants, and the ``contrast'' parameter (\eqn{\xi}{xi}) among
+ partitions.
+
+ Alternative topologies can also be compared using likelihood-ratio
+ tests (LRTs) or AICs.
+}
+\value{
+ an object of class \code{"phylo"}. There are possible additional
+ attributes:
+
+ \item{loglik}{the maximum log-likelihood.}
+ \item{npart}{the number of partitions.}
+ \item{model}{the substitution model.}
+ \item{rates}{the estimated substitution rates.}
+ \item{invar}{the estimated proportion of invariants.}
+ \item{alpha}{the estimated shape parameter of the inter-sites
+ variation in substitution rates.}
+}
+\references{
+ Felsenstein, J. (1981) Evolutionary trees from DNA sequences: a
+ maximum likelihood approach. \emph{Journal of Molecular Evolution},
+ \bold{17}, 368--376.
+
+ Yang, Z. (1994) Maximum likelihood phylogenetic estimation from DNA
+ sequences with variable rates over sites: approximate methods.
+ \emph{Journal of Molecular Evolution}, \bold{39}, 306--314.
+
+ Yang, Z. (1996) Maximum-likelihood models for combined analyses of
+ multiple sequence data. \emph{Journal of Molecular Evolution},
+ \bold{42}, 587--596.
+}
+\author{Emmanuel Paradis \email{Emmanuel.Paradis@mpl.ird.fr}}
+\seealso{
+ \code{\link{DNAmodel}}, \code{\link{nj}}, \code{\link{read.dna}},
+ \code{\link{summary.phylo}}
+}
+\keyword{models}
--- /dev/null
+\name{mrca}
+\alias{mrca}
+\title{Find Most Recent Common Ancestors Between Pairs}
+\description{
+ This function returns for each pair of tips (and nodes) its most
+ recent common ancestor (MRCA).
+}
+\usage{
+mrca(phy, full = FALSE)
+}
+\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.}
+}
+\details{
+ 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.
+}
+\value{
+ a matrix of mode numeric.
+}
+\author{Emmanuel Paradis \email{Emmanuel.Paradis@mpl.ird.fr}}
+\keyword{manip}
--- /dev/null
+\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{...}{further arguments to be passed to \code{plot()}.}
+}
+\description{
+ The function \code{mst} finds the minimum spanning tree between a set of
+ observations using a matrix of pairwise distances.
+
+ The \code{plot} method plots the minimum spanning tree showing the
+ links where the observations are identified by their numbers.
+}
+\details{
+ These functions provide two ways to plot the minimum spanning tree which
+ try to space as much as possible the observations in order to show as
+ clearly as possible the links. The option \code{graph = "circle"}
+ simply plots regularly the observations on a circle, whereas
+ \code{graph = "nsca"} uses a non-symmetric correspondence analysis
+ where each observation is represented at the centroid of its neighbours.
+
+ Alternatively, the user may use any system of coordinates for the
+ obsevations, for instance a principal components analysis (PCA) if the
+ distances were computed from an original matrix of continous variables.
+}
+\value{
+ an object of class \code{"mst"} which is a square numeric matrix of size
+ equal to the number of observations with either \code{1} if a link
+ between the corresponding observations was found, or \code{0}
+ otherwise. The names of the rows and columns of the distance matrix,
+ if available, are given as rownames and colnames to the returned object.
+}
+\author{
+ Yvonnick Noel \email{noel@univ-lille3.fr},
+ Julien Claude \email{claude@isem.univ-montp2.fr} and
+ Emmanuel Paradis \email{Emmanuel.Paradis@mpl.ird.fr}
+}
+\seealso{
+ \code{\link{dist.dna}}, \code{\link{dist.gene}},
+ \code{\link[stats]{dist}}, \code{\link[graphics]{plot}}
+}
+\examples{
+library(stats)
+n <- 20
+X <- matrix(runif(n * 10), n, 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}
--- /dev/null
+\name{multi2di}
+\alias{multi2di}
+\alias{di2multi}
+\title{Collapse and Resolve Multichotomies}
+\description{
+ These two functions collapse or resolve multichotomies in phylogenetic
+ trees (objects of class \code{"phylo"}).
+}
+\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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+\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}
--- /dev/null
+\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.
+}
+\author{Emmanuel Paradis \email{Emmanuel.Paradis@mpl.ird.fr}}
+\seealso{
+ \code{\link{write.tree}}, \code{\link{read.tree}},
+ \code{\link{dist.dna}}, \code{\link{mlphylo}}
+}
+\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[row(M) > col(M)] <- x
+M[row(M) < col(M)] <- x
+rownames(M) <- colnames(M) <- 1:8
+tr <- nj(M)
+plot(tr, "u")
+### a less theoretical example
+data(woodmouse)
+trw <- nj(dist.dna(woodmouse))
+plot(trw)
+}
+\keyword{models}
--- /dev/null
+\name{node.depth}
+\alias{node.depth}
+\title{Depth of Nodes and Tips}
+\description{
+ This function returns the depth of nodes and tips given by the number
+ of descendants (1 is returned for tips).
+}
+\usage{
+node.depth(phy)
+}
+\arguments{
+ \item{phy}{an object of class "phylo".}
+}
+\details{
+ The depth of a node is computed as the number of tips which are its
+ descendants. The value of 1 is given to the tips.
+}
+\value{
+ A numeric vector indexed with the node numbers of the matrix `edge' of
+ \code{phy}.
+}
+\author{Emmanuel Paradis \email{Emmanuel.Paradis@mpl.ird.fr}}
+\seealso{
+ \code{\link{plot.phylo}}
+}
+\keyword{manip}
--- /dev/null
+\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", ...)
+tiplabels(text, tip, adj = c(0.5, 0.5), frame = "rect",
+ pch = NULL, thermo = NULL, pie = NULL, piecol = NULL,
+ col = "black", bg = "yellow", ...)
+edgelabels(text, edge, adj = c(0.5, 0.5), frame = "rect",
+ pch = NULL, thermo = NULL, pie = NULL, piecol = NULL,
+ col = "black", bg = "lightgreen", ...)
+
+}
+\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. 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).}
+}
+\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 \email{Emmanuel.Paradis@mpl.ird.fr}, Ben Bolker
+ \email{bolker@zoo.ufl.edu}, and Jim Lemon}
+\seealso{
+ \code{\link{plot.phylo}}
+}
+\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)
+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}
--- /dev/null
+\name{nuc.div}
+\alias{nuc.div}
+\title{Nucleotide Diversity}
+\description{
+ This function computes the nucleotide diversity from a sample of DNA
+ sequences.
+}
+\usage{
+nuc.div(x, variance = FALSE, pairwise.deletion = FALSE)
+}
+\arguments{
+ \item{x}{a matrix or a list which contains the DNA sequences.}
+ \item{variance}{a logical indicating whether to compute the variance
+ of the estimated nucleotide diversity.}
+ \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.}
+}
+\details{
+ The nucleotide diversity is the sum of the number of differences
+ between pairs of sequences divided by the number of comparisons
+ (i.e. n(n - 1)/2, where n is the number of sequences).
+
+ The variance of the estimated diversity uses formula (10.9) from Nei
+ (1987). This applies only if all sequences are of the same lengths,
+ and cannot be used if \code{pairwise.deletion = TRUE}. A bootstrap
+ estimate may be in order if you insist on using the latter option.
+}
+\value{
+ A numeric vector with one or two values (if \code{variance = TRUE}).
+}
+\references{
+ Nei, M. (1987) \emph{Molecular evolutionary genetics}. New York:
+ Columbia University Press.
+}
+\author{Emmanuel Paradis \email{Emmanuel.Paradis@mpl.ird.fr}}
+\seealso{
+ \code{\link{base.freq}}, \code{\link{GC.content}},
+ \code{\link{theta.s}}, \code{\link{seg.sites}}
+}
+\examples{
+data(woodmouse)
+nuc.div(woodmouse)
+nuc.div(woodmouse, TRUE)
+nuc.div(woodmouse, FALSE, TRUE)
+}
+\keyword{manip}
+\keyword{univar}
--- /dev/null
+\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.
+}
+\seealso{
+\code{\link{klastorin}}.
+}
+\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}
--- /dev/null
+\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, path2exec = NULL)
+\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
+ binary file. This argument can be left missing under Windows: the
+ default name \code{"phyml_w32"} will then be used.}
+ \item{path2exec}{a character string giving the path to the PHYML
+ binary file. If \code{NULL} the file must be accessible to R (either
+ it is in the computer path, or it is in R's working directory).}
+ \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{...}{further arguments passed to or from other methods.}
+}
+\description{
+ This function calls the software 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 has been tested with version 2.4 of PHYML; it
+ should also work with version 2.3, but it won't work with version 2.1.
+
+ Under unix-like systems, it seems necessary to run R from csh or a
+ similar shell (sh might not work).
+
+ 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.
+
+ If the usual output files of PHYML already exist, they are not
+ deleted and PHYML's results are appended.
+
+ 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).
+}
+\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://atgc.lirmm.fr/phyml/}
+}
+\author{Emmanuel Paradis \email{Emmanuel.Paradis@mpl.ird.fr}}
+\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) <- .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}
--- /dev/null
+\name{pic}
+\alias{pic}
+\title{Phylogenetically Independent Contrasts}
+\usage{
+pic(x, phy, scaled = TRUE, var.contrasts = 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 variance (default to \code{TRUE}).}
+ \item{var.contrasts}{logical, indicates whether the expected
+ variance of the contrasts should be returned (default to \code{FALSE}).}
+}
+\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, 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.
+}
+\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}).
+}
+\references{
+ Felsenstein, J. (1985) Phylogenies and the comparative method.
+ \emph{American Naturalist}, \bold{125}, 1--15.
+}
+\author{Emmanuel Paradis \email{Emmanuel.Paradis@mpl.ird.fr}}
+\seealso{
+ \code{\link{read.tree}}, \code{\link{compar.gee}}, \code{\link{compar.lynch}}
+}
+\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}
--- /dev/null
+\name{plot.ancestral}
+\alias{plot.ancestral}
+\title{Plot Ancestral Character Values on a Tree}
+\description{
+ Plot a phylogenetic tree with edge colors picked according to the
+ corresponding node ancestral character value.
+}
+\usage{
+\method{plot}{ancestral}(x, which = names(x$node.character), n.col = 10,
+col.fun = function(n) rainbow(n, start = 0.4, end = 0),
+plot.node.values = FALSE,
+ask = prod(par("mfcol")) < length(which) && dev.interactive(),
+...)
+}
+\arguments{
+ \item{x}{An object of class 'ancestral'.}
+ \item{which}{Which characters to plot. Can be a vecotr of names, or a
+ vector of indices.}
+ \item{n.col}{The number of colors to use in the gradient.}
+ \item{col.fun}{the color function to use.}
+ \item{plot.node.values}{Should character values used as node labels?}
+ \item{ask}{Ask before each plot?}
+ \item{...}{Further parameters to pass to the plot.phylo function.}
+}
+\details{
+ This function produces one plot by selected ancestral character. It
+ uses the plot.phylo function with particular arguments to display edge
+ colors according to ancestral character values.
+}
+\author{Julien Dutheil \email{Julien.Dutheil@univ-montp2.fr}}
+\seealso{
+ \code{\link{plot.phylo}}, \code{\link{evolve.phylo}}
+}
+\examples{
+data(bird.orders)
+x <- rep(0, 4)
+names(x) <- c("A", "B", "C", "D")
+anc <- evolve.phylo(bird.orders, x, 1)
+plot(anc, edge.width = 3, plot.node.values = TRUE)
+par(mfrow = c(2, 2), mar = c(5.5, 0, 0, 0))
+plot(anc, edge.width = 3, type = "r")
+}
+\keyword{hplot}
--- /dev/null
+\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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+\seealso{
+ \code{\link{correlogram.formula}}, \code{\link{Moran.I}}
+}
+\keyword{hplot}
--- /dev/null
+\name{plot.phylo}
+\alias{plot.phylo}
+\alias{plot.multiPhylo}
+\title{Plot Phylogenies}
+\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, 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", ...)
+\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{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{layout}{the number of trees to be plotted simultaneously.}
+ \item{...}{further arguments to be passed to \code{plot} or to
+ \code{plot.phylo}.}
+}
+\description{
+ These functions plot phylogenetic trees on the current graphical
+ device.
+}
+\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 formatting of the labels of both 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:'').
+
+ Note that if you resize manually the graphical device (windows or X11)
+ you may need to replot the tree.
+}
+\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{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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+\seealso{
+ \code{\link{read.tree}}, \code{\link{add.scale.bar}},
+ \code{\link{axisPhylo}}, \code{\link{nodelabels}},
+ \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(xenarthra)
+plot(xenarthra)
+### remove the margins...
+plot(xenarthra, no.margin = TRUE)
+### ... and use a smaller font size
+plot(xenarthra, no.margin = TRUE, cex = 0.8)
+plot(xenarthra, type = "c", no.margin = TRUE,
+ use.edge.length = FALSE, cex = 0.8)
+par(mar = c(5.1, 4.1, 4.1, 2.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}
--- /dev/null
+\name{plot.varcomp}
+\alias{plot.varcomp}
+\title{Plot Variance Components}
+\description{
+ Plot previously estimated variance components.
+}
+\usage{
+\method{plot}{varcomp}(x, xlab = "Levels", ylab = "Variance", type = "b", ...)
+}
+\arguments{
+ \item{x}{ A \var{varcomp} object}
+ \item{xlab}{ x axis label}
+ \item{ylab}{ y axis label }
+ \item{type}{ plot type ("l", "p" or "b", see \code{\link{plot}})}
+ \item{\dots}{Further argument sent to the \code{\link[lattice]{xyplot}} function.}
+}
+\value{
+ The same as \code{\link[lattice]{xyplot}}.
+}
+\author{Julien Dutheil \email{julien.dutheil@univ-montp2.fr}}
+\seealso{\code{\link{varcomp}}}
+\keyword{hplot}
--- /dev/null
+\name{print.phylo}
+\alias{print.phylo}
+\alias{print.multiPhylo}
+\alias{[.multiPhylo}
+\title{Compact Display of a Phylogeny}
+\usage{
+\method{print}{phylo}(x, printlen = 6 ,...)
+\method{print}{multiPhylo}(x, details = FALSE ,...)
+\method{[}{multiPhylo}(x, i)
+}
+\arguments{
+ \item{x}{an object of class \code{"phylo"} or \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{i}{indices of the trees to select from a list; this may be a
+ vector of integers, logicals, or names.}
+ \item{...}{further arguments passed to or from other methods.}
+}
+\description{
+ These functions prints a compact summary of a phylogeny, or a list of,
+ on the console.
+}
+\value{
+ An object of class \code{"multiPhylo"} or NULL.
+}
+\author{Ben Bolker \email{bolker@zoo.ufl.edu} and Emmanuel Paradis
+ \email{Emmanuel.Paradis@mpl.ird.fr}}
+\seealso{
+ \code{\link{read.tree}}, \code{\link{summary.phylo}},
+ \code{\link[base]{print}} for the generic R function
+}
+\keyword{manip}
--- /dev/null
+\name{ratogram}
+\alias{ratogram}
+
+\title{Ratogram Computed by Nonparametric Rate Smoothing}
+\usage{
+ratogram(phy, scale = 1, expo = 2, minEdgeLength = 1e-06)
+}
+\arguments{
+ \item{phy}{A phylogenetic tree (i.e. an object of class \code{"phylo"}), where
+ the branch lengths are measured in substitutions.}
+
+ \item{scale}{Age of the root in the chronogram corresponding to the inferred ratogram(default value: 0). }
+
+ \item{expo}{Exponent in the objective function (default value: 2)}
+ \item{minEdgeLength}{Minimum edge length in the phylogram (default value: 1e-06). If any branch lengths are
+ smaller then they will be set to this value. }
+}
+\description{
+
+ \code{ratogram} computes a ratogram from a phylogram by applying the NPRS
+ (nonparametric rate smoothing) algorithm described in Sanderson (1997).
+}
+\details{
+ Please refer to Sanderson (1997) for mathematical details
+}
+\value{
+\code{chronogram} returns an object of class \code{"phylo"}. The branch lengths of this
+tree will be the absolute rates estimated for each branch.
+}
+\author{Gangolf Jobb (\url{http://www.treefinder.de}) and
+Korbinian Strimmer (\url{http://www.stat.uni-muenchen.de/~strimmer/})
+}
+\seealso{
+\code{\link{chronogram}}, \code{\link{NPRS.criterion}}.
+}
+\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{
+# get tree
+data("landplants.newick") # example tree in NH format
+tree.landplants <- read.tree(text = landplants.newick)
+
+# plot tree
+tree.landplants
+plot(tree.landplants, label.offset = 0.001)
+
+# estimate ratogram
+rato.plants <- ratogram(tree.landplants)
+
+# plot
+plot(rato.plants, label.offset = 0.001)
+}
+\keyword{manip}
--- /dev/null
+\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, 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{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.
+}
+\seealso{
+ \code{\link{read.dna}}, \code{\link{write.dna}},
+ \code{\link{dist.dna}}, \code{\link{DNAbin}}
+}
+\author{Emmanuel Paradis \email{Emmanuel.Paradis@mpl.ird.fr}}
+\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}
--- /dev/null
+\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 "phylo" with the following components:
+\item{edge}{a two-column matrix of mode character where each row represents an edge of the tree; the nodes and the tips are symbolized with numbers (these numbers are not treated as numeric, hence the mode character); the nodes are represented with negative numbers (the root being "-1"), and the tips are represented with positive numbers. For each row, the first column gives the ancestor. This representation allows an easy manipulation of the tree, particularly if it is rooted.}
+\item{edge.length}{a numeric vector giving the lengths of the branches given by 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 edge.}
+\item{node.label}{(optional) a vector of mode character giving the names of the nodes (set to NULL if not available in the file).}
+\item{root.edge}{(optional) a numeric value giving the length of the branch at the root is it exists (NULL otherwise).}
+}
+\references{
+ Purvis, A. and Rambaut, A. (1995) Comparative analysis by independent
+ contrasts (CAIC): an Apple Macintosh application for analysing
+ comparative data. \emph{CABIOS}, \bold{11} :241--251.
+}
+\author{Julien Dutheil \email{julien.dutheil@univ-montp2.fr}}
+\section{Warning }{The branch length support is still experimental and was not fully tested.}
+\seealso{ \code{\link{read.tree}}, \code{\link{read.nexus}} }
+\examples{
+### The same example than in read.tree, without branch lengths.
+### An extract from Sibley and Ahlquist (1990)
+cat("AAA","Strix_aluco","AAB","Asio_otus",
+ "AB","Athene_noctua","B","Tyto_alba",
+ file = "ex.tre", sep = "\n")
+tree.owls <- read.caic("ex.tre")
+plot(tree.owls)
+tree.owls
+unlink("ex.tre") # delete the file "ex.tre"
+}
+\keyword{hplot}
--- /dev/null
+\name{read.dna}
+\alias{read.dna}
+\title{Read DNA Sequences in a File}
+\usage{
+read.dna(file, format = "interleaved", skip = 0,
+ nlines = 0, comment.char = "#", seq.names = NULL,
+ as.character = FALSE)
+}
+\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. Three choices are possible: \code{"interleaved"},
+ \code{"sequential"}, 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.}
+ \item{nlines}{the number of lines to be read (by default the file is
+ read untill its end).}
+ \item{comment.char}{a single character, the remaining of the line
+ after this character is ignored.}
+ \item{seq.names}{the names to give to each sequence; by default the
+ names read in the file are used.}
+ \item{as.character}{a logical controlling whether to return the
+ sequences as an object of class \code{"DNAbin"} (the default).}
+}
+\description{
+ This function reads 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.
+}
+\details{
+ This function 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 (though a data file
+ with 10-characters-long taxa names is fine as well). 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 unless the `seq.names' option is used. Particularities for
+ each format are detailed below.
+
+ \item{Interleaved:}{the function starts to read the sequences when it
+ finds 10 contiguous characters belonging to the ambiguity code of
+ the IUPAC (namely A, C, G, T, U, M, R, W, S, Y, K, V, H, D, B, and
+ N, upper- or lowercase, so you might run into trouble if you have a
+ taxa name with 10 contiguous letters among these!) All characters
+ before the sequences are taken as the taxa names after removing the
+ leading and trailing spaces (so spaces in a taxa name 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{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"}).
+}
+\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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+\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")
+### ... and in FASTA format
+cat("> No305",
+"NTTCGAAAAACACACCCACTACTAAAANTTATCAGTCACT",
+"> No304",
+"ATTCGAAAAACACACCCACTACTAAAAATTATCAACCACT",
+"> No306",
+"ATTCGAAAAACACACCCACTACTAAAAATTATCAATCACT",
+file = "exdna.txt", sep = "\n")
+ex.dna3 <- read.dna("exdna.txt", format = "fasta")
+### These are the same!
+identical(ex.dna, ex.dna2)
+identical(ex.dna, ex.dna3)
+unlink("exdna.txt") # clean-up
+}
+\keyword{IO}
--- /dev/null
+\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 that gives names to the individual trees; if
+ \code{NULL} (the default), the trees are named \code{"tree1"},
+ \code{"tree2"}, ...}
+}
+\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. Only the block ``TREES'' is read; the other data can be
+ read with other functions (e.g., \code{\link{read.dna}},
+ \code{\link[base]{read.table}}, ...). A trace of the original data is
+ kept with the attribute \code{"origin"} (see below).
+
+ `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"} with the following components:
+ \item{edge}{a two-column matrix of mode character where each row
+ represents an edge of the tree; the nodes and the tips are
+ symbolized with numbers (these numbers are not treated as numeric,
+ hence the mode character); the nodes are represented with negative
+ numbers (the root being \code{"-1"}), and the tips are represented with
+ positive numbers. For each row, the first column gives the
+ ancestor. This representation allows an easy manipulation of the
+ tree, particularly if it is rooted.}
+ \item{edge.length}{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{node.label}{(optional) a vector of mode character giving the
+ names of the nodes (set to \code{NULL} if not available in the file).}
+ \item{root.edge}{(optional) a numeric value giving the length of the
+ branch at the root is it exists (\code{NULL} otherwise).}
+
+ 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"}.
+
+ An attribute \code{"origin"} is further given to the returned object
+ which gives the name of the source file (with its path). This is used
+ to write a tree in a NEXUS file where all the original data must be
+ written (not only the tree) in accordance to the specifications of
+ Maddison et al. (1997).
+}
+\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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+\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}
--- /dev/null
+\name{read.nexus.data}
+\alias{read.nexus.data}
+\title{
+ Read Character Data In NEXUS Format
+}
+\description{
+ This function reads a file with sequences in the NEXUS format.
+}
+\usage{
+read.nexus.data(file)
+}
+\arguments{
+ \item{file}{a file name specified by either a variable of mode
+ character, or a double-quoted string.}
+}
+\details{
+ This parser tries to read data from a file written in a
+ \emph{restricted} NEXUS format (see examples below).
+
+ Please see files \file{data.nex} and \file{taxacharacters.nex} for
+ examples of formats that will work.
+
+ Some noticeable exceptions from the NEXUS standard (non-exhaustive
+ list):
+
+ \itemize{
+ \item{\bold{I}}{Comments must be either on separate lines or at the
+ end of lines. Examples:\cr
+ \code{[Comment]} \bold{--- OK}\cr
+ \code{Taxon ACGTACG [Comment]} \bold{--- OK}\cr
+ \code{[Comment line 1}
+
+ \code{Comment line 2]} \bold{--- NOT OK!}\cr
+ \code{Tax[Comment]on ACG[Comment]T} \bold{--- NOT OK!}}
+ \item{\bold{II}}{No spaces (or comments) are allowed in the
+ sequences. Examples:\cr
+ \code{name ACGT} \bold{--- OK}\cr
+ \code{name AC GT} \bold{--- NOT OK!}}
+ \item{\bold{III}}{No spaces are allowed in taxon names, not even if
+ names are in single quotes. That is, single-quoted names are not
+ treated as such by the parser. Examples:\cr
+ \code{Genus_species} \bold{--- OK}\cr
+ \code{'Genus_species'} \bold{--- OK}\cr
+ \code{'Genus species'} \bold{--- NOT OK!}}
+ \item{\bold{IV}}{The trailing \code{end} that closes the
+ \code{matrix} must be on a separate line. Examples:\cr
+ \code{taxon AACCGGT}
+
+ \code{end;} \bold{--- OK}\cr
+ \code{taxon AACCGGT;}
+
+ \code{end;} \bold{--- OK}\cr
+ \code{taxon AACCCGT; end;} \bold{--- NOT OK!}}
+ \item{\bold{V}}{Multistate characters are not allowed. That is,
+ NEXUS allows you to specify multiple character states at a
+ character position either as an uncertainty, \code{(XY)}, or as an
+ actual appearance of multiple states, \code{\{XY\}}. This is
+ information is not handled by the parser. Examples:\cr
+ \code{taxon 0011?110} \bold{--- OK}\cr
+ \code{taxon 0011{01}110} \bold{--- NOT OK!}\cr
+ \code{taxon 0011(01)110} \bold{--- NOT OK!}}
+ \item{\bold{VI}}{The number of taxa must be on the same line as
+ \code{ntax}. The same applies to \code{nchar}. Examples:\cr
+ \code{ntax = 12} \bold{--- OK}\cr
+ \code{ntax =}
+
+ \code{12} \bold{--- NOT OK!}}
+ \item{\bold{VII}}{The word \dQuote{matrix} can not occur anywhere in
+ the file before the actual \code{matrix} command, unless it is in
+ a comment. Examples:\cr
+ \code{BEGIN CHARACTERS;}
+
+ \code{TITLE 'Data in file "03a-cytochromeB.nex"';}
+
+ \code{DIMENSIONS NCHAR=382;}
+
+ \code{FORMAT DATATYPE=Protein GAP=- MISSING=?;}
+
+ \code{["This is The Matrix"]} \bold{--- OK}
+
+ \code{MATRIX}\cr
+
+ \code{BEGIN CHARACTERS;}
+
+ \code{TITLE 'Matrix in file "03a-cytochromeB.nex"';} \bold{--- NOT OK!}
+
+ \code{DIMENSIONS NCHAR=382;}
+
+ \code{FORMAT DATATYPE=Protein GAP=- MISSING=?;}
+
+ \code{MATRIX}}
+ }
+}
+\value{
+ A list of sequences each made of a single vector of mode character
+ where each element is a (phylogenetic) character state.
+}
+\references{
+ Maddison, D. R., Swofford, D. L. and Maddison, W. P. (1997) NEXUS: an
+ extensible file format for systematic information. \emph{Systematic
+ Biology}, \bold{46}, 590--621.
+}
+\author{Johan Nylander \email{nylander@scs.fsu.edu}}
+\seealso{
+ \code{\link{read.nexus}}, \code{\link{write.nexus}},
+ \code{\link{write.nexus.data}}
+}
+\examples{
+## Use read.nexus.data to read a file in NEXUS format into object x
+\dontrun{x <- read.nexus.data("file.nex")}
+}
+\keyword{file}
--- /dev/null
+\name{read.tree}
+\alias{read.tree}
+\title{Read Tree File in Parenthetic Format}
+\usage{
+read.tree(file = "", text = NULL, tree.names = NULL,
+ skip = 0, comment.char = "#", ...)
+}
+\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{...}{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.
+}
+\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"}.
+}
+\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. (2006) Definition of Formats for Coding Phylogenetic Trees
+ in R. \url{http://pbil.univ-lyon1.fr/R/ape/misc/FormatTreeR_4Dec2006.pdf}
+}
+
+\author{Emmanuel Paradis \email{Emmanuel.Paradis@mpl.ird.fr}}
+\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)
+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")
+str(tree.owls)
+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}
--- /dev/null
+\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", ...)
+}
+\arguments{
+ \item{x}{an object of class \code{"phylo"}.}
+ \item{order}{a character string: either \code{"cladewise"} (the
+ default), or \code{"pruningwise"}, or any unambiguous abbreviation
+ of these.}
+ \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 two rules: in the
+ \code{"cladewise"} order each clade is formed by a series of
+ contiguous rows; this is the order returned by
+ \code{\link{read.tree}}. In the \code{"pruningwise"} order, rows are
+ arranged so that ``pruning'' the tree (or post-order tree traversal)
+ can be done by descending along the rows of `edge'. The possible
+ multichotomies and branch lengths are preserved.
+}
+\value{
+ an object of class \code{"phylo"}.
+}
+\author{Emmanuel Paradis \email{Emmanuel.Paradis@mpl.ird.fr}}
+\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, "p")
+all.equal(bird.families, tr) # uses all.equal.phylo actually
+all.equal.list(bird.families, tr) # bypasses the generic
+}
+
+\keyword{manip}
--- /dev/null
+\name{root}
+\alias{root}
+\alias{unroot}
+\alias{is.rooted}
+\title{Roots Phylogenetic Trees}
+\usage{
+root(phy, outgroup)
+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.}
+}
+\description{
+ \code{root} reroots a phylogenetic tree with respect to the specified
+ outgroup.
+
+ \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) is used as the new root. Note that the tree is really
+ 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.
+
+ 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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+\seealso{
+ \code{\link{bind.tree}}, \code{\link{drop.tip}}
+}
+\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:
+is.rooted(multi2di(tr))
+### To keep the basal trichotomy but forcing the tree as rooted:
+tr$root.edge <- 0
+is.rooted(tr)
+}
+\keyword{manip}
--- /dev/null
+\name{rotate}
+\alias{rotate}
+\title{Swopping sister clades}
+\description{
+For a given node, 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 swopping.}
+\usage{
+rotate(phy, node, polytom = c(1, 2))
+}
+\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}
+}
+\details{
+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.
+
+node can be any of the interior nodes of a phylogenetic tree including the root node. Number of the nodes can be identified by the nodelabels function. Alternatively, you can specify a vector of length two that contains either the number or the names of two tips that coalesce in the node of interest.
+
+If the node subtends a polytomy, any two clades of the the polytomy can be chosen by polytom. On a plotted phylogeny, the clades are numbered from bottom to top and polytom is used to index the two clades one likes to swop.
+}
+\value{
+an object of class \code{"phylo"}.
+}
+\author{Christoph Heibl \email{heibl@lmu.de}}
+\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.phylo(tre, use.edge.length=FALSE)
+nodelabels()
+
+# rotate clades around node 30:
+tre.new <- rotate(tre, 30)
+
+# compare the results:
+X11() # open new graphical device
+par(mfrow=c(1,2)) # devide graphical device
+plot(tre) # plot old tre
+plot(tre.new) # plot new tree
+
+# visualize labels of terminal nodes:
+X11() # open new graphical device
+plot.phylo(tre)
+tiplabels()
+
+# rotate clades containing nodes 12 and 20:
+tre.new <- rotate(tre, c(12, 21))
+
+# compare the results:
+X11() # open new graphical device
+par(mfrow=c(1,2)) # devide 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:
+X11() # open new graphical device
+par(mfrow=c(1,2)) # devide graphical device
+plot(tre) # plot old tre
+plot(tre.new) # plot new tree
+}
+\keyword{manip}
--- /dev/null
+\name{rtree}
+\alias{rtree}
+\alias{rcoal}
+\title{Generates Random Trees}
+\usage{
+rtree(n, rooted = TRUE, tip.label = NULL, br = runif, ...)
+rcoal(n, tip.label = NULL, br = rexp, ...)
+}
+\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}{either an R function used to generate the branch lengths
+ (\code{rtree}) or the coalescence times (\code{rcoal}), or
+ \code{NULL} to give no branch lengths in the tree.}
+ \item{...}{further argument(s) to be passed to \code{br}.}
+}
+\description{
+ These functions generate trees by splitting randomly the edges
+ (\code{rtree}) or randomly clustering the tips (\code{rcoal}).
+ \code{rtree} generates general (non-ultrametric) trees, and
+ \code{rcoal} generates coalescent (ultrametric) trees.
+}
+\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}. In \code{rcoal} \code{rexp} is used to generate the
+ inter-node distances. If further arguments are passed to \code{br},
+ they need to be tagged (e.g., \code{min = 0, max = 10}).
+}
+\author{Emmanuel Paradis \email{Emmanuel.Paradis@mpl.ird.fr}}
+\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}
--- /dev/null
+\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.
+}
+\value{
+ A numeric vector giving the indices of the segregating sites.
+}
+\author{Emmanuel Paradis \email{Emmanuel.Paradis@mpl.ird.fr}}
+\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{GC.content}},
+ \code{\link{theta.s}}, \code{\link{nuc.div}}
+}
+\examples{
+data(woodmouse)
+y <- seg.sites(woodmouse)
+y
+length(y)
+}
+\keyword{univar}
--- /dev/null
+\name{sh.test}
+\alias{sh.test}
+\title{Shimodaira-Hasegawa Test}
+\usage{
+sh.test(..., x, model = DNAmodel(), B = 100)
+}
+\arguments{
+ \item{...}{either a series of objects of class \code{"phylo"}
+ separated by commas, or a list containing such objects.}
+ \item{x}{a list, a matrix, or a data frame containing the (aligned)
+ DNA sequences.}
+ \item{model}{the model to be fitted to each tree (as an object of
+ \code{"DNAmodel"}).}
+ \item{B}{the number of bootstrap replicates.}
+}
+\description{
+ This function computes the Shimodaira--Hasegawa test for a set of
+ trees.
+}
+\details{
+ The present implementation follows the original formulation of
+ Shimodaira and Hasegawa (1999). A difference is that the bootstrap
+ resampling is done on the original sequence data rather than the RELL
+ method as sugested by Shimodaira and Hasegawa.
+}
+\value{
+ a numeric vector with the P-value associated with each tree given in
+ \code{...}.
+}
+\references{
+ Shimodaira, H. and Hasegawa, M. (1999) Multiple comparisons of
+ log-likelihoods with applications to phylogenetic
+ inference. \emph{Molecular Biology and Evolution}, \bold{16},
+ 1114--1116.
+}
+\author{Emmanuel Paradis \email{Emmanuel.Paradis@mpl.ird.fr}}
+\seealso{
+ \code{\link{mlphylo}}, \code{\link{DNAmodel}}
+}
+\examples{
+data(woodmouse)
+t1 <- nj(dist.dna(woodmouse))
+t2 <- rtree(15, tip.label = t1$tip.label)
+t3 <- rtree(15, tip.label = t1$tip.label)
+### Are the NJ tree and two random tress significantly different?
+\dontrun{sh.test(t1, t2, t3, x = woodmouse, B = 100)}
+}
+\keyword{models}
--- /dev/null
+\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{...}{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}
--- /dev/null
+\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}
--- /dev/null
+\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{...}{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.
+
+ If the tree was estimated by maximum likelihood with
+ \code{\link{mlphylo}}, a summary of the model fit and the parameter
+ estimated is printed.
+
+ \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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+\seealso{
+ \code{\link{read.tree}}, \code{\link[base]{summary}} for the generic R
+ function
+}
+\examples{
+data(bird.families)
+summary(bird.families)
+Ntip(bird.families)
+Nnode(bird.families)
+Nedge(bird.families)
+}
+\keyword{manip}
--- /dev/null
+\name{theta.h}
+\alias{theta.h}
+\title{Population Parameter THETA using Homozygosity}
+\usage{
+theta.h(x, standard.error = FALSE)
+}
+\arguments{
+ \item{x}{a vector or a factor.}
+ \item{standard.error}{a logical indicating whether the standard error
+ of the estimated theta should be returned (\code{TRUE}), the default
+ being \code{FALSE}.}
+}
+\description{
+ This function computes the population parameter THETA using the
+ homozygosity (or mean heterozygosity) from gene frequencies.
+}
+\value{
+ a numeric vector of length one with the estimated theta (the default),
+ or of length two if the standard error is returned
+ (\code{standard.error = TRUE}).
+}
+\details{
+ The argument \code{x} can be either a factor or a vector. If it is a
+ factor, then it is taken to give the individual alleles in the
+ population. If it is a numeric vector, then its values are taken to be
+ the numbers of each allele in the population. If it is a non-numeric
+ vector, it is a coerced as a factor.
+
+ The standard error is computed with an approximation due to
+ Chakraborty and Weiss (1991).
+}
+\references{
+ Zouros, E. (1979) Mutation rates, population sizes and amounts of
+ electrophoretic variation at enzyme loci in natural
+ populations. \emph{Genetics}, \bold{92}, 623--646.
+
+ Chakraborty, R. and Weiss, K. M. (1991) Genetic variation of the
+ mitochondrial DNA genome in American Indians is at mutation-drift
+ equilibrium. \emph{American Journal of Human Genetics}, \bold{86}, 497--506.
+}
+\author{Emmanuel Paradis \email{Emmanuel.Paradis@mpl.ird.fr}}
+\seealso{
+ \code{\link{heterozygosity}}, \code{\link{theta.s}}, \code{\link{theta.k}}
+}
+\keyword{manip}
+\keyword{univar}
--- /dev/null
+\name{theta.k}
+\alias{theta.k}
+\title{Population Parameter THETA using Expected Number of Alleles}
+\usage{
+theta.k(x, n = NULL, k = NULL)
+}
+\arguments{
+ \item{x}{a vector or a factor.}
+ \item{n}{a numeric giving the sample size.}
+ \item{k}{a numeric giving the number of alleles.}
+}
+\description{
+ This function computes the population parameter THETA using the
+ expected number of alleles.
+}
+\value{
+ a numeric vector of length one with the estimated theta.
+}
+\details{
+ This function can be used in two ways: either with a vector giving the
+ individual genotypes from which the sample size and number of alleles
+ are derived (\code{theta.k(x)}), or giving directly these two
+ quantities (\code{theta.k(n, k)}).
+
+ The argument \code{x} can be either a factor or a vector. If it is a
+ factor, then it is taken to give the individual alleles in the
+ population. If it is a numeric vector, then its values are taken to be
+ the numbers of each allele in the population. If it is a non-numeric
+ vector, it is a coerced as a factor.
+
+ Both arguments \code{n} and \code{k} must be single numeric values.
+}
+\note{
+ For the moment, no standard-error or confidence interval is computed.
+}
+\references{
+ Ewens, W. J. (1972) The sampling theory of selectively neutral
+ alleles. \emph{Theoretical Population Biology}, \bold{3}, 87--112.
+}
+\author{Emmanuel Paradis \email{Emmanuel.Paradis@mpl.ird.fr}}
+\seealso{
+ \code{\link{theta.h}}, \code{\link{theta.s}}
+}
+\keyword{manip}
+\keyword{univar}
--- /dev/null
+\name{theta.s}
+\alias{theta.s}
+\title{Population Parameter THETA using Segregating Sites
+ in DNA Sequences}
+\usage{
+theta.s(s, n, variance = FALSE)
+}
+\arguments{
+ \item{s}{a numeric giving the number of segregating sites.}
+ \item{n}{a numeric giving the number of sequences.}
+ \item{variance}{a logical indicating whether the variance of the
+ estimated THETA should be returned (\code{TRUE}), the default being
+ \code{FALSE}.}
+}
+\description{
+ This function computes the population parameter THETA using the
+ number of segregating sites \code{s} in a sample of \code{n} DNA sequences.
+}
+\value{
+ a numeric vector of length one with the estimated theta (the default),
+ or of length two if the standard error is returned
+ (\code{variance = TRUE}).
+}
+\note{
+ The number of segregating sites needs to be computed beforehand, for
+ instance with the function \code{seg.sites} (see example below).
+}
+\references{
+ Watterson, G. (1975) On the number of segragating sites in genetical
+ models without recombination. \emph{Theoretical Population Biology},
+ \bold{7}, 256--276.
+
+ Tajima, F. (1989) Statistical method for testing the neutral mutation
+ hypothesis by DNA polymorphism. \emph{Genetics}, \bold{123}, 585--595.
+}
+\author{Emmanuel Paradis \email{Emmanuel.Paradis@mpl.ird.fr}}
+\seealso{
+ \code{\link{theta.h}}, \code{\link{theta.k}}, \code{\link{seg.sites}},
+ \code{\link{nuc.div}}
+}
+\examples{
+data(woodmouse)
+y <- seg.sites(woodmouse)
+s <- length(y)
+n <- length(woodmouse)
+theta.s(s, n)
+theta.s(s, n, variance = TRUE)
+}
+\keyword{manip}
+\keyword{univar}
--- /dev/null
+\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"} which is a list of objects of
+ class \code{"phylo"}.
+}
+\author{Emmanuel Paradis \email{Emmanuel.Paradis@mpl.ird.fr}}
+\seealso{
+ \code{all.equal.phylo}, \code{\link[base]{unique}} for the generic R
+ function, \code{read.tree}, \code{read.nexus}
+}
+\examples{
+TR <- replicate(50, rtree(4), simplify = FALSE)
+class(TR) <- "multiPhylo" # set the class!
+length(unique(TR)) # not always 15...
+howmanytrees(4)
+}
+\keyword{manip}
--- /dev/null
+\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's book.
+}
+\value{
+ A named vector of class \code{varcomp} with estimated variance components.
+}
+\references{
+ Venables, W. N. and Ripley, B. D. (2002) \emph{Modern applied statistics
+ with S (fourth edition)}. New York: Springer-Verlag.
+}
+\author{Julien Dutheil \email{julien.dutheil@univ-montp2.fr}}
+\seealso{\code{\link[nlme]{lme}}}
+\examples{
+data(carnivora)
+m <- lme(log10(SW) ~ 1, random = ~ 1|Order/SuperFamily/Family/Genus, data=carnivora)
+v <- varcomp(m, TRUE, TRUE)
+plot(v)
+}
+\keyword{regression}
+\keyword{dplot}
--- /dev/null
+\name{vcv.phylo}
+\alias{vcv.phylo}
+\title{Phylogenetic Variance-covariance or Correlation Matrix}
+\usage{
+vcv.phylo(phy, model = "Brownian", cor = FALSE)
+}
+\arguments{
+ \item{phy}{an object of class \code{"phylo"}.}
+ \item{model}{a character giving the model used to compute the
+ variances and covariances of the phynotype; by default
+ \code{"Brownian"}. Currently only the Brownian model is available.}
+ \item{cor}{a logical indicating whether the correlation matrix should
+ be returned (\code{TRUE}); by default the variance-covariance matrix
+ is returned (\code{FALSE}).}
+}
+\description{
+ This function computes the expected variances and covariances of a
+ continuous phenotype assuming it evolves under a given model
+ (currently only the model of Brownian motion is available).
+}
+\value{
+ a numeric matrix with the names of the tips (as given by the \code{tip.label}
+ of the argument \code{phy}) 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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+\seealso{
+ \code{\link{read.tree}} to read tree files in Newick format
+}
+\keyword{manip}
+\keyword{multivariate}
--- /dev/null
+\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.
+
+ This 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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+\seealso{
+ \code{\link{Moran.I}}, \code{\link{correlogram.formula}}
+}
+\keyword{manip}
--- /dev/null
+\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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+\seealso{
+ \code{\link{bind.tree}}, \code{\link{drop.tip}}, \code{\link{root}}
+}
+\keyword{manip}
--- /dev/null
+\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 (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}
--- /dev/null
+\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. The names of the vectors of the list are
+ used as taxa names.
+}
+\details{
+ The same three formats are supported in the present function than in
+ \code{\link{read.dna}}: see its help page and the references below for
+ a description of these formats.
+
+ 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; if the taxon names are longer than 10 characters,
+ they are truncated and a warning message is issued.
+
+ The argument `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 `indent = NULL)'. In the FASTA
+ format, the rows are not indented by default. This default behaviour
+ can be modified by specifying a value to `indent': the rows are then
+ indented with `indent' (if it is a character) or `indent' spaces (if
+ it is a numeric). For example, specifying `indent = " "' or `indent
+ = 3' will have exactly the same effect (use `indent = "\t"' for a
+ tabulation).
+}
+\note{
+ Specifying a negative value for `nbcol' (meaning that the nucleotides
+ are printed on a single line) gives the same result for the
+ interleaved and sequential formats.
+
+ 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.
+}
+\value{
+ None (invisible `NULL').
+}
+\author{Emmanuel Paradis \email{Emmanuel.Paradis@mpl.ird.fr}}
+\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}}
+}
+\keyword{IO}
--- /dev/null
+\name{write.nexus}
+\alias{write.nexus}
+\title{Write Tree File in Nexus Format}
+\usage{
+write.nexus(..., file = "", translate = TRUE, original.data = TRUE)
+}
+\arguments{
+ \item{...}{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.}
+ \item{original.data}{a logical, if \code{TRUE} (the default) the
+ data in the original NEXUS file are eventually written in
+ \code{"file"} (see below).}
+}
+\description{
+ This function writes trees in a file with the NEXUS format.
+}
+\details{
+ If \code{original.data = TRUE}, the file as specified by the attribute
+ \code{"origin"} of the first tree is read and its data (except the
+ trees) are written in \code{file}.
+
+ If several trees are given, they must have all the same tip labels.
+
+ If among the objects given some are not trees of class \code{"phylo"},
+ they are simply skipped and not written to 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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+\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}
--- /dev/null
+\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@scs.fsu.edu}}
+\seealso{
+ \code{\link{read.nexus}},\code{\link{write.nexus}},
+ \code{\link{read.nexus.data}}
+}
+\examples{
+\dontrun{\dontshow{library(ape)}}
+## Write interleaved DNA data with 100 characters per line in a DATA block
+\dontrun{data("woodmouse")}
+\dontrun{write.nexus.data(woodmouse, file= "woodmouse.example.nex", interleaved = TRUE, charsperline = 100)}
+## Write sequential DNA data in TAXA and CHARACTERS blocks
+\dontrun{data("cynipids")}
+\dontrun{write.nexus.data(cynipids, file= "cynipids.example.nex", format = "protein", datablock = FALSE, interleaved = FALSE)}
+\dontrun{\dontshow{unlink(c("woodmouse.example.nex", "cynipids.example.nex"))}}
+}
+\keyword{file}
--- /dev/null
+\name{write.tree}
+\alias{write.tree}
+\title{Write Tree File in Parenthetic Format}
+\usage{
+write.tree(phy, file = "", append = FALSE,
+ digits = 10)
+}
+\arguments{
+ \item{phy}{an object of class \code{"phylo"}.}
+ \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.}
+}
+\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
+ `NULL') otherwise.
+}
+\details{
+ The node labels and the root edge length, if available, are written in
+ the file.
+}
+\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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+\seealso{
+ \code{\link{read.tree}}, \code{\link{read.nexus}},
+ \code{\link{write.nexus}}
+}
+\keyword{manip}
+\keyword{IO}
--- /dev/null
+\name{xenarthra}
+\alias{xenarthra}
+\title{Molecular Phylogeny of Living Xenarthrans}
+\description{
+ This phylogeny was inferred by maximum likelihood analysis of the
+ nuclear gene BRCA1 (breast cancer susceptibility, 2788 sites)
+ sequences for 47 placental and 3 marsupial taxa.
+}
+\usage{
+data(xenarthra)
+}
+\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{
+ Delsuc, F., Scally, M., Madsen, O., Stanhope, M. J., de Jong, W. W.,
+ Catzeflis, F. M., Springer, M. S. and Douzery, E. J. P. (2002)
+ Molecular phylogeny of living xenarthrans and the impact of character
+ and taxon sampling on the placental tree rooting. \emph{Molecular
+ Biology and Evolution}, \bold{19}, 1656--1671.
+}
+\seealso{
+ \code{\link{read.tree}}
+}
+\examples{
+data(xenarthra)
+plot(xenarthra)
+### remove the margins...
+plot(xenarthra, no.margin = TRUE)
+### ... and use a smaller font size
+plot(xenarthra, no.margin = TRUE, cex = 0.8)
+}
+\keyword{datasets}
--- /dev/null
+\name{yule}
+\alias{yule}
+\title{Fits 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 \email{Emmanuel.Paradis@mpl.ird.fr}}
+\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}
--- /dev/null
+\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:
+
+ \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{pic}} but
+ currently needs some hacking!
+}
+\value{
+ A NULL value is returned, the results are simply printed.
+}
+\references{
+ Paradis, E. (2005) Statistical analysis of diversification with
+ species traits. \emph{Evolution}, \bold{59}, 1--12.
+}
+\author{Emmanuel Paradis \email{Emmanuel.Paradis@mpl.ird.fr}}
+\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)
+### compare with the simple Yule model, eventually
+### with a likelihood ratio test
+yule(bird.orders)
+### another example with a tree that has a multichotomy
+### but we cannot run yule() because of this!
+data(bird.families)
+y <- rnorm(272) # 137 tips + 135 nodes
+yule.cov(bird.families, ~ y)
+}
+\keyword{models}
--- /dev/null
+\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{...}{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[graphics]{rainbow}} for some possibilities
+ with colours.
+}
+\author{Emmanuel Paradis \email{Emmanuel.Paradis@mpl.ird.fr}}
+\seealso{
+ \code{\link{plot.phylo}}, \code{\link{drop.tip}},
+ \code{\link[graphics]{layout}}, \code{\link[graphics]{rainbow}},
+ \code{\link[graphics]{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}
--- /dev/null
+/*;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; ;
+; BIONJ program ;
+; ;
+; Olivier Gascuel ;
+; ;
+; GERAD - Montreal- Canada ;
+; olivierg@crt.umontreal.ca ;
+; ;
+; LIRMM - Montpellier- France ;
+; gascuel@lirmm.fr ;
+; ;
+; UNIX version, written in C ;
+; by Hoa Sien Cuong (Univ. Montreal) ;
+; ;
+\*;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;*/
+
+//#include "BIONJ.h"
+#include "me.h"
+
+void Initialize(float **delta, double *X, char **labels, int n, POINTERS *trees);
+void Print_outputChar(int i, POINTERS *trees, char *output);
+void bionj (double *X, int *N, char **labels, char **treeStr);
+int Symmetrize(float **delta, int n);
+void Concatenate(char chain1[MAX_LABEL_LENGTH], int ind, POINTERS *trees, int post);
+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 Finish_branch_length(int i, int j, int k, float **delta);
+void FinishStr (float **delta, int n, POINTERS *trees, char *StrTree);
+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);
+
+/* void printMat(float **delta, int n); */
+
+/*;;;;;;;;;;; INPUT, OUTPUT, INITIALIZATION ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; ;
+; ;
+; The delta matrix is read from the input-file. ;
+; It is recommended to put it and the executable in ;
+; a special directory. The input-file and output-file ;
+; can be given as arguments to the executable by ;
+; typing them after the executable (Bionj input-file ;
+; output-file) or by typing them when asked by the ;
+; program. The input-file has to be formated according ;
+; the PHYLIP standard. The output file is formated ;
+; according to the NEWWICK standard. ;
+; ;
+; 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. ;
+; ;
+; This delta matix is made symmetrical using the rule: ;
+; Dij = Dji <- (Dij + Dji)/2. The diagonal is set to 0; ;
+; during the further steps of the algorithm, it is used ;
+; to store the sums Sx. ;
+; ;
+; A second array, trees, is used to store taxon names. ;
+; During the further steps of the algoritm, some ;
+; positions in this array are emptied while the others ;
+; are used to store subtrees. ;
+; ;
+\*;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;*/
+
+
+/*;;;;;;;;;;;;;;;;;;;;;;;;;; Initialize ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;*\
+; ;
+; Description : This function reads an input file and return the ;
+; delta matrix and trees: the list of taxa. ;
+; ;
+; input : ;
+; float **delta : delta matrix ;
+; FILE *input : pointer to input file ;
+; int n : number of taxa ;
+; char **trees : list of taxa ;
+; ;
+; return value: ;
+; float **delta : delta matrix ;
+; char *trees : list of taxa ;
+; ;
+\*;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;*/
+
+//void Initialize(float **delta, FILE *input, int n, POINTERS *trees)
+void Initialize(float **delta, double *X, char **labels, int n, POINTERS *trees)
+{
+ int lig; /* matrix line */
+ int col; /* matrix column */
+// float distance;
+ //char name_taxon[LEN]; /* taxon name */
+ char name_taxon[MAX_LABEL_LENGTH];
+ char format[MAX_DIGITS];
+ WORD *name;
+
+ snprintf (format, MAX_DIGITS, "%%%ds", MAX_LABEL_LENGTH);
+
+ for(lig=1; lig <= n; lig++)
+ {
+ //fscanf(input,"%s",name_taxon); /* read taxon name */
+ //fscanf (input, format, name_taxon); /* read taxon name */
+ strncpy (name_taxon, labels[lig-1], MAX_LABEL_LENGTH);
+ name=(WORD *)calloc(1,sizeof(WORD)); /* taxon name is */
+ if(name == NULL) /* put in trees */
+ {
+ Rprintf("Out of memories !!");
+ exit(0);
+ }
+ else
+ {
+ strncpy (name->name, name_taxon, MAX_LABEL_LENGTH);
+ name->suiv=NULL;
+ trees[lig].head=name;
+ trees[lig].tail=name;
+ for(col=lig; col <= n; col++)
+ {
+ //fscanf(input,"%f",&distance); /* read the distance */
+// &distance = X[XINDEX(lig,col)];
+ delta[col][lig]=X[XINDEX(lig,col)];
+ delta[lig][col]=X[XINDEX(lig,col)];
+ if (lig==col)
+ delta[lig][col]=0;
+ }
+ }
+ }
+ return;
+}
+
+/*;;;;;;;;;;;;;;;;;;;;;;;;;;; Print_output;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;*\
+; ;
+; ;
+; Description : This function prints out the tree in the output file. ;
+; ;
+; input : ;
+; POINTERS *trees : pointer to the subtrees. ;
+; int i : indicate the subtree i to be printed. ;
+: FILE *output : pointer to the output file. ;
+; ;
+; return value: The phylogenetic tree in the output file. ;
+; ;
+\*;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;*/
+
+void Print_outputChar(int i, POINTERS *trees, char *output)
+{
+ WORD *parcour;
+ parcour=trees[i].head;
+ while (parcour != NULL && (strlen (output) + strlen (parcour->name) < MAX_INPUT_SIZE))
+ {
+ output = strncat (output, parcour->name, strlen (parcour->name));
+ parcour=parcour->suiv;
+ }
+ return;
+}
+
+/*;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
+; ;
+; Main program ;
+; ;
+; argc is the number of arguments ;
+; **argv contains the arguments: ;
+; the first argument has to be BIONJ; ;
+; the second is the inptu-file; ;
+; the third is the output-file. ;
+; When the input and output files are ;
+; not given, the user is asked for them. ;
+; ;
+\*;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;*/
+
+
+//tree *bionj (FILE *input, boolean isNJ)
+void bionj (double *X, int *N, char **labels, char **treeStr)
+{
+ POINTERS *trees; /* list of subtrees */
+ tree *T; /* the returned tree */
+ char *chain1; /* stringized branch-length */
+// char *chain2; /* idem */
+ char *str; /* the string containing final tree */
+ 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 i;
+// int ok;
+ int r; /* number of subtrees */
+ int n; /* number of taxa */
+ int x, y;
+// double t;
+ a=(int*)calloc(1,sizeof(int));
+ b=(int*)calloc(1,sizeof(int));
+ chain1=(char *)calloc(MAX_LABEL_LENGTH,sizeof(char));
+ str = (char *)R_alloc(MAX_INPUT_SIZE, sizeof(char));
+ /* added by EP */
+ if (strlen(str))
+ strncpy(str, "", strlen(str));
+ /* end */
+
+// fscanf(input,"%d",&n);
+ n = *N;
+ /* Create the delta matrix */
+ delta=(float **)calloc(n+1,sizeof(float*));
+ for(i=1; i<= n; i++)
+ {
+ delta[i]=(float *)calloc(n+1, sizeof(float));
+ if(delta[i] == NULL)
+ {
+ Rprintf("Out of memories!!");
+ exit(0);
+ }
+ }
+ trees=(POINTERS *)calloc(n+1,sizeof(POINTERS));
+ if(trees == NULL)
+ {
+ Rprintf("Out of memories!!");
+ exit(0);
+ }
+ /* initialise and symmetrize the running delta matrix */
+ r=n;
+ *a=0;
+ *b=0;
+ Initialize(delta, X, labels, n, trees);
+// ok=Symmetrize(delta, n);
+
+// if(!ok)
+// Rprintf("\n The matrix is not symmetric.\n ");
+ while (r > 3) /* until 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) */
+// if (!isNJ)
+ lamda=Lamda(*a, *b, vab, delta, n, r); /* compute lambda* using (9)*/
+ for(i=1; i <= n; i++)
+ {
+ if(!Emptied(i,delta) && (i != *a) && (i != *b))
+ {
+ 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);
+ }
+ }
+ strncpy(chain1,"",1); /* agglomerate the subtrees */
+ strncat(chain1,"(",1); /* a and b together with the*/
+ Concatenate(chain1, *a, trees, 0); /* branch-lengths according */
+ strncpy(chain1,"",1); /* to the NEWWICK format */
+ strncat(chain1,":",1);
+ snprintf(chain1+strlen(chain1),MAX_LABEL_LENGTH,"%f",la);
+
+ strncat(chain1,",",1);
+ Concatenate(chain1,*a, trees, 1);
+ trees[*a].tail->suiv=trees[*b].head;
+ trees[*a].tail=trees[*b].tail;
+ strncpy(chain1,"",1);
+ strncat(chain1,":",1);
+ snprintf(chain1+strlen(chain1),MAX_LABEL_LENGTH,"%f",lb);
+
+ strncat(chain1,")",1);
+ Concatenate(chain1, *a, trees, 1);
+ delta[*b][0]=1.0; /* make the b line empty */
+ trees[*b].head=NULL;
+ trees[*b].tail=NULL;
+ r=r-1;
+ }
+
+ FinishStr (delta, n, trees, str); /* compute the branch-lengths*/
+ /* of the last three subtrees*/
+ /* and print the tree in the */
+ /* output-file */
+ T = readNewickString (str, n);
+ T = detrifurcate(T);
+// compareSets(T,species);
+ partitionSizes(T);
+ *treeStr = (char *)R_alloc(MAX_INPUT_SIZE, sizeof(char));
+ /* added by EP */
+ if (strlen(*treeStr))
+ strncpy(*treeStr, "", strlen(*treeStr));
+ /* end */
+ NewickPrintTreeStr (T, *treeStr);
+
+ for(i=1; i<=n; i++)
+ {
+ delta[i][0]=0.0;
+ trees[i].head=NULL;
+ trees[i].tail=NULL;
+ }
+ free(delta);
+ free(trees);
+ /* free (str); */
+ free (chain1);
+ free (a);
+ free (b);
+ freeTree(T);
+ T = NULL;
+// return (ret);
+ return;
+}
+
+/*;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;*\
+; ;
+; Utilities ;
+; ;
+\*;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;*/
+
+
+
+/*;;;;;;;;;;;;;;;;;;;;;;;;;;; Symmetrize ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;*\
+; ;
+; Description : This function verifies if the delta matrix is symmetric; ;
+; if not the matrix is made symmetric. ;
+; ;
+; input : ;
+; float **delta : delta matrix ;
+; int n : number of taxa ;
+; ;
+; return value: ;
+; int symmetric : indicate if the matrix has been made ;
+; symmetric or not ;
+; ;
+\*;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;*/
+
+int Symmetrize(float **delta, int n)
+{
+ int lig; /* matrix line */
+ int col; /* matrix column */
+ float value; /* symmetrized value */
+ int symmetric;
+
+ symmetric=1;
+ for(lig=1; lig <= n; lig++)
+ {
+ for(col=1; col < lig; col++)
+ {
+ if(delta[lig][col] != delta[col][lig])
+ {
+ value= (delta[lig][col]+delta[col][lig])/2;
+ delta[lig][col]=value;
+ delta[col][lig]=value;
+ symmetric=0;
+ }
+ }
+ }
+ return(symmetric);
+}
+
+
+
+
+/*;;;;;;;;;;;;;;;;;;;;;;;;;;; Concatenate ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;*\
+; ;
+; ;
+; Description : This function concatenates a string to another. ;
+; ;
+; input : ;
+; char *chain1 : the string to be concatenated. ;
+; int ind : indicate the subtree to which concatenate the ;
+; string ;
+; POINTERS *trees : pointer to subtrees. ;
+; int post : position to which concatenate (front (0) or ;
+; end (1)) ;
+; ;
+\*;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;*/
+
+//void Concatenate(char chain1[LEN], int ind, POINTERS *trees, int post)
+void Concatenate(char chain1[MAX_LABEL_LENGTH], int ind, POINTERS *trees, int post)
+{
+ WORD *bran;
+
+ bran=(WORD *)calloc(1,sizeof(WORD));
+ if(bran == NULL)
+ {
+ Rprintf("Out of memories");
+ exit(0);
+ }
+ else
+ {
+ strncpy(bran->name,chain1,MAX_LABEL_LENGTH);
+ bran->suiv=NULL;
+ }
+ if(post == 0)
+ {
+ bran->suiv=trees[ind].head;
+ trees[ind].head=bran;
+ }
+ else
+ {
+ trees[ind].tail->suiv=bran;
+ trees[ind].tail=trees[ind].tail->suiv;
+ }
+}
+
+
+/*;;;;;;;;;;;;;;;;;;;;;;;;;;;;;Distance;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;*\
+; ;
+; Description : This function retrieve ant return de distance between taxa ;
+; i and j from the delta matrix. ;
+; ;
+; input : ;
+; int i : taxon i ;
+; int j : taxon j ;
+; float **delta : the delta matrix ;
+; ;
+; return value: ;
+; 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;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;*\
+; ;
+; Description : This function retrieve and return 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 ;
+; ;
+; return value: ;
+; 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 ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;*\
+; ;
+; Description : This function verifie if a line is emptied or not. ;
+; ;
+; input : ;
+; int i : subtree (or line) i ;
+; float **delta : the delta matrix ;
+; ;
+; return value: ;
+; 0 : if not emptied. ;
+; 1 : if emptied. ;
+; ;
+\*;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;*/
+
+int Emptied(int i, float **delta) /* test if the ith line is emptied */
+{
+ return((int)delta[i][0]);
+}
+
+
+/*;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;Sum_S;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;*\
+; ;
+; Description : This function retrieves the sum Sx from the diagonal ;
+; of the delta matrix. ;
+; ;
+; input : ;
+; int i : subtree i ;
+; float **delta : the delta matrix ;
+; ;
+; return value: ;
+; float delta[i][i] : sum Si ;
+; ;
+\*;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;*/
+
+float Sum_S(int i, float **delta) /* get sum Si form the diagonal */
+{
+ return(delta[i][i]);
+}
+
+
+/*;;;;;;;;;;;;;;;;;;;;;;;Compute_sums_Sx;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;*\
+; ;
+; Description : This function computes the sums Sx and store 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;
+ int j;
+
+ for(i= 1; i <= n ; i++)
+ {
+ if(!Emptied(i,delta))
+ {
+ sum=0;
+ for(j=1; j <=n; j++)
+ {
+ if(i != j && !Emptied(j,delta)) /* compute the sum Si */
+ sum=sum + Distance(i,j,delta);
+ }
+ }
+ delta[i][i]=sum; /* store the sum Si in */
+ } /* delta\92s diagonal */
+}
+
+
+/*;;;;;;;;;;;;;;;;;;;;;;;;;;;;;Best_pair;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;*\
+; ;
+; Description : 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 ;
+; ;
+; return value: ;
+; 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.0e300;
+ for(x=1; x <= n; x++)
+ {
+ if(!Emptied(x,delta))
+ {
+ for(y=1; y < x; y++)
+ {
+ if(!Emptied(y,delta))
+ {
+ Qxy=Agglomerative_criterion(x,y,delta,r);
+ if(Qxy < Qmin-0.000001)
+ {
+ Qmin=Qxy;
+ *a=x;
+ *b=y;
+ }
+ }
+ }
+ }
+ }
+}
+
+
+/*;;;;;;;;;;;;;;;;;;;;;;Finish_branch_length;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;*\
+; ;
+; Description : Compute the length of the branch attached ;
+; to the subtree i, during the final step ;
+; ;
+; input : ;
+; int i : position of subtree i ;
+; int j : position of subtree j ;
+; int k : position of subtree k ;
+; float **delta : ;
+; ;
+; return value: ;
+; float length : The length of the branch ;
+; ;
+\*;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;*/
+
+float Finish_branch_length(int i, int j, int k, float **delta)
+{
+ float length;
+ length=0.5*(Distance(i,j,delta) + Distance(i,k,delta)
+ -Distance(j,k,delta));
+ return(length);
+}
+
+
+/*;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;Finish;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;*\
+; ;
+; Description : This function compute the length of the lasts three ;
+; subtrees and write the tree in the output file. ;
+; ;
+; input : ;
+; float **delta : the delta matrix ;
+; int n : the number of taxa ;
+; WORD *trees : list of subtrees ;
+; ;
+; ;
+\*;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;*/
+/*
+void Finish(float **delta, int n, POINTERS *trees, FILE *output)
+{
+ int l=1;
+ int i=0;
+ float length;
+ WORD *bidon;
+ WORD *ele;
+ int last[3]; // the last three subtrees
+
+ while(l <= n)
+ { // find the last tree subtree
+ if(!Emptied(l, delta))
+ {
+ last[i]=l;
+ i++;
+ }
+ l++;
+ }
+
+ length=Finish_branch_length(last[0],last[1],last[2],delta);
+ fprintf(output,"(");
+ Print_output(last[0],trees,output);
+ fprintf(output,":");
+// gcvt(length,PREC, str);
+// fprintf(output,"%s,",str);
+ fprintf(output,"%f,",length);
+
+ length=Finish_branch_length(last[1],last[0],last[2],delta);
+ Print_output(last[1],trees,output);
+ fprintf(output,":");
+// gcvt(length,PREC, str);
+// fprintf(output,"%s,",str);
+ fprintf(output,"%f,",length);
+
+ length=Finish_branch_length(last[2],last[1],last[0],delta);
+ Print_output(last[2],trees,output);
+ fprintf(output,":");
+// gcvt(length,PREC,str);
+// fprintf(output,"%s",str);
+ fprintf(output,"%f",length);
+ fprintf(output,");");
+ fprintf(output,"\n");
+
+ for(i=0; i < 3; i++)
+ {
+ bidon=trees[last[i]].head;
+ ele=bidon;
+ while(bidon!=NULL)
+ {
+ ele=ele->suiv;
+ free(bidon);
+ bidon=ele;
+ }
+ }
+}
+*/
+
+void FinishStr (float **delta, int n, POINTERS *trees, char *StrTree)
+{
+ int l=1;
+ int i=0;
+ float length;
+ char *tmp;
+ WORD *bidon;
+ WORD *ele;
+ int last[3]; /* the last three subtrees */
+
+ while(l <= n)
+ { /* find the last tree subtree */
+ if(!Emptied(l, delta))
+ {
+ last[i]=l;
+ i++;
+ }
+ l++;
+ }
+ tmp = (char*) calloc (12, sizeof(char));
+ StrTree[0]='(';
+
+ length=Finish_branch_length(last[0],last[1],last[2],delta);
+ Print_outputChar (last[0], trees, StrTree);
+ snprintf (tmp, 12, "%f,", length);
+ if (strlen (StrTree) + strlen (tmp) < MAX_INPUT_SIZE-1) {
+ strncat (StrTree, ":", 1);
+ strncat (StrTree, tmp, strlen (tmp));
+ }
+
+ length=Finish_branch_length(last[1],last[0],last[2],delta);
+ Print_outputChar (last[1], trees, StrTree);
+ snprintf (tmp, 12, "%f,", length);
+ if (strlen (StrTree) + strlen (tmp) < MAX_INPUT_SIZE-1) {
+ strncat (StrTree, ":", 1);
+ strncat (StrTree, tmp, strlen (tmp));
+ }
+
+ length=Finish_branch_length(last[2],last[1],last[0],delta);
+ Print_outputChar (last[2], trees, StrTree);
+ snprintf (tmp, 12, "%f", length);
+ if (strlen (StrTree) + strlen (tmp) < MAX_INPUT_SIZE-1) {
+ strncat (StrTree, ":", 1);
+ strncat (StrTree, tmp, strlen (tmp));
+ }
+
+ if (strlen (StrTree) < MAX_INPUT_SIZE-3)
+ strncat (StrTree, ");\n", 3);
+
+ free (tmp);
+ for(i=0; i < 3; i++)
+ {
+ bidon=trees[last[i]].head;
+ ele=bidon;
+ while(bidon!=NULL)
+ {
+ ele=ele->suiv;
+ free(bidon);
+ bidon=ele;
+ }
+ }
+ return;
+}
+
+/*;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;*\
+; ;
+; Formulae ;
+; ;
+\*;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;*/
+
+
+float Agglomerative_criterion(int i, int j, float **delta, int r)
+{
+ float Qij;
+ Qij=(r-2)*Distance(i,j,delta) /* Formula (1) */
+ -Sum_S(i,delta)
+ -Sum_S(j,delta);
+
+ return(Qij);
+}
+
+
+float Branch_length(int a, int b, float **delta, int r)
+{
+ float length;
+ length=0.5*(Distance(a,b,delta) /* Formula (2) */
+ +(Sum_S(a,delta)
+ -Sum_S(b,delta))/(r-2));
+ return(length);
+}
+
+
+float Reduction4(int a, float la, int b, float lb, int i, float lamda, float **delta)
+{
+ float Dui;
+ Dui=lamda*(Distance(a,i,delta)-la)
+ +(1-lamda)*(Distance(b,i,delta)-lb); /* Formula (4) */
+ return(Dui);
+}
+
+
+float Reduction10(int a, int b, int i, float lamda, float vab, float **delta)
+{
+ float Vci;
+ Vci=lamda*Variance(a,i,delta)+(1-lamda)*Variance(b,i,delta)
+ -lamda*(1-lamda)*vab; /*Formula (10) */
+ return(Vci);
+}
+
+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))
+ lamda=lamda + (Variance(b,i,delta) - Variance(a,i,delta));
+ }
+ lamda=0.5 + lamda/(2*(r-2)*vab);
+ } /* Formula (9) and the */
+ if(lamda > 1.0) /* constraint that lamda*/
+ lamda = 1.0; /* belongs to [0,1] */
+ if(lamda < 0.0)
+ lamda=0.0;
+ return(lamda);
+}
+
+
+/* void printMat(float **delta, int n) */
+/* { */
+/* int i, j; */
+/* for (i=1; i<=n; i++) { */
+/* for (j=1; j<=n; j++) */
+/* Rprintf ("%f ", delta[i][j]); */
+/* Rprintf("\n"); */
+/* } */
+/* Rprintf("\n"); */
+/* return; */
+/* } */
--- /dev/null
+PKG_LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS)
--- /dev/null
+/*#include <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+#include "graph.h"
+#include "main.h"*/
+
+#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);
+}
+*/
--- /dev/null
+/*#include <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+#include "graph.h"
+#include "main.h"
+*/
+#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;
+ 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]];
+ (*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]);
+}
+
--- /dev/null
+/* bipartition.c 2007-06-29 */
+
+/* Copyright 2005-2007 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.h>
+#include <Rinternals.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 */
+
+/* From R-ext: */
+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;
+}
+
+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, l, 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*(Nnode - 1) + 1;
+ else Npart = Nnode;
+
+ 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++) {
+ 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 */
--- /dev/null
+/* dist_dna.c 2007-12-01 */
+
+/* Copyright 2005-2007 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>
+
+/* 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;
+
+void distDNA_raw(unsigned char *x, int *n, int *s, double *d)
+{
+ 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++;
+ d[target] = ((double) Nd / *s);
+ target++;
+ }
+ }
+}
+
+void distDNA_raw_pairdel(unsigned char *x, int *n, int *s, double *d)
+{
+ 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++;
+ }
+ d[target] = ((double) Nd/L);
+ 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 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++;
+
+#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))/2;\
+ }
+
+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, k, Nd, Ns1, Ns2, L, target, s1, s2;
+ double P1, P2, Q, A, B, C, 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, k, Nd, Ns1, Ns2, L, target, s1, s2;
+ double P1, P2, Q, A, B, C, 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)/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] - 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], ndim = 4, info, ipiv[16];
+ double P12[16], P21[16], U[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++;
+ }
+ }
+}
+
+void BaseProportion(unsigned char *x, int *n, double *BF)
+{
+ int i, m;
+
+ m = 0;
+ for (i = 0; i < *n; i++) {
+ if (KnownBase(x[i])) {
+ m++;
+ switch (x[i]) {
+ case 136 : BF[0]++; break;
+ case 40 : BF[1]++; break;
+ case 72 : BF[2]++; break;
+ case 24 : BF[3]++; break;
+ }
+ }
+ }
+ for (i = 0; i < 4; i++) BF[i] /= m;
+}
+
+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 (x[i] == basis) i++;
+ else {
+ seg[j] = 1;
+ break;
+ }
+ }
+ }
+}
+
+void NucleotideDiversity(unsigned char *x, int *n, int *s,
+ int *pairdel, double *ans)
+{
+ int i1, i2, s1, s2, Nd, L;
+
+ if (!*pairdel) L = *s;
+
+ for (i1 = 1; i1 < *n; i1++) {
+ for (i2 = i1 + 1; i2 <= *n; i2++) {
+ Nd = 0;
+ if (*pairdel) 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++;
+ }
+ *ans += ((double) Nd/L);
+ }
+ }
+ *ans /= (*n * (*n - 1)/2);
+}
+
+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);
+ else distDNA_raw(x, n, s, d); 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;
+ }
+}
--- /dev/null
+/*#include <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+#include "main.h"*/
+
+#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);
+}
--- /dev/null
+/* matexpo.c 2007-10-08 */
+
+/* Copyright 2007 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, *ord;
+ 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));
+ ord = (int *)R_alloc(n, 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];
+ }
+ }
+}
--- /dev/null
+#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);
+
+
+void me_b(double *X, int *N, char **labels, char **treeStr, int *nni)
+{
+ double **D, **A;
+ set *species, *slooper;
+ node *addNode;
+ tree *T;
+ char *str;
+ int n, nniCount;
+
+ n = *N;
+ T = NULL;
+ nniCount = 0;
+ species = (set *) malloc(sizeof(set));
+ species->firstNode = NULL;
+ species->secondNode = NULL;
+ str = (char *)R_alloc(MAX_INPUT_SIZE, sizeof(char));
+ /* added by EP */
+ if (strlen(str))
+ strncpy(str, "", strlen(str));
+ /* end */
+ 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 == 1)
+ bNNI(T,A,&nniCount,D,n);
+ assignBMEWeights(T,A);
+
+ NewickPrintTreeStr(T,str);
+
+ if (strlen (str) < MAX_INPUT_SIZE -1)
+ {
+ *treeStr = (char *)R_alloc(MAX_INPUT_SIZE, sizeof(char));
+ /* added by EP */
+ if (strlen(*treeStr))
+ strncpy(*treeStr, "", strlen(*treeStr));
+ /* end */
+ strncpy (*treeStr, str, strlen(str));
+ }
+
+/* free (str); */
+ freeMatrix(D,n);
+ freeMatrix(A,2*n - 2);
+ freeSet(species);
+ freeTree(T);
+ T = NULL;
+
+ /* return; */
+}
+
+void me_o(double *X, int *N, char **labels, char **treeStr, int *nni)
+{
+ double **D, **A;
+ set *species, *slooper;
+ node *addNode;
+ tree *T;
+ char *str;
+ int n, nniCount;
+
+ n = *N;
+ T = NULL;
+ nniCount = 0;
+ species = (set *) malloc(sizeof(set));
+ species->firstNode = NULL;
+ species->secondNode = NULL;
+ str = (char *)R_alloc(MAX_INPUT_SIZE, sizeof(char));
+ /* added by EP */
+ if (strlen(str))
+ strncpy(str, "", strlen(str));
+ /* end */
+
+ 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 == 1)
+ NNI(T,A,&nniCount,D,n);
+ assignOLSWeights(T,A);
+
+ NewickPrintTreeStr(T,str);
+
+ if (strlen (str) < MAX_INPUT_SIZE -1)
+ {
+ *treeStr = (char *)R_alloc(MAX_INPUT_SIZE, sizeof(char));
+ /* added by EP */
+ if (strlen(*treeStr))
+ strncpy(*treeStr, "", strlen(*treeStr));
+ /* end */
+ strncpy (*treeStr, str, strlen (str));
+ }
+
+ /* free (str); */
+ freeMatrix(D,n);
+ freeMatrix(A,2*n - 2);
+ freeSet(species);
+ freeTree(T);
+ T = NULL;
+
+ return;
+}
+
+/*************************************************************************
+
+ 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)
+{
+ 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->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)
+{
+ return(makeNode(label,NULL,i));
+}
+
+node *makeNode(char *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->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)
+ {
+ Rprintf ("Error: root %s is poorly rooted.\n",v->label);
+ exit(0);
+ }
+ 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))
+ {
+ 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))
+ {
+ v->index2 = w->index2;
+ w->index2 = -1;
+ break;
+ }
+ }
+ if (-1 == v->index2)
+ {
+ Rprintf("Error leaf %s in tree not in distance matrix.\n",v->label);
+ exit(0);
+ }
+ e = depthFirstTraverse(T,NULL);
+ while (NULL != e)
+ {
+ v = e->head;
+ if ((leaf(v)) && (-1 == v->index2))
+ {
+ Rprintf("Error leaf %s in tree not in distance matrix.\n",v->label);
+ exit(0);
+ }
+ e = depthFirstTraverse(T,e);
+ }
+ for(X = S; NULL != X; X = X->secondNode)
+ if (X->firstNode->index2 > -1)
+ {
+ Rprintf("Error node %s in matrix but not a leaf in tree.\n",X->firstNode->label);
+ exit(0);
+ }
+ 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)
+ 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);
+}
+
--- /dev/null
+//#include <stdio.h>
+//#include <stdlib.h>
+//#include <math.h>
+//#include <string.h>
+//#include <sys/types.h>
+//#include <sys/stat.h>
+//#include "main.h"
+//#include "graph.h"
+#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 {
+ 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, char **labels, char **treeStr, int *nni);
+void me_o(double *X, int *N, char **labels, char **treeStr, int *nni);
+int whiteSpace(char c);
+double **initDoubleMatrix(int d);
+double **loadMatrix (double *X, char **labels, int n, set *S);
+set *addToSet(node *v, set *X);
+node *makeNewNode(char *label, int i);
+node *makeNode(char *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);
+tree *readNewickString (char *str, int numLeaves);
+node *decodeNewickSubtree(char *treeString, tree *T, int *uCount);
+void NewickPrintSubtree(tree *T, edge *e, char *str);
+void NewickPrintBinaryTree(tree *T, char *str);
+void NewickPrintTrinaryTree(tree *T, char *str);
+void NewickPrintTreeStr(tree *T, char *str);
+
--- /dev/null
+//#include <stdio.h>
+//#include <stdlib.h>
+//#include <math.h>
+#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;
+ 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*/
--- /dev/null
+//#include <stdio.h>
+//#include <stdlib.h>
+//#include <math.h>
+#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++)
+ printf("%lf ", A[i][j]);
+ printf("\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)
+{
+ 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);
+}
--- /dev/null
+/* mlphylo.c 2008-01-03 */
+
+/* Copyright 2006-2008 Emmanuel Paradis */
+
+/* This file is part of the R-package `ape'. */
+/* See the file ../COPYING for licensing issues. */
+
+#include <R.h>
+#include <Rmath.h>
+#include <R_ext/Applic.h>
+#include <R_ext/Lapack.h>
+
+typedef struct {
+ int *n;
+ int *s;
+ double *w;
+ unsigned char *seq;
+ double *anc;
+} dna_matrix;
+
+typedef struct {
+ int *edge1;
+ int *edge2;
+ double *el;
+} phylo;
+
+typedef struct {
+ int *npart;
+ int *partition;
+ int *model;
+ double *xi;
+ double *para;
+ int *npara;
+ double *alpha;
+ int *nalpha;
+ int *ncat;
+ double *invar;
+ int *ninvar;
+} DNAmodel;
+
+typedef struct {
+ dna_matrix X;
+ phylo PHY;
+ DNAmodel MOD;
+ double *BF;
+} DNAdata;
+
+typedef struct {
+ DNAdata *D; int i;
+} info;
+
+
+void tQ_unbalBF(double *BF, double *P)
+/* This function computes the rate matrix Q multiplied by
+ time t in the case of unbalanced base frequencies.
+ The arguments are:
+ BF: the base frequencies
+ P: (input) the matrix of substitution rates
+ (output) tQ
+ NOTE: P must already be multiplied by t */
+{
+ P[1] *= BF[0]; P[2] *= BF[0]; P[3] *= BF[0];
+ P[4] *= BF[1]; P[6] *= BF[1]; P[7] *= BF[1];
+ P[8] *= BF[2]; P[9] *= BF[2]; P[11] *= BF[2];
+ P[12] *= BF[3]; P[13] *= BF[3]; P[14] *= BF[3];
+
+ P[0] = -P[4] - P[8] - P[12];
+ P[5] = -P[1] - P[9] - P[13];
+ P[10] = -P[2] - P[6] - P[14];
+ P[15] = -P[3] - P[7] - P[11];
+}
+
+void mat_expo4x4(double *P)
+/* This function computes the exponential of a 4x4 matrix */
+{
+ double U[16], vl[4], WR[4], Uinv[16], WI[4], work[32];
+ int i, info, ipiv[16], n = 4, lw = 32, ord[4];
+ char yes = 'V', no = 'N';
+
+ /* 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 */
+ for (i = 0; i < 16; i++) P[i] = U[i];
+
+ /* For the inversion, we first make Uinv an identity matrix */
+ for (i = 1; i < 15; i++) Uinv[i] = 0;
+ Uinv[0] = Uinv[5] = Uinv[10] = Uinv[15] = 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 < 4; i++) U[i] *= exp(WR[0]);
+ for (i = 4; i < 8; i++) U[i] *= exp(WR[1]);
+ for (i = 8; i < 12; i++) U[i] *= exp(WR[2]);
+ for (i = 12; i < 16; i++) U[i] *= exp(WR[3]);
+
+ /* The second matrix product with U^-1 */
+ P[1] = U[1]*Uinv[0] + U[5]*Uinv[1] + U[9]*Uinv[2] + U[13]*Uinv[3];
+ P[2] = U[2]*Uinv[0] + U[6]*Uinv[1] + U[10]*Uinv[2] + U[14]*Uinv[3];
+ P[3] = U[3]*Uinv[0] + U[7]*Uinv[1] + U[11]*Uinv[2] + U[15]*Uinv[3];
+ P[4] = U[0]*Uinv[4] + U[4]*Uinv[5] + U[8]*Uinv[6] + U[12]*Uinv[7];
+ P[6] = U[2]*Uinv[4] + U[6]*Uinv[5] + U[10]*Uinv[6] + U[14]*Uinv[7];
+ P[7] = U[3]*Uinv[4] + U[7]*Uinv[5] + U[11]*Uinv[6] + U[15]*Uinv[7];
+ P[8] = U[0]*Uinv[8] + U[4]*Uinv[9] + U[8]*Uinv[10] + U[12]*Uinv[11];
+ P[9] = U[1]*Uinv[8] + U[5]*Uinv[9] + U[9]*Uinv[10] + U[13]*Uinv[11];
+ P[11] = U[3]*Uinv[8] + U[7]*Uinv[9] + U[11]*Uinv[10] + U[15]*Uinv[11];
+ P[12] = U[0]*Uinv[12] + U[4]*Uinv[13] + U[8]*Uinv[14] + U[12]*Uinv[15];
+ P[13] = U[1]*Uinv[12] + U[5]*Uinv[13] + U[9]*Uinv[14] + U[13]*Uinv[15];
+ P[14] = U[2]*Uinv[12] + U[6]*Uinv[13] + U[10]*Uinv[14] + U[14]*Uinv[15];
+ P[0] = 1 - P[4] - P[8] - P[12];
+ P[5] = 1 - P[1] - P[9] - P[13];
+ P[10] = 1 - P[2] - P[6] - P[14];
+ P[15] = 1 - P[3] - P[7] - P[11];
+}
+
+void PMAT_JC69(double t, double u, double *P)
+{
+ P[1]=P[2]=P[3]=P[4]=P[6]=P[7]=P[8]=P[9]=P[11]=P[12]=P[13]=P[14]=(1 - exp(-4*u*t))/4;
+ P[0] = P[5] = P[10] = P[15] = 1 - 3*P[1];
+}
+
+void PMAT_K80(double t, double b, double a, double *P)
+{
+ double R, p;
+
+ R = a/(2*b);
+ p = exp(-2*t/(R + 1));
+
+ P[1] = 0.5*(1 - p); /* A -> C */
+ P[2] = 0.25 - 0.5*exp(-t*(2*R + 1)/(R + 1)) + 0.25*p; /* A -> G */
+ P[0] = P[5] = P[10] = P[15] = 1 - 2*P[1] - P[2];
+ P[3] = P[4] = P[6] = P[11] = P[9] = P[12] = P[14] = P[1];
+ P[7] = P[8] = P[13] = P[2];
+}
+
+void PMAT_F81(double t, double u, double *BF, double *P)
+{
+ double p;
+ p = exp(-t*u);
+
+ P[0] = p + (1 - p) * BF[0]; /* A->A */
+ P[1] = P[9] = P[13] = (1 - p)*BF[1]; /* A->C, G->C, T->C */
+ P[2] = P[6] = P[14] = (1 - p)*BF[2]; /* A->G, C->G, T->G */
+ P[3] = P[7] = P[11] = (1 - p)*BF[3]; /* A->T, C->T, G->T */
+ P[4] = P[8] = P[12] = (1 - p)*BF[0]; /* C->A, G->A, T->A */
+ P[5] = p + P[1]; /* C->C */
+ P[10] = p + P[2]; /* G->G */
+ P[15] = p + P[3]; /* T->T */
+}
+
+void PMAT_F84(double t, double a, double b, double *BF, double *P)
+{
+ double pI, pII, B, x, y;
+
+ B = exp(-b*t);
+ pI = B * (1 - exp(-a*t)); /* probability of at least one event of type I */
+ pII = 1 - B; /* probability of at least one event of type II */
+ x = pI * (BF[0] + BF[2]);
+ y = pI * (BF[1] + BF[3]);
+
+ P[12] = P[4] = pII * BF[0]; /* C->A, T->A */
+ P[14] = P[6] = pII * BF[2]; /* C->G, T->G */
+ P[9] = P[1] = pII * BF[1]; /* A->C, G->C */
+ P[2] = x + P[6]; /* A->G */
+ P[11] = P[3] = pII * BF[3]; /* A->T, G->T*/
+ P[0] = 1 - P[1] - P[2] - P[3]; /* A->A */
+ P[7] = y + P[3]; /* C->T */
+ P[5] = 1 - P[4] - P[6] - P[7]; /* C->C */
+ P[8] = x + P[4]; /* G->A */
+ P[10] = 1 - P[8] - P[9] - P[11]; /* G->G */
+ P[13] = y + P[1]; /* T->C */
+ P[15] = 1 - P[12] - P[13] - P[14]; /* T->T */
+}
+
+void PMAT_HKY85(double t, double a, double b, double *BF, double *P)
+{
+ P[2] = P[7] = P[8] = P[13] = t*a;
+ P[1] = P[3] = P[4] = P[6] = P[9] = P[11] = P[12] = P[14] = t*b;
+ tQ_unbalBF(BF, P);
+ mat_expo4x4(P);
+}
+
+void PMAT_T92(double t, double a, double b, double *BF, double *P)
+{
+ double theta, A, B1, B2, C, x, y;
+
+ theta = BF[1] + BF[2];
+ A = (1 - theta)/2;
+ B1 = (1 + exp(-t));
+ B2 = (1 - exp(-t));
+ C = exp(-t * ((a/b + 1)/2));
+ x = 0.5 * theta * B1;
+ y = (1 - theta) * C;
+
+ P[1] = P[6] = P[9] = P[14] = 0.5 * theta * B2; /* A->C, C->G, T->G, G->C */
+ P[2] = P[13] = x - theta * C; /* A->G, T->C */
+ P[3] = P[4] = P[11] = P[12] = A * B2; /* A->T, C->A, G->T, T->A */
+ P[0] = P[15] = 1 - P[1] - P[2] - P[3]; /* A->A, T->T */
+ P[5] = P[10] = x + y; /* C->C, G->G */
+ P[7] = P[8] = A * B1 - y; /* C->T, G->A */
+}
+
+void PMAT_TN93(double t, double a1, double a2, double b,
+ double *BF, double *P)
+{
+
+ double A1, A2, B;
+
+ A1 = (1 - exp(-a1*t)); /* transitions between purines (A <-> G) */
+ A2 = (1 - exp(-a2*t)); /* transitions between pyrimidines (C <-> T) */
+ B = (1 - exp(-b*t));
+
+ P[1] = B * BF[1]; /* A->C */
+ P[2] = A1 * BF[2]; /* A->G */
+ P[3] = B * BF[3]; /* A->T */
+ P[0] = 1 - P[1] - P[2] - P[3]; /* A->A */
+ P[4] = B * BF[0]; /* C->A */
+ P[6] = B * BF[2]; /* C->G */
+ P[7] = A2 * BF[3] ; /* C->T */
+ P[5] = 1 - P[4] - P[6] - P[7]; /* C->C */
+ P[8] = A1 * BF[0]; /* G->A */
+ P[9] = B * BF[1]; /* G->C */
+ P[11] = B * BF[3]; /* G->T */
+ P[10] = 1 - P[8] - P[9] - P[11]; /* G->G */
+ P[12] = B * BF[0]; /* T->A */
+ P[13] = A2 * BF[1]; /* T->C */
+ P[14] = B * BF[2]; /* T->G */
+ P[15] = 1 - P[12] - P[13] - P[14]; /* T->T */
+}
+
+void PMAT_GTR(double t, double a, double b, double c, double d, double e,
+ double f, double *BF, double *P)
+{
+ P[1] = P[4] = t*a;
+ P[2] = P[8] = t*b;
+ P[3] = P[12] = t*c;
+ P[6] = P[9] = t*d;
+ P[7] = P[13] = t*e;
+ P[11] = P[14] = t*f;
+ tQ_unbalBF(BF, P);
+ mat_expo4x4(P);
+}
+
+#define GET_DNA_PARAMETERS \
+ /* get the substitution parameters */ \
+ model = *(D->MOD.model); \
+ /* If the model is not JC69 or F81: */ \
+ if (model != 1 && model != 3) { \
+ for(i = 0; i < *(D->MOD.npara); i++) \
+ u[i] = D->MOD.para[i]; \
+ } \
+ /* get the shape parameter and calculate the coefficients */ \
+ ncat = *(D->MOD.ncat); \
+ if (ncat > 1) { \
+ /* use `tmp[0]' to store the mean of the coefficients */ \
+ /* in order to rescale them */ \
+ tmp[0] = 0.; \
+ if (*(D->MOD.nalpha) > 1) alpha = *(D->MOD.alpha); \
+ else alpha = D->MOD.alpha[k]; \
+ for (j = 0; j < ncat; j++) { \
+ coef_gamma[j] = qgamma((0.5 + j)/ncat, alpha, \
+ 1/alpha, 1, 0); \
+ tmp[0] += coef_gamma[j]; \
+ } \
+ tmp[0] /= ncat; \
+ for (j = 0; j < ncat; j++) \
+ coef_gamma[j] /= tmp[0]; \
+ } else coef_gamma[0] = 1.; \
+ /* get the proportion of invariants */ \
+ if (*(D->MOD.ninvar)) { \
+ if (*(D->MOD.ninvar) > 1) I = *(D->MOD.invar); \
+ else I = D->MOD.invar[k]; \
+ } else I = 0.; \
+
+void getSiteLik(int n, int d, int j, int nr, DNAdata *D, double *L)
+{
+ int i;
+
+ if (d <= n - 1) {
+ i = d + j*n;
+ memset(L, 0, 4*sizeof(double));
+ if (D->X.seq[i] & 128) L[0] = 1;
+ if (D->X.seq[i] & 64) L[1] = 1;
+ if (D->X.seq[i] & 32) L[2] = 1;
+ if (D->X.seq[i] & 16) L[3] = 1;
+ } else {
+ i = (d - n) + j*(n - 2);
+ L[0] = D->X.anc[i];
+ L[1] = D->X.anc[i + nr];
+ L[2] = D->X.anc[i + 2*nr];
+ L[3] = D->X.anc[i + 3*nr];
+ }
+}
+
+#define LOOP_THROUGH_SITES \
+ for(j = start; j < end; j++) { \
+ memset(tmp, 0, 4*sizeof(double)); \
+ getSiteLik(n, d1, j, nr, D, L1); \
+ getSiteLik(n, d2, j, nr, D, L2); \
+ for(i = 0; i < ncat; i++) { \
+ switch(model) { \
+ case 1 : PMAT_JC69(l1, coef_gamma[i], P1); \
+ PMAT_JC69(l2, coef_gamma[i], P2); break; \
+ case 2 : PMAT_K80(l1, coef_gamma[i], u[0], P1); \
+ PMAT_K80(l2, coef_gamma[i], u[0], P2); break; \
+ case 3 : PMAT_F81(l1, coef_gamma[i], BF, P1); \
+ PMAT_F81(l2, coef_gamma[i], BF, P2); break; \
+ case 4 : PMAT_F84(l1, coef_gamma[i], u[0], BF, P1); \
+ PMAT_F84(l2, coef_gamma[i], u[0], BF, P2); break; \
+ case 5 : PMAT_HKY85(l1, coef_gamma[i], u[0], BF, P1); \
+ PMAT_HKY85(l2, coef_gamma[i], u[0], BF, P2); break; \
+ case 6 : PMAT_T92(l1, coef_gamma[i], u[0], BF, P1); \
+ PMAT_T92(l2, coef_gamma[i], u[0], BF, P2); break; \
+ case 7 : PMAT_TN93(l1, coef_gamma[i], u[0], u[1], BF, P1); \
+ PMAT_TN93(l2, coef_gamma[i], u[0], u[1], BF, P2); break; \
+ case 8 : PMAT_GTR(l1, coef_gamma[i], u[0], u[1], u[2], u[3], u[4], BF, P1); \
+ PMAT_GTR(l2, coef_gamma[i], u[0], u[1], u[2], u[3], u[4], BF, P2); break; \
+ } \
+ tmp[0] += (L1[0]*P1[0] + L1[1]*P1[1] + L1[2]*P1[2] + L1[3]*P1[3]) * \
+ (L2[0]*P2[0] + L2[1]*P2[1] + L2[2]*P2[2] + L2[3]*P2[3]); \
+ tmp[1] += (L1[0]*P1[4] + L1[1]*P1[5] + L1[2]*P1[6] + L1[3]*P1[7]) * \
+ (L2[0]*P2[4] + L2[1]*P2[5] + L2[2]*P2[6] + L2[3]*P2[7]); \
+ tmp[2] += (L1[0]*P1[8] + L1[1]*P1[9] + L1[2]*P1[10] + L1[3]*P1[11]) * \
+ (L2[0]*P2[8] + L2[1]*P2[9] + L2[2]*P2[10] + L2[3]*P2[11]); \
+ tmp[3] += (L1[0]*P1[12] + L1[1]*P1[13] + L1[2]*P1[14] + L1[3]*P1[15]) * \
+ (L2[0]*P2[12] + L2[1]*P2[13] + L2[2]*P2[14] + L2[3]*P2[15]); \
+ } \
+ if (ncat > 1) { \
+ tmp[0] /= ncat; \
+ tmp[1] /= ncat; \
+ tmp[2] /= ncat; \
+ tmp[3] /= ncat; \
+ } \
+ if (D->MOD.ninvar) { \
+ V = 1. - I; \
+ tmp[0] = V*tmp[0] + I*L1[0]*L2[0]; \
+ tmp[1] = V*tmp[1] + I*L1[1]*L2[1]; \
+ tmp[2] = V*tmp[2] + I*L1[2]*L2[2]; \
+ tmp[3] = V*tmp[3] + I*L1[3]*L2[3]; \
+ } \
+ ind = anc - n + j*(n - 2); \
+ D->X.anc[ind] = tmp[0]; \
+ D->X.anc[ind + nr] = tmp[1]; \
+ D->X.anc[ind + 2*nr] = tmp[2]; \
+ D->X.anc[ind + 3*nr] = tmp[3]; \
+ }
+
+void lik_dna_node(DNAdata *D, int ie)
+/*
+This function computes the likelihoods at a node for all
+nucleotides.
+*/
+{
+ int d1, d2, anc, n, nr;
+ int i, j, k, start, end, ind, i1, i2, ncat, model;
+ double tmp[4], L1[4], L2[4], l1, l2, P1[16], P2[16], V, coef_gamma[10], u[6], I, alpha, *BF;
+
+ n = *(D->X.n);
+ nr = *(D->X.s) * (n - 2);
+ BF = D->BF;
+
+ d1 = D->PHY.edge2[ie];
+ d2 = D->PHY.edge2[ie + 1];
+ anc = D->PHY.edge1[ie];
+
+ /* change these to use them as indices */
+ d1--; d2--; anc--;
+
+ l1 = D->PHY.el[ie];
+ l2 = D->PHY.el[ie + 1];
+
+ for(k = 0; k < *(D->MOD.npart); k++) {
+ start = D->MOD.partition[k*2] - 1;
+ end = D->MOD.partition[k*2 + 1] - 1;
+
+ GET_DNA_PARAMETERS
+
+ if (k > 0) {
+ l1 *= D->MOD.xi[k - 1];
+ l2 *= D->MOD.xi[k - 1];
+ }
+
+ LOOP_THROUGH_SITES
+ }
+} /* lik_dna_node */
+
+void lik_dna_root(DNAdata *D)
+/*
+This function computes the likelihoods at the root for all
+nucleotides.
+*/
+{
+ int i, j, k, start, end, ind, ncat, model, d1, d2, d3, n, N, nr;
+ double tmp[4], L1[4], L2[4], L3[4], l1, l2, l3, P1[16], P2[16], P3[16], V, coef_gamma[10], u[6], I, alpha, *BF;
+
+ n = *(D->X.n); /* number of tips */
+ N = 2*n - 3; /* number of edges */
+ nr = *(D->X.s) * (n - 2);
+ BF = D->BF;
+
+ d1 = D->PHY.edge2[N - 3];
+ d2 = D->PHY.edge2[N - 2];
+ d3 = D->PHY.edge2[N - 1];
+
+ /* change these to use them as indices */
+ d1--; d2--; d3--;
+
+ l1 = D->PHY.el[N - 3];
+ l2 = D->PHY.el[N - 2];
+ l3 = D->PHY.el[N - 1];
+
+ for(k = 0; k < *(D->MOD.npart); k++) {
+ start = D->MOD.partition[k*2] - 1;
+ end = D->MOD.partition[k*2 + 1] - 1;
+
+ GET_DNA_PARAMETERS
+
+ if (k > 0) {
+ l1 *= D->MOD.xi[k - 1];
+ l2 *= D->MOD.xi[k - 1];
+ l3 *= D->MOD.xi[k - 1];
+ }
+
+ for(j = start; j < end; j++) {
+ getSiteLik(n, d1, j, nr, D, L1);
+ getSiteLik(n, d2, j, nr, D, L2);
+ getSiteLik(n, d3, j, nr, D, L3);
+ memset(tmp, 0, 4*sizeof(double));
+ for(i = 0; i < ncat; i++) {
+ switch(model) {
+ case 1 : PMAT_JC69(l1, coef_gamma[i], P1);
+ PMAT_JC69(l2, coef_gamma[i], P2);
+ PMAT_JC69(l3, coef_gamma[i], P3); break;
+ case 2 : PMAT_K80(l1, coef_gamma[i], u[0], P1);
+ PMAT_K80(l2, coef_gamma[i], u[0], P2);
+ PMAT_K80(l3, coef_gamma[i], u[0], P3); break;
+ case 3 : PMAT_F81(l1, coef_gamma[i], BF, P1);
+ PMAT_F81(l2, coef_gamma[i], BF, P3);
+ PMAT_F81(l3, coef_gamma[i], BF, P3); break;
+ case 4 : PMAT_F84(l1, coef_gamma[i], u[0], BF, P1);
+ PMAT_F84(l2, coef_gamma[i], u[0], BF, P2);
+ PMAT_F84(l3, coef_gamma[i], u[0], BF, P3); break;
+ case 5 : PMAT_HKY85(l1, coef_gamma[i], u[0], BF, P1);
+ PMAT_HKY85(l2, coef_gamma[i], u[0], BF, P2);
+ PMAT_HKY85(l3, coef_gamma[i], u[0], BF, P3); break;
+ case 6 : PMAT_T92(l1, coef_gamma[i], u[0], BF, P1);
+ PMAT_T92(l2, coef_gamma[i], u[0], BF, P2);
+ PMAT_T92(l3, coef_gamma[i], u[0], BF, P3); break;
+ case 7 : PMAT_TN93(l1, coef_gamma[i], u[0], u[1], BF, P1);
+ PMAT_TN93(l2, coef_gamma[i], u[0], u[1], BF, P2);
+ PMAT_TN93(l3, coef_gamma[i], u[0], u[1], BF, P3);break;
+ case 8 : PMAT_GTR(l1, coef_gamma[i], u[0], u[1], u[2], u[3], u[4], BF, P1);
+ PMAT_GTR(l2, coef_gamma[i], u[0], u[1], u[2], u[3], u[4], BF, P2);
+ PMAT_GTR(l3, coef_gamma[i], u[0], u[1], u[2], u[3], u[4], BF, P3); break;
+ }
+ tmp[0] += (L1[0]*P1[0] + L1[1]*P1[1] + L1[2]*P1[2] + L1[3]*P1[3]) *
+ (L2[0]*P2[0] + L2[1]*P2[1] + L2[2]*P2[2] + L2[3]*P2[3]) *
+ (L3[0]*P3[0] + L3[1]*P3[1] + L3[2]*P3[2] + L3[3]*P3[3]);
+ tmp[1] += (L1[0]*P1[4] + L1[1]*P1[5] + L1[2]*P1[6] + L1[3]*P1[7]) *
+ (L2[0]*P2[4] + L2[1]*P2[5] + L2[2]*P2[6] + L2[3]*P2[7]) *
+ (L3[0]*P3[4] + L3[1]*P3[5] + L3[2]*P3[6] + L3[3]*P3[7]);
+ tmp[2] += (L1[0]*P1[8] + L1[1]*P1[9] + L1[2]*P1[10] + L1[3]*P1[11]) *
+ (L2[0]*P2[8] + L2[1]*P2[9] + L2[2]*P2[10] + L2[3]*P2[11]) *
+ (L3[0]*P3[8] + L3[1]*P3[9] + L3[2]*P3[10] + L3[3]*P3[11]);
+ tmp[3] += (L1[0]*P1[12] + L1[1]*P1[13] + L1[2]*P1[14] + L1[3]*P1[15]) *
+ (L2[0]*P2[12] + L2[1]*P2[13] + L2[2]*P2[14] + L2[3]*P2[15]) *
+ (L3[0]*P3[12] + L3[1]*P3[13] + L3[2]*P3[14] + L3[3]*P3[15]);
+ }
+ if (ncat > 1) {
+ tmp[0] /= ncat;
+ tmp[1] /= ncat;
+ tmp[2] /= ncat;
+ tmp[3] /= ncat;
+ }
+ if (D->MOD.ninvar) {
+ V = 1. - I;
+ tmp[0] = V*tmp[0] + I*L1[0]*L2[0]*L3[0];
+ tmp[1] = V*tmp[1] + I*L1[1]*L2[1]*L3[1];
+ tmp[2] = V*tmp[2] + I*L1[2]*L2[2]*L3[2];
+ tmp[3] = V*tmp[3] + I*L1[3]*L2[3]*L3[3];
+ }
+ ind = j*(n - 2);
+ D->X.anc[ind] = tmp[0];
+ D->X.anc[ind + nr] = tmp[1];
+ D->X.anc[ind + 2*nr] = tmp[2];
+ D->X.anc[ind + 3*nr] = tmp[3];
+ }
+ }
+} /* lik_dna_root */
+
+void lik_dna_tree(DNAdata *D, double *loglik)
+{
+ int i, j, n, nnode, nsite, nr;
+ double tmp;
+
+ n = *(D->X.n);
+ nnode = n - 2;
+ nsite = *(D->X.s);
+ nr = nsite*nnode;
+
+ /* initialize before looping through the tree */
+ memset(D->X.anc, 1., nr*4*sizeof(double));
+
+ /* loop through the tree
+ We don't do the root node here, so i goes between 0 and 2n - 6 */
+ for(i = 0; i < 2*n - 6; i += 2)
+ lik_dna_node(D, i);
+
+ /* We now do the root */
+ lik_dna_root(D);
+ *loglik = 0.;
+ for(j = 0; j < nsite; j++) {
+ tmp = 0.;
+ for (i = 0; i < 4; i++)
+ tmp += D->BF[i] * D->X.anc[j + i*nr];
+ *loglik += D->X.w[j]*log(tmp);
+ }
+} /* lik_dna_tree */
+
+double fcn_mlphylo_invar(double I, info *INFO)
+{
+ double loglik;
+
+ INFO->D->MOD.invar[INFO->i] = I;
+ lik_dna_tree(INFO->D, &loglik);
+
+ return -loglik;
+}
+
+void mlphylo_invar(int N, DNAdata *D, double *loglik)
+/*
+optimize proportion of invariants
+*/
+{
+ int i;
+ info INFO, *infptr;
+ double I;
+
+ infptr = &INFO;
+ INFO.D = D;
+
+ for(i = 0; i < N; i++) {
+ infptr->i = i;
+ I = Brent_fmin(0.0, 1.0,
+ (double (*)(double, void*)) fcn_mlphylo_invar,
+ infptr, 1.e-9);
+ D->MOD.invar[i] = I;
+ }
+}
+
+double fcn_mlphylo_gamma(double a, info *INFO)
+{
+ double loglik;
+
+ INFO->D->MOD.alpha[INFO->i] = a;
+ lik_dna_tree(INFO->D, &loglik);
+
+ return -loglik;
+}
+
+void mlphylo_gamma(int N, DNAdata *D, double *loglik)
+/*
+optimize gamma (ISV) parameters
+*/
+{
+ int i;
+ info INFO, *infptr;
+ double a;
+
+ infptr = &INFO;
+ INFO.D = D;
+
+ for(i = 0; i < N; i++) {
+ infptr->i = i;
+ a = Brent_fmin(0.0, 1.e4,
+ (double (*)(double, void*)) fcn_mlphylo_gamma,
+ infptr, 1.e-6);
+ D->MOD.alpha[i] = a;
+ }
+}
+
+double fcn_mlphylo_para(double p, info *INFO)
+{
+ double loglik;
+
+ INFO->D->MOD.para[INFO->i] = p;
+ lik_dna_tree(INFO->D, &loglik);
+
+ return -loglik;
+}
+
+void mlphylo_para(int N, DNAdata *D, double *loglik)
+/*
+optimize the contrast parameter(s) xi
+*/
+{
+ int i;
+ info INFO, *infptr;
+ double p;
+
+ infptr = &INFO;
+ INFO.D = D;
+
+ for(i = 0; i < N; i++) {
+ infptr->i = i;
+ p = Brent_fmin(0, 1.e3,
+ (double (*)(double, void*)) fcn_mlphylo_para,
+ infptr, 1.e-6);
+ D->MOD.para[i] = p;
+ }
+}
+
+double fcn_mlphylo_xi(double XI, info *INFO)
+{
+ double loglik;
+
+ INFO->D->MOD.xi[INFO->i] = XI;
+ lik_dna_tree(INFO->D, &loglik);
+
+ return -loglik;
+}
+
+void mlphylo_xi(int N, DNAdata *D, double *loglik)
+/*
+optimize the contrast parameter(s) xi
+*/
+{
+ int i;
+ info INFO, *infptr;
+ double XI;
+
+ infptr = &INFO;
+ INFO.D = D;
+
+ /* In the following, the range of the search algo was changed from */
+ /* 0-1000 to 0-100 to avoid infinite looping. (2006-04-15) */
+ /* This was changed again to 0-20. (2006-07-17) */
+
+ for(i = 0; i < N; i++) {
+ infptr->i = i;
+ XI = Brent_fmin(0.0, 2.e1,
+ (double (*)(double, void*)) fcn_mlphylo_xi,
+ infptr, 1.e-4);
+ D->MOD.xi[i] = XI;
+ }
+}
+
+double fcn_mlphylo_edgelength(double l, info *INFO)
+{
+ double loglik;
+
+ INFO->D->PHY.el[INFO->i] = l;
+ lik_dna_tree(INFO->D, &loglik);
+
+ return -loglik;
+}
+
+void mlphylo_edgelength(int N, DNAdata *D, double *loglik)
+/*
+optimize branch lengths
+*/
+{
+ int i;
+ info INFO, *infptr;
+ double l;
+
+ infptr = &INFO;
+ INFO.D = D;
+
+ for(i = 0; i < N; i++) {
+ infptr->i = i;
+ l = Brent_fmin(0.0, 0.1,
+ (double (*)(double, void*)) fcn_mlphylo_edgelength,
+ infptr, 1.e-6);
+ D->PHY.el[i] = l;
+ }
+}
+
+void mlphylo_DNAmodel(int *n, int *s, unsigned char *SEQ, double *ANC,
+ double *w, int *edge1, int *edge2,
+ double *edge_length, int *npart, int *partition,
+ int *model, double *xi, double *para, int *npara,
+ double *alpha, int *nalpha, int *ncat,
+ double *invar, int *ninvar, double *BF,
+ int *search_tree, int *fixed, double *loglik)
+/*
+This function iterates to find the MLEs of the substitution
+paramaters and of the branch lengths for a given tree.
+*/
+{
+ DNAdata *D, data;
+
+ D = &data;
+
+ D->X.n = n;
+ D->X.s = s;
+ D->X.w = w;
+ D->X.seq = SEQ;
+ D->X.anc = ANC;
+
+ D->PHY.edge1 = edge1;
+ D->PHY.edge2 = edge2;
+ D->PHY.el = edge_length;
+
+ D->MOD.npart = npart;
+ D->MOD.partition = partition;
+ D->MOD.model = model;
+ D->MOD.xi = xi;
+ D->MOD.para = para;
+ D->MOD.npara = npara;
+ D->MOD.alpha = alpha;
+ D->MOD.nalpha = nalpha;
+ D->MOD.ncat = ncat;
+ D->MOD.invar = invar;
+ D->MOD.ninvar = ninvar;
+
+ D->BF = BF;
+
+ lik_dna_tree(D, loglik);
+ if (! *fixed) {
+ if (*npart > 1) mlphylo_xi(*npart - 1, D, loglik);
+ if (*npara) mlphylo_para(*npara, D, loglik);
+ if (*nalpha) mlphylo_gamma(*nalpha, D, loglik);
+ if (*ninvar) mlphylo_invar(*ninvar, D, loglik);
+ }
+ lik_dna_tree(D, loglik);
+} /* mlphylo_DNAmodel */
+/*
+void jc69(double *P, double *t, double *u)
+{
+ PMAT_JC69(*t, *u, P);
+}
+
+void k80(double *P, double *t, double *u)
+{
+ PMAT_K80(*t, u[0], u[1], P);
+}
+*/
--- /dev/null
+/*#include <stdio.h>
+#include <stdlib.h>
+#include <math.h>
+#include <string.h>
+#include "graph.h"
+#include "newick.h"
+#include "main.h"
+*/
+#include "me.h"
+
+int nodeCount;
+int edgeCount;
+
+int whiteSpace(char c)
+{
+ if ((' ' == c) || ('\t' == c) || ('\n' == c))
+ return(1);
+ else return(0);
+}
+
+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);
+}
+
+/*decodeNewickSubtree is used to turn a string of the form
+ "(v1:d1,v2:d2,(subtree) v3:d3....vk:dk) subroot:d," into a subtree
+ rooted at subrooted, with corresponding subtrees and leaves at v1
+ through vk. It is called recursively on subtrees*/
+
+node *decodeNewickSubtree(char *treeString, tree *T, int *uCount)
+{
+ node *thisNode;
+ node *centerNode;
+ double thisWeight;
+ edge *thisEdge;
+// char label[MAX_LABEL_LENGTH];
+ char stringWeight[MAX_LABEL_LENGTH];
+ int state;
+ int i = 0;
+ int j;
+ int left,right;
+ int parcount;
+// snprintf(label,14,"Default_Label\0");
+ left = right = 0;
+ parcount = 0;
+ state = ReadOpenParenthesis;
+ if('(' == treeString[0])
+ parcount++;
+ //centerNode = makeNode(label,NULL,nodeCount++);
+ centerNode = makeNode("",NULL,nodeCount++);
+ T->size++;
+ while(parcount > 0)
+ {
+ while(whiteSpace(treeString[i]))
+ i++;
+ switch(state)
+ {
+ case(ReadOpenParenthesis):
+ if('(' != treeString[0])
+ {
+ Rprintf("Error reading subtree.\n");
+ exit(0);
+ }
+ i++;
+ state = ReadSubTree;
+ break;
+ case(ReadSubTree):
+ if('(' == treeString[i]) /*if treeString[i] is a left parenthesis,
+ we scan down the string until we find its partner.
+ the relative number of '('s vs. ')'s is counted
+ by the variable parcount*/
+ {
+ left = i++;
+ parcount++;
+ while(parcount > 1)
+ {
+ while (('(' != treeString[i]) && (')' != treeString[i]))
+ i++; /*skip over characters which are not parentheses*/
+ if('(' == treeString[i])
+ parcount++;
+ else if (')' == treeString[i])
+ parcount--;
+ i++;
+ } /*end while */
+ right = i; /*at this point, the subtree string goes from
+ treeString[left] to treeString[right - 1]*/
+ thisNode = decodeNewickSubtree(treeString + left,T,uCount); /*note that this
+ step will put
+ thisNode in T*/
+ i = right; /*having created the node for the subtree, we move
+ to assigning the label for the new node.
+ treeString[right] will be the start of this label */
+ } /* end if ('(' == treeString[i]) condition */
+ else
+ {
+ //thisNode = makeNode(label,NULL,nodeCount++);
+ thisNode = makeNode("",NULL,nodeCount++);
+ T->size++;
+ }
+ state = ReadLabel;
+ break;
+ case(ReadLabel):
+ left = i; /*recall "left" is the left marker for the substring, "right" the right*/
+ if (':' == treeString[i]) /*this means an internal node?*/
+ {
+ //sprintf(thisNode->label,"I%d",(*uCount)++);
+ //snprintf(thisNode->label,MAX_LABEL_LENGTH,"I%d",(*uCount)++);
+ (*uCount)++;
+ right = i;
+ }
+ else
+ {
+ while((':' != treeString[i]) && (',' != treeString[i]) && (')' != treeString[i]))
+ i++;
+ right = i;
+ j = 0;
+ for(i = left; i < right;i++)
+ if(!(whiteSpace(treeString[i])))
+ thisNode->label[j++] = treeString[i];
+ thisNode->label[j] = '\0';
+ }
+ if(':' == treeString[right])
+ state = ReadWeight;
+ else
+ {
+ state = AddEdge;
+ thisWeight = 0.0;
+ }
+ i = right + 1;
+ break;
+ case(ReadWeight):
+ left = i;
+ while
+ ((',' != treeString[i]) && (')' != treeString[i]))
+ i++;
+ right = i;
+ j = 0;
+ for(i = left; i < right; i++)
+ stringWeight[j++] = treeString[i];
+ stringWeight[j] = '\0';
+ thisWeight = atof(stringWeight);
+ state=AddEdge;
+ break;
+ case(AddEdge):
+ //thisEdge = makeEdge(label,centerNode,thisNode,thisWeight);
+ thisEdge = makeEdge("",centerNode,thisNode,thisWeight);
+ thisNode->parentEdge = thisEdge;
+ if (NULL == centerNode->leftEdge)
+ centerNode->leftEdge = thisEdge;
+ else if (NULL == centerNode->rightEdge)
+ centerNode->rightEdge = thisEdge;
+ else if (NULL == centerNode->middleEdge)
+ centerNode->middleEdge = thisEdge;
+ else
+ {
+ Rprintf("Error: node %s has too many (>3) children.\n",centerNode->label);
+ exit(0);
+ }
+ //sprintf(thisEdge->label,"E%d",edgeCount++);
+ //snprintf(thisEdge->label,MAX_LABEL_LENGTH,"E%d",edgeCount++);
+ edgeCount++;
+ i = right + 1;
+ if (',' == treeString[right])
+ state = ReadSubTree;
+ else
+ parcount--;
+ break;
+ }
+ }
+ return(centerNode);
+}
+
+tree *readNewickString (char *str, int numLeaves)
+{
+ tree *T;
+ node *centerNode;
+ int i = 0;
+ int j = 0;
+ int inputLength;
+ int uCount = 0;
+ int parCount = 0;
+ char rootLabel[MAX_LABEL_LENGTH];
+ nodeCount = edgeCount = 0;
+
+ T = newTree();
+
+ if ('(' != str[0])
+ {
+ Rprintf("Error reading generated tree - does not start with '('.\n");
+ exit(0);
+ }
+ inputLength = strlen (str)+1;
+ for(i = 0; i < inputLength; i++)
+ {
+ if ('(' == str[i])
+ parCount++;
+ else if (')' == str[i])
+ parCount--;
+ if (parCount > 0)
+ ;
+ else if (0 == parCount)
+ {
+ i++;
+/* if(';' == str[i])
+ sprintf(rootLabel,"URoot");
+ else
+ {*/
+ while(';' != str[i])
+ if (!(whiteSpace (str[i++])))
+ rootLabel[j++] = str[i-1]; /*be careful here */
+ rootLabel[j] = '\0';
+// }
+ i = inputLength;
+ }
+ else if (parCount < 0)
+ {
+ Rprintf("Error reading generated tree. Too many right parentheses.\n");
+ exit(0);
+ }
+ }
+ centerNode = decodeNewickSubtree (str, T, &uCount);
+ snprintf (centerNode->label, MAX_LABEL_LENGTH, rootLabel);
+ T->root = centerNode;
+ return (T);
+}
+
+tree *loadNewickTree(FILE *ifile, int numLeaves)
+{
+// char label[] = "EmptyEdge";
+ tree *T;
+ node *centerNode;
+ int i = 0;
+ int j = 0;
+ int inputLength;
+ int uCount = 0;
+ int parCount = 0;
+ char c;
+ int Comment;
+ char *nextString;
+ char rootLabel[MAX_LABEL_LENGTH];
+ nodeCount = edgeCount = 0;
+ T = newTree();
+ nextString = (char *) malloc(numLeaves*INPUT_SIZE*sizeof(char));
+ if (NULL == nextString)
+ nextString = (char *) malloc(MAX_INPUT_SIZE*sizeof(char));
+ Comment = 0;
+ while(1 == fscanf(ifile,"%c",&c))
+ {
+ if('[' == c)
+ Comment = 1;
+ else if (']' == c)
+ Comment = 0;
+ else if (!(Comment))
+ {
+ if(whiteSpace(c))
+ {
+ if (i > 0)
+ nextString[i++] = ' ';
+ }
+ else /*note that this else goes with if(whiteSpace(c))*/
+ nextString[i++] = c;
+ if (';' == c)
+ break;
+ }
+ }
+ if ('(' != nextString[0])
+ {
+ fprintf(stderr,"Error reading input file - does not start with '('.\n");
+ exit(EXIT_FAILURE);
+ }
+ inputLength = i;
+ for(i = 0; i < inputLength;i++)
+ {
+ if ('(' == nextString[i])
+ parCount++;
+ else if (')' == nextString[i])
+ parCount--;
+ if (parCount > 0)
+ ;
+ else if (0 == parCount)
+ {
+ i++;
+/* if(';' == nextString[i])
+ sprintf(rootLabel,"URoot");
+ else
+ {*/
+ while(';' != nextString[i])
+ if(!(whiteSpace(nextString[i++])))
+ rootLabel[j++] = nextString[i-1]; /*be careful here */
+ rootLabel[j] = '\0';
+// }
+ i = inputLength;
+ }
+ else if (parCount < 0)
+ {
+ fprintf(stderr,"Error reading tree input file. Too many right parentheses.\n");
+ exit(EXIT_FAILURE);
+ }
+ }
+ centerNode = decodeNewickSubtree(nextString,T,&uCount);
+ snprintf(centerNode->label, MAX_LABEL_LENGTH, rootLabel);
+ T->root = centerNode;
+ free(nextString);
+ return(T);
+}
+
+double GetSubTreeLength (tree *T, edge *e)
+{
+ double ret = 0;
+
+ if ( (NULL != e) && (! leaf(e->head) )) {
+ ret += GetSubTreeLength (T, e->head->leftEdge);
+ ret += GetSubTreeLength (T, e->head->rightEdge);
+ }
+ ret += e->distance;
+ return ret;
+}
+
+void NewickPrintSubtree(tree *T, edge *e, char *str)
+{
+ char *tmp;
+ if (NULL == e)
+ {
+ Rprintf("Error with Newick Printing routine.\n");
+ exit(0);
+ }
+ if(!(leaf(e->head)))
+ {
+ if (strlen (str) < MAX_INPUT_SIZE -2)
+ strncat (str, "(", 1);
+ NewickPrintSubtree(T,e->head->leftEdge,str);
+ if (strlen (str) < MAX_INPUT_SIZE -2)
+ strncat (str, ",", 1);
+ NewickPrintSubtree(T,e->head->rightEdge,str);
+ if (strlen (str) < MAX_INPUT_SIZE -2)
+ strncat (str, ")", 1);
+ }
+ if (strlen (str) < MAX_INPUT_SIZE - strlen (e->head->label) -1)
+ strncat (str, e->head->label, strlen (e->head->label));
+
+ if (strlen (str) < MAX_INPUT_SIZE - 2)
+ strncat (str, ":", 1);
+
+ tmp = (char *)R_alloc(INPUT_SIZE, sizeof(char));
+ /* added by EP */
+ if (strlen(tmp))
+ strncpy(tmp, "", strlen(tmp));
+ /* end */
+ snprintf (tmp, INPUT_SIZE, "%lf", e->distance);
+ if (strlen (str) < MAX_INPUT_SIZE - strlen (tmp) -1)
+ strncat (str, tmp, strlen (tmp));
+
+ /* free (tmp); */
+ return;
+}
+
+double GetBinaryTreeLength (tree *T)
+{
+ double ret = 0;
+ edge *e, *f;
+ node *rootchild;
+ e = T->root->leftEdge;
+ rootchild = e->head;
+
+ f = rootchild->leftEdge;
+ if (NULL != f)
+ ret += GetSubTreeLength (T, f);
+ f = rootchild->rightEdge;
+ if (NULL != f)
+ ret += GetSubTreeLength (T, f);
+ ret += e->distance;
+ return ret;
+}
+
+void NewickPrintBinaryTree(tree *T, char *str)
+{
+ edge *e, *f;
+ node *rootchild;
+ char *tmp;
+ e = T->root->leftEdge;
+ rootchild = e->head;
+ if (strlen (str) < MAX_INPUT_SIZE -2)
+ strncat (str, "(", 1);
+ f = rootchild->leftEdge;
+ if (NULL != f)
+ {
+ NewickPrintSubtree(T,f,str);
+ if (strlen (str) < MAX_INPUT_SIZE -2)
+ strncat (str, ",", 1);
+ }
+ f = rootchild->rightEdge;
+ if (NULL != f)
+ {
+ NewickPrintSubtree(T,f,str);
+ if (strlen (str) < MAX_INPUT_SIZE -2)
+ strncat (str, ",", 1);
+ }
+ if (strlen (str) < MAX_INPUT_SIZE - strlen (T->root->label) -1)
+ strncat (str, T->root->label, strlen (T->root->label));
+
+ if (strlen (str) < MAX_INPUT_SIZE - 2)
+ strncat (str, ":", 1);
+
+ tmp = (char *)R_alloc(INPUT_SIZE, sizeof(char));
+ /* added by EP */
+ if (strlen(tmp))
+ strncpy(tmp, "", strlen(tmp));
+ /* end */
+ snprintf (tmp, INPUT_SIZE, "%lf", e->distance);
+ if (strlen (str) < MAX_INPUT_SIZE - strlen (tmp) -1)
+ strncat (str, tmp, strlen (tmp));
+
+ if (strlen (str) < MAX_INPUT_SIZE - 2)
+ strncat (str, ")", 1);
+
+ if (NULL != rootchild->label)
+ if (strlen (str) < MAX_INPUT_SIZE - strlen (rootchild->label) -1)
+ strncat (str, T->root->label, strlen (rootchild->label));
+
+ if (strlen (str) < MAX_INPUT_SIZE - 3)
+ strncat (str, ";\n", 2);
+
+ /* free (tmp); */
+ return;
+}
+
+double GetTrinaryTreeLength (tree *T)
+{
+ double ret = 0;
+ edge *f;
+ f = T->root->leftEdge;
+ if (NULL != f)
+ ret += GetSubTreeLength (T, f);
+ f = T->root->rightEdge;
+ if (NULL != f)
+ ret += GetSubTreeLength (T, f);
+ f = T->root->middleEdge;
+ if (NULL != f)
+ ret += GetSubTreeLength (T, f);
+
+ return ret;
+}
+
+void NewickPrintTrinaryTree(tree *T, char *str)
+{
+ edge *f;
+ f = T->root->leftEdge;
+ if (strlen (str) < MAX_INPUT_SIZE -2)
+ strncat (str, "(", 1);
+ if (NULL != f)
+ {
+ NewickPrintSubtree(T,f,str);
+ if (strlen (str) < MAX_INPUT_SIZE -2)
+ strncat (str, ",", 1);
+ }
+ f = T->root->rightEdge;
+ if (NULL != f)
+ {
+ NewickPrintSubtree(T,f,str);
+ if (strlen (str) < MAX_INPUT_SIZE -2)
+ strncat (str, ",", 1);
+ }
+ f = T->root->middleEdge;
+ if (NULL != f)
+ {
+ NewickPrintSubtree(T,f,str);
+ if (strlen (str) < MAX_INPUT_SIZE -2)
+ strncat (str, ")", 1);
+ }
+ if (NULL != T->root->label)
+ if (strlen (str) < MAX_INPUT_SIZE - strlen (T->root->label) -1)
+ strncat (str, T->root->label, strlen (T->root->label));
+ if (strlen (str) < MAX_INPUT_SIZE - 3)
+ strncat (str, ";\n", 2);
+ return;
+}
+
+void NewickPrintTreeStr(tree *T, char *str)
+{
+ if (leaf(T->root))
+ NewickPrintBinaryTree(T,str);
+ else
+ NewickPrintTrinaryTree(T,str);
+}
+
+double GetTreeLength (tree *T)
+{
+ double ret = 0;
+ if (leaf(T->root))
+ ret = GetBinaryTreeLength (T);
+ else
+ ret = GetTrinaryTreeLength (T);
+ return ret;
+}
+/*
+void NewickPrintTree(tree *T, FILE *ofile)
+{
+ if (leaf(T->root))
+ NewickPrintBinaryTree(T,ofile);
+ else
+ NewickPrintTrinaryTree(T,ofile);
+}
+*/
+//edge *depthFirstTraverse(tree *T, edge *e);
+
--- /dev/null
+/* nj.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>
+
+#define DINDEX(i, j) n*(i - 1) - i*(i - 1)/2 + j - i - 1
+
+int give_index(int i, int j, int n)
+{
+ if (i > j) return(DINDEX(j, i));
+ else return(DINDEX(i, j));
+}
+
+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 between 1, and n and j != i */
+{
+ double sum;
+ int j;
+
+ sum = 0;
+
+ if (i != 1) {
+ for (j = 1; j < i; j++)
+ sum += D[DINDEX(j, i)];
+ }
+
+ if (i != n) {
+ for (j = i + 1; j <= n; j++)
+ sum += D[DINDEX(i, j)];
+ }
+
+ return(sum);
+}
+
+#define GET_I_AND_J \
+/* Find the 'R' indices of the two corresponding OTUs */ \
+/* The indices of the first element of the pair in the \
+ distance matrix are n-1 times 1, n-2 times 2, n-3 times 3, \
+ ..., once n-1. Given this, the algorithm below is quite \
+ straightforward.*/ \
+ i = 0; \
+ for (OTU1 = 1; OTU1 < n; OTU1++) { \
+ i += n - OTU1; \
+ if (i >= smallest + 1) break; \
+ } \
+ /* Finding the second OTU is easier! */ \
+ OTU2 = smallest + 1 + OTU1 - n*(OTU1 - 1) + OTU1*(OTU1 - 1)/2;
+
+#define SET_CLADE \
+/* give the node and tip numbers to edge */ \
+ edge2[k] = otu_label[OTU1 - 1]; \
+ edge2[k + 1] = otu_label[OTU2 - 1]; \
+ edge1[k] = edge1[k + 1] = cur_nod;
+
+void nj(double *D, int *N, int *edge1, int *edge2, double *edge_length)
+{
+ double SUMD, Sdist, *S, Ndist, *new_dist, A, B, *DI, d_i, 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;
+ DI = &d_i;
+
+ n = *N;
+ cur_nod = 2*n - 2;
+
+ S = (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, sizeof(int));
+ DI = (double*)R_alloc(n - 2, sizeof(double));
+
+ for (i = 0; i < n; i++) otu_label[i] = i + 1;
+ k = 0;
+
+ /* First, look if there are distances equal to 0. */
+ /* Since there may be multichotomies, we loop
+ through the OTUs instead of the distances. */
+
+ OTU1 = 1;
+ while (OTU1 < n) {
+ OTU2 = OTU1 + 1;
+ while (OTU2 <= n) {
+ if (D[DINDEX(OTU1, OTU2)] == 0) {
+ SET_CLADE
+ edge_length[k] = edge_length[k + 1] = 0.;
+ k = k + 2;
+
+ /* update */
+ /* We remove the second tip label: */
+ if (OTU2 < n) {
+ for (i = OTU2; i < n; i++)
+ otu_label[i - 1] = otu_label[i];
+ }
+
+ ij = 0;
+ for (i = 1; i < n; i++) {
+ if (i == OTU2) continue;
+ for (j = i + 1; j <= n; j++) {
+ if (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];
+
+ otu_label[OTU1 - 1] = cur_nod;
+ /* to avoid adjusting the internal branch at the end: */
+ DI[cur_nod - *N - 1] = 0;
+ cur_nod--;
+ } else OTU2++;
+ }
+ OTU1++;
+ }
+
+ while (n > 3) {
+
+ SUMD = 0;
+ for (i = 0; i < n*(n - 1)/2; i++) SUMD += D[i];
+
+ for (i = 1; i < n; i++) {
+ for (j = i + 1; j <= n; j++) {
+ /* we know that i < j, so: */
+ ij = DINDEX(i, j);
+ A = sum_dist_to_i(n, D, i) - D[ij];
+ B = sum_dist_to_i(n, D, j) - D[ij];
+ S[ij] = (A + B)/(2*n - 4) + 0.5*D[ij] + (SUMD - A - B - D[ij])/(n - 2);
+ }
+ }
+
+ /* find the 'C' index of the smallest value of S */
+ smallest = 0;
+ for (i = 1; i < n*(n - 1)/2; i++)
+ if (S[smallest] > S[i]) smallest = i;
+
+ GET_I_AND_J
+
+ SET_CLADE
+
+ /* 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 = B = ij = 0;
+ for (i = 1; i <= n; i++) {
+ if (i == OTU1 || i == OTU2) continue;
+ x = D[give_index(i, OTU1, n)]; /* distance between OTU1 and i */
+ y = D[give_index(i, OTU2, n)]; /* distance between OTU2 and i */
+ new_dist[ij] = (x + y)/2;
+ A += x;
+ B += y;
+ ij++;
+ }
+ /* compute the branch lengths */
+ A /= n - 2;
+ B /= n - 2;
+ edge_length[k] = (D[smallest] + A - B)/2;
+ edge_length[k + 1] = (D[smallest] + B - A)/2;
+ DI[cur_nod - *N - 1] = D[smallest];
+
+ /* update before the next loop */
+ if (OTU1 > OTU2) { /* make sure that OTU1 < OTU2 */
+ i = OTU1;
+ OTU1 = OTU2;
+ OTU2 = i;
+ }
+ if (OTU1 != 1)
+ for (i = OTU1 - 1; i > 0; i--) otu_label[i] = otu_label[i - 1];
+ if (OTU2 != n)
+ for (i = OTU2; i <= n; i++) otu_label[i - 1] = otu_label[i];
+ otu_label[0] = 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];
+ }
+
+ 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;
+
+ for (i = 0; i < *N*2 - 3; i++) {
+ if (edge2[i] <= *N) continue;
+ /* In case there are zero branch lengths (see above): */
+ if (DI[edge2[i] - *N - 1] == 0) continue;
+ edge_length[i] -= DI[edge2[i] - *N - 1]/2;
+ }
+}
--- /dev/null
+/*
+ * nprsfunc.c
+ *
+ * (c) 2003 Gangolf Jobb and Korbinian Strimmer
+ *
+ * Functions for nonparametric rate smoothing (NPRS)
+ * (see MJ Sanderson. 1997. MBE 14:1218-1231)
+ *
+ * This code may be distributed under the GNU GPL
+ */
+
+
+#include <stdlib.h>
+#include <string.h>
+#include <math.h>
+
+/*============================================================================*/
+
+#define EPS 1e-6
+#define LARGENUM 1e99
+
+/* original scale */
+#define MINPARAM EPS
+#define MAXPARAM 1-EPS
+#define STARTPARAM 0.5
+
+
+/* log scale */
+#define MINLPARAM log(MINPARAM)
+#define MAXLPARAM log(MAXPARAM)
+#define STARTLPARAM log(STARTPARAM)
+
+#define ARRLEN 2048
+#define LABLEN 64
+
+#define index aperates_index
+
+int tree_lowerNodes[ARRLEN];
+int tree_upperNodes[ARRLEN];
+double tree_edgeLengths[ARRLEN];
+int tree_nedges;
+char tree_tipLabels[ARRLEN][LABLEN];
+int tree_ntips;
+
+int nparams,index[ARRLEN],ancestor[ARRLEN];
+
+/*============================================================================*/
+
+void setTree(
+ int *lowerNodes,
+ int *upperNodes,
+ double *edgeLengths,
+ double *minEdgeLength,
+ int *nedges,
+ char **tipLabels,
+ int *ntips,
+ int *result
+) {
+ int i;
+
+ tree_nedges=*nedges;
+
+ for(i=0;i<tree_nedges;i++) {
+ tree_lowerNodes[i]=lowerNodes[i];
+ tree_upperNodes[i]=upperNodes[i];
+ tree_edgeLengths[i]=(edgeLengths[i]<*minEdgeLength)?*minEdgeLength:edgeLengths[i];
+ }
+
+ tree_ntips=*ntips;
+
+ for(i=0;i<tree_ntips;i++) {
+ strcpy(tree_tipLabels[i],tipLabels[i]);
+ }
+
+ nparams=0;
+ for(i=0;i<tree_nedges;i++) {
+ if(tree_lowerNodes[i]<0&&tree_upperNodes[i]<0) {index[-tree_upperNodes[i]]=nparams++;}
+ if(tree_upperNodes[i]<0) ancestor[-tree_upperNodes[i]]=tree_lowerNodes[i];
+ }
+
+ *result=0;
+}
+
+/*============================================================================*/
+
+void getNFreeParams(int *result) { *result=nparams; }
+
+/*============================================================================*/
+
+void getNEdges(int *result) { *result=tree_nedges; }
+
+/*============================================================================*/
+
+void getEdgeLengths(double *result) {
+ int i;
+
+ for(i=0;i<tree_nedges;i++) result[i]=tree_edgeLengths[i];
+
+}
+
+/*============================================================================*/
+
+double age(double *params,int node) {
+ double prod;
+
+ if(node>=0) return(0.0);
+ if(node==-1) return(1.0);
+
+ prod=0.0;
+ while(node!=-1) {prod+=params[index[-node]]; node=ancestor[-node];}
+
+ return(exp(prod));
+}
+
+
+void getDurations(double *params,double *scale,double *result) {
+ int i,low,upp;
+
+ for(i=0;i<tree_nedges;i++) {
+ low=tree_lowerNodes[i]; upp=tree_upperNodes[i];
+ if(low<0&&upp<0) result[i]=*scale*(age(params,low)-age(params,upp));
+ else result[i]=*scale*age(params,low);
+ }
+
+}
+
+/*============================================================================*/
+
+void getRates(double *params,double *scale,double *result) {
+ int i,low,upp;
+
+ for(i=0;i<tree_nedges;i++) {
+ low=tree_lowerNodes[i]; upp=tree_upperNodes[i];
+ if(low<0&&upp<0) result[i]=tree_edgeLengths[i]/(*scale*(age(params,low)-age(params,upp)));
+ else result[i]=tree_edgeLengths[i]/(*scale*age(params,low));
+ }
+
+}
+
+/*============================================================================*/
+
+
+/* note on the choice of parameters:
+ *
+ * in order to obtain a chronogram we optimize the
+ * relative heights of each internal node, i.e. to
+ * each internal node (minus the root) we assign a number
+ * between 0 and 1 (MINPARAM - MAXPARAM).
+ *
+ * To obtain the actual height of a node the relative heights
+ * of the nodes have to multiplied (in fact we work on the log-scale
+ * so we simply sum).
+ */
+
+
+/* internal objective function - parameters are on log scale */
+void nprsObjectiveFunction(
+ double *params,
+ int *expo,
+ double *result
+) {
+ int p,k,j;
+ double me,rk,rj,sum,scale=1.0,durations[ARRLEN],rates[ARRLEN];
+
+ p=*expo;
+
+ getDurations(params,&scale,durations);
+
+ for(k=0;k<tree_nedges;k++) rates[k]=tree_edgeLengths[k]/durations[k];
+
+ me=0.; for(k=0;k<tree_nedges;k++) me+=rates[k]; me/=tree_nedges;
+
+ sum=0.;
+
+ for(k=0;k<tree_nedges;k++) { rk=rates[k];
+ for(j=0;j<tree_nedges;j++) { if(j==k) continue; rj=rates[j];
+ if(tree_lowerNodes[j]==-1) sum+=pow(fabs(me-rj),p); else
+ if(tree_upperNodes[k]==tree_lowerNodes[j]) sum+=pow(fabs(rk-rj),p);
+ }
+ }
+
+ *result=sum;
+
+}
+
+
+/* check parameter bounds on log scale */
+int checkLogParams(double *params)
+{
+ int i;
+ for(i=0; i<nparams; i++)
+ {
+ if(params[i] > MAXLPARAM || params[i] < MINLPARAM) return 0; /* out of bounds */
+ }
+ return 1; /* within bounds */
+}
+
+
+
+/*
+ * public objective function
+ * - parameters are on log scale
+ * - if parameters are out of bounds function returns large value
+ */
+void objFuncLogScale(
+ double *params,
+ int *expo,
+ double *result
+)
+{
+
+ if( checkLogParams(params) == 0 ) /* out of bounds */
+ {
+ *result = LARGENUM;
+ }
+ else
+ {
+ nprsObjectiveFunction(params, expo, result);
+ }
+}
+
+
+/*============================================================================*/
+
+
+double ageAlongEdges(int node) { /* tree must be clock-like */
+ int i;
+
+ if(node>=0) return(0.);
+
+ for(i=0;i<tree_nedges;i++)
+ if(tree_lowerNodes[i]==node)
+ return(tree_edgeLengths[i]+ageAlongEdges(tree_upperNodes[i]));
+
+ return(0.);
+}
+
+/* compute set of parameters for a given clock-like tree */
+void getExternalParams(double *result) {
+ int i;
+
+ for(i=0;i<tree_nedges;i++) {
+ if(tree_lowerNodes[i]<0&&tree_upperNodes[i]<0)
+ result[index[-tree_upperNodes[i]]]
+ =-log(ageAlongEdges(tree_lowerNodes[i])/ageAlongEdges(tree_upperNodes[i]));
+ }
+
+}
+
+/*============================================================================*/
--- /dev/null
+/* 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 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;
+ }
+ }
+}
--- /dev/null
+/* plot_phylo.c (2006-10-13) */
+
+/* Copyright 2004-2006 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 *edge1, int *edge2,
+ int *nedge, double *xx)
+{
+ 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) */
+ for (i = 0; i < *nedge; i++)
+ xx[edge1[i] - 1] = xx[edge1[i] - 1] + xx[edge2[i] - 1];
+}
+
+void node_height(int *ntip, int *nnode, int *edge1, int *edge2,
+ int *nedge, double *yy)
+{
+ int i, k, n;
+ double S;
+
+ /* The coordinates of the tips have been already computed */
+
+ k = 1;
+ S = 0;
+ n = 0;
+ for (i = 0; i < *nedge; i++) {
+ S += yy[edge2[i] - 1];
+ n += 1;
+ if (edge1[i + 1] != edge1[i]) {
+ yy[edge1[i] - 1] = S/n;
+ S = 0;
+ n = 0;
+ }
+ }
+}
+
+void node_height_clado(int *ntip, int *nnode, int *edge1, int *edge2,
+ int *nedge, double *xx, double *yy)
+{
+ int i, k, n;
+ double S;
+
+ node_depth(ntip, nnode, edge1, edge2, nedge, xx);
+
+ /* The coordinates of the tips have been already computed */
+
+ k = 1;
+ S = 0;
+ n = 0;
+ for (i = 0; i < *nedge; i++) {
+ S += yy[edge2[i] - 1] * xx[edge2[i] - 1];
+ n += xx[edge2[i] - 1];
+ if (edge1[i + 1] != edge1[i]) {
+ yy[edge1[i] - 1] = S/n;
+ S = 0;
+ n = 0;
+ }
+ }
+}
--- /dev/null
+/* reorder_phylo.c 2006-10-11 */
+
+/* Copyright 2006 Emmanuel Paradis */
+
+/* This file is part of the R-package `ape'. */
+/* See the file ../COPYING for licensing issues. */
+
+#include <R.h>
+#include <R_ext/Applic.h>
+
+void neworder_cladewise(int *n, int *edge1, int *edge2,
+ int *N, int *neworder)
+/* n: nb of tips, N: nb of edges */
+{
+ int i, j, k, node, *done, dn, *node_back, eb;
+ done = &dn;
+ node_back = &eb;
+
+ /* done: indicates whether an edge has been collected
+ node_back: the series of node from the root to `node'
+ node: the current node */
+
+ done = (int*)R_alloc(*N, sizeof(int));
+ node_back = (int*)R_alloc(*N + 2 - *n, sizeof(int));
+ for (i = 0; i < *N; i++) done[i] = 0;
+
+ j = 0;
+ k = 0;
+ node = *n + 1;
+ while (j < *N) {
+ for (i = 0; i < *N; i++) {
+ if (done[i] || edge1[i] != node) continue;
+ neworder[j] = i + 1;
+ j++;
+ done[i] = 1;
+ if (edge2[i] > *n) {
+ node_back[k] = node;
+ k++;
+ node = edge2[i];
+ /* if found a new node, reset the loop */
+ i = -1;
+ }
+ }
+ /* if arrived at the end of `edge', go down one node */
+ k--;
+ node = node_back[k];
+ }
+}
+
+#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 *Ndegr, degree, *ready, rdy, i, j, node, nextI, n;
+ Ndegr = °ree;
+ ready = &rdy;
+
+ ready = (int*)R_alloc(*nedge, sizeof(int));
+
+ /* use `nextI' temporarily because need an address for R_tabulate */
+ nextI = *ntip + *nnode;
+ Ndegr = (int*)R_alloc(nextI, sizeof(int));
+ for (i = 0; i < nextI; i++) Ndegr[i] = 0;
+ R_tabulate(edge1, nedge, &nextI, Ndegr);
+
+ /* `ready' indicates whether an edge is ready to be */
+ /* collected; only the terminal edges are initially ready */
+ for (i = 0; i < *nedge; i++)
+ if (edge2[i] <= *ntip) ready[i] = 1;
+ else ready[i] = 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++;
+ }
+}
--- /dev/null
+/*
+ * treefunc.c
+ *
+ * (c) 2003 Gangolf Jobb (http://www.treefinder.de)
+ *
+ * Various data structures and methods for manipulating
+ * and traversing trees
+ * (e.g., to classify genes)
+ *
+ * This code may be distributed under the GNU GPL
+ */
+
+#include <stdlib.h>
+#include <string.h>
+#include <math.h>
+
+/*============================================================================*/
+
+#define LABLEN 128
+
+typedef struct tree {
+ char label[LABLEN];
+ struct tree *branches,*next;
+ double length;
+ int mark;
+} Tree;
+
+/*....*/
+
+Tree *NewTree(void) {
+ Tree *b;
+
+ b=malloc(sizeof(Tree)); if(!b) return(NULL);
+
+ *b->label='\0'; b->branches=NULL; b->next=NULL; b->length=0.0;
+
+ return(b);
+}
+
+/*....*/
+
+void FreeTree(Tree *t) {
+ Tree *b;
+
+ while(t->branches) {b=t->branches; t->branches=b->next; FreeTree(b);}
+
+ free(t);
+
+}
+
+/*============================================================================*/
+
+static Tree *current=NULL;
+
+static int tip_index;
+static int edge_index;
+static int node_index;
+
+enum {OK=0,ERROR}; /* one may invent more descriptive error codes */
+static int error=OK;
+
+/*============================================================================*/
+
+Tree *buildTreeFromPhylo_(
+ int node,
+ int *lowerNodes,
+ int *upperNodes,
+ double *edgeLengths,
+ int nedges,
+ char **tipLabels,
+ int ntips
+) {
+ Tree *t,*b,**bb;
+ int i,j,n;
+
+ t=NewTree();
+
+ bb=&t->branches; n=0;
+ for(i=0;i<nedges;i++) { if(lowerNodes[i]!=node) continue;
+ j=upperNodes[i]; if(j==0) {error=ERROR; goto err;}
+ if(j>0) { if(j>ntips) {error=ERROR; goto err;}
+ b=NewTree(); strcpy(b->label,tipLabels[j-1]);
+ } else { if(-j>nedges) {error=ERROR; goto err;}
+ b=
+ buildTreeFromPhylo_(j,lowerNodes,upperNodes,edgeLengths,nedges,tipLabels,ntips);
+ }
+ b->length=edgeLengths[i];
+ *bb=b; bb=&b->next; n++;
+ } if(n<2) {error=ERROR; goto err;}
+ err:
+ *bb=NULL;
+
+ return(t);
+}
+
+/*....*/
+
+void buildTreeFromPhylo(
+ int *lowerNodes,
+ int *upperNodes,
+ double *edgeLengths,
+ int *nedges,
+ char **tipLabels,
+ int *ntips,
+ int *result
+) {
+
+ error=OK;
+
+ if(current) {FreeTree(current); current=NULL;}
+
+ if(*nedges<2||*ntips<2) {error=ERROR; *result=error; return;}
+
+ current=buildTreeFromPhylo_(-1,lowerNodes,upperNodes,edgeLengths,*nedges,tipLabels,*ntips);
+
+ if(error&¤t) {FreeTree(current); current=NULL;}
+
+ *result=error;
+
+}
+
+/*============================================================================*/
+
+void destroyTree(int *result) {
+
+ error=OK;
+
+ if(current) {FreeTree(current); current=NULL;}
+
+ *result=error;
+
+}
+
+/*============================================================================*/
+
+void getError(int *result) {
+
+ *result=error;
+
+ error=OK;
+
+}
+
+/*============================================================================*/
+
+int nTips_(Tree *t) {
+ Tree *b;
+ int n;
+
+ if(!t->branches) return(1);
+
+ n=0; for(b=t->branches;b;b=b->next) n+=nTips_(b);
+
+ return(n);
+}
+
+/*....*/
+
+void nTips(int *result) {
+
+ error=OK;
+
+ if(!current) {error=ERROR; *result=0; return;}
+
+ *result=nTips_(current);
+
+}
+
+/*============================================================================*/
+
+int nNodes_(Tree *t) {
+ Tree *b;
+ int n;
+
+ if(!t->branches) return(1);
+
+ n=1; for(b=t->branches;b;b=b->next) n+=nNodes_(b);
+
+ return(n);
+}
+
+/*....*/
+
+void nNodes(int *result) {
+
+ error=OK;
+
+ if(!current) {error=ERROR; *result=0; return;}
+
+ *result=nNodes_(current);
+
+}
+
+/*....*/
+
+void nEdges(int *result) {
+
+ error=OK;
+
+ if(!current) {error=ERROR; *result=0; return;}
+
+ *result=nNodes_(current)-1;
+}
+
+/*============================================================================*/
+
+double markClasses_(Tree *t) {
+ Tree *b; double destinct,sum;
+
+ /* all tips above a marked ( == 1) node belong to the same class */
+
+ if(!t->branches) {t->mark=1; return(t->length);}
+
+ sum=0.; for(b=t->branches;b;b=b->next) sum+=markClasses_(b);
+
+ destinct=nTips_(t)*(t->length); /* (t->length) == 0. at root */
+
+ if(destinct>sum) { t->mark=1; return(destinct); }
+
+ t->mark=0; return(sum);
+
+}
+
+/*....*/
+
+void getMisawaTajima__(Tree *t,int ignore,int *result) { /* maps tips to marked classes */
+ Tree *b;
+
+ if(t->mark&&!ignore) {node_index++; ignore=1;} /* marked nodes above a marked node will be ignored */
+
+ if(!t->branches) {result[tip_index++]=node_index; return;}
+
+ for(b=t->branches;b;b=b->next) getMisawaTajima__(b,ignore,result);
+
+}
+
+/*....*/
+
+void getMisawaTajima_(Tree *t,int *result) {
+
+ markClasses_(t);
+
+ tip_index=0; node_index=0;
+
+ getMisawaTajima__(t,0,result);
+
+}
+
+/*....*/
+
+void getMisawaTajima(int *result) {
+
+ error=OK;
+
+ if(!current) {error=ERROR; return;}
+
+ getMisawaTajima_(current,result);
+
+}
projects / ape.git / commitdiff