[med-svn] [r-cran-phangorn] 01/02: Imported Upstream version 1.99-13
Alba Crespi
albac-guest at moszumanska.debian.org
Thu May 21 13:08:31 UTC 2015
This is an automated email from the git hooks/post-receive script.
albac-guest pushed a commit to branch master
in repository r-cran-phangorn.
commit ca6513a3eb7ed54c6749451c5f75d6678376d51b
Author: Alba Crespi <crespialba+debian at gmail.com>
Date: Thu May 21 13:49:41 2015 +0100
Imported Upstream version 1.99-13
---
DESCRIPTION | 19 +
MD5 | 117 +
NAMESPACE | 84 +
NEWS | 863 ++++++++
R/Coalescent.R | 98 +
R/Densi.R | 199 ++
R/SOWH.R | 77 +
R/cladePar.R | 19 +
R/clanistic.R | 412 ++++
R/dist.p.R | 79 +
R/distSeq.R | 193 ++
R/fitch.R | 530 +++++
R/hadamard.R | 201 ++
R/neighborNet.R | 196 ++
R/networx.R | 1435 +++++++++++++
R/parsimony.R | 828 ++++++++
R/phyDat.R | 937 ++++++++
R/phylo.R | 4455 +++++++++++++++++++++++++++++++++++++++
R/sankoff.R | 95 +
R/simSeq.R | 85 +
R/sysdata.rda | Bin 0 -> 19469 bytes
R/treeManipulation.R | 1088 ++++++++++
R/treedist.R | 273 +++
R/zzz.R | 14 +
README.md | 17 +
build/vignette.rds | Bin 0 -> 335 bytes
data/Laurasiatherian.RData | Bin 0 -> 15988 bytes
data/chloroplast.RData | Bin 0 -> 21692 bytes
data/yeast.RData | Bin 0 -> 157884 bytes
inst/CITATION | 17 +
inst/README | 22 +
inst/doc/Ancestral.R | 110 +
inst/doc/Ancestral.Rnw | 171 ++
inst/doc/Ancestral.pdf | Bin 0 -> 237029 bytes
inst/doc/Networx.R | 44 +
inst/doc/Networx.Rmd | 96 +
inst/doc/Networx.html | 143 ++
inst/doc/Trees.R | 221 ++
inst/doc/Trees.Rnw | 256 +++
inst/doc/Trees.pdf | Bin 0 -> 138040 bytes
inst/doc/phangorn-specials.R | 109 +
inst/doc/phangorn-specials.Rnw | 258 +++
inst/doc/phangorn-specials.pdf | Bin 0 -> 157302 bytes
inst/extdata/Blosum62.dat | 22 +
inst/extdata/Dayhoff.dat | 22 +
inst/extdata/FLU.dat | 22 +
inst/extdata/HIVb.dat | 22 +
inst/extdata/HIVw.dat | 22 +
inst/extdata/JTT.dat | 22 +
inst/extdata/MtZoa.dat | 30 +
inst/extdata/RtREV.dat | 22 +
inst/extdata/VT.dat | 22 +
inst/extdata/cpREV.dat | 39 +
inst/extdata/dayhoff-dcmut.dat | 50 +
inst/extdata/jtt-dcmut.dat | 50 +
inst/extdata/lg.dat | 22 +
inst/extdata/mtArt.dat | 113 +
inst/extdata/mtREV24.dat | 39 +
inst/extdata/mtmam.dat | 77 +
inst/extdata/wag.dat | 43 +
man/Ancestors.Rd | 49 +
man/Laurasiatherian.Rd | 18 +
man/NJ.Rd | 42 +
man/SH.test.Rd | 48 +
man/SOWH.test.Rd | 53 +
man/allTrees.Rd | 30 +
man/ancestral.pml.Rd | 72 +
man/as.splits.Rd | 81 +
man/bab.Rd | 64 +
man/bootstrap.pml.Rd | 104 +
man/chloroplast.Rd | 19 +
man/cladePar.Rd | 63 +
man/consensusNet.Rd | 56 +
man/densiTree.Rd | 83 +
man/designTree.Rd | 55 +
man/dfactorial.Rd | 28 +
man/dist.hamming.Rd | 49 +
man/dist.p.Rd | 71 +
man/distanceHadamard.Rd | 37 +
man/getClans.Rd | 122 ++
man/hadamard.Rd | 81 +
man/lento.Rd | 47 +
man/midpoint.Rd | 50 +
man/modelTest.Rd | 67 +
man/neighborNet.Rd | 42 +
man/nni.Rd | 36 +
man/parsimony.Rd | 81 +
man/phangorn-package.Rd | 41 +
man/phyDat.Rd | 97 +
man/plot.networx.Rd | 117 +
man/pml.Rd | 152 ++
man/pml.fit.Rd | 79 +
man/pmlCluster.Rd | 70 +
man/pmlMix.Rd | 103 +
man/pmlPart.Rd | 73 +
man/read.aa.Rd | 43 +
man/simSeq.Rd | 74 +
man/splitsNetwork.Rd | 56 +
man/superTree.Rd | 70 +
man/treedist.Rd | 46 +
man/upgma.Rd | 30 +
man/yeast.Rd | 19 +
src/Makevars | 3 +
src/dist.c | 231 ++
src/fitch.c | 741 +++++++
src/ml.c | 1134 ++++++++++
src/phangorn.c | 868 ++++++++
src/read_aa.c | 153 ++
src/sankoff.c | 256 +++
vignettes/Ancestral.Rnw | 171 ++
vignettes/Networx.Rmd | 96 +
vignettes/Trees.RData | Bin 0 -> 51886 bytes
vignettes/Trees.Rnw | 256 +++
vignettes/exdna.txt | 4 +
vignettes/movie.gif | Bin 0 -> 185412 bytes
vignettes/phangorn-specials.Rnw | 258 +++
vignettes/phangorn.bib | 400 ++++
vignettes/primates.dna | 61 +
118 files changed, 21650 insertions(+)
diff --git a/DESCRIPTION b/DESCRIPTION
new file mode 100644
index 0000000..d2cf18d
--- /dev/null
+++ b/DESCRIPTION
@@ -0,0 +1,19 @@
+Package: phangorn
+Title: Phylogenetic Analysis in R
+Version: 1.99-13
+Date: 2015-04-07
+Author: Klaus Schliep, Emmanuel Paradis
+Maintainer: Klaus Schliep <klaus.schliep at gmail.com>
+Description: Phylogenetic analysis in R: Estimation of phylogenetic
+ trees and networks using Maximum Likelihood, Maximum Parsimony,
+ distance methods and Hadamard conjugation.
+Depends: R (>= 3.0.0), ape (>= 3.2)
+Imports: quadprog, igraph (>= 0.6), Matrix, parallel, nnls
+Suggests: seqLogo, seqinr, xtable, flashClust, rgl, knitr
+License: GPL (>= 2)
+VignetteBuilder: utils, knitr
+URL: https://github.com/KlausVigo/phangorn
+Repository: CRAN
+Packaged: 2015-04-07 21:11:16 UTC; klaus
+NeedsCompilation: yes
+Date/Publication: 2015-04-08 00:44:28
diff --git a/MD5 b/MD5
new file mode 100644
index 0000000..ab6d131
--- /dev/null
+++ b/MD5
@@ -0,0 +1,117 @@
+ba46ad1e822741dcea4f2fd1269a5742 *DESCRIPTION
+c699d9d5eb46e6f75a81ce923cc3411b *NAMESPACE
+0c9b7550aefe626cca7d81bc5f24d59b *NEWS
+115bc297835dcaab7d32527fcacb2061 *R/Coalescent.R
+874ee7c405b1384b2f04828ac27574ef *R/Densi.R
+f916be823b9a838d49145695b0a37aa1 *R/SOWH.R
+188e8e2a81eb0c50cc6b7cda6d2c9b98 *R/cladePar.R
+db718843face57068ea5d842cccc22e2 *R/clanistic.R
+e4992df0ce2eaeb1380543eed22aa769 *R/dist.p.R
+eb92decd10b1af4636c9dfa3cc97b4b9 *R/distSeq.R
+4dc4a844ea48eb8a694cf8449b23b0af *R/fitch.R
+86e1095878e3b46eca343d1804a6957e *R/hadamard.R
+0feeebf15c688ec1dd1a003e4c9e488c *R/neighborNet.R
+43346cdbdfd0a819f69a6fbcf8f10ff5 *R/networx.R
+0079fca0b3af71d1730ceab3aeae4f94 *R/parsimony.R
+1378c04926c78c226a3e34d5301f7fa3 *R/phyDat.R
+51b2f1bbf59dd590fba1bd33a5def284 *R/phylo.R
+ef07cb79ed0ece0caa494ed7c566e17b *R/sankoff.R
+bd5ce765336904ef9fd6ee286dc42220 *R/simSeq.R
+2b4d6884b4ee2b92e617cea76f79d3da *R/sysdata.rda
+b10db1358eff8e0d1ed28aff3f318ce5 *R/treeManipulation.R
+d6c76453e0fba7e7691111839479c7f0 *R/treedist.R
+c925e4cd5ce95bf91968fc909d6eef76 *R/zzz.R
+fd3b3539a74c05bdcc9f368f3ee222ad *README.md
+aa1792f357c0e14cc50a2a2b4bb7facd *build/vignette.rds
+4a92b07bcd170e85bd237e460acafa93 *data/Laurasiatherian.RData
+4b269c2e640293341b9b1c04d4dd7f4e *data/chloroplast.RData
+19f84425e8caaf9f605490cdff17dd81 *data/yeast.RData
+b4d3fa3f40aae3a68846d1f28274e9a0 *inst/CITATION
+61b3722df2ead748e0db8595428412a1 *inst/README
+cd23e5801a1f3632bf0cdd76e5242279 *inst/doc/Ancestral.R
+0b18e27e3877621f05e6f78c89a0f5d2 *inst/doc/Ancestral.Rnw
+bfd8e0dfe0c57e211e4600e8221b530d *inst/doc/Ancestral.pdf
+5ae7b5f00020d5544ffe34f27420749b *inst/doc/Networx.R
+efd64c8a6ee13e6443a20adf473d17e4 *inst/doc/Networx.Rmd
+555b48fe21566da8383c1ee92e7a9b81 *inst/doc/Networx.html
+e7c9012ad6d10f1c247564b2562b3eda *inst/doc/Trees.R
+a6ff44c68626895b856effc7e646446d *inst/doc/Trees.Rnw
+46d2167ad02c1ee4670cd07e6420876c *inst/doc/Trees.pdf
+1d5112656a0fe77fd68081a8a81474b9 *inst/doc/phangorn-specials.R
+6e60535c60981d4f5492b73ebf7344df *inst/doc/phangorn-specials.Rnw
+1c3fda481fca1865b5a0b6dae6667885 *inst/doc/phangorn-specials.pdf
+3009f9da02a198cb557d435cc5ad8c7f *inst/extdata/Blosum62.dat
+72f496d4c6e937ffe744d25bd8891313 *inst/extdata/Dayhoff.dat
+5aa357dab0e72b27023e4302bc37dbad *inst/extdata/FLU.dat
+7f63f617d5d29421b0bd90ab8511feb7 *inst/extdata/HIVb.dat
+29e1aa10906a86bb9bca6d9c7f98a6cb *inst/extdata/HIVw.dat
+ca86e539345fa57de5c77a60308bed09 *inst/extdata/JTT.dat
+fdc1176d0c0f2db3de1c9dfd83d3c070 *inst/extdata/MtZoa.dat
+106715eba35efc2743ccad7923ac13ce *inst/extdata/RtREV.dat
+e05f5a0ca507e4e15e7b95d1ce93b9fa *inst/extdata/VT.dat
+fc090d051ce4f18b937448a254e2764e *inst/extdata/cpREV.dat
+50c707c26bf9015b37670f15d5e1c14b *inst/extdata/dayhoff-dcmut.dat
+6da24109959f0c7a7db50c8db78d5d42 *inst/extdata/jtt-dcmut.dat
+ddc4bd45521cd72848aaf2f79b90ac6e *inst/extdata/lg.dat
+917303a3df098f9137c651de0afa78fa *inst/extdata/mtArt.dat
+1cd5e39670b86d32b5fe5c27dcc79648 *inst/extdata/mtREV24.dat
+0ca0d0e987fcebf847a876779eddd934 *inst/extdata/mtmam.dat
+87fa1533c4dfe7074237cfa2196bcbeb *inst/extdata/wag.dat
+985da8b17504af26eff230a7160f208e *man/Ancestors.Rd
+bda5669b71de975e1309d909c495b71f *man/Laurasiatherian.Rd
+4d6fb151c28a597eadc0d4ec2c59a504 *man/NJ.Rd
+5dd84777963b553e8c89bddc951b17c8 *man/SH.test.Rd
+b3418f878911164dd974046f0492c79c *man/SOWH.test.Rd
+6403c950d8f9700d3fe1c847970461ef *man/allTrees.Rd
+2c88d4ded0156a68c44cee9e8fc290b4 *man/ancestral.pml.Rd
+52ca504c035177a8ac1dbe43fc8e90d5 *man/as.splits.Rd
+3b53888e5f37fd54344286a9175d8dc2 *man/bab.Rd
+22ea01fa824c0992bd55a8a43de76b21 *man/bootstrap.pml.Rd
+22ad0ef60c2edd8b3d003f170f2fa15a *man/chloroplast.Rd
+4361615c7d1dc7beb8a4e6118505423c *man/cladePar.Rd
+8d3c6fd646d8a64e29dc79791692a388 *man/consensusNet.Rd
+e99c28d255d25b20b6c02b772e88bacc *man/densiTree.Rd
+f44e43abbbf7707821627c8e88f6e9fa *man/designTree.Rd
+924c4e906042d64ac4fc4907af8c6cf1 *man/dfactorial.Rd
+559e1e95a100d3393e508513ecce311d *man/dist.hamming.Rd
+e7e01cc12be2fac182ff773826ad286f *man/dist.p.Rd
+4f8fa46c2cf1f904d1b85f35fc4db884 *man/distanceHadamard.Rd
+72abceeb247f22b3da6560df0c20468a *man/getClans.Rd
+c1cacff95f20b574c03126d3f8e24106 *man/hadamard.Rd
+9c306689d9d7cd539d8d1055b35e24a2 *man/lento.Rd
+f24a38210a0e90d3241e27514a6f5b8a *man/midpoint.Rd
+970c755f7ac1a0d81ca7d38bf2119a9f *man/modelTest.Rd
+5a825bb21eeef78dccf760a5ee0aca26 *man/neighborNet.Rd
+94cd3c21e4dd4a6919db7fde5146a711 *man/nni.Rd
+f5175ae5af6f9dea5bd0ee51e302e6a0 *man/parsimony.Rd
+06d3770fff0d07f19393875735cfa004 *man/phangorn-package.Rd
+faa3f02d77384b128f4682819b55e04f *man/phyDat.Rd
+1b46f1588ec4e8706df8de61eaa63058 *man/plot.networx.Rd
+cb484368c04bf20d286dedf974c83da1 *man/pml.Rd
+deadaacd3d541c707db8aab53ca1e35d *man/pml.fit.Rd
+9506d15a81467d18f40bb4741b3d9d28 *man/pmlCluster.Rd
+8b06bdee57c510a690ea04b40bac4844 *man/pmlMix.Rd
+ff67d17fa29bf88cea645905334c5ecc *man/pmlPart.Rd
+bfc83a71d7de4e1c0b994b8b9c853439 *man/read.aa.Rd
+eaadcb69db59ca4c512eeb6258013714 *man/simSeq.Rd
+9bfb43eb7ed5a2a3a36496bfffa965dd *man/splitsNetwork.Rd
+2614e984b5c5aa40d9364d3542172654 *man/superTree.Rd
+9cac90a57bbdef5d40f016648d431df9 *man/treedist.Rd
+64399c9fb7fb25d103c25aa925ab7a10 *man/upgma.Rd
+b97649fe8b91a0632a1ded89a6f43125 *man/yeast.Rd
+9a8672b7759d360a54c251d1866b3e05 *src/Makevars
+56d140fd1f0fceb9031c4ad70dfb96f1 *src/dist.c
+a750f640db7ff1a3c56a98ccfe02041a *src/fitch.c
+70437536c7263fe33acf2beeaa96e461 *src/ml.c
+a573d9543f40a6a32c5af7c14ad8993a *src/phangorn.c
+d8e5c864aa0b122ce426a67479d3a610 *src/read_aa.c
+2256cf09434a7ff05e750f4a11124aba *src/sankoff.c
+0b18e27e3877621f05e6f78c89a0f5d2 *vignettes/Ancestral.Rnw
+efd64c8a6ee13e6443a20adf473d17e4 *vignettes/Networx.Rmd
+9608eda76927e9438fa12a63ef8692cd *vignettes/Trees.RData
+a6ff44c68626895b856effc7e646446d *vignettes/Trees.Rnw
+6af5f4d4c2e93469cc19d46a97ab5d0f *vignettes/exdna.txt
+1ca8b1d97a011a9d0ecd9630d548dfb3 *vignettes/movie.gif
+6e60535c60981d4f5492b73ebf7344df *vignettes/phangorn-specials.Rnw
+27f308df3a021c770a6b43e4c5ad9eff *vignettes/phangorn.bib
+d3069d1eff9e70bed655b8962bf4ee2b *vignettes/primates.dna
diff --git a/NAMESPACE b/NAMESPACE
new file mode 100644
index 0000000..8560741
--- /dev/null
+++ b/NAMESPACE
@@ -0,0 +1,84 @@
+useDynLib(phangorn, .registration=TRUE)
+
+importFrom(ape, as.DNAbin, as.phylo, plot.phylo, as.prop.part, nj,old2new.phylo,
+ new2old.phylo, is.rooted, unroot, root, is.binary.tree, as.alignment,
+ di2multi, multi2di, .uncompressTipLabel, .compressTipLabel, prop.part,
+ postprocess.prop.part, speciesTree, plotPhyloCoor, cladogram.plot, phylogram.plot,
+ node.depth.edgelength, drop.tip, stree, rtree, is.ultrametric, .PlotPhyloEnv,
+ nodelabels, edgelabels, BOTHlabels, read.nexus.data, write.nexus.data,
+ read.dna, write.dna, reorder.phylo, dist.nodes, collapse.singles, rotate)
+importFrom(Matrix, Matrix, sparseMatrix, spMatrix, crossprod, solve)
+importFrom(igraph, graph, graph.adjacency, layout.kamada.kawai, plot.igraph,
+ get.shortest.paths, set.edge.attribute, vcount, graph.edgelist, topological.sort)
+importFrom(stats, AIC, logLik, reorder)
+#importFrom(fastmatch, fmatch)
+#importFrom(rgl, open3d, segments3d, spheres3d, rgl.texts)
+importFrom(parallel, mclapply)
+importFrom(nnls, nnls)
+
+export(pml, optim.pml, pml.control, parsimony, optim.parsimony, pratchet, NJ, UNJ, PNJ,
+ phyDat, cbind.phyDat, read.phyDat, write.phyDat, as.Matrix, as.phyDat, as.splits, as.networx,
+ dfactorial, ldfactorial, hadamard, nni, allSitePattern, allSplits, fhm,
+ distanceHadamard, treedist, sankoff, fitch, h2st, h4st, dist.logDet, dist.hamming,
+ dist.ml, dist.p, upgma, wpgma, write.nexus.splits, read.nexus.splits, write.splits, pmlPart,
+ pmlCluster, pmlMix, pmlPen, read.aa, allTrees, designTree, designSplits, nnls.tree,
+ nnls.splits, nnls.phylo, nnls.networx, neighborNet, pmlPart2multiPhylo,
+ splitsNetwork, simSeq, SH.test, bootstrap.pml, bootstrap.phyDat, RF.dist, rNNI,
+ rSPR, plotBS, Ancestors, Descendants, mrca.phylo, Children, Siblings, pace, modelTest,
+ lento, compatible, acgt2ry, ancestral.pars, ancestral.pml, CI, RI, getClans, getSlices,
+ getClips, getDiversity, midpoint, pruneTree, acctran, getRoot, plotAnc, consensusNet,
+ bab, random.addition, diversity, baseFreq, densiTree, superTree, coalSpeciesTree,
+ pml.fit, pml.init, pml.free, edQt, lli, cladePar, addConfidences, countCycles,
+ SOWH.test, plot.networx, presenceAbsence, as.networx.splits, addTrivialSplits)
+
+S3method('[', splits)
+S3method(addConfidences, phylo)
+S3method(addConfidences, splits)
+S3method(addConfidences, networx)
+S3method(as.character, phyDat)
+S3method(as.data.frame, phyDat)
+S3method(anova, pml)
+S3method(c, phyDat)
+S3method(c, splits)
+S3method(cbind, phyDat)
+S3method(unique, phyDat)
+S3method(as.matrix, splits)
+S3method(as.Matrix, splits)
+S3method(as.networx, splits)
+#S3method(as.igraph, networx)
+S3method(as.phyDat, DNAbin)
+S3method(as.phyDat, alignment)
+S3method(as.phyDat, data.frame)
+S3method(as.phyDat, matrix)
+S3method(as.DNAbin, phyDat)
+S3method(as.phylo, splits)
+S3method(as.splits, phylo)
+S3method(as.splits, multiPhylo)
+S3method(as.splits, prop.part)
+S3method(as.splits, networx)
+S3method(as.prop.part, splits)
+S3method(logLik, pml)
+S3method(logLik, pmlPart)
+S3method(logLik, pmlMix)
+S3method(plot, pml)
+S3method(plot, networx)
+S3method(plot, pmlCluster)
+S3method(print, phyDat)
+S3method(print, pml)
+S3method(print, pmlMix)
+S3method(print, pmlPart)
+S3method(print, splits)
+S3method(print, summary.clanistics)
+S3method(print, SOWH)
+S3method(reorder, networx)
+#S3method(reorder, splits)
+S3method(simSeq, phylo)
+S3method(simSeq, pml)
+S3method(subset, phyDat)
+S3method(summary, clanistics)
+S3method(summary, SOWH)
+S3method(update, pml)
+S3method(vcov, pml)
+
+
+
diff --git a/NEWS b/NEWS
new file mode 100644
index 0000000..bdae77e
--- /dev/null
+++ b/NEWS
@@ -0,0 +1,863 @@
+ CHANGES in PHANGORN VERSION 1.99-13
+
+OTHER CHANGES
+
+ o improved importing and conversion of data
+
+ o improved stability of pml and optim.pml
+
+
+
+ CHANGES in PHANGORN VERSION 1.99-12
+
+NEW FEATURES
+
+ o added neighborNet algorithm (Bryant and Moulton 2004)
+
+ very experimental at the moment
+
+BUG FIXES
+
+ o plotBS was not working correctly if bootstraped trees are in
+
+ compressed form (bug report by Tobias Müller)
+
+OTHER CHANGES
+
+ o many splits and networx methods have been improved
+
+ and a vignette was added
+
+ o phangorn now suggests only the rgl and not depends on it
+
+ to avoid problems on different platforms (suggestion by Matt Pennell)
+
+ o new package dependencies knitr for html vignettes and nnls
+
+
+
+ CHANGES in PHANGORN VERSION 1.99-10
+
+BUG FIXES
+
+ o reorder.networx may not work as expected
+
+ o Gamma model was not working properly in simSeq.pml
+
+
+
+ CHANGES in PHANGORN VERSION 1.99-9
+
+BUG FIXES
+
+ o bug fixes for clang environment
+
+ o midpoint takes care of node labels
+
+
+
+ CHANGES in PHANGORN VERSION 1.99-8
+
+NEW FEATURES
+
+ o pmlPart got an argument rooted to handle rooted trees
+
+ o simSeq is now a generic function. This simplifies the
+
+ construcion of parametric bootstrap test
+
+ o SOWH.test (very experimental)
+
+ o as.networx and plot.networx improved considerably
+
+ (often generate networks less edges)
+
+ and planar graphs are now plotted nicely
+
+BUG FIXES
+
+ o fixed some bugs in ancestral.pars
+
+ o amino acid model "Blosum62" was not working
+
+OTHER CHANGES
+
+ o improvements to read.nexus.splits, write.nexus.splits to
+
+ be more consistant with splitstree
+
+ o splitsNetwork got an additional argument splits
+
+ o help for consensusNet, as.splits, as.networx have been reorganised
+
+ and improved
+
+ o treedist is much faster for larger trees
+
+ o several changes to keep R CMD check happy
+
+ o a development version phangorn is now available on github
+
+ https://github.com/KlausVigo/phangorn.git
+
+
+
+ CHANGES in PHANGORN VERSION 1.99-6
+
+NEW FEATURES
+
+ o cladePar helps coloring trees
+
+ o treedist is faster for larger trees, better documentation and examples
+
+BUG FIXES
+
+ o the plot of consensusNet shows now the proper bootstrap values
+
+OTHER CHANGES
+
+ o phangorn does not depend only suggest rgl
+
+ (should build on OS X now)
+
+ o default rearrangement for parsimony is now "SPR"
+
+
+
+ CHANGES in PHANGORN VERSION 1.99-5
+
+NEW FEATURES
+
+ o RF.dist works also on "multiPhylo" objects and is quite fast
+
+ o optim.pml can now handle NNI tree arrangements for rooted trees,
+
+ still experimental but useful for dating etc.
+
+BUG FIXES
+
+ o rNNI did return sometimes trees without tip labels
+
+ o SH.test did not work for pmlCluster objects
+
+ o df for rooted rooted/ultrametric trees are correctly computed
+
+OTHER CHANGES
+
+ o lots of internal code C-code changed
+
+ o exports of some of the internal ML function, this should speed up in
+
+ future other packages e.g. the colescentMCMC package, which use them
+
+ considerably (interface may changes in the future)
+
+ o registered C routines
+
+
+
+ CHANGES in PHANGORN VERSION 1.99-0
+
+NEW FEATURES
+
+ o new function dist.p to estimate pairwise polymorphism
+
+ p-distances from DNA sequences
+
+BUG FIXES
+
+ o as.data.frame.phyDat returned only site patterns and so did
+
+ write.phyDat for nexus files
+
+ o some of the recently introduced (1.7-4) amino acid models were not known
+
+ by all functions and contained NAs
+
+OTHER CHANGES
+
+ o changed package imports and depends structure to aviod error messages,
+
+ thanks to Brian Ripley
+
+ o a lot of the internal C-code has changed
+
+
+
+ CHANGES in PHANGORN VERSION 1.7-4
+
+NEW FEATURES
+
+ o densiTree plots are available now
+
+ o new species tree and super tree methods
+
+ o more amino acid models
+
+BUG FIXES
+
+ o phangorn now depends on rgl instead of suggests rgl,
+
+ rgl wants to be loaded before igraph, otherwise a compiling error
+
+ on some platforms occured!
+
+ o fixed a bug that sometimes caused in pratched to crash
+
+ o fixed a bug when using negative indices in subset.phyDat
+
+ o the search heuristic SPR in optim.parsimony evaluates now more trees
+
+ and is more likely to find better ones
+
+OTHER CHANGES
+
+ o underlying C-code for several functions has changed.
+
+ less memory reallocations and potentially time savings
+
+ hopefully I included not too many bugs
+
+ o optimising edge length changed from Jacobi to Gauss-Seidel method
+
+ and will hopefully be more robust in the long term!
+
+ o Descendants is much faster for option type="all"
+
+ o plotAnc gives user more control and produces nicer plots
+
+
+ CHANGES in PHANGORN VERSION 1.7-1
+
+NEW FEATURES
+
+ o pmlPart got additional argument model
+
+ (request from Santiago Claramunt)
+
+BUG FIXES
+
+ o pmlPart should be more robust
+
+OTHER CHANGES
+
+ o started reorganising the code
+
+ o underlying code of several parsimony functions has changed and
+
+ these are now considerably faster
+
+ o some examples are changed to allow faster checking on CRAN
+
+
+
+ CHANGES in PHANGORN VERSION 1.6-5
+
+NEW FEATURES
+
+ o dist.hamming handles ambigious states now as dist.ml
+
+ (request from Arne Mooers)
+
+BUG FIXES
+
+ o phangorn links properly to ape
+
+
+
+ CHANGES in PHANGORN VERSION 1.6-3
+
+NEW FEATURES
+
+ o optim.parsimony has a new search heuristic (SPR)
+
+BUG FIXES
+
+ o changed package to work with igraph >= 0.6
+
+OTHER CHANGES
+
+ o arguments of pratchet changed
+
+
+
+ CHANGES in PHANGORN VERSION 1.6-0
+
+NEW FEATURES
+
+ o dist.ml has more options and is faster (ca. 5 times for nucleotides and 20 times for amino acids)
+
+BUG FIXES
+
+ o plotBS did not work properly with ape version 3.0
+
+OTHER CHANGES
+
+ o vignettes changed for a faster compilation of the package
+
+ o Ancestors allows a vector of nodes as input
+
+ o midpoint uses less memory and works for larger trees (10000 of tips)
+
+ o ancestral.pars gives better formated output
+
+
+
+ CHANGES in PHANGORN VERSION 1.5-1
+
+OTHER CHANGES
+
+ o several examples changed for a faster compilation of the package
+
+
+
+ CHANGES in PHANGORN VERSION 1.5-0
+
+NEW FEATURES
+
+ o codon models can be used directly
+
+ (dn/ds ratio can be computed)
+
+ o modelTest works now also for amino acids
+
+BUG FIXES
+
+ o the code to compute RI and CI changed and should be more robust
+
+OTHER CHANGES
+
+ o package parallel is used instead of multicore
+
+ o vignettes, examples, help improved
+
+ o ChangeLog is called NEWS
+
+
+
+ CHANGES in PHANGORN VERSION 1.4-1
+
+NEW FEATURES
+
+ o parsimony branch-and-bould algorithms bab (so far pretty slow and memory intensive)
+
+ o more amino acid models
+
+ o function nnls.tree to compute non-negative edge weights for
+
+ a given tree and a distance matrix
+
+BUG FIXES
+
+ o allTrees returns now an integer edge matrix,
+
+ this could have caused some problems previously
+
+ o CI and RI now take better care of ambiguous states
+
+ o dist.ml has default value for amino acids
+
+ o as.splits.multiPhylo produces more sensible bipartitions
+
+ and so lento and consensusNet produce more useful plots
+
+ (thanks to Emmanuel Paradis)
+
+OTHER CHANGES
+
+ o several changes to the networx classes and methods
+
+ o modelTest now also returns the function calls of the estimated models,
+
+ which can be used in downstream analyses
+
+ o vignette "Trees" has a few more examples
+
+ o dist.ml is more general (base frequencies and rate matrix can be supplied)
+
+ o pml objects are more compact, thanks to the Matrix package
+
+ o xtable is now a suggested package (needed for vignettes)
+
+
+
+ CHANGES in PHANGORN VERSION 1.4-0
+
+NEW FEATURES
+
+ o plot.network to plot split networks in 3D (requires rgl) and 2D
+
+ (still very experimantal)
+
+ o consensusNet computes consensus networks
+
+ o Lento plot allows to take multiPhylo objects as input
+
+BUG FIXES
+
+ o CI and RI did not work with only one site pattern present
+
+ o pratchet returned only one, not all of the best trees found
+
+OTHER CHANGES
+
+ o phangorn now requires the Matrix, igraph and rgl packages
+
+ o designTree returns a sparse Matrix and this can save a lot of memory
+
+ o internal code for computing bipartitions is much faster for large trees,
+
+ and so are several functions depending on it, e.g. RF.dist, treedist, Descendants
+
+
+
+ CHANGES in PHANGORN VERSION 1.3-1
+
+BUG FIXES
+
+ o the multicore package may failed, if executed in a GUI environment,
+
+ more error checks included
+
+ o optim.pml, in rare cases may failed to optimize edge length
+
+ (should be more robust now)
+
+OTHER CHANGES
+
+ o some changes to keep R CMD check happy
+
+ o modelTest, pratchet, bootstrap.pml, bootstrap.phyDat
+
+ got an additional argument multicore option to switch
+
+ between serial and parallel execution
+
+
+
+ CHANGES in PHANGORN VERSION 1.3-0
+
+
+NEW FEATURES
+
+ o acctran to assign edge length to parsimony trees
+
+OTHER CHANGES
+
+ o phangorn can now be cited
+
+ o additional and improved ancestral reconstructions methods
+
+ (ACCTRAN, MPR)
+
+ o new vignette describing ancestral sequence reconstruction
+
+
+
+ CHANGES in PHANGORN VERSION 1.2-0
+
+
+NEW FEATURES
+
+ o new function pratchet (parsimony ratchet)
+
+ o new function midpoint for rooting trees
+
+ o new function pruneTree to build concensus trees from node labels
+
+ (e.g. bootstrap values)
+
+ o multicore support for modelTest
+
+BUG FIXES
+
+ o ancestral.pars sometimes did not show all possible states
+
+ o the call-attributes did not get proper changed in update.pml and
+
+ optim.pml
+
+OTHER CHANGES
+
+ o there is now a general help page displayed with '?phangorn'
+
+ o dist.hamming is faster
+
+ o getClans, getSlices and getDiverstity can now
+
+ handle multifurcating trees
+
+
+
+ CHANGES in PHANGORN VERSION 1.1-2
+
+
+NEW FEATURES
+
+ o more generic methods for class splits (print, as.matrix)
+
+ o plotBS can plot now cladograms and phylograms
+
+BUG FIXES
+
+ o read.phyDat sometimes did not work properly for amino acids
+
+
+
+ CHANGES in PHANGORN VERSION 1.1-1
+
+
+NEW FEATURES
+
+ o optim.pml allows to optimise rooted trees
+
+OTHER CHANGES
+
+ o description of getClans improved
+
+
+
+
+ CHANGES in PHANGORN VERSION 1.1-0
+
+
+NEW FEATURES
+
+ o Consistency Index (CI) and and Rentention Index (RI)
+
+ o clanistic tools
+
+ o new generic function cbind.phyDat
+
+ o optim.parsimony works now also with the fitch algorithm,
+
+ faster than the sankoff version
+
+BUG FIXES
+
+ o treedist and RF.dist now check whether trees are binary and
+
+ try to handle multifurcations (thanks to Jeremy Beaulieu for bug fixes)
+
+OTHER CHANGES
+
+ o second vignette describing some special features
+
+ o allTrees is faster
+
+ o trace and pml.control are now more consistent
+
+ o optim.pml uses less memory and can be faster
+
+ for data with lots of characters
+
+
+
+ CHANGES in PHANGORN VERSION 1.0-2
+
+
+BUG FIXES
+
+ o pml.control did not work properly
+
+OTHER CHANGES
+
+ o pmlCluster, pmlMix and pmlPart gained an attribute control,
+
+ which controls the outermost loop
+
+ o some more error checking for pml and parsimony classes
+
+ (thanks to Emmanuel and Liat)
+
+
+
+ CHANGES in PHANGORN VERSION 1.0-1
+
+
+NEW FEATURES
+
+ o ancestral sequence reconstruction
+
+ (parsimony and likelihood based)
+
+ o a small convenience function acgt2ry for ry-coding
+
+ o as.phylo.splits computes a tree from compatible splits
+
+BUG FIXES
+
+ o a small error in pmlCluster was fixed
+
+OTHER CHANGES
+
+ o upgma changed to accommodate change in as.phylo.hclust
+
+ o lento plots are looking nicer
+
+
+
+
+ CHANGES IN PHANGORN VERSION 1.0-0
+
+
+NEW FEATURES
+
+ o implementation of many nucleotide substitution models
+
+ (additional general transition models can be defined)
+
+ o new function modelTest, comparison of different phylogenetic model
+
+ with AIC or BIC
+
+ o Lento plot
+
+ o subset functions for phyDat objects
+
+BUG FIXES
+
+ o an error in pace is fixed
+
+OTHER CHANGES
+
+ o parsimony (fitch and sankoff) can now handle multiPhylo objects
+
+ o splits structure (which is a list of bipartitions), used by lento
+
+ and hadamard conjugation
+
+ o phyDat objects can be more general generated using a contrast
+
+ matrix
+
+
+
+ CHANGES IN PHANGORN VERSION 0.99-6
+
+
+NEW FEATURES
+
+ o pace, extracts the ancestral states of the root of a tree
+
+ using the sankoff algorithm
+
+BUG FIXES
+
+ o fixed a bug in dist.ml (thanks to Emmanuel)
+
+ o fixed a bug introduced to SH.test in 0.99-5
+
+OTHER CHANGES
+
+ o fixed several spelling mistakes in the documentation
+
+
+
+ CHANGES IN PHANGORN VERSION 0.99-5
+
+
+NEW FEATURES
+
+ o parallel computing via multicore
+
+ (so far bootstrap.pml, bootstrap.pml profit under linux)
+
+ o compute edge weights for parsimony trees
+
+BUG FIXES
+
+ o optim.pml had problems when
+
+ o as.character converted ?,- wrongly to NA
+
+ o fitch needed binary trees as input, otherwise pscore is
+
+ likely to be wrong (returns now a warning)
+
+ o optim.pml had a problem with identical sequences
+
+OTHER CHANGES
+
+ o optim.parsimony returns now a tree with edge weights
+
+ o vignette is enhanced, I fixed some spelling mistakes and added
+
+ some more examples.
+
+
+
+ CHANGES IN PHANGORN VERSION 0.99-4
+
+
+NEW FEATURES
+
+ o new generic function unique.phyDat
+
+OTHER CHANGES
+
+ o internal data format phyDat changed
+
+ and data are stored more memory efficient
+
+ (optim.pml and friends use less memory and may be faster)
+
+
+
+ CHANGES IN PHANGORN VERSION 0.99-3
+
+
+BUG FIXES
+
+ o RF.dist sometimes returned wrong distances
+
+ o rate parameter is now properly normalized in pml.Part
+
+ and pmlCluster
+
+ o simSeq had problems simulating a single character
+
+NEW FEATURES
+
+ o rSPR and rNNI to simulate tree rearrangements
+
+
+
+ CHANGES IN PHANGORN VERSION 0.99-2
+
+
+NEW FEATURES
+
+ o bootstrap.pml and bootstrap.phyDat: parametric
+
+ bootstrap methods
+
+ o simSeq: A new function to simulate sequence data
+
+ o read.phyDat: simplifies reading in alignments
+
+ o SH.test: Shimodaira-Hasegawa test
+
+ o RF.dist: Robinson-Foulds distance as replacement
+
+ for treedist (uses less memory and is much faster)
+
+BUG FIXES
+
+ o dist.ml returned wrong variances.
+
+ o as.character.phyDat, as.data.frame caused an error
+
+ for alignments with only one site.
+
+OTHER CHANGES
+
+ o added vignette describing how to perform some
+
+ standard phylogenetic analysis with phangorn.
+
+ o more functions to convert between different data formats.
+
+ o NNI tree search is now general possible for
+
+ partition models (pmlPart, pmlCluster)
+
+
+
+ CHANGES IN PHANGORN VERSION 0.0-5
+
+
+BUG FIXES
+
+ o Solved a namespace problem with ape (>=2.2-3).
+
+
+
+ CHANGES IN PHANGORN VERSION 0.0-4
+
+
+NEW FEATURES
+
+ o splitsNetwork fits a phylogenetic network using a L1 penalty.
+
+ (High memory consumption)
+
+ o pmlPen: A new function to estimate penalized likelihood models
+
+ for sets of edge weights in mixtures or partition models.
+
+BUG FIXES
+
+ o dist.ml should be more forgiving for different inputs.
+
+OTHER CHANGES
+
+ o a new dataset.
+
+
+
+
+ CHANGES IN PHANGORN VERSION 0.0-3
+
+
+NEW FEATURES
+
+ o amino acid models
+
+ o several new maximum likelihood models:
+
+ mixture models (pmlMix), and some model for
+
+ phylogenomic data partition models (pmlPart),
+
+ and clustering of partitions / genes (pmlCluster)
+
+ (still experimental, feed back wellcome)
+
+ o design matrices for phylogenetic distance methods
+
+ o added some functions useful for simulations
+
+ (nni, allTrees)
+
+
+
+OTHER CHANGES
+
+ o the data object phyDat changed slightly internally
+
+ o a new dataset
+
+ o read.aa to read amino acid data in phylip format
+
+ based on read.dna from the ape package
+
+
+
+
+
+ CHANGES IN PHANGORN VERSION 0.0-2
+
+
+NEW FEATURES
+
+ o more generic functions (plot.pml, update.pml)
+
+
+BUG FIXES
+
+ o the "Fitch" algorithm in parsimony contained a bug
+
+
+OTHER CHANGES
+
+ o pml has a cleaner interface (less parameter)
+
+ o new faster parsimony analysis (more compiled C-Code)
+
+ o added NAMESPACE
+
+
+
+
+
diff --git a/R/Coalescent.R b/R/Coalescent.R
new file mode 100644
index 0000000..eee4a4a
--- /dev/null
+++ b/R/Coalescent.R
@@ -0,0 +1,98 @@
+nodeHeight <- function(tree)
+{
+ if(is.null(attr(tree, "order")) || attr(tree, "order") == "cladewise")
+ tree <- reorder(tree, "postorder")
+ edge = tree$edge[, 2]
+ node = tree$edge[, 1]
+ m <- max(tree$edge)
+ el = double(m)
+ el[edge] = tree$edge.length
+ res = .C("nodeH", as.integer(edge), as.integer(node), el, as.integer(length(edge)), double(m))[[5]]
+ max(res) - res
+}
+
+
+
+ancstat = function(phy, x){
+ contrast= attr(x, "contrast")
+ storage.mode(contrast) = "integer"
+ phy=reorder(phy, "postorder")
+ res=matrix(0L, max(phy$edge), ncol(contrast))
+ colnames(res) = attr(x,"levels")
+ nTips=length(phy$tip.label)
+ pa=phy$edge[,1]
+ ch=phy$edge[,2]
+ res[1:nTips, ] = contrast[as.numeric(x)[match(phy$tip, names(x))],, drop=FALSE]
+ for(i in 1:length(pa)){
+ res[pa[i],] = res[pa[i],] | res[ch[i],]
+ }
+ res
+}
+
+
+comp <- function(x, y){
+ tmp1 = matrix(rowSums(x), nrow(x), nrow(y))
+ res = matrix(rowSums(y), nrow(x), nrow(y), byrow=TRUE)
+ tmp3 = tcrossprod(x, 1-y)
+ tmp0 = tcrossprod(x, y)
+ tmp0[tmp3>0]=0L
+ res[!(tmp0>(tmp1 - 1e-8))] = 10000000L
+ apply(res, 1, which.min)
+}
+
+
+comp2 <- function(x, y){
+ res = matrix(rowSums(x), nrow(x), nrow(y))
+ tmp1 = matrix(rowSums(y), nrow(x), nrow(y), byrow=TRUE)
+ tmp3 = tcrossprod(1-x, y)
+ tmp0 = tcrossprod(x, y)
+ tmp0[tmp3>0]=0L
+ res[tmp0<2] = Inf
+ apply(res, 2, which.min)
+}
+
+# single linkage of minimal coalescent times
+# extends speciesTree fom ape
+
+coalSpeciesTree <- function(tree, X, sTree=NULL){
+
+ if(is.null(X))return(speciesTree(tree))
+ trees = unclass(tree)
+ States = lapply(tree, ancstat, X)
+ NH = lapply(tree, nodeHeight)
+ if(is.null(sTree)){
+ l <- attr(X, "nc")
+ m <- choose(l, 2)
+ SST <- matrix(0L, m, l)
+ k <- 1
+ for(i in 1:(l-1)){
+ for(j in (i+1):l){
+ SST[k, i] <- SST[k,j] <- 1L
+ k <- k+1
+ }
+ }
+ Y=matrix(Inf, length(NH), nrow(SST))
+ dm = rep(Inf, m)
+ for(i in 1:length(NH)){
+ ind = comp2(States[[i]],SST)
+ dm = pmin(dm, NH[[i]][ind])
+ # for(j in 1:length(ind))Y[i, ind[j]] = min(Y[i, ind[j]], NH[[i]][j])
+ }
+ dm = structure(2*dm, Labels = attr(X, "levels"), Size = l, class = "dist", Diag = FALSE, Upper = FALSE)
+
+ sTree <- upgma(dm, "single")
+ # dm of pairwise states
+ }
+ else{
+ SST = ancstat(sTree, X)
+ Y=matrix(Inf, length(NH), nrow(SST))
+ for(i in 1:length(NH)){
+ ind = comp(States[[i]],SST)
+ for(j in 1:length(ind))Y[i, ind[j]] = min(Y[i, ind[j]], NH[[i]][j])
+ }
+ STH = apply(Y, 2, min)
+ sTree$edge.length = STH[sTree$edge[,1]] - STH[sTree$edge[,2]]
+ }
+ sTree
+}
+
diff --git a/R/Densi.R b/R/Densi.R
new file mode 100644
index 0000000..be7087d
--- /dev/null
+++ b/R/Densi.R
@@ -0,0 +1,199 @@
+getAges <- function(x){
+ fun=function(x) max(node.depth.edgelength(x))
+ height=NULL
+ if(class(x)=="phylo") height <- fun(x)
+ if(class(x)=="multiPhylo"){
+ if(!is.null(attr(x, "TipLabel"))){
+ x = unclass(x)
+ x = .uncompressTipLabel(x)
+ x = unclass(x)
+ height = sapply(x, fun)
+ }
+ else{
+ x = unclass(x)
+ height = sapply(x, fun)
+ }
+ }
+ height
+}
+
+
+# from phytools code by Liam Revell with a few changes
+my.supertree<-function(trees,method=c("pratchet","optim.parsimony"), trace=0, ...){
+ # set method
+ method<-method[1]
+ # some minor error checking
+ if(!class(trees)=="multiPhylo") stop("trees must be object of class 'multiPhylo.'")
+ # compute matrix representation phylogenies
+ X<-list() # list of bipartitions
+ characters<-0 # number of characters
+ for(i in 1:length(trees)){
+ temp<-prop.part(trees[[i]]) # find all bipartitions
+ # create matrix representation of trees[[i]] in X[[i]]
+ X[[i]]<-matrix(0,nrow=length(trees[[i]]$tip),ncol=length(temp)-1)
+ for(j in 1:ncol(X[[i]])) X[[i]][c(temp[[j+1]]),j]<-1
+ rownames(X[[i]])<-attr(temp,"labels") # label rows
+ if(i==1) species<-trees[[i]]$tip.label
+ else species<-union(species,trees[[i]]$tip.label) # accumulate labels
+ characters<-characters+ncol(X[[i]]) # count characters
+ }
+ XX<-matrix(data="?",nrow=length(species),ncol=characters,dimnames=list(species))
+ j<-1
+ for(i in 1:length(X)){
+ # copy each of X into supermatrix XX
+ XX[rownames(X[[i]]),c(j:((j-1)+ncol(X[[i]])))]<-X[[i]][1:nrow(X[[i]]),1:ncol(X[[i]])]
+ j<-j+ncol(X[[i]])
+ }
+ # compute contrast matrix for phangorn
+ contrast<-matrix(data=c(1,0,0,1,1,1),3,2,dimnames=list(c("0","1","?"),c("0","1")),byrow=TRUE)
+ # convert XX to phyDat object
+ XX<-phyDat(XX,type="USER",contrast=contrast)
+ # estimate supertree
+ if(method=="pratchet"){
+ if(hasArg(start)){
+ start<-list(...)$start
+ if(class(start)=="phylo"){
+ supertree<-pratchet(XX,all=TRUE, trace=0, ...)
+ } else {
+ if(start=="NJ") start<-NJ(dist.hamming(XX))
+ else if(start=="random") start<-rtree(n=length(XX),tip.label=names(XX))
+ else {
+ warning("do not recognize that option for start; using random starting tree")
+ tree<-rtree(n=length(XX),tip.label=names(XX))
+ }
+ args<-list(...)
+ args$start<-start
+ args$data<-XX
+ args$all<-TRUE
+ supertree<-do.call(pratchet,args)
+ }
+ } else supertree<-pratchet(XX,all=TRUE, trace=0, ...)
+ if(class(supertree)=="phylo")
+ if(trace>0)message(paste("The MRP supertree, optimized via pratchet(),\nhas a parsimony score of ",
+ attr(supertree,"pscore")," (minimum ",characters,")",sep=""))
+ else if(class(supertree)=="multiPhylo")
+ if(trace>0)message(paste("pratchet() found ",length(supertree)," supertrees\nwith a parsimony score of ",
+ attr(supertree[[1]],"pscore")," (minimum ",characters,")",sep=""))
+ } else if(method=="optim.parsimony"){
+ if(hasArg(start)){
+ start<-list(...)$start
+ if(class(start)=="phylo"){
+ supertree<-optim.parsimony(tree=start,data=XX, trace=0, ...)
+ } else {
+ if(start=="NJ") start<-NJ(dist.hamming(XX))
+ else if(start=="random") start<-rtree(n=length(XX),tip.label=names(XX))
+ else {
+ warning("do not recognize that option for tree; using random starting tree")
+ start<-rtree(n=length(XX),tip.label=names(XX))
+ }
+ supertree<-optim.parsimony(tree=start,data=XX,...)
+ }
+ } else {
+ if(trace>0)message("no input starting tree or option for optim.parsimony; using random addition tree")
+ start<-random.addition(XX) # rtree(n=length(XX),tip.label=names(XX))
+ supertree<-optim.parsimony(tree=start,data=XX, trace=0, ...)
+ }
+ if(class(supertree)=="phylo")
+ if(trace>0)message(paste("The MRP supertree, optimized via optim.parsimony(),\nhas a parsimony score of ",
+ attr(supertree,"pscore")," (minimum ",characters,")",sep=""))
+ else if(class(supertree)=="multiPhylo")
+ if(trace>0)message(paste("optim.parsimony() found ",length(supertree)," supertrees\nwith a parsimony score of ",
+ attr(supertree[[1]],"pscore")," (minimum ",characters,")",sep=""))
+ }
+ return(supertree)
+}
+
+
+# we want a rooted supertree
+superTree = function(tree, method="optim.parsimony", rooted=TRUE, ...){
+ fun = function(x){
+ x=reorder(x, "postorder")
+ nTips = length(x$tip)
+ x$edge[x$edge>nTips] = x$edge[x$edge>nTips] + 2L
+ l=nrow(x$edge)
+ oldroot = x$edge[l,1L]
+ x$edge=rbind(x$edge,matrix(c(rep(nTips+2,2),oldroot,nTips+1),2L,2L))
+ x$edge.length=c(x$edge.length, 100, 100)
+ x$tip.label=c(x$tip.label, "ZZZ")
+ x$Nnode=x$Nnode+1L
+ x
+ }
+ if(!is.null(attr(tree, "TipLabel")))tree = .uncompressTipLabel(tree)
+ tree = unclass(tree)
+ if(rooted) tree = lapply(tree, fun)
+ class(tree)="multiPhylo"
+ res = my.supertree(tree, method=method, ...)
+ if(rooted){
+ if(class(res)=="multiPhylo"){
+ res = lapply(res, root, "ZZZ")
+ res = lapply(res, drop.tip, "ZZZ")
+ class(res) = "multiPhylo"
+ }
+ else{
+ res = root(res, "ZZZ")
+ res = drop.tip(res, "ZZZ")
+ }
+ }
+ if(class(res)=="multiPhylo"){
+ fun = function(x){
+ x$edge.length <- rep(.1, nrow(x$edge))
+ x
+ }
+ res <- lapply(res, fun)
+ res <- lapply(res, reorder, "postorder")
+ class(res) = "multiPhylo"
+ }
+ else{
+ res$edge.length = rep(.1, nrow(res$edge))
+ res <- reorder(res, "postorder")
+ }
+ res
+}
+
+
+
+densiTree <- function(x, type="cladogram", alpha=1/length(x), consensus=NULL, optim=FALSE, scaleX=FALSE, col=1, width=1, cex=.8, ...) {
+ if(class(x)!="multiPhylo")stop("x must be of class multiPhylo")
+ compressed <- ifelse(is.null(attr(x, "TipLabel")), FALSE, TRUE)
+ if(is.null(consensus))consensus <- superTree(x)
+ consensus = reorder(consensus, "postorder")
+ e2 = reorder(consensus)$edge[,2]
+ nTip = as.integer(length(consensus$tip))
+ tiporder = e2[e2<=nTip]
+ maxBT = max(getAges(x))
+ if(scaleX) maxBT=1.0
+ label = rev(pretty(c(maxBT,0)))
+ maxBT = max(label)
+ xy = plotPhyloCoor(consensus, ...)
+ yy = xy[,2]
+ plot.new()
+ tl = which.max(nchar(consensus$tip.label))
+ sw <- strwidth(consensus$tip.label[tl],cex=cex) * 1.1
+ plot.window(xlim=c(0, 1.0+sw), ylim=c(0, nTip+1))
+ axis(side=1,at=seq(0,1.0, length.out=length(label)), labels=label)
+ text(x=rep(1.0,Ntip(consensus)),y=yy[1:nTip],labels=consensus$tip.label,pos=4,cex=cex)
+ tip.order = yy[1:nTip]
+ for (treeindex in 1:length(x)) {
+ tmp <- reorder(x[[treeindex]], "postorder")
+ xy <- plotPhyloCoor(tmp, tip.order=tiporder, ...)
+ xx = xy[,1]
+ yy = xy[,2]
+ if(scaleX) xx <- xx/max(xx)
+ else xx <- xx/maxBT
+ xx <- xx + (1.0 - max(xx))
+ e1=tmp$edge[,1]
+ e2=tmp$edge[,2]
+ if(type=="cladogram") cladogram.plot(tmp$edge, xx, yy, edge.color=adjustcolor(col, alpha.f=alpha), edge.width=width, edge.lty=1)
+ if(type=="phylogram"){
+ Ntip <- min(e1)-1L
+ Nnode <- tmp$Nnode
+ phylogram.plot(tmp$edge, Ntip, Nnode, xx, yy, TRUE, edge.color=adjustcolor(col, alpha.f=alpha), edge.width=width, 1)
+ }
+ }
+}
+
+
+
+
+
+
diff --git a/R/SOWH.R b/R/SOWH.R
new file mode 100644
index 0000000..c841198
--- /dev/null
+++ b/R/SOWH.R
@@ -0,0 +1,77 @@
+SOWH.test <- function(x, n=100, restricted=list(optNni=FALSE), optNni=TRUE, trace = 1, ...){
+
+ res = matrix(NA, n, 2)
+ extras <- match.call(expand.dots = FALSE)$...
+
+ optU = list (optNni = optNni, optBf = FALSE, optQ = FALSE,
+ optInv = FALSE, optGamma = FALSE, optEdge = TRUE, optRate = FALSE,
+ optRooted = FALSE, model = NULL)
+
+ if(!is.null(extras)){
+ namAll = names(extras)
+ for(i in 1: length(extras))optU[[namAll[i]]] = extras[[i]]
+ }
+ optR = optU
+ namR = names(restricted)
+ for(i in 1: length(namR))optR[[namR[i]]] = restricted[[i]]
+ restr <- optim.pml(x, optNni = optR$optNni, optBf = optR$optBf, optQ = optR$optQ,
+ optInv = optR$optInv, optGamma = optR$optGamma, optEdge = optR$optEdge,
+ optRate = optR$optRate, optRooted = optR$optRooted, model = optR$model,
+ pml.control(trace = trace-1L))
+ unrestr <- optim.pml(restr, optNni = optU$optNni, optBf = optU$optBf, optQ = optU$optQ,
+ optInv = optU$optInv, optGamma = optU$optGamma, optEdge = optU$optEdge,
+ optRate = optU$optRate, optRooted = optU$optRooted, model = optU$model,
+ pml.control(trace = trace-1L))
+
+ for(i in 1:n){
+ if(trace>0) cat("iteration: ", i, "\n")
+ newData <- simSeq(restr)
+ restrTmp <- update(restr, data=newData)
+ unrestrTmp <- restrTmp # update(unrestr, data=newData)
+ restrTmp <- optim.pml(restrTmp, optNni = optR$optNni, optBf = optR$optBf, optQ = optR$optQ,
+ optInv = optR$optInv, optGamma = optR$optGamma, optEdge = optR$optEdge,
+ optRate = optR$optRate, optRooted = optR$optRooted, model = optR$model,
+ pml.control(trace = trace-1L))
+ unrestrTmp <- optim.pml(unrestrTmp, optNni = optU$optNni, optBf = optU$optBf, optQ = optU$optQ,
+ optInv = optU$optInv, optGamma = optU$optGamma, optEdge = optU$optEdge,
+ optRate = optU$optRate, optRooted = optU$optRooted, model = optU$model,
+ pml.control(trace = trace-1L))
+ res[i, 1] <- logLik(restrTmp)
+ res[i, 2] <- logLik(unrestrTmp)
+ }
+ result = list("LL"=res, "restr" = restr, "unrestr" = unrestr)
+ class(result) = "SOWH"
+ result
+}
+
+
+print.SOWH <- function(x, digits = 4L, ...){
+ resLL = logLik(x$restr)
+ unresLL = logLik(x$unrestr)
+ diffLL = unresLL - resLL
+ pval <- sum( (x$LL[,2] - x$LL[,1]) > diffLL) / nrow(x$LL)
+ res = c(resLL, unresLL, diffLL, pval)
+ names(res) = c("ln L restr", "ln L unrestr", "Diff ln L", "p-value")
+ print(res, digits=digits)
+ invisible(x)
+}
+
+
+summary.SOWH <- function(object, digits = 4L, plot=TRUE, ...){
+ resLL = logLik(object$restr)
+ unresLL = logLik(object$unrestr)
+ diffLL = unresLL - resLL
+ pval <- sum( (object$LL[,2] - object$LL[,1]) > diffLL) / nrow(object$LL)
+ res = c(resLL, unresLL, diffLL, pval)
+ names(res) = c("ln L restr", "ln L unrestr", "Diff ln L", "p-value")
+ print(res, digits=digits)
+ if(plot){
+ d = object$LL[,2] - object$LL[,1]
+ hist( d, freq=FALSE, xlim=c(0, 1.2 * max(d, diffLL)))
+ abline(v=diffLL, col="red")
+ }
+ invisible(object)
+}
+
+
+
diff --git a/R/cladePar.R b/R/cladePar.R
new file mode 100644
index 0000000..3905205
--- /dev/null
+++ b/R/cladePar.R
@@ -0,0 +1,19 @@
+cladePar = function(tree, node, edge.color="red", tip.color=edge.color, edge.width = 1, edge.lty = 1, x=NULL, plot=FALSE, ...){
+ if(is.null(x)){
+ m = max(tree$edge)
+ x=list(edge=data.frame(color=rep("black",m), width = rep(1, m), lty = rep(1, m), stringsAsFactors = FALSE),tip=rep("black", length(tree$tip)))
+ }
+ ind = Descendants(tree,node,"all")
+ x$edge$color[ind] = edge.color
+ x$edge$width[ind] = edge.width
+ x$edge$lty[ind] = edge.lty
+ x[[2]][Descendants(tree, node, "tips")[[1]]] = tip.color
+ if(plot){
+ tree=reorder(tree)
+ plot(tree, edge.color=x$edge$color[tree$edge[,2]], edge.width = x$edge$width[tree$edge[,2]], edge.lty = x$edge$lty[tree$edge[,2]], tip.color=x[[2]],...)
+ }
+ else return(x)
+}
+
+
+
diff --git a/R/clanistic.R b/R/clanistic.R
new file mode 100644
index 0000000..0e28944
--- /dev/null
+++ b/R/clanistic.R
@@ -0,0 +1,412 @@
+###########################################################################################
+
+
+getClans = function (tree)
+{
+ if (is.rooted(tree))
+ tree = unroot(tree)
+ bp = bip(tree)
+ nTips = length(tree$tip)
+ root = nTips + 1
+ bp[root] = NULL
+ X = matrix(0, length(bp) - nTips, nTips)
+ k = 1
+ nl = NULL
+ if (!is.null(tree$node.label)) {
+ nl = c(rep("-1", nTips), rep("-1", nTips), tree$node.label[-1],
+ tree$node.label[-1])
+ }
+ if(root<=length(bp)){
+ for (i in root:length(bp)) {
+ X[k, bp[[i]]] = 1
+ k = k + 1
+ }
+ }
+ res <- rbind(diag(nTips), 1 - diag(nTips), X, 1 - X)
+ colnames(res) <- tree$tip
+ if (!is.null(nl))
+ rownames(res) = nl
+ res
+}
+
+
+getSlices <- function(tree){
+ nTips = length(tree$tip)
+ clans = getClans(tree)
+ m = dim(clans)[1]
+ X = tcrossprod(clans)
+ z = rowSums(clans)
+ Z1 = matrix(z,m,m)
+ Z2 = t(Z1)
+ Z = matrix(0,m,m)
+ Z[Z1<=Z2] = Z1[Z1<=Z2]
+ Z[Z2<Z1] = Z2[Z2<Z1]
+
+ diag(X)=0
+ X[upper.tri(X)] = 0
+ X[X==1] = 0
+ X[X==Z] = 0
+ index = which(X>0,arr.ind=TRUE)
+ l = dim(index)[1]
+ nSlices = 2 * nTips^2 -10 * nTips + 12
+ result = matrix(0, nSlices, nTips)
+ strClan = do.call("paste", c(as.data.frame(clans), sep = ""))
+ k=1
+ for(i in 1:l){
+ tmp1 = as.numeric((clans[index[i,1],] + clans[index[i,2],])==2)
+ tmp = paste(tmp1,sep="",collapse="")
+ if(is.na(match(tmp,strClan))){
+ result[k,] = tmp1
+ k=k+1
+ }
+ }
+ if(k<nSlices) result = result[1:(k-1),]
+ colnames(result) <- tree$tip
+ result
+}
+
+
+getClips = function (tree, all = TRUE)
+{
+ if (any(is.na(tree$edge.length)))
+ return(NULL)
+ dm = cophenetic(tree)
+ tips = tree$tip
+ nTips = length(tips)
+ res = numeric(nTips)
+ result = NULL
+ for (i in 1:nTips) {
+ ord = order(dm[i, ])
+ for (j in 2:(nTips - 1)) {
+ ind = ord[1:j]
+
+ if(i>min(ind) ) break()
+ within = max(dm[ind, ind])
+ between = min(dm[ind, -ind])
+ if (within < between) {
+ res = numeric(nTips)
+ res[ind] = 1L
+ result = rbind(result, res)
+ }
+ }
+ }
+ dimnames(result) = list(NULL, tips)
+ if (all)
+ return(result)
+ ind = which.max(rowSums(result))
+ result[ind, ]
+}
+
+
+shannon <- function (x, norm=TRUE)
+{
+ p = x/sum(x)
+ ShD = -sum(p * log10(p))
+ if(norm){
+ if (sum(x) == 1) return(0)
+ ShD = ShD/log10(sum(x))
+ }
+ ShD
+}
+
+
+shannon2 <- function (x, norm=TRUE)
+{
+ p = x/sum(x)
+ ShD = -sum(p * log(p))
+ if(norm){
+ if (sum(x) == 1) return(0)
+ ShD = ShD/log(sum(x))
+ }
+ ShD
+}
+
+
+getE = function (tree, x, clans = NULL, norm = TRUE)
+{
+ if (is.rooted(tree))
+ tree = unroot(tree)
+ if (is.null(clans))
+ clans = getClans(tree)
+ labels = tree$tip.label
+ x = x[labels]
+ result = rep(NA, 12)
+ names(result) = c("E* tree", "# natives", "# intruder", "# unknown",
+ "E* clan", "# intruder", "# unknown", "E* slice", "# intruder",
+ "# unknown", "bs 1", "bs 2")
+ result[2] = sum(x == 1)
+ result[3] = sum(x == 2)
+ result[4] = sum(x == 3)
+ if (result[2] == 0 || result[3] == 0) {
+ if (result[2] > 1)
+ return(list(result, labels))
+ else return(list(result, integer(0)))
+ }
+ LHG = E_Intruder(clans, x)
+ d = dim(LHG)[1]
+ if (d == 1) {
+ result[1] = 0
+ if (!is.null(tree$node.label))
+ result[11] = as.numeric(rownames(LHG))
+ return(list(result, labels[LHG == 0]))
+ }
+ intr = drop(LHG %*% as.numeric(x == 2))
+ result[1] = shannon2(intr, norm = norm)
+ o <- order(intr, decreasing = TRUE)
+ if (!is.null(tree$node.label))
+ result[11:12] = as.numeric(rownames(LHG)[o[c(1, 2)]])
+ ind = which(LHG[o[1], ] == 1)
+ result[6] = sum(x[-ind] == 2)
+ result[7] = sum(x[-ind] == 3)
+
+
+ if (length(x[-ind]) < 4)
+ return(list(result, NULL))
+ result[5] = shannon2(intr[-o[1]], norm = norm)
+ ind2 = c(which(LHG[o[1], ] == 1), which(LHG[o[2], ] == 1))
+
+ spl = structure(list(which(colSums(LHG)==0)), labels=labels, weights=1)
+ class(spl)="splits"
+
+ if (d == 2) {
+ return(list(result, spl))
+ }
+ result[9] = sum(x[-ind2] == 2)
+ result[10] = sum(x[-ind2] == 3)
+ if (length(x[-ind2]) < 4){
+ return(list(result, spl))
+ }
+ result[8] = shannon2(intr[-c(o[1], o[2])], norm = norm)
+ return(list(result, spl))
+}
+
+
+E_Intruder <- function (clans, x)
+{
+ cp = drop(clans %*% as.numeric(x == 1))
+ ci = drop(clans %*% as.numeric(x == 2))
+ homo = which(cp == 0 & ci > 0)
+ l = length(homo)
+ if (l > 0) {
+ HG = clans[homo, , drop = FALSE]
+ lhg = rep(TRUE, l)
+ rsh = rowSums(HG)
+ Z = tcrossprod(HG)>0
+ Z = Z * rsh
+ zmax = apply(Z,2,max)
+ lhg = !(zmax > rsh)
+ LHG = HG[lhg, , drop = FALSE]
+ return(LHG)
+ }
+ return(NULL)
+}
+
+
+E_Intruder_2 <- function (clans, x, native=NULL)
+{
+ contr = attr(x, "contr")
+ d = dim(contr)
+ if(d[1]>d[2])contr[(d[2]+1):d[1],]=0
+ cp = clans %*% contr[as.numeric(x),]
+
+ homo = which(rowSums(cp > 0) == 1)
+
+ l = length(homo)
+ if (l > 0) {
+ HG = clans[homo, , drop = FALSE]
+ lhg = rep(TRUE, l)
+ rsh = rowSums(HG)
+ Z = tcrossprod(HG)>0
+ Z = Z * rsh
+ zmax = apply(Z,2,max)
+ lhg = !(zmax > rsh)
+ LHG = HG[lhg, , drop = FALSE]
+ return(LHG)
+ }
+ return(NULL)
+}
+
+
+getDiv <- function(tree, x, native=NULL){
+ clans = getClans(tree)
+ labels = tree$tip.label
+ x = subset(x, labels)
+ LHG = E_Intruder_2(clans, subset(x,,1))
+ if(!is.null(native)){
+ ll = match(native, attr(x, "allLevels"))
+ ind = (as.numeric(x) %in% ll)
+ }
+ if(!is.null(native)){
+ rs = rowSums(clans)
+ intr = clans %*% ind
+ clans = clans[intr==0,]
+ d = which.max(rs[intr==0])
+ tree2 = drop.tip(tree, tip=labels[which(clans[d, ]==1)])
+ }
+ else tree2=NULL
+ list(c(shannon(rowSums(LHG)),
+ summary(factor(attr(x, "allLevels"))[as.numeric(subset(x,,1))]), parsimony(tree, x)), tree2 )
+}
+
+
+getDiversity <- function (tree, x, norm = TRUE, var.names = NULL, labels="new")
+{
+ k = 1
+ if(class(tree) == "multiPhylo")
+ k = length(tree)
+ l = attr(x, "nr")
+ tmp = matrix(0, k * l, 12)
+
+ tnam = 1
+ if (class(tree) == "multiPhylo") {
+ tnam = names(tree)
+ if (is.null(tnam))
+ tnam = 1:length(tree)
+ }
+ if(is.null(var.names)) var.names = 1:l
+ PM = data.frame("t1", "a", stringsAsFactors = FALSE)
+ colnames(PM) = c("Tree", "Var")
+ PM = PM[FALSE,]
+ PM[1 :(k*l), ] = NA
+ perfect = names(x)
+ L = vector("list",k*l)
+ m = 1
+ o = 1
+ ok= 0
+ for (i in 1:k) {
+ if (class(tree) == "multiPhylo")
+ tmptree = tree[[i]]
+ else tmptree = tree
+ if (is.rooted(tmptree))
+ tmptree = unroot(tmptree)
+ clans = getClans(tmptree)
+ for (j in 1:l) {
+ TMP = getE(tmptree, getRows(x, j), clans, norm = norm)
+ tmp[m, ] = TMP[[1]]
+ L[[m]] = TMP[[2]] # if class =splits else NULL
+ PM[m, 1] = tnam[i]
+ PM[m, 2] = var.names[j]
+ m = m + 1
+ }
+ }
+
+ tnam = rep(tnam, each = l)
+ dnam = var.names
+ dnam = rep(dnam, k)
+ pscore = as.numeric(sankoff(tree, x, site = "site"))
+ res = data.frame(tnam, dnam, tmp, pscore)
+ if(labels=="old")names(res) = c("tree", "variable", "E tree", "# natives",
+ "# intruder", "# unknown", "E clan", "# intruder", "# unknown",
+ "E slice", "# intruder", "# unknown", "bs 1", "bs 2", "p-score")
+ else{
+ names(res) = c("tree", "variable", "E clan", "# natives",
+ "# intruder", "# unknown", "E slice", "# intruder", "# unknown",
+ "E melange", "# intruder", "# unknown", "bs 1", "bs 2", "p-score")
+ warning("The variable names have changed")
+ }
+ attr(res, "Perfect") = L
+ class(res) = c("clanistics", "data.frame")
+ res
+}
+
+
+summary.clanistics <- function(object, ...){
+ res <- matrix(FALSE, nrow(object), 5)
+ res[,1] = object[,4]>0 & object[,"p-score"]==0 # "natives"
+ res[,2] = object[,5]>0 & object[,"p-score"]==0 # "intruder"
+ res[,3] = object[,"p-score"]==1
+ res[,4] = ( (object[,"p-score"]==2) & (object[,7]==0) & (!is.na(object[,7])) ) |
+ ( (object[,"p-score"]==2) & (object[,4]==2) & (is.na(object[,7])) )
+ res[,5] = object[,"p-score"]>=2 & (object[,7]>0) & (!is.na(object[,7]))
+ res[] = as.numeric(res)
+ tmp = data.frame(factor(object[,"variable"]), res)
+ colnames(tmp) = c("Variable", "Natives_only", "Intruder_only", "Clan", "Slice", "Melange")
+# colnames(res) = c("Natives only", "Intruder only", "Clan", "Melange")
+ class(tmp) <- c("summary.clanistics", "data.frame")
+ tmp
+ }
+
+
+print.summary.clanistics <- function(x, ...){
+ print(aggregate(x[,-1], list(Variable=x[,1]), sum), ...)
+}
+
+
+compareSplits <- function(res, nam1, nam2){
+ wide <- reshape(res[, c("tree", "E tree", "variable")], v.names="E tree", idvar="tree", timevar="variable", direction="wide")
+ wideI <- reshape(res[, c("tree", "# natives", "variable")], v.names="# natives", idvar="tree", timevar="variable", direction="wide")
+ for(i in 2:dim(wide)[2])colnames(wide)[i] = strsplit(colnames(wide)[i],"E tree.")[[1]][2]
+ for(i in 2:dim(wide)[2])colnames(wideI)[i] = strsplit(colnames(wideI)[i],"# natives.")[[1]][2]
+ ntrees = wide[,1]
+ splits = attr(res, "Perfect")
+ dat = attr(attr(res, "Perfect"), "data")
+ res = matrix(NA, length(ntrees), length(nam1)*length(nam2))
+ for(m in 1:length(trees)){
+ k=1
+ trnam=ntrees[m]
+ for(i in nam1){
+ E1 = wide[m, i]
+ for(j in nam2){
+ E2 = wide[m, j]
+ if(!is.na(E1) & !is.na(E2)){
+ if(E1 == E2){ # if(E1 == 0 & E2 == 0){
+ if( (wideI[m, i] >0) & (wideI[m, j]) >0){
+ ind1 = which(dat[,1]==trnam & dat[,2]==i)
+ sp1 = splits[[ind1]]
+ ind2 = which(dat[,1]==trnam & dat[,2]==j)
+ sp2 = splits[[ind2]]
+ if(length(ind1)>0 & length(ind2)>0 )res[m, k] = drop(compatible3(sp1, sp2))
+ }
+ }
+ }
+ k=k+1
+ }
+ }
+ }
+ res
+}
+
+
+diversity <- function(tree, X){
+# from kknn
+ contr.dummy <- function (n, contrasts = TRUE)
+ {
+ if (length(n) <= 1) {
+ if (is.numeric(n) && length(n) == 1 && n > 1)
+ levels <- 1:n
+ else stop("contrasts are not defined for 0 degrees of freedom")
+ }
+ else levels <- n
+ lenglev <- length(levels)
+ cont <- array(0, c(lenglev, lenglev), list(levels, levels))
+ cont[col(cont) == row(cont)] <- 1
+ cont
+ }
+
+
+ l = dim(X)[2]
+ m <- ifelse(class(tree)=="multiPhylo", length(tree), 1)
+
+ contr = as.list(rep("contr.dummy", l))
+ names(contr) = names(X)
+ tmp = model.matrix(~.-1, X, contrast=contr)
+ tmp1 <- phyDat.default(tmp, levels=c(1,0), compress = FALSE)
+ attr(tmp1, "varnames") = colnames(tmp)
+ fd = sankoff(tree,tmp1,site = "site")
+ fd = matrix(fd, ncol=m)
+
+ if(m>1){
+ if(is.null(names(tree))) tnames <- paste("tree", 1:m, sep=".")
+ else tnames <- names(tree)
+ }
+ else tnames = "tree"
+ dimnames(fd) = list(colnames(tmp), tnames)
+ res = stack(data.frame(fd))
+
+ if(m>1)nt = rep(sapply(tree, function(x)length(x$tip)), each=dim(fd)[1])
+ else nt = rep(length(tree$tip), each=dim(fd)[1])
+ if(m>1)res2 = as.vector(sapply(tree, function(x,y)colSums(y[x$tip,,drop=FALSE]) , y=tmp))
+ else res2 = colSums(tmp[tree$tip,,drop=FALSE])
+ result <- data.frame(tree = res[,2], variable=rep(colnames(tmp),m), pscore=res[,1], ntips=nt, natives=res2)
+ result
+}
diff --git a/R/dist.p.R b/R/dist.p.R
new file mode 100644
index 0000000..081aa23
--- /dev/null
+++ b/R/dist.p.R
@@ -0,0 +1,79 @@
+
+dist.p <- function (x, cost="polymorphism", ignore.indels=TRUE)
+{
+ if (class(x) != "phyDat")
+ stop("x has to be element of class phyDat")
+
+ l = length(x)
+ weight <- attr(x, "weight")
+ n <- length(attr(x, "allLevels"))
+ d = numeric((l * (l - 1))/2)
+ lev = attr(x, "allLevels")
+ if(is.null(cost)){
+ cost <- 1 - diag(n)
+ dimnames(cost) = list(lev, lev)
+ }
+# if(cost=="polymorphism" && attr(x, "type")=="DNA"){
+ if(cost=="polymorphism"){
+ costLev = c('a','c','t','u','g','x','m','r','w','s','y','k','v','h','d','b','-','?','n')
+
+ cost <- matrix(c(
+ #a,c,t,u,g,X,m,r,w,s,y,k,v,h,d,b,-,?,n,
+ 0,2,2,2,2,1,1,1,1,3,3,3,2,2,2,4,2,0,0, #a
+ 2,0,2,2,2,1,1,3,3,1,1,3,2,2,4,2,2,0,0, #c
+ 2,2,0,0,2,1,3,3,1,3,1,1,4,2,2,2,2,0,0, #t
+ 2,2,0,0,2,1,3,3,1,3,1,1,4,2,2,2,2,0,0, #u
+ 2,2,2,2,0,1,3,1,3,1,3,1,2,4,2,2,2,0,0, #g
+ 1,1,1,1,1,0,1,1,1,1,1,1,1,1,1,1,1,0,0, #X
+ 1,1,3,3,3,1,0,2,2,2,2,4,1,1,3,3,3,0,0, #m
+ 1,3,3,3,1,1,2,0,2,2,4,2,1,3,1,3,3,0,0, #r
+ 1,3,1,1,3,1,2,2,0,4,2,2,3,1,1,3,3,0,0, #w
+ 3,1,3,3,1,1,2,2,4,0,2,2,1,3,3,1,3,0,0, #s
+ 3,1,1,1,3,1,2,4,2,2,0,2,3,1,3,1,3,0,0, #y
+ 3,3,1,1,1,1,4,2,2,2,2,0,3,3,1,1,3,0,0, #k
+ 2,2,4,4,2,1,1,1,3,1,3,3,0,2,2,2,4,0,0, #v
+ 2,2,2,2,4,1,1,3,1,3,1,3,2,0,2,2,4,0,0, #h
+ 2,4,2,2,2,1,3,1,1,3,3,1,2,2,0,2,4,0,0, #d
+ 4,2,2,2,2,1,3,3,3,1,1,1,2,2,2,0,4,0,0, #b
+ 2,2,2,2,2,1,3,3,3,3,3,3,4,4,4,4,0,0,0, #-
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0, #?
+ 0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0,0),#n
+ ncol = 19,nrow=19,dimnames=list(costLev,costLev))
+ }
+
+ lev1 = dimnames(cost)[[1]]
+
+
+ if(any(is.na(match(lev, lev1)))) stop("Levels of x are not in levels of cost matrix!")
+
+ if (ignore.indels) {
+ cost["-",]=0
+ cost[,"-"]=0
+ }
+
+
+ cost <- cost[lev, lev]
+
+ k = 1
+ for (i in 1:(l - 1)) {
+ for (j in (i + 1):l) {
+ d[k] = sum(weight * cost[cbind(x[[i]], x[[j]])])
+ k = k + 1
+ }
+ }
+ attr(d, "Size") <- l
+ if (is.list(x))
+ attr(d, "Labels") <- names(x)
+ else attr(d, "Labels") <- colnames(x)
+ attr(d, "Diag") <- FALSE
+ attr(d, "Upper") <- FALSE
+ attr(d, "call") <- match.call()
+ attr(d, "method") <- "p"
+ class(d) <- "dist"
+ return(d)
+}
+
+
+
+
+
diff --git a/R/distSeq.R b/R/distSeq.R
new file mode 100644
index 0000000..8ec34c2
--- /dev/null
+++ b/R/distSeq.R
@@ -0,0 +1,193 @@
+#
+# dist
+#
+dist.hamming <- function (x, ratio = TRUE, exclude = "none")
+{
+ if (class(x) != "phyDat")
+ stop("x has to be element of class phyDat")
+ l = length(x)
+
+ contrast <- attr(x, "contrast")
+ nc <- as.integer(attr(x, "nc"))
+ con = rowSums(contrast > 0) < 2
+ if (exclude == "all") {
+ index = con[x[[1]]]
+ for (i in 2:l) index = index & con[x[[i]]]
+ index = which(index)
+ x = subset(x, , index)
+ }
+ weight <- attr(x, "weight")
+ d = numeric((l * (l - 1))/2)
+
+ if(exclude == "pairwise"){
+ k=1
+ W <- numeric(l*(l-1)/2)
+ for (i in 1:(l - 1)) {
+ tmp = con[x[[i]]]
+ for (j in (i + 1):l) {
+ W[k] = sum(weight[tmp & con[ x[[j]] ] ])
+ k = k + 1
+ }
+ }
+
+ }
+
+ if(nc > 31){
+# contrast <- attr(x, "contrast")
+ k = 1
+ for (i in 1:(l - 1)) {
+ X = contrast[x[[i]], , drop = FALSE]
+ for (j in (i + 1):l) {
+ d[k] = sum(weight * (rowSums(X * contrast[x[[j]], , drop = FALSE]) == 0))
+ k = k + 1
+ }
+ }
+ } # end if
+ else{
+ nr <- attr(x, "nr")
+ if(exclude == "pairwise")ind <- which(con[unlist(x)]==FALSE)
+ x <- prepareDataFitch(x)
+ if(exclude == "pairwise")x[ind] <- as.integer(2L^nc -1L)
+ res <- .C("distHamming", as.integer(x), as.double(weight), as.integer(nr), as.integer(l), as.double(d), PACKAGE = "phangorn")
+ d <- res[[5]]
+ }
+
+ if (ratio){
+ if(exclude == "pairwise") d = d/W
+ else d = d/sum(weight)
+ }
+ attr(d, "Size") <- l
+ if (is.list(x))
+ attr(d, "Labels") <- names(x)
+ else attr(d, "Labels") <- colnames(x)
+ attr(d, "Diag") <- FALSE
+ attr(d, "Upper") <- FALSE
+ attr(d, "call") <- match.call()
+ attr(d, "method") <- "hamming"
+ class(d) <- "dist"
+ return(d)
+}
+
+
+
+dist.ml <- function (x, model = "JC69", exclude = "none", bf = NULL, Q = NULL, ...)
+{
+ if (class(x) != "phyDat")
+ stop("x has to be element of class phyDat")
+ l = length(x)
+ d = numeric((l * (l - 1))/2)
+ v = numeric((l * (l - 1))/2)
+ contrast <- attr(x, "contrast")
+ nc <- as.integer(attr(x, "nc"))
+ nr <- as.integer(attr(x, "nr"))
+ con = rowSums(contrast > 0) < 2
+ if (exclude == "all") {
+ index = con[x[[1]]]
+ for (i in 2:l) index = index & con[x[[i]]]
+ index = which(index)
+ x = subset(x, , index)
+ }
+# model <- match.arg(model, c("JC69", "WAG", "JTT", "LG", "Dayhoff", "cpREV", "mtmam", "mtArt", "MtZoa", "mtREV24"))
+ model <- match.arg(model, c("JC69", .aamodels))
+# if (!is.na(match(model, c("WAG", "JTT", "LG", "Dayhoff", "cpREV", "mtmam", "mtArt", "MtZoa", "mtREV24"))))
+ if (!is.na(match(model, .aamodels)))
+ getModelAA(model, bf = is.null(bf), Q = is.null(Q))
+ if (is.null(bf))
+ bf <- rep(1/nc, nc)
+ if (is.null(Q))
+ Q <- rep(1, (nc - 1) * nc/2L)
+
+ bf = as.double(bf)
+ eig <- edQt(Q = Q, bf = bf)
+ k = 1
+ w = as.double(1)
+ g = as.double(1)
+ fun <- function(s) -(nc - 1)/nc * log(1 - nc/(nc - 1) * s)
+ eps <- (nc - 1)/nc
+ n = as.integer(dim(contrast)[1])
+ ind1 = rep(1:n, n:1)
+ ind2 = unlist(lapply(n:1, function(x) seq_len(x) + n - x))
+ li <- as.integer(length(ind1))
+ weight = as.double(attr(x, "weight"))
+ ll.0 = as.double(weight * 0)
+ if (exclude == "pairwise") {
+ index = con[ind1] & con[ind2]
+ index = which(!index)
+ }
+ tmp = (contrast %*% eig[[2]])[ind1, ] * (contrast %*% (t(eig[[3]]) * bf))[ind2, ]
+ tmp2 = vector("list", k)
+ wdiag = .Call("PWI", as.integer(1:n), as.integer(1:n), as.integer(n),
+ as.integer(n), rep(1, n), as.integer(li), PACKAGE = "phangorn")
+ wdiag = which(wdiag > 0)
+ for (i in 1:(l - 1)) {
+ for (j in (i + 1):l) {
+ w0 = .Call("PWI", as.integer(x[[i]]), as.integer(x[[j]]),
+ nr, n, weight, li, PACKAGE = "phangorn")
+ if (exclude == "pairwise")
+ w0[index] = 0.0
+ ind = w0 > 0
+
+ old.el <- 1 - (sum(w0[wdiag])/sum(w0))
+ if (old.el > eps)
+ old.el <- 10
+ else old.el <- fun(old.el)
+ # sind = sum(ind)
+ # tmp2 = vector("list", k)
+ tmp2[[1]] <- tmp[ind, , drop = FALSE]
+ # FS0 verwenden!!!
+ res <- .Call("FS5", eig, nc, as.double(old.el), w, g, tmp2, 1L, as.integer(sum(ind)),
+ bf, w0[ind], ll.0, PACKAGE = "phangorn")
+ d[k] <- res[1] # res[[1]]
+ v[k] <- res[2] # res[[2]]
+ k = k + 1
+ }
+ }
+ attr(d, "Size") <- l
+ if (is.list(x))
+ attr(d, "Labels") <- names(x)
+ else attr(d, "Labels") <- colnames(x)
+ attr(d, "Diag") <- FALSE
+ attr(d, "Upper") <- FALSE
+ attr(d, "call") <- match.call()
+ attr(d, "variance") <- v
+ class(d) <- "dist"
+ return(d)
+}
+
+
+dist.logDet = function (x)
+{
+ if (class(x) != "phyDat")
+ stop("x has to be element of class phyDat")
+ weight <- attr(x, "weight")
+ contrast <- attr(x, 'contrast')
+ r <- attr(x, "nc")
+ l = length(x)
+ d = numeric((l * (l - 1))/2)
+ k = 1
+ for (i in 1:(l - 1)) {
+ Xi = weight * contrast[x[[i]], , drop=FALSE]
+ for (j in (i + 1):l) {
+ tmp = crossprod(Xi, contrast[x[[j]], , drop=FALSE])
+ class(tmp) = "matrix"
+ z = determinant.matrix(tmp, logarithm=TRUE)
+ res = z$sign*z$modulus
+ if (is.nan(res)) {
+ d[k] = 10
+ }
+ else d[k] = (-res + sum(log(rowSums(tmp) * colSums(tmp)))/2)/r
+ k = k + 1
+ }
+ }
+ attr(d, "Size") <- l
+ if (is.list(x))
+ attr(d, "Labels") <- names(x)
+ else attr(d, "Labels") <- colnames(x)
+ attr(d, "Diag") <- FALSE
+ attr(d, "Upper") <- FALSE
+ attr(d, "call") <- match.call()
+ attr(d, "method") <- "logDet"
+ class(d) <- "dist"
+ return(d)
+}
+
diff --git a/R/fitch.R b/R/fitch.R
new file mode 100644
index 0000000..de52340
--- /dev/null
+++ b/R/fitch.R
@@ -0,0 +1,530 @@
+fitch <- function (tree, data, site="pscore")
+{
+ if (class(data) != "phyDat")
+ stop("data must be of class phyDat")
+ levels <- attr(data, "levels")
+ if(class(tree)=="multiPhylo"){
+ TL = attr(tree,"TipLabel")
+ if (!is.null(TL)){
+ data <- subset(data, TL)
+ nTips <- length(TL)
+ weight <- attr(data, "weight")
+ nr <- attr(data, "nr")
+ m <- nr*(2L*nTips - 1L)
+ }
+ }
+ data <- prepareDataFitch(data)
+ d = attributes(data)
+ data <- as.integer(data)
+ attributes(data) <- d
+ if(class(tree)=="phylo") return(fit.fitch(tree, data, site))
+ {
+ if(is.null(attr(tree,"TipLabel"))){
+ tree = unclass(tree)
+ return(sapply(tree, fit.fitch, data, site))
+ }
+ else{
+ tree = unclass(tree)
+# tree = lapply(tree, reorder, "postorder")
+ site = ifelse(site == "pscore", 1L, 0L)
+ on.exit(.C("fitch_free"))
+ .C("fitch_init", as.integer(data), as.integer(nTips*nr), as.integer(m), as.double(weight), as.integer(nr))
+ return(sapply(tree, fast.fitch, nr, site))
+ }
+ }
+}
+
+
+fit.fitch <- function (tree, data, returnData = c("pscore", "site", "data"))
+{
+ if (is.null(attr(tree, "order")) || attr(tree, "order") ==
+ "cladewise")
+ tree <- reorder(tree, "postorder")
+ returnData <- match.arg(returnData)
+ nr = attr(data, "nr")
+ node <- tree$edge[, 1]
+ edge <- tree$edge[, 2]
+ weight = attr(data, "weight")
+ m = max(tree$edge)
+ q = length(tree$tip)
+ result <- .Call("FITCH", data[, tree$tip.label], as.integer(nr), as.integer(node), as.integer(edge), as.integer(length(edge)), as.double(weight), as.integer(m), as.integer(q))
+ if (returnData == "site") return(result[[2]])
+ pscore <- result[[1]]
+ res = pscore
+ if (returnData == "data")
+ res <- list(pscore = pscore, dat = result[[3]], site = result[[2]])
+ res
+}
+
+
+# NNI
+fnodesNew2 <- function (EDGE, nTips, nr)
+{
+ node <- EDGE[, 1]
+ edge <- EDGE[, 2]
+ n = length(node)
+ m= as.integer(max(EDGE)+1L)
+ m2 = 2L*n
+ root0 <- as.integer(node[n])
+ .Call("FNALL_NNI", as.integer(nr), node, edge, as.integer(n), as.integer(m), as.integer(m2), as.integer(root0))
+}
+
+
+# SPR und bab kompakter
+fnodesNew5 <- function (EDGE, nTips, nr)
+{
+ node <- EDGE[, 1]
+ edge <- EDGE[, 2]
+ n = length(node)
+ m= as.integer(max(EDGE)+1L)
+ m2 = 2L*n
+ root0 <- as.integer(node[n])
+ .Call("FNALL5", as.integer(nr), node, edge, as.integer(n), as.integer(m), as.integer(m2), as.integer(root0))
+}
+
+
+random.addition <- function(data, method="fitch")
+{
+ label <- names(data)
+ nTips <- as.integer(length(label))
+ remaining <- as.integer(sample(nTips))
+ tree <- structure(list(edge = structure(c(rep(nTips+1L, 3), remaining[1:3]), .Dim = c(3L, 2L)),
+ tip.label = label, Nnode = 1L), .Names = c("edge", "tip.label", "Nnode"), class = "phylo", order = "postorder")
+ remaining <- remaining[-c(1:3)]
+
+ if(nTips==3L) return(tree)
+
+ nr <- attr(data, "nr")
+ storage.mode(nr) <- "integer"
+ n <- length(data) #- 1L
+
+ data <- subset(data,,order(attr(data, "weight"), decreasing=TRUE))
+ data <- prepareDataFitch(data)
+ weight <- attr(data, "weight")
+
+ m = nr*(2L*nTips - 2L)
+
+ on.exit(.C("fitch_free"))
+ .C("fitch_init", as.integer(data), as.integer(nTips*nr), as.integer(m), as.double(weight), as.integer(nr))
+
+ storage.mode(weight) <- "double"
+
+ for (i in remaining) {
+ edge = tree$edge[,2]
+ score = fnodesNew5(tree$edge, nTips, nr)[edge]
+ score <- .Call("FITCHTRIP3", as.integer(i), as.integer(nr), as.integer(edge), as.double(score), as.double(Inf))
+ res = min(score)
+ nt = which.min(score)
+ tree = addOne(tree, i, nt)
+ }
+ attr(tree, "pscore") = res
+ tree
+}
+
+
+fast.fitch <- function (tree, nr, ps = TRUE)
+{
+ node <- tree$edge[, 1]
+ edge <- tree$edge[, 2]
+ m = max(tree$edge)
+ .Call("FITCH345", as.integer(nr), as.integer(node), as.integer(edge), as.integer(length(edge)), as.integer(m), as.integer(ps))
+}
+
+
+fitch.spr <- function(tree, data){
+ nTips = as.integer(length(tree$tip))
+ nr = attr(data, "nr")
+ minp = fast.fitch(tree, nr, TRUE)
+
+ for(i in 1:nTips){
+ treetmp = dropTip(tree, i)
+ edge = treetmp$edge[,2]
+ score = fnodesNew5(treetmp$edge, nTips, nr)[edge]
+ score <- .Call("FITCHTRIP3", as.integer(i), as.integer(nr), as.integer(edge), as.double(score), as.double(minp))
+
+ if(min(score)<minp){
+ nt = which.min(score)
+ tree = addOne(treetmp, i, nt)
+ minp=min(score)
+ # print(paste("new",minp))
+ }
+ }
+ m=max(tree$edge)
+ root <- getRoot(tree)
+ ch = allChildren(tree)
+ for(i in (nTips+1L):m){
+ if(i!=root){
+ tmp = dropNode(tree, i, all.ch=ch)
+ if(!is.null(tmp)){
+ edge = tmp[[1]]$edge[,2]
+ blub = fast.fitch(tmp[[2]], nr, TRUE)
+ score = fnodesNew5(tmp[[1]]$edge, nTips, nr)[edge] + blub
+ score <- .Call("FITCHTRIP3", as.integer(i), as.integer(nr), as.integer(edge), as.double(score), as.double(minp))
+ if(min(score)<minp){
+ nt = which.min(score)
+ tree = addOneTree(tmp[[1]], tmp[[2]], nt, tmp[[3]])
+ minp <- min(score)
+ ch = allChildren(tree)
+ }
+ }
+ }
+ }
+ tree
+}
+
+# raus
+fitch.spr2 <- function(tree, data){
+ nTips = as.integer(length(tree$tip))
+ nr = attr(data, "nr")
+ minp = fast.fitch(tree, nr, TRUE)
+
+ changeIndex <- function(x, i, j){
+ x$edge[x$edge == i] = 0L
+ x$edge[x$edge == j] = i
+ x$edge[x$edge == 0L] = j
+ x
+ }
+
+
+ for(i in 1:nTips){
+ treetmp = dropTip(tree, i)
+ edge = treetmp$edge[,2]
+ score = fnodesNew5(treetmp$edge, nTips, nr)[edge]
+ score <- .Call("FITCHTRIP3", as.integer(i), as.integer(nr), as.integer(edge), as.double(score), as.double(minp))
+
+ if(min(score)<minp){
+ nt = which.min(score)
+ tree = addOne(treetmp, i, nt)
+ minp=min(score)
+ # print(paste("new",minp))
+ }
+ }
+ m=max(tree$edge)
+
+ root <- getRoot(tree)
+ for(i in (nTips+1L):m){
+ if(i!=root){
+ tmp = dropNode(tree, i)
+ print(i)
+ if(!is.null(tmp)){
+ edge = tmp[[1]]$edge[,2]
+ blub = fast.fitch(tmp[[2]], nr, TRUE)
+ score = fnodesNew5(tmp[[1]]$edge, nTips, nr)[edge] + blub
+ score <- .Call("FITCHTRIP3", as.integer(i), as.integer(nr), as.integer(edge), as.double(score), as.double(minp))
+ if(min(score)<minp){
+ nt = which.min(score)
+ tree = addOneTree(tmp[[1]], tmp[[2]], nt, tmp[[3]])
+ minp <- min(score)
+ }
+ }
+# browser()
+# j = Ancestors(tree, i, "parent")
+# tree2 = reroot(tree, node=i)
+# tree2 = unroot(tree2)
+# tree2 = reorder(tree2, "postorder")
+# if(j == (nTips+1L)) tree2 = changeIndex(tree2, as.integer(nTips+1L), as.integer(i))
+# tmp = dropNode(tree2, j)
+# if(!is.null(tmp)){
+# edge = tmp[[1]]$edge[,2]
+# blub = fast.fitch(tmp[[2]], nr, TRUE)
+# score = fnodesNew5(tmp[[1]]$edge, nTips, nr)[edge] + blub
+# score <- .Call("FITCHTRIP3", as.integer(j), as.integer(nr), as.integer(edge), as.double(score), as.double(minp), PACKAGE="phangorn")
+# if(min(score)<minp){
+# nt = which.min(score)
+# tree = addOneTree(tmp[[1]], tmp[[2]], nt, tmp[[3]])
+# minp <- min(score)
+# }
+# }
+ }
+ }
+ tree
+}
+
+indexNNI2 <- function(tree){
+ parent = tree$edge[, 1]
+ child = tree$edge[, 2]
+
+ ind = which(child %in% parent)
+ Nnode = tree$Nnode
+ edgeMatrix = matrix(0L, 6, length(ind))
+
+ pvector <- numeric(max(parent))
+ pvector[child] <- parent
+ cvector <- allChildren(tree)
+
+ k=0
+ for(i in ind){
+ p1 = parent[i]
+ p2 = child[i]
+ e34 = cvector[[p2]]
+ ind1 = cvector[[p1]]
+ e12 = ind1[ind1 != p2]
+ if(pvector[p1]) edgeMatrix[, k+1] = c(p1,e12, e34, p2, 1L)
+ else edgeMatrix[, k+1] = c(e12, e34, p2, 0L)
+ k=k+1
+ }
+ cbind(edgeMatrix[c(1,3,2,4,5,6),], edgeMatrix[c(1,4,2,3,5,6),])
+}
+
+# nr statt data uebergeben, fitchQuartet ohne weight
+# weniger Speicher 2 Zeilen weinger
+fitch.nni <- function (tree, data, ...)
+{
+ nTips = as.integer(length(tree$tip)) # auskommentieren?
+ INDEX <- indexNNI2(tree)
+ nr = attr(data, "nr")
+ weight <- attr(data, "weight")
+ p0 <- fast.fitch(tree, nr)
+ m <- dim(INDEX)[2]
+ tmp = fnodesNew2(tree$edge, nTips, nr)
+ pscore <- .C("fitchQuartet", as.integer(INDEX), as.integer(m), as.integer(nr), as.double(tmp[[1]]), as.double(tmp[[2]]), as.double(weight), double(m))[[7]]
+ swap <- 0
+ candidates <- pscore < p0
+ while (any(candidates)) {
+ ind = which.min(pscore)
+ pscore[ind] = Inf
+ tree2 <- changeEdge(tree, INDEX[c(2,3), ind])
+ test <- fast.fitch(tree2, nr)
+ if (test >= p0)
+ candidates[ind] = FALSE
+ if (test < p0) {
+ p0 <- test
+ swap = swap + 1
+ tree <- tree2
+ indi <- which(INDEX[5,] %in% INDEX[1:5, ind])
+ candidates[indi] <- FALSE
+ pscore[indi] <- Inf
+ }
+ }
+ list(tree = tree, pscore = p0, swap = swap)
+}
+
+
+optim.fitch <- function(tree, data, trace=1, rearrangements = "SPR", ...) {
+ if(class(tree)!="phylo") stop("tree must be of class phylo")
+ if(!is.binary.tree(tree)){
+ tree <- multi2di(tree)
+ attr(tree, "order") <- NULL
+ }
+ if(is.rooted(tree)){
+ tree <- unroot(tree)
+ attr(tree, "order") <- NULL
+ }
+ if(is.null(attr(tree, "order")) || attr(tree, "order") == "cladewise") tree <- reorder(tree, "postorder")
+ if (class(data)[1] != "phyDat") stop("data must be of class phyDat")
+
+ rt = FALSE
+ nTips = as.integer(length(tree$tip))
+
+ nr = attr(data, "nr")
+ pis <- parsinfo(data)
+ p0 <- sum(attr(data, "weight")[pis[, 1]] * pis[, 2])
+ if (length(pis) > 0)
+ data <- getRows(data, c(1:nr)[-pis[, 1]], TRUE)
+
+ nr = attr(data, "nr")
+
+ data <- subset(data,tree$tip,order(attr(data, "weight"), decreasing=TRUE))
+ dat <- prepareDataFitch(data)
+ weight <- attr(data, "weight")
+
+ m = nr*(2L*nTips - 2L)
+ on.exit(.C("fitch_free"))
+ .C("fitch_init", as.integer(dat), as.integer(nTips*nr), as.integer(m), as.double(weight), as.integer(nr))
+
+ tree$edge.length=NULL
+ swap = 0
+ iter = TRUE
+ pscore <- fast.fitch(tree, nr)
+ while (iter) {
+ res <- fitch.nni(tree, dat, ...)
+ tree <- res$tree
+ if(trace>1)cat("optimize topology: ", pscore + p0, "-->", res$pscore + p0,
+ "\n")
+ pscore = res$pscore
+ swap = swap + res$swap
+ if (res$swap == 0){
+ if(rearrangements=="SPR"){
+ tree <- fitch.spr(tree, dat)
+ psc <- fast.fitch(tree, nr)
+ if(trace>1)cat("optimize topology (SPR): ", pscore + p0 , "-->", psc + p0, "\n")
+ if(pscore < psc+1e-6) iter=FALSE
+ pscore <- psc
+ }
+ else iter = FALSE
+ }
+ }
+ if(trace>0)cat("Final p-score",pscore + p0,"after ",swap, "nni operations \n")
+ if(rt)tree <- ptree(tree, data)
+ attr(tree, "pscore") = pscore + p0
+ tree
+}
+
+# branch and bound
+getOrder <- function (x)
+{
+ label = names(x)
+ dm = as.matrix(dist.hamming(x, FALSE))
+ ind = as.vector(which(dm == max(dm), arr.ind = TRUE)[1, ])
+ nTips = as.integer(length(label))
+ added = ind
+ remaining <- c(1:nTips)[-ind]
+
+ tree <- structure(list(edge = structure(c(rep(nTips+1L, 3), c(ind, 0L)), .Dim = c(3L, 2L)), tip.label = label, Nnode = 1L), .Names = c("edge", "tip.label", "Nnode"), class = "phylo", order = "postorder")
+
+ l = length(remaining)
+ res = numeric(l)
+
+ nr <- attr(x, "nr")
+ storage.mode(nr) <- "integer"
+ n <- length(x) #- 1L
+
+ data <- prepareDataFitch(x)
+ weight <- attr(data, "weight")
+ storage.mode(weight) <- "double"
+
+ m = nr*(2L*nTips - 2L)
+
+ on.exit(.C("fitch_free"))
+ .C("fitch_init", as.integer(data), as.integer(nTips*nr), as.integer(m), as.double(weight), as.integer(nr))
+
+ for(i in 1:length(remaining)){
+ tree$edge[3,2]= remaining[i]
+ res[i] = fast.fitch(tree, nr)
+ }
+ tmp = which.max(res)
+ added = c(added, remaining[tmp])
+ remaining <- remaining[-tmp]
+ tree$edge[,2]= added
+
+ for (i in 4:(nTips - 1L)) {
+ edge = tree$edge[,2]
+ score0 = fnodesNew5(tree$edge, nTips, nr)[edge]
+
+ l = length(remaining)
+ res = numeric(l)
+ nt = numeric(l)
+ k = length(added)+1L
+ for(j in 1:l){
+ score <- .Call("FITCHTRIP3", as.integer(remaining[j]), as.integer(nr), as.integer(edge), as.double(score0), as.double(Inf))
+
+# score = score0[edge] + psc
+ res[j] = min(score)
+ nt[j] = which.min(score)
+ }
+ tmp = which.max(res)
+ added = c(added, remaining[tmp])
+ tree = addOne(tree, remaining[tmp], nt[tmp])
+ remaining <- remaining[-tmp]
+ }
+ added = c(added, remaining)
+ added
+}
+
+
+bab <- function (data, tree = NULL, trace = 1, ...)
+{
+ o = order(attr(data, "weight"), decreasing = TRUE)
+ data = subset(data, , o)
+ nr <- attr(data, "nr")
+ pis <- parsinfo(data)
+ p0 <- sum(attr(data, "weight")[pis[, 1]] * pis[, 2])
+ if (length(pis) > 0)
+ data <- getRows(data, c(1:nr)[-pis[, 1]], TRUE)
+ tree <- pratchet(data, start = tree, trace = trace - 1, ...)
+ data <- subset(data, tree$tip.label)
+ nr <- as.integer(attr(data, "nr"))
+ inord <- getOrder(data)
+ lb <- lowerBound(data)
+ nTips <- m <- length(data)
+
+ nr <- as.integer(attr(data, "nr"))
+ TMP <- matrix(0, m, nr)
+ for (i in 4:m) {
+ TMP[i, ] = lowerBound(subset(data, inord[1:i]))
+ }
+
+ weight <- as.double(attr(data, "weight"))
+ data <- prepareDataFitch(data)
+ m = nr*(2L*nTips - 2L)
+ on.exit(.C("fitch_free"))
+ .C("fitch_init", as.integer(data), as.integer(nTips*nr), as.integer(m), as.double(weight), as.integer(nr))
+ mmsAmb = 0
+ mmsAmb = TMP %*% weight
+ mmsAmb = mmsAmb[nTips] - mmsAmb
+ mms0 = 0
+ mms0 = mms0 + mmsAmb
+
+ minPars = mms0[1]
+ kPars = 0
+
+ if (trace)
+ print(paste("lower bound:", p0 + mms0[1]))
+ bound <- fast.fitch(tree, nr)
+ if (trace)
+ print(paste("upper bound:", bound + p0))
+
+ startTree <- structure(list(edge = structure(c(rep(nTips+1L, 3), as.integer(inord)[1:3]), .Dim = c(3L, 2L)),
+ tip.label = tree$tip.label, Nnode = 1L), .Names = c("edge", "tip.label", "Nnode"), class = "phylo", order = "postorder")
+
+ trees <- vector("list", nTips)
+ trees[[3]] <- list(startTree$edge)
+ for(i in 4:nTips) trees[[i]] <- vector("list", (2L*i) - 5L) # new
+
+# index M[i] is neues node fuer edge i+1
+# index L[i] is length(node) tree mit i+1
+ L = as.integer( 2L*(1L:nTips) -3L )
+ M = as.integer( 1L:nTips + nTips - 1L )
+
+ PSC <- matrix(c(3,1,0), 1, 3)
+ PSC[1,3] <- fast.fitch(startTree, nr)
+
+ k = 4L
+ Nnode = 1L
+ npsc = 1
+
+ result <- list()
+ while (npsc > 0) {
+ a = PSC[npsc,1]
+ b = PSC[npsc,2]
+ PSC = PSC[-npsc,, drop=FALSE]
+
+ tmpTree <- trees[[a]][[b]]
+ edge = tmpTree[,2]
+ score = fnodesNew5(tmpTree, nTips, nr)[edge] + mms0[a+1L]
+ score <- .Call("FITCHTRIP3", as.integer(inord[a+1L]), as.integer(nr), as.integer(edge), as.double(score), as.double(bound))
+
+ ms = min(score)
+ if(ms<=bound){
+ if((a+1L)<nTips){
+ ind = (1:L[a])[score<=bound]
+ for(i in 1:length(ind))trees[[a+1]][[i]] <- .Call("AddOne", tmpTree, as.integer(inord[a+1L]), as.integer(ind[i]), as.integer(L[a]), as.integer(M[a]))
+ l = length(ind)
+ os = order(score[ind], decreasing=TRUE)
+ PSC = rbind(PSC, cbind(rep(a+1, l), os, score[ind][os] ))
+ }
+ else{
+ ind = which(score==ms)
+ tmp <- vector("list", length(ind))
+ for(i in 1:length(ind))tmp[[i]] <- .Call("AddOne", tmpTree, as.integer(inord[a+1L]), as.integer(ind[i]), as.integer(L[a]), as.integer(M[a]))
+
+ if(ms < bound){
+ bound = ms
+ if(trace)cat("upper bound:", bound, "\n")
+ result = tmp
+ PSC = PSC[PSC[,3]<(bound+1e-8),]
+
+ }
+ else result = c(result, tmp)
+ }
+ }
+ npsc = nrow(PSC)
+ }
+ for(i in 1:length(result)){
+ result[[i]] = structure(list(edge = result[[i]], Nnode = nTips-2L), .Names = c("edge", "Nnode"), class = "phylo", order = "postorder")
+ }
+ attr(result, "TipLabel") = tree$tip.label
+ class(result) <- "multiPhylo"
+ return(result)
+}
+
diff --git a/R/hadamard.R b/R/hadamard.R
new file mode 100644
index 0000000..533ac8f
--- /dev/null
+++ b/R/hadamard.R
@@ -0,0 +1,201 @@
+dec2Bin = function (x)
+{
+ res = NULL
+ i = 1L
+ while (x > 0) {
+ if (x%%2L)
+ res = c(res, i)
+ x = x%/%2L
+ i = i + 1L
+ }
+ res
+}
+
+
+# returns binary (0, 1) vector of length k
+dec2bin <- function (x, k=ceiling(log2(x)))
+{
+ i = 1L
+ res = integer(k)
+ while (x > 0) {
+ if (x%%2L)
+ res[i] = 1L
+ x = x%/%2L
+ i = i + 1L
+ }
+ res
+}
+
+# double factorial: log version
+"ldfactorial" <- function(x){
+ x = (x+1)/2
+ res = lgamma(2*x)-(lgamma(x)+(x-1)*log(2))
+ res
+}
+
+# double factorial
+"dfactorial" <- function(x){exp(ldfactorial(x))}
+
+
+#
+# Hadamard Conjugation
+#
+
+hadamard <- function(x){
+ res=1
+ while(x>0){
+ res=rbind(cbind(res,res),cbind(res,-res))
+ x=x-1
+ }
+ res
+}
+
+
+fhm <- function(v){
+ n = length(v)
+ n = log2(n)
+ res = .C("C_fhm", v = as.double(v), n = as.integer(n))$v #
+ res
+}
+
+
+seq2split = function(s){
+ n=length(s)
+ res= fhm(log(fhm(s)))/n
+ res
+}
+
+
+split2seq = function(q){
+ n=length(q)
+ res= fhm(exp(fhm(q)))/n
+ res
+}
+
+
+distanceHadamard <- function (dm, eps = 0.001)
+{
+ if (class(dm) == "dist") {
+ n <- attr(dm, "Size")
+ Labels = attr(dm, "Labels")
+ }
+ if (class(dm) == "matrix") {
+ n <- dim(dm)[1]
+ Labels <- colnames(dm)
+ dm <- dm[lower.tri(dm)]
+ }
+ ns <- 2^(n - 1)
+ if (n > 23)
+ stop("Hadamard conjugation works only efficient for n < 24")
+ result <- .Call("dist2spectra", dm, as.integer(n), as.integer(ns),
+ PACKAGE = "phangorn")
+ weights = -fhm(result)/2^(n - 2)
+
+ if(eps>0){
+ weights = weights[-1]
+ ind2 = which(weights>eps)
+ n2 = length(ind2)
+ splits = vector("list", n2)
+ for(i in 1:n2)splits[[i]] = dec2Bin(ind2[i])
+ attr(splits, "weights") = weights[ind2]
+ attr(splits, "labels") = Labels
+ attr(splits, 'dm') = dm
+ class(splits)='splits'
+ return(splits)
+ }
+ res <- data.frame(distance = result, edges = weights, index = 0:(ns - 1))
+ attr(res, "Labels") <- Labels
+ res
+}
+
+
+h4st = function(obj, levels=c('a','c','g','t')){
+ if (is.matrix(obj))
+ obj = as.data.frame(t(obj))
+ if (class(obj) == "phyDat")
+ obj = as.data.frame(t(as.character(obj)))
+ # if(is.matrix(obj)) obj = as.data.frame(t(obj))
+ # DNA = as.data.frame(obj)
+ # DNA = t(as.character(obj))
+
+ n = dim(obj)[1]
+ p = dim(obj)[2]
+
+ if(p>11) stop("4-state Hadamard conjugation works only efficient for n < 12")
+
+ DNAX = matrix(0,n,p)
+ DNAY = matrix(0,n,p)
+
+ DNAX[obj==levels[1]]=0
+ DNAX[obj==levels[2]]=1
+ DNAX[obj==levels[3]]=1
+ DNAX[obj==levels[4]]=0
+
+ DNAY[obj==levels[1]]=0
+ DNAY[obj==levels[2]]=1
+ DNAY[obj==levels[3]]=0
+ DNAY[obj==levels[4]]=1
+
+ DNAY = DNAY - DNAY[,p]
+ DNAX = DNAX - DNAX[,p]
+
+ DNAY = abs(DNAY[,-p])
+ DNAX = abs(DNAX[,-p])
+ dy = DNAY %*% (2^(0:(p-2)))
+ dx = DNAX %*% (2^(0:(p-2)))
+
+ INDEX = dx + 2^(p-1) * dy
+ blub = table(INDEX)
+ index = as.numeric(rownames(blub)) + 1
+ sv = numeric(4^(p-1))
+ sv[index] = blub
+ qv = matrix(seq2split(sv),2^(p-1),2^(p-1))
+ sv = matrix(sv,2^(p-1),2^(p-1))
+ # q = cbind(transversion = qv[-1,1], transition.1 = diag(qv)[-1], transition.2 = qv[1,-1])
+ transversion <- transition.1 <- transition.2 <- allSplits(p, colnames(obj))
+ attr(transversion,"weights") = qv[-1,1]
+ attr(transition.1,"weights") = diag(qv)[-1]
+ attr(transition.2,"weights") = qv[1,-1]
+ # result = list(q = q, qv = qv, sv=sv, n=sum(sv), names=names(obj))
+ result = list(transversion = transversion, transition.1=transition.1, transition.2 = transition.2,
+ qv = qv, sv=sv, n=sum(sv), names=names(obj))
+ result
+}
+
+
+h2st <- function (obj, eps=0.001)
+{
+ if (class(obj) != "phyDat") stop("Error")
+ if (attr(obj,"nc") != 2)stop("Error")
+ nr = attr(obj, "nr") #n
+ p = length(obj) #p
+ weight = attr(obj, "weight")
+ if (p > 23)
+ stop("Hadamard conjugation works only efficient for n < 24")
+ DNAX = matrix(0, nr, p-1)
+ for(i in 1:(p-1)) DNAX[,i] = obj[[i]]-1
+ DNAX[obj[[p]]==2,] = 1 - DNAX[obj[[p]]==2,]
+
+ index = DNAX %*% (2^(0:(p - 2))) + 1
+ sv = numeric(2^(p - 1))
+ for(i in 1:nr)sv[index[i]] = sv[index[i]]+ weight[i]
+ qv = seq2split(sv)
+
+ if(eps>0){
+ qv = qv[-1]
+ ind2 = which(qv>eps)
+ indT= c(2L^(0:(p-2)), 2L^(p-1)-1)
+ ind2 = union(ind2, indT)
+ n2 = length(ind2)
+ splits = vector("list", n2)
+ for(i in 1:n2)splits[[i]] = dec2Bin(ind2[i])
+ attr(splits, "weights") = qv[ind2]
+ attr(splits, "labels") = names(obj)
+ class(splits)='splits'
+ return(splits)
+ }
+ result = data.frame(edges = qv, splits = sv, index = 0:(2^(p -
+ 1) - 1))
+ attr(result, "Labels") = names(obj)
+ result
+}
diff --git a/R/neighborNet.R b/R/neighborNet.R
new file mode 100644
index 0000000..a2d3fe5
--- /dev/null
+++ b/R/neighborNet.R
@@ -0,0 +1,196 @@
+# computes all n(n-1)/2 cyclic splits
+cyclicSplits <- function(k, labels=NULL){
+ k = as.integer(k)
+ l = (k-1L) %/% 2L
+ res <- vector("list", k*(k-1L)/2)
+ res[1:k] = 1L:k
+ ind = k
+ if(k>3){
+ fun = function(x,y){
+ tmp = (1L:y)+x
+ tmp %% (k+1L) + tmp %/% (k+1L)
+ }
+ for(i in 2:l){
+ res[(ind+1):(ind+k)] <- lapply(0L:(k-1L), fun, i)
+ ind <- ind+k
+ }
+ if((k%%2L)==0){
+ m <- k%/%2
+ res[(ind+1):(ind+m)] <- lapply(0L:(m-1L), fun, m)
+ }
+ }
+ if(is.null(labels)) labels=(as.character(1:k))
+ attr(res, 'labels') =labels
+ class(res)="splits"
+ res
+}
+
+
+distC <- function(d, CL){
+ l=length(CL)
+ res = matrix(0, l, l)
+ for(i in 1:(l-1)){
+ for(j in (i+1):l)
+ res[i,j] = mean.default(d[CL[[i]], CL[[j]]])
+ }
+ res + t(res)
+}
+
+
+reduc <- function(d, x, y, z){
+ u <- 2/3* d[x, ] + d[y,]/3
+ v <- 2/3* d[z, ] + d[y,]/3
+ uv <- (d[x,y] + d[x,z] + d[y,z])/3
+ d[x, ] <- u
+ d[, x] <- u
+ d[z, ] <- v
+ d[, z] <- v
+
+ d[y, ] <- 0
+ d[, y] <- 0
+
+ d[x, z] <- d[z, x] <- uv
+ diag(d) <- 0
+ d
+}
+
+
+# computes ordering
+getOrderingNN <- function (x)
+{
+ x = as.matrix(x)
+ labels <- attr(x, "Labels")
+ if (is.null(labels))
+ labels = colnames(x)
+ d = x #as.matrix(x)
+ l = dim(d)[1]
+ CL = vector("list", l)
+ CL[1:l] <- ORD <- 1:l
+ lCL <- length(CL)
+ ord <- CL
+ while (lCL>1){
+ i = 0
+ j = 0
+ # browser()
+ DM = distC(d, CL)
+ l = nrow(DM)
+ if(l>2){
+ r = rowSums(DM)/(l - 2)
+ tmp <- .C("out", as.double(DM), as.double(r), as.integer(l),
+ as.integer(i), as.integer(j), PACKAGE = "phangorn")
+ e1 = tmp[[4]]
+ e2 = tmp[[5]]
+ }
+ else {e1 = 1
+ e2=2}
+ n1 <- length(CL[[e1]])
+ n2 <- length(CL[[e2]])
+ if(n1==1 & n2==1){
+ newCL <- c(CL[[e1]], CL[[e2]])
+ newOrd = newCL
+ CL = c(CL[-c(e1,e2)], list(newCL))
+ ord <- c(ord[-c(e1,e2)], list(newCL))
+ lCL <- lCL - 1L
+ }
+ else{
+ CLtmp = c(as.list(CL[[e1]]), as.list(CL[[e2]]), CL[-c(e1,e2)])
+ ltmp =length(CLtmp)
+ DM2 = distC(d, CLtmp)
+ if(ltmp>2) rtmp = rowSums(DM2)/(ltmp - 2)
+ DM2 = DM2 - outer(rtmp, rtmp, "+")
+
+ TMP = DM2[1:n1, (n1+1):(n1+n2)]
+#browser()
+# dtmp = d[CL[[e1]], CL[[e2]]]
+# rtmp = numeric(n1+n2)
+# for(ii in 1:(n1+n2)){
+# for(jj in 1:ltmp){if(ii!=jj) rtmp[ii]=rtmp[ii] + mean.default(d[CLtmp[[ii]], CLtmp[[jj]]])
+# }
+# }
+#browser()
+# rtmp = rtmp/(ltmp-2)
+# TMP2 = dtmp + rep(rtmp[1:n1],n2) + rep(rtmp[(n1+1):(n1+n2)], each=n1)
+
+#browser()
+
+ blub = which.min(TMP)
+# print(blub)
+#print("blub")
+ if(n1==2 & n2==1){
+ if(blub == 2){
+ newCL <- c(CL[[e1]][1], CL[[e2]])
+ newOrd <- c(CL[[e1]], ord[[e2]])
+ d <- reduc(d, CL[[e1]][1], CL[[e1]][2], CL[[e2]])
+ }
+ else{
+ newCL <- c(CL[[e2]], CL[[e1]][2])
+ newOrd <- c(ord[[e2]], ord[[e1]])
+ d <- reduc(d, CL[[e2]], CL[[e1]][1], CL[[e1]][2])
+ }
+
+
+ }
+ if(n1==1 & n2==2){
+ if(blub==1){
+ newCL <- c(CL[[e1]], CL[[e2]][2])
+ newOrd <- c(CL[[e1]], ord[[e2]])
+ d <- reduc(d, CL[[e1]], CL[[e2]][1], CL[[e2]][2])
+ }
+ else{
+ newCL <- c(CL[[e2]][1], CL[[e1]])
+ newOrd <- c(ord[[e2]], ord[[e1]])
+ d <- reduc(d, CL[[e2]][1], CL[[e2]][2], CL[[e1]])
+ }
+ }
+ if(n1==2 & n2==2){
+ if(blub==1){
+ newCL <- c(CL[[e1]][2], CL[[e2]][2])
+ newOrd <- c(rev(ord[[e1]]), ord[[e2]])
+ d <- reduc(d, CL[[e1]][2], CL[[e1]][1], CL[[e2]][1])
+ d <- reduc(d, CL[[e1]][2], CL[[e2]][1], CL[[e2]][2])
+ }
+ if(blub==2){
+ newCL <- c(CL[[e1]][1], CL[[e2]][2])
+ newOrd <- c(ord[[e1]], ord[[e2]])
+ d <- reduc(d, CL[[e1]][1], CL[[e1]][2], CL[[e2]][1])
+ d <- reduc(d, CL[[e1]][1], CL[[e2]][1], CL[[e2]][2])
+
+ }
+ if(blub==3){
+ newCL <- c(CL[[e1]][2], CL[[e2]][1])
+ newOrd <- c(rev(ord[[e1]]), rev(ord[[e2]]))
+ d <- reduc(d, CL[[e1]][2], CL[[e1]][1], CL[[e2]][2])
+ d <- reduc(d, CL[[e1]][2], CL[[e2]][2], CL[[e2]][1])
+ }
+ if(blub==4){
+ newCL <- c(CL[[e1]][1], CL[[e2]][1])
+ newOrd <- c(ord[[e1]], rev(ord[[e2]]))
+ d <- reduc(d, CL[[e1]][1], CL[[e1]][2], CL[[e2]][2])
+ d <- reduc(d, CL[[e1]][1], CL[[e2]][2], CL[[e2]][1])
+ }
+ }
+ CL <- c(CL[-c(e1,e2)], list(newCL))
+ ord <- c(ord[-c(e1,e2)], list(newOrd))
+ lCL <- lCL - 1L
+ }
+ }
+ newOrd
+}
+
+#
+neighborNet <- function(x, ord=NULL){
+ x = as.matrix(x)
+ labels <- attr(x, "Labels")[[1]]
+ if (is.null(labels))
+ labels = colnames(x)
+ l <- length(labels)
+#browser()
+ if(is.null(ord))ord <- getOrderingNN(x)
+ spl <- cyclicSplits(l, labels[ord])
+ spl <- nnls.splits(spl, x)
+ # nnls.split mit nnls statt quadprog
+ attr(spl, "cycle") <- 1:l
+ as.networx(spl)
+}
+
+
diff --git a/R/networx.R b/R/networx.R
new file mode 100644
index 0000000..6b5eb6f
--- /dev/null
+++ b/R/networx.R
@@ -0,0 +1,1435 @@
+#
+# splits format, networx, Matrix, lento plot
+#
+as.splits <- function (x, ...){
+ if(inherits(x, "splits")) return(x)
+ UseMethod("as.splits")
+}
+
+
+as.Matrix <- function (x, ...){
+ if (class(x) == "Matrix") return(x)
+ UseMethod("as.Matrix")
+}
+
+
+as.matrix.splits <- function(x, zero.print = 0L, one.print=1L, ...){
+ m = length(x)
+ labels = attr(x, "labels")
+ n = length(labels)
+ res = matrix(zero.print, m, n)
+ for(i in 1:m)res[i,x[[i]]]=one.print
+ dimnames(res) = list(names(x), labels)
+ res
+}
+
+
+as.Matrix.splits <- function(x, ...){
+ labels = attr(x, "labels")
+ l = length(x)
+ j = unlist(x)
+ i = rep(1:l, sapply(x, length))
+ sparseMatrix(i,j, x = rep(1L, length(i)), dimnames = list(NULL, labels)) # included x und labels
+}
+
+
+print.splits <- function (x, maxp = getOption("max.print"),
+ zero.print = ".", one.print="|", ...)
+{
+ x.orig <- x
+ cx <- as.matrix(x, zero.print = zero.print, one.print=one.print)
+ print(cx, quote = FALSE, right = TRUE, max = maxp)
+ invisible(x.orig)
+}
+
+
+"[.splits" = function(x, i){
+ tmp = attributes(x)
+ result = unclass(x)[i]
+ if(!is.null(tmp$weights)) tmp$weights = tmp$weights[i]
+ if(!is.null(tmp$confidences)) tmp$confidences = tmp$confidences[i]
+ if(!is.null(tmp$intervals)) tmp$intervals = tmp$intervals[i]
+ if(!is.null(tmp$data)) tmp$data = tmp$data[i,, drop=FALSE]
+ attributes(result) = tmp
+ result
+}
+
+
+orderSplitLabel = function(x, order){
+ label = attr(x, "labels")
+ nTips = length(label)
+ ord = match(label, order)
+ for(i in 1:length(x))
+ x[[i]] = sort(ord[x[[i]]])
+ attr(x, "labels") = order
+ x
+}
+
+
+presenceAbsence <- function(x, y){
+ X <- as.splits(x)
+ Y <- as.splits(y)
+ labels <- attr(X, "labels")
+ if(class(x)[1] == "phylo") X <- X[x$edge[,2]]
+ if(class(y)[1] == "phylo") Y <- Y[y$edge[,2]]
+ Y <- orderSplitLabel(Y, labels)
+ nTips <- length(labels)
+ X <- oneWise(X, nTips)
+ Y <- oneWise(Y, nTips)
+ res <- match(X, Y)
+ res <- !is.na(res)
+ if(inherits(x, "networx")){
+ res <- res[x$splitIndex]
+ }
+ res
+}
+
+
+optCycle <- function(splits, tree){
+ tips = tree$tip.label
+ tree = reorder(tree)
+ nodes = sort(unique(tree$edge[,1]))
+
+ M = as.matrix(splits)
+
+ l = as.integer(nrow(M))
+ m = as.integer(ncol(M))
+
+ tmp = tree$edge[,2]
+ tmp = tmp[tmp<=m]
+
+ start <- .C("countCycle", M[, tmp], l, m, integer(1))[[4]]
+ best = start
+ eps = 1
+ if(eps>0){
+ for(i in 1:length(nodes)){
+ tmptree = rotate(tree, nodes[i])
+ tmp = tmptree$edge[,2]
+ tmp = tmp[tmp<=m]
+ tmpC <- .C("countCycle", M[, tmp], l, m, integer(1))[[4]]
+ if(tmpC < best){
+ best <- tmpC
+ tree = tmptree
+ }
+ }
+ eps = start - best
+ }
+ tree # list(best, tree)
+}
+
+
+countCycles <- function(splits, tree=NULL, ord=NULL){
+ M = as.matrix(splits)
+ l = as.integer(nrow(M))
+ m = as.integer(ncol(M))
+ if(!is.null(tree)) ord = getOrdering(tree)
+ res <- .C("countCycle2", M[, ord], l, m, integer(l))[[4]]
+ res
+}
+
+
+c.splits <- function (..., recursive=FALSE)
+{
+ x <- list(...)
+ n <- length(x)
+ match.names <- function(a, b) {
+ if (any(!(a %in% b)))
+ stop("names do not match previous names")
+ }
+ if (n == 1)
+ return(x[[1]])
+
+ labels <- attr(x[[1]], "labels")
+ cycle <- attr(x[[1]], "cycle")
+ for (i in 2:n) {
+ match.names(labels, attr(x[[i]], "labels"))
+ }
+ res = structure(NextMethod("c"), class=c("splits", "prop.part"))
+ attr(res, "labels") = labels
+ attr(res, "weight") = as.vector(sapply(x, attr, "weight"))
+ attr(res, "cycle") = cycle
+ res
+}
+
+
+# computes splits from phylo
+as.splits.phylo <- function(x, ...){
+ result = bip(x)
+ if(!is.null(x$edge.length)){
+ edge.weights = numeric(max(x$edge))
+ edge.weights[x$edge[,2]] = x$edge.length
+ attr(result, "weights") = edge.weights
+ }
+ attr(result, "labels") <- x$tip
+ class(result) = c('splits', 'prop.part')
+ result
+}
+
+
+# computes splits from multiPhylo object (e.g. bootstrap, MCMC etc.)
+as.splits.multiPhylo <- function(x, ...){
+ if(class(x)=="multiPhylo")x = .uncompressTipLabel(x)
+ lx = length(x)
+ if(class(x)=="multiPhylo")class(x)='list' # prop.part allows not yet multiPhylo
+ firstTip = x[[1]]$tip[1]
+ x = lapply(x, root, firstTip) # old trick
+ splits <- prop.part(x)
+ class(splits)='list'
+ weights = attr(splits, 'number')
+ lab = attr(splits,'labels')
+ attr(splits,'labels') <- attr(splits, 'number') <- NULL
+ l = length(lab)
+ splitTips = vector('list', l)
+ for(i in 1:l) splitTips[[i]] = i
+ result = c(splitTips,splits)
+ attr(result, "weights") = c(rep(lx, l), weights)
+ attr(result, "confidences") <- attr(result, "weights")
+ attr(result, "labels") <- lab
+ class(result) = c('splits', 'prop.part')
+ result
+}
+
+
+as.splits.prop.part <- function(x, ...){
+ if(is.null(attr(x, "number")))
+ attr(x, "weights") = rep(1, length(x))
+ else{
+ attr(x, "weights") = attr(x, "number")
+ attr(x, "confidences") = attr(x, "number")
+ }
+ class(x) = c('splits', 'prop.part')
+ x
+}
+
+
+as.splits.networx <- function(x, ...){
+ if(!is.null(attr(x, "splits")))attr(x, "splits")
+ else warning("No split object included!")
+}
+
+
+as.prop.part.splits <- function(x, ...){
+ attr(x, "number") = attr(x, "weights")
+ attr(x, "weights") = NULL
+ class(x) = c('prop.part')
+ x
+}
+
+
+as.phylo.splits <- function (x, result = "phylo", ...)
+{
+ result <- match.arg(result, c("phylo", "all"))
+ labels = attr(x, "labels")
+ nTips = length(labels)
+ weights = attr(x, "weights")
+ nTips = length(labels)
+ x = SHORTwise(x, nTips)
+ dm = as.matrix(compatible(x))
+ rs = rowSums(dm)
+ ind = which(rs == 0)
+ if (any(rs > 0)) {
+ tmp = which(rs > 0)
+ candidates = tmp[order(rs[tmp])]
+ for (i in candidates) {
+ if (sum(dm[ind, i]) == 0)
+ ind = c(ind, i)
+ }
+ }
+ splits = x[ind]
+ weights = weights[ind]
+ l = length(ind)
+ res = matrix(0L, l, nTips)
+ for (i in 1:l) res[i, splits[[i]]] = 1L
+ dm2 = (crossprod(res * weights, 1 - res))
+ dm2 = dm2 + t(dm2)
+ dimnames(dm2) = list(labels, labels)
+ tree <- di2multi(NJ(dm2), tol = 1e-08)
+ attr(tree, "order") = NULL
+ tree <- reorder(tree)
+ tree <- optCycle(x, tree)
+ tree <- reorder(tree, "postorder")
+ if (result == "phylo")
+ return(tree)
+# tree = reroot(tree, Ancestors(tree, 1, "parent"))
+ spl = as.splits(tree)
+ spl = SHORTwise(spl, nTips)
+ spl <- spl[tree$edge[,2]]
+ list(tree = tree, index = tree$edge[, 2], split = spl, rest = x[-ind])
+}
+
+
+# computes compatible splits
+compatible <- function(obj){
+ labels = attr(obj, "labels")
+ if(!inherits(obj, "splits"))stop("obj needs to be of class splits")
+
+ l = length(labels)
+ n = length(obj)
+
+ bp = matrix(0L, n, l)
+ for(i in 1:n)bp[i,obj[[i]]] = 1L
+ bp[bp[, 1] == 0L, ] = 1L - bp[bp[, 1] == 0L, ]
+ k=1
+ res = matrix(0L, n, n)
+
+ tmp1 = tcrossprod(bp) #sum(bp[i,]* bp[j,])
+ tmp2 = tcrossprod(1L - bp) #sum((1L - bp[i,])*(1L - bp[j,]))
+ tmp3 = tcrossprod(bp, 1L - bp) #sum(bp[i,]*(1L - bp[j,]))
+ tmp4 = tcrossprod(1L - bp, bp) #sum((1L - bp[i,])*bp[j,])
+ res[(tmp1 * tmp2 * tmp3 * tmp4)>0]=1L
+ k = k+1
+
+ res = res[lower.tri(res)]
+ attr(res, "Size") <- n
+ attr(res, "Diag") <- FALSE
+ attr(res, "Upper") <- FALSE
+ class(res) <- "dist"
+ return(res)
+}
+
+
+compatible2 <- function (obj1, obj2=NULL)
+{
+ if (!inherits(obj1, "splits"))
+ stop("obj needs to be of class splits")
+ labels = attr(obj1, "labels")
+ l = length(labels)
+ n = length(obj1)
+ bp1 = as.matrix(obj1)
+ bp1[bp1[, 1] == 0L, ] = 1L - bp1[bp1[, 1] == 0L, ]
+ if(!is.null(obj2)){
+ m = length(obj2)
+ bp2 = as.matrix(obj2)
+ labels2 = attr(obj2, "labels")
+ bp2 = bp2[, match(labels2, labels), drop=FALSE]
+ bp2[bp2[, 1] == 0L, ] = 1L - bp2[bp2[, 1] == 0L, ]
+ }
+ else bp2 = bp1
+
+ if(is.null(obj2)) res = matrix(0L, n, n)
+ else res = matrix(0L, n, m)
+
+ tmp1 = tcrossprod(bp1, bp2)
+ tmp2 = tcrossprod(1L - bp1, 1L - bp2)
+ tmp3 = tcrossprod(bp1, 1L - bp2)
+ tmp4 = tcrossprod(1L - bp1, bp2)
+ res[(tmp1 * tmp2 * tmp3 * tmp4) > 0] = 1L
+ if(is.null(obj2)){
+ res = res[lower.tri(res)]
+ attr(res, "Size") <- n
+ attr(res, "Diag") <- FALSE
+ attr(res, "Upper") <- FALSE
+ class(res) <- "dist"
+ }
+ return(res)
+}
+
+
+compatible3 <- function(x, y=NULL)
+{
+ if (!inherits(x, "splits"))
+ stop("x needs to be of class splits")
+ if(is.null(y)) y <- x
+
+ if (!inherits(y, "splits"))
+ stop("y needs to be of class splits")
+ xlabels = attr(x, "labels")
+ ylabels = attr(y, "labels")
+ if(identical(xlabels, ylabels)) labels = xlabels
+ else labels = intersect(xlabels, ylabels)
+# if(length(labels) maybe warning
+ nx = length(x)
+ ny = length(y)
+ bp1 = as.matrix(x)[,labels, drop=FALSE]
+ bp2 = as.matrix(y)[,labels, drop=FALSE]
+ rs1 = rowSums(bp1)
+ rs2 = rowSums(bp2)
+ res = matrix(0L, nx, ny)
+ tmp1 = tcrossprod(bp1, bp2)
+ res = matrix(0L, nx, ny)
+ for(i in 1:nx){
+ for(j in 1:ny){
+ if(tmp1[i, j]==rs1[i]) res[i,j] = 1
+ if(tmp1[i, j]==rs2[j]) res[i,j] = 2
+ if(tmp1[i, j]==rs1[i] & tmp1[i, j]==rs2[j])res[i,j] = 3
+ }
+ }
+ if(is.null(y)){
+ res = res[lower.tri(res)]
+ attr(res, "Size") <- length(x)
+ attr(res, "Diag") <- FALSE
+ attr(res, "Upper") <- FALSE
+ class(res) <- "dist"
+ }
+ return(res)
+}
+
+
+#
+# splits
+#
+splitsNetwork <- function(dm, splits=NULL, gamma=.1, lambda=1e-6, weight=NULL){
+ dm = as.matrix(dm)
+ k = dim(dm)[1]
+
+ if(!is.null(splits)){
+ tmp = which(sapply(splits, length)==k)
+ splits = splits[-tmp]
+ lab = attr(splits, "labels")
+ dm = dm[lab, lab]
+ }
+
+ if(is.null(splits)){
+ X2 = designAll(k, TRUE)
+ X=X2[[1]]
+ }
+ else X = as.matrix(splits2design(splits))
+
+ y = dm[lower.tri(dm)]
+ if(is.null(splits))ind = c(2^(0:(k-2)),2^(k-1)-1)
+ else ind = which(sapply(splits, length)==1)
+ # y2 = lm(y~X[,ind]-1)$res
+ n = dim(X)[2]
+
+ ridge <- lambda * diag(n)
+ ridge[ind,ind] <- 0
+ if(!is.null(weight)) Dmat <- crossprod(X * sqrt(weight)) + ridge
+ else Dmat <- crossprod(X) + ridge
+ if(!is.null(weight)) dvec <- crossprod(X * sqrt(weight),y * sqrt(weight))
+ else dvec <- crossprod(X, y)
+
+ # Dmat <- as.matrix(Dmat)
+ # dvec <- as.vector(dvec)
+
+ ind1 <- rep(1,n)
+ ind1[ind] <- 0
+
+ Amat <- cbind(ind1,diag(n))
+ bvec <- c(gamma, rep(0,n))
+
+ solution <- quadprog::solve.QP(Dmat,dvec,Amat,bvec=bvec, meq=1)$sol
+
+ ind2 <- which(solution>1e-8)
+ n2 <- length(ind2)
+
+ ind3 = which(duplicated(c(ind2, ind), fromLast = TRUE)[1:n2])
+ ridge2 <- lambda * diag(n2)
+ ridge2[ind3,ind3] <- 0
+
+ if(!is.null(weight)) Dmat <- crossprod(X[, ind2] * sqrt(weight)) + ridge2
+ else Dmat <- crossprod(X[, ind2]) + ridge2
+ if(!is.null(weight)) dvec <- crossprod(X[, ind2] * sqrt(weight),y * sqrt(weight))
+ else dvec <- crossprod(X[, ind2], y)
+
+ Amat2 <- diag(n2)
+ bvec2 <- rep(0, n2)
+ solution2 <- quadprog::solve.QP(Dmat, dvec, Amat2)$sol
+
+ RSS1 = sum((y-X[,ind2]%*%solution[ind2])^2)
+ RSS2 = sum((y-X[,ind2]%*%solution2)^2)
+
+ if(is.null(splits)){
+ splits = vector("list", length(ind2))
+ for(i in 1:length(ind2))splits[[i]] = which(X2[[2]][ind2[i],]==1)
+ }
+ else splits = splits[ind2]
+ attr(splits, "weights") = solution[ind2]
+ attr(splits, "unrestricted") = solution2
+ attr(splits, "stats") = c(df=n2, RSS_p = RSS1, RSS_u=RSS2)
+ attr(splits,"labels") =dimnames(dm)[[1]]
+ class(splits)='splits'
+ return(splits)
+}
+
+
+allSplits = function(k, labels=NULL){
+ result <- lapply(1:(2^(k-1)-1),dec2Bin)
+ if(is.null(labels)) labels=(as.character(1:k))
+ attr(result, 'labels') =labels
+ class(result)='splits'
+ result
+}
+
+
+allCircularSplits <- function(k, labels=NULL){
+ k = as.integer(k)
+ l = (k-1L) %/% 2L
+ res <- vector("list", k*(k-1L)/2)
+
+ res[1:k] = 1L:k
+ ind = k
+ if(k>3){
+ fun = function(x,y){
+ tmp = (1L:y)+x
+ tmp %% (k+1L) + tmp %/% (k+1L)
+ }
+ for(i in 2:l){
+ res[(ind+1):(ind+k)] <- lapply(0L:(k-1L), fun, i)
+ ind <- ind+k
+ }
+ if((k%%2L)==0){
+ m <- k%/%2
+ res[(ind+1):(ind+m)] <- lapply(0L:(m-1L), fun, m)
+ }
+
+ }
+ if(is.null(labels)) labels=(as.character(1:k))
+ attr(res, 'labels') =labels
+ class(res)="splits"
+ res
+}
+
+
+getIndex = function(left, right, n){
+ if(n<max(left) | n<max(right)) stop("Error")
+ left = as.integer(left)
+ right = as.integer(right)
+ ll = length(left)
+ lr = length(right)
+ .C("giveIndex", left, right, ll, lr, as.integer(n), integer(ll*lr))[[6]]+1
+}
+
+
+splits2design <- function(obj, weight=NULL){
+ labels= attr(obj,'labels')
+ m = length(labels)
+ n=length(obj)
+ l = 1:m
+ sl = sapply(obj, length)
+ p0 = sl * (m-sl)
+ p = c(0,cumsum(p0))
+ i = numeric(max(p))
+ for(k in 1:n){
+ sp = obj[[k]]
+ if(p0[k]!=0) i[(p[k]+1):p[k+1]] = getIndex(sp, l[-sp], m)
+ }
+ dims=c(m*(m-1)/2,n)
+ sparseMatrix(i=i, p=p, x=1.0, dims=dims)
+}
+
+
+addEdge <- function(network, desc, spl){
+ edge <- network$edge
+ parent <- edge[,1]
+ child <- edge[,2]
+ nTips <- length(network$tip.label)
+
+ desc2 = SHORTwise(desc, nTips)
+ split <- desc2[spl]
+
+ index = network$splitIndex
+ ind = which(compatible2(split, desc2[index]) == 1)
+ if(is.null(ind)) return(network)
+ add = TRUE
+
+ X = as.matrix(desc2)
+ rsX = rowSums(X)
+ z = X %*% X[spl,]
+ v = which((rsX == z)[index] == TRUE)
+
+ while(add){
+ tmp = ind
+ for(i in ind){
+ tmp2 = which(compatible2(desc2[index][i], desc2[index]) == 1)
+ tmp = union(tmp, tmp2)
+ }
+ if(identical(ind, tmp)){
+ ind=tmp
+ add=FALSE
+ }
+ ind=tmp
+ }
+ oldNodes = unique(as.vector(edge[ind,]))
+ mNodes = max(network$edge)
+ newNodes = (mNodes+1L) : (mNodes+length(oldNodes))
+
+# duplicated splits
+ dSpl = edge[ind,]
+ edge2 = edge[v,]
+ for(i in 1:length(oldNodes)){
+ edge2[edge2 == oldNodes[i]] = newNodes[i]
+ }
+ edge[v,] = edge2
+
+ #alle Splits verdoppeln
+ for(i in 1:length(oldNodes)) dSpl[dSpl==oldNodes[i]] = newNodes[i]
+ edge = rbind(edge, dSpl, deparse.level = 0) # experimental: no labels
+ index = c(index, index[ind])
+ #neu zu alt verbinden
+ edge = rbind(edge, cbind(oldNodes, newNodes), deparse.level = 0)
+ index = c(index, rep(spl, length(oldNodes)) )
+ network$splitIndex = index
+ network$edge = edge
+ network$Nnode = max(edge) - nTips
+ network
+}
+
+
+circNetwork <- function(x, ord=NULL){
+ if(is.null(ord))ord = attr(x, "cycle")
+
+ weight <- attr(x, "weights")
+ if(is.null(weight)) weight = rep(1, length(x))
+ nTips = length(ord)
+ tmp = which(ord == 1)
+ if(tmp!=1) ord = c(ord[tmp:nTips], ord[1:(tmp-1)])
+ res = stree(nTips, tip.label = attr(x, "labels"))
+ res$edge[, 2] = ord
+ res$edge.length=NULL
+# browser()
+ x <- SHORTwise(x, nTips)
+ spRes <- as.splits(res)[res$edge[,2]]
+ index = match(spRes, x)
+
+ if(any(is.na(index))){
+ l.na = sum(is.na(index))
+ x <- c(x, spRes[is.na(index)])
+ weight = c(weight, rep(0, l.na))
+ index = match(spRes, x)
+ }
+
+ l = sapply(oneWise(x, nTips), length)
+ l2 = sapply(x, length)
+ # dm <- as.matrix(compatible2(x))
+
+ tmp <- countCycles(x, ord=ord)
+ ind = which(tmp == 2 & l2>1) # & l<nTips changed with ordering
+
+ ind = ind[order(l[ind])]
+
+ dm2 <- as.matrix(compatible2(x, x[ind]))
+
+ X = as.matrix(x)[,ord]
+ Y = X
+ rsY = rowSums(Y)
+ X = X[ind, ]
+
+ for(k in 1: length(ind)){
+ Vstart = ord[1]
+ Vstop = ord[nTips]
+ ordStart = 1
+ ordStop = nTips
+ for(j in 2:nTips){
+
+ if(X[k,j-1] < X[k,j]){
+ Vstart = ord[j]
+ ordStart = j
+ }
+ if(X[k,j-1] > X[k,j]){
+ Vstop = ord[j-1]
+ ordStop = j-1
+ }
+ }
+
+ fromTo <- ordStart:ordStop
+ if(ordStart>ordStop) fromTo <- c(ordStart:nTips, 1:ordStop)
+ fromTo = ord[fromTo]
+# print(fromTo)
+ g = graph(t(res$edge), directed=FALSE)
+
+ isChild = (rsY == (Y %*% X[k,]))[index]
+ sp2 = NULL
+ sp0 = NULL
+
+ for(i in 2:length(fromTo)){
+ sptmp = get.shortest.paths(g, fromTo[i-1], fromTo[i],
+ output=c("epath"))$epath[[1]]
+ sp2 = c(sp2, sptmp[-c(1, length(sptmp))])
+ sp0 = c(sp0, sptmp)
+ }
+ sp0 = unique(sp0)
+
+ if(length(sp2)>0){
+ # blub = which(dm[index[sp2], ind[k]]>0)
+ TMP = rowSums(dm2[index[sp2], 1:k, drop=FALSE])
+ blub = which(TMP>0)
+ sp2 = sp2[blub]
+ }
+ if(length(sp2)==0){
+ isChild = (rsY == (Y %*% X[k,]))[index]
+ sp0 = which(isChild == TRUE)
+ edge1 = unique(as.vector(res$edge[sp0,]))
+ edge2 = as.vector(res$edge[-sp0,])
+ asdf = edge1 %in% edge2
+ sp = edge1[asdf]
+ }
+ if(length(sp2)>0) sp = unique(as.vector(t(res$edge[sp2,])))
+ parent = res$edge[,1]
+ child = res$edge[,2]
+
+ j = ord[which(X[k,]==1)]
+ anc = unique(parent[match(j, child)])
+
+ maxVert = max(parent)
+ l = length(sp)
+
+ newVert = (maxVert+1) : (maxVert+l)
+ sp01 = setdiff(sp0, sp2)
+ for(i in 1:l) res$edge[sp01,][res$edge[sp01,]==sp[i]] = newVert[i]
+
+ newindex = rep(ind[k], l)
+ if(length(sp)>1)newindex = c(index[sp2], newindex)
+ index = c(index, newindex)
+ # connect new and old vertices
+ newEdge = matrix(cbind(sp, newVert), ncol=2)
+ if(length(sp)>1){
+ # copy edges
+ qwer = match(as.vector(res$edge[sp2,]), sp)
+ newEdge = rbind(matrix(newVert[qwer], ncol=2), newEdge)
+ }
+
+ res$edge = rbind(res$edge, newEdge)
+ res$Nnode = max(res$edge) - nTips
+
+ res$splitIndex = index
+ res$edge.length <- rep(1, nrow(res$edge))
+ class(res) = c("networx", "phylo")
+ attr(res, "order") = NULL
+ #browser()
+ }
+ res$Nnode = max(res$edge) - nTips
+ res$splitIndex = index
+ res$edge.length = weight[index] # ausserhalb
+ attr(res, "splits") = x
+ class(res) = c("networx", "phylo")
+ attr(res, "order") = NULL
+ res
+}
+
+
+as.networx <- function (x, ...)
+{
+ if (inherits(x, "networx"))
+ return(x)
+ UseMethod("as.networx")
+}
+
+
+getOrdering <- function(x){
+ tree = as.phylo(x)
+ nTips = length(tree$tip)
+ ord = reorder(tree)$edge[,2]
+ ord = ord[ord<=nTips]
+ ind = which(ord == 1L)
+ if(ind>1) ord = c(ord[ind:nTips], ord[c(1:(ind-1L))])
+ ord
+}
+
+
+addTrivialSplits <- function(obj){
+ label <- attr(obj, "label")
+ nTips <- length(label)
+ weight <- attr(obj, "weights")
+ if(is.null(weight)) weight = rep(1, length(obj))
+ STree = stree(nTips, tip.label = attr(obj, "labels"))
+ STree$edge.length=NULL
+ spRes <- as.splits(STree)[STree$edge[,2]]
+ tmpIndex = match(spRes, SHORTwise(obj, nTips))
+ if(any(is.na(tmpIndex))){
+ l.na = sum(is.na(tmpIndex))
+ obj <- c(obj, spRes[is.na(tmpIndex)])
+ weight = c(weight, rep(0, l.na))
+ attr(obj, "weights") <- weight
+ }
+ obj
+}
+
+
+as.networx.splits <- function(x, planar=FALSE, ...){
+ label <- attr(x, "label")
+
+ x = addTrivialSplits(x)
+
+ nTips <- length(label)
+ weight <- attr(x, "weights")
+ if(is.null(weight)) weight = rep(1, length(x))
+ attr(x, "weights") <- weight
+
+ x <- oneWise(x, nTips)
+ l <- sapply(x, length)
+ if(any(l==nTips))x <- x[l!=nTips] # get rid of trivial splits
+ ext <- sum(l==1 | l==(nTips-1))
+ if(!is.null(attr(x, "cycle"))){
+ c.ord <- attr(x, "cycle")
+ }
+ else c.ord <- getOrdering(x)
+ attr(x, "cycle") = c.ord
+
+ dm <- as.matrix(compatible2(x))
+# which splits are in circular ordering
+ circSplits = which(countCycles(x, ord=c.ord)==2)
+ if(length(circSplits) == length(x)) planar=TRUE
+ tmp = circNetwork(x, c.ord)
+ attr(tmp, "order") = NULL
+ if(planar){
+ return(reorder(tmp))
+ }
+
+ ll <- sapply(x, length)
+ ind <- tmp$splitIndex # match(sp, x)
+ ind2 = union(ind, which(ll==0)) # which(duplicated(x))
+ ind2 = union(ind2, which(ll==nTips))
+ ord <- order(colSums(dm))
+ ord <- setdiff(ord, ind2)
+ if(length(ord)>0){
+ for(i in 1:length(ord)){
+ tmp = addEdge(tmp, x, ord[i])
+ tmp$edge.length = weight[tmp$splitIndex]
+ tmp$Nnode = max(tmp$edge) - nTips
+ class(tmp) = c("networx", "phylo")
+ }
+ }
+ tmp$Nnode = max(tmp$edge) - nTips
+ tmp$edge.length = weight[tmp$splitIndex]
+ attr(x, "cycle") <- c.ord
+ attr(tmp, "splits") = x
+ class(tmp) = c("networx", "phylo")
+ tmp <- reorder(tmp)
+ tmp
+}
+
+
+#as.igraph.networx <- function(x, directed=FALSE){
+# graph(t(x$edge), directed=directed)
+#}
+
+
+consensusNet <- function (obj, prob = 0.3, ...)
+{
+ l = length(obj)
+ spl = as.splits(obj)
+ w = attr(spl, "weights")
+ ind = (w/l) > prob
+ spl = spl[ind]
+ attr(spl, "confidences") = round((w/l)[ind]*100)
+# attr(spl, "weights") = w[ind]
+ res = as.networx(spl)
+ res$edge.labels = as.character(res$edge.length / l * 100)
+ res$edge.labels[res$edge[,2]<=length(res$tip.label)] = ""
+ reorder(res)
+}
+
+
+addConfidences <- function (obj, phy) UseMethod("addConfidences")
+
+
+
+addConfidences.splits <- function(obj, phy){
+ tiplabel <- attr(obj, "label")
+ obj = addTrivialSplits(obj)
+ ind <- match(tiplabel, phy$tip.label)
+ if (any(is.na(ind)) | length(tiplabel) != length(phy$tip.label))
+ stop("trees have different labels")
+ phy$tip.label <- phy$tip.label[ind]
+ ind2 <- match(1:length(ind), phy$edge[, 2])
+ phy$edge[ind2, 2] <- order(ind)
+
+ spl <- as.splits(phy)
+
+ nTips <- length(tiplabel)
+ spl <- SHORTwise(spl, nTips)
+ ind <- match(SHORTwise(obj, nTips), spl)
+ pos <- which(ind > nTips)
+ confidences <- character(length(obj))
+ confidences[pos] <- phy$node.label[ind[pos] - nTips]
+ attr(obj, "confidences") <- confidences
+ obj
+}
+
+
+addConfidences.networx <- function(obj, phy){
+ spl <- attr(obj, "splits")
+ spl <- addConfidences(spl, phy)
+ attr(obj, "splits") <- spl
+ obj
+}
+
+
+addConfidences.phylo <- function(obj, phy){
+ conf = attr(addConfidences(as.splits(obj), phy), "confidences")
+ nTips = length(obj$tip.label)
+ obj$node.label = conf[-c(1:nTips)]
+ obj
+}
+
+
+reorder.networx <- function (x, order = "cladewise", ...)
+{
+ order <- match.arg(order, c("cladewise", "postorder"))
+ if (!is.null(attr(x, "order")))
+ if (attr(x, "order") == order)
+ return(x)
+ g <- graph(t(x$edge))
+ if(order == "cladewise") neword <- topological.sort(g, "out")
+ else neword <- topological.sort(g, "in")
+ neworder <- order(match(x$edge[,1], neword))
+
+ x$edge <- x$edge[neworder, ]
+ if (!is.null(x$edge.length))
+ x$edge.length <- x$edge.length[neworder]
+ if (!is.null(x$edge.labels))
+ x$edge.labels <- x$edge.labels[neworder]
+ if (!is.null(x$splitIndex))x$splitIndex <- x$splitIndex[neworder]
+ attr(x, "order") <- order
+ x
+}
+
+
+coords <- function(obj, dim="3D"){
+# if(is.null(attr(obj,"order")) || (attr(obj, "order")=="postorder") )
+# obj = reorder.networx(obj)
+
+ l = length(obj$edge.length)
+ ind1 = which(!duplicated(obj$splitIndex))
+
+ n = max(obj$edge)
+ adj = Matrix::spMatrix(n, n, i = obj$edge[,2], j = obj$edge[,1], x = rep(1, length(obj$edge.length)))
+ g = graph.adjacency(adj, "undirected")
+##########
+# add this
+# g2 <- graph(t(obj$edge), directed=FALSE)
+# g2 <- set.edge.attribute(g, "weight", value=rep(1, nrow(obj$edge))
+ if(dim=="3D"){
+ coord <- layout.kamada.kawai(g, dim=3)
+ k = matrix(0, max(obj$split), 3)
+ for(i in ind1){
+ tmp = coord[obj$edge[i, 2],] - coord[obj$edge[i, 1],]
+ k[obj$split[i], ] = kart2kugel(tmp[1], tmp[2], tmp[3])
+ }
+ k[obj$split[ind1],1] = obj$edge.length[ind1]
+
+ res = matrix(0, vcount(g), 3)
+ for(i in 1:l){# unique(obj$split)
+ j = obj$edge[i,1]
+ m = obj$edge[i,2]
+ p = obj$split[i]
+ res[m,] = res[j,] + kugel2kart(k[p,1], k[p,2], k[p,3])
+ }
+ }
+ else{
+ coord <- layout.kamada.kawai(g, dim=2)
+ k = matrix(0, max(obj$split), 2)
+ for(i in ind1){
+ tmp = coord[obj$edge[i, 2],] - coord[obj$edge[i, 1],]
+ k[obj$split[i], ] = kart2kreis(tmp[1], tmp[2])
+ }
+ k[obj$split[ind1],1] = obj$edge.length[ind1]
+ res = matrix(0, vcount(g), 2)
+ for(i in 1:l){# unique(obj$split)
+ j = obj$edge[i,1]
+ m = obj$edge[i,2]
+ p = obj$split[i]
+ res[m,] = res[j,] + kreis2kart(k[p,1], k[p,2])
+ }
+ }
+ res
+}
+
+
+kart2kugel <- function(x,y,z){
+ r = sqrt(x*x+y*y+z*z)
+ alpha = atan(sqrt(x*x+y*y) / z)
+ if(z<0) alpha = alpha+pi
+ beta = atan(y/x)
+ if(x<0) beta = beta+pi
+ c(r,alpha,beta)
+}
+
+
+kart2kreis <- function(x,y){
+ r = sqrt(x*x+y*y)
+ alpha = atan(y/x)
+ if(x<0) alpha = alpha+pi
+ c(r,alpha)
+}
+
+
+kreis2kart <- function(r,alpha){
+ c(r*cos(alpha), r*sin(alpha))
+}
+
+
+kugel2kart <- function(r,alpha,beta){
+ x = r * sin(alpha) * cos(beta)
+ y = r * sin(alpha) * sin(beta)
+ z = r * cos(alpha)
+ c(x,y,z)
+}
+
+
+edgeLabels <- function(xx,yy,zz=NULL, edge){
+ XX <- (xx[edge[, 1]] + xx[edge[, 2]])/2
+ YY <- (yy[edge[, 1]] + yy[edge[, 2]])/2
+ if(!is.null(zz)){
+ ZZ <- (zz[edge[, 1]] + zz[edge[, 2]])/2
+ return(cbind(XX, YY, ZZ))
+ }
+ cbind(XX, YY)
+}
+
+.check.pkg <- function (pkg)
+{
+ if (pkg %in% rownames(installed.packages())) {
+ require(pkg, character.only = TRUE)
+ return(TRUE)
+ }
+ else return(FALSE)
+}
+
+
+plot.networx = function(x, type="3D", use.edge.length = TRUE, show.tip.label=TRUE,
+ show.edge.label=FALSE, edge.label=NULL, show.node.label = FALSE, node.label=NULL,
+ show.nodes=FALSE, tip.color = "blue",
+ edge.color="grey", edge.width = 3, edge.lty = 1,
+ font = 3, cex = 1, ...){
+ type = match.arg(type, c("3D", "2D"))
+ if(use.edge.length==FALSE) x$edge.length[] = 1
+ x = reorder(x)
+ nTips = length(x$tip.label)
+ conf = attr(attr(x, "splits"),"confidences")
+ index = x$splitIndex
+ if(is.null(edge.label) & !is.null(conf))edge.label = conf[index]
+ if(is.null(node.label))node.label = as.character(1:max(x$edge))
+ if(show.tip.label)node.label[1:nTips] = ""
+
+ chk <- FALSE
+ if(type=="3D") chk <- .check.pkg("rgl")
+ if(!chk && type=="3D"){
+ warning("type=\"3D\" requires the package \"rgl\"\n, plotting =\"2D\" instead!\n")
+ type="2D"
+ }
+ if(type=="3D") {
+ coord <- coords(x, dim="3D")
+ plotRGL(coord, x, show.tip.label=show.tip.label, show.edge.label=show.edge.label,
+ edge.label = edge.label, show.node.label = show.node.label, node.label=node.label,
+ show.nodes=show.nodes, tip.color = tip.color, edge.color=edge.color,
+ edge.width = edge.width, font = font, cex = cex)
+ }
+ else{
+ coord <- coords(x, dim="2D")
+ plot2D(coord, x, show.tip.label=show.tip.label, show.edge.label=show.edge.label,
+ edge.label = edge.label, show.node.label = show.node.label, node.label=node.label,
+ show.nodes=show.nodes, tip.color = tip.color, edge.color=edge.color,
+ edge.width = edge.width, edge.lty=edge.lty,font = font, cex = cex, add=FALSE)
+ }
+}
+
+
+plotRGL <- function(coords, net, show.tip.label=TRUE,
+ show.edge.label=FALSE, edge.label=NULL, show.node.label=FALSE, node.label=NULL,
+ show.nodes=FALSE, tip.color = "blue", edge.color="grey",
+ edge.width = 3, font = 3, cex = par("cex"), ...){
+
+ chk <- .check.pkg("rgl")
+ if(!chk) open3d <- segments3d <- spheres3d <- rgl.texts <- function(...)NULL
+
+ edge = net$edge
+
+ x = coords[,1]
+ y = coords[,2]
+ z = coords[,3]
+
+ nTips = length(net$tip.label)
+
+ segments3d(x[t(edge)],y[t(edge)],z[t(edge)], col=edge.color, lwd=edge.width)
+ radius=0
+ if(show.nodes){
+ radius = sqrt((max(x)-min(x))^2 + (max(y)-min(y))^2 + (max(z)-min(z))^2) / 200
+ spheres3d(x[1:nTips], y[1:nTips],z[1:nTips], radius=2*radius, color="cyan")
+ spheres3d(x[-c(1:nTips)], y[-c(1:nTips)],z[-c(1:nTips)], radius=radius, color="magenta")
+ }
+ if(show.tip.label){
+ rgl.texts(x[1:nTips]+2.05*radius,y[1:nTips],z[1:nTips],net$tip.label, color=tip.color, cex=cex, font=font)
+ }
+ if(show.edge.label){
+ ec = edgeLabels(x, y, z, edge)
+ if(is.null(edge.label)) edge.label = net$splitIndex
+ #else edge.label = net$splitIndex
+ rgl.texts(ec[,1], ec[,2], ec[,3], edge.label, color=tip.color, cex=cex, font=font)
+ }
+ if(show.node.label){
+ rgl.texts(x, y, z, node.label, color=tip.color, cex=cex, font=font)
+ }
+}
+
+
+plot2D <- function(coords, net, show.tip.label=TRUE,
+ show.edge.label=FALSE, edge.label=NULL, show.node.label=FALSE, node.label=NULL,
+ tip.color = "blue", edge.color="grey",
+ edge.width = 3, edge.lty=1, font = 3, cex = par("cex"), add=FALSE, ...){
+ edge = net$edge
+ label = net$tip.label
+ xx = coords[,1]
+ yy = coords[,2]
+ nTips = length(label)
+
+ cex=1
+
+ xlim <- range(xx)
+ ylim <- range(yy)
+
+ if(show.tip.label){
+ offset <- max(nchar(label)) * 0.018 * cex * diff(xlim)
+ xlim = c(xlim[1]-offset, xlim[2]+offset)
+ ylim = c(ylim[1]-0.03 * cex * diff(ylim), ylim[2]+0.03 * cex * diff(ylim))
+ }
+ if(!add){
+ plot.new()
+ plot.window(xlim, ylim, asp=1)
+ }
+ cladogram.plot(edge, xx, yy, edge.color, edge.width, edge.lty)
+ if(show.tip.label){
+ ind=match(1:nTips, edge[,2])
+ pos = rep(4, nTips)
+ XX <- xx[edge[ind, 1]] - xx[edge[ind, 2]]
+ pos[XX>0] = 2
+ YY <- yy[edge[ind, 1]] - yy[edge[ind, 2]]
+ pos2 <- rep(3, nTips)
+ pos2[YY>0] = 1
+ pos[abs(YY)>abs(XX)] <- pos2[abs(YY)>abs(XX)]
+ text(xx[1:nTips], yy[1:nTips], labels=label, pos=pos, col=tip.color, cex=cex, font=font)
+ }
+ if(show.edge.label){
+ ec = edgeLabels(xx,yy, edge=edge)
+ if(is.null(edge.label))edge.label = net$splitIndex
+ text(ec[,1], ec[,2], labels=edge.label, col=tip.color, cex=cex, font=font)
+ }
+ if(show.node.label){
+ text(xx, yy, labels=node.label, col=tip.color, cex=cex, font=font)
+ }
+}
+
+
+lento <- function (obj, xlim = NULL, ylim = NULL, main = "Lento plot",
+ sub = NULL, xlab = NULL, ylab = NULL, bipart=TRUE, trivial=FALSE, ...)
+{
+ if (class(obj) == "phylo")
+ obj = as.splits(obj)
+ if (class(obj) == "multiPhylo")
+ obj = as.splits(obj)
+ labels = attr(obj, "labels")
+ l = length(labels)
+ if(!trivial){
+ triv = sapply(obj, length)
+ ind = logical(length(obj))
+ ind[(triv >1) & (triv < (l-1))] = TRUE
+ obj = obj[ind]
+ }
+ CM = compatible(obj)
+ support = attr(obj, "weights")
+ if (is.null(support))
+ support = rep(1, length(obj))
+ conflict = -as.matrix(CM) %*% support
+ n = length(support)
+ if (is.null(ylim)) {
+ eps = (max(support) - min(conflict)) * 0.05
+ ylim = c(min(conflict) - eps, max(support) + eps)
+ }
+ if (is.null(xlim)) {
+ xlim = c(0, n + 1)
+ }
+
+ ord = order(support, decreasing = TRUE)
+ support = support[ord]
+ conflict = conflict[ord]
+ plot.new()
+ plot.window(xlim, ylim)
+ title(main = main, sub = sub, xlab = xlab, ylab = ylab, ...)
+ segments(0:(n - 1), support, y1 = conflict, ...)
+ segments(1:n, support, y1 = conflict, ...)
+ segments(0:(n - 1), support, x1 = 1:n, ...)
+ segments(0:(n - 1), conflict, x1 = 1:n, ...)
+ abline(h = 0)
+ axis(2, ...)
+ aty = diff(ylim)/(l+1)
+ at = min(ylim) + (1:l) * aty
+ if(bipart){
+ Y = rep(at, n)
+ X = rep((1:n)-.5, each=l)
+ Circles = matrix(1, l, n)
+ for(i in 1:n) Circles[obj[[ord[i]]],i] = 19
+# axis(4, labels=labels, at=at)
+ text(x=n+.1,y=at, labels, pos=4, ...)
+ points(X,Y,pch = as.numeric(Circles), col = rgb(0,0,0,.5), ...)
+ }
+ invisible(cbind(support, conflict))
+ }
+
+
+write.splits = function (x, file = "", zero.print = ".", one.print = "|", print.labels = TRUE, ...)
+{
+ labels = attr(x, "labels")
+ x.orig <- x
+ cx <- as.matrix(x, zero.print = zero.print, one.print = one.print)
+ w = FALSE
+ if (!is.null(attr(x, "names"))) {
+ nam = TRUE
+ vnames = format(attr(x, "names"))
+ }
+ nam = FALSE
+ if (!is.null(attr(x, "weights"))) {
+ w = TRUE
+ weight = format(attr(x, "weights"))
+ }
+ d = FALSE
+ if (!is.null(attr(x, "data"))) {
+ d = TRUE
+ data = attr(x, "data")
+ }
+ if(print.labels){for(i in 1:length(labels)) cat(labels[i], "\n", file = file, append = TRUE)}
+ if (w)
+ cat("weight", "\t", file = file, append = TRUE)
+ if (d)
+ cat(paste(colnames(data), "\t"), file = file, append = TRUE)
+ cat("\n", file = file, append = TRUE) #"Matrix",
+ for (i in 1:length(x)) {
+ if (nam)
+ cat(vnames[i], "\t", file = file, append = TRUE)
+ if (d)
+ cat(paste(data[i, ], "\t"), file = file, append = TRUE)
+ if (w)
+ cat(weight[i], "\t", file = file)
+ cat("\n", paste(cx[i, ], collapse = ""),"\n", file = file, append = TRUE)
+ }
+}
+
+
+write.nexus.splits <- function (obj, file = "", weights=NULL)
+{
+ if(is.null(weights))weight <- attr(obj, "weights")
+ taxa.labels <- attr(obj, "labels")
+ ntaxa = length(taxa.labels)
+ nsplits = length(obj)
+
+ if (is.null(weight))
+ weight = numeric(nsplits) + 100
+ cat("#NEXUS\n\n", file = file)
+ cat("[Splits block for Spectronet or Splitstree]\n", file = file, append = TRUE)
+ cat("[generated by phangorn:\n", file = file, append = TRUE)
+ cat(format(citation("phangorn"), "text"), "]\n\n",
+ file = file, append = TRUE)
+ cat(paste("BEGIN TAXA;\n\tDIMENSIONS NTAX=", ntaxa, ";\n",
+ sep = ""), file = file, append = TRUE)
+ cat("\tTAXLABELS", paste(taxa.labels, sep = " "), ";\nEND;\n\n",
+ file = file, append = TRUE)
+ cat(paste("BEGIN SPLITS;\n\tDIMENSIONS NSPLITS=", nsplits,
+ ";\n", sep = ""), file = file, append = TRUE)
+ format = "\tFORMAT labels=left weights=yes"
+ fcon = fint = flab = FALSE
+ if(!is.null(attr(obj, "confidences"))){
+ format = paste(format, "confidences=yes")
+ fcon=TRUE
+ conf = attr(obj, "confidences")
+ if(storage.mode(conf) == "character"){
+ conf[conf==""] = "0"
+ attr(obj, "confidences") = conf
+ }
+ }
+ else format = paste(format, "confidences=no")
+ if(!is.null(attr(obj, "intervals"))){
+ format = paste(format, "intervals=yes")
+ fint=TRUE
+ }
+ else format = paste(format, "intervals=no")
+ if(!is.null(attr(obj, "splitlabels"))) flab=TRUE
+ format = paste(format, ";\n", sep = "")
+ cat(format, file = file, append = TRUE)
+ cat("\tMATRIX\n", file = file, append = TRUE)
+ obj = oneWise(obj, ntaxa)
+ for (i in 1:nsplits){
+ slab <- ifelse(flab, attr(obj, "splitlabels")[i], i)
+ scon <- ifelse(fcon, paste(attr(obj, "confidences")[i], "\t"), "")
+ sint <- ifelse(fint, paste(attr(obj, "intervals")[i], "\t"), "")
+ cat("\t\t", slab, "\t", weight[i], "\t", scon, sint, paste(obj[[i]], collapse=" "),
+ ",\n", file = file, append = TRUE, sep = "")
+ }
+ cat("\t;\nEND;\n", file = file, append = TRUE)
+}
+
+
+read.nexus.splits <- function(file)
+{
+ X <- scan(file = file, what = "", sep = "\n", quiet = TRUE)
+ semico <- grep(";", X)
+ X=gsub("\\[(.*?)\\]", "", X) # get rid of comments
+ i1 <- grep("TAXLABELS", X, ignore.case = TRUE)
+ taxlab <- TRUE
+ if (taxlab) {
+ end <- semico[semico > i1][1]
+ x <- X[(i1 + 1):end] # assumes there's a 'new line' after "TRANSLATE"
+ ## x <- gsub("TRANSLATE", "", x, ignore.case = TRUE)
+ x <- unlist(strsplit(x, "[,; \t]"))
+ x <- x[nzchar(x)]
+ x <- gsub("['\"]", "", x)
+ xntaxa <- length(x)
+ }
+ sp <- grep("SPLITS;", X, ignore.case = TRUE)
+ spEnd <- grep("END;", X, ignore.case = TRUE)
+ spEnd <- spEnd[spEnd>sp][1]
+ dims <- grep("DIMENSION", X, ignore.case = TRUE)
+ cyc <- grep("CYCLE", X, ignore.case = TRUE)
+ matr <- grep("MATRIX", X, ignore.case = TRUE)
+ format <- grep("FORMAT", X, ignore.case = TRUE)
+ start <- matr[matr>sp][1] + 1
+ end <- semico[semico>start][1] -1
+ format <- format[(format>sp) & (format<spEnd)]
+
+ res <- vector("list", end - start + 1)
+ weights = numeric(end - start + 1)
+ j=1
+
+ flab = fwei = fcon = fint = FALSE
+
+ if(length(format)>0){
+ tmp = X[format]
+ tmp = gsub("\\;", "", tmp)
+ tmp = gsub("\\s+", "", tmp)
+ flab = grepl("labels=left", tmp, ignore.case = TRUE)
+ fwei = grepl("weights=yes", tmp, ignore.case = TRUE)
+ fcon = grepl("confidences=yes", tmp, ignore.case = TRUE)
+ fint = grepl("intervals=yes", tmp, ignore.case = TRUE)
+ # = as.numeric(na.omit(as.numeric(strsplit(tmp, " ")[[1]])))
+ ind = cumsum(c(flab, fwei, fcon, fint))
+ mformat = sum(c(flab, fwei, fcon, fint))
+ }
+
+ if(fint)intervals = numeric(end - start + 1)
+ if(fcon)confidences = numeric(end - start + 1)
+ if(flab)labels = vector("character", end - start + 1)
+
+ for(i in start:end){
+ tmp = X[i]
+ tmp = sub("\\s+", "", tmp)
+ tmp = strsplit(tmp, "\t")[[1]]
+ if(length(tmp)!=(mformat+1)) warning("blub")
+ if(flab)labels[j] = as.numeric(tmp[ind[1]])
+ if(fwei)weights[j] = as.numeric(tmp[ind[2]])
+ if(fcon)confidences[j] = as.numeric(tmp[ind[3]])
+ if(fint)intervals[j] = as.numeric(tmp[ind[4]])
+ tmp = tmp[length(tmp)]
+ tmp = gsub("\\,", "", tmp)
+ res[[j]] = as.integer(na.omit(as.numeric(strsplit(tmp, " ")[[1]])))
+ j=j+1
+ }
+ if(length(cyc)>0){
+ tmp = X[cyc]
+ tmp = gsub("\\;", "", tmp)
+ tmp = gsub("CYCLE", "", tmp, ignore.case = TRUE)
+ tmp = sub("\\s+", "", tmp)
+ cyc = as.integer(na.omit(as.numeric(strsplit(tmp, " ")[[1]])))
+ }
+ attr(res, "labels") = x
+ attr(res, "weights") = weights
+ if(fint)attr(res, "intervals") = intervals
+ if(fcon)attr(res, "confidences") = confidences
+ if(flab)attr(res, "splitlabels") = labels
+ attr(res, "cycle") = cyc
+ class(res) = c("splits", "prop.part")
+ res
+}
+
+
+#
+# ancestral sequences ML
+#
+ancestral.pml <- function (object, type=c("ml", "bayes"))
+{
+ call <- match.call()
+ type <- match.arg(type)
+ pt <- match.arg(type, c("ml", "bayes"))
+ tree = object$tree
+
+ INV <- object$INV
+ inv <- object$inv
+
+ data = getCols(object$data, tree$tip)
+ if (is.null(attr(tree, "order")) || attr(tree, "order") ==
+ "cladewise")
+ tree <- reorder(tree, "postorder")
+ q = length(tree$tip.label)
+ node <- tree$edge[, 1]
+ edge <- tree$edge[, 2]
+ m = length(edge) + 1 # max(edge)
+ w = object$w
+ g = object$g
+ l = length(w)
+ nr <- attr(data, "nr")
+ nc <- attr(data, "nc")
+ dat = vector(mode = "list", length = m*l)
+ result = vector(mode = "list", length = m)
+ dim(dat) <- c(l,m)
+
+ x = attributes(data)
+ label = as.character(1:m)
+ nam = tree$tip.label
+ label[1:length(nam)] = nam
+ x[["names"]] = label
+
+
+ tmp = length(data)
+ result = new2old.phyDat(data)
+ eig = object$eig
+
+ bf = object$bf
+ el <- tree$edge.length
+ P <- getP(el, eig, g)
+ nr <- as.integer(attr(data, "nr"))
+ nc <- as.integer(attr(data, "nc"))
+ node = as.integer(node - min(node))
+ edge = as.integer(edge - 1)
+ nTips = as.integer(length(tree$tip))
+ mNodes = as.integer(max(node) + 1)
+ contrast = attr(data, "contrast")
+ nco = as.integer(dim(contrast)[1])
+ for(i in 1:l)dat[i,(q + 1):m] <- .Call("LogLik2", data, P[i,], nr, nc, node, edge, nTips, mNodes, contrast, nco, PACKAGE = "phangorn")
+
+ parent <- tree$edge[, 1]
+ child <- tree$edge[, 2]
+ nTips = min(parent) - 1
+
+ for(i in 1:l){
+ for (j in (m - 1):1) {
+ if (child[j] > nTips){
+ tmp2 = (dat[[i, parent[j]]]/(dat[[i,child[j]]] %*% P[[i,j]]))
+ dat[[i, child[j]]] = (tmp2 %*% P[[i,j]]) * dat[[i, child[j]]]
+ }
+ }
+ }
+ for (j in unique(parent)) {
+ tmp <- matrix(0, nr, nc)
+ if(inv>0) tmp = as.matrix(INV) * inv
+ for(i in 1:l){
+ tmp = tmp + w[i] * dat[[i, j]]
+ }
+ if (pt == "bayes") tmp = tmp * rep(bf, each=nr)
+ tmp = tmp / rowSums(tmp)
+ result[[j]] = tmp
+ }
+ attributes(result) = x
+ attr(result, "call") <- call
+ result
+}
+
+
+fast.tree = function(tree, node){
+ parent = c(node, Ancestors(tree, node))
+ children = Descendants(tree, parent, 'children')
+ l = sapply(children, length)
+ edge = cbind(rep(parent, l), unlist(children))
+ obj = list(edge=edge, Nnode=sum(l>0), tip.label=as.character(edge[is.na(match(edge[,2], edge[,1])),2]))
+ class(obj) = 'phylo'
+ obj
+}
+
+# schneller ???
+fast.tree2 = function(tree, node){
+ parent = c(node, Ancestors(tree, node))
+ edge = tree$edge
+ ind = match(edge[,1], parent)
+ edge=edge[which(!is.na(ind)),]
+ obj = list(edge=edge, Nnode=length(parent), tip.label=as.character(edge[is.na(match(edge[,2], edge[,1])),2]))
+ class(obj) = 'phylo'
+ obj
+}
+
+
diff --git a/R/parsimony.R b/R/parsimony.R
new file mode 100644
index 0000000..c16adb1
--- /dev/null
+++ b/R/parsimony.R
@@ -0,0 +1,828 @@
+#
+# Maximum Parsimony
+#
+rowMin = function(X){
+ d=dim(X)
+ .Call("C_rowMin", X, as.integer(d[1]), as.integer(d[2]), PACKAGE = "phangorn")
+}
+
+
+sankoff.quartet <- function (dat, cost, p, l, weight)
+{
+ erg <- .Call("sankoffQuartet", sdat = dat, sn = p, scost = cost,
+ sk = l, PACKAGE = "phangorn")
+ sum(weight * erg)
+}
+
+
+parsimony <- function(tree, data, method='fitch', ...){
+ if (class(data)[1] != "phyDat") stop("data must be of class phyDat")
+ if(method=='sankoff') result <- sankoff(tree, data, ...)
+ if(method=='fitch') result <- fitch(tree, data, ...)
+ result
+}
+
+
+ancestral.pars <- function (tree, data, type = c("MPR", "ACCTRAN"), cost=NULL)
+{
+ call <- match.call()
+ type <- match.arg(type)
+ if (type == "ACCTRAN")
+ res = ptree(tree, data, retData = TRUE)[[2]]
+# if (type == "MPR")
+# res = mpr(tree, data)
+ if (type == "MPR"){
+ res <- mpr(tree, data, cost=cost)
+ attr(res, "call") = call
+ return(res)
+ }
+ l = length(tree$tip)
+
+ x = attributes(data)
+ m = dim(res)[2]
+ label = as.character(1:m)
+ nam = tree$tip.label
+ label[1:length(nam)] = nam
+ x[["names"]] = label
+
+ nc = attr(data, "nc")
+ result = vector("list", m)
+ Z = unique(as.vector(res))
+ tmp = t(sapply(Z, function(x)dec2bin(x, nc)))
+ tmp = tmp / rowSums(tmp)
+# rownames(tmp) = Z
+ dimnames(tmp) = list(Z, attr(data, "levels"))
+ for(i in 1:m){
+# tmp = t(sapply(res[,i], function(x, k=4)dec2bin(x, nc)))
+# result[[i]] = tmp / rowSums(tmp) no indices
+# test = match(res[,i], Z) sollte stimmen wegen fitch
+ result[[i]] = tmp[as.character(res[,i]),,drop=FALSE]
+ rownames(result[[i]]) = NULL
+ }
+
+ attributes(result) = x
+ attr(result, "call") <- call
+ result
+}
+
+
+pace <- ancestral.pars
+
+
+mpr.help = function (tree, data, cost=NULL)
+{
+ tree<- reorder(tree, "postorder")
+ if (class(data) != "phyDat")
+ stop("data must be of class phyDat")
+ levels <- attr(data, "levels")
+ l = length(levels)
+ if (is.null(cost)) {
+ cost <- matrix(1, l, l)
+ cost <- cost - diag(l)
+ }
+ weight = attr(data, "weight")
+ p = attr(data, "nr")
+ kl = TRUE
+ i = 1
+ dat <- prepareDataSankoff(data)
+ for (i in 1:length(dat)) storage.mode(dat[[i]]) = "double"
+ tmp = fit.sankoff(tree, dat, cost, returnData='data')
+ p0 = tmp[[1]]
+ datf = tmp[[2]]
+ datp = pnodes(tree, datf, cost)
+
+ nr = attr(data, "nr")
+ nc = attr(data, "nc")
+ node <- tree$edge[, 1]
+ edge <- tree$edge[, 2]
+
+ node = as.integer(node - 1)
+ edge = as.integer(edge - 1)
+
+ res <- .Call("sankoffMPR", datf, datp, as.numeric(cost), as.integer(nr),as.integer(nc),
+ node, edge, PACKAGE="phangorn")
+ root = getRoot(tree)
+ res[[root]] <- datf[[root]]
+ res
+}
+
+
+mpr <- function(tree, data, cost=NULL){
+ data = subset(data, tree$tip.label)
+ att = attributes(data)
+ nr = att$nr
+ nc = att$nc
+ res <- mpr.help(tree,data,cost)
+ l = length(tree$tip)
+ m = length(res)
+ label = as.character(1:m)
+ nam = tree$tip.label
+ label[1:length(nam)] = nam
+ att[["names"]] = label
+ ntips = length(tree$tip)
+ contrast = att$contrast
+ eps=5e-6
+ rm = apply(res[[ntips+1]], 1, min)
+ RM = matrix(rm,nr, nc) + eps
+ for(i in 1:ntips) res[[i]] = contrast[data[[i]],,drop=FALSE]
+ for(i in (ntips+1):m) res[[i]][] = as.numeric(res[[i]] < RM)
+ fun = function(X){
+ rs = apply(X, 1, sum)
+ X / rs
+ }
+ res <- lapply(res, fun)
+ attributes(res) = att
+ res
+}
+
+
+
+plotAnc <- function (tree, data, i = 1, col=NULL, cex.pie=par("cex"), pos="bottomright", ...)
+{
+ y = subset(data, , i)
+# args <- list(...)
+# CEX <- if ("cex" %in% names(args))
+# args$cex
+# else par("cex")
+ CEX = cex.pie
+ xrad <- CEX * diff(par("usr")[1:2])/50
+ levels = attr(data, "levels")
+ nc = attr(data, "nc")
+ y = matrix(unlist(y[]), ncol = nc, byrow = TRUE)
+ l = dim(y)[1]
+ dat = matrix(0, l, nc)
+ for (i in 1:l) dat[i, ] = y[[i]]
+ plot(tree, label.offset = 1.1 * xrad, plot = FALSE, ...)
+ lastPP <- get("last_plot.phylo", envir = .PlotPhyloEnv)
+ XX <- lastPP$xx
+ YY <- lastPP$yy
+ xrad <- CEX * diff(lastPP$x.lim * 1.1)/50
+ par(new = TRUE)
+ plot(tree, label.offset = 1.1 * xrad, plot = TRUE, ...)
+ if(is.null(col)) col = rainbow(nc)
+ if(length(col)!=nc) warning("Length of color vector differs from number of levels!")
+ BOTHlabels(pie = y, XX = XX, YY = YY, adj = c(0.5, 0.5),
+ frame = "rect", pch = NULL, sel = 1:length(XX), thermo = NULL,
+ piecol = col, col = "black", bg = "lightblue", horiz = FALSE,
+ width = NULL, height = NULL, cex=cex.pie)
+ legend(pos, levels, text.col = col)
+}
+
+
+prepareDataFitch <- function (data)
+{
+ lev <- attr(data, "levels")
+ l <- length(lev)
+ nr <- attr(data, "nr")
+ nc <- length(data)
+ contrast <- attr(data, "contrast")
+ tmp = contrast %*% 2L^c(0L:(l - 1L))
+ tmp = as.integer(tmp)
+ attrData <- attributes(data)
+ nam <- attrData$names
+ attrData$names <- NULL
+ data = unlist(data, FALSE, FALSE)
+ X = tmp[data]
+ attributes(X) <- attrData
+ attr(X, "dim") <- c(nr, nc)
+ dimnames(X) <- list(NULL, nam)
+ X
+}
+
+
+compressSites <- function(data){
+ attrData <- attributes(data)
+ lev <- attr(data, "levels")
+ LEV <- attr(data,"allLevels")
+ l <- length(lev)
+ nr <- attr(data, "nr")
+ nc <- length(data)
+
+ data = unlist(data, FALSE, FALSE)
+
+ attr(data, "dim") <- c(nr, nc)
+ uni <- match(lev, LEV)
+ fun = function(x, uni) {
+ u = unique.default(x)
+ res= if(any(is.na(match(u, uni)))) return(x)
+ match(x, u)
+ }
+ data = t(apply(data, 1, fun, uni))
+ ddd = fast.table(data)
+ data = ddd$data
+ class(data) = "list"
+ attrData$weight = tapply(attrData$weight,ddd$index, sum)
+ attrData$index=NULL
+ attrData$nr <- length(attrData$weight)
+ attrData$compressed <- TRUE
+ attributes(data) <- attrData
+ data
+}
+
+
+
+is.rooted2 = function(tree){
+ length(tree$edge[, 1][!match(tree$edge[, 1], tree$edge[, 2], 0)]) < 3
+}
+
+
+#
+# Branch and bound
+#
+
+parsinfo <- function (x)
+{
+ low = lowerBound(x)
+ up = upperBound(x)
+ ind = which(low==up)
+ cbind(ind, low[ind])
+}
+
+
+lowerBound <- function(x, cost=NULL){
+ tip <- names(x)
+ att = attributes(x)
+ nc = attr(x, "nc")
+ nr = attr(x, "nr")
+ contrast = attr(x, "contrast")
+ rownames(contrast) = attr(x, "allLevels")
+ colnames(contrast) = attr(x, "levels")
+ attr(x, "weight") = rep(1, nr)
+ attr(x, "index") = NULL
+
+ y <- as.character(x)
+ states <- apply(y, 2, unique.default)
+# duplicated function(x)x[duplicated(x)]="?" avoids looping
+ if(nr==1) nst <- length(states)
+ else nst <- sapply(states, length)
+
+ res = numeric(nr)
+ ust = sort(unique(nst))
+
+ if(is.null(cost))cost <- 1 - diag(nc)
+
+
+
+ if(any(ust>1)){
+ ust = ust[ust>1]
+ m <- max(ust)
+ tips = paste("t", 1:m, sep="")
+#
+ for(i in ust){
+ dat = matrix(unlist(states[nst==i]), nrow=i, dimnames=list(tips[1:i], NULL))
+ dat = phyDat(dat, type="USER", contrast=contrast)
+ tree = stree(i)
+ res[nst==i] = sankoffNew(tree, dat, cost=cost, site="site")[attr(dat, "index")]
+ }
+ }
+ res
+}
+
+
+upperBound <- function(x, cost=NULL){
+ tree = stree(length(x), tip.label=names(x))
+ if(is.null(cost))cost <- 1 - diag(attr(x, "nc"))
+ sankoffNew(tree, x, cost=cost, site="site")
+}
+
+
+CI <- function (tree, data, cost=NULL){
+ pscore = sankoff(tree, data, cost=cost)
+ weight = attr(data, "weight")
+ data = subset(data, tree$tip.label)
+ m = lowerBound(data, cost=cost)
+ sum(m * weight)/pscore
+}
+
+
+RI <- function (tree, data, cost=NULL)
+{
+ pscore = sankoffNew(tree, data, cost=cost)
+ data = subset(data, tree$tip.label)
+ weight = attr(data, "weight")
+ m = lowerBound(data, cost=cost)
+ m = sum(m * weight)
+ g = upperBound(data, cost=cost)
+ g = sum(g * weight)
+ (g - pscore)/(g - m)
+}
+
+# not used
+add.one <- function (tree, tip.name, i){
+ if (class(tree) != "phylo")
+ stop("tree should be an object of class 'phylo.'")
+ nTips = length(tree$tip)
+ tmpedge = tree$edge
+ m = max(tmpedge)
+ l = nrow(tmpedge)
+ trees <- vector("list", l)
+ tmp = tree
+ tmp$tip.label = c(tree$tip.label, tip.name)
+ tmpedge[tmpedge > nTips] <- tmpedge[tmpedge > nTips] + 1L
+ tmp$Nnode = tmp$Nnode + 1L
+ tmp$edge.length <- NULL
+ tmpedge = rbind(tmpedge, matrix(c(m + 2L, m + 2L, 0L, nTips + 1L), 2, 2))
+ edge = tmpedge
+ edge[l + 1L, 2] <- edge[i, 2]
+ edge[i, 2] <- m + 2L
+ neworder = .C("C_reorder", edge[, 1], edge[, 2], as.integer(l +
+ 2L), as.integer(m + 2L), integer(l + 2L), as.integer(nTips +
+ 1L), PACKAGE = "phangorn")[[5]]
+ tmp$edge <- edge[neworder, ]
+ tmp
+}
+
+
+mmsNew0 <- function (x, Y)
+{
+ w <- attr(x, "weight")
+ names(w) = NULL
+ m = length(x)
+ data <- matrix(unlist(x[1:m]), ncol = m)
+ l = nrow(data)
+ v = Y[,1] + 1L
+# v = numeric(l)
+# for (i in 1:l) v[i] = length(.Internal(unique(data[i, ],
+# FALSE, FALSE)))
+ result = matrix(NA, sum(w), 6)
+ Res = matrix(NA, sum(w), m)
+ Res2 = matrix(NA, sum(w), m)
+ j = 1
+ res = 0
+ bin = as.integer(2L^c(0L:30L))
+ for (i in 1:(l - 1L)) {
+ if (w[i] > 0) {
+ v2 = v[i] + v[(i + 1L):l] - 2L
+ v3 = integer(l - i)
+ ind = which(w[(i + 1):l] > 0)
+ V3 = matrix(NA, m, l - i)
+ k = length(ind)
+ V3[, ind] <- t(data[ind + i, , drop = FALSE]) + 100L *
+ data[i, ]
+ v3[ind] <- apply(V3[, ind, drop = FALSE], 2, function(x) {
+ length(unique.default(x, FALSE, FALSE)) - 1L })
+# length(.Internal(unique(x, FALSE, FALSE))) - 1L })
+ r = v3 - v2
+ while (any(r > 0) && w[i] > 0) {
+ a = which.max(r)
+ w0 = min(w[i], w[i + a])
+ if (w0 == 0) {
+ r[a] = 0
+ }
+ else {
+ res = res + w0 * v3[a]
+ w[i] = w[i] - w0
+ w[i + a] = w[i + a] - w0
+ result[j, ] = c(i, a + i, w0, r[a], v3[a],
+ v2[a])
+ abc = V3[, a]
+ Res[j, ] = bin[match(abc, unique(abc))]
+ Res2[j, ] = match(abc, unique(abc))
+ r[a] = 0
+ j = j + 1
+ }
+ }
+ }
+ }
+ result = na.omit(result)
+ mm = max(result[, 5])
+ Res = na.omit(Res)
+ Res2 = na.omit(Res2)
+ maxr = max(Res2)
+ resm = apply(Res2, 1, function(x) {
+ length(unique.default(x, FALSE, FALSE)) - 1L })
+# length(.Internal(unique(x, FALSE, FALSE))) - 1L })
+ Res2 = t(Res2)
+ Res2 = phyDat(Res2, type="USER", levels=1:maxr)
+ names(Res2) = as.character(1:m)
+ resm = lowerBound(Res2)
+ ind = which(w > 0)
+# data = data[ind, ]
+
+ tmp = matrix(0, attr(Res2, "nr"), m)
+ for (i in 4:m) {
+ tmp[, i] = resm - upperBound(subset(Res2, 1:i))
+ }
+ tmp = tmp[attr(Res2, "index"), , drop=FALSE]
+ tmp2 = Y[result[,1],] + Y[result[,2],]
+ tmp3 = pmax(tmp, tmp2)
+# Res = rbind(Res, data[ind, ])
+ tmp = rbind(tmp3, Y[ind, ])
+ weight = c(result[, 3], w[ind])
+ res = t(tmp) %*% weight
+ #res[m] - res
+ res
+}
+
+
+#
+# Sankoff
+#
+
+#old2new.phyDat <- function(data){}
+# works only for nucleotides
+old2new.phyDat <- function(obj){
+ att <- attributes(obj)
+ l = length(obj)
+ contrast <- attr(obj, "contrast")
+ nr <- attr(obj, "nr")
+ X = matrix(rep(rowSums(contrast), each=nr),nrow=nr)
+ res <- vector("list", l)
+ for(i in 1:l){
+ browser()
+ tmp = X - tcrossprod(obj[[i]], contrast)
+ res[[i]] = unlist(apply(tmp, 1, function(x)which(x<1e-6)[1]))
+ }
+ attributes(res) <- att
+ res
+}
+
+old2new.phyDat <- function(obj){
+ att <- attributes(obj)
+ l = length(obj)
+ contrast <- attr(obj, "contrast")
+ nr <- attr(obj, "nr")
+ X = matrix(rep(rowSums(contrast), each=nr),nrow=nr)
+ for(i in 1:l)obj[[i]][obj[[i]]>0] = 1
+ res <- vector("list", l)
+ contrast[contrast==0]=1e6
+ for(i in 1:l){
+ tmp = tcrossprod(obj[[i]], contrast) - X
+ res[[i]] = unlist(apply(tmp, 1, function(x)which(x<1e-6)[1]))
+ }
+ attributes(res) <- att
+ res
+}
+
+
+
+new2old.phyDat <- function(data){
+ contrast = attr(data, "contrast")
+ for(i in 1:length(data)) data[[i]] = contrast[data[[i]],,drop=FALSE]
+ data
+ }
+
+
+prepareDataSankoff <- function(data){
+ contrast = attr(data, "contrast")
+ contrast[contrast == 0] = 1e+06
+ contrast[contrast == 1] <- 0
+ for (i in 1:length(data)) data[[i]] = contrast[data[[i]], , drop = FALSE]
+ data
+}
+
+
+
+sankoff <- function (tree, data, cost = NULL, site = 'pscore')
+{
+ if (class(data) != "phyDat")
+ stop("data must be of class phyDat")
+ data <- prepareDataSankoff(data)
+ levels <- attr(data, "levels")
+ l = length(levels)
+
+ if (is.null(cost)) {
+ cost <- matrix(1, l, l)
+ cost <- cost - diag(l)
+ }
+ for (i in 1:length(data)) storage.mode(data[[i]]) = "double"
+ if(class(tree)=="phylo") return(fit.sankoff(tree, data, cost, returnData =site))
+ if(class(tree)=="multiPhylo"){
+ if(is.null(tree$TipLabel))tree = unclass(tree)
+ return(sapply(tree, fit.sankoff, data, cost, site))
+ }
+}
+
+
+fit.sankoff <- function (tree, data, cost, returnData = c("pscore", "site", "data"))
+{
+ if (is.null(attr(tree, "order")) || attr(tree, "order") ==
+ "cladewise")
+ tree <- reorder(tree, "postorder")
+ returnData <- match.arg(returnData)
+ node <- tree$edge[, 1]
+ edge <- tree$edge[, 2]
+ weight = attr(data, "weight")
+ nr = p = attr(data, "nr")
+ q = length(tree$tip.label)
+ nc = l = attr(data, "nc")
+ m = length(edge) + 1
+ dat = vector(mode = "list", length = m)
+ dat[1:q] = data[tree$tip.label]
+ node = as.integer(node - 1)
+ edge = as.integer(edge - 1)
+ nTips = as.integer(length(tree$tip))
+ mNodes = as.integer(max(node) + 1)
+ tips = as.integer((1:length(tree$tip))-1)
+ res <- .Call("sankoff3", dat, as.numeric(cost), as.integer(nr),as.integer(nc),
+ node, edge, mNodes, tips, PACKAGE="phangorn")
+ root <- getRoot(tree)
+ erg <- .Call("C_rowMin", res[[root]], as.integer(nr), as.integer(nc), PACKAGE = "phangorn")
+ if (returnData=='site') return(erg)
+ pscore <- sum(weight * erg)
+ result = pscore
+ if (returnData=="data"){
+ result <- list(pscore = pscore, dat = res)
+ }
+ result
+}
+
+
+pnodes <- function (tree, data, cost)
+{
+ if (is.null(attr(tree, "order")) || attr(tree, "order") ==
+ "cladewise")
+ tree <- reorder(tree, "postorder")
+ node <- tree$edge[, 1]
+ edge <- tree$edge[, 2]
+ nr = nrow(data[[1]])
+ nc = ncol(data[[1]])
+ node = as.integer(node - 1)
+ edge = as.integer(edge - 1)
+ .Call("pNodes", data, as.numeric(cost), as.integer(nr),as.integer(nc),
+ node, edge, PACKAGE="phangorn")
+}
+
+
+indexNNI <- function(tree){
+ parent = tree$edge[, 1]
+ child = tree$edge[, 2]
+
+ ind = which(child %in% parent)
+ Nnode = tree$Nnode
+ edgeMatrix = matrix(0,(Nnode-1),5)
+
+ pvector <- numeric(max(parent))
+ pvector[child] <- parent
+ tips <- !logical(max(parent))
+ tips[parent] <- FALSE
+# cvector <- allCildren(tree)
+ cvector <- vector("list",max(parent))
+ for(i in 1:length(parent)) cvector[[parent[i]]] <- c(cvector[[parent[i]]], child[i])
+ k=0
+ for(i in ind){
+ p1 = parent[i]
+ p2 = child[i]
+ e34 = cvector[[p2]]
+ ind1 = cvector[[p1]]
+ e12 = ind1[ind1 != p2]
+ if(pvector[p1])e12=c(p1,e12)
+ edgeMatrix[k+1, ] = c(e12,e34,p2)
+ k=k+1
+ }
+# vielleicht raus
+ attr(edgeMatrix, 'root') <-cvector[[min(parent)]]
+ edgeMatrix
+}
+
+
+sankoff.nni = function (tree, data, cost, ...)
+{
+ if(is.rooted(tree))tree<- reorder(unroot(tree), "postorder")
+ INDEX <- indexNNI(tree)
+ rootEdges <- attr(INDEX,"root")
+ if (class(data) != "phyDat")
+ stop("data must be of class phyDat")
+ levels <- attr(data, "levels")
+ l = length(levels)
+ weight = attr(data, "weight")
+ p = attr(data, "nr")
+ kl = TRUE
+ i = 1
+ tmp = fit.sankoff(tree, data, cost, returnData='data')
+ p0 = tmp[[1]]
+ datf = tmp[[2]]
+ datp = pnodes(tree, datf, cost)
+
+ parent = tree$edge[,1]
+ child = tree$edge[,2]
+ m <- dim(INDEX)[1]
+ k = min(parent)
+ pscore = numeric(2*m)
+
+ for(i in 1:m){
+ ei = INDEX[i,]
+ datn <- datf[ei[1:4]]
+ if (!(ei[5] %in% rootEdges)) datn[1] = datp[ei[1]]
+ pscore[(2*i)-1] <- sankoff.quartet(datn[ c(1, 3, 2, 4)],
+ cost, p, l, weight)
+ pscore[(2*i)] <- sankoff.quartet(datn[ c(1, 4, 3, 2)],
+ cost, p, l, weight)
+ }
+ swap <- 0
+ candidates <- pscore < p0
+ while(any(candidates)){
+
+ ind = which.min(pscore)
+ pscore[ind]=Inf
+ if( ind %% 2 ) swap.edge = c(2,3)
+ else swap.edge = c(2,4)
+
+ tree2 <- changeEdge(tree, INDEX[(ind+1)%/%2,swap.edge])
+ test <- fit.sankoff(tree2, data, cost, 'pscore')
+
+ if(test >= p0) candidates[ind] = FALSE
+ if(test < p0) {
+ p0 <- test
+ swap=swap+1
+ tree <- tree2
+ candidates[ind] = FALSE
+ indi <- which(rep(colSums(apply(INDEX,1,match,INDEX[(ind+1)%/%2,],nomatch=0))>0,each=2))
+ candidates[indi] <- FALSE
+ pscore[indi] <- Inf
+ }
+ }
+ list(tree = tree, pscore = p0, swap = swap)
+}
+
+
+optim.parsimony <- function(tree,data, method='fitch', cost=NULL, trace=1, rearrangements="SPR", ...){
+ if(method=='fitch') result <- optim.fitch(tree=tree, data=data, trace=trace, rearrangements=rearrangements, ...)
+ if(method=='sankoff') result <- optim.sankoff(tree=tree, data=data, cost=cost, trace=trace, ...)
+ result
+}
+
+
+pratchet <- function (data, start=NULL, method="fitch", maxit=100, k=5, trace=1, all=FALSE, rearrangements="SPR", ...)
+{
+ eps = 1e-08
+# if(method=="fitch" && (is.null(attr(data, "compressed")) || attr(data, "compressed") == FALSE))
+# data <- compressSites(data)
+ trace = trace - 1
+ uniquetree <- function(trees) {
+ k = 1
+ res = trees[[1]]
+ result = list()
+ result[[1]]=res
+ k=2
+ trees = trees[-1]
+ while (length(trees) > 0) {
+# test and replace
+# change RF to do this faster RF.dist(res, trees) class(tree) = "multiPhylo"
+# rf2 = RF.dist(res, trees, FALSE)
+ rf = sapply(trees, RF.dist, res, FALSE)
+ if(any(rf==0))trees = trees[-which(rf == 0)]
+ if (length(trees) > 0) {
+ res = trees[[1]]
+ result[[k]] = res
+ k=k+1
+ trees = trees[-1]
+ }
+ }
+ result
+ }
+ if (is.null(start))
+ start = optim.parsimony(nj(dist.hamming(data)), data, trace = trace, method=method, rearrangements=rearrangements, ...)
+ tree = start
+ data = subset(data, tree$tip.label)
+ attr(tree, "pscore") = parsimony(tree, data, method=method, ...)
+ mp <- attr(tree, "pscore")
+ if (trace >= 0)
+ print(paste("Best pscore so far:",attr(tree, "pscore")))
+
+ FUN = function(data, tree, method, rearrangements, ...)
+ optim.parsimony(tree, data = data, method=method, rearrangements=rearrangements, ...)
+ result = list()
+ result[[1]] = tree
+ kmax = 1
+ for (i in 1:maxit) {
+ bstrees <- bootstrap.phyDat(data, FUN, tree = tree, bs = 1, trace = trace, method=method, rearrangements=rearrangements, ...)
+ trees <- lapply(bstrees, optim.parsimony, data, trace = trace, method=method, rearrangements=rearrangements, ...)
+ if(class(result)=="phylo")m=1
+ else m = length(result)
+ if(m>0) trees[2 : (1+m)] = result[1:m]
+ pscores <- sapply(trees, function(data) attr(data, "pscore"))
+ mp1 = min(pscores)
+ if((mp1+eps) < mp) kmax=1
+ else kmax=kmax+1
+ mp=mp1
+
+ if (trace >= 0)
+ print(paste("Best pscore so far:",mp))
+ ind = which(pscores < mp + eps)
+ if (length(ind) == 1) {
+ result = trees[ind]
+ tree = result[[1]]
+ }
+ else {
+ result = uniquetree(trees[ind])
+ l = length(result)
+ tree = result[[sample(l, 1)]]
+ }
+ if(kmax == k) break()
+ }# for
+ if(!all) return(tree)
+ if(length(result)==1) return(result[[1]])
+ class(result) = "multiPhylo"
+ result
+} # pratchet
+
+
+
+optim.sankoff <- function(tree, data, cost=NULL, trace=1, ...) {
+ if(class(tree)!="phylo") stop("tree must be of class phylo")
+ if(is.rooted(tree))tree <- unroot(tree)
+ if(is.null(attr(tree, "order")) || attr(tree, "order") == "cladewise") tree <- reorder(tree, "postorder")
+ if (class(data)[1] != "phyDat") stop("data must be of class phyDat")
+
+ rt = FALSE
+ dat <- prepareDataSankoff(data)
+ l <- attr(dat, "nc")
+ if (is.null(cost)) {
+ cost <- matrix(1, l, l)
+ cost <- cost - diag(l)
+ # rt = TRUE
+ }
+ tree$edge.length=NULL
+ swap = 0
+ iter = TRUE
+ pscore <- fit.sankoff(tree,dat,cost,'pscore')
+ while (iter) {
+ res <- sankoff.nni(tree,dat,cost,...)
+ tree <- res$tree
+ if(trace>1)cat("optimize topology: ", pscore , "-->", res$pscore,
+ "\n")
+ pscore = res$pscore
+ swap = swap + res$swap
+ if (res$swap == 0) iter = FALSE
+ }
+ if(trace>0)cat("Final p-score",pscore,"after ",swap, "nni operations \n")
+ if(rt)tree <- ptree(tree, data)
+ attr(tree, "pscore") = pscore
+ tree
+}
+
+
+#
+# ACCTRAN
+#
+ptree <- function (tree, data, type = "ACCTRAN", retData = FALSE)
+{
+ if (class(data) != "phyDat")
+ stop("data must be of class phyDat")
+ if (is.null(attr(tree, "order")) || attr(tree, "order") ==
+ "cladewise")
+ tree <- reorder(tree, "pruningwise")
+ # if (!is.binary.tree(tree))
+ # stop("Tree must be binary!")
+ tmp = fitch(tree, data, site = "data")
+ nr = attr(data, "nr")
+ node <- tree$edge[, 1]
+ edge <- tree$edge[, 2]
+ weight = attr(data, "weight")
+ m = length(edge) + 1
+ q = length(tree$tip)
+ l = as.integer(length(edge))
+ nTips = length(tree$tip)
+ dat = tmp[[2]]
+ if (!is.rooted2(tree)) {
+ root = getRoot(tree)
+ ind = edge[node == root]
+ rSeq = .C("fitchTriplet", integer(nr), dat[, ind[1]],
+ dat[, ind[2]], dat[, ind[3]], as.integer(nr))
+ dat[, root] = rSeq[[1]]
+ }
+ result <- .C("ACCTRAN2", dat, as.integer(nr), numeric(nr),
+ as.integer(node[l:1L]), as.integer(edge[l:1L]), l, as.double(weight),
+ numeric(l), as.integer(nTips))
+ el = result[[8]][l:1L]
+ if (!is.rooted2(tree)) {
+ ind2 = which(node[] == root)
+ dat = matrix(result[[1]], nr, max(node))
+ result <- .C("ACCTRAN3", result[[1]], as.integer(nr),
+ numeric(nr), as.integer(node[(l - 3L):1L]), as.integer(edge[(l -
+ 3L):1L]), l - 3L, as.double(weight), numeric(l),
+ as.integer(nTips))
+ el = result[[8]][(l - 3L):1L]
+ pars = .C("fitchTripletACC4", dat[, root], dat[, ind[1]],
+ dat[, ind[2]], dat[, ind[3]], as.integer(nr), numeric(1),
+ numeric(1), numeric(1), as.double(weight), numeric(nr),
+ integer(nr))
+ el[ind2[1]] = pars[[6]]
+ el[ind2[2]] = pars[[7]]
+ el[ind2[3]] = pars[[8]]
+ }
+ else {
+ result <- .C("ACCTRAN3", result[[1]], as.integer(nr),
+ numeric(nr), as.integer(node[l:1L]), as.integer(edge[l:1L]),
+ l, as.double(weight), numeric(l), as.integer(nTips))
+ el = result[[8]][l:1L]
+ }
+ tree$edge.length = el
+ if (retData)
+ return(list(tree, matrix(result[[1]], nr, max(node))))
+ tree
+}
+
+
+acctran <- function(tree, data) ptree(tree, data, type="ACCTRAN", retData=FALSE)
+
+
+parsimony.plot <- function(tree, ...){
+ x = numeric(max(tree$edge))
+ x[tree$edge[,2]] = tree$edge.length
+ plot(tree, ...)
+ ind <- get("last_plot.phylo", envir = .PlotPhyloEnv)$edge[, 2]
+ edgelabels(prettyNum(x[ind]), frame = "none")
+}
+
diff --git a/R/phyDat.R b/R/phyDat.R
new file mode 100644
index 0000000..40141d2
--- /dev/null
+++ b/R/phyDat.R
@@ -0,0 +1,937 @@
+#
+# Data structures for ML and MP
+#
+fast.table <- function (data)
+{
+ if(!is.data.frame(data))
+ data = as.data.frame(data, stringsAsFactors = FALSE)
+ da = do.call("paste", c(data, sep = "\r"))
+ ind = !duplicated(da)
+ levels = da[ind]
+ cat <- factor(da,levels = levels)
+ nl <- length(levels(cat))
+ bin <- (as.integer(cat) - 1)
+ pd <- nl
+ bin <- bin[!is.na(bin)]
+ if (length(bin)) bin <- bin + 1
+ y <- tabulate(bin, pd)
+ result=list(index = bin, weights = y, data = data[ind,])
+ result
+}
+
+
+phyDat.default <- function (data, levels = NULL, return.index = TRUE, contrast = NULL,
+ ambiguity = "?", compress=TRUE, ...)
+{
+ if (is.matrix(data))
+ nam = row.names(data)
+ else nam = names(data)
+ if (class(data) == "DNAbin")
+ data = as.character(data)
+ if (is.matrix(data))
+ data = as.data.frame(t(data), stringsAsFactors = FALSE)
+ else data = as.data.frame(data, stringsAsFactors = FALSE)
+ if(compress){
+ ddd = fast.table(data)
+ data = ddd$data
+ weight = ddd$weight
+ index = ddd$index
+ }
+ else{
+ p = length(data[[1]])
+ weight = rep(1, p)
+ index = 1:p
+ }
+ q = length(data)
+ p = length(data[[1]])
+ tmp <- vector("list", q)
+ if (!is.null(contrast)) {
+ levels = colnames(contrast)
+ all.levels = rownames(contrast)
+ rownames(contrast) = NULL
+ }
+ else {
+ if (is.null(levels))
+ stop("Either argument levels or contrast has to be supplied")
+ l = length(levels)
+ contrast = diag(l)
+ all.levels = levels
+ if (!is.null(ambiguity)) {
+ all.levels = c(all.levels, ambiguity)
+ k = length(ambiguity)
+ if (k > 0)
+ contrast = rbind(contrast, matrix(1, k, l))
+ }
+ }
+ d = dim(data)
+ att = attributes(data)
+ data = match(unlist(data), all.levels)
+ attr(data, "dim") = d
+ data = as.data.frame(data, stringsAsFactors=FALSE)
+ attributes(data) = att
+
+ row.names(data) = as.character(1:p)
+ data = na.omit(data)
+
+ aaa = match(index, attr(data, "na.action"))
+ index = index[is.na(aaa)]
+ index = match(index, unique(index))
+ rn = as.numeric(rownames(data))
+ attr(data, "na.action") = NULL
+
+ weight = weight[rn]
+ p = dim(data)[1]
+ names(data) = nam
+ attr(data, "row.names") = NULL
+ attr(data, "weight") = weight
+ attr(data, "nr") = p
+ attr(data, "nc") = length(levels)
+ if (return.index)
+ attr(data, "index") = index
+ attr(data, "levels") = levels
+ attr(data, "allLevels") = all.levels
+ attr(data, "type") = "USER"
+ attr(data, "contrast") = contrast
+ class(data) = "phyDat"
+ data
+}
+
+
+phyDat.DNA = function (data, return.index = TRUE)
+{
+ if (is.matrix(data))
+ nam = row.names(data)
+ else nam = names(data)
+ if (class(data) == "DNAbin")
+ data = as.character(data)
+ if (is.matrix(data))
+ data = as.data.frame(t(data), stringsAsFactors = FALSE)
+ else data = as.data.frame(data, stringsAsFactors = FALSE)
+
+ data = data.frame(tolower(as.matrix(data)), stringsAsFactors = FALSE)
+
+ ac = c("a", "c", "g", "t", "u", "m", "r", "w", "s", "y",
+ "k", "v", "h", "d", "b", "n", "?", "-")
+ AC = matrix(c(c(1, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 1, 1, 1,
+ 0, 1, 1, 1), c(0, 1, 0, 0, 0, 1, 0, 0, 1, 1, 0, 1, 1,
+ 0, 1, 1, 1, 1), c(0, 0, 1, 0, 0, 0, 1, 0, 1, 0, 1, 1,
+ 0, 1, 1, 1, 1, 1), c(0, 0, 0, 1, 1, 0, 0, 1, 0, 1, 1,
+ 0, 1, 1, 1, 1, 1, 1)), 18, 4, dimnames = list(NULL, c("a",
+ "c", "g", "t")))
+
+ ddd = fast.table(data)
+ data = ddd$data
+ index = ddd$index
+ q = length(data)
+ p = length(data[[1]])
+ d = dim(data)
+ att = attributes(data)
+ data = match(unlist(data), ac)
+ attr(data, "dim") = d
+ data = as.data.frame(data, stringsAsFactors=FALSE)
+ attributes(data) = att
+
+ row.names(data) = as.character(1:p)
+ data = na.omit(data)
+ rn = as.numeric(rownames(data))
+
+ aaa = match(index, attr(data, "na.action"))
+ index = index[is.na(aaa)]
+ index = match(index, unique(index))
+ rn = as.numeric(rownames(data))
+ attr(data, "na.action") = NULL
+
+ weight = ddd$weight[rn]
+ p = dim(data)[1]
+ names(data) = nam
+ attr(data, "row.names") = NULL
+ attr(data, "weight") = weight
+ attr(data, "nr") = p
+ attr(data, "nc") = 4
+ if (return.index)
+ attr(data, "index") = index
+ attr(data, "levels") = c("a", "c", "g", "t")
+ attr(data, "allLevels") = ac
+ attr(data, "type") = "DNA"
+ attr(data, "contrast") = AC
+ class(data) = "phyDat"
+ data
+}
+
+
+phyDat.AA <- function (data, return.index = TRUE)
+{
+ if(is.matrix(data)) nam = row.names(data)
+ else nam = names(data)
+ if (class(data) == "DNAbin")
+ data = as.character(data)
+ if (is.matrix(data))
+ data = as.data.frame(t(data), stringsAsFactors = FALSE)
+ else data = as.data.frame(data, stringsAsFactors = FALSE)
+
+ data = data.frame(tolower(as.matrix(data)), stringsAsFactors = FALSE)
+
+ aa <- c("a", "r", "n", "d", "c", "q", "e", "g", "h", "i",
+ "l", "k", "m", "f", "p", "s", "t", "w", "y", "v")
+ aa2 <- c("a", "r", "n", "d", "c", "q", "e", "g", "h", "i",
+ "l", "k", "m", "f", "p", "s", "t", "w", "y", "v", "b",
+ "z", "x", "-", "?")
+ AA <- diag(20)
+ AA <- rbind(AA, matrix(0, 5, 20))
+ AA[21, 3] <- AA[21, 4] <- 1 # Aspartate or Asparagine
+ AA[22, 6] <- AA[22, 7] <- 1 #
+ AA[23:25, ] = 1
+ dimnames(AA) <- list(aa2, aa)
+
+ ddd = fast.table(data)
+ data = ddd$data
+ index = ddd$index
+ q = length(data)
+ p = length(data[[1]])
+ tmp <- vector("list", q)
+
+ d = dim(data)
+ att = attributes(data)
+ data = match(unlist(data), aa2)
+ attr(data, "dim") = d
+ data = as.data.frame(data, stringsAsFactors=FALSE)
+ attributes(data) = att
+
+ row.names(data) = as.character(1:p)
+ data = na.omit(data)
+ rn = as.numeric(rownames(data))
+
+ aaa = match(index, attr(data, "na.action"))
+ index = index[is.na(aaa)]
+ index = match(index, unique(index))
+ rn = as.numeric(rownames(data))
+ attr(data, "na.action") = NULL
+
+ weight = ddd$weight[rn]
+ p = dim(data)[1]
+ names(data) = nam
+ attr(data, "row.names") = NULL
+ attr(data, "weight") = weight
+ attr(data, "nr") = p
+ attr(data, "nc") = 20
+ if (return.index)
+ attr(data, "index") = index
+ attr(data, "levels") = aa
+ attr(data, "allLevels") = aa2
+ attr(data, "type") = "AA"
+ attr(data, "contrast") = AA
+ class(data) = "phyDat"
+ data
+}
+
+
+
+phyDat.codon <- function (data, return.index = TRUE)
+{
+ if(is.matrix(data)) nam = row.names(data)
+ else nam = names(data)
+ if (class(data) == "DNAbin")
+ data = as.character(data)
+
+ if (is.matrix(data))
+ data = as.data.frame(t(data), stringsAsFactors = FALSE)
+ else data = as.data.frame(data, stringsAsFactors = FALSE)
+
+ data = data.frame(tolower(as.matrix(data)), stringsAsFactors = FALSE)
+
+ data[data=="u"] = "t"
+
+ splseq = function (seq, frame = 0)
+ {
+ starts <- seq(from = frame + 1, to = length(seq), by = 3L)
+ sapply(starts, function(x) paste(seq[x:(x + 2L)], collapse=""))
+ }
+
+ data = sapply(data, splseq)
+
+ ddd = fast.table(data)
+ codon = c("aaa", "aac", "aag", "aat", "aca", "acc", "acg", "act",
+ "aga", "agc", "agg", "agt", "ata", "atc", "atg", "att",
+ "caa", "cac", "cag", "cat", "cca", "ccc", "ccg", "cct", "cga",
+ "cgc", "cgg", "cgt", "cta", "ctc", "ctg", "ctt", "gaa", "gac",
+ "gag", "gat", "gca", "gcc", "gcg", "gct", "gga", "ggc", "ggg",
+ "ggt", "gta", "gtc", "gtg", "gtt", "tac", "tat",
+ "tca", "tcc", "tcg", "tct", "tgc", "tgg", "tgt", "tta",
+ "ttc", "ttg", "ttt")
+# ohne Stopcodons "taa", "tag", "tga",
+
+ CODON <- diag(61)
+ dimnames(CODON) <- list(codon, codon)
+
+ data = ddd$data
+ index = ddd$index
+ q = length(data)
+ p = length(data[[1]])
+ tmp <- vector("list", q)
+
+ d = dim(data)
+ att = attributes(data)
+ data = match(unlist(data), codon)
+ attr(data, "dim") = d
+ data = as.data.frame(data, stringsAsFactors=FALSE)
+ attributes(data) = att
+
+ row.names(data) = as.character(1:p)
+ data = na.omit(data)
+ rn = as.numeric(rownames(data))
+
+ aaa = match(index, attr(data, "na.action"))
+ index = index[is.na(aaa)]
+ index = match(index, unique(index))
+ rn = as.numeric(rownames(data))
+ attr(data, "na.action") = NULL
+
+ weight = ddd$weight[rn]
+ p = dim(data)[1]
+ names(data) = nam
+ attr(data, "row.names") = NULL
+ attr(data, "weight") = weight
+ attr(data, "nr") = p
+ attr(data, "nc") = 61
+ if (return.index)
+ attr(data, "index") = index
+ attr(data, "levels") = codon
+ attr(data, "allLevels") = codon
+ attr(data, "type") = "CODON"
+ attr(data, "contrast") = CODON
+ class(data) = "phyDat"
+ data
+}
+
+
+as.phyDat <- function (x, ...){
+ if (class(x) == "phyDat") return(x)
+ UseMethod("as.phyDat")
+}
+
+
+as.phyDat.DNAbin <- function(x,...) phyDat.DNA(x,...)
+
+
+
+
+as.phyDat.alignment <- function (x, type="DNA",...)
+{
+ x$seq <- tolower(x$seq)
+ data <- sapply(x$seq, strsplit, "")
+ names(data) <- x$nam
+ if(type=="DNA") dat <- phyDat.DNA(data,...)
+ if(type=="AA") dat <- phyDat.AA(data, ...)
+ if(type=="CODON") dat <- phyDat.codon(data, ...)
+ if(type=="USER") dat <- phyDat.default(data, ...)
+ dat
+}
+
+
+as.alignment.phyDat <- function(x, ...) as.alignment(as.character(x))
+
+
+as.phyDat.matrix <- function (x, ...) phyDat(data=x, ...)
+
+
+as.phyDat.data.frame <- function (x, ...) phyDat(data=x, ...)
+
+
+acgt2ry <- function(obj){
+ ac = c("a", "c", "g", "t", "u", "m", "r", "w", "s", "y",
+ "k", "v", "h", "d", "b", "n", "?", "-")
+ AC = matrix(c(c(1, 0, 0, 0, 0, 1, 1, 1, 0, 0, 0, 1, 1, 1,
+ 0, 1, 1, 1), c(0, 1, 0, 0, 0, 1, 0, 0, 1, 1, 0, 1, 1,
+ 0, 1, 1, 1, 1), c(0, 0, 1, 0, 0, 0, 1, 0, 1, 0, 1, 1,
+ 0, 1, 1, 1, 1, 1), c(0, 0, 0, 1, 1, 0, 0, 1, 0, 1, 1,
+ 0, 1, 1, 1, 1, 1, 1)), 18, 4, dimnames = list(NULL, c("a",
+ "c", "g", "t")))
+ ry = AC[c(7,10),]
+ RY = AC %*% t(ry)
+ RY[RY==2] = 1
+ dimnames(RY) = list(NULL, c("r", "y"))
+ attr(obj, "levels") = c("r", "y")
+ attr(obj, "nc") = 2
+ attr(obj, "type") = "USER"
+ attr(obj, "contrast") = RY
+ obj=phyDat.default(as.character(obj, allLevels=FALSE), levels = c("r", "y"), ambiguity = NULL)
+ obj
+}
+
+
+as.character.phyDat <- function (x, allLevels=TRUE, ...)
+{
+ nr <- attr(x, "nr")
+ nc <- attr(x, "nc")
+ type <- attr(x, "type")
+ if (type == "DNA") {
+ labels <- c("a", "c", "g", "t", "u", "m", "r", "w", "s",
+ "y", "k", "v", "h", "d", "b", "n", "?", "-")
+ }
+ if (type == "AA") {
+ labels <- c("a", "r", "n", "d", "c", "q", "e", "g", "h",
+ "i", "l", "k", "m", "f", "p", "s", "t", "w", "y",
+ "v", "b", "z", "x", "-", "?")
+ }
+ if (type == "USER") {
+ #levels
+ if(allLevels)labels = attr(x, "allLevels")
+ else{
+ tmp = attr(x, "levels")
+ contrast = attr(x, "contrast") # contrast=AC
+ contrast[contrast>0] = 1
+ ind = which(rowSums(contrast)==1)
+ contrast[rowSums(contrast)>1,] = 0
+ labels = rep(NA, length(attr(x, "allLevels")))
+ labels[ind] = tmp[contrast%*%c(1:length(tmp))]
+ }
+ }
+ result = matrix(NA, nrow = length(x), ncol = nr)
+ for (i in 1:length(x)) result[i, ] <- labels[x[[i]]]
+ if (is.null(attr(x, "index")))
+ index = rep(1:nr, attr(x, "weight"))
+ else {
+ index = attr(x, "index")
+ if (is.data.frame(index))
+ index <- index[, 1]
+ }
+ result = result[, index, drop = FALSE]
+ rownames(result) = names(x)
+ result
+}
+
+
+# replace as.character.phyDat 20 Zeilen weniger
+as.character.phyDat2 <- function (x, ...)
+{
+ nr <- attr(x, "nr")
+ nc <- attr(x, "nc")
+ type <- attr(x, "type")
+ labels = attr(x, "allLevels")
+ result = matrix(NA, nrow = length(x), ncol = nr)
+ for (i in 1:length(x)) result[i, ] <- labels[x[[i]]]
+ if (is.null(attr(x, "index")))
+ index = rep(1:nr, attr(x, "weight"))
+ else {
+ index = attr(x, "index")
+ if (is.data.frame(index))
+ index <- index[, 1]
+ }
+ result = result[, index, drop = FALSE]
+ rownames(result) = names(x)
+ result
+}
+
+
+#as.data.frame.phyDat <- function(x, ...){
+# data.frame(t(as.character(x, ...)), stringsAsFactors=FALSE)
+#}
+
+# much faster
+# TODO as stringsAsFactors=FALSE
+# result[[i]] <- x[[i]] + factor levels setzen
+#
+as.data.frame.phyDatOld <- function(x, ...){
+ nr <- attr(x, "nr")
+ nc <- attr(x, "nc")
+ labels <- attr(x, "allLevels")
+ result <- vector("list", length(x))
+ for (i in 1:length(x)) result[[i]] <- labels[x[[i]]]
+ attr(result, "names") <- names(x)
+ attr(result, "row.names") <- 1:nr
+ attr(result, "class") <- "data.frame"
+ result
+}
+
+
+as.data.frame.phyDat <- function(x, ...){
+ nr <- attr(x, "nr")
+ nc <- attr(x, "nc")
+ labels <- attr(x, "allLevels")
+ result <- vector("list", length(x))
+ if (is.null(attr(x, "index")))
+ index = rep(1:nr, attr(x, "weight"))
+ else {
+ index = attr(x, "index")
+ if (is.data.frame(index))
+ index <- index[, 1]
+ }
+ for (i in 1:length(x)) result[[i]] <- labels[x[[i]][index]]
+ attr(result, "names") <- names(x)
+ attr(result, "row.names") <- 1:length(index)
+ attr(result, "class") <- "data.frame"
+ result
+}
+
+
+#as.DNAbin.phyDat <- function(x,...) {
+# if(attr(x, "type")=="DNA") return(as.DNAbin(as.character(x, ...)))
+# else stop("x must be a nucleotide sequence")
+#}
+
+# quite abit faster
+as.DNAbin.phyDat <- function (x, ...)
+{
+ if(attr(x, "type")=="DNA"){
+
+ nr <- attr(x, "nr")
+ ac = attr(x, "allLevels")
+ result = matrix(as.raw(0), nrow = length(x), ncol = nr)
+ # from ape ._cs_
+ cs <- c("a", "g", "c", "t", "r", "m", "w", "s", "k", "y", "v", "h",
+ "d", "b", "n", "-", "?")
+ # from ape ._bs_
+ bs <- as.raw(c(136, 72, 40, 24, 192, 160, 144, 96, 80, 48, 224, 176, 208,
+ 112, 240, 4, 2))
+ ord <- match(ac, cs)
+ ord[5] <- 4
+
+ for (i in 1:length(x)){
+ ind <- ord[x[[i]]]
+ result[i,] <- bs[ind]
+ }
+ if (is.null(attr(x, "index")))
+ index = rep(1:nr, attr(x, "weight"))
+ else {
+ index = attr(x, "index")
+ if (is.data.frame(index))
+ index <- index[, 1]
+ }
+ result = result[, index, drop = FALSE]
+ rownames(result) = names(x)
+ class(result) <- "DNAbin"
+ return(result)
+ }
+ else stop("x must be a nucleotide sequence")
+}
+
+
+
+phyDat <- function (data, type="DNA", levels=NULL, return.index = TRUE,...)
+{
+ if (class(data) == "DNAbin") type <- "DNA"
+ pt <- match.arg(type, c("DNA", "AA", "CODON", "USER"))
+ if(pt=="DNA") dat <- phyDat.DNA(data, return.index=return.index,...)
+ if(pt=="AA") dat <- phyDat.AA(data, return.index=return.index, ...)
+ if(pt=="CODON") dat <- phyDat.codon(data, return.index=return.index, ...)
+ if(pt=="USER") dat <- phyDat.default(data, levels = levels, return.index=return.index, ...)
+ dat
+}
+
+
+print.phyDat = function (x, ...)
+{
+ cat(length(x), "sequences with",sum(attr(x,"weight")), "character and",attr(x,"nr"),"different site patterns.\n")
+ cat("The states are",attr(x,"levels"), "\n")
+}
+
+
+c.phyDat <- function(...){
+ object <- as.list(substitute(list(...)))[-1]
+ x <- list(...)
+ n <- length(x)
+ match.names <- function(a,b){
+ if(any(!(a %in% b)))stop("names do not match previous names")
+ }
+ if (n == 1)
+ return(x[[1]])
+ type <- attr(x[[1]], "type")
+ nr = numeric(n)
+ nr[1] <- sum(attr(x[[1]], "weight"))
+ levels <- attr(x[[1]], "levels")
+ snames <- names(x[[1]])
+ objNames<-as.character(object)
+ if(any(duplicated(objNames))) objNames <- paste(objNames,1:n,sep="")
+ tmp <- as.character(x[[1]])
+ for(i in 2:n){
+ match.names(snames,names(x[[i]]))
+ x[[i]] <- getCols(x[[i]],snames)
+ nr[i] <- sum(attr(x[[i]], "weight"))
+ tmp <- cbind(tmp, as.character(x[[i]]))
+ }
+ if (type == "DNA")
+ dat <- phyDat.DNA(tmp, return.index = TRUE)
+ if (type == "AA")
+ dat <- phyDat.AA(tmp, return.index = TRUE)
+ if (type == "USER")
+ dat <- phyDat.default(tmp, levels = levels, return.index = TRUE)
+ if (type == "CODON")
+ dat <- phyDat.codon(tmp, return.index = TRUE)
+ attr(dat,"index") <- data.frame(index=attr(dat,"index"), genes=rep(objNames, nr))
+ dat
+}
+
+
+# new cbind.phyDat
+cbindPD <- function(..., gaps="-"){
+ object <- as.list(substitute(list(...)))[-1]
+ x <- list(...)
+ n <- length(x)
+ if (n == 1)
+ return(x[[1]])
+ type <- attr(x[[1]], "type")
+ nr = numeric(n)
+
+ ATTR <- attributes(x[[1]])
+
+ nr[1] <- sum(attr(x[[1]], "weight"))
+ levels <- attr(x[[1]], "levels")
+ allLevels <- attr(x[[1]], "allLevels")
+ gapsInd <- match(gaps, allLevels)
+ snames <- vector("list", n) # names(x[[1]])
+ vec = numeric(n+1)
+ wvec = numeric(n+1)
+ objNames<-as.character(object)
+ if(any(duplicated(objNames))) objNames <- paste(objNames,1:n,sep="")
+ # tmp <- as.character(x[[1]])
+
+ for(i in 1:n){
+ snames[[i]] = names(x[[i]])
+ nr[i] <- attr(x[[i]], "nr")
+ vec[i+1] = attr(x[[i]], "nr")
+ wvec[i+1] = sum(attr(x[[i]], "weight"))
+ }
+ vec = cumsum(vec)
+ wvec = cumsum(wvec)
+ snames = unique(unlist(snames))
+ weight <- numeric(vec[n+1])
+
+ index <- numeric(wvec[n+1])
+ ATTR$names <- snames
+ ATTR$nr <- vec[n+1]
+
+ tmp = matrix(gapsInd, vec[n+1], length(snames), dimnames = list(NULL, snames))
+ tmp <- as.data.frame(tmp)
+
+ for(i in 1:n){
+ nam = names(x[[i]])
+ tmp[(vec[i]+1):vec[i+1], nam] <- x[[i]][nam]
+ weight[(vec[i]+1):vec[i+1]] <- attr(x[[i]], "weight")
+ index[(wvec[i]+1):wvec[i+1]] <- attr(x[[i]], "index")
+ }
+ ATTR$index <- index
+ ATTR$weight <- weight
+ attributes(tmp) <- ATTR
+ tmp
+}
+
+
+
+cbind.phyDat <- function(..., gaps="-"){
+ object <- as.list(substitute(list(...)))[-1]
+ x <- list(...)
+ n <- length(x)
+ if (n == 1)
+ return(x[[1]])
+ type <- attr(x[[1]], "type")
+ nr = numeric(n)
+ nr[1] <- sum(attr(x[[1]], "weight"))
+ levels <- attr(x[[1]], "levels")
+ snames <- vector("list", n) # names(x[[1]])
+ vec = numeric(n+1)
+ objNames<-as.character(object)
+ if(any(duplicated(objNames))) objNames <- paste(objNames,1:n,sep="")
+ tmp <- as.character(x[[1]])
+ for(i in 1:n){
+ snames[[i]] = names(x[[i]]) #match.names(snames,names(x[[i]]))
+ nr[i] <- sum(attr(x[[i]], "weight"))
+ vec[i+1] = sum(attr(x[[i]], "weight"))
+ }
+ vec = cumsum(vec)
+ snames = unique(unlist(snames))
+
+ tmp = matrix(gaps, length(snames), vec[n+1], dimnames = list(snames, NULL))
+
+ for(i in 1:n){
+ nam = names(x[[i]])
+ tmp[nam,(vec[i]+1):vec[i+1] ] <- as.character(x[[i]])
+ }
+ if (type == "DNA")
+ dat <- phyDat.DNA(tmp, return.index = TRUE)
+ if (type == "AA")
+ dat <- phyDat.AA(tmp, return.index = TRUE)
+ if (type == "USER")
+ dat <- phyDat.default(tmp, levels = levels,
+ return.index = TRUE)
+ if (type == "CODON")
+ dat <- phyDat.codon(tmp, return.index = TRUE)
+ attr(dat,"index") <- data.frame(index=attr(dat,"index"), genes=rep(objNames, nr))
+ dat
+}
+
+
+write.phyDat <- function(x, file, format="phylip",...){
+ if(format=="fasta") write.dna(as.character(x), file, format="fasta", ...)
+ if(format=="phylip") write.dna(as.character(x), file, format="sequential", ...)
+ if(format=="nexus"){
+ type = attr(x, "type")
+ if(type=="DNA") write.nexus.data(as.list(as.data.frame(x)), file, format = "dna",...)
+ else write.nexus.data(as.list(as.data.frame(x)), file, format = "protein", ...)
+ }
+ }
+
+
+read.phyDat <- function(file, format="phylip", type="DNA", ...){
+ if(format=="nexus") data=read.nexus.data(file, ...)
+ else {
+ if(format=="phylip")format="interleaved" #"sequential"
+ if (type == "DNA" || type == "CODON"){
+ data = read.dna(file, format, as.character = TRUE, ...)
+ }
+ if (type == "AA") data = read.aa(file, format=format, ...)
+ # raus
+ }
+ phyDat(data, type, return.index = TRUE)
+}
+
+
+baseFreq <- function(obj, freq=FALSE, drop.unused.levels = FALSE){
+ if (class(obj) != "phyDat")
+ stop("data must be of class phyDat")
+ labels <- attr(obj, "allLevels")
+ weight <- attr(obj,"weight")
+ n <- length(obj)
+ res <- numeric(length(labels))
+ D = diag(length(labels))
+ for(i in 1:n)res <- res + colSums(D[obj[[i]],, drop=FALSE]*weight)
+ if(!freq)res <- res/sum(res)
+ names(res) <- labels
+ if(drop.unused.levels) return(res[res>0])
+ res
+}
+
+
+phylo <- function(edge, tip, edge.length=NULL){
+ res <- list(edge=edge, tip.label=tip, edge.length=edge.length)
+ class(res)="phylo"
+ res
+ }
+
+
+getCols <- function (data, cols)
+{
+ attrib = attributes(data)
+ attr(data, "class") <- "list"
+ data = data[cols]
+ if (is.character(cols))
+ attrib$names = cols
+ else attrib$names = attrib$names[cols]
+ attributes(data) = attrib
+ attr(data, "class") <- "phyDat"
+ data
+}
+
+
+# allows negative indexing subset(dat,,-c(3:5))
+getRows <- function (data, rows, site.pattern = TRUE)
+{
+ index <- attr(data, "index")
+ if(is.data.frame(index))index = index[,1]
+ if(!site.pattern){ # & all(rows>0)
+ weight = tabulate(index[rows])
+ ind = which(weight>0)
+ rows = ind # rows[ind]
+ weight = weight[ind]
+ }
+ for (i in 1:length(data)){
+ if(is.matrix(data[[i]]))data[[i]] = data[[i]][rows,]
+ else data[[i]] = data[[i]][rows]
+ }
+ attr(data, "weight") = attr(data, "weight")[rows]
+ if(!site.pattern) attr(data, "weight") = weight
+ attr(data, "nr") = length(attr(data, "weight"))
+ attr(data, "index") = NULL
+ data
+}
+
+
+subset.phyDat <- function (x, subset, select, site.pattern = TRUE,...)
+{
+
+ if (!missing(subset)) x <- getCols(x, subset)
+ if (!missing(select)){
+# if(!site.pattern){
+# if(is.data.frame(attr(x, "index"))) select <- attr(x, "index")[select,1]
+# else select <- attr(x, "index")[select]
+# }
+ if(any(is.na(select))) return(NULL)
+ x <- getRows(x, select, site.pattern=site.pattern)
+ }
+ x
+}
+
+
+unique.phyDat <- function(x, incomparables=FALSE, ...) getCols(x, !duplicated(x))
+
+
+allSitePattern <- function(n,levels=c("a","c","g","t"), names=NULL){
+ l=length(levels)
+ X=matrix(0, l^n,n)
+ for(i in 1:n)
+ X[, i] = rep(rep(c(1:l), each=l^(i-1)),l^(n-i))
+ for(i in 1:l)X[X==i] = levels[i]
+ if(is.null(names))colnames(X) = paste("t",1:n, sep="")
+ else colnames(X)=names
+ phyDat.default(t(X), levels)
+}
+
+
+write.phylip <- function(data, weight, file=""){
+ n = sum(weight)
+ m = dim(data)[2]
+ cat(m,n,"\n",file = file)
+ for(i in 1:m)
+ cat(colnames(data)[i]," ",toupper(rep(data[,i],weight)),"\n", sep="", file=file, append=TRUE)
+}
+
+
+read.FASTA.AA <- function (file)
+{
+ if (length(grep("^(ht|f)tp:", file))) {
+ url <- file
+ file <- tempfile()
+ download.file(url, file)
+ }
+ sz <- file.info(file)$size
+ x <- readBin(file, "raw", sz)
+ icr <- which(x == as.raw(13))
+ if (length(icr))
+ x <- x[-icr]
+ res <- .Call("rawStream2phyDat", x)
+
+ aa <- c("a", "r", "n", "d", "c", "q", "e", "g", "h", "i",
+ "l", "k", "m", "f", "p", "s", "t", "w", "y", "v")
+ aa2 <- c("a", "r", "n", "d", "c", "q", "e", "g", "h", "i",
+ "l", "k", "m", "f", "p", "s", "t", "w", "y", "v", "b",
+ "z", "x", "-", "?")
+ AA <- diag(20)
+ AA <- rbind(AA, matrix(0, 5, 20))
+ AA[21, 3] <- AA[21, 4] <- 1 # Aspartate or Asparagine
+ AA[22, 6] <- AA[22, 7] <- 1 #
+ AA[23:25, ] = 1
+ dimnames(AA) <- list(aa2, aa)
+
+ ddd = fast.table(res)
+
+ data = ddd$data
+ names(data) <- sub("^ +", "", names(data))
+ row.names(data) = NULL
+
+ attr(data, "row.names") = NULL
+ attr(data, "weight") = ddd$weight
+ attr(data, "nr") = length(ddd$weight)
+ attr(data, "nc") = 20
+ attr(data, "index") = as.integer(ddd$index)
+ attr(data, "levels") = aa
+ attr(data, "allLevels") = aa2
+ attr(data, "type") = "AA"
+ attr(data, "contrast") = AA
+ class(data) = "phyDat"
+ data
+}
+
+
+# throw out
+read.aa <- function (file, format = "interleaved", skip = 0, nlines = 0,
+ comment.char = "#", seq.names = NULL)
+{
+ getTaxaNames <- function(x) {
+ x <- sub("^ +", "", x)
+ x <- sub(" +$", "", x)
+ x <- sub("^['\"]", "", x)
+ x <- sub("['\"]$", "", x)
+ x
+ }
+ format <- match.arg(format, c("interleaved", "sequential", "fasta"))
+ phylip <- if (format %in% c("interleaved", "sequential"))
+ TRUE
+ else FALSE
+
+
+ if (format == "fasta") {
+ obj <- read.FASTA.AA(file)
+ return(obj)
+ }
+ 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)
+ 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("[-AaRrNnDdCcQqEeGgHhIiLlKkMmFfPpSsTtWwYyVvBbZzXx?]", 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("[-AaRrNnDdCcQqEeGgHhIiLlKkMmFfPpSsTtWwYyVvBbZzXx?]",
+ 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") return(read.FASTA.AA(file))
+# start <- grep("^ {0,}>", X)
+# taxa <- X[start]
+# n <- length(taxa)
+# obj <- vector("list", n)
+# if (is.null(seq.names)) {
+# taxa <- sub("^ {0,}>", "", taxa)
+# seq.names <- getTaxaNames(taxa)
+# }
+# start <- c(start, length(X) + 1)
+# 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)
+ }
+ obj
+}
+
diff --git a/R/phylo.R b/R/phylo.R
new file mode 100644
index 0000000..2f47dc5
--- /dev/null
+++ b/R/phylo.R
@@ -0,0 +1,4455 @@
+#
+# UPGMA, NJ and UNJ
+#
+"upgma" <- function(D,method="average",...){
+ DD=as.dist(D)
+ hc = hclust(DD,method=method,...)
+ result = as.phylo(hc)
+ result = reorder(result, "postorder")
+ result
+}
+
+
+"wpgma" <- function(D,method="mcquitty",...){
+ DD=as.dist(D)
+ hc = hclust(DD,method=method,...)
+ result = as.phylo(hc)
+ result = reorder(result, "postorder")
+ result
+}
+
+
+NJ_old <- function(x)
+{
+ x = as.matrix(x)
+ labels <- attr(x, "Labels")[[1]]
+ edge.length = NULL
+ edge = NULL
+ d = as.matrix(x)
+ if (is.null(labels))
+ labels = colnames(d)
+ l = dim(d)[1]
+ m = l - 2
+ nam = 1L:l
+ k = 2L * l - 2L
+ while (l > 2) {
+ r = rowSums(d)/(l - 2)
+ i = 0
+ j = 0
+ tmp <- .C("out", as.double(d), as.double(r), as.integer(l),
+ as.integer(i), as.integer(j))
+ e2 = tmp[[5]]
+ e1 = tmp[[4]]
+ l1 = d[e1, e2]/2 + (r[e1] - r[e2])/(2)
+ l2 = d[e1, e2] - l1
+ edge.length = c(l1, l2, edge.length)
+ edge = rbind(c(k, nam[e2]), edge)
+ edge = rbind(c(k, nam[e1]), edge)
+ nam = c(nam[c(-e1, -e2)], k)
+ dnew = (d[e1, ] + d[e2, ] - d[e1, e2])/2
+ d = cbind(d, dnew)
+ d = rbind(d, c(dnew, 0))
+ d = d[-c(e1, e2), -c(e1, e2)]
+ k = k - 1L
+ l = l - 1L
+ }
+ edge.length = c(d[2, 1], edge.length)
+ attr(edge.length,"names") = NULL
+ result = list(edge = rbind(c(nam[2], nam[1]), edge), edge.length = edge.length,
+ tip.label = labels, Nnode = m)
+ class(result) <- "phylo"
+ reorder(result, "postorder")
+}
+
+
+NJ <- function(x) reorder(nj(x), "postorder")
+
+
+UNJ <- function(x)
+{
+ x = as.matrix(x)
+ labels <- attr(x, "Labels")[[1]]
+ edge.length = NULL
+ edge = NULL
+ d = as.matrix(x)
+ if (is.null(labels))
+ labels = colnames(d)
+ l = dim(d)[1]
+ n = l
+ nam = as.character(1:l)
+ m=l-2
+ nam = 1:l
+ k = 2*l-2
+ w = rep(1,l)
+ while (l > 2) {
+ r = rowSums(d)/(l - 2)
+ i = 0
+ j = 0
+ tmp <- .C("out", as.double(d), as.double(r), as.integer(l), as.integer(i), as.integer(j))
+ e2 = tmp[[5]]
+ e1 = tmp[[4]]
+ l1 = d[e1, e2]/2 + sum((d[e1,-c(e1,e2)] - d[e2,-c(e1,e2)])*w[-c(e1,e2)])/(2*(n-w[e1]-w[e2]))
+ l2 = d[e1, e2]/2 + sum((d[e2,-c(e1,e2)] - d[e1,-c(e1,e2)])*w[-c(e1,e2)])/(2*(n-w[e1]-w[e2]))
+ edge.length = c(l1, l2, edge.length)
+ edge = rbind(c(k, nam[e2]), edge)
+ edge = rbind(c(k, nam[e1]), edge)
+ nam = c(nam[c(-e1, -e2)], k)
+
+ dnew = (w[e1]*d[e1, ] + w[e2]*d[e2, ] - w[e1]*l1 - w[e2]*l2)/(w[e1] + w[e2])
+ d = cbind(d, dnew)
+ d = rbind(d, c(dnew, 0))
+ d = d[-c(e1, e2), -c(e1, e2)]
+ w = c(w, w[e1] + w[e2])
+ w = w[-c(e1, e2)]
+ k = k - 1
+ l = l - 1
+ }
+ edge.length=c(d[2,1],edge.length)
+ result = list(edge = rbind(c(nam[2], nam[1]), edge),
+ edge.length=edge.length, tip.label = labels, Nnode=m)
+ class(result) <- "phylo"
+ reorder(result)
+}
+
+
+PNJ <- function (data)
+{
+ q <- l <- r <- length(data)
+ weight <- attr(data,"weight")
+
+ height = NULL
+ parentNodes <- NULL
+ childNodes <- NULL
+ nam <- names(data)
+ tip.label <- nam
+ edge = 1:q
+
+ z = 0
+ D = matrix(0, q, q)
+
+ for (i in 1:(l - 1)) {
+ for (j in (i + 1):l) {
+ w = (data[[i]] * data[[j]]) %*% c(1, 1, 1, 1)
+ D[i, j] = sum(weight[w==0])
+ }
+ }
+
+ while (l > 1) {
+ l = l - 1
+ z = z + 1
+ d = D + t(D)
+ if(l>1) r = rowSums(d)/(l-1)
+ if(l==1) r = rowSums(d)
+ M = d - outer(r,r,"+")
+ diag(M) = Inf
+
+ e=which.min(M)
+ e0=e%%length(r)
+ e1 = ifelse(e0==0, length(r), e0)
+ e2= ifelse(e0==0, e%/%length(r), e%/%length(r) + 1)
+
+ ind = c(e1,e2)
+ len = d[e]/2
+ nam = c(nam[-ind], as.character(-l))
+
+ parentNodes = c(parentNodes,-l,-l)
+ childNodes = c(childNodes,edge[e1],edge[e2])
+
+ height = c(height, len, len)
+ edge = c(edge[-ind], -l)
+ w = (data[[e1]] * data[[e2]]) %*% c(1, 1, 1, 1)
+ w = which(w == 0)
+ newDat = data[[e1]] * data[[e2]]
+ newDat[w, ] = data[[e1]][w, ] + data[[e2]][w, ]
+ data = data[-c(e1,e2)]
+ data[[l]] = newDat
+ if (l > 1) {
+ D = as.matrix(D[, -ind])
+ D = D[-ind, ]
+ dv = numeric(l - 1)
+ for (i in 1:(l - 1)) {
+ w = (data[[i]] * data[[l]]) %*% c(1, 1, 1, 1)
+ dv[i] = sum(weight[w==0])
+ }
+ D = cbind(D, dv)
+ D = rbind(D, 0)
+ }
+ }
+ tree <- list(edge = cbind(as.character(parentNodes),as.character(childNodes)),tip.label=tip.label)
+ class(tree) <- "phylo"
+ tree <- old2new.phylo(tree)
+ reorder(tree)
+}
+
+
+
+#
+# Maximum likelihood estimation
+#
+discrete.gamma <- function (alpha, k)
+{
+ if (k == 1) return(1)
+ quants <- qgamma((1:(k - 1))/k, shape = alpha, rate = alpha)
+ diff( c(0, pgamma(quants * alpha, alpha + 1),1)) * k
+}
+
+
+optimQ <- function (tree, data, Q=rep(1,6), subs=rep(1,length(Q)), trace = 0, ...)
+{
+ m = length(Q)
+ n = max(subs)
+ ab = numeric(n)
+# ab = log(Q[match(1:n, subs)])
+ for(i in 1:n) ab[i]=log(Q[which(subs==i)[1]])
+ fn = function(ab, tree, data, m, n, subs,...) {
+ Q = numeric(m)
+ for(i in 1:n)Q[subs==i] = ab[i]
+ pml.fit(tree, data, Q = exp(Q),...)# Q^2, ...)
+ }
+ res = optim(par = ab, fn = fn, gr = NULL, method = "L-BFGS-B",
+ lower = -Inf, upper = 10, control = list(fnscale = -1,
+ maxit = 25, trace = trace), tree = tree, data = data, m=m, n=n, subs=subs,...)
+ Q = rep(1, m)
+ for(i in 1:n) Q[subs==i] = exp(res[[1]][i])
+ res[[1]] = Q
+ res
+}
+
+
+optimCodon <- function (tree, data, Q=rep(1,1830), subs=rep(1,length(Q)), syn = rep(0, length(Q)), trace = 0L, ab = c(0,0), optK=TRUE, optW=TRUE, ...)
+{
+ m = length(Q)
+ n = 1L # max(subs)
+
+ fn = function(ab, tree, data, m, n, subs, syn, optK, optW, ...) {
+ Q = numeric(m)
+ Q[subs==1] = 0 # transversion
+ if(optK) Q[subs==2] = ab[1] # transition
+ else Q[subs==2] = 0
+ if(optW) Q[syn==1] = Q[syn==1] + ab[2] # ab[n+1] dnds
+ Q[syn<0] = -Inf
+ pml.fit(tree, data, Q = exp(Q),...)# Q^2, ...)
+ }
+ res = optim(par = ab, fn = fn, gr = NULL, method = "L-BFGS-B",
+ lower = -Inf, upper = Inf, control = list(fnscale = -1,
+ maxit = 25, trace = trace), tree = tree, data = data, m=m, n=n,
+ subs=subs, syn=syn, optK=optK, optW=optW, ...)
+ ab = exp(res[[1]])
+ Q[subs==1] = 1 # transversion
+ if(optK) Q[subs==2] = ab[1] # transition
+ else{
+ Q[subs==2] = 1
+ ab[1] = 1
+ }
+ if(optW) Q[syn==1] = Q[syn==1] * ab[2] # dnds
+ else ab[2] = 1
+ Q[syn<0] = 0
+ res[[5]] = ab
+ res[[1]] = Q
+ res
+}
+
+
+subsChoice <- function(type=c("JC", "F81", "K80", "HKY", "TrNe", "TrN", "TPM1", "K81", "TPM1u", "TPM2", "TPM2u", "TPM3", "TPM3u", "TIM1e", "TIM1", "TIM2e", "TIM2", "TIM3e", "TIM3", "TVMe", "TVM", "SYM", "GTR")){
+ type = match.arg(type)
+ switch(type,
+ JC = list(optQ=FALSE, optBf=FALSE, subs=c(0, 0, 0, 0, 0, 0)),
+ F81 = list(optQ=FALSE, optBf=TRUE, subs=c(0, 0, 0, 0, 0, 0)),
+ K80 = list(optQ=TRUE, optBf=FALSE, subs=c(0, 1, 0, 0, 1, 0)),
+ HKY = list(optQ=TRUE, optBf=TRUE, subs=c(0, 1, 0, 0, 1, 0)),
+ TrNe = list(optQ=TRUE, optBf=FALSE, subs=c(0, 1, 0, 0, 2, 0)),
+ TrN = list(optQ=TRUE, optBf=TRUE, subs=c(0, 1, 0, 0, 2, 0)),
+ TPM1 = list(optQ=TRUE, optBf=FALSE, subs=c(0, 1, 2, 2, 1, 0)),
+ K81 = list(optQ=TRUE, optBf=FALSE, subs=c(0, 1, 2, 2, 1, 0)),
+ TPM1u = list(optQ=TRUE, optBf=TRUE, subs=c(0, 1, 2, 2, 1, 0)),
+ TPM2 = list(optQ=TRUE, optBf=FALSE, subs=c(1, 2, 1, 0, 2, 0)),
+ TPM2u = list(optQ=TRUE, optBf=TRUE, subs=c(1, 2, 1, 0, 2, 0)),
+ TPM3 = list(optQ=TRUE, optBf=FALSE, subs=c(1, 2, 0, 1, 2, 0)),
+ TPM3u = list(optQ=TRUE, optBf=TRUE, subs=c(1, 2, 0, 1, 2, 0)),
+ TIM1e = list(optQ=TRUE, optBf=FALSE, subs=c(0, 1, 2, 2, 3, 0)),
+ TIM1 = list(optQ=TRUE, optBf=TRUE, subs=c(0, 1, 2, 2, 3, 0)),
+ TIM2e = list(optQ=TRUE, optBf=FALSE, subs=c(1, 2, 1, 0, 3, 0)),
+ TIM2 = list(optQ=TRUE, optBf=TRUE, subs=c(1, 2, 1, 0, 3, 0)),
+ TIM3e = list(optQ=TRUE, optBf=FALSE, subs=c(1, 2, 0, 1, 3, 0)),
+ TIM3 = list(optQ=TRUE, optBf=TRUE, subs=c(1, 2, 0, 1, 3, 0)),
+ TVMe = list(optQ=TRUE, optBf=FALSE, subs=c(1, 2, 3, 4, 2, 0)),
+ TVM = list(optQ=TRUE, optBf=TRUE, subs=c(1, 2, 3, 4, 2, 0)),
+ SYM = list(optQ=TRUE, optBf=FALSE, subs=c(1, 2, 3, 4, 5, 0)),
+ GTR = list(optQ=TRUE, optBf=TRUE, subs=c(1, 2, 3, 4, 5, 0))
+ )
+}
+
+
+modelTest <- function (object, tree = NULL, model = c("JC", "F81", "K80",
+ "HKY", "SYM", "GTR"), G = TRUE, I = TRUE, k = 4, control = pml.control(epsilon = 1e-08,
+ maxit = 3, trace = 1), multicore = FALSE)
+{
+ if (class(object) == "phyDat")
+ data = object
+ if (class(object) == "pml") {
+ data = object$data
+ if (is.null(tree))
+ tree = object$tree
+ }
+
+ if(attr(data, "type")=="DNA") type = c("JC", "F81", "K80", "HKY", "TrNe", "TrN", "TPM1",
+ "K81", "TPM1u", "TPM2", "TPM2u", "TPM3", "TPM3u", "TIM1e",
+ "TIM1", "TIM2e", "TIM2", "TIM3e", "TIM3", "TVMe", "TVM",
+ "SYM", "GTR")
+ if(attr(data, "type")=="AA") type = .aamodels
+# type = c("WAG", "JTT", "Dayhoff", "LG", "cpREV", "mtmam", "mtArt", "MtZoa", "mtREV24")
+ model = match.arg(model, type, TRUE)
+
+ env = new.env()
+ assign("data", data, envir=env)
+
+ if (is.null(tree))
+ tree = NJ(dist.hamming(data))
+ trace <- control$trace
+ control$trace = trace - 1
+ fit = pml(tree, data)
+ fit = optim.pml(fit, control = control)
+ l = length(model)
+ n = 1L + sum(I + G + (G & I))
+ nseq = sum(attr(data, "weight"))
+ fitPar = function(model, fit, G, I, k) {
+ m = 1
+ res = matrix(NA, n, 5)
+ res = as.data.frame(res)
+ colnames(res) = c("Model", "df", "logLik", "AIC", "BIC")
+ data.frame(c("Model", "df", "logLik", "AIC", "BIC"))
+ calls = vector("list", n)
+ trees = vector("list", n)
+ fittmp = optim.pml(fit, model = model, control = control)
+ res[m, 1] = model
+ res[m, 2] = fittmp$df
+ res[m, 3] = fittmp$logLik
+ res[m, 4] = AIC(fittmp)
+ res[m, 5] = AIC(fittmp, k = log(nseq))
+ calls[[m]] = fittmp$call
+
+ trees[[m]] = fittmp$tree
+ m = m + 1
+ if (I) {
+ if(trace>0)print(paste(model, "+I", sep = ""))
+ fitI = optim.pml(fittmp, model = model, optInv = TRUE,
+ control = control)
+ res[m, 1] = paste(model, "+I", sep = "")
+ res[m, 2] = fitI$df
+ res[m, 3] = fitI$logLik
+ res[m, 4] = AIC(fitI)
+ res[m, 5] = AIC(fitI, k = log(nseq))
+ calls[[m]] = fitI$call
+ trees[[m]] = fitI$tree
+ m = m + 1
+ }
+ if (G) {
+ if(trace>0)print(paste(model, "+G", sep = ""))
+ fitG = update(fittmp, k = k)
+ fitG = optim.pml(fitG, model = model, optGamma = TRUE,
+ control = control)
+ res[m, 1] = paste(model, "+G", sep = "")
+ res[m, 2] = fitG$df
+ res[m, 3] = fitG$logLik
+ res[m, 4] = AIC(fitG)
+ res[m, 5] = AIC(fitG, k = log(nseq))
+ calls[[m]] = fitG$call
+ trees[[m]] = fitG$tree
+ m = m + 1
+ }
+ if (G & I) {
+ if(trace>0)print(paste(model, "+G+I", sep = ""))
+ fitGI = optim.pml(fitG, model = model, optGamma = TRUE,
+ optInv = TRUE, control = control)
+ res[m, 1] = paste(model, "+G+I", sep = "")
+ res[m, 2] = fitGI$df
+ res[m, 3] = fitGI$logLik
+ res[m, 4] = AIC(fitGI)
+ res[m, 5] = AIC(fitGI, k = log(nseq))
+ calls[[m]] = fitGI$call
+ trees[[m]] = fitGI$tree
+ m = m + 1
+ }
+ list(res, trees, calls)
+ }
+ eval.success <- FALSE
+ if (!eval.success & multicore) {
+# !require(parallel) ||
+ if (.Platform$GUI != "X11") {
+ warning("package 'parallel' not found or GUI is used, \n analysis is performed in serial")
+ }
+ else {
+ RES <- mclapply(model, fitPar, fit, G, I, k)
+ eval.success <- TRUE
+ }
+ }
+ if (!eval.success)
+ res <- RES <- lapply(model, fitPar, fit, G, I, k)
+
+ RESULT = matrix(NA, n * l, 5)
+ RESULT = as.data.frame(RESULT)
+ colnames(RESULT) = c("Model", "df", "logLik", "AIC", "BIC")
+ for (i in 1:l) RESULT[((i - 1) * n + 1):(n * i), ] = RES[[i]][[1]]
+ for(i in 1:l){
+ for(j in 1:n){
+ mo = RES[[i]][[1]][j,1]
+ tname = paste("tree_", mo, sep = "")
+ tmpmod = RES[[i]][[3]][[j]]
+ tmpmod["tree"] = call(tname)
+ if(!is.null(tmpmod[["k"]]))tmpmod["k"] = k
+ if(attr(data, "type")=="AA") tmpmod["model"] = RES[[i]][[1]][1,1]
+ assign(tname, RES[[i]][[2]][[j]], envir=env)
+ assign(mo, tmpmod, envir=env)
+ }
+ }
+ attr(RESULT, "env") = env
+ RESULT
+}
+
+
+optimGamma = function(tree, data, shape=1, k=4,...){
+ fn = function(shape, tree, data, k,...)pml.fit(tree, data, shape=shape, k=k,...)
+ res = optimize(f=fn, interval = c(0.1, 500), lower = 0.1, upper = 500, maximum = TRUE,
+ tol = .01, tree=tree, data=data, k=k,...)
+ res
+ }
+
+
+optimInv = function(tree, data, inv=0.01, INV=NULL, ll.0=NULL,...){
+ fn = function(inv, tree, data,...)pml.fit(tree, data, inv=inv, INV=INV, ll.0=NULL,...)
+ res = optimize(f=fn, interval = c(0,1), lower = 0, upper = 1, maximum = TRUE,
+ tol = .0001, tree=tree, data=data,...)
+ res
+ }
+
+
+# changed to c(-10,10) from c(-5,5)
+optimRate <- function(tree, data, rate=1, ...){
+ fn <- function(rate, tree, data, ...) pml.fit(tree, data, rate=exp(rate), ...)
+ res <- optimize(f = fn, interval = c(-10, 10), tree = tree, data = data, ..., maximum = TRUE)
+ res[[1]] <- exp(res[[1]])
+ res
+}
+
+
+optimBf = function(tree, data, bf=c(.25,.25,.25,.25), trace=0,...){
+ l=length(bf)
+ nenner = 1/bf[l]
+ lbf = log(bf * nenner)
+ lbf = lbf[-l]
+ fn = function(lbf, tree, data,...){
+ bf = exp(c(lbf,0))
+ bf = bf/sum(bf)
+ pml.fit(tree, data, bf=bf, ...)
+ }
+ res = optim(par=lbf, fn=fn, gr=NULL, method="Nelder-Mead", control=list(fnscale=-1, maxit=500, trace=trace),tree=tree, data=data,...)
+ bf = exp(c(res[[1]],0))
+ bf = bf/sum(bf)
+ result = list(bf=bf, loglik = res[[2]])
+ result
+ }
+
+
+optimW = function(fit,...){
+ w = fit$w
+ g = fit$g
+ siteLik = fit$siteLik
+ k = length(w)
+ l = dim(siteLik[[1]])[1]
+ x=matrix(0,l,k)
+ for(i in 1:k)x[,i] = rowSums(siteLik[[i]])
+ weight = fit$weight
+ nenner = 1/w[k]
+ eta = log(w * nenner)
+ eta = eta[-k]
+ fn = function(eta,x,g,weight){
+ eta = c(eta,0)
+ p = exp(eta)/sum(exp(eta))
+ res = x%*%p
+ res = sum(weight*log(res)) * (1 + abs(sum(p*g) - 1))
+ res
+ }
+ res = optim(eta, fn = fn, method = "Nelder-Mead", control=list(fnscale=-1, reltol = 1e-12),gr=NULL, x=x,g=g, weight=weight)
+ p = exp(c(res$par,0))
+ p = p/sum(p)
+ result = list(par = p, value = res$value)
+ result
+}
+
+
+#predict.pml <- function(object, newdata,...) sum(object$site * newdata)
+
+
+logLik.pml <- function(object,...){
+ res <- object$logLik
+ attr(res,"df") <- object$df
+ class(res) <- "logLik"
+ res
+}
+
+anova.pml <- function (object, ...)
+{
+ X <- c(list(object), list(...))
+ df <- sapply(X, "[[", "df")
+ ll <- sapply(X, "[[", "logLik")
+ 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", "Diff log lik.", "Pr(>|Chi|)"))
+ structure(table, heading = "Likelihood Ratio Test Table",
+ class = c("anova", "data.frame"))
+}
+
+
+#vcov.pml <- function(object, obs=FALSE,...){
+# if(obs) FI = score4(object)[[2]]
+# else FI = score(object,FALSE)[[2]]
+# l = dim(FI)[1]
+# res = try(solve(FI))
+# if(class(res) == "try-error"){
+# cat("Covariance is ill-conditioned !! \n")
+# res = solve(FI + diag(l)* 1e-8)
+# }
+# res
+#}
+
+vcov.pml <- function(object, ...){
+ FI = score(object,FALSE)[[2]]
+ l = dim(FI)[1]
+ res = try(solve(FI))
+ if(class(res) == "try-error"){
+ cat("Covariance is ill-conditioned !! \n")
+ res = solve(FI + diag(l)* 1e-8)
+ }
+ res
+}
+
+
+getd2P <- function(el, eig=edQt(), g=1.0){
+ n <- length(eig$values)
+ res <- .Call("getd2PM",eig,as.integer(n),as.double(el),as.double(g))
+ attr(res,"dim") <- c(length(g),length(el))
+ res
+}
+
+
+getdP <- function(el, eig=edQt(), g=1.0){
+ n <- length(eig$values)
+ res <- .Call("getdPM",eig,as.integer(n),as.double(el),as.double(g))
+ attr(res,"dim") <- c(length(g),length(el))
+ res
+}
+
+
+# version without transformation (used for vcov)
+getdP2 <- function(el, eig=edQt(), g=1.0){
+ n <- length(eig$values)
+ res <- .Call("getdPM2",eig,as.integer(n),as.double(el),as.double(g))
+ attr(res,"dim") <- c(length(g),length(el))
+ res
+}
+
+
+# version without transformation
+getd2P2 <- function(el, eig=edQt(), g=1.0){
+ n <- length(eig$values)
+ res <- .Call("getd2PM2",eig,as.integer(n),as.double(el),as.double(g))
+ attr(res,"dim") <- c(length(g),length(el))
+ res
+}
+
+
+getP <- function(el, eig=edQt(), g=1.0){
+ n <- length(eig$values)
+ res <- .Call("getPM", eig, as.integer(n), as.double(el), as.double(g))
+ attr(res, "dim") <- c(length(g), length(el))
+ res
+}
+
+
+lli = function (data, tree, ...)
+{
+ contrast = attr(data, "contrast")
+ nr = attr(data, "nr")
+ nc = attr(data, "nc")
+ nco = as.integer(dim(contrast)[1])
+ .Call("invSites", data[tree$tip.label], as.integer(nr), as.integer(nc), contrast, as.integer(nco))
+}
+
+
+edQt <- function (Q = c(1, 1, 1, 1, 1, 1), bf = c(0.25, 0.25, 0.25, 0.25))
+{
+ l = length(bf)
+ res = matrix(0, l, l)
+ res[lower.tri(res)] = Q
+ res = res + t(res)
+ res = res * bf
+ res2 = res * rep(bf, each = l)
+ diag(res) = -colSums(res)
+ res = res/sum(res2)
+ e = eigen(res, FALSE)
+ e$inv = solve.default(e$vec)
+ e
+}
+
+
+edQ <- function(Q=c(1,1,1,1,1,1), bf=c(0.25,.25,.25,.25)){
+ l=length(bf)
+ res = matrix(0, l, l)
+ res[lower.tri(res)] = Q
+ res = res+t(res)
+ res = res * rep(bf,each=l)
+ diag(res) = -rowSums(res)
+ res2 = res * rep(bf,l)
+ diag(res2)=0
+ res = res/sum(res2)
+ e = eigen(res, FALSE)
+ e$inv = solve.default(e$vec)
+ e
+}
+
+edQ2 <- function(Q){
+ res = Q
+ l=dim(Q)[1]
+ diag(res) = 0
+ diag(res) = -rowSums(res)
+ e = eigen(res, FALSE)
+ e$inv = solve.default(e$vec)
+ e
+}
+
+
+
+pml.free <- function(){.C("ll_free")}
+
+
+pml.init <- function(data, k=1L){
+ nTips <- length(data)
+ nr <- attr(data, "nr")
+ nc <- attr(data, "nc")
+ .C("ll_init", as.integer(nr), as.integer(nTips), as.integer(nc), as.integer(k))
+}
+
+
+pml.free2 <- function(){.C("ll_free2")}
+
+pml.init2 <- function(data, k=1L){
+ nTips <- length(data)
+ nr <- attr(data, "nr")
+ nc <- attr(data, "nc")
+ weight <- attr(data, "weight")
+ .C("ll_init2", as.integer(unlist(data, use.names=FALSE)), as.double(weight), as.integer(nr), as.integer(nTips), as.integer(nc), as.integer(k))
+}
+
+
+ll <- function(dat1, tree, bf = c(0.25, 0.25, 0.25, 0.25), g = 1,
+ eig = NULL, assign.dat = FALSE, ...)
+{
+ q = length(tree$tip.label)
+ node <- tree$edge[, 1]
+ edge <- tree$edge[, 2]
+ m = length(edge) + 1
+# if (is.null(eig)) eig = edQt(bf = bf, Q = Q) # raus
+ el <- tree$edge.length
+ P <- getP(el, eig, g)
+ nr <- as.integer(attr(dat1,"nr"))
+ nc <- as.integer(attr(dat1,"nc"))
+ node = as.integer(node-min(node))
+ edge = as.integer(edge-1L)
+ nTips = as.integer(length(tree$tip))
+ mNodes = as.integer(max(node) + 1L)
+ contrast = attr(dat1, "contrast")
+ nco = as.integer(dim(contrast)[1])
+ res <- .Call("LogLik2", dat1[tree$tip.label], P, nr, nc, node, edge, nTips, mNodes, contrast, nco)
+ result = res[[1]] %*% bf # root statt 1
+ if (assign.dat){
+ dat = vector(mode = "list", length = m)
+ dat[(q+1):m] <- res
+ attr(dat, "names") = c(tree$tip.label, as.character((q + 1):m))
+ assign("asdf", dat, envir = parent.frame(n = 1))
+ }
+ result
+}
+
+
+fn.quartet <- function(old.el, eig, bf, dat, g=1, w=1, weight, ll.0) {
+ l= length(dat[,1])
+ ll = ll.0
+ res = vector("list", 2*l)
+ tmp1 = NULL
+ tmp2 = NULL
+ attr(res,"dim") = c(l,2)
+ for(j in 1:l){
+ P = getP(old.el, eig, g[j])
+ tmp1 = (dat[[j,1]] %*% P[[1]]) *(dat[[j,2]] %*% P[[2]])
+ tmp2 = (dat[[j,3]] %*% P[[3]]) * (dat[[j,4]] %*% P[[4]])
+ res[[j,1]] = tmp1 * (tmp2 %*% P[[5]])
+ res[[j,2]] = tmp2
+ ll = ll + res[[j,1]] %*% (w[j]*bf)
+ }
+ l0 = sum(weight * log(ll))
+ list(ll=l0,res=res)
+}
+
+
+fn.quartet2 <- function (old.el, eig, bf, dat1, dat2, dat3, dat4, g = 1, w = 1,
+ weight, ll.0, contrast, ext)
+{
+ l = length(w)
+ ll = ll.0
+ res = vector("list", 2 * l)
+ tmp1 = NULL
+ tmp2 = NULL
+ attr(res, "dim") = c(l, 2)
+ for (j in 1:l) {
+ P = getP(old.el, eig, g[j])
+ if (ext[1] == FALSE && ext[2] == FALSE)
+ tmp1 = (dat1[[j]] %*% P[[1]]) * (dat2[[j]] %*% P[[2]])
+ if (ext[1] == FALSE && ext[2] == TRUE)
+ tmp1 = (dat1[[j]] %*% P[[1]]) * (contrast %*% P[[2]])[dat2, ]
+ if (ext[1] == TRUE && ext[2] == FALSE)
+ tmp1 = (contrast %*% P[[1]])[dat1, ] * (dat2[[j]] %*% P[[2]])
+ if (ext[1] == TRUE && ext[2] == TRUE)
+ tmp1 = (contrast %*% P[[1]])[dat1, ] * (contrast %*% P[[2]])[dat2, ]
+ if (ext[3] == FALSE && ext[4] == FALSE)
+ tmp2 = (dat3[[j]] %*% P[[3]]) * (dat4[[j]] %*% P[[4]])
+ if (ext[3] == FALSE && ext[4] == TRUE)
+ tmp2 = (dat3[[j]] %*% P[[3]]) * (contrast %*% P[[4]])[dat4, ]
+ if (ext[3] == TRUE && ext[4] == FALSE)
+ tmp2 = (contrast %*% P[[3]])[dat3, ] * (dat4[[j]] %*% P[[4]])
+ if (ext[3] == TRUE && ext[4] == TRUE)
+ tmp2 = (contrast %*% P[[3]])[dat3, ] * (contrast %*% P[[4]])[dat4, ]
+ res[[j, 1]] = tmp1 * (tmp2 %*% P[[5]])
+ res[[j, 2]] = tmp2
+ ll = ll + res[[j, 1]] %*% (w[j] * bf)
+ }
+ l0 = sum(weight * log(ll))
+ list(ll = l0, res = res)
+}
+
+
+optim.quartet2 <- function (old.el, eig, bf, dat1, dat2, dat3, dat4, g = 1, w = 1,
+ weight, ll.0 = weight * 0, control = list(eps = 1e-08, maxit = 5,
+ trace = 0), llcomp = -Inf, evi, contrast, contrast2,
+ ext = c(FALSE, FALSE, FALSE, FALSE))
+{
+ eps = 1
+ iter = 0
+ while (eps > control$eps && iter < control$maxit) {
+ tmp <- fn.quartet2(old.el = old.el, eig = eig, bf = bf,
+ dat1 = dat1, dat2 = dat2, dat3 = dat3, dat4 = dat4,
+ g = g, w = w, weight = weight, ll.0 = ll.0, contrast=contrast, ext = ext)
+ old.ll = tmp$ll
+
+ el1 <- fs3(old.el[1], eig, tmp$res[, 1], dat1, weight,
+ g = g, w = w, bf = bf, ll.0 = ll.0, contrast=contrast, contrast2=contrast2, evi=evi, ext = ext[1], getA=TRUE, getB=FALSE)
+ el2 <- fs3(old.el[2], eig, el1[[2]], dat2, weight,
+ g = g, w = w, bf = bf, ll.0 = ll.0, contrast=contrast, contrast2=contrast2, evi=evi, ext = ext[2], getA=TRUE, getB=FALSE)
+ el5 <- fs3(old.el[5], eig, el2[[2]], tmp$res[, 2], weight,
+ g = g, w = w, bf = bf, ll.0 = ll.0, contrast=contrast, contrast2=contrast2, evi=evi, ext = 0L, getA=FALSE, getB=TRUE)
+ el3 <- fs3(old.el[3], eig, el5[[3]], dat3, weight,
+ g = g, w = w, bf = bf, ll.0 = ll.0, contrast=contrast, contrast2=contrast2, evi=evi, ext = ext[3], getA=TRUE, getB=FALSE)
+ el4 <- fs3(old.el[4], eig, el3[[2]], dat4, weight,
+ g = g, w = w, bf = bf, ll.0 = ll.0, contrast=contrast, contrast2=contrast2, evi=evi, ext = ext[4], getA=FALSE, getB=FALSE)
+ old.el[1] = el1[[1]]
+ old.el[2] = el2[[1]]
+ old.el[3] = el3[[1]]
+ old.el[4] = el4[[1]]
+ old.el[5] = el5[[1]]
+ iter = iter + 1
+ ll = el4[[4]]
+ eps = (old.ll - ll)/ll
+ if (ll < llcomp)
+ return(list(old.el, ll))
+ old.ll = ll
+ }
+ list(old.el, ll)
+}
+
+
+pml.nni <- function (tree, data, w, g, eig, bf, ll.0, ll, ...)
+{
+ k = length(w)
+ INDEX <- indexNNI(tree)
+ rootEdges <- attr(INDEX,"root")
+ .dat <- NULL
+
+ data = getCols(data, tree$tip)
+
+ parent = tree$edge[,1]
+ child = tree$edge[,2]
+ weight = attr(data, "weight")
+ datp = rnodes(tree, data, w, g, eig, bf)
+ contrast <- attr(data, "contrast")
+ contrast2 <- contrast %*% eig[[2]]
+ evi = (t(eig[[3]]) * bf)
+
+ nTips = length(tree$tip.label)
+ evector <- numeric(max(parent))
+ evector[child] <- tree$edge.length
+ m <- dim(INDEX)[1]
+ loglik = numeric(2*m)
+ edgeMatrix <- matrix(0, 2*m, 5)
+ l = length(datp[, 1])
+ for(i in 1:m){
+ ei = INDEX[i,]
+ el0 = evector[INDEX[i,]]
+
+ ext = ei[1:4] < nTips+1L
+ if (!(ei[5] %in% rootEdges)) dat1 = datp[, ei[1], drop = FALSE]
+ else{ if(ext[1]) dat1 = data[[ ei[1] ]]
+ else dat1 = .dat[, ei[1], drop=FALSE]
+ }
+ if(ext[2]) dat2 = data[[ ei[2] ]]
+ else dat2 = .dat[, ei[2], drop=FALSE]
+ if(ext[3]) dat3 = data[[ ei[3] ]]
+ else dat3 = .dat[, ei[3], drop=FALSE]
+ if(ext[4]) dat4 = data[[ ei[4] ]]
+ else dat4 = .dat[, ei[4], drop=FALSE]
+
+ new1 <- optim.quartet2(el0[c(1, 3, 2, 4, 5)], eig, bf,
+ dat1, dat3, dat2, dat4, g, w, weight, ll.0, llcomp=ll, evi=evi, contrast=contrast, contrast2=contrast2, ext=ext[c(1, 3, 2, 4)])
+ new2 <- optim.quartet2(el0[c(1, 4, 3, 2, 5)], eig, bf,
+ dat1, dat4, dat3, dat2, g, w, weight, ll.0, llcomp=ll, evi=evi, contrast=contrast, contrast2=contrast2, ext=ext[c(1, 4, 3, 2)])
+
+
+ loglik[(2*i)-1]=new1[[2]]
+ loglik[(2*i)]=new2[[2]]
+ edgeMatrix[(2*i)-1,]=new1[[1]]
+ edgeMatrix[(2*i),]=new2[[1]]
+ }
+ swap <- 0
+ eps0 <- 1e-6
+ candidates <- loglik > ll + eps0
+
+ nr <- as.integer(attr(data, "nr"))
+ nc <- as.integer(attr(data, "nc"))
+ nTips <- as.integer(length(tree$tip.label))
+
+# on.exit(.C("ll_free"))
+# .C("ll_init", nr, nTips, nc, as.integer(k))
+
+ while(any(candidates)){
+ ind = which.max(loglik)
+ loglik[ind]=-Inf
+ if( ind %% 2 ) swap.edge = c(2,3)
+ else swap.edge = c(2,4)
+ tree2 <- changeEdge(tree, INDEX[(ind+1)%/%2,swap.edge], INDEX[(ind+1)%/%2,], edgeMatrix[ind,])
+
+ test <- pml.fit(tree2, data, bf = bf, k=k, g=g, w=w, eig=eig, ll.0=ll.0, ...)
+ if(test <= ll + eps0) candidates[ind] = FALSE
+ if(test > ll + eps0) {
+ ll = test
+ swap=swap+1
+ tree <- tree2
+ indi <- which(rep(colSums(apply(INDEX,1,match,INDEX[(ind+1)%/%2,],nomatch=0))>0,each=2))
+ candidates[indi] <- FALSE
+ loglik[indi] <- -Inf
+ }
+ }
+ list(tree=tree, ll=ll, swap=swap)
+}
+
+
+rnodes <- function (tree, data, w, g, eig, bf)
+{
+ if (is.null(attr(tree, "order")) || attr(tree, "order") ==
+ "cladewise")
+ tree <- reorder(tree, "postorder")
+ data = getCols(data, tree$tip)
+ q = length(tree$tip.label)
+ node <- tree$edge[, 1]
+ edge <- tree$edge[, 2]
+ m = length(edge) + 1 # max(edge)
+ l = length(w)
+ dat = vector(mode = "list", length = m*l)
+ dim(dat) <- c(l,m)
+ tmp = length(data)
+# for(i in 1:length(w))dat[i,1:tmp]=new2old.phyDat(data) #
+# dat[1,1:tmp] <- data vielleicht gebraucht
+ el <- tree$edge.length
+ P <- getP(el, eig, g)
+ nr <- as.integer(attr(data, "nr"))
+ nc <- as.integer(attr(data, "nc"))
+ node = as.integer(node - min(node))
+ edge = as.integer(edge - 1)
+ nTips = as.integer(length(tree$tip))
+ mNodes = as.integer(max(node) + 1)
+ contrast = attr(data, "contrast")
+ nco = as.integer(dim(contrast)[1])
+ for(i in 1:l)dat[i,(q + 1):m] <- .Call("LogLik2", data, P[i,], nr, nc, node, edge, nTips, mNodes, contrast, nco)
+ parent <- tree$edge[, 1]
+ child <- tree$edge[, 2]
+ nTips = min(parent) - 1
+ datp = vector("list", m)
+ dat2 = vector("list", m * l)
+ dim(dat2) <- c(l,m)
+ for(i in 1:l){
+ datp[(nTips + 1)] = dat[i,(nTips + 1)]
+ for (j in (m - 1):1) {
+ if (child[j] > nTips){
+ tmp2 = (datp[[parent[j]]]/(dat[[i,child[j]]] %*% P[[i,j]]))
+ datp[[child[j]]] = (tmp2 %*% P[[i,j]]) * dat[[i,child[j]]]
+ dat2[[i, child[j]]] = tmp2
+ }
+ }
+ }
+ assign(".dat", dat, envir = parent.frame(n = 1))
+ dat2
+}
+
+
+score <- function (fit, transform=TRUE)
+{
+ tree = fit$tree
+ child <- tree$edge[, 2]
+ l = length(child)
+ sc = numeric(l)
+ weight = as.numeric(fit$weight)
+ f <- drop(exp(fit$site))
+ dl = dl(fit, transform)
+ dl = dl/f
+ sc = colSums(weight * dl)
+ F = crossprod(dl*weight,dl)
+ names(sc) = child
+ dimnames(F) = list(child, child)
+ result = list(sc = sc, F = F)
+ result
+}
+
+
+# wird noch in partition models verwendet
+optim.quartet <- function (old.el, eig, bf, dat, g = 1, w = 1, weight, ll.0 = weight *
+ 0, control = list(eps = 1e-08, maxit = 5, trace = 0), llcomp=-Inf)
+{
+ eps = 1
+ iter = 0
+ evi = (t(eig[[3]]) * bf)
+ while (eps > control$eps && iter < control$maxit) {
+ tmp <- fn.quartet(old.el = old.el, eig = eig, bf = bf, dat = dat,
+ g = g, w = w, weight = weight, ll.0 = ll.0)
+ old.ll = tmp$ll
+ el1 <- fs(old.el[1], eig, tmp$res[, 1], dat[, 1], weight,
+ g = g, w = w, bf = bf, ll.0 = ll.0, evi, getA=TRUE, getB=FALSE)
+ el2 <- fs(old.el[2], eig, el1[[2]], dat[, 2], weight,
+ g = g, w = w, bf = bf, ll.0 = ll.0, evi, getA=TRUE, getB=FALSE)
+ el5 <- fs(old.el[5], eig, el2[[2]], tmp$res[, 2], weight,
+ g = g, w = w, bf = bf, ll.0 = ll.0, evi, getA=FALSE, getB=TRUE)
+ el3 <- fs(old.el[3], eig, el5[[3]], dat[, 3], weight,
+ g = g, w = w, bf = bf, ll.0 = ll.0, evi, getA=TRUE, getB=FALSE)
+ el4 <- fs(old.el[4], eig, el3[[2]], dat[, 4], weight,
+ g = g, w = w, bf = bf, ll.0 = ll.0, evi, getA=FALSE, getB=FALSE)
+ old.el[1] = el1[[1]]
+ old.el[2] = el2[[1]]
+ old.el[3] = el3[[1]]
+ old.el[4] = el4[[1]]
+ old.el[5] = el5[[1]]
+ iter = iter + 1
+ ll = el4[[4]]
+ eps = (old.ll - ll) / ll
+ if(ll<llcomp)return(list(old.el, ll))
+ old.ll = ll
+ }
+ list(old.el, ll)
+}
+
+
+optim.quartet2 <- function (old.el, eig, bf, dat1, dat2, dat3, dat4, g = 1, w = 1, weight, ll.0 = weight *
+ 0, control = list(eps = 1e-08, maxit = 5, trace = 0), llcomp=-Inf, evi, contrast, contrast2, ext=c(FALSE, FALSE, FALSE, FALSE))
+{
+ eps = 1
+ iter = 0
+ while (eps > control$eps && iter < control$maxit) {
+ tmp <- fn.quartet2(old.el = old.el, eig = eig, bf = bf, dat1 = dat1, dat2 = dat2, dat3 = dat3, dat4 = dat4,
+ g = g, w = w, weight = weight, ll.0 = ll.0, contrast=contrast, ext=ext)
+ old.ll = tmp$ll
+ el1 <- fs3(old.el[1], eig, tmp$res[, 1], dat1, weight,
+ g = g, w = w, bf = bf, ll.0 = ll.0, contrast=contrast, contrast2=contrast2, evi=evi, ext = ext[1], getA=TRUE, getB=FALSE)
+ el2 <- fs3(old.el[2], eig, el1[[2]], dat2, weight,
+ g = g, w = w, bf = bf, ll.0 = ll.0, contrast=contrast, contrast2=contrast2, evi=evi, ext = ext[2], getA=TRUE, getB=FALSE)
+ el5 <- fs3(old.el[5], eig, el2[[2]], tmp$res[, 2], weight,
+ g = g, w = w, bf = bf, ll.0 = ll.0, contrast=contrast, contrast2=contrast2, evi=evi, ext = 0L, getA=FALSE, getB=TRUE)
+ el3 <- fs3(old.el[3], eig, el5[[3]], dat3, weight,
+ g = g, w = w, bf = bf, ll.0 = ll.0, contrast=contrast, contrast2=contrast2, evi=evi, ext = ext[3], getA=TRUE, getB=FALSE)
+ el4 <- fs3(old.el[4], eig, el3[[2]], dat4, weight,
+ g = g, w = w, bf = bf, ll.0 = ll.0, contrast=contrast, contrast2=contrast2, evi=evi, ext = ext[4], getA=FALSE, getB=FALSE)
+ old.el[1] = el1[[1]]
+ old.el[2] = el2[[1]]
+ old.el[3] = el3[[1]]
+ old.el[4] = el4[[1]]
+ old.el[5] = el5[[1]]
+ iter = iter + 1
+ ll = el4[[4]]
+ eps = (old.ll - ll) / ll
+ if(ll<llcomp)return(list(old.el, ll))
+ old.ll = ll
+ }
+ list(old.el, ll)
+}
+
+
+plot.pml<-function(x,...)plot.phylo(x$tree,...)
+
+
+phangornParseFormula <- function(model){
+
+ parseSide <- function(model) {
+ model.vars <- list()
+ while (length(model) == 3 && model[[1]] == as.name("+")) {
+ model.vars <- c(model.vars, model[[3]])
+ model <- model[[2]]
+ }
+ unlist(rev(c(model.vars, model)))
+
+ }
+
+ if (!inherits(model, "formula"))
+ stop("model must be a formula object")
+ l <- length(model)
+ varsLHS <- NULL
+ if(l==3){
+ modelLHS <- model[[2]]
+ modelRHS <- model[[3]]
+ varsRHS <- parseSide(modelRHS)
+ varsRHS <- unlist(lapply(varsRHS,as.character))
+ varsLHS <- parseSide(modelLHS)
+ varsLHS <- unlist(lapply(varsLHS,as.character))
+ }
+ if(l==2){
+ modelRHS <- model[[2]]
+ varsRHS <- parseSide(modelRHS)
+ varsRHS <- unlist(lapply(varsRHS,as.character))
+ }
+ list(left=varsLHS, right=varsRHS)
+}
+
+
+pml.control <- function (epsilon = 1e-08, maxit = 10, trace = 1)
+{
+ if (!is.numeric(epsilon) || epsilon <= 0)
+ stop("value of 'epsilon' must be > 0")
+ if (!is.numeric(maxit) || maxit <= 0)
+ stop("maximum number of iterations must be > 0")
+ list(epsilon = epsilon, maxit = maxit, trace = trace)
+}
+
+
+optim.pml <- function (object, optNni = FALSE, optBf = FALSE, optQ = FALSE,
+ optInv = FALSE, optGamma = FALSE, optEdge = TRUE, optRate = FALSE, optRooted=FALSE,
+ control = pml.control(epsilon = 1e-8, maxit = 10, trace = 1L),
+ model = NULL, subs = NULL, ...)
+{
+ extras <- match.call(expand.dots = FALSE)$...
+ pmla <- c("wMix", "llMix")
+ wMix <- object$wMix
+ llMix <- object$llMix
+ if(is.null(llMix)) llMix=0
+ if (!is.null(extras)) {
+ names(extras) <- pmla[pmatch(names(extras), pmla)]
+ existing <- match(pmla, names(extras))
+ if (!is.na(existing[1]))
+ wMix <- eval(extras[[existing[1]]], parent.frame())
+ if (!is.na(existing[2]))
+ llMix <- eval(extras[[existing[2]]], parent.frame())
+ }
+ tree = object$tree
+ call = object$call
+ if(optNni) {
+ if(!is.binary.tree(tree))
+ tree = multi2di(tree)
+ optEdge = TRUE
+ }
+ if(is.rooted(tree)) {
+ if(optRooted==FALSE && optEdge==TRUE){
+ tree = unroot(tree)
+ attr(tree, "order") <- NULL
+ tree = reorder(tree, "postorder")
+ warning("I unrooted the tree", call. = FALSE)
+ }
+ }
+ if(is.null(attr(tree, "order")) || attr(tree, "order") ==
+ "cladewise")
+ tree <- reorder(tree, "postorder")
+ if(any(tree$edge.length < 1e-08)) {
+ tree$edge.length[tree$edge.length < 1e-08] <- 1e-08
+# save to change to new update.pml
+ object <- update.pml(object, tree = tree)
+ }
+ if(optEdge & optRate) {
+ warning("You can't optimise edges and rates at the same time, only edges are optimised!", call. = FALSE)
+ optRate = FALSE
+ }
+ if(optRooted){
+ optEdge = FALSE
+ if(!is.rooted(tree)) stop("Tree must be rooted!")
+ if(!is.ultrametric(tree)) stop("Tree must be ultrametric!")
+ }
+ trace <- control$trace
+
+ data = object$data
+ data = subset(data, tree$tip.label)
+
+ type <- attr(data, "type")
+ if (type == "AA" & !is.null(model)){
+ object = update(object, model=model)
+ }
+ if (type == "CODON") {
+ dnds <- object$dnds
+ tstv <- object$tstv
+ if(!is.null(model)){
+ if(model == "codon0") optQ = FALSE
+ else optQ = TRUE
+ }
+ }
+ Q = object$Q
+ if(is.null(subs)) subs = c(1:(length(Q) - 1), 0)
+ bf = object$bf
+ eig = object$eig
+ inv = object$inv
+ k = object$k
+ if(k==1 & optGamma){
+ optGamma = FALSE
+ warning('only one rate class, ignored optGamma')
+ }
+ shape = object$shape
+ w = object$w
+ g = object$g
+ if (type == "DNA" & !is.null(model)) {
+ tmp = subsChoice(model)
+ optQ = tmp$optQ
+ if (!optQ)
+ Q = rep(1, 6)
+ optBf = tmp$optBf
+ if (!optBf)
+ bf = c(0.25, 0.25, 0.25, 0.25)
+ subs = tmp$subs
+ }
+ ll0 <- object$logLik
+ INV <- object$INV
+ ll.0 <- object$ll.0
+ rate <- object$rate
+ ll = ll0
+ ll1 = ll0
+ opti = TRUE
+
+ nr <- as.integer(attr(data, "nr"))
+ nc <- as.integer(attr(data, "nc"))
+ nTips <- as.integer(length(tree$tip.label))
+
+ on.exit(.C("ll_free"))
+ .C("ll_init", nr, nTips, nc, as.integer(k))
+
+ if (optEdge) {
+ res <- optimEdge(tree, data, eig=eig, w=w, g=g, bf=bf, rate=rate, ll.0=ll.0, INV=INV,
+ control = pml.control(epsilon = 1e-07, maxit = 5, trace=trace - 1))
+ if(trace > 0)
+ cat("optimize edge weights: ", ll, "-->", res[[2]], "\n")
+ if (res[[2]] > ll){
+ ll <- res[[2]]
+ tree <- res[[1]]
+ }
+ }
+ if(optRooted){
+ res <- optimRooted(tree, data, eig=eig, w=w, g=g, bf=bf, rate=rate, ll.0=ll.0, INV=INV, control = pml.control(epsilon = 1e-07, maxit = 10, trace = trace-1))
+ if(trace > 0)
+ cat("optimize edge weights: ", ll, "-->", res[[2]], "\n")
+ if(res[[2]] > ll){
+ ll <- res[[2]]
+ tree <- res[[1]]
+ }
+ }
+ rounds = 1
+ while (opti) {
+ if (optBf) {
+ res = optimBf(tree, data, bf = bf, inv = inv, Q = Q,
+ w = w, g = g, INV = INV, rate = rate, k = k,
+ llMix = llMix)
+ bf = res[[1]]
+ eig = edQt(Q = Q, bf = bf)
+ if (inv > 0)
+ ll.0 <- as.matrix(INV %*% (bf * inv))
+ if (wMix > 0)
+ ll.0 <- ll.0 + llMix
+ if (trace > 0)
+ cat("optimize base frequencies: ", ll, "-->",
+ res[[2]], "\n")
+ ll = res[[2]]
+ }
+ if (optQ) {
+ if(type=="CODON"){
+ if(is.null(model)) model <- "codon1"
+ model <- match.arg(model, c("codon0", "codon1", "codon2", "codon3"))
+ ab <- c(tstv, dnds)
+ res <- switch(model,
+ codon1 = optimCodon(tree,data, Q=rep(1,1830), subs=.sub, syn=.syn,
+ bf = bf, w = w, g = g, inv = inv, INV = INV, ll.0 = ll.0, rate = rate, k = k, ab=log(ab),
+ optK=TRUE, optW = TRUE),
+ codon2 = optimCodon(tree,data, Q=rep(1,1830), subs=.sub, syn=.syn,
+ bf = bf, w = w, g = g, inv = inv, INV = INV, ll.0 = ll.0, rate = rate, k = k, ab=log(ab),
+ optK=FALSE, optW = TRUE),
+ codon3 = optimCodon(tree,data, Q=rep(1,1830), subs=.sub, syn=.syn,
+ bf = bf, w = w, g = g, inv = inv, INV = INV, ll.0 = ll.0, rate = rate, k = k, ab=log(ab),
+ optK=TRUE, optW = FALSE))
+ tmp <- res[[5]]
+ m = length(tmp)
+ dnds = tmp[m]
+
+ if(m>1) tstv <- tmp[1]
+ }
+ else
+ res = optimQ(tree, data, Q = Q, subs = subs, bf = bf, w = w, g = g, inv = inv, INV = INV,
+ ll.0 = ll.0, rate = rate, k = k)
+ Q = res[[1]]
+ eig = edQt(Q = Q, bf = bf)
+ if (trace > 0)
+ cat("optimize rate matrix: ", ll, "-->", res[[2]],
+ "\n")
+ ll = res[[2]]
+ }
+ if(optInv) {
+ res = optimInv(tree, data, inv = inv, INV = INV, Q = Q,
+ bf = bf, eig = eig, k = k, shape = shape, rate = rate)
+ inv = res[[1]]
+ w = rep(1/k, k)
+ g = discrete.gamma(shape, k)
+ w = (1 - inv) * w
+ if (wMix > 0)
+ w <- (1 - wMix) * w
+ g = g/(1 - inv)
+ g <- g * rate
+ ll.0 = as.matrix(INV %*% (bf * inv))
+ if (wMix > 0)
+ ll.0 <- ll.0 + llMix
+ if (trace > 0)
+ cat("optimize invariant sites: ", ll, "-->", res[[2]], "\n")
+ ll = res[[2]]
+ }
+ if(optGamma) {
+ res = optimGamma(tree, data, shape = shape, k = k,
+ inv = inv, INV = INV, Q = Q, bf = bf, eig = eig,
+ ll.0 = ll.0, rate = rate)
+ shape = res[[1]]
+ w = rep(1/k, k)
+ g = discrete.gamma(shape, k)
+ if (inv > 0) {
+ w = (1 - inv) * w
+ g = g/(1 - inv)
+ }
+ if (wMix > 0)
+ w <- (1 - wMix) * w
+ g <- g * rate
+ if (trace > 0)
+ cat("optimize shape parameter: ", ll, "-->",
+ res[[2]], "\n")
+ ll = res[[2]]
+ }
+ if(optRate) {
+ res = optimRate(tree, data, rate = rate, inv = inv,
+ INV = INV, Q = Q, bf = bf, eig = eig, k = k,
+ shape = shape, w = w, ll.0 = ll.0)
+ if (res[[2]] > ll)rate = res[[1]]
+ g = discrete.gamma(shape, k)
+ w = rep(1/k, k)
+ if (inv > 0) {
+ w = (1 - inv) * w
+ g = g/(1 - inv)
+ }
+ if (wMix > 0)
+ w <- (1 - wMix) * w
+ g <- g * rate
+ if (trace > 0)
+ cat("optimize rate: ", ll, "-->", res[[2]], "\n")
+ ll = res[[2]]
+ }
+ if (optEdge) {
+ res <- optimEdge(tree, data, eig=eig, w=w, g=g, bf=bf, rate=rate, ll.0=ll.0,
+ control = pml.control(epsilon = 1e-08, maxit = 5, trace=trace - 1))
+ if (trace > 0)
+ cat("optimize edge weights: ", ll, "-->", res[[2]], "\n")
+ if (res[[2]] > ll){
+ ll <- res[[2]]
+ tree <- res[[1]]
+ }
+ }
+ if(optRooted){
+ res <- optimRooted(tree, data, eig=eig, w=w, g=g, bf=bf, rate=rate, ll.0=ll.0, INV=INV, control = pml.control(epsilon = 1e-07, maxit = 10, trace = trace-1))
+ if(trace > 0)
+ cat("optimize edge weights: ", ll, "-->", res[[2]], "\n")
+ if (res[[2]] > ll){
+ ll <- res[[2]]
+ tree <- res[[1]]
+ }
+ }
+ if(optNni) {
+ swap = 0
+ iter = 1
+ while (iter < 4) {
+ if(optEdge){
+ tmp <- pml.nni(tree, data, w, g, eig, bf, ll.0, ll, ...)
+ swap = swap + tmp$swap
+ res <- optimEdge(tmp$tree, data, eig=eig, w=w, g=g, bf=bf, rate=rate, ll.0=ll.0, control = pml.control(epsilon = 1e-08, maxit = 3, trace=0))
+ ll2 = res[[2]]
+ tree <- res[[1]]
+ }
+ else{
+ tmp <- rooted.nni(tree, data, eig=eig, w=w, g=g, bf=bf, rate=rate, ll.0=ll.0, INV=INV, ...)
+ swap = swap + tmp$swap
+ tree <- tmp$tree
+ ll2 = tmp$logLik
+ }
+ if (trace > 0)
+ cat("optimize topology: ", ll, "-->", ll2, "\n")
+ ll = ll2
+ iter = iter + 1
+ if (tmp$swap == 0) {
+ iter = 4
+ }
+ }
+ if (trace > 0)
+ cat(swap, "\n")
+ if (swap > 0)
+ rounds = 1
+ if (swap == 0)
+ optNni = FALSE
+ }
+ rounds = rounds + 1
+ if(rounds > control$maxit) opti <- FALSE
+ if (( ll1 - ll ) / ll < control$eps) #abs(ll1 - ll)
+ opti <- FALSE
+ ll1 = ll
+ }
+ if(type=="CODON"){
+ object$dnds = dnds
+ object$tstv = tstv
+ }
+
+ tmp <- pml.fit(tree, data, bf, shape = shape, k = k, Q = Q,
+ levels = attr(data, "levels"), inv = inv, rate = rate,
+ g = g, w = w, eig = eig, INV = INV, ll.0 = ll.0, llMix = llMix,
+ wMix = wMix, site = TRUE)
+
+ df <- ifelse(optRooted, tree$Nnode, length(tree$edge.length))
+ # length(tree$edge.length)
+ if (type == "CODON") {
+ df <- df + (k > 1) + (inv > 0) +
+ length(unique(bf)) - 1 + (dnds != 1) + (tstv != 1)
+ }
+ else df = df + (k > 1) + (inv > 0) +
+ length(unique(bf)) - 1 + length(unique(Q)) - 1
+
+ object = list(logLik = tmp$loglik, inv = inv, k = k, shape = shape,
+ Q = Q, bf = bf, rate = rate, siteLik = tmp$siteLik, weight = attr(data, "weight"),
+ g = g, w = w, eig = eig, data = data, model = model,
+ INV = INV, ll.0 = ll.0, tree = tree, lv = tmp$resll,
+ call = call, df = df, wMix = wMix, llMix = llMix)
+ if (type == "CODON") {
+ object$dnds <- dnds
+ object$tstv <- tstv
+ }
+ class(object) = "pml"
+
+ extras = pairlist(bf = bf, Q = Q, inv = inv, shape = shape, rate = rate)[c(optBf, optQ, optInv, optGamma, optRate)]
+ if (length(extras)) {
+ existing <- !is.na(match(names(extras), names(call)))
+ for (a in names(extras)[existing]) call[[a]] <- extras[[a]]
+ if (any(!existing)) {
+ call <- c(as.list(call), extras[!existing])
+ call <- as.call(call)
+ }
+ }
+ object$call = call
+ object
+}
+
+
+fs <- function (old.el, eig, parent.dat, child.dat, weight, g=g,
+ w=w, bf=bf, ll.0=ll.0, evi, getA=TRUE, getB=TRUE)
+{
+ if (old.el < 1e-8) old.el <- 1e-8
+ lg = length(parent.dat)
+ P <- getP(old.el, eig, g)
+ nr = as.integer(length(weight))
+ nc = as.integer(length(bf))
+ eve = eig[[2]]
+ dad <- .Call("getDAD", parent.dat, child.dat, P, nr, nc)
+ X <- .Call("getPrep", dad, child.dat, eig[[2]], evi, nr, nc)
+ .Call("FS4", eig, as.integer(length(bf)), as.double(old.el),
+ as.double(w), as.double(g), X, child.dat, dad, as.integer(length(w)),
+ as.integer(length(weight)), as.double(bf), as.double(weight),
+ as.double(ll.0), as.integer(getA), as.integer(getB))
+}
+
+
+fs3 <- function (old.el, eig, parent.dat, child, weight, g=g,
+ w=w, bf=bf, ll.0=ll.0, contrast, contrast2, evi, ext=TRUE, getA=TRUE, getB=TRUE) # child.dat
+{
+ if (old.el < 1e-8) old.el <- 1e-8
+ lg = length(parent.dat)
+ P <- getP(old.el, eig, g)
+ nr = as.integer(length(weight))
+ nc = as.integer(length(bf))
+ if(ext==FALSE){
+ child.dat <- child
+ eve = eig[[2]]
+ dad <- .Call("getDAD", parent.dat, child.dat, P, nr, nc)
+ X <- .Call("getPrep", dad, child.dat, eig[[2]], evi, nr, nc)
+ }
+ else {
+ nco = as.integer(nrow(contrast))
+ dad <- .Call("getDAD2", parent.dat, child, contrast, P, nr, nc, nco)
+ child.dat <- vector("list", lg)
+ for (i in 1:lg)child.dat[[i]] <- contrast[child, , drop=FALSE]
+ X <- .Call("getPrep2", dad, child, contrast2, evi, nr, nc, nco)
+ }
+ .Call("FS4", eig, as.integer(length(bf)), as.double(old.el),
+ as.double(w), as.double(g), X, child.dat, dad, as.integer(length(w)),
+ as.integer(length(weight)), as.double(bf), as.double(weight),
+ as.double(ll.0), as.integer(getA), as.integer(getB))
+}
+
+
+
+optimEdge <- function (tree, data, eig=eig, w=w, g=g, bf=bf, rate=rate, ll.0=ll.0,
+ control = pml.control(epsilon = 1e-08, maxit = 10, trace=0), ...)
+{
+ if (is.null(attr(tree, "order")) || attr(tree, "order") == "cladewise")
+ tree <- reorder(tree, "postorder")
+ nTips <- length(tree$tip)
+ el <- tree$edge.length
+ tree$edge.length[el < 0] <- 1e-08
+ oldtree = tree
+ k = length(w)
+ data = subset(data, tree$tip)
+ loglik = pml.fit2(tree, data, bf=bf, g=g, w=w, eig=eig, ll.0=ll.0, k=k)
+ start.ll <- old.ll <- loglik
+ contrast <- attr(data, "contrast")
+ contrast2 <- contrast %*% eig[[2]]
+ evi = (t(eig[[3]]) * bf)
+ weight <- attr(data, "weight")
+ eps = 1
+ iter = 0
+
+ treeP = tree
+ tree = reorder(tree)
+ el <- tree$edge.length
+
+ child = tree$edge[, 2]
+ parent = tree$edge[, 1]
+ loli = parent[1]
+
+ pvec <- integer(max(tree$edge))
+ pvec[child] <- parent
+
+ EL = numeric(max(child))
+ EL[child] = tree$edge.length
+
+ nTips = min(parent) - 1
+ n = length(tree$edge.length)
+ lt = length(tree$tip)
+
+ nr = as.integer(length(weight))
+ nc = as.integer(length(bf))
+ nco = as.integer(nrow(contrast))
+ eve = eig[[2]]
+ lg = k
+ rootNode = getRoot(tree)
+ ScaleEPS = 1.0/4294967296.0
+ anc = Ancestors(tree, 1:max(tree$edge), "parent")
+
+ while (eps > control$eps && iter < control$maxit) {
+ blub3 <- .Call("extractScale", as.integer(rootNode), w, g, as.integer(nr), as.integer(nc), as.integer(nTips))
+ rowM = apply(blub3, 1, min)
+ blub3 = (blub3-rowM)
+ blub3 = ScaleEPS ^ (blub3)
+
+ for(j in 1:n) {
+ ch = child[j]
+ pa = parent[j]
+
+ while(loli != pa){
+ blub <- .Call("moveloli", as.integer(loli), as.integer(anc[loli]), eig, EL[loli], w, g, as.integer(nr), as.integer(nc), as.integer(nTips))
+ loli=anc[loli]
+ }
+
+ old.el = tree$edge.length[j]
+ if (old.el < 1e-8) old.el <- 1e-8
+
+ X <- .Call("moveDad", data, as.integer(pa), as.integer(ch), eig, evi, old.el, w, g, as.integer(nr), as.integer(nc), as.integer(nTips), as.double(contrast), as.double(contrast2), nco)
+ # in moveDad, das sollte teuer sein in Kopien
+ for(i in 1:k)X[[i]] <- X[[i]] * blub3[,i]
+
+ newEL <- .Call("FS5", eig, nc, as.double(old.el), as.double(w), as.double(g), X, as.integer(length(w)), as.integer(length(weight)), as.double(bf), as.double(weight), as.double(ll.0))
+
+ el[j] = newEL[[1]] # nur EL?
+ EL[ch] = newEL[[1]]
+ if (child[j] > nTips) loli = child[j]
+ else loli = parent[j]
+
+ blub <- .Call("updateLL", data, as.integer(pa), as.integer(ch), eig, newEL[[1]], w, g,
+ as.integer(nr), as.integer(nc), as.integer(nTips), as.double(contrast), nco)
+
+ tree$edge.length = el
+ }
+ tree$edge.length = el
+ iter = iter + 1
+
+ treeP$edge.length = EL[treeP$edge[,2]]
+ newll <- pml.fit2(treeP, data, bf=bf, g=g, w=w, eig=eig, ll.0=ll.0, k=k)
+
+ eps = ( old.ll - newll ) / newll
+ if( eps <0 ) return(list(oldtree, old.ll))
+ oldtree = tree
+ if(control$trace>1) cat(old.ll, " -> ", newll, "\n")
+ old.ll = newll
+ loli = parent[1]
+
+ }
+ if(control$trace>0) cat(start.ll, " -> ", newll, "\n")
+ list(tree=treeP, logLik=newll, c(eps, iter))
+}
+
+
+
+# bf raus C naeher
+pml.move <- function(EDGE, el, data, g, w, eig, k, nTips, bf){
+ node <- EDGE[, 1]
+ edge <- EDGE[, 2]
+ root <- as.integer(node[length(node)])
+# el <- as.double(tree$edge.length)
+ nr = as.integer(attr(data, "nr"))
+ nc = as.integer(attr(data, "nc"))
+ node = as.integer(node - nTips - 1L)
+ edge = as.integer(edge - 1L)
+ contrast = attr(data, "contrast")
+ nco = as.integer(dim(contrast)[1])
+ tmp <- .Call("PML3", dlist=data, as.double(el), as.double(w), as.double(g), nr, nc, k, eig, as.double(bf), node, edge, nTips, root, nco, contrast, N=as.integer(length(edge)))
+ return(NULL)
+}
+
+
+
+#
+# pmlPart + pmlCluster
+#
+optimPartQ <- function (object, Q = c(1, 1, 1, 1, 1, 1), ...)
+{
+ l = length(Q)
+ Q = Q[-l]
+ Q = sqrt(Q)
+ fn = function(Q, object, ...) {
+ result <- 0
+ Q = c(Q^2, 1)
+ n <- length(object)
+ for (i in 1:n) result <- result + update(object[[i]], Q = Q, ...)$logLik
+ result
+ }
+ res = optim(par = Q, fn = fn, gr = NULL, method = "L-BFGS-B",
+ lower = 0, upper = Inf, control = list(fnscale = -1,
+ maxit = 25), object = object, ...)
+ res[[1]] = c(res[[1]]^2, 1)
+ res
+}
+
+
+optimPartQGeneral <- function (object, Q = c(1, 1, 1, 1, 1, 1), subs=rep(1,length(Q)), ...)
+{
+ m = length(Q)
+ n = max(subs)
+ ab = numeric(n)
+ for(i in 1:n) ab[i]=log(Q[which(subs==i)[1]])
+ fn = function(ab, object, m, n, subs, ...) {
+ Q = numeric(m)
+ for(i in 1:n)Q[subs==i] = ab[i]
+ Q = exp(Q)
+ result = 0
+ for (i in 1:length(object)) result <- result + update(object[[i]], Q = Q, ...)$logLik
+ result
+ }
+ res = optim(par = ab, fn = fn, gr = NULL, method = "L-BFGS-B",
+ lower = -Inf, upper = Inf, control = list(fnscale = -1,
+ maxit = 25), object = object, m=m, n=n, subs=subs, ...)
+ Q = rep(1, m)
+ for(i in 1:n) Q[subs==i] = exp(res[[1]][i])
+ res[[1]] = Q
+ res
+}
+
+
+optimPartBf <- function (object, bf = c(0.25, 0.25, 0.25, 0.25), ...)
+{
+ l = length(bf)
+ nenner = 1/bf[l]
+ lbf = log(bf * nenner)
+ lbf = lbf[-l]
+ fn = function(lbf, object, ...) {
+ result <- 0
+ bf = exp(c(lbf, 0))
+ bf = bf/sum(bf)
+ n <- length(object)
+ for (i in 1:n) result <- result + update(object[[i]],
+ bf = bf, ...)$logLik
+ result
+ }
+ res = optim(par = lbf, fn = fn, gr = NULL, method = "Nelder-Mead",
+ control = list(fnscale = -1, maxit = 500), object, ...)
+ print(res[[2]])
+ bf = exp(c(res[[1]], 0))
+ bf = bf/sum(bf)
+}
+
+
+optimPartInv <- function (object, inv = 0.01, ...)
+{
+ fn = function(inv, object, ...) {
+ result <- 0
+ n <- length(object)
+ for (i in 1:n) result <- result + update(object[[i]], inv = inv,
+ ...)$logLik
+ result
+ }
+ res = optimize(f = fn, interval = c(0, 1), lower = 0, upper = 1,
+ maximum = TRUE, tol = 1e-04, object, ...)
+ print(res[[2]])
+ res[[1]]
+}
+
+
+optimPartGamma <- function (object, shape = 1, ...)
+{
+ fn = function(shape, object, ...) {
+ result <- 0
+ n <- length(object)
+ for (i in 1:n) result <- result + update(object[[i]], shape = shape,
+ ...)$logLik
+ result
+ }
+ res = optimize(f = fn, interval = c(0, 100), lower = 0, upper = 100,
+ maximum = TRUE, tol = 0.01, object, ...)
+ res
+}
+
+
+dltmp <- function (fit, i=1, transform=transform) # i = weights
+{
+ tree = fit$tree
+ data = getCols(fit$data, tree$tip)
+ if (is.null(attr(tree, "order")) || attr(tree, "order") ==
+ "cladewise")
+ tree <- reorder(tree, "postorder")
+ q = length(tree$tip.label)
+ node <- tree$edge[, 1]
+ edge <- tree$edge[, 2]
+ m = length(edge) + 1 # max(edge)
+ dat = vector(mode = "list", length = m)
+ eig = fit$eig
+ w = fit$w[i]
+ g = fit$g[i]
+ bf = fit$bf
+ el <- tree$edge.length
+ P <- getP(el, eig, g)
+ nr <- as.integer(attr(data, "nr"))
+ nc <- as.integer(attr(data, "nc"))
+ node = as.integer(node - min(node))
+ edge = as.integer(edge - 1)
+ nTips = as.integer(length(tree$tip))
+ mNodes = as.integer(max(node) + 1)
+ contrast = attr(data, "contrast")
+ nco = as.integer(dim(contrast)[1])
+ dat[(q + 1):m] <- .Call("LogLik2", data, P, nr, nc, node, edge, nTips, mNodes, contrast, nco)
+ result = dat[[q+1]] %*% (bf * w)
+
+ parent <- tree$edge[, 1]
+ child <- tree$edge[, 2]
+ nTips = min(parent) - 1
+ datp = vector("list", m)
+ el = tree$edge.length
+ if (transform) dP = getdP(tree$edge.length, eig, g)
+ else dP = getdP2(tree$edge.length, eig, g)
+
+ datp[(nTips + 1)] = dat[(nTips + 1)]
+ l = length(child)
+ dl = matrix(0, nr, l)
+ for (j in (m - 1):1) {
+ # tips have factor format, internal edges are matrices
+ if (child[j] > nTips){
+ tmp2 = (datp[[parent[j]]]/(dat[[child[j]]] %*% P[[j]]))
+ dl[, j] = (tmp2 * (dat[[child[j]]] %*% dP[[j]])) %*% (w * bf)
+ datp[[child[j]]] = (tmp2 %*% P[[j]]) * dat[[child[j]]]
+ }
+ else{
+ tmp2 = (datp[[parent[j]]]/((contrast %*% P[[j]])[data[[child[j]]],] ))
+ dl[, j] = (tmp2 * ((contrast %*% dP[[j]])[data[[child[j]]],]) ) %*% (w * bf)
+ }
+ }
+ dl
+}
+
+
+dl <- function(x, transform = TRUE){
+ w = x$w
+ l=length(x$w)
+ dl = dltmp(x, 1, transform)
+ i=2
+ while(i < (l+1)){
+ dl = dl + dltmp(x, i, transform)
+ i = i + 1
+ }
+ dl
+}
+
+
+# add control and change edge
+optimPartEdge <- function (object, ...)
+{
+ tree <- object[[1]]$tree
+ theta <- object[[1]]$tree$edge.length
+ n <- length(object)
+ l <- length(theta)
+ nrv <- numeric(n)
+ for (i in 1:n) nrv[i] = attr(object[[i]]$data, "nr")
+ cnr <- cumsum(c(0, nrv))
+ weight = numeric(sum(nrv))
+ dl <- matrix(NA, sum(nrv), l)
+ for (i in 1:n) weight[(cnr[i] + 1):cnr[i + 1]] = attr(object[[i]]$data,
+ "weight")
+ ll0 = 0
+ for (i in 1:n) ll0 = ll0 + object[[i]]$logLik
+ eps = 1
+ scalep =1
+ k = 1
+ while (eps > 0.001 & k<50) {
+ if(scalep==1){
+ for (i in 1:n) {
+ lv = drop(exp(object[[i]]$site))
+ dl[(cnr[i] + 1):cnr[i + 1], ] = dl(object[[i]], TRUE)/lv
+ }
+ sc = colSums(weight * dl)
+ F = crossprod(dl * weight, dl) + diag(l)*1e-10
+ # add small ridge penalty for numerical stability
+ }
+ thetaNew = log(theta) + scalep * solve(F, sc)
+ tree$edge.length = as.numeric(exp(thetaNew))
+ for (i in 1:n) object[[i]] <- update(object[[i]], tree = tree)
+ ll1 = 0
+ for (i in 1:n) ll1 = ll1 + object[[i]]$logLik
+ eps <- ll1 - ll0
+ if (eps < 0 || is.nan(eps)) {
+ scalep = scalep/2
+ eps = 1
+ thetaNew = log(theta)
+ ll1 = ll0
+ }
+ else scalep = 1
+ theta = exp(thetaNew)
+ ll0 <- ll1
+ k=k+1
+ }
+ object
+}
+
+
+makePart <- function(fit, rooted, weight=~index+genes){
+ if(class(fit)=="phyDat"){
+ x <- fit
+ dm <- dist.ml(x)
+ if(!rooted) tree <- NJ(dm)
+ else tree <- upgma(dm)
+ fit <- pml(tree, x, k=4)
+ }
+ dat <- fit$data
+ if(class(weight)[1]=="formula")
+ weight <- xtabs(weight, data=attr(dat, "index"))
+ fits <- NULL
+ for(i in 1:dim(weight)[2]){
+ ind <- which(weight[,i] > 0)
+ dat2 <- getRows(dat, ind)
+ attr(dat2, "weight") <- weight[ind,i]
+ fits[[i]] <- update(fit, data = dat2)
+ }
+ names(fits) = colnames(fits)
+ fits
+}
+
+
+multiphyDat2pmlPart <- function(x, rooted=FALSE, ...){
+ fun <- function(x, ...){
+ dm <- dist.ml(x)
+ if(!rooted) tree <- NJ(dm)
+ else tree <- upgma(dm)
+ fit <- pml(tree, x, ...)
+ }
+ fits <- lapply(x at dna, fun, ...)
+ fits
+}
+
+
+pmlPart2multiPhylo <- function(x){
+ res <- lapply(x$fits, FUN=function(x)x$tree)
+ class(res) <- "multiPhylo"
+ res
+}
+
+
+pmlPart <- function (formula, object, control=pml.control(epsilon=1e-8, maxit=10, trace=1), model=NULL, rooted=FALSE, ...)
+{
+ call <- match.call()
+ form <- phangornParseFormula(formula)
+ opt <- c("nni", "bf", "Q", "inv", "shape", "edge", "rate")
+ optAll <- match(opt, form$left)
+ optPart <- match(opt, form$right)
+ AllNNI <- !is.na(optAll[1])
+ AllBf <- !is.na(optAll[2])
+ AllQ <- !is.na(optAll[3])
+ AllInv <- !is.na(optAll[4])
+ AllGamma <- !is.na(optAll[5])
+ AllEdge <- !is.na(optAll[6])
+ PartNni <- !is.na(optPart[1])
+ PartBf <- !is.na(optPart[2])
+ PartQ <- !is.na(optPart[3])
+ PartInv <- !is.na(optPart[4])
+ PartGamma <- !is.na(optPart[5])
+ PartEdge <- !is.na(optPart[6])
+ PartRate <- !is.na(optPart[7])
+
+ if(class(object)=="multiphyDat"){
+ if(AllNNI || AllEdge) object <- do.call(cbind.phyDat, object at dna)
+ else fits <- multiphyDat2pmlPart(object, rooted=rooted, ...)
+ }
+ if(class(object)=="pml") fits <- makePart(object, rooted=rooted, ...)
+ if(class(object)=="phyDat") fits <- makePart(object, rooted=rooted, ...)
+ if(class(object)=="pmlPart") fits <- object$fits
+ if(class(object)=="list") fits <- object
+
+
+ trace = control$trace
+ epsilon = control$epsilon
+ maxit = control$maxit
+
+ p <- length(fits)
+ # if(length(model)<p) model = rep(model, length = p)
+
+ m = 1
+ logLik = 0
+ for (i in 1:p) logLik = logLik + fits[[i]]$log
+ eps = 10
+ while (eps > epsilon & m < maxit) {
+ loli = 0
+ if(any(c(PartNni, PartBf, PartInv, PartQ, PartGamma, PartEdge, PartRate))){
+ for (i in 1:p) {
+ fits[[i]] = optim.pml(fits[[i]], optNni=PartNni, optBf=PartBf,
+ optQ=PartQ, optInv=PartInv, optGamma=PartGamma, optEdge=PartEdge,
+ optRate=PartRate, optRooted=rooted,
+ control = pml.control(maxit = 3, epsilon = 1e-8, trace-1), model=model[i])
+ }
+ }
+ if (AllQ) {
+ Q = fits[[1]]$Q
+ subs = c(1:(length(Q)-1), 0)
+ newQ <- optimPartQGeneral(fits, Q=Q, subs=subs)
+ for (i in 1:p) fits[[i]] <- update(fits[[i]], Q = newQ[[1]])
+ }
+ if (AllBf) {
+ bf = fits[[1]]$bf
+ newBf <- optimPartBf(fits, bf=bf)
+ for (i in 1:p) fits[[i]] <- update(fits[[i]], bf = newBf)
+ }
+ if (AllInv) {
+ inv = fits[[1]]$inv
+ newInv <- optimPartInv(fits, inv=inv)
+ for (i in 1:p) fits[[i]] <- update(fits[[i]], inv = newInv)
+ }
+ if (AllGamma) {
+ shape = fits[[1]]$shape
+ newGamma <- optimPartGamma(fits, shape=shape)[[1]]
+ for (i in 1:p) fits[[i]] <- update(fits[[i]], shape = newGamma)
+ }
+ if (AllNNI){
+ fits <- optimPartNNI(fits,AllEdge)
+ if(trace>0) cat(attr(fits,"swap"), " NNI operations performed")
+ }
+ if (AllEdge)
+ fits <- optimPartEdge(fits)
+ if (PartRate){
+ tree = fits[[1]]$tree
+ rate=numeric(p)
+ wp =numeric(p)
+ for(i in 1:p){
+ wp[i]=sum(fits[[i]]$weight)
+ rate[i] <- fits[[i]]$rate
+ }
+ ratemult = sum(wp) / sum(wp*rate)
+ tree$edge.length = tree$edge.length/ratemult
+ for(i in 1:p)fits[[i]] = update(fits[[i]], tree=tree, rate=rate[i]*ratemult)
+ }
+ loli <- 0
+ for (i in 1:p) loli <- loli + fits[[i]]$log
+ eps = (logLik - loli)/loli
+ if(trace>0) cat("loglik:", logLik, "-->", loli, "\n")
+ logLik <- loli
+ m = m + 1
+ }
+
+ df <- matrix(1, 6 ,2)
+ colnames(df) <- c("#df", "group")
+ rownames(df) <- c("Edge", "Shape", "Inv", "Bf", "Q", "Rate")
+ df[1,1] <- length(fits[[1]]$tree$edge.length)
+ df[2,1] <- fits[[1]]$k > 1
+ df[3,1] <- fits[[1]]$inv > 0
+ df[4,1] <- length(unique(fits[[1]]$bf)) - 1
+ df[5,1] <- length(unique(fits[[1]]$Q)) - 1
+ df[6,1] <- 0 # rates
+ if(PartEdge) df[1,2] = p
+ if(PartGamma) df[2,2] = p
+ if(PartInv) df[3,2] = p
+ if(PartBf) df[4,2] = p
+ if(PartQ) df[5,2] = p
+ if(PartRate) df[6,1] = p-1
+ attr(logLik, "df") = sum(df[,1]*df[,2])
+ object <- list(logLik = logLik, fits = fits, call = call, df=df)
+ class(object) <- "pmlPart"
+ object
+}
+
+
+#
+# Distance Matrix methods
+#
+
+bip <- function (obj)
+{
+ if (is.null(attr(obj, "order")) || attr(obj, "order") ==
+ "cladewise")
+ obj <- reorder(obj, "postorder")
+ maxP = max(obj$edge)
+ nTips = length(obj$tip)
+ res <- .Call("C_bip", as.integer(obj$edge[, 1]), as.integer(obj$edge[, 2]), as.integer(nTips), as.integer(maxP))
+ res
+}
+
+
+# as.Matrix, sparse = TRUE,
+designTree <- function(tree, method="unrooted", sparse=FALSE, ...){
+ if (!is.na(pmatch(method, "all")))
+ method <- "unrooted"
+ METHOD <- c("unrooted", "rooted")
+ method <- pmatch(method, METHOD)
+ if (is.na(method)) stop("invalid method")
+ if (method == -1) stop("ambiguous method")
+ if(!is.rooted(tree) & method==2) stop("tree has to be rooted")
+ if(method==1){ X <- designUnrooted(tree,...)
+ if(sparse) X = Matrix(X)
+ }
+ if(method==2) X <- designUltra(tree, sparse=sparse,...)
+ X
+}
+
+
+# splits now work
+designUnrooted = function (tree, order = NULL)
+{
+ if(inherits(tree, "phylo")){
+ if (is.rooted(tree))
+ tree = unroot(tree)
+ p = bipartition(tree)
+ }
+ if(inherits(tree, "splits")) p <- as.matrix(tree)
+ if (!is.null(order))
+ p = p[, order]
+
+ m = dim(p)[2]
+ ind = rowSums(p)
+ p=p[ind!=m,]
+ n = dim(p)[1]
+ res = matrix(0, (m - 1) * m/2, n)
+ k = 1
+ for (i in 1:(m - 1)) {
+ for (j in (i + 1):m) {
+ res[k, ] = p[, i] != p[, j]
+ k = k + 1
+ }
+ }
+ if(inherits(tree, "phylo"))colnames(res) = paste(tree$edge[, 1], tree$edge[, 2], sep = "<->")
+ res
+}
+
+
+designUltra <- function (tree, sparse=FALSE)
+{
+ if (is.null(attr(tree, "order")) || attr(tree, "order") == "cladewise")
+ tree = reorder(tree, "postorder")
+ leri = allChildren(tree)
+ bp = bip(tree)
+ n = length(tree$tip)
+ l = tree$Nnode
+ nodes = integer(l)
+ k = 1L
+ u=numeric( n * (n - 1)/2)
+ v=numeric( n * (n - 1)/2)
+ m = 1L
+ for (i in 1:length(leri)) {
+ if (!is.null(leri[[i]])) {
+ ind = getIndex(bp[[leri[[i]][1] ]], bp[[leri[[i]][2] ]], n)
+ li = length(ind)
+ v[m: (m+li-1)]=k
+ u[m: (m+li-1)]=ind
+ nodes[k]=i
+ m = m+li
+ k = k + 1L
+ }
+ }
+ if(sparse) X = sparseMatrix(i=u,j=v, x=2L)
+ else{
+ X = matrix(0L, n * (n - 1)/2, l)
+ X[cbind(u,v)]=2L
+ }
+ colnames(X) = nodes
+ attr(X, "nodes") = nodes
+ X
+}
+
+
+nnls.tree <- function(dm, tree, rooted=FALSE, trace=1){
+ if(is.rooted(tree) & rooted==FALSE){
+ tree = unroot(tree)
+ warning("tree was rooted, I unrooted the tree!")
+ }
+ tree = reorder(tree, "postorder")
+ dm = as.matrix(dm)
+ k = dim(dm)[1]
+ labels = tree$tip
+ dm = dm[labels,labels]
+ y = dm[lower.tri(dm)]
+#computing the design matrix from the tree
+ if(rooted) X = designUltra(tree)
+ else X = designUnrooted(tree)
+# na.action
+ if(any(is.na(y))){
+ ind = which(is.na(y))
+ X = X[-ind,,drop=FALSE]
+ y= y[-ind]
+ }
+# LS solution
+ fit = lm.fit(X,y)
+ betahat = as.vector(fit$coefficients) # added as.vector
+ if(rooted){
+ bhat = numeric(max(tree$edge))
+ bhat[as.integer(colnames(X))] = betahat
+ betahat = bhat[tree$edge[,1]] - bhat[tree$edge[,2]]
+ }
+ if(!any(betahat<0)){
+ RSS = sum(fit$residuals^2)
+ if(trace)print(paste("RSS:", RSS))
+ attr(tree, "RSS") = RSS
+ tree$edge.length = betahat # deleted []
+ return(tree)
+ }
+# non-negative LS
+ n = dim(X)[2]
+ Dmat <- crossprod(X) # cross-product computations
+ dvec <- crossprod(X, y)
+ if(rooted){
+ l = nrow(tree$edge)
+ Amat = matrix(0, n, l)
+ ind = match(tree$edge[,1], colnames(X))
+ Amat[cbind(ind, 1:l)] = 1
+ ind = match(tree$edge[,2], colnames(X))
+ Amat[cbind(ind, 1:l)] = -1
+ }
+ else Amat <- diag(n)
+ betahat <- quadprog::solve.QP(Dmat,dvec,Amat)$sol # quadratic programing solving
+ RSS = sum((y-(X%*%betahat))^2)
+
+ if(rooted){
+ bhat = numeric(max(tree$edge))
+ bhat[as.integer(colnames(X))] = betahat
+ betahat = bhat[tree$edge[,1]] - bhat[tree$edge[,2]]
+ }
+ tree$edge.length = betahat # deleted []
+ if(trace)print(paste("RSS:", RSS))
+ attr(tree, "RSS") = RSS
+ tree
+}
+
+
+nnls.phylo <- function(x, dm, rooted=FALSE, trace=0){
+ nnls.tree(dm, x, rooted, trace=trace)
+}
+
+
+nnls.splits <- function(x, dm, trace=0){
+ labels=attr(x, "labels")
+ dm = as.matrix(dm)
+ k = dim(dm)[1]
+ dm = dm[labels,labels]
+ y = dm[lower.tri(dm)]
+
+ x = SHORTwise(x, k)
+ l <- sapply(x, length)
+ if(any(l==0)) x = x[-which(l==0)]
+
+ X = splits2design(x)
+
+ if(any(is.na(y))){
+ ind = which(is.na(y))
+ X = X[-ind,,drop=FALSE]
+ y= y[-ind]
+ }
+ X = as.matrix(X)
+ n = dim(X)[2]
+ int = sapply(x, length)
+ Amat = diag(n) # (int)
+ betahat <- nnls(X, y)
+ ind = (betahat$x > 1e-8) | int==1
+ x = x[ind]
+ RSS <- betahat$deviance
+ attr(x, "weights") = betahat$x[ind]
+ if(trace)print(paste("RSS:", RSS))
+ attr(x, "RSS") = RSS
+ x
+}
+
+
+nnls.splitsOld <- function(x, dm, trace=0){
+ labels=attr(x, "labels")
+ dm = as.matrix(dm)
+ k = dim(dm)[1]
+ dm = dm[labels,labels]
+ y = dm[lower.tri(dm)]
+
+ x = SHORTwise(x, k)
+ l <- sapply(x, length)
+ if(any(l==0)) x = x[-which(l==0)]
+
+ X = splits2design(x)
+
+ if(any(is.na(y))){
+ ind = which(is.na(y))
+ X = X[-ind,,drop=FALSE]
+ y= y[-ind]
+ }
+
+ Dmat <- crossprod(X) # cross-product computations
+ dvec <- crossprod(X, y)
+ betahat <- as.vector(solve(Dmat, dvec))
+
+ if(!any(betahat<0)){
+ RSS = sum((y-(X%*%betahat))^2)
+ if(trace)print(paste("RSS:", RSS))
+ attr(x, "RSS") = RSS
+ attr(x, "weights") = betahat
+ return(x)
+ }
+ n = dim(X)[2]
+
+ int = sapply(x, length)
+# int = as.numeric(int==1)# (int>1)
+ Amat = diag(n) # (int)
+ betahat <- quadprog::solve.QP(as.matrix(Dmat),as.vector(dvec),Amat)$sol # quadratic programing solving
+ RSS = sum((y-(X%*%betahat))^2)
+ ind = (betahat > 1e-8) | int==1
+ x = x[ind]
+ attr(x, "weights") = betahat[ind]
+ if(trace)print(paste("RSS:", RSS))
+ attr(x, "RSS") = RSS
+ x
+}
+
+nnls.networx <- function(x, dm){
+ spl <- attr(x, "splits")
+ spl2 <- nnls.splits(spl, dm)
+ weight <- attr(spl, "weight")
+ weight[] <- 0
+ weight[match(spl2, spl)] = attr(spl2, "weight")
+ attr(attr(x, "splits"), "weight") <- weight
+ x$edge.length = weight[x$splitIndex]
+ x
+}
+
+
+designSplits <- function (x, splits = "all", ...)
+{
+ if (!is.na(pmatch(splits, "all")))
+ splits <- "all"
+ if(inherits(x, "splits")) return(designUnrooted(x))
+ SPLITS <- c("all", "star") #,"caterpillar")
+ splits <- pmatch(splits, SPLITS)
+ if (is.na(splits)) stop("invalid splits method")
+ if (splits == -1) stop("ambiguous splits method")
+ if(splits==1) X <- designAll(x)
+ if(splits==2) X <- designStar(x)
+ return(X)
+}
+
+# add return splits=FALSE
+designAll <- function(n, add.split=FALSE){
+ Y = matrix(0L, n*(n-1)/2, n)
+ k = 1
+ for(i in 1:(n-1)){
+ for(j in (i+1):n){
+ Y[k,c(i,j)]=1L
+ k=k+1L
+ }
+ }
+ m <- n-1L
+ X <- matrix(0L, m+1, 2^m)
+ for(i in 1:m)
+ X[i, ] <- rep(rep(c(0L,1L), each=2^(i-1)),2^(m-i))
+ X <- X[,-1]
+ if(!add.split) return((Y%*%X)%%2)
+ list(X=(Y%*%X)%%2,Splits=t(X))
+}
+
+
+designStar = function(n){
+ res=NULL
+ for(i in 1:(n-1)) res = rbind(res,cbind(matrix(0,(n-i),i-1),1,diag(n-i)))
+ res
+}
+
+
+bipart <- function(obj){
+ if (is.null(attr(obj, "order")) || attr(obj, "order") == "cladewise")
+ obj <- reorder(obj, "postorder")
+ maxP = max(obj$edge)
+ nTips = length(obj$tip)
+ res <- .Call("C_bipart", as.integer(obj$edge[,1]) , as.integer(obj$edge[,2]), as.integer(nTips), as.integer(maxP)) #, as.integer(obj$Nnode))
+# attr(res, "nodes") = unique(obj$edge[,1])
+ res
+}
+
+
+bipartition <- function (tree)
+{
+ if(is.rooted(tree))tree <- unroot(tree)
+ if(is.null(attr(tree,"order")) || attr(tree, "order")=="cladewise") tree <- reorder(tree, "postorder")
+ bp <- bipart(tree)
+ nTips = length(tree$tip)
+ l = length(bp)
+ m = length(bp[[l]])
+ k = length(tree$edge[, 1])
+ result = matrix(0L, l, m)
+ res = matrix(0L, k, m)
+ for (i in 1:l) result[i, bp[[i]]] = 1L
+ result = result[-l, ,drop=FALSE]
+ for (i in 1:nTips) res[(tree$edge[, 2] == i), i] = 1L
+# res[tree$edge[, 2] > nTips, ] = result
+ res[ match(unique(tree$edge[,1]),tree$edge[,2])[-l], ] = result
+ colnames(res) = tree$tip.label
+ rownames(res) = tree$edge[,2]
+ res[res[, 1] == 1, ] = 1L - res[res[, 1] == 1, ]
+ res
+}
+
+
+
+pmlCluster.fit <- function (formula, fit, weight, p = 4, part = NULL, control=pml.control(epsilon=1e-8, maxit=10, trace=1), ...)
+{
+ call <- match.call()
+ form <- phangornParseFormula(formula)
+ opt <- c("nni", "bf", "Q", "inv", "shape", "edge", "rate")
+ optAll <- match(opt, form$left)
+ optPart <- match(opt, form$right)
+ AllNNI <- !is.na(optAll[1])
+ AllBf <- !is.na(optAll[2])
+ AllQ <- !is.na(optAll[3])
+ AllInv <- !is.na(optAll[4])
+ AllGamma <- !is.na(optAll[5])
+ AllEdge <- !is.na(optAll[6])
+ PartNni <- !is.na(optPart[1])
+ PartBf <- !is.na(optPart[2])
+ PartQ <- !is.na(optPart[3])
+ PartInv <- !is.na(optPart[4])
+ PartGamma <- !is.na(optPart[5])
+ PartEdge <- !is.na(optPart[6])
+ PartRate <- !is.na(optPart[7])
+ nrw <- dim(weight)[1]
+ ncw <- dim(weight)[2]
+ if (is.null(part)){
+ part = rep(1:p, length=ncw)
+ part = sample(part)
+ }
+ Part = part
+ Gtrees = vector("list", p)
+ dat <- fit$data
+ attr(fit$orig.data, "index") <- attr(dat, "index") <- NULL
+ for (i in 1:p) Gtrees[[i]] = fit$tree
+ fits = vector("list", p)
+ for (i in 1:p) fits[[i]] = fit
+ trace = control$trace
+ eps = 0
+ m = 1
+ logLik = fit$log
+ trees = list()
+ weights = matrix(0, nrw, p)
+ lls = matrix(0, nrw, p)
+ loli = fit$log
+ oldpart = part
+ eps2 = 1
+ iter = 0
+ swap = 1
+ while (eps < ncw || abs(eps2) > control$eps) {
+ df2 = 0
+
+ if(any(c(PartNni, PartBf, PartInv, PartQ, PartGamma, PartEdge, PartRate))){
+ for (i in 1:p) {
+ weights[, i] = rowSums(weight[, which(part == i),
+ drop = FALSE])
+ ind <- which(weights[, i] > 0)
+ dat2 <- getRows(dat, ind)
+ attr(dat2, "weight") <- weights[ind, i]
+ fits[[i]] <- update(fits[[i]], data = dat2)
+ fits[[i]] = optim.pml(fits[[i]], PartNni, PartBf,
+ PartQ, PartInv, PartGamma, PartEdge, PartRate,
+ control = pml.control(epsilon = 1e-8, maxit = 3, trace-1))
+ lls[, i] = update(fits[[i]], data = dat)$site
+ Gtrees[[i]] = fits[[i]]$tree
+ }
+ }
+ if (AllQ) {
+ Q = fits[[1]]$Q
+ subs = c(1:(length(Q)-1), 0)
+ newQ <- optimPartQGeneral(fits, Q=Q, subs=subs)[[1]]
+ for (i in 1:p) fits[[i]] <- update(fits[[i]], Q = newQ)
+ df2 = df2 + length(unique(newQ)) - 1
+ }
+ if (AllBf) {
+ bf = fits[[1]]$bf
+ newBf <- optimPartBf(fits, bf=bf)
+ for (i in 1:p) fits[[i]] <- update(fits[[i]], bf = newBf)
+ df2 = df2 + length(unique(newBf)) - 1
+ }
+ if (AllInv) {
+ inv = fits[[1]]$inv
+ newInv <- optimPartInv(fits, inv=inv)
+ for (i in 1:p) fits[[i]] <- update(fits[[i]], inv = newInv) #there was an Error
+ df2 = df2 + 1
+ }
+ if (AllGamma) {
+ shape = fits[[1]]$shape
+ newGamma <- optimPartGamma(fits, shape=shape)[[1]]
+ for (i in 1:p) fits[[i]] <- update(fits[[i]], shape = newGamma)
+ df2 = df2 + 1
+ }
+ if (AllNNI) {
+ fits <- optimPartNNI(fits, AllEdge)
+ if(trace>0)cat(attr(fits, "swap"), " NNI operations performed")
+ swap <- attr(fits, "swap")
+ }
+ if (AllEdge) {
+ fits <- optimPartEdge(fits)
+ df2 = df2 + length(fits[[1]]$tree$edge.length)
+ }
+ if (PartRate) {
+ tree = fits[[1]]$tree
+ rate = numeric(p)
+ wp = numeric(p)
+ for (i in 1:p) {
+ wp[i] = sum(fits[[i]]$weight)
+ rate[i] <- fits[[i]]$rate
+ }
+ ratemult = sum(wp)/sum(wp * rate)
+ tree$edge.length = tree$edge.length/ratemult
+ for (i in 1:p) fits[[i]] = update(fits[[i]], tree = tree,
+ rate = rate[i] * ratemult)
+ }
+ for (i in 1:p) lls[, i] = update(fits[[i]], data = dat)$site
+ trees[[m]] = Gtrees
+ LL = t(weight) %*% lls
+# choose partitions which change
+ tmp =(LL[cbind(1:ncw,part)] - apply(LL, 1, max))/colSums(weight)
+ fixi = numeric(p)
+ for(i in 1:p){
+ tmpi = which(part == i)
+ fixi[i] = tmpi[which.max(tmp[tmpi])]
+ }
+ oldpart = part
+# restrict the number of elements changing groups
+# If more than 25% would change, only the 25% with the highest increase per site change
+ if( sum(tmp==0)/length(tmp) < .75){
+ medtmp = quantile(tmp, .25)
+ medind = which(tmp<=medtmp)
+ part[medind] = apply(LL[medind,], 1, which.max)
+ }
+ else part = apply(LL, 1, which.max)
+# force groups to have at least one member
+ part[fixi] = 1:p
+ Part = cbind(Part, part)
+ eps = sum(diag(table(part, oldpart)))
+ eps2 = loli
+ loli = sum(apply(LL, 1, max))
+ eps2 = (eps2 - loli)/loli
+ logLik = c(logLik, loli)
+ if(trace>0) print(loli)
+ Part = cbind(Part, part)
+ df2 = df2 + df2
+ if (eps == ncw & swap == 0)
+ AllNNI = FALSE
+ m = m + 1
+ if (eps == ncw)
+ iter = iter + 1
+ if (iter == 3)
+ break
+ }
+ df <- matrix(1, 6, 2)
+ colnames(df) <- c("#df", "group")
+ rownames(df) <- c("Edge", "Shape", "Inv", "Bf", "Q", "Rate")
+ df[1, 1] <- length(fits[[1]]$tree$edge.length)
+ df[2, 1] <- fits[[1]]$k - 1
+ df[3, 1] <- fits[[1]]$inv > 0
+ df[4, 1] <- length(unique(fits[[1]]$bf)) - 1
+ df[5, 1] <- length(unique(fits[[1]]$Q)) - 1
+ df[6, 1] <- 0
+ if (PartEdge)
+ df[1, 2] = p
+ if (PartGamma)
+ df[2, 2] = p
+ if (PartInv)
+ df[3, 2] = p
+ if (PartBf)
+ df[4, 2] = p
+ if (PartQ)
+ df[5, 2] = p
+ if (PartRate)
+ df[6, 1] = p - 1
+ attr(logLik, "df") = sum(df[, 1] * df[, 2])
+ res = list(logLik = logLik, Partition = Part, trees = trees) # intermediate results
+ result <- list(logLik = loli, fits = fits, Partition = part, df = df, res = res, call = call)
+ class(result) <- c("pmlPart")
+ result
+}
+
+
+pmlCluster <- function (formula, fit, weight, p = 1:5, part = NULL, nrep = 10, control = pml.control(epsilon = 1e-08,
+ maxit = 10, trace = 1), ...)
+{
+ call <- match.call()
+ form <- phangornParseFormula(formula)
+ if(any(p==1)){
+ opt2 <- c("nni", "bf", "Q", "inv", "shape", "edge")
+ tmp1 <- opt2 %in% form$left
+ tmp1 <- tmp1 | (opt2 %in% form$right)
+ fit <- optim.pml(fit, tmp1[1], tmp1[2], tmp1[3], tmp1[4],
+ tmp1[5], tmp1[6])
+ }
+
+ p=p[p!=1]
+ if(length(p)==0)return(fit)
+ n = sum(weight)
+ k=2
+
+ BIC = matrix(0, length(p)+1, nrep)
+ BIC[1,] = AIC(fit, k = log(n))
+ LL = matrix(NA, length(p)+1, nrep)
+ LL[1,] = logLik(fit)
+
+ P = array(dim=c(length(p)+1, nrep, dim(weight)[2]))
+ tmpBIC = Inf
+ choice = c(1,1)
+ for(j in p){
+ tmp=NULL
+ for(i in 1:nrep){
+ tmp = pmlCluster.fit(formula, fit, weight, p=j, part=part, control=control,...)
+ P[k,i,] = tmp$Partition
+ BIC[k,i] = AIC(tmp, k = log(n))
+ LL[k,i] = logLik(tmp)
+ if(BIC[k,i]<tmpBIC){
+ tmpBIC = BIC[k,i]
+ result = tmp
+ choice = c(k,i)
+ }
+ }
+ k=k+1
+ }
+
+ p = c(1,p)
+ result$choice = choice
+ result$BIC = BIC
+ result$AllPartitions = P
+ result$AllLL = LL
+ result$p = p
+ class(result) = c("pmlCluster", "pmlPart")
+ result
+}
+
+
+plot.pmlCluster <- function(x, which = c(1L:3L), caption = list("BIC", "log-likelihood", "Partitions"), ...){
+ show <- rep(FALSE, 3)
+ show[which] <- TRUE
+ choice = x$choice
+ if(show[1]){
+ X <- x$AllPartitions[choice[1],,]
+ d <- dim(X)
+ ind = order(X[choice[2],])
+ im = matrix(0, d[2], d[2])
+ for(j in 1:d[1]){for(i in 1:d[2]) im[i,] = im[i,] + (X[j,] == X[j,i]) }
+ image(im[ind, ind], ...)
+ }
+
+ if(show[1])matplot(x$p, x$BIC, ylab="BIC", xlab="number of clusters")
+ if(show[1])matplot(x$p, x$AllLL, ylab="log-likelihood", xlab="number of clusters")
+}
+
+
+readAArate <- function(file){
+ tmp <- read.table(system.file(file.path("extdata", file)), col.names = 1:20, fill=TRUE)
+ Q <- tmp[1:19,1:19]
+ names <- c("a", "r", "n", "d", "c", "q", "e", "g", "h", "i", "l", "k", "m", "f", "p", "s", "t", "w", "y", "v")
+ Q <- as.numeric(Q[lower.tri(Q,TRUE)])
+ bf <- as.numeric(as.character(unlist(tmp[20,])))
+ names(bf) <- names
+ list(Q=Q, bf=bf)
+}
+
+
+#.LG <- readAArate("lg.dat")
+#.WAG <- readAArate("wag.dat")
+#.Dayhoff <- readAArate("dayhoff-dcmut.dat")
+#.JTT <- readAArate("jtt-dcmut.dat")
+#.cpREV <- readAArate("cpREV.dat")
+#.mtmam <- readAArate("mtmam.dat")
+#.mtArt <- readAArate("mtArt.dat")
+# save(.LG,.WAG,.Dayhoff,.JTT,.cpREV,.mtmam,.mtArt, file = "sysdata2.rda")
+
+
+getModelAA <- function(model, bf=TRUE, Q=TRUE){
+ model <- match.arg(eval(model), .aamodels)
+ tmp = get(paste(".", model, sep=""), environment(pml))
+ if(Q) assign("Q", tmp$Q, envir=parent.frame())
+ if(bf) assign("bf", tmp$bf, envir=parent.frame())
+}
+
+
+print.pml = function(x,...){
+ cat("\n loglikelihood:", x$logLik, "\n")
+ w <- x$weight
+ w <- w[w>0]
+ type <- attr(x$data, "type")
+ levels <- attr(x$data, "levels")
+ nc <- attr(x$data, "nc")
+ ll0 = sum(w*log(w/sum(w)))
+ cat("\nunconstrained loglikelihood:", ll0, "\n")
+ if(x$inv > 0)cat("Proportion of invariant sites:",x$inv,"\n")
+ if(x$k >1){
+ cat("Discrete gamma model\n")
+ cat("Number of rate categories:",x$k,"\n")
+ cat("Shape parameter:",x$shape,"\n")
+ }
+ if(type=="AA") cat("Rate matrix:",x$model, "\n")
+ if(type=="DNA"){
+ cat("\nRate matrix:\n")
+ QM = matrix(0, nc, nc, dimnames = list(levels,levels))
+ QM[lower.tri(QM)] = x$Q
+ QM = QM+t(QM)
+ print(QM)
+ cat("\nBase frequencies: \n")
+ bf = x$bf
+ names(bf) = levels
+ cat(bf, "\n")
+ }
+ if(type=="CODON") {
+ cat("dn/ds:",x$dnds, "\n")
+ cat("ts/tv:",x$tstv, "\n")
+ }
+ if(type=="USER" & length(x$bf)<11){
+ cat("\nRate matrix:\n")
+ QM = matrix(0, nc, nc, dimnames = list(levels,levels))
+ QM[lower.tri(QM)] = x$Q
+ QM = QM+t(QM)
+ print(QM)
+ cat("\nBase frequencies: \n")
+ bf = x$bf
+ names(bf) = levels
+ cat(bf, "\n")
+ }
+}
+
+
+optEdgeMulti <- function (object, control = pml.control(epsilon = 1e-8, maxit = 10, trace=1), ...)
+{
+ tree <- object$tree
+ theta <- object$tree$edge.length
+ weight <- attr(object$data, "weight")
+ ll0 = object$logLik
+ eps = 1
+ iter = 0
+ iter2 = 0
+ scale = 1
+ # l = length(theta)
+ while (abs(eps) > control$eps && iter < control$maxit) {
+ dl = score(object)
+ thetaNew = log(theta) + scale * solve(dl[[2]], dl[[1]]) #+ diag(l)*1e-10
+ newtheta = exp(thetaNew)
+ tree$edge.length = as.numeric(newtheta)
+ object <- update(object, tree = tree)
+ ll1 = object$logLik
+ eps <- ( ll0 - ll1 ) / ll1
+ if(eps < 0){
+ newtheta = theta
+ scale = scale / 2
+ tree$edge.length = as.numeric(theta)
+ ll1 = ll0
+ iter2 <- iter2+1
+ }
+ else{
+ scale=1
+ iter2 = 0
+ }
+ theta = newtheta
+ if(iter2==0 && control$trace>0) cat("loglik: ",ll1,"\n")
+ ll0 <- ll1
+ if(iter2==10)iter2=0
+ if(iter2==0)iter <- iter+1
+ }
+ object <- update(object, tree = tree)
+ object
+}
+
+
+# add data for internal use parent.frame(n) for higher nestings
+update.pmlNew <- function (object, ..., evaluate = TRUE){
+ call <- object$call
+ if (is.null(call))
+ stop("need an object with call component")
+ extras <- match.call(expand.dots = FALSE)$...
+ if (length(extras)) {
+ existing <- !is.na(match(names(extras), names(call)))
+ for (a in names(extras)[existing]) call[[a]] <- extras[[a]]
+ if (any(!existing)) {
+ call <- c(as.list(call), extras[!existing])
+ call <- as.call(call)
+ }
+ }
+ if (evaluate)
+ eval(call, object, parent.frame())
+ else call
+}
+
+
+update.pml <- function (object, ...)
+{
+ extras <- match.call(expand.dots = FALSE)$...
+ pmla <- c("tree", "data", "bf", "Q", "inv", "k", "shape",
+ "rate", "model", "wMix", "llMix", "...")
+ names(extras) <- pmla[pmatch(names(extras), pmla[-length(pmla)])]
+ call = object$call
+ if (length(extras)) {
+ existing <- !is.na(match(names(extras), names(call)))
+ for (a in names(extras)[existing]) call[[a]] <- extras[[a]]
+ if (any(!existing)) {
+ call <- c(as.list(call), extras[!existing])
+ call <- as.call(call)
+ }
+ }
+ existing <- match(pmla, names(extras))
+ updateEig <- FALSE
+ updateRates <- FALSE
+ if (is.na(existing[1])) tree <- object$tree
+ else tree <- eval(extras[[existing[1]]], parent.frame())
+ if(is.null(attr(tree,"order")) || attr(tree,"order")=="cladewise")tree <- reorder(tree, "postorder")
+ if (is.na(existing[2])){
+ data <- object$data
+ INV <- object$INV
+ }
+ else{
+ data <- eval(extras[[existing[2]]], parent.frame())
+ ll.0 <- numeric(attr(data,"nr"))
+ INV <- Matrix(lli(data, tree), sparse=TRUE)
+ }
+ nr <- as.integer(attr(data, "nr"))
+ nc <- as.integer(attr(data, "nc"))
+
+ if (is.na(existing[3])) bf <- object$bf
+ else {
+ bf <- eval(extras[[existing[3]]], parent.frame())
+ updateEig <- TRUE
+ }
+ if (is.na(existing[4])) Q <- object$Q
+ else {
+ Q <- eval(extras[[existing[4]]], parent.frame())
+ updateEig <- TRUE
+ }
+# model <- object$model
+ type <- attr(object$data, "type")
+ model<-NULL
+ if (type == "AA") {
+ if(!is.na(existing[9]) ){
+# model <- match.arg(eval(extras[[existing[9]]], parent.frame()), c("WAG", "JTT", "LG", "Dayhoff", "cpREV", "mtmam", "mtArt", "MtZoa", "mtREV24"))
+ model <- match.arg(eval(extras[[existing[9]]], parent.frame()), .aamodels)
+ getModelAA(model, bf = is.na(existing[3]), Q = is.na(existing[4]))
+ updateEig <- TRUE
+ }
+# else model <- object$model
+ }
+
+ if(is.na(existing[5])) inv <- object$inv
+ else{
+ inv <- eval(extras[[existing[5]]], parent.frame())
+ updateRates <- TRUE
+ }
+ if(is.na(existing[6])) k <- object$k
+ else{
+ k <- eval(extras[[existing[6]]], parent.frame())
+ updateRates <- TRUE
+ }
+ if(is.na(existing[7])) shape <- object$shape
+ else{
+ shape <- eval(extras[[existing[7]]], parent.frame())
+ updateRates <- TRUE
+ }
+ rate <- ifelse(is.na(existing[8]), object$rate, eval(extras[[existing[8]]], parent.frame()))
+ wMix <- ifelse(is.na(existing[10]), object$wMix, eval(extras[[existing[10]]], parent.frame()))
+ if(is.na(existing[11])) llMix <- object$llMix
+ else llMix <- eval(extras[[existing[11]]], parent.frame())
+ levels <- attr(data, "levels")
+ weight <- attr(data, "weight")
+ if(updateEig)eig <- edQt(bf = bf, Q = Q)
+ else eig <- object$eig
+ g <- discrete.gamma(shape, k)
+ g <- rate * g
+ if (inv > 0) g <- g/(1 - inv)
+ ll.0 <- as.matrix(INV %*% (bf * inv))
+ if(wMix>0) ll.0 <- ll.0 + llMix
+ w = rep(1/k, k)
+ if (inv > 0)
+ w <- (1 - inv) * w
+ if (wMix > 0)
+ w <- wMix * w
+ m <- 1
+
+ resll <- matrix(0, nr, k)
+ nTips = as.integer(length(tree$tip.label))
+
+ data <- subset(data, tree$tip.label)
+
+ on.exit(.C("ll_free"))
+ .C("ll_init", nr, nTips, nc, as.integer(k))
+ tmp <- pml.fit(tree, data, bf, shape = shape, k = k, Q = Q, levels = attr(data, "levels"),
+ inv = inv, rate = rate, g = g, w = w, eig = eig, INV = INV, ll.0 = ll.0, llMix = llMix,
+ wMix = wMix, site = TRUE)
+
+ df <- ifelse(is.ultrametric(tree), tree$Nnode, length(tree$edge.length))
+
+ if (type == "CODON") {
+ df <- df + (k > 1) + (inv > 0) + length(unique(bf)) - 1
+ }
+ else df = df + (k > 1) + (inv > 0) +
+ length(unique(bf)) - 1 + length(unique(Q)) - 1
+ result = list(logLik = tmp$loglik, inv = inv, k = k, shape = shape, Q = Q, bf = bf,
+ rate = rate, siteLik = tmp$siteLik, weight = weight, g = g, w = w, eig = eig,
+ data = data, model = model, INV = INV, ll.0 = ll.0, tree = tree, lv = tmp$resll,
+ call = call, df = df, wMix = wMix, llMix = llMix)
+ if (type == "CODON") {
+ result$dnds <- 1
+ result$tstv <- 1
+ }
+ class(result) = "pml"
+ result
+}
+
+
+optimMixQ <- function(object, Q=c(1, 1, 1, 1, 1, 1), omega,...){
+ l = length(Q)
+ Q = Q[-l]
+ Q = sqrt(Q)
+ fn = function(Q, object, omega,...) {
+ Q = c(Q^2, 1)
+ weight <- object[[1]]$weight
+ n <- length(omega)
+ p <- length(weight)
+ result <- numeric(p)
+ for(i in 1:n)result <- result + as.numeric(update(object[[i]], Q=Q, ...)$lv) * omega[i]
+ result <- sum(weight %*% log(result))
+ result
+ }
+ res = optim(par=Q, fn=fn, gr=NULL, method="L-BFGS-B", lower=0,
+ upper=Inf, control=list(fnscale = -1, maxit=25),
+ object=object, omega=omega,...)
+ res[[1]] = c(res[[1]]^2, 1)
+ res
+}
+
+
+optimMixBf <- function(object, bf=c(.25,.25,.25,.25), omega,...){
+ l = length(bf)
+ nenner = 1/bf[l]
+ lbf = log(bf * nenner)
+ lbf = lbf[-l]
+ fn = function(lbf, object, omega,...) {
+ bf = exp(c(lbf,0))
+ bf = bf/sum(bf)
+ weight <- object[[1]]$weight
+ n <- length(omega)
+ p <- length(weight)
+ result <- numeric(p)
+ for(i in 1:n)result <- result + as.numeric(update(object[[i]], bf=bf, ...)$lv) * omega[i]
+ result <- sum(weight %*% log(result))
+ result
+ }
+ res = optim(par=lbf, fn=fn, gr=NULL, method="Nelder-Mead",
+ control=list(fnscale=-1, maxit=500), object, omega=omega,...)
+ print(res[[2]])
+ bf = exp(c(res[[1]],0))
+ bf = bf/sum(bf)
+}
+
+
+optimMixInv <- function(object, inv=0.01, omega,...){
+ fn = function(inv, object, omega,...) {
+ n <- length(omega)
+ weight <- object[[1]]$weight
+ p <- length(weight)
+ result <- numeric(p)
+ for(i in 1:n)result <- result + as.numeric(update(object, inv=inv, ...)$lv) * omega[i]
+ result <- sum(weight %*% log(result))
+ result
+ }
+ res = optimize(f=fn, interval = c(0,1), lower = 0, upper = 1, maximum = TRUE,
+ tol = .0001, object, omega=omega,...)
+ print(res[[2]])
+ res[[1]]
+}
+
+
+optimMixRate <- function (fits, ll, weight, omega, rate=rep(1,length(fits)))
+{
+ r <- length(fits)
+ rate0 <- rate[-r]
+
+ fn<-function(rate, fits, ll, weight, omega){
+ r <- length(fits)
+ rate <- c(rate, (1- sum(rate *omega[-r]))/omega[r])
+ for (i in 1:r) fits[[i]]<-update(fits[[i]], rate = rate[i])
+ for (i in 1:r) ll[, i] <- fits[[i]]$lv
+ sum(weight*log(ll%*%omega))
+ }
+ ui=diag(r-1)
+ ui <- rbind(-omega[-r], ui)
+ ci <- c(-1, rep(0, r-1))
+ res <- constrOptim(rate0, fn, grad=NULL, ui=ui, ci=ci, mu = 1e-04, control = list(fnscale=-1),
+ method = "Nelder-Mead", outer.iterations = 50, outer.eps = 1e-05, fits=fits, ll=ll, weight=weight, omega=omega)
+ rate <- res[[1]]
+ res[[1]] <- c(rate, (1- sum(rate *omega[-r]))/omega[r])
+ res
+}
+
+
+optW <- function (ll, weight, omega,...)
+{
+ k = length(omega)
+ nenner = 1/omega[1]
+ eta = log(omega * nenner)
+ eta = eta[-1]
+ fn = function(eta, ll, weight) {
+ eta = c(0,eta)
+ p = exp(eta)/sum(exp(eta))
+ res = sum(weight * log(ll %*% p))
+ res
+ }
+ if(k==2)res = optimize(f =fn , interval =c(-3,3) , lower = -3, upper = 3, maximum = TRUE, tol = .Machine$double.eps^0.25, ll = ll, weight = weight)
+ else res = optim(eta, fn = fn, method = "L-BFGS-B", lower=-5, upper=5,control = list(fnscale = -1,
+ maxit=25), gr = NULL, ll = ll, weight = weight)
+
+ p = exp(c(0,res[[1]]))
+ p = p/sum(p)
+ result = list(par = p, value = res[[2]])
+ result
+}
+
+
+optimMixEdge <- function(object, omega, trace=1,...){
+ tree <- object[[1]]$tree
+ theta <- object[[1]]$tree$edge.length
+ weight = as.numeric(attr(object[[1]]$data,"weight"))
+ n <- length(omega)
+ p <- length(weight)
+ q <- length(theta)
+ lv1 = numeric(p)
+ for(i in 1:n) lv1 = lv1 + as.numeric(object[[i]]$lv) * omega[i]
+ ll0 <- sum(weight * log(lv1))
+ eps=1
+ iter <- 0
+ scalep <- 1
+ if(trace>0) cat(ll0)
+ while(abs(eps)>.001 & iter<10){
+ dl <- matrix(0,p,q)
+ for(i in 1:n)dl <- dl + dl(object[[i]],TRUE) * omega[i]
+ dl <- dl/lv1
+ sc = colSums(weight * dl)
+ F = crossprod(dl * weight, dl)+diag(q)*1e-6
+ blub <- TRUE
+ iter2 <- 0
+ while(blub & iter2<10){
+ thetaNew = log(theta) + scalep * solve(F, sc)
+ tree$edge.length = as.numeric(exp(thetaNew))
+ for(i in 1:n)object[[i]] <- update(object[[i]],tree=tree)
+ lv1 = numeric(p)
+ for(i in 1:n) lv1 = lv1 + as.numeric(object[[i]]$lv) * omega[i]
+ ll1 <- sum(weight * log(lv1))
+ eps <- ll1 - ll0
+ if (eps < 0 || is.nan(eps)) {
+ scalep = scalep/2
+ eps = 1
+ thetaNew = log(theta)
+ ll1 = ll0
+ iter2 <- iter2+1
+ }
+ else{
+ scalep = 1;
+ theta = exp(thetaNew)
+ blub=FALSE
+ }
+ }
+ iter <- iter+1
+ ll0 <- ll1
+ }
+ tree$edge.length <- theta
+ for(i in 1:n)object[[i]] <- update(object[[i]],tree=tree)
+ if(trace>0) cat("->", ll1, "\n")
+ object
+}
+
+
+pmlMix <- function (formula, fit, m = 2, omega = rep(1/m, m), control=pml.control(epsilon=1e-8, maxit=20, trace=1), ...)
+{
+ call <- match.call()
+ form <- phangornParseFormula(formula)
+ opt <- c("nni", "bf", "Q", "inv", "shape", "edge", "rate")
+ optAll <- match(opt, form$left)
+ optPart <- match(opt, form$right)
+ AllBf <- !is.na(optAll[2])
+ AllQ <- !is.na(optAll[3])
+ AllInv <- !is.na(optAll[4])
+ AllGamma <- !is.na(optAll[5])
+ AllEdge <- !is.na(optAll[6])
+ MixNni <- !is.na(optPart[1])
+ MixBf <- !is.na(optPart[2])
+ MixQ <- !is.na(optPart[3])
+ MixInv <- !is.na(optPart[4])
+ MixGamma <- !is.na(optPart[5])
+ MixEdge <- !is.na(optPart[6])
+ MixRate <- !is.na(optPart[7])
+ if (class(fit) == "list")
+ fits <- fit
+ else {
+ fits <- vector("list", m)
+ for (i in 1:m) fits[[i]] <- fit
+ }
+ dat <- fits[[1]]$data
+ p = attr(dat, "nr")
+ weight = attr(dat, "weight")
+ r = m
+ ll = matrix(0, p, r)
+ for (i in 1:r) ll[, i] = fits[[i]]$lv
+
+ for (i in 1:r){
+ pl0 <- ll[, -i, drop = FALSE] %*% omega[-i]
+ fits[[i]] <- update(fits[[i]], llMix = pl0, wMix = omega[i])
+ }
+
+ if(MixRate) rate <- rep(1,r)
+
+ llstart = sum(weight * log(ll %*% omega))
+ llold <- llstart
+ ll0 <- llstart
+ ll3 <- llstart
+ eps0 <- 1
+ iter0 <- 0
+ trace = control$trace
+ while (eps0 > control$eps & iter0 < control$maxit) { #while (eps0 > 1e-6 & iter0 < 20) {
+ eps1 <- 100
+ iter1 <- 0
+
+ if (AllQ) {
+ newQ <- optimMixQ(fits, Q = fits[[1]]$Q,
+ omega = omega)[[1]]
+ for (i in 1:m) fits[[i]] <- update(fits[[i]], Q = newQ)
+ }
+ if (AllBf) {
+ newBf <- optimMixBf(fits, bf = fits[[1]]$bf,
+ omega = omega)
+ for (i in 1:m) fits[[i]] <- update(fits[[i]], bf = newBf)
+ }
+ if (AllInv) {
+ newInv <- optimMixInv(fits, inv = fits[[1]]$inv,
+ omega = omega)
+ for (i in 1:m) fits[[i]] <- update(fits[[i]], Inv = newInv)
+ }
+ if (AllEdge)
+ fits <- optimMixEdge(fits, omega, trace=trace-1)
+ for (i in 1:r) ll[, i] <- fits[[i]]$lv
+
+ while ( abs(eps1) > 0.001 & iter1 < 3) {
+ if(MixRate){
+ rate <- optimMixRate(fits, ll, weight, omega, rate)[[1]]
+ for (i in 1:r) fits[[i]] <- update(fits[[i]], rate=rate[i])
+ for (i in 1:r) ll[, i] <- fits[[i]]$lv
+ }
+ for (i in 1:r){
+ pl0 <- ll[, -i, drop = FALSE] %*% omega[-i]
+ fits[[i]] <- update(fits[[i]], llMix = pl0, wMix = omega[i])
+ }
+
+ for (i in 1:r) {
+ pl0 <- ll[, -i, drop = FALSE] %*% omega[-i]
+ fits[[i]] <- optim.pml(fits[[i]], MixNni, MixBf, MixQ, MixInv, MixGamma,
+ MixEdge, optRate=FALSE, control = pml.control(epsilon = 1e-8, maxit = 3,
+ trace-1), llMix = pl0, wMix = omega[i])
+ ll[, i] <- fits[[i]]$lv
+
+ res = optW(ll, weight, omega)
+ omega = res$p
+
+ if(MixRate){
+ blub <- sum(rate*omega)
+ rate <- rate / blub
+ tree <- fits[[1]]$tree
+ tree$edge.length <- tree$edge.length*blub
+ for (i in 1:r) fits[[i]]<-update(fits[[i]], tree=tree, rate = rate[i])
+ for (i in 1:r) ll[, i] <- fits[[i]]$lv
+ }
+ for (i in 1:r){
+ pl0 <- ll[, -i, drop = FALSE] %*% omega[-i]
+ fits[[i]] <- update(fits[[i]], llMix = pl0, wMix = omega[i])
+ }
+
+ }
+ ll1 = sum(weight * log(ll %*% omega))
+ res = optW(ll, weight, omega)
+ omega = res$p
+ if(MixRate){
+ blub <- sum(rate*omega)
+ rate <- rate / blub
+ tree <- fits[[1]]$tree
+ tree$edge.length <- tree$edge.length*blub
+ for (i in 1:r) fits[[i]]<-update(fits[[i]], tree=tree, rate = rate[i])
+ if(trace>0) print(rate)
+ for (i in 1:r) ll[, i] <- fits[[i]]$lv
+ }
+ for (i in 1:r){
+ pl0 <- ll[, -i, drop = FALSE] %*% omega[-i]
+ fits[[i]] <- update(fits[[i]], llMix = pl0, wMix = omega[i])
+ }
+
+ ll2 = sum(weight * log(ll %*% omega))
+ eps1 = llold - ll2
+ iter1 <- iter1 + 1
+ llold = ll2
+ }
+
+ ll1 <- sum(weight * log(ll %*% omega))
+ eps0 <- (ll3 - ll1) / ll1
+ ll3 <- ll1
+ iter0 <- iter0 + 1
+ if(trace>0) print(iter0)
+ }
+ parameter <- c(AllBf=AllBf, AllQ=AllQ, AllInv=AllInv, AllGamma=AllGamma, AllEdge=AllEdge, MixNni=MixNni,
+ MixBf=MixBf, MixQ=MixQ, MixInv=MixInv, MixGamma=MixGamma, MixEdge=MixEdge, MixRate=MixRate)
+
+ df <- matrix(1, 6 ,2)
+ colnames(df) <- c("#df", "group")
+ rownames(df) <- c("Edge", "Shape", "Inv", "Bf", "Q", "Rate")
+ df[1,1] <- length(fits[[1]]$tree$edge.length)
+# df[2,1] <- fits[[1]]$k - 1
+ df[2,1] <- fits[[1]]$k > 1
+ df[3,1] <- fits[[1]]$inv > 0
+ df[4,1] <- length(unique(fits[[1]]$bf)) - 1
+ df[5,1] <- length(unique(fits[[1]]$Q)) - 1
+ df[6,1] <- 0
+ if(MixEdge) df[1,2] = r
+ if(MixGamma) df[2,2] = r
+ if(MixInv) df[3,2] = r
+ if(MixBf) df[4,2] = r
+ if(MixQ) df[5,2] = r
+ if(MixRate) df[6,1] = r-1
+ attr(logLik, "df") = sum(df[,1]*df[,2])
+ converge <- c(iter=iter0, eps=eps0)
+ result <- list(logLik = ll1, omega = omega, fits = fits, call = call, converge=converge, parameter=parameter, df=df)
+ class(result) <- "pmlMix"
+ result
+}
+
+
+print.pmlMix <- function(x,...){
+ nc <- attr(x$fits[[1]]$data, "nc")
+ nr <- attr(x$fits[[1]]$data, "nr")
+ levels <- attr(x$fits[[1]]$data, "levels")
+ r <- length(x$fits)
+ w <- x$fits[[1]]$weight
+ w <- w[w>0]
+ type <- attr(x$fits[[1]]$data, "type")
+ nc <- attr(x$fits[[1]]$data, "nc")
+ ll0 = sum(w*log(w/sum(w)))
+
+
+ bf <- matrix(0,r,nc)
+ dimnames(bf) <- list(1:r, levels)
+ Q <- matrix(0, r, nc*(nc-1)/2)
+ dimnames(Q) <- list(1:r, NULL)
+
+ rate <- numeric(r)
+ inv <- x$fits[[1]]$inv
+ shape <- numeric(r)
+
+ for(i in 1:r){
+ bf[i, ] <- x$fits[[i]]$bf
+ Q[i, ] <- x$fits[[i]]$Q
+ rate[i] <- x$fits[[i]]$rate
+ shape[i] <- x$fits[[i]]$shape
+ }
+ cat("\nloglikelihood:", x$logLik, "\n")
+ cat("\nunconstrained loglikelihood:", ll0, "\n")
+ cat("AIC: ", AIC(x), " BIC: ", AIC(x, k=log(nr)), "\n\n")
+ cat("\nposterior:", x$omega ,"\n")
+ if(inv > 0)cat("Proportion of invariant sites:",inv,"\n")
+ cat("\nRates:\n")
+ cat(rate,"\n")
+ cat("\nBase frequencies: \n")
+ print(bf)
+ cat("\nRate matrix:\n")
+ print(Q)
+}
+
+
+logLik.pmlMix <- function (object, ...)
+{
+ res <- object$logLik
+ attr(res, "df") <- sum(object$df[,1] * object$df[,2])
+ class(res) <- "logLik"
+ res
+}
+
+
+print.pmlPart <- function(x,...){
+ df <- x$df
+ nc <- attr(x$fits[[1]]$data, "nc")
+ levels <- attr(x$fits[[1]]$data, "levels")
+ r <- length(x$fits)
+ nc <- attr(x$fits[[1]]$data, "nc")
+ nr <- attr(x$fits[[1]]$data, "nr")
+ k <- x$fits[[1]]$k
+
+ lbf=x$df["Bf",2]
+ bf <- matrix(0, lbf, nc)
+ if(lbf>1)dimnames(bf) <- list(1:r, levels)
+ lQ = x$df["Q",2]
+ Q <- matrix(0, lQ, nc*(nc-1)/2)
+ if(lQ>1)dimnames(Q) <- list(1:r, NULL)
+ type <- attr(x$fits[[1]]$data, "type")
+
+ loli <- numeric(r)
+ rate <- numeric(r)
+ shape <- numeric(r)
+ sizes <- numeric(r)
+ inv <- numeric(r)
+ for(i in 1:r){
+ loli[i] <- x$fits[[i]]$logLik
+ if(i <= lbf)bf[i, ] <- x$fits[[i]]$bf
+ if(i <= lQ)Q[i, ] <- x$fits[[i]]$Q
+ rate[i] <- x$fits[[i]]$rate
+ shape[i] <- x$fits[[i]]$shape
+ inv[i] <- x$fits[[i]]$inv
+ sizes[i] <- sum(attr(x$fits[[i]]$data,"weight"))
+ }
+ cat("\nloglikelihood:", x$logLik, "\n")
+ cat("\nloglikelihood of partitions:\n ", loli, "\n")
+ cat("AIC: ", AIC(x), " BIC: ", AIC(x, k=log(sum(sizes))), "\n\n")
+ cat("Proportion of invariant sites:",inv,"\n")
+ cat("\nRates:\n")
+ cat(rate,"\n")
+ if(k>1){
+ cat("\nShape parameter:\n")
+ cat(shape,"\n")
+ }
+ if(type=="AA") cat("Rate matrix:",x$fits[[1]]$model, "\n")
+ else{
+ cat("\nBase frequencies: \n")
+ print(bf)
+ cat("\nRate matrix:\n")
+ print(Q)
+ }
+}
+
+
+logLik.pmlPart <- function (object, ...)
+{
+ res <- object$logLik
+ attr(res, "df") <- sum(object$df[,1] * object$df[,2])
+ class(res) <- "logLik"
+ res
+}
+
+
+pmlPen <- function(object, lambda, ...){
+ if(class(object)=="pmlPart") return(pmlPartPen(object, lambda,...))
+ if(class(object)=="pmlMix") return(pmlMixPen(object, lambda,...))
+ else stop("object has to be of class pmlPart or pmlMix")
+ }
+
+
+pmlPartPen <- function(object, lambda, control=pml.control(epsilon=1e-8, maxit=20, trace=1),...){
+ fits <- object$fits
+
+ m <- length(fits)
+ K = -diag(length(fits[[1]]$tree$edge.length))
+ Ktmp=K
+ for(i in 1:(m-1))Ktmp = cbind(Ktmp,K)
+ KM = Ktmp
+ for(i in 1:(m-1))KM = rbind(KM,Ktmp)
+ diag(KM) = m-1
+ theta=NULL
+ l = length(fits[[1]]$tree$edge.length)
+ loglik = 0
+ for(i in 1:m){
+ theta = c(theta,fits[[i]]$tree$edge.length)
+ loglik = loglik + fits[[i]]$logLik
+ }
+ print(loglik)
+ pen = - 0.5 * lambda * t(theta)%*%KM%*%theta
+ loglik = loglik - 0.5 * lambda * t(theta)%*%KM%*%theta
+ eps=1
+ H = matrix(0, m * l, m * l)
+ iter=0
+ trace = control$trace
+ while( abs(eps)>control$eps & iter<control$maxit){
+ theta=NULL
+ sc = NULL
+ for(i in 1:m){
+ theta = c(theta,fits[[i]]$tree$edge.length)
+ scoretmp = score(fits[[i]], TRUE)
+ sc = c(sc,scoretmp$sc)
+ H[(1:l)+l*(i-1), (1:l)+l*(i-1)] = scoretmp$F
+ }
+ sc = sc - lambda * KM%*% log(theta)
+ thetanew = log(theta) + solve(H + lambda*KM, sc)
+ for(i in 1:m) fits[[i]]$tree$edge.length = exp(thetanew[(1:l)+(i-1)*l])
+ for(i in 1:m) fits[[i]] = update.pml(fits[[i]], tree=fits[[i]]$tree)
+ loglik1 = 0
+ for(i in 1:m) loglik1 = loglik1 + fits[[i]]$logLik
+ logLik <- loglik1
+ if(trace>0)print(loglik1)
+ loglik0 = loglik1
+ pen = - 0.5 * lambda * t(theta)%*%KM%*%theta
+ loglik1 = loglik1 - 0.5 * lambda * t(thetanew)%*%KM%*%thetanew
+ eps = (loglik - loglik1) / loglik1
+ loglik = loglik1
+ theta = exp(thetanew)
+ iter = iter+1
+ if(trace>0)print(iter)
+ }
+ df = sum( diag(solve(H + lambda* KM, H)))
+
+ object$df[1,1] = df
+ object$df[1,2] = 1
+ object$fits = fits
+ object$logLik = loglik0
+ attr(object$logLik, "df") = sum(object$df[,1]*object$df[,2])
+ object$logLik.pen = loglik
+ attr(object$logLik.pen, "df") = sum(object$df[,1]*object$df[,2])
+ object
+}
+
+
+pmlMixPen = function (object, lambda, optOmega=TRUE, control=pml.control(epsilon=1e-8, maxit=20, trace=1), ...)
+{
+ fits <- object$fits
+ m <- length(fits)
+ K = -diag(length(fits[[1]]$tree$edge.length))
+ tree <- fits[[1]]$tree
+ Ktmp = K
+ for (i in 1:(m - 1)) Ktmp = cbind(Ktmp, K)
+ KM = Ktmp
+ for (i in 1:(m - 1)) KM = rbind(KM, Ktmp)
+ diag(KM) = m - 1
+ theta = NULL
+ l = length(fits[[1]]$tree$edge.length)
+ omega <- object$omega
+ dat <- fits[[1]]$data
+ nr = attr(dat, "nr")
+ weight = drop(attr(dat, "weight"))
+ ll = matrix(0, nr, m)
+ for (i in 1:m) ll[, i] = fits[[i]]$lv
+ lv = drop(ll %*% omega)
+ loglik = sum(weight * log(lv))
+ for (i in 1:m) theta = c(theta, fits[[i]]$tree$edge.length)
+ pen = - 0.5 * lambda * t(theta) %*% KM %*% theta
+ loglik = loglik + pen
+ print(loglik)
+ eps0 = 1
+ dl <- matrix(0, nr, m * l)
+ iter0 = 0
+ trace = control$trace
+ while (abs(eps0) > control$eps & iter0 < control$maxit) {
+ eps = 1
+ iter = 0
+ while (abs(eps) > 0.01 & iter < 5) {
+ for (i in 1:m) {
+ dl[, (1:l) + l * (i - 1)] <- dl(fits[[i]], TRUE) *
+ omega[i]
+ }
+ dl <- dl/lv
+ sc = colSums(weight * dl) - lambda * KM %*% log(theta)
+ H = crossprod(dl * weight, dl)
+ thetanew = log(theta) + solve(H + lambda * KM, sc)
+ for (i in 1:m) fits[[i]]$tree$edge.length = exp(thetanew[(1:l) +
+ (i - 1) * l])
+ for (i in 1:m) {
+ tree$edge.length = exp(thetanew[(1:l) + (i - 1) * l])
+ fits[[i]] = update.pml(fits[[i]], tree = tree)
+ ll[, i] = fits[[i]]$lv
+ }
+ lv = drop(ll %*% omega)
+ loglik1 = sum(weight * log(lv))
+ pen = - 0.5 * lambda * t(thetanew) %*% KM %*% thetanew
+ loglik1 = loglik1 + pen
+ eps = abs(loglik1 - loglik)
+ theta = exp(thetanew)
+ loglik <- loglik1
+ iter = iter + 1
+ }
+ if(optOmega){
+ res = optWPen(ll, weight, omega, pen)
+ omega = res$p
+ for (i in 1:m) {
+ pl0 <- ll[, -i, drop = FALSE] %*% omega[-i]
+ fits[[i]] <- update(fits[[i]], llMix = pl0, wMix = omega[i])
+ }
+ }
+ lv = drop(ll %*% omega)
+ loglik1 = sum(weight * log(lv))
+ loglik0 =loglik1
+ loglik1 = loglik1 - 0.5 * lambda * t(thetanew) %*% KM %*% thetanew
+ eps0 = (loglik - loglik1) / loglik1
+ theta = exp(thetanew)
+ loglik <- loglik1
+ iter0 = iter0 + 1
+ if(trace>0) print(loglik)
+ }
+
+ for (i in 1:m) {
+ pl0 <- ll[, -i, drop = FALSE] %*% omega[-i]
+ fits[[i]] <- update(fits[[i]], llMix = pl0, wMix = omega[i])
+ }
+ df = sum(diag(solve(H + lambda * KM, H)))
+ penalty <- list(lambda=lambda, K=KM, thetanew=thetanew, ploglik=loglik)
+ object$omega = omega
+ object$df[1, 1] = df
+ object$df[1, 2] = 1
+ object$fits = fits
+ object$logLik = loglik0
+ object$penalty = penalty
+ object
+}
+
+
+optWPen = function (ll, weight, omega, pen, ...)
+{
+ k = length(omega)
+ nenner = 1/omega[1]
+ eta = log(omega * nenner)
+ eta = eta[-1]
+ fn = function(eta, ll, weight, pen) {
+ eta = c(0, eta)
+ p = exp(eta)/sum(exp(eta))
+ res = sum(weight * log(ll %*% p)) + pen
+ res
+ }
+ if (k == 2)
+ res = optimize(f = fn, interval = c(-3, 3), lower = -3,
+ upper = 3, maximum = TRUE, tol = .Machine$double.eps^0.25,
+ ll = ll, weight = weight, pen = pen)
+ else res = optim(eta, fn = fn, method = "L-BFGS-B", lower = -5,
+ upper = 5, control = list(fnscale = -1, maxit = 25),
+ gr = NULL, ll = ll, weight = weight, pen=pen)
+ p = exp(c(0, res[[1]]))
+ p = p/sum(p)
+ result = list(par = p, value = res[[2]])
+ result
+}
+
+
+optNNI <- function(fit, INDEX){
+ tree = fit$tree
+ ll.0 <- fit$ll.0
+ loli <- fit$logLik
+ bf = fit$bf
+ eig = fit$eig
+ k = fit$k
+ w = fit$w
+ g = fit$g
+ rootEdges <- attr(INDEX, "root")
+ .dat <- NULL
+ parent = tree$edge[, 1]
+ child = tree$edge[, 2]
+
+ data = getCols(fit$data, tree$tip)
+ datp <- rnodes(tree, data, w, g, eig, bf)
+# nicht elegant, spaeter auch raus
+ tmp = length(tree$tip.label)
+ for(i in 1:length(w)).dat[i,1:tmp]=new2old.phyDat(data)
+# datp = rnodes(fit) # raus
+
+ evector <- numeric(max(parent))
+ evector[child] <- tree$edge.length
+ m <- dim(INDEX)[1]
+ k = min(parent)
+ loglik = numeric(2 * m)
+ edgeMatrix <- matrix(0, 2 * m, 5)
+ for (i in 1:m) {
+ ei = INDEX[i, ]
+ el0 = evector[INDEX[i, ]]
+ l = length(datp[, 1])
+ weight = fit$weight
+ datn = vector("list", 4 * l)
+ attr(datn, "dim") = c(l, 4)
+ datn <- .dat[, ei[1:4], drop = FALSE]
+ if (!(ei[5] %in% rootEdges))
+ datn[, 1] = datp[, ei[1], drop = FALSE]
+ new1 <- optim.quartet(el0[c(1, 3, 2, 4, 5)],
+ eig, bf, datn[, c(1, 3, 2, 4), drop = FALSE], g,
+ w, weight, ll.0, llcomp = fit$log)
+ new2 <- optim.quartet(el0[c(1, 4, 3, 2, 5)],
+ eig, bf, datn[, c(1, 4, 3, 2), drop = FALSE], g,
+ w, weight, ll.0, llcomp = fit$log)
+ loglik[(2 * i) - 1] = new1[[2]]
+ loglik[(2 * i)] = new2[[2]]
+ edgeMatrix[(2 * i) - 1, ] = new1[[1]]
+ edgeMatrix[(2 * i), ] = new2[[1]]
+ }
+ list(loglik=loglik, edges = edgeMatrix)
+ }
+
+
+optimPartNNI <- function (object, AllEdge=TRUE,...)
+{
+ tree <- object[[1]]$tree
+ INDEX <- indexNNI(tree)
+ l = length(object)
+ loglik0 = 0
+ for(i in 1:l)loglik0 = loglik0 + logLik(object[[i]])
+
+ l = length(object)
+ TMP=vector("list", l)
+ for(i in 1:l){
+ TMP[[i]] = optNNI(object[[i]], INDEX)
+ }
+ loglik=TMP[[1]][[1]]
+ for(i in 2:l)loglik=loglik+TMP[[i]][[1]]
+
+ swap <- 0
+ candidates <- loglik > loglik0
+
+ while (any(candidates)) {
+ ind = which.max(loglik)
+ loglik[ind] = -Inf
+ if (ind%%2)
+ swap.edge = c(2, 3)
+ else swap.edge = c(2, 4)
+ tree2 <- changeEdge(tree, INDEX[(ind + 1)%/%2, swap.edge],
+ INDEX[(ind + 1)%/%2, ], TMP[[1]][[2]][ind, ])
+ tmpll = 0
+ for(i in 1:l){
+ if(!AllEdge)tree2 <- changeEdge(object[[i]]$tree, INDEX[(ind + 1)%/%2, swap.edge],
+ INDEX[(ind + 1)%/%2, ], TMP[[i]][[2]][ind, ])
+ tmpll <- tmpll + update(object[[i]], tree = tree2)$logLik
+ }
+
+ if (tmpll < loglik0)
+ candidates[ind] = FALSE
+ if (tmpll > loglik0) {
+
+ swap = swap + 1
+ tree <- tree2
+ indi <- which(rep(colSums(apply(INDEX, 1, match,
+ INDEX[(ind + 1)%/%2, ], nomatch = 0)) > 0, each = 2))
+ candidates[indi] <- FALSE
+ loglik[indi] <- -Inf
+
+ for(i in 1:l){
+ if(!AllEdge)tree2 <- changeEdge(object[[i]]$tree, INDEX[(ind + 1)%/%2, swap.edge],
+ INDEX[(ind + 1)%/%2, ], TMP[[i]][[2]][ind, ])
+ object[[i]] <- update(object[[i]], tree = tree2)
+ }
+ loglik0 = 0
+ for(i in 1:l)loglik0 = loglik0 + logLik(object[[i]])
+ cat(loglik0, "\n")
+ }
+ }
+ if(AllEdge)object <- optimPartEdge(object)
+ attr(object,"swap") = swap
+ object
+}
+
+
+
+SH.test <- function (..., B = 10000, data = NULL)
+{
+ fits <- list(...)
+ p = 1
+ if (inherits(fits[[1]],"pmlPart"))
+# class(fits[[1]]) == "pmlPart")
+ {
+ fits = fits[[1]]$fits
+ p = length(fits)
+ }
+ k = length(fits)
+ if (is.null(data))
+ data = fits[[1]]$data
+ res = NULL
+ for (h in 1:p) {
+ if (p > 1)
+ data = fits[[h]]$data
+ weight = attr(data, "weight")
+ lw = length(weight)
+ siteLik = matrix(0, lw, k)
+ for (i in 1:k) siteLik[, i] = update(fits[[i]], data = data)$site
+ ntree = k
+ Lalpha <- drop(crossprod(siteLik, weight))
+ Talpha <- max(Lalpha) - Lalpha
+ M <- matrix(NA, k, B)
+# S <- matrix(NA, k, B)
+ wvec <- rep(1L:lw, weight)
+ size = length(wvec)
+ for (i in 1:B) {
+ boot = tabulate(sample(wvec, replace=TRUE), nbins=lw)
+ M[, i] <- crossprod(siteLik, boot)
+ }
+ M <- M - rowMeans(M)
+# for (i in 1:B) for (j in 1:ntree) S[j, i] <- max(M[j, i] - M[, i])
+ S = matrix(apply(M,2,min), k, B, byrow=TRUE)
+ S = M - S
+ count <- numeric(ntree)
+ for (j in 1:ntree) count[j] <- sum(S[j, ] > Talpha[j])
+ count <- count/B
+ trees <- 1:k
+ if (p == 1)
+ res = cbind(trees, Lalpha, Talpha, count)
+ else res = rbind(res, cbind(h, trees[-h], Lalpha[-h],
+ Talpha[-h], count[-h]))
+ }
+ if (p == 1)
+ colnames(res) <- c("Trees", "ln L", "Diff ln L", "p-value")
+ else colnames(res) <- c("Partition", "Trees", "ln L", "Diff ln L",
+ "p-value")
+ res
+}
+
+
+#
+# Bootstrap functions
+# multicore support
+#
+bootstrap.pml = function (x, bs = 100, trees = TRUE, multicore=FALSE, ...)
+{
+ data = x$data
+ weight = attr(data, "weight")
+ v = rep(1:length(weight), weight)
+ BS = vector("list", bs)
+ for (i in 1:bs) BS[[i]] = tabulate(sample(v, replace = TRUE),
+ length(weight))
+ pmlPar <- function(weights, fit, trees = TRUE, ...) {
+ data = fit$data
+ ind <- which(weights > 0)
+ data <- getRows(data, ind)
+ attr(data, "weight") <- weights[ind]
+ fit = update(fit, data = data)
+ fit = optim.pml(fit, ...)
+ if (trees) {
+ tree = fit$tree
+ return(tree)
+ }
+ attr(fit, "data") = NULL
+ fit
+ }
+ eval.success <- FALSE
+ if (!eval.success & multicore) {
+# !require(parallel) ||
+ if (.Platform$GUI!="X11") {
+ warning("package 'parallel' not found or GUI is used,
+ bootstrapping is performed in serial")
+ } else {
+ res <- mclapply(BS, pmlPar, x, trees = trees, ...)
+ eval.success <- TRUE
+ }
+ }
+ if (!eval.success) res <- lapply(BS, pmlPar, x, trees = trees, ...)
+ if (trees) {
+ class(res) = "multiPhylo"
+ res = .compressTipLabel(res) # save memory
+ }
+ res
+}
+
+
+bootstrap.phyDat <- function (x, FUN, bs = 100, mc.cores=1L, ...)
+{
+ weight = attr(x, "weight")
+ v = rep(1:length(weight), weight)
+ BS = vector("list", bs)
+ for(i in 1:bs)BS[[i]]=tabulate(sample(v, replace=TRUE),length(weight))
+ fitPar <- function(weights, data, ...){
+ ind <- which(weights > 0)
+ data <- getRows(data, ind)
+ attr(data, "weight") <- weights[ind]
+ FUN(data,...)
+ }
+ res <- mclapply(BS, fitPar, x, ..., mc.cores = mc.cores)
+ if(class(res[[1]]) == "phylo"){
+ class(res) <- "multiPhylo"
+ res = .compressTipLabel(res) # save memory
+ }
+ res
+}
+
+
+matchEdges = function(tree1, tree2){
+ bp1 = bip(tree1)
+ bp2 = bip(tree2)
+ l = length(tree1$tip)
+ fn = function(x, y){
+ if(x[1]==1)return(x)
+ else return(y[-x])
+ }
+ bp1[] = lapply(bp1, fn, 1:l)
+ bp2[] = lapply(bp2, fn, 1:l)
+ match(bp1, bp2)
+}
+
+
+checkLabels <- function(tree, tip){
+ ind <- match(tip, tree$tip.label)
+ tree$tip.label <- tree$tip.label[ind]
+ ind2 <- match(1:length(ind), tree$edge[, 2])
+ tree$edge[ind2, 2] <- order(ind)
+ tree
+}
+
+
+plotBS <- function (tree, BStrees, type = "unrooted", bs.col = "black",
+ bs.adj = NULL, ...)
+{
+ # prop.clades raus??
+ prop.clades <- function(phy, ..., part = NULL, rooted = FALSE) {
+ if (is.null(part)) {
+ obj <- list(...)
+ if (length(obj) == 1 && class(obj[[1]]) != "phylo")
+ obj <- unlist(obj, recursive = FALSE)
+ if (!identical(phy$tip, obj[[1]]$tip))
+ obj[[1]] = checkLabels(obj[[1]], phy$tip)
+ part <- prop.part(obj, check.labels = TRUE)
+ }
+ bp <- prop.part(phy)
+ if (!rooted) {
+ bp <- postprocess.prop.part(bp)
+ part <- postprocess.prop.part(part)
+ }
+ n <- numeric(phy$Nnode)
+ for (i in seq_along(bp)) {
+ for (j in seq_along(part)) {
+ if (identical(bp[[i]], part[[j]])) {
+ n[i] <- attr(part, "number")[j]
+ done <- TRUE
+ break
+ }
+ }
+ }
+ n
+ }
+ type <- match.arg(type, c("phylogram", "cladogram", "fan",
+ "unrooted", "radial"))
+ if (type == "phylogram" | type == "cladogram") {
+ if (!is.rooted(tree))
+ tree2 = midpoint(tree)
+ else tree2=tree
+ plot(tree2, type = type, ...)
+ }
+ else plot(tree, type = type, ...)
+ BStrees <- .uncompressTipLabel(BStrees)
+ x = prop.clades(tree, BStrees)
+ x = round((x/length(BStrees)) * 100)
+ tree$node.label = x
+ label = c(rep("", length(tree$tip)), x)
+ ind <- get("last_plot.phylo", envir = .PlotPhyloEnv)$edge[,
+ 2]
+ if (type == "phylogram" | type == "cladogram") {
+ root = getRoot(tree)
+ label = c(rep(0, length(tree$tip)), x)
+ label[root] = 0
+ ind2 = matchEdges(tree2, tree)
+ label = label[ind2]
+ ind = which(label > 0)
+ if (is.null(bs.adj))
+ bs.adj = c(1, 1)
+ nodelabels(text = label[ind], node = ind, frame = "none",
+ col = bs.col, adj = bs.adj, ...)
+ }
+ else {
+ if (is.null(bs.adj))
+ bs.adj = c(0.5, 0.5)
+ edgelabels(label[ind], frame = "none", col = bs.col,
+ adj = bs.adj, ...)
+ }
+ invisible(tree)
+}
+
+
+pml.fit2 <- function (tree, data, bf = rep(1/length(levels), length(levels)),
+ shape = 1, k = 1, Q = rep(1, length(levels) * (length(levels) - 1)/2),
+ levels = attr(data, "levels"), inv = 0, rate = 1, g = NULL, w = NULL,
+ eig = NULL, INV = NULL, ll.0 = NULL, llMix = NULL, wMix = 0, ..., site=FALSE)
+{
+ weight <- as.double(attr(data, "weight"))
+ nr <- as.integer(attr(data, "nr"))
+ nc <- as.integer(attr(data, "nc"))
+ nTips <- as.integer(length(tree$tip.label))
+ k <- as.integer(k)
+ m = 1
+ if (is.null(eig))
+ eig = edQt(bf = bf, Q = Q)
+ if (is.null(w)) {
+ w = rep(1/k, k)
+ if (inv > 0)
+ w <- (1 - inv) * w
+ if (wMix > 0)
+ w <- (1 - wMix) * w
+ }
+ if (is.null(g)) {
+ g = discrete.gamma(shape, k)
+ if (inv > 0)
+ g <- g/(1 - inv)
+ g <- g * rate
+ }
+# inv0 <- inv
+ if(any(g<.gEps)){
+ for(i in 1:length(g)){
+ if(g[i]<.gEps){
+ inv <- inv+w[i]
+ }
+ }
+ w <- w[g>.gEps]
+ g <- g[g>.gEps]
+# kmax <- k
+ k <- length(w)
+ }
+ if (is.null(INV))
+ INV <- Matrix(lli(data, tree), sparse=TRUE)
+ if (is.null(ll.0)){
+ ll.0 <- numeric(attr(data,"nr"))
+ }
+ if(inv>0)
+ ll.0 <- as.matrix(INV %*% (bf * inv))
+ if (wMix > 0)
+ ll.0 <- ll.0 + llMix
+
+ node <- tree$edge[, 1]
+ edge <- tree$edge[, 2]
+ root <- as.integer(node[length(node)])
+ el <- as.double(tree$edge.length)
+ node = as.integer(node - nTips - 1L) # min(node))
+ edge = as.integer(edge - 1L)
+
+ contrast = attr(data, "contrast")
+ nco = as.integer(dim(contrast)[1])
+# dlist=data, nr, nc, weight, k ausserhalb definieren
+# pmlPart einbeziehen
+ resll <- .Call("PML3", dlist=data, el, as.double(w), as.double(g), nr, nc, k, eig, as.double(bf), node, edge, nTips, root, nco, contrast, N=as.integer(length(edge)))
+
+ # sort(INV at i)+1L
+ ind = which(ll.0>0) # automatic in INV gespeichert
+
+ sca = .Call("rowMax", resll, length(weight), as.integer(k)) + 1 # nr statt length(weight)
+ lll = resll - sca
+ lll <- exp(lll)
+ lll <- (lll%*%w)
+ lll[ind] = lll[ind] + exp(log(ll.0[ind])-sca[ind])
+ siteLik <- lll
+ siteLik <- log(siteLik) + sca
+ # needs to change
+ if(wMix >0) siteLik <- log(exp(siteLik) * (1-wMix) + llMix )
+ loglik <- sum(weight * siteLik)
+ if(!site) return(loglik)
+ resll = exp(resll)
+ return(list(loglik=loglik, siteLik=siteLik, resll=resll))
+}
+
+
+pml.fit <- function (tree, data, bf = rep(1/length(levels), length(levels)),
+ shape = 1, k = 1, Q = rep(1, length(levels) * (length(levels) - 1)/2),
+ levels = attr(data, "levels"), inv = 0, rate = 1, g = NULL, w = NULL,
+ eig = NULL, INV = NULL, ll.0 = NULL, llMix = NULL, wMix = 0, ..., site=FALSE)
+{
+ weight <- as.double(attr(data, "weight"))
+ nr <- as.integer(attr(data, "nr"))
+ nc <- as.integer(attr(data, "nc"))
+ nTips <- as.integer(length(tree$tip.label))
+ k <- as.integer(k)
+ m = 1
+ if (is.null(eig))
+ eig = edQt(bf = bf, Q = Q)
+ if (is.null(w)) {
+ w = rep(1/k, k)
+ if (inv > 0)
+ w <- (1 - inv) * w
+ if (wMix > 0)
+ w <- (1 - wMix) * w
+ }
+ if (is.null(g)) {
+ g = discrete.gamma(shape, k)
+ if (inv > 0)
+ g <- g/(1 - inv)
+ g <- g * rate
+ }
+ # inv0 <- inv
+ if(any(g<.gEps)){
+ for(i in 1:length(g)){
+ if(g[i]<.gEps){
+ inv <- inv+w[i]
+ }
+ }
+ w <- w[g>.gEps]
+ g <- g[g>.gEps]
+ # kmax <- k
+ k <- length(w)
+ }
+ if (is.null(INV))
+ INV <- Matrix(lli(data, tree), sparse=TRUE)
+ if (is.null(ll.0)){
+ ll.0 <- numeric(attr(data,"nr"))
+ }
+ if(inv>0)
+ ll.0 <- as.matrix(INV %*% (bf * inv))
+ if (wMix > 0)
+ ll.0 <- ll.0 + llMix
+
+ node <- tree$edge[, 1]
+ edge <- tree$edge[, 2]
+ root <- as.integer(node[length(node)])
+ el <- as.double(tree$edge.length)
+ node = as.integer(node - nTips - 1L) # min(node))
+ edge = as.integer(edge - 1L)
+
+ contrast = attr(data, "contrast")
+ nco = as.integer(dim(contrast)[1])
+ # dlist=data, nr, nc, weight, k ausserhalb definieren
+ # pmlPart einbeziehen
+ resll <- .Call("PML0", dlist=data, el, as.double(w), as.double(g), nr, nc, k, eig, as.double(bf), node, edge, nTips, root, nco, contrast, N=as.integer(length(edge)))
+
+ # sort(INV at i)+1L
+ ind = which(ll.0>0) # automatic in INV gespeichert
+
+ sca = .Call("rowMax", resll, length(weight), as.integer(k)) + 1 # nr statt length(weight)
+ lll = resll - sca
+ lll <- exp(lll)
+ lll <- (lll%*%w)
+ lll[ind] = lll[ind] + exp(log(ll.0[ind])-sca[ind])
+ siteLik <- lll
+ siteLik <- log(siteLik) + sca
+ # needs to change
+ if(wMix >0) siteLik <- log(exp(siteLik) * (1-wMix) + llMix )
+ loglik <- sum(weight * siteLik)
+ if(!site) return(loglik)
+ resll = exp(resll)
+ return(list(loglik=loglik, siteLik=siteLik, resll=resll))
+}
+
+
+pml <- function (tree, data, bf = NULL, Q = NULL, inv = 0, k = 1, shape = 1,
+ rate = 1, model=NULL, ...)
+{
+ call <- match.call()
+ extras <- match.call(expand.dots = FALSE)$...
+ pmla <- c("wMix", "llMix")
+ existing <- match(pmla, names(extras))
+ wMix <- ifelse(is.na(existing[1]), 0, eval(extras[[existing[1]]], parent.frame()) )
+ llMix <- ifelse(is.na(existing[2]), 0, eval(extras[[existing[2]]], parent.frame()) )
+
+ if(class(tree)!="phylo") stop("tree must be of class phylo")
+ if (is.null(attr(tree, "order")) || attr(tree, "order") ==
+ "cladewise")
+ tree <- reorder(tree, "postorder")
+ if(any(tree$edge.length < 0)) {
+ tree$edge.length[tree$edge.length < 0] <- 1e-08
+ warning("negative edges length changed to 0!")
+ }
+ if (class(data)[1] != "phyDat") stop("data must be of class phyDat")
+ if(is.null(tree$edge.length)) stop("tree must have edge weights")
+ if(any(is.na(match(tree$tip, attr(data, "names"))))) stop("tip labels are not in data")
+ data <- subset(data, tree$tip.label) # needed
+ levels <- attr(data, "levels")
+ weight <- attr(data, "weight")
+ nr <- attr(data, "nr")
+ type <- attr(data,"type")
+ if(type=="AA" & !is.null(model)){
+ model <- match.arg(model, .aamodels)
+ getModelAA(model, bf=is.null(bf), Q=is.null(Q))
+ }
+ if(type=="CODON") Q <- as.numeric(.syn > 0)
+ if (is.null(bf))
+ bf <- rep(1/length(levels), length(levels))
+ if (is.null(Q))
+ Q <- rep(1, length(levels) * (length(levels) - 1)/2)
+ m <- 1
+ eig <- edQt(bf = bf, Q = Q)
+
+ w <- rep(1/k, k)
+ if (inv > 0)
+ w <- (1 - inv) * w
+ if (wMix > 0)
+ w <- wMix * w
+ g <- discrete.gamma(shape, k)
+ if (inv > 0)
+ g <- g/(1 - inv)
+ g <- rate * g
+ inv0 <- inv
+ kmax <- k
+ if(any(g<.gEps)){
+ for(i in 1:length(g)){
+ if(g[i]<.gEps){
+ inv <- inv+w[i]
+ }
+ }
+ w <- w[g>.gEps]
+ g <- g[g>.gEps]
+ k <- length(w)
+ }
+
+ INV <- Matrix(lli(data, tree), sparse=TRUE)
+ ll.0 <- as.matrix(INV %*% (bf * inv))
+ if(wMix>0) ll.0 <- ll.0 + llMix
+
+ nr <- as.integer(attr(data, "nr"))
+ nc <- as.integer(attr(data, "nc"))
+ nTips <- as.integer(length(tree$tip.label))
+
+ on.exit(.C("ll_free"))
+ .C("ll_init", nr, nTips, nc, as.integer(k))
+ tmp <- pml.fit(tree, data, bf, shape = shape, k = k, Q = Q,
+ levels = attr(data, "levels"), inv = inv, rate = rate, g = g, w = w,
+ eig = eig, INV = INV, ll.0 = ll.0, llMix = llMix, wMix = wMix, site=TRUE)
+
+ df <- ifelse(is.ultrametric(tree), tree$Nnode, length(tree$edge.length))
+ if(type=="CODON"){
+ df <- df + (kmax>1) + (inv0 > 0) + length(unique(bf)) - 1
+ }
+ else df = df + (kmax>1) + (inv0 > 0) + length(unique(bf)) - 1 + length(unique(Q)) - 1
+ result = list(logLik = tmp$loglik, inv = inv, k = kmax, shape = shape,
+ Q = Q, bf = bf, rate = rate, siteLik = tmp$siteLik, weight = weight,
+ g = g, w = w, eig = eig, data = data, model=model, INV = INV,
+ ll.0 = ll.0, tree = tree, lv = tmp$resll, call = call, df=df, wMix=wMix, llMix=llMix)
+ if(type=="CODON"){
+ result$dnds <- 1
+ result$tstv <- 1
+ }
+ class(result) = "pml"
+ result
+}
+
+
+optimRooted <- function(tree, data, eig=eig, w=w, g=g, bf=bf, rate=rate, ll.0=ll.0, INV=INV,
+ control = pml.control(epsilon = 1e-08, maxit = 25, trace=0), ...){
+ ind0 = which(ll.0>0)
+ contrast = attr(data, "contrast")
+ tree$edge.length[tree$edge.length < 1e-08] <- 1e-08
+ nTips = as.integer(length(tree$tip.label))
+ k = length(w)
+
+ weight = attr(data , "weight")
+ nr = as.integer(attr(data , "nr"))
+ nc = as.integer(attr(data , "nc"))
+ # optimising rooted triplets
+ optRoot0 <- function(t, tree, data, g, w, eig, bf, ll.0, k, INV){
+ l = length(tree$edge.length)
+ tree$edge.length[1:(l-1)] = tree$edge.length[1:(l-1)] + t
+ tree$edge.length[l] = tree$edge.length[l] - t
+ loglik = pml.fit(tree, data, bf=bf, g=g, w=w, eig=eig, ll.0=ll.0, k=k, INV=INV)
+ loglik
+ }
+ # optim edges leading to the root
+ optRoot2 <- function(t, tree, data, g, w, eig, bf, ll.0, k, INV){
+ tree$edge.length = tree$edge.length + t #c(el1+t, el2-t)
+ loglik = pml.fit(tree, data, bf=bf, g=g, w=w, eig=eig, ll.0=ll.0, k=k, INV=INV)
+ loglik
+ }
+
+ scaleEdges = function(t=1, trace=0, tree, data, ...){
+ fn = function(t, tree, data,...){
+ tree$edge.length = tree$edge.length*t
+ pml.fit(tree, data, ...)
+ }
+ optimize(f=fn, interval=c(0.25,4), tree=tree, data=data, ..., maximum = TRUE,
+ tol = .00001)
+ }
+ parent = tree$edge[, 1]
+ child = tree$edge[, 2]
+
+ anc <- Ancestors(tree, 1:max(tree$edge), "parent")
+ sibs <- Siblings(tree, 1:max(tree$edge))
+ allKids <- cvector <- allChildren(tree)
+ rootNode = getRoot(tree)
+
+ child2 = orderNNI(cvector, rootNode, nTips, TRUE)
+
+ lengthList <- edgeList <- vector("list", max(tree$edge))
+ for(i in tree$edge[,2]){
+ pa <- anc[i]
+ kids <- sibs[[i]]
+ if(pa!=rootNode){
+ edgeList[[i]] <- cbind(pa, c(anc[pa], kids))
+ lengthList[[i]] <- c(pa, kids)
+ }
+ else{
+ edgeList[[i]] <- cbind(pa, kids)
+ lengthList[[i]] <- kids
+ }
+ }
+
+ ll <- pml.fit(tree, data, bf=bf, k=k, eig=eig, INV=INV, ll.0=ll.0, w=w, g=g)
+ if(control$trace>2)cat("ll", ll, "\n")
+ eps=10
+ iter = 1
+
+ EL = numeric(max(tree$edge))
+ EL[tree$edge[, 2]] = tree$edge.length
+
+ eps0 =1e-8
+
+ tmp <- scaleEdges(t, trace=0, tree, data, bf = bf, k=k, ll.0=ll.0, INV=INV, eig = eig, w=w, g=g)
+ if(control$trace>2)cat("scale", tmp[[2]], "\n")
+ t = tmp[[1]]
+ tree$edge.length = tree$edge.length*t
+ el = tree$edge.length
+ EL[tree$edge[, 2]] = tree$edge.length
+ ll2 <- pml.fit(tree, data, bf=bf, k=k, eig=eig, ll.0=ll.0, INV=INV, w=w, g=g)
+
+ tmptree = tree
+
+ while(eps>control$eps && iter < control$maxit){
+ ll2 <- pml.fit(tree, data, bf=bf, k=k, eig=eig, ll.0=ll.0, INV=INV, w=w, g=g)
+ loli <- rootNode
+
+ children <- allKids[[rootNode]]
+ kidsEl <- EL[children]
+ minEl = min(kidsEl)
+ kidsEl = kidsEl - minEl
+
+# EDGE = cbind(rootNode, children)
+ tmptree$edge = cbind(rootNode, children)
+ tmptree$edge.length = kidsEl
+
+ t <- optimize(f=optRoot2,interval=c(1e-8,3), tmptree, data=data, k=k, g=g, w=w, eig=eig, bf=bf, ll.0=ll.0, INV=INV, maximum=TRUE)
+ optRoot2(t[[1]], tmptree, data=data, k=k, g=g, w=w, eig=eig, bf=bf, ll.0=ll.0, INV=INV)
+
+ if(control$trace>2)cat("optRoot", t[[2]], "\n")
+ ll3 = t[[2]]
+ EL[children] = kidsEl + t[[1]]
+
+ tree$edge.length = EL[tree$edge[, 2]]
+ ll2 <- pml.fit(tree, data, bf=bf, k=k, eig=eig, ll.0=ll.0, INV=INV, w=w, g=g)
+
+ for(i in 1:length(child2)){ # length(child2)
+ dad = child2[i]
+ if(dad>nTips ){ # kann raus
+ pa = anc[dad]
+ while(loli != pa){
+ tmpKids= cvector[[loli]]
+ tmpEdge = cbind(loli, tmpKids)
+ pml.move(tmpEdge, EL[tmpKids], data, g, w, eig, k, nTips, bf)
+ loli=anc[loli]
+ }
+ pml.move(edgeList[[dad]], EL[lengthList[[dad]]], data, g, w, eig, k, nTips, bf)
+ children <- allKids[[dad]]
+ kidsEl <- EL[children]
+ minEl = min(kidsEl)
+ kidsEl = kidsEl - minEl
+ maxEl = minEl + EL[dad]
+ kids=c(children, pa)
+ EDGE = cbind(dad, kids)
+ tmptree$edge = EDGE
+ tmptree$edge.length = c(kidsEl, maxEl)
+
+ tmptree2 = tmptree
+ tmptree2$edge.length = c(EL[children], EL[dad])
+
+ t0 = optRoot0(0, tmptree2, data, g, w, eig, bf, ll.0, k, INV)
+
+ t = optimize(f=optRoot0, interval=c(0+eps0,maxEl-eps0), tmptree, data=data, g=g, w=w, eig=eig, bf=bf, ll.0=ll.0, k=k, INV=INV, maximum=TRUE)
+
+ if(control$trace>2) cat("edge", t[[2]], "\n")
+ if(!is.nan(t[[2]]) & t[[2]] > ll3){
+ optRoot0(t[[1]], tmptree, data=data, g=g, w=w, eig=eig, bf=bf, ll.0=ll.0, k=k, INV=INV)
+ EL[children] = kidsEl+t[[1]]
+ EL[dad] = maxEl-t[[1]]
+ ll3 = t[[2]]
+ }
+ else optRoot0(0, tmptree2, data, g, w, eig, bf, ll.0, k, INV)
+ loli = dad
+ tree$edge.length = EL[tree$edge[, 2]]
+ }
+ }
+ ll2 <- pml.fit(tree, data, bf=bf, k=k, eig=eig, ll.0=ll.0, INV=INV, w=w, g=g)
+ eps = (ll - ll2) / ll2
+
+ if(control$trace>1) cat(ll, " -> ", ll2, "\n")
+ ll=ll2
+ iter = iter+1
+ }
+ list(tree=tree, logLik=ll, c(eps=eps, iter=iter))
+}
+
+
+# copy node likelihoods from C to R
+getNodeLogLik = function(data, i, j=1L){
+ nr = attr(data, "nr")
+ nc = attr(data, "nc")
+ ntips = length(data)
+ .Call("getLL", as.integer(i), as.integer(j-1L), as.integer(nr), as.integer(nc), as.integer(ntips))
+}
+
+
+# copy scaling parameters from C to R
+getSC = function(data, k=1L){
+ nr = attr(data, "nr")
+ ntips = length(data)
+ .Call("getSCM", as.integer(k), as.integer(nr), as.integer(ntips))
+}
+
+
+index.nni <- function (ch, cvector, pvector, root)
+{
+ p1 = pvector[ch]
+ k12 = cvector[[ch]]
+ k3 = cvector[[p1]]
+ k3 = k3[k3 != ch]
+ kids = c(k12, k3, ch)
+ parents = c(ch, ch, p1, p1)
+ if (p1 != root){
+ k4 = pvector[p1]
+ kids = c(kids, k4)
+ parents = c(parents, p1)
+ }
+ cbind(parents, kids)
+}
+
+
+# nicer traversal
+orderNNI <- function (cvector, root, nTips, nni=TRUE)
+{
+ #if(nni) l = sum(sapply(cvector, function(x, nTips) sum(x > nTips), nTips))
+ # eleganter
+ if(nni) l = sum(unlist(cvector) > nTips)
+ else l=length(unlist(cvector))
+ i = 1L
+ j = 1L
+ res = integer(l + 1L)
+ tmp = integer(l)
+ res[1] = root
+ while (i < (l + 1)) {
+ x = cvector[[res[i]]]
+ if(nni)x = x[x > nTips]
+ if (length(x) == 0) {
+ res[i + 1] = tmp[j - 1]
+ j = j - 1L
+ }
+ else {
+ res[i + 1] = x[1]
+ m = length(x)
+ if (m > 1) {
+ tmp[j:(j + m - 2L)] = x[-1]
+ j = j + m - 1L
+ }
+ }
+ i = i + 1
+ }
+ res[-1]
+}
+
+
+rooted.nni <- function(tree, data, eig, w, g, bf, rate, ll.0, INV,
+ control = pml.control(epsilon = 1e-08, maxit = 25, trace=0), ...){
+ ind0 = which(ll.0>0)
+ contrast = attr(data, "contrast")
+ tree$edge.length[tree$edge.length < 1e-08] <- 1e-08
+ nTips = as.integer(length(tree$tip.label))
+ k = length(w)
+ if (is.null(attr(tree, "order")) || attr(tree, "order") == "cladewise")
+ tree <- reorder.phylo(tree, "postorder")
+ if(!is.rooted(tree))stop("tree must be rooted")
+
+ attr(tree, "order") = NULL
+ weight = attr(data , "weight")
+ nr = as.integer(attr(data , "nr"))
+ nc = as.integer(attr(data , "nc"))
+
+ getEL1 <- function(t, nh){
+ el = numeric(4)
+ if(nh[1] > nh[2]){
+ el[2] = nh[1] -nh[2]
+ tnh = nh[1] + t[1]
+ }
+ else{
+ el[1] = nh[2] -nh[1]
+ tnh = nh[2] + t[1]
+ }
+ el[1:2] = el[1:2] + t[1]
+ if(tnh > nh[3]) el[3] = el[3] + tnh - nh[3]
+ else el[4] = el[4] - tnh + nh[3]
+ el[3:4] = el[3:4] + t[2]
+ el
+ }
+
+ optRootU <- function(t, tree, data, bf, g, w, eig, ll.0, k, INV, nh){
+ tree$edge.length = getEL1(t, nh)
+ pml.fit(tree, data, bf=bf, g=g, w=w, eig=eig, ll.0=ll.0, k=k, INV=INV)
+ }
+
+
+ getEL2 = function(t, nh){
+ el = numeric(5)
+ eps= 1e-6
+ nh12.min = max(nh[1:2]) + eps
+ nh123.min = max(nh12.min, nh[3]) + eps
+ l1 = nh[5] - nh123.min - eps
+ el[5] = l1 * t[1] + eps
+ nh123 = nh[5] - el[5]
+ l2 = nh123 - nh12.min - eps
+ nh12 = nh12.min + l2 * t[2]
+ el[1] = nh12 - nh[1]
+ el[2] = nh12 - nh[2]
+ el[3] = nh123 - nh[3]
+ el[4] = nh123 - nh12
+ el
+ }
+
+
+ optEdgeU <- function(t, tree, data, bf, g, w, eig, ll.0, k, INV, nh){
+ tree$edge.length = getEL2(t, nh)
+ pml.fit(tree, data, bf=bf, g=g, w=w, eig=eig, ll.0=ll.0, k=k, INV=INV)
+ }
+
+
+ child = tree$edge[, 2]
+ parent = tree$edge[, 1]
+ ll <- pml.fit(tree, data, bf=bf, k=k, eig=eig, ll.0=ll.0, INV=INV, w=w, g=g)
+ llstart <- ll
+ eps=.00001
+ iter = 1
+ EL = numeric(max(tree$edge))
+ EL[tree$edge[,2]] = tree$edge.length
+ change = numeric(length(parent)) + 1
+ rootNode = getRoot(tree)
+ anc = Ancestors(tree, 1:max(tree$edge), "parent")
+ cvector = allChildren(tree)
+ sibs <- Siblings(tree, 1:max(tree$edge))
+
+ child2 = orderNNI(cvector, rootNode, nTips)
+
+ while(iter < 2){
+ ll2 <- pml.fit(tree, data, bf=bf, k=k, eig=eig, ll.0=ll.0, INV=INV, w=w, g=g)
+# browser()
+
+ nh=nodeHeight(tree)
+
+ loli <- rootNode
+ pa <-rootNode
+ nchanges = 0
+ ind=1
+ i <- 1
+
+ tree1 <- tree2 <- tree3 <- tree
+ for(i in 1:length(child2)){
+ ch <- child2[i]
+ dad <- anc[ch]
+ if(ch>nTips){
+
+ EL[tree$edge[,2]] = tree$edge.length
+
+ pa <- ifelse(dad==rootNode, rootNode ,anc[dad])
+# should avoid unnecessary movements
+ while(loli != dad && loli!=rootNode){
+ if(loli==pa){
+ tmpKids <- sibs[[dad]]
+ tmpEdge <- cbind(pa, c(anc[pa], tmpKids))
+ pml.move(tmpEdge, EL[c(pa, tmpKids)], data, g, w, eig, k, nTips, bf)
+# cat("move from pa to dad \n")
+ loli = dad
+ }
+ else{
+# cat("move loli up", loli, "dad", dad, "pa", pa, "ch", ch, "\n")
+ tmpKids = cvector[[loli]]
+ tmpEdge = cbind(loli, tmpKids)
+ pml.move(tmpEdge, EL[tmpKids], data, g, w, eig, k, nTips, bf)
+ loli=anc[loli]
+ }
+
+ }
+
+ if(loli == rootNode && dad!= loli){
+ # update all nodes
+ pml.fit(tree, data, bf=bf, k=k, eig=eig, ll.0=ll.0, INV=INV, w=w, g=g)
+# cat("move down loli", loli, "dad", dad, "pa", pa, "ch", ch, "\n")
+ gd <- rev(Ancestors(tree, ch, "all"))
+
+ tmpKids <- sibs[[gd[2]]]
+ tmpEdge <- cbind(rootNode, tmpKids)
+ pml.move(tmpEdge, EL[tmpKids], data, g, w, eig, k, nTips, bf)
+ gd = gd[-1]
+ while(length(gd)>1){
+ tmpKids <- sibs[[gd[2]]]
+ tmpEdge = cbind(gd[1], c(anc[gd[1]],tmpKids))
+ pml.move(tmpEdge, EL[c(gd[1],tmpKids)], data, g, w, eig, k, nTips, bf)
+ gd = gd[-1]
+ }
+ loli=dad
+ }
+
+ X1 <- index.nni(ch, cvector, anc, rootNode)
+
+# if(loli!=rootNode){
+# tmpKids <- c(ch, sibs[[ch]])
+# tmpEdge <- cbind(dad, c(pa, tmpKids))
+# tree1$edge <- tmpEdge
+# tree1$edge.length = EL[c(dad, tmpKids)]
+# ll0 = pml.fit(tree1, data, bf=bf, g=g, w=w, eig=eig, ll.0=ll.0, k=k, INV=INV)
+# cat("triplet", ll0, "\n")
+# }
+
+
+ if(loli!=rootNode){
+ tree1$edge <- X1
+ tree1$edge.length = abs(nh[X1[,1]] - nh[X1[,2]])
+ ll0 = pml.fit(tree1, data, bf=bf, g=g, w=w, eig=eig, ll.0=ll.0, k=k, INV=INV)
+# cat("quartet", ll0, ch, dad, "\n")
+ }
+
+
+ if(dad == rootNode){
+
+ ll0 = pml.fit(tree, data, bf=bf, g=g, w=w, eig=eig, ll.0=ll.0, k=k, INV=INV)
+
+# cat("at root", ll0, ch, dad, "\n")
+ ind2 = c(1,3,2,4)
+ ind3 = c(3,2,1,4)
+ X2 = X3 = X1
+ X2[,2] = X1[ind2, 2]
+ X3[,2] = X1[ind3, 2]
+
+ tree1$edge = X1
+ tree2$edge = X2
+ tree3$edge = X3
+ edge1 <- X1[,2]
+ edge1[4] = dad
+ res1 =optim(par = c(.1,.1), optRootU, gr=NULL, tree=tree1, data=data, nh=nh[X1[,2]], g=g, w=w, eig=eig, bf=bf, ll.0=ll.0, INV=INV, k=k, method = "L-BFGS-B", lower = 1e-8, upper = 5, control = list(fnscale=-1))
+ res2 =optim(par = c(.1,.1), optRootU, gr=NULL, tree=tree2, data=data, nh=nh[X2[,2]], g=g, w=w, eig=eig, bf=bf, ll.0=ll.0, INV=INV, k=k, method = "L-BFGS-B", lower = 1e-8, upper = 5, control = list(fnscale=-1))
+ res3 =optim(par = c(.1,.1), optRootU, gr=NULL, tree=tree3, data=data, nh=nh[X3[,2]], g=g, w=w, eig=eig, bf=bf, ll.0=ll.0, INV=INV, k=k, method = "L-BFGS-B", lower = 1e-8, upper = 5, control = list(fnscale=-1))
+
+ ind = which.max(c(res1[[2]], res2[[2]], res3[[2]]))
+ if(control$trace>2) cat("root", c(res1[[2]], res2[[2]], res3[[2]]), "\n")
+
+ if(ind==1){
+ ll2 = res1[[2]]
+ optRootU(t=res1[[1]], tree=tree1, data=data, nh=nh[X1[,2]], g=g, w=w, eig=eig, bf=bf, ll.0=ll.0, INV=INV, k=k)
+ tmpEL = getEL1(res1[[1]], nh[X1[,2]])
+ tree = changeEdgeLength(tree, X1[,2], tmpEL)
+ }
+ if(ind==2){
+ ll2 = res2[[2]]
+ optRootU(t=res2[[1]], tree=tree2, data=data, nh=nh[X2[,2]], g=g, w=w, eig=eig, bf=bf, ll.0=ll.0, INV=INV, k=k)
+ tmpEL = getEL1(res2[[1]], nh[X2[,2]])
+ tree <- changeEdge(tree, X1[c(2,3),2])
+ tree = changeEdgeLength(tree, X2[,2], tmpEL)
+ }
+ if(ind==2){
+ ll2 = res3[[2]]
+ optRootU(t=res3[[1]], tree=tree3, data=data, nh=nh[X3[,2]], g=g, w=w, eig=eig, bf=bf, ll.0=ll.0, INV=INV, k=k)
+ tmpEL = getEL1(res3[[1]], nh[X3[,2]])
+ tree <- changeEdge(tree, X1[c(1,3),2])
+ tree = changeEdgeLength(tree, X3[,2], tmpEL)
+ }
+ }
+ else{
+ loli = dad
+ ind2 = c(1,3,2,4,5)
+ ind3 = c(3,2,1,4,5)
+ X2 = X3 = X1
+ X2[,2] = X1[ind2, 2]
+ X3[,2] = X1[ind3, 2]
+ tree1$edge = X1
+ tree2$edge = X2
+ tree3$edge = X3
+ tt = c(.3,.5)
+
+ res1 =optim(par = tt, optEdgeU, gr=NULL, tree=tree1, data, nh=nh[X1[,2]], g=g, w=w, eig=eig, bf=bf, ll.0=ll.0, INV=INV, k=k, method = "L-BFGS-B", lower = 1e-4, upper = 1-1e-4, control = list(fnscale=-1))
+
+ res2 =optim(par = tt, optEdgeU, gr=NULL, tree=tree2, data, nh=nh[X2[,2]], g=g, w=w, eig=eig, bf=bf, ll.0=ll.0, INV=INV, k=k, method = "L-BFGS-B", lower = 1e-4, upper = 1-1e-4, control = list(fnscale=-1))
+
+ res3 =optim(par = tt, optEdgeU, gr=NULL, tree=tree3, data, nh=nh[X3[,2]], g=g, w=w, eig=eig, bf=bf, ll.0=ll.0, INV=INV, k=k, method = "L-BFGS-B", lower = 1e-4, upper = 1-1e-4, control = list(fnscale=-1))
+
+ ind = which.max(c(res1[[2]], res2[[2]], res3[[2]]))
+ if(control$trace>2) cat("edge", ch, ":", c(res1[[2]], res2[[2]], res3[[2]]), "\n")
+ ll3 = max(c(res1[[2]], res2[[2]], res3[[2]]))
+
+ if( (ll3 - 1e-5*ll3) < ll2){
+ loli = rootNode
+ ll2 <- pml.fit(tree, data, bf=bf, eig=eig, ll.0=ll.0, w=w, g=g)
+ nh=nodeHeight(tree)
+ EL[tree$edge[,2]] = tree$edge.length
+ ind=0
+ }
+ else{
+ if(ind==1){
+ ll2 = res1[[2]]
+ optEdgeU(res1[[1]], tree=tree1, data, nh=nh[X1[,2]], g=g, w=w, eig=eig, bf=bf, ll.0=ll.0, INV=INV, k=k)
+ tmpEL = getEL2(res1[[1]], nh[X1[,2]])
+ tmpE = X1[,2]
+ tmpE[5] = X1[5,1]
+ tree = changeEdgeLength(tree, tmpE, tmpEL)
+ }
+ if(ind==2){
+ ll2 = res2[[2]]
+ optEdgeU(res2[[1]], tree=tree2, data, nh=nh[X2[,2]], g=g, w=w, eig=eig, bf=bf, ll.0=ll.0, INV=INV, k=k)
+ tmpEL = getEL2(res2[[1]], nh[X2[,2]])
+ tmpE = X2[,2]
+ tmpE[5] = X1[5,1]
+ tree <- changeEdge(tree, X1[c(2,3),2])
+ tree = changeEdgeLength(tree, tmpE, tmpEL)
+ }
+ if(ind==3){
+ ll2 = res3[[2]]
+ optEdgeU(res3[[1]], tree=tree3, data, nh=nh[X3[,2]], g=g, w=w, eig=eig, bf=bf, ll.0=ll.0, INV=INV, k=k)
+ tmpEL = getEL2(res3[[1]], nh[X3[,2]])
+ tmpE = X3[,2]
+ tmpE[5] = X1[5,1]
+ tree <- changeEdge(tree, X1[c(1,3),2])
+ tree = changeEdgeLength(tree, tmpE, tmpEL)
+ }
+
+ }
+ }
+ nh=nodeHeight(tree)
+ EL[tree$edge[,2]] = tree$edge.length
+ loli = dad
+
+ if(ind>1){
+# print("NNI swap")
+ nchanges = nchanges+1
+ anc = Ancestors(tree, 1:max(tree$edge), "parent")
+ cvector = allChildren(tree)
+ sibs <- Siblings(tree, 1:max(tree$edge))
+ }
+ }
+
+ }
+ ll2 <- pml.fit(tree, data, bf=bf, g=g, w=w, eig=eig, ll.0=ll.0, k=k, INV=INV)
+ eps = (ll - ll2) / ll2
+ if(control$trace>1) cat(ll, " -> ", ll2, "\n")
+ if(control$trace>1) cat("swap:", nchanges)
+ ll=ll2
+ iter = iter+1
+ }
+ list(tree=tree, logLik=ll, iter=iter, swap=nchanges)
+}
+
+
+
+
+
diff --git a/R/sankoff.R b/R/sankoff.R
new file mode 100644
index 0000000..2a8c991
--- /dev/null
+++ b/R/sankoff.R
@@ -0,0 +1,95 @@
+prepareDataSankoffNew <- function(data){
+ contrast = attr(data, "contrast")
+ contrast[contrast == 0] = 1.0e+06
+ contrast[contrast == 1] <- 0.0
+ attr(data, "contrast") <- contrast
+ data
+}
+
+
+sankoffNew <- function (tree, data, cost = NULL, site = 'pscore')
+{
+ if (class(data) != "phyDat")
+ stop("data must be of class phyDat")
+ data <- prepareDataSankoffNew(data)
+ weight <- attr(data, "weight")
+
+ levels <- attr(data, "levels")
+ l = length(levels)
+
+ if (is.null(cost)) {
+ cost <- matrix(1, l, l)
+ cost <- cost - diag(l)
+ }
+
+ l <- length(data)
+ nr <- attr(data, "nr")
+
+# on.exit(.C("sankoff_free"))
+# .C("sankoff_init", as.integer())
+
+
+# for (i in 1:length(data)) storage.mode(data[[i]]) = "double"
+
+ if(class(tree)=="phylo") return(fit.sankoffNew(tree, data, cost, returnData =site))
+ if(class(tree)=="multiPhylo"){
+ if(is.null(tree$TipLabel))tree = unclass(tree)
+ return(sapply(tree, fit.sankoffNew, data, cost, site))
+ }
+}
+
+
+fit.sankoffNew <- function (tree, data, cost, returnData = c("pscore", "site", "data"))
+{
+ if (is.null(attr(tree, "order")) || attr(tree, "order") ==
+ "cladewise")
+ tree <- reorder(tree, "postorder")
+ returnData <- match.arg(returnData)
+ node <- tree$edge[, 1]
+ edge <- tree$edge[, 2]
+ weight = attr(data, "weight")
+ nr = p = attr(data, "nr")
+
+ contr = attr(data, "contrast")
+
+ q = length(tree$tip.label)
+ nc = l = attr(data, "nc")
+ m = length(edge) + 1
+ dat = vector(mode = "list", length = m)
+ dat[1:q] = data[tree$tip.label]
+ node = as.integer(node - 1)
+ edge = as.integer(edge - 1)
+ nTips = as.integer(length(tree$tip))
+ mNodes = as.integer(max(node) + 1)
+# tips = as.integer((1:length(tree$tip))-1)
+ res <- .Call("sankoff3B", dat, as.numeric(cost), as.integer(nr),as.integer(nc),
+ node, edge, mNodes, nTips, as.double(contr), as.integer(nrow(contr)), PACKAGE="phangorn")
+ root <- getRoot(tree)
+ erg <- .Call("C_rowMin", res[[root]], as.integer(nr), as.integer(nc), PACKAGE = "phangorn")
+ if (returnData=='site') return(erg)
+ pscore <- sum(weight * erg)
+ result = pscore
+ if (returnData=="data"){
+ result <- list(pscore = pscore, dat = res)
+ }
+ result
+}
+
+
+pnodesNew <- function (tree, data, cost)
+{
+ if (is.null(attr(tree, "order")) || attr(tree, "order") ==
+ "cladewise")
+ tree <- reorder(tree, "postorder")
+ node <- tree$edge[, 1]
+ edge <- tree$edge[, 2]
+ nr = nrow(data[[1]])
+ nc = ncol(data[[1]])
+ node = as.integer(node - 1)
+ edge = as.integer(edge - 1)
+ .Call("pNodes", data, as.numeric(cost), as.integer(nr),as.integer(nc),
+ node, edge, PACKAGE="phangorn")
+}
+
+
+
diff --git a/R/simSeq.R b/R/simSeq.R
new file mode 100644
index 0000000..8305556
--- /dev/null
+++ b/R/simSeq.R
@@ -0,0 +1,85 @@
+
+#
+# add codon models, change to phyDat statt 3*
+#
+simSeq <- function (x, ...)
+ UseMethod("simSeq")
+
+
+simSeq.phylo = function(x, l=1000, Q=NULL, bf=NULL, rootseq=NULL, type = "DNA", model="USER",
+ levels = NULL, rate=1, ancestral=FALSE, ...){
+
+ pt <- match.arg(type, c("DNA", "AA", "USER"))
+ if (pt == "DNA")
+ levels <- c("a", "c", "g", "t")
+ if (pt == "AA")
+ levels <- c("a", "r", "n", "d", "c", "q", "e", "g", "h", "i",
+ "l", "k", "m", "f", "p", "s", "t", "w", "y", "v")
+ if (pt == "USER")
+ if(is.null(levels))stop("levels have to be supplied if type is USER")
+
+ lbf = length(levels)
+
+ if (type == "AA" & !is.null(model)) {
+ # model <- match.arg(model, c("USER", "WAG", "JTT", "LG", "Dayhoff", "cpREV", "mtmam", "mtArt", "MtZoa", "mtREV24"))
+ model <- match.arg(model, c("USER", .aamodels))
+ if(model!="USER")getModelAA(model, bf=is.null(bf), Q=is.null(Q))
+ }
+
+ if(is.null(bf)) bf = rep(1/lbf,lbf)
+ if(is.null(Q)) Q = rep(1,lbf*(lbf-1)/2)
+ if(is.matrix(Q)) Q=Q[lower.tri(Q)]
+ eig = edQt(Q, bf)
+
+ m = length(levels)
+
+ if(is.null(rootseq))rootseq = sample(levels, l, replace=TRUE, prob=bf)
+ x = reorder(x)
+ edge = x$edge
+ nNodes = max(edge)
+ res = matrix(NA, l, nNodes)
+ parent <- as.integer(edge[, 1])
+ child <- as.integer(edge[, 2])
+ root <- as.integer(parent[!match(parent, child, 0)][1])
+ res[, root] = rootseq
+ tl = x$edge.length
+ for(i in 1:length(tl)){
+ from = parent[i]
+ to = child[i]
+ P = getP(tl[i], eig, rate)[[1]]
+ for(j in 1:m){
+ ind = res[,from]==levels[j]
+ res[ind,to] = sample(levels, sum(ind), replace=TRUE, prob=P[,j])
+ }
+ }
+ k = length(x$tip)
+ label = c(x$tip, as.character((k+1):nNodes))
+ colnames(res)=label
+ if(!ancestral)res = res[, x$tip, drop=FALSE]
+ if(pt=="DNA") return(phyDat.DNA(as.data.frame(res), return.index=TRUE))
+ if(pt=="AA") return(phyDat.AA(as.data.frame(res), return.index=TRUE))
+ if(pt=="USER") return(phyDat.default(as.data.frame(res), levels = levels, return.index=TRUE))
+}
+
+
+
+simSeq.pml <- function(x, ancestral=FALSE, ...){
+ g = x$g
+ w = x$w
+ if(x$inv>0){
+ w = c(x$inv, w)
+ g = c(0.0, g)
+ }
+ n = length(w)
+ res = vector("list", n)
+ y = sample(n, sum(x$weight), replace=TRUE, prob=w)
+ levels = attr(x$data, "levels")
+ type = attr(x$data, "type")
+ for(i in 1:n){
+ l = sum(y==i)
+ res[[i]] = simSeq(x$tree, l, Q=x$Q, bf=x$bf, type=type, levels=levels, rate=g[i], ancestral=ancestral)
+ }
+ x = call("c.phyDat", quote(res[[1]]))
+ if(n>1) x <- parse(text= paste("c(", "res[[1]]", paste0(",res[[", 2:n, "]]", collapse=""), ")"))
+ eval(x)
+}
diff --git a/R/sysdata.rda b/R/sysdata.rda
new file mode 100644
index 0000000..c1e3371
Binary files /dev/null and b/R/sysdata.rda differ
diff --git a/R/treeManipulation.R b/R/treeManipulation.R
new file mode 100644
index 0000000..050bb63
--- /dev/null
+++ b/R/treeManipulation.R
@@ -0,0 +1,1088 @@
+#
+# tree manipulation
+#
+
+# from coalescenMCMC
+getIndexEdge <- function(tip, edge)
+ ## 'integer(1)' mustn't be substituted by '0L' except if 'DUP = TRUE':
+ .C("get_single_index_integer", as.integer(edge[, 2L]),
+ as.integer(tip), integer(1L), PACKAGE = "phangorn",
+ NAOK = TRUE)[[3L]]
+
+getIndexEdge2 <- function(node, edge)
+ .C("get_two_index_integer", as.integer(edge[, 1L]),
+ as.integer(node), integer(2L), PACKAGE = "phangorn",
+ NAOK = TRUE)[[3L]]
+
+# no checks for postorder
+getRoot <- function (tree)
+{
+ if(!is.null(attr(tree, "order")) && attr(tree, "order") ==
+ "postorder"){
+ return(tree$edge[nrow(tree$edge), 1])
+ }
+ res = unique(tree$edge[, 1][!match(tree$edge[, 1], tree$edge[, 2], 0)])
+ if (length(res) == 1)
+ return(res)
+ else stop("There are apparently two root edges in your tree")
+}
+
+
+# renames root node
+reroot <- function (tree, node)
+{
+ anc = Ancestors(tree, node, "all")
+ l = length(anc)
+ if(is.na(match(node,tree$edge[,1])))stop("node not in tree")
+ if(l==0)return(tree)
+ ind = match(c(node, anc[-l]), tree$edge[, 2])
+ tree$edge[ind, c(1, 2)] = tree$edge[ind, c(2, 1)]
+ root = anc[l]
+ tree$edge[tree$edge == root] = 0L
+ tree$edge[tree$edge == node] = root
+ tree$edge[tree$edge == 0L] = node
+# needed for unrooted trees
+ tree <- collapse.singles(tree)
+ attr(tree, "order") <- NULL
+ reorder(tree, "postorder")
+}
+
+
+reroot2 <- function(tree, node) {
+ if(node==getRoot(tree)) return(tree)
+ anc = Ancestors(tree, node, "all")
+ l = length(anc)
+ ind = match(c(node, anc[-l]), tree$edge[, 2])
+ tree$edge[ind, c(1, 2)] = tree$edge[ind, c(2, 1)]
+ reorderPruning(tree)
+}
+
+
+changeEdge = function (tree, swap, edge = NULL, edge.length = NULL)
+{
+ attr(tree, "order") = NULL
+ child <- tree$edge[, 2]
+ tmp = numeric(max(child))
+ tmp[child] = 1:length(child)
+ tree$edge[tmp[swap[1]], 2] = swap[2]
+ tree$edge[tmp[swap[2]], 2] = swap[1]
+ if (!is.null(edge)) {
+ tree$edge.length[tmp[edge]] = edge.length
+ }
+ reorder(tree, "postorder")
+}
+
+
+changeEdgeLength = function (tree, edge, edge.length)
+{
+ tree$edge.length[match(edge, tree$edge[,2])] = edge.length
+ tree
+}
+
+
+# O(n) statt O(n^2) Speicher und Geschwindigkeit
+midpoint <- function(tree){
+# distance from node to root
+node2root <- function(x){
+ x = reorder(x, "postorder")
+ el = numeric(max(x$edge))
+ parents <- x$edge[, 1]
+ child <- x$edge[, 2]
+ el[child] = x$edge.length
+ l = length(parents)
+ res <- numeric(max(x$edge))
+ for(i in l:1){
+ res[child[i]] = el[child[i]] + res[parents[i]]
+ }
+ res
+}
+ oldtree <- tree
+ tree = unroot(tree)
+ nTips = length(tree$tip)
+ maxD1 = node2root(tree)[1:nTips]
+ ind = which.max(maxD1)
+ tmproot = Ancestors(tree, ind, "parent")
+ tree = reroot(tree, tmproot)
+ el = numeric(max(tree$edge))
+ el[tree$edge[,2]]=tree$edge.length
+ maxdm = el[ind]
+ tree$edge.length[tree$edge[,2]==ind] = 0
+ maxD1 = node2root(tree)[1:nTips]
+ tree$edge.length[tree$edge[,2]==ind] = maxdm
+ ind = c(ind, which.max(maxD1) )
+ maxdm = maxdm + maxD1[ind[2]]
+ rn = max(tree$edge)+1
+ edge = tree$edge
+ el = tree$edge.length
+ children = tree$edge[,2]
+ left = match(ind[1], children)
+ tmp = Ancestors(tree, ind[2], "all")
+ tmp= c(ind[2], tmp[-length(tmp)])
+ right = match(tmp, children)
+ if(el[left]>= (maxdm/2)){
+ edge = rbind(edge, c(rn, ind[1]))
+ edge[left,2] = rn
+ el[left] = el[left] - (maxdm/2)
+ el = c(el, maxdm/2)
+ }
+ else{
+ sel = cumsum(el[right])
+ i = which(sel>(maxdm/2))[1]
+ edge = rbind(edge, c(rn, tmp[i]))
+ edge[right[i],2] = rn
+ eltmp = sel[i] - (maxdm/2)
+ el = c(el, el[right[i]] - eltmp)
+ el[right[i]] = eltmp
+ }
+ tree$edge.length = el
+ tree$edge=edge
+ tree$Nnode = tree$Nnode+1
+ attr(tree, "order") <- NULL
+ tree <- reorder(reroot(tree, rn), "postorder")
+ if(!is.null(oldtree$node.label))tree <- addConfidences.phylo(tree, oldtree)
+ tree
+}
+
+
+pruneTree = function(tree, ..., FUN = ">="){
+ if(is.null(tree$node)) stop("no node labels")
+ if(is.rooted(tree)) tree = unroot(tree)
+ m = max(tree$edge)
+ nTips = length(tree$tip)
+ bs = rep(TRUE, m)
+ bs[ (nTips+1) : m] = sapply(as.numeric(as.character(tree$node)), FUN,...)
+ tree$edge.length[!bs[tree$edge[,2]]] = 0
+
+ reorder(di2multi(tree), "postorder")
+}
+
+
+# requires postorder
+# works fine with fit.fitch
+# for internal use in fitch.spr
+# pos statt i
+dropTip <- function(x, i, check.binary=FALSE, check.root=TRUE){
+ edge <- x$edge
+# edge1 <- edge[,1]
+# edge2 <- edge[,2]
+ root <- getRoot(x)
+ ch <- which(edge[,2] == i)
+ pa <- edge[ch,1]
+ edge = edge[-ch,]
+ ind <- which(edge[,1] == pa)
+ if(root == pa){
+ if(length(ind)==1){
+ edge = edge[-ind,]
+ x$Nnode=x$Nnode-1L
+ }
+ if(length(ind)==2){
+ n = dim(edge)[1]
+ newroot = edge[n-2L,1]
+ newedge = edge[ind,2]
+ if(newedge[1]==newroot)edge[n-1,] <- newedge
+ else edge[n-1,] <- newedge[2:1]
+ edge = edge[-n,]
+ x$Nnode=x$Nnode-1L
+ edge[edge==newroot] = root
+ pa <- newroot
+ }
+ # todo handle unrooted trees
+ }
+ else{
+ nind <- which(edge[,2] == pa)
+ # normal binary case
+ if(length(ind)==1){
+ edge[nind,2] = edge[ind,2]
+ edge <- edge[-ind,]
+ x$Nnode <- x$Nnode-1L
+ }
+ }
+ #
+ edge[edge>pa] = edge[edge>pa] -1L
+ x$edge <- edge
+ x
+}
+
+# kind of works well too
+dropTip2 <- function(x, i, check.binary=FALSE, check.root=TRUE){
+ edge <- x$edge
+ root <- getRoot(x)
+ ch <- which(edge[,2] == i)
+ pa <- edge[ch,1]
+ edge = edge[-ch,]
+ ind <- which(edge[,1] == pa)
+ if(root == pa){
+ if(length(ind)==1){
+ edge = edge[-ind,]
+ x$Nnode=x$Nnode-1L
+ }
+ if(length(ind)==2){
+ n = dim(edge)[1]
+ newroot = edge[n-2L,1]
+ newedge = edge[ind,2]
+ if(newedge[1]==newroot)edge[n-1,] <- newedge
+ else edge[n-1,] <- newedge[2:1]
+ edge = edge[-n,]
+ x$Nnode=x$Nnode-1L
+ edge[edge==newroot] = root
+ pa <- newroot
+ }
+ # todo handle unrooted trees
+ }
+ else{
+ nind <- which(edge[,2] == pa)
+ # normal binary case
+ if(length(ind)==1){
+ edge[nind,2] = edge[ind,2]
+ edge <- edge[-ind,]
+ x$Nnode <- x$Nnode-1L
+ }
+ }
+ #
+# edge[edge>pa] = edge[edge>pa] -1L
+ x$edge <- edge
+ x
+}
+
+
+# like drop tip and returns two trees,
+# to be used in fitch.spr
+# ch = allKids(edge, nTips)
+descAll = function (x, node, nTips, ch)
+{
+ edge = x[,1]
+ m = max(x)
+ isInternal = logical(m)
+ isInternal[(nTips+1):m] = TRUE
+ desc = function(node, isInternal) {
+ if (!isInternal[node]) return(node)
+ res = NULL
+ while (length(node) > 0) {
+ tmp = unlist(ch[node])
+ res = c(res, tmp)
+ node = tmp[isInternal[tmp]]
+ }
+ res
+ }
+ desc(node, isInternal)
+}
+
+
+dropNode <- function(x, i, check.binary=FALSE, check.root=TRUE, all.ch=NULL){
+ edge <- x$edge
+ root <- getRoot(x)
+ ch <- which(edge[,2] == i)
+# getIndexEdge(tip, edge)
+
+ nTips <- length(x$tip.label)
+ pa <- edge[ch,1]
+ if(i>nTips){
+# kids <- Descendants(x, i, "all")
+ if(is.null(all.ch)) all.ch=allChildren(x)
+ kids <- descAll(edge, i, nTips, all.ch)
+ ind <- match(kids,edge[,2])
+ edge2 <- edge[sort(ind),]
+ edge <- edge[-c(ch, ind),]
+ }
+ else edge = edge[-ch,]
+ if(nrow(edge)<3)return(NULL)
+ ind <- which(edge[,1] == pa)
+ if(root == pa){
+ if(length(ind)==1){
+ edge = edge[-ind,]
+ x$Nnode=x$Nnode-1L
+ }
+ if(length(ind)==2){
+ n = dim(edge)[1]
+ newroot = edge[n-2L,1]
+ newedge = edge[ind,2]
+ if(newedge[1]==newroot)edge[n-1,] <- newedge
+ else edge[n-1,] <- newedge[2:1]
+ edge = edge[-n,]
+ x$Nnode=length(unique(edge[,1]))
+ edge[edge==newroot] = root
+ pa <- newroot
+ }
+ # todo handle unrooted trees
+ }
+ else{
+ nind <- which(edge[,2] == pa)
+ # normal binary case
+ if(length(ind)==1){
+ edge[nind,2] = edge[ind,2]
+ edge <- edge[-ind,]
+ x$Nnode <- length(unique(edge[,1]))
+ }
+ }
+ #
+# edge[edge>pa] = edge[edge>pa] -1L
+ x$edge <- edge
+ y <- x
+ y$edge <- edge2
+ y$Nnode <- length(unique(edge2[,1]))
+ list(x, y, pa)
+}
+
+
+
+dropNodeNew <- function(edge, i, nTips, check.binary=FALSE, check.root=TRUE){
+ root <- edge[nrow(edge),2]
+ ch <- which(edge[,2] == i)
+ pa <- edge[ch,1]
+ edge2=NULL
+
+ # einfachere allChildren Variante 2*schneller
+ allKids = function (edge, nTips)
+ {
+ parent = edge[, 1]
+ children = edge[, 2]
+ .Call("AllChildren", as.integer(children), as.integer(parent), as.integer(max(edge)), PACKAGE = "phangorn")
+ }
+
+ descAll = function (edge, node, nTips)
+ {
+ ch = allKids(edge, nTips)
+ isInternal = logical(max(edge))
+ isInternal[unique(edge[, 1])] = TRUE
+ desc = function(node, isInternal) {
+ if (!isInternal[node]) return(node)
+ res = NULL
+ while (length(node) > 0) {
+ tmp = unlist(ch[node])
+ res = c(res, tmp)
+ node = tmp[isInternal[tmp]]
+ }
+ res
+ }
+ desc(node, isInternal)
+ }
+
+ if(i>nTips){
+ kids <- descAll(edge, i, nTips)
+ ind <- match(kids,edge[,2])
+ edge2 <- edge[sort(ind),]
+ edge <- edge[-c(ch, ind),]
+ }
+ else edge = edge[-ch,]
+ if(nrow(edge)<3)return(NULL)
+ ind <- which(edge[,1] == pa)
+ if(root == pa){
+ if(length(ind)==1){
+ edge = edge[-ind,]
+ }
+ if(length(ind)==2){
+ n = dim(edge)[1]
+ newroot = edge[n-2L,1]
+ newedge = edge[ind,2]
+ if(newedge[1]==newroot)edge[n-1,] <- newedge
+ else edge[n-1,] <- newedge[2:1]
+ edge = edge[-n,]
+ edge[edge==newroot] = root
+ pa <- newroot
+ }
+ # todo handle unrooted trees
+ }
+ else{
+ nind <- which(edge[,2] == pa)
+ # normal binary case
+ if(length(ind)==1){
+ edge[nind,2] = edge[ind,2]
+ edge <- edge[-ind,]
+ }
+ }
+ #
+ # edge[edge>pa] = edge[edge>pa] -1L
+ list(edge, edge2, pa)
+}
+
+
+dropTipNew <- function(edge, i, nTips, check.binary=FALSE, check.root=TRUE){
+ root <- edge[nrow(edge),2]
+ ch <- which(edge[,2] == i)
+ pa <- edge[ch,1]
+ edge = edge[-ch,]
+ ind <- which(edge[,1] == pa)
+ if(root == pa){
+ if(length(ind)==1){
+ edge = edge[-ind,]
+ }
+ if(length(ind)==2){
+ n = dim(edge)[1]
+ newroot = edge[n-2L,1]
+ newedge = edge[ind,2]
+ if(newedge[1]==newroot)edge[n-1,] <- newedge
+ else edge[n-1,] <- newedge[2:1]
+ edge = edge[-n,]
+ edge[edge==newroot] = root
+ pa <- newroot
+ }
+ # todo handle unrooted trees
+ }
+ else{
+ nind <- which(edge[,2] == pa)
+ # normal binary case
+ if(length(ind)==1){
+ edge[nind,2] = edge[ind,2]
+ edge <- edge[-ind,]
+ }
+ }
+ #
+ edge[edge>pa] = edge[edge>pa] -1L
+ edge
+}
+
+
+# postorder remained tip in 1:nTips
+addOne <- function (tree, tip, i){
+ edge = tree$edge
+ parent = edge[,1]
+ l = dim(edge)[1]
+ m = max(edge)+1L
+ p = edge[i,1]
+ k = edge[i,2]
+ edge[i, 2] = m
+ ind = match(p, parent)
+ if(ind==1) edge = rbind(matrix(c(m,m,k,tip), 2, 2), edge)
+ else edge = rbind(edge[1:(ind-1), ], matrix(c(m,m,k,tip), 2, 2), edge[ind:l, ])
+ tree$edge = edge
+ tree$Nnode = tree$Nnode+1
+ tree
+}
+
+
+addOneTree <- function (tree, subtree, i, node){
+ edge = tree$edge
+ parent = edge[,1]
+ l = dim(edge)[1]
+ m = node #max(edge)+1L
+ p = edge[i,1]
+ k = edge[i,2]
+ edge[i, 2] = m
+ edge2 = subtree$edge
+ ind = match(p, parent)
+ r2 = edge2[nrow(edge2),1]
+ if(ind==1) edge = rbind(edge2, matrix(c(m,m,r2,k), 2, 2), edge)
+ else edge = rbind(edge[1:(ind-1), ], edge2, matrix(c(m,m,r2,k), 2, 2), edge[ind:l, ])
+ tree$edge = edge
+ tree$Nnode = tree$Nnode + subtree$Nnode + 1L
+ attr(tree, "order") = NULL
+ tips1 = as.integer(length(tree$tip) + 1L)
+ tmproot = getRoot(tree)
+ if(tmproot!=tips1){
+ tree$edge[tree$edge==tmproot] = 0L
+ tree$edge[tree$edge==tips1] = tmproot
+ tree$edge[tree$edge==0L] = tips1
+ }
+ tree <- reorder(tree, "postorder")
+ if(tmproot!=tips1) tree <- unroot(tree)
+ tree
+}
+
+
+reorderPruning <- function (x, ...)
+{
+ parents <- as.integer(x$edge[, 1])
+ child <- as.integer(x$edge[, 2])
+ root <- as.integer(parents[!match(parents, child, 0)][1]) # unique out
+ if (length(root) > 2)
+ stop("more than 1 root found")
+ n = length(parents)
+ m = max(x$edge) # edge parents
+ neworder = .C("C_reorder", parents, child, as.integer(n), as.integer(m), integer(n), as.integer(root-1L), PACKAGE = "phangorn")[[5]]
+ x$edge = x$edge[neworder,]
+ x$edge.length = x$edge.length[neworder]
+ attr(x, "order") <- "pruningwise"
+ x
+}
+
+
+add.tip <- function(phy, n, edgeLength=NULL, tip=""){
+ ind <- which(phy$edge[,2] == n)
+ phy <- new2old.phylo(phy)
+ edge <- matrix(as.numeric(phy$edge),ncol=2)
+ k <- min(edge)
+ l <- max(edge)
+ phy$edge <- rbind(phy$edge, c(k-1,phy$edge[ind,2]))
+ phy$edge <- rbind(phy$edge, c(k-1,l+1))
+ phy$edge[ind,2] = k-1
+ phy$edge.length[ind] = edgeLength[1]
+ phy$edge.length <- c(phy$edge.length, edgeLength[-1])
+ phy$tip.label <- c(phy$tip.label, tip)
+ phy <- old2new.phylo(phy)
+ phy <- reorder(phy, "postorder")
+ phy
+}
+
+
+nnin <- function (tree, n)
+{
+ attr(tree, "order") = NULL
+ tree1 = tree
+ tree2 = tree
+ edge = matrix(tree$edge, ncol = 2)
+ parent = edge[, 1]
+ child = tree$edge[, 2]
+ k = min(parent) - 1
+ ind = which(child > k)[n]
+ if(is.na(ind))return(NULL)
+ p1 = parent[ind]
+ p2 = child[ind]
+ ind1 = which(parent == p1)
+ ind1 = ind1[ind1 != ind][1]
+ ind2 = which(parent == p2)
+ e1 = child[ind1]
+ e2 = child[ind2[1]]
+ e3 = child[ind2[2]]
+ tree1$edge[ind1, 2] = e2
+ tree1$edge[ind2[1], 2] = e1
+ tree2$edge[ind1, 2] = e3
+ tree2$edge[ind2[2], 2] = e1
+ if(!is.null(tree$edge.length)){
+ tree1$edge.length[c(ind1, ind2[1])] = tree$edge.length[c(ind2[1] ,ind1)]
+ tree2$edge.length[c(ind1, ind2[2])] = tree$edge.length[c(ind2[2] ,ind1)]
+ }
+ tree1 <- reorder(tree1, "postorder")
+ tree2 <- reorder(tree2, "postorder")
+# tree1$tip.label <- tree2$tip.label <- NULL
+ result = list(tree1, tree2)
+ result
+}
+
+
+nni <- function (tree)
+{
+ tip.label <- tree$tip.label
+ attr(tree, "order") = NULL
+ k = min(tree$edge[, 1]) - 1
+ n = sum(tree$edge[, 2] > k)
+ result = vector("list", 2*n)
+ l=1
+ for (i in 1:n) {
+ tmp = nnin(tree, i)
+ tmp[[1]]$tip.label <- tmp[[2]]$tip.label <- NULL
+ result[c(l, l+1)] = tmp
+ l = l + 2
+ }
+ attr(result, "TipLabel") <- tip.label
+ class(result) <- "multiPhylo"
+ result
+}
+
+
+allTrees <- function (n, rooted = FALSE, tip.label = NULL)
+{
+ n <- as.integer(n)
+ nt <- as.integer(round(dfactorial(2 * (n + rooted) - 5)))
+ if ((n + rooted) > 10) {
+ nt <- dfactorial(2 * (n + rooted) - 5)
+ stop("That would generate ", round(nt), " trees, and take up more than ",
+ round(nt/1000), " MB of memory!")
+ }
+ if (n < 2) {
+ stop("A tree must have at least two taxa.")
+ }
+ if (!rooted && n == 2) {
+ stop("An unrooted tree must have at least three taxa.")
+ }
+
+ if (rooted) {
+ edge <- matrix(NA, 2*n-2, 2)
+ edge[1:2,] <- c(n+1L, n+1L, 1L, 2L)
+ }
+ else {
+ edge <- matrix(NA, 2*n-3, 2)
+ edge[1:3,] <- c(n+1L, n+1L, n+1L, 1L, 2L, 3L)
+ }
+ edges <- list()
+ edges[[1]] <- edge
+
+ m=1
+ nedge = 1
+ trees <- vector("list", nt)
+ if ((n + rooted) > 3) {
+ i = 3L + (!rooted)
+ pa = n + 2L
+ nr = 2L + (!rooted)
+ while(i < (n+1L)){
+ nedge = nedge+2
+ m2 = m * nedge
+
+ newedges <- vector("list", m2)
+ for (j in 1:m) {
+ edge <- edges[[j]]
+ l <- nr # nrow(edge)
+
+ edgeA <- edge
+ edgeB <- edge
+
+ for (k in 1L:l) {
+ edge = edgeA
+ node <- edge[k, 1]
+ edge[k, 1] <- pa
+ edge[l + 1, ] <- c(pa, i)
+ edge[l + 2, ] <- c(node, pa)
+
+ newedges[[(j - 1) * (l + rooted) + k]] <- edge
+ }
+
+ if(rooted) {
+ edgeB[] <- as.integer(sub(n+1L, pa, edgeB))
+ edge = edgeB
+ edge[l + 1, ] <- c(n+1L, i)
+ edge[l + 2, ] <- c(n+1L, pa)
+ newedges[[j * (l + 1)]] <- edge
+ }
+ } # end for
+ edges <- newedges
+ m=m2
+ i = i + 1L
+ pa = pa + 1L
+ nr = nr + 2L
+ } # end for m
+ } # end if
+ for (x in 1:m) {
+ tree <- list(edge = edges[[x]])
+ tree$Nnode <- n - 2L + rooted
+ class(tree) <- "phylo"
+ trees[[x]] <- reorderPruning(tree)
+ }
+ attr(trees, "TipLabel") <- if (is.null(tip.label))
+ paste("t", 1:n, sep = "")
+ else tip.label
+ class(trees) <- "multiPhylo"
+ trees
+}
+
+
+
+dn <- function (x){
+ if (!is.binary.tree(x) )
+ x <- multi2di(x, random = FALSE)
+ x = reroot2(x, 1)
+ n <- length(x$tip.label)
+ n.node <- x$Nnode
+ N <- n + n.node
+ x <- reorderPruning(x)
+ res <- matrix(NA, N, N)
+ res[cbind(1:N, 1:N)] <- 0
+ res[x$edge] <- res[x$edge[, 2:1]] <- 1
+ 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 > n)
+ des1 <- which(!is.na(res[des1, ]))
+ if (des2 > n)
+ des2 <- which(!is.na(res[des2, ]))
+ for (y in des1) res[y, des2] <- res[des2, y] <- res[anc,
+ y] + res[anc, des2]
+ if (anc != 1) {
+ ind <- which(x$edge[, 2] == anc)
+ nod <- x$edge[ind, 1]
+ l <- 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
+}
+
+
+# replace with dist.nodes
+dn <- function(x){
+# if (!is.binary.tree(x) ) x <- multi2di(x, random = FALSE)
+ if(is.null(x$edge.length))x$edge.length=rep(1,nrow(x$edge))
+ else x$edge.length[] = 1
+ dist.nodes(x)
+}
+
+
+rSPR = function (tree, moves = 1, n = length(moves), k=NULL)
+{
+ if (n == 1) {
+ trees = tree
+ for (i in 1:moves) trees = kSPR(trees, k=k)
+ }
+ else {
+ trees = vector("list", n)
+ if(length(moves)==1) moves = rep(moves, n)
+
+ for (j in 1:n) {
+ tmp = tree
+ if(moves[j]>0){
+ for (i in 1:moves[j]) tmp = kSPR(tmp, k=k)
+ }
+ tmp$tip.label = NULL
+ trees[[j]] = tmp
+ }
+ attr(trees, "TipLabel") <- tree$tip.label
+ class(trees) <- "multiPhylo"
+ }
+ trees
+}
+
+
+kSPR = function(tree, k=NULL){
+ l <- length(tree$tip.label)
+ root= getRoot(tree)
+ distN = dn(tree)[-c(1:l), -c(1:l)]
+ distN[upper.tri(distN)]=Inf
+ dN = distN[lower.tri(distN)]
+ tab = table(dN)
+ tab[1] = tab[1] * 2
+ tab[-1] = tab[-1] * 8
+ if(is.null(k)) k = 1:length(tab)
+ k = na.omit((1:length(tab))[k])
+ if(length(k)>1)k = sample((1:length(tab))[k], 1, prob=tab[k] / sum(tab[k]) )
+ if(k==1) return(rNNI(tree, 1, 1))
+ index = which(distN==k, arr.ind=TRUE) + l
+ m = dim(index)[1]
+ if(m==0)stop("k is chosen too big")
+ ind = index[sample(m, 1),]
+ s1 = sample(c(1,2),1)
+ if(s1==1)res = (oneOf4(tree, ind[1], ind[2], sample(c(1,2),1), sample(c(1,2),1)))
+ if(s1==2)res = (oneOf4(tree, ind[2], ind[1], sample(c(1,2),1), sample(c(1,2),1)))
+ res=reroot2(res, root)
+ reorderPruning(res)
+}
+
+
+oneOf4 = function(tree, ind1, ind2, from=1, to=1){
+ if (!is.binary.tree(tree))
+ stop("Sorry, trees must be binary!")
+ tree=reroot2(tree, ind2)
+ trees = vector('list', 8)
+ kids1 = Children(tree, ind1)
+ anc = Ancestors(tree, ind1, "all")
+ l = length(anc)
+ kids2 = Children(tree, ind2)
+ kids2 = kids2[kids2!=anc[l-1]]
+
+ child = tree$edge[,2]
+ tmp = numeric(max(tree$edge))
+ tmp[child] = 1:length(child)
+
+ edge = tree$edge
+ edge[tmp[kids1[-from]],1] = Ancestors(tree, ind1, "parent")
+ edge[tmp[kids2[to]],1] = ind1
+ edge[tmp[ind1]] = ind2
+ tree$edge=edge
+ reorderPruning(tree)
+}
+
+
+# faster than kSPR
+rSPR_Old <- function(tree, moves=1, n=1){
+ k=length(tree$edge[,1])
+ if(n==1){
+ trees = tree
+ for(i in 1:moves) trees = sprMove(trees,sample(k,1))
+ }
+ else{
+ trees = vector("list", n)
+ for(j in 1:n){
+ tmp = tree
+ for(i in 1:moves) tmp = sprMove(tmp,sample(k,1))
+ tmp$tip.label=NULL
+ trees[[j]] = tmp
+ }
+ attr(trees, "TipLabel") <- tree$tip.label
+ class(trees) <- "multiPhylo"
+ }
+ trees
+}
+
+
+sprMove <- function(tree, m){
+ if (is.rooted(tree)) tree <- unroot(tree)
+ #stop("Sorry trees must be unrooted")
+ if(!is.binary.tree(tree))stop("Sorry trees must be binary!")
+
+ reroot2 <- function(tree, node){
+ anc = Ancestors(tree, node, "all")
+ l = length(anc)
+ ind = match(c(node, anc[-l]), tree$edge[,2])
+ tree$edge[ind,c(1,2)] = tree$edge[ind,c(2,1)]
+ tree
+ }
+ changeEdge <- function(tree, new, old){
+ tree$edge[tree$edge==old] = 0L
+ tree$edge[tree$edge==new] = old
+ tree$edge[tree$edge==0L] = new
+ # needed for unrooted trees
+ tree <- collapse.singles(tree)
+ tree
+ }
+
+ edge = tree$edge
+ k = max(edge)
+ nTips = length(tree$tip)
+ nEdges = 2*nTips-3
+ if(m > nEdges) stop("m to big")
+
+ parent = edge[,1]
+ child = edge[,2]
+ pv = integer(k)
+ pv[child] = parent
+ cv = list()
+ for(i in unique(parent)) cv[[i]] = child[parent==i]
+ bp = bip(tree)
+ root <- parent[!match(parent, child, 0)][1]
+
+ ch = child[m]
+ pa = parent[m]
+
+ candidates = !logical(k)
+ candidates[root] = FALSE
+ candidates[cv[[ch]]] = FALSE
+ candidates[cv[[pa]]] = FALSE
+ candidates[pv[pa]] = FALSE
+ candidates[pa] = FALSE
+
+ ind = which(candidates)
+ l = sample(ind,1)
+
+ cr=FALSE
+
+ if(!any(is.na(match(bp[[l]], bp[[ch]]))) ){
+
+ newroot = cv[[ch]] #[ 1]
+ newroot = newroot[newroot>nTips][1]
+ tree <- reroot2(tree, newroot)
+ edge = tree$edge
+ parent = tree$edge[,1]
+ child = tree$edge[,2]
+ pv = integer(k)
+ pv[child] = parent
+ cv = list()
+ for(i in unique(parent)) cv[[i]] = child[parent==i]
+
+ tmp = pa
+ pa=ch
+ ch=tmp
+ cr = TRUE
+ }
+
+ if(pa==root){
+ cp = cv[[pa]]
+ newroot = cp[cp!=ch]
+
+ newroot = newroot[newroot>nTips][1]
+# if(length(newroot)==0)browser()
+ #!newroot = cp[cp>nTips][1]
+ tree = reroot2(tree, newroot)
+ edge = tree$edge
+ parent = tree$edge[,1]
+ child = tree$edge[,2]
+ pv = integer(k)
+ pv[child] = parent
+ cv = list()
+ for(i in unique(parent)) cv[[i]] = child[parent==i]
+
+ cr = TRUE
+ }
+
+ el = tree$edge.length
+ cp = cv[[pa]]
+ sib = cp[cp!=ch]
+
+ edge[child==l,1] = pa
+ edge[child==pa,1] = pv[l]
+ edge[child==sib,1] = pv[pa]
+
+ el[child==sib] = el[child==sib] + el[child==pa]
+ el[child==l] = el[child==l] / 2
+ el[child==pa] = el[child==l]
+
+ tree$edge=edge
+ tree$edge.length = el
+ if(cr) tree <- changeEdge(tree,root,newroot)
+ tree <- reorder(tree, "postorder")
+ tree
+}
+
+
+rNNI <- function (tree, moves = 1, n = length(moves))
+{
+ k = length(na.omit(match(tree$edge[, 2], tree$edge[, 1])))
+ if (n == 1) {
+ trees = tree
+ if(moves>0){
+ for (i in 1:moves) trees = nnin(trees, sample(k, 1))[[sample(2,1)]]
+ }
+ trees$tip.label <- tree$tip.label
+ }
+ else {
+ trees = vector("list", n)
+ if(length(moves)==1) moves = rep(moves, n)
+ for (j in 1:n) {
+ tmp = tree
+ if(moves[j]>0){
+ for (i in 1:moves[j]) tmp = nnin(tmp, sample(k, 1))[[sample(2,1)]]
+ }
+ tmp$tip.label = NULL
+ trees[[j]] = tmp
+ }
+ attr(trees, "TipLabel") <- tree$tip.label
+ class(trees) <- "multiPhylo"
+ }
+ trees
+}
+
+
+#
+# some generic tree functions
+#
+allAncestors <- function(x){
+ x = reorder(x, "postorder")
+ parents <- x$edge[, 1]
+ child <- x$edge[, 2]
+ l = length(parents)
+ res <- vector("list",max(x$edge))
+ for(i in l:1){
+ pa = parents[i]
+ res[[child[i]]] = c(pa, res[[pa]])
+ }
+ res
+}
+
+
+Ancestors <- function (x, node, type = c("all", "parent"))
+{
+ parents <- x$edge[, 1]
+ child <- x$edge[, 2]
+ pvector <- numeric(max(x$edge)) # parents
+ pvector[child] <- parents
+ type <- match.arg(type)
+ if (type == "parent")
+ return(pvector[node])
+ anc <- function(pvector, node){
+ res <- numeric(0)
+ repeat {
+ anc <- pvector[node]
+ if (anc == 0) break
+ res <- c(res, anc)
+ node <- anc
+ }
+ res
+ }
+ if(length(node)==1) return(anc(pvector, node))
+ else allAncestors(x)[node]
+}
+
+
+allChildren <- function(x){
+ l = length(x$tip)
+ if(l<20){
+ parent = x$edge[,1]
+ children = x$edge[,2]
+ res = vector("list", max(x$edge))
+ for(i in 1:length(parent)) res[[parent[i]]] = c(res[[parent[i]]], children[i])
+ return(res)
+ }
+ else{
+ if (is.null(attr(x, "order")) || attr(x, "order") == "cladewise")
+ x <- reorder(x, "postorder")
+ parent = x$edge[,1]
+ children = x$edge[,2]
+ res <- .Call("AllChildren", as.integer(children), as.integer(parent), as.integer(max(x$edge))) # , PACKAGE="phangorn"
+ return(res)
+ }
+}
+
+
+Children <- function(x, node){
+ if(length(node)==1)return(x$edge[x$edge[,1]==node,2])
+ allChildren(x)[node]
+}
+
+
+Descendants = function(x, node, type=c("tips","children","all")){
+ type <- match.arg(type)
+ if(type=="children") return(Children(x, node))
+ if(type=="tips") return(bip(x)[node])
+ ch = allChildren(x) # out of the loop
+ isInternal = logical(max(x$edge))
+ isInternal[ unique(x$edge[,1]) ] =TRUE
+ desc = function(node, isInternal){
+ if(!isInternal[node])return(node)
+ res = NULL
+ while(length(node)>0){
+ tmp = unlist(ch[node])
+ res = c(res, tmp)
+ node = tmp[isInternal[tmp]]
+ }
+ res
+ }
+ if(length(node)>1) return(lapply(node, desc, isInternal))
+ desc(node, isInternal)
+}
+
+
+Siblings = function (x, node, include.self = FALSE)
+{
+ l = length(node)
+ if(l==1){
+ v <- Children(x, Ancestors(x, node, "parent"))
+ if (!include.self)
+ v <- v[v != node]
+ return(v)
+ }
+ else{
+ parents <- x$edge[, 1]
+ child <- x$edge[, 2]
+ pvector <- integer(max(x$edge)) # parents
+ pvector[child] <- parents
+ root <- as.integer(parents[!match(parents, child, 0)][1])
+ res = vector("list", l)
+ ch = allChildren(x)
+ k = 1
+ for(i in node){
+ if(i != root){
+ tmp <- ch[[ pvector[i] ]]
+ res[[k]] = tmp[tmp != i]
+ }
+ k=k+1
+ }
+ }
+ res
+}
+
+
+
+mrca.phylo <- function(x, node){
+ anc <- Ancestors(x, node, type = "all")
+ res <- Reduce(intersect, anc)[1]
+ res
+}
+
+# mrca.phylo <- getMRCA
+
+
+# 1090
+rNNI_Old <- function(tree, moves=1, n=1){
+ k = length(na.omit(match(tree$edge[,2], tree$edge[,1])))
+ if(n==1){
+ trees = tree
+ for(i in 1:moves) trees = nnin(trees,sample(k,1))[[sample(2,1)]]
+ trees$tip.label <- tree$tip.label
+ }
+ else{
+ trees = vector("list", n)
+ for(j in 1:n){
+ tmp = tree
+ for(i in 1:moves) tmp = nnin(tmp, sample(k,1))[[sample(2,1)]]
+ tmp$tip.label=NULL
+ trees[[j]] = tmp
+ }
+ attr(trees, "TipLabel") <- tree$tip.label
+ class(trees) <- "multiPhylo"
+ }
+ trees
+}
+
+
diff --git a/R/treedist.R b/R/treedist.R
new file mode 100644
index 0000000..1d68789
--- /dev/null
+++ b/R/treedist.R
@@ -0,0 +1,273 @@
+#
+# tree distance functions
+#
+
+allKids <- function(phy){
+ nTips = as.integer(length(phy$tip))
+ lp=nrow(phy$edge)
+ nNode = phy$Nnode
+ .C("AllKids", as.integer(phy$edge[,2]), as.integer(phy$edge[,1]), as.integer(nTips),
+ as.integer(nNode), as.integer(lp), integer(lp), integer(nNode+1L),integer(nNode))
+}
+
+
+coph <- function(x){
+ if (is.null(attr(x, "order")) || attr(x, "order") == "cladewise")
+ x <- reorder(x, "postorder")
+ nTips = as.integer(length(x$tip.label))
+ parents = as.integer(x$edge[,1])
+ kids = as.integer(x$edge[,2])
+ lp= as.integer(length(parents))
+ nNode = as.integer(x$Nnode)
+ m = as.integer(max(x$edge))
+ el = double(m)
+ el[kids] = x$edge.length
+ dm <- .C("C_cophenetic", kids, parents, as.double(el), lp, m, nTips, nNode, double(nTips*(nTips-1L)/2L))[[8]]
+ attr(dm, "Size") <- nTips
+ attr(dm, "Labels") <- x$tip.label
+ attr(dm, "Diag") <- FALSE
+ attr(dm, "Upper") <- FALSE
+ class(dm) <- "dist"
+ dm
+}
+
+
+SHORTwise <- function (x, nTips, delete=FALSE)
+{
+ v <- 1:nTips
+ l <- sapply(x, length)
+ lv = floor(nTips/2)
+ for (i in 1:length(x)) {
+ if(l[i]>lv){
+ y <- x[[i]]
+ x[[i]] <- v[-y]
+ }
+ if(l[i]==nTips/2){
+ y <- x[[i]]
+ if (y[1] != 1)
+ x[[i]] <- v[-y]
+ }
+ }
+ if(any(l==nTips) && delete){
+ x=x[l!=nTips]
+ }
+ x
+}
+
+
+oneWise <- function (x, nTips=NULL)
+{
+ if(is.null(nTips))nTips <- length(x[[1L]])
+ v <- 1:nTips
+ for (i in 2:length(x)) {
+ y <- x[[i]]
+ if (y[1] != 1)
+ x[[i]] <- v[-y]
+ }
+ x
+}
+
+
+treedist <- function (tree1, tree2, check.labels=TRUE)
+{
+ tree1 = unroot(tree1)
+ tree2 = unroot(tree2)
+
+ if (check.labels) {
+ ind <- match(tree1$tip.label, tree2$tip.label)
+ if (any(is.na(ind)) | length(tree1$tip.label) !=
+ length(tree2$tip.label))
+ stop("trees have different labels")
+ tree2$tip.label <- tree2$tip.label[ind]
+ ind2 <- match(1:length(ind), tree2$edge[, 2])
+ tree2$edge[ind2, 2] <- order(ind)
+ }
+
+ tree1 = reorder(tree1, "postorder")
+ tree2 = reorder(tree2, "postorder")
+
+ symmetric.difference = NULL
+ branch.score.difference = NULL
+ path.difference = NULL
+ quadratic.path.difference = NULL
+ if(!is.binary.tree(tree1) | !is.binary.tree(tree2))warning("Trees are not binary!")
+
+ bp1 = bip(tree1)
+ bp2 = bip(tree2)
+ bp1 <- SHORTwise(bp1, length(tree1$tip))
+ bp2 <- SHORTwise(bp2, length(tree2$tip))
+ bp1 <- sapply(bp1, paste, collapse = "_")
+ bp2 <- sapply(bp2, paste, collapse = "_")
+
+ l = length(tree1$tip.label)
+
+ if (!is.null(tree1$edge.length) & !is.null(tree2$edge.length)) {
+ dv1 = coph(tree1)
+ dv2 = coph(tree2)
+ quadratic.path.difference = sqrt(sum((dv1 - dv2)^2))
+
+ }
+
+ RF = sum(match(bp1, bp2, nomatch=0L)==0L) + sum(match(bp2, bp1, nomatch=0L)==0L)
+
+ symmetric.difference = RF #2 * (p - sum(r1))
+ if (!is.null(tree1$edge.length) & !is.null(tree2$edge.length)) {
+ w1 = numeric(max(tree1$edge))
+ w2 = numeric(max(tree2$edge))
+ w1[tree1$edge[,2]] = tree1$edge.length
+ w2[tree2$edge[,2]] = tree2$edge.length
+
+ v1 = tree1$edge.length
+ v2 = tree2$edge.length
+
+ ind3 = match(bp1, bp2, nomatch=0L)
+ ind4 = ind3[ind3>0]
+ ind3 = which(ind3>0)
+
+ s1 = sum((w1[ind3] - w2[ind4])^2)
+
+ s2 = sum(w1[-ind3]^2)
+ s3 = sum(w2[-ind4]^2)
+ branch.score.difference = sqrt(s1 + s2 + s3)
+ }
+
+ tree1$edge.length = rep(1, nrow(tree1$edge))
+ tree2$edge.length = rep(1, nrow(tree2$edge))
+
+ dt1 = coph(tree1)
+ dt2 = coph(tree2)
+ path.difference = sqrt(sum((dt1 - dt2)^2))
+
+ result = c(symmetric.difference = symmetric.difference,
+ branch.score.difference = branch.score.difference,
+ path.difference = path.difference,
+ quadratic.path.difference = quadratic.path.difference)
+ result
+}
+
+
+mRF2 <- function(tree, trees, check.labels = TRUE){
+ if (class(trees) != "multiPhylo")
+ stop("trees should be an object of class \"multiPhylo\"")
+ if (class(tree) != "phylo")
+ stop("trees should be an object of class \"phylo\"")
+ trees <- .compressTipLabel(trees)
+ tipLabel <- attr(trees, "TipLabel")
+ if (check.labels) {
+ ind <- match(tipLabel, tree$tip.label)
+ if (any(is.na(ind)) | length(tipLabel) != length(tree$tip.label))
+ stop("trees have different labels")
+ tree$tip.label <- tree$tip.label[ind]
+ ind2 <- match(1:length(ind), tree$edge[, 2])
+ tree$edge[ind2, 2] <- order(ind)
+ }
+ nTips <- length(tipLabel)
+ l <- length(trees)
+ RF <- numeric(l)
+ trees <- .uncompressTipLabel(trees)
+ # n <- length(attr(trees, "TipLabel"))
+ trees <- unclass(trees)
+ if (any(sapply(trees, is.rooted))) {
+ warning("Some trees are rooted. Unrooting all trees.\n")
+ trees <- lapply(trees, unroot)
+ }
+ if (any(sapply(trees, function(x) !is.binary.tree(x)))) {
+ warning("Some trees are not binary. Result may not what you expect!")
+ }
+ tree <- reorder(tree, "postorder")
+ trees <- lapply(trees, reorder, "postorder")
+ xx <- lapply(trees, bipart)
+ xx <- lapply(xx, SHORTwise, nTips)
+ xx <- lapply(xx,function(x)sapply(x, paste, collapse="_"))
+ yy <- bipart(tree)
+ yy <- SHORTwise(yy, nTips)
+ yy <- sapply(yy, paste, collapse="_")
+ for (i in 1:l){
+# RF[i] <- 2 * sum(fmatch(xx[[i]], yy, nomatch=0L)==0L)
+ RF[i] <- sum(match(xx[[i]], yy, nomatch=0L)==0L) + sum(match(yy, xx[[i]], nomatch=0L)==0L)
+ }
+ if(!is.null(names(trees)))names(RF) <- names(trees)
+ return(RF)
+}
+
+
+mRF<-function(trees){
+ if (class(trees) != "multiPhylo")
+ stop("trees should be an object of class \"multiPhylo\"")
+ trees <- .compressTipLabel(trees)
+ tipLabel <- attr(trees, "TipLabel")
+ nTips <- length(tipLabel)
+ l <- length(trees)
+ RF <- numeric((l * (l - 1))/2)
+ trees <- .uncompressTipLabel(trees)
+ # n <- length(attr(trees, "TipLabel"))
+ trees <- unclass(trees)
+ if (any(sapply(trees, is.rooted))) {
+ warning("Some trees are rooted. Unrooting all trees.\n")
+ trees <- lapply(trees, unroot)
+ }
+ if (any(sapply(trees, function(x) !is.binary.tree(x)))) {
+ warning("Some trees are not binary. Result may not what you expect!")
+ }
+ trees <- lapply(trees, reorder, "postorder")
+ xx <- lapply(trees, bipart)
+ xx <- lapply(xx, SHORTwise, nTips)
+ xx <- lapply(xx,function(x)sapply(x, paste, collapse="_"))
+ # returns list of character vectors
+ k=1
+ for (i in 1:(l - 1)){
+ tmp = xx[[i]]
+ for (j in (i + 1):l){
+# RF[k] <- 2 * sum(fmatch(xx[[j]], tmp, nomatch=0L)==0L)
+ RF[k] <- sum(match(xx[[j]], tmp, nomatch=0L)==0L) + sum(match(tmp, xx[[j]], nomatch=0L)==0L)
+ k=k+1
+ }
+ }
+ attr(RF, "Size") <- l
+ if(!is.null(names(trees)))attr(RF, "Labels") <- names(trees)
+ attr(RF, "Diag") <- FALSE
+ attr(RF, "Upper") <- FALSE
+ class(RF) <- "dist"
+ return(RF)
+}
+
+
+RF.dist <- function (tree1, tree2=NULL, check.labels = TRUE)
+{
+ if(class(tree1)=="multiPhylo" && is.null(tree2))return(mRF(tree1))
+ if(class(tree1)=="phylo" && class(tree2)=="multiPhylo")return(mRF2(tree1, tree2, check.labels))
+ if(class(tree2)=="phylo" && class(tree1)=="multiPhylo")return(mRF2(tree2, tree1, check.labels))
+ r1 = is.rooted(tree1)
+ r2 = is.rooted(tree2)
+ if(r1 != r2){
+ warning("one tree is unrooted, unrooted both")
+ }
+ if (check.labels) {
+ ind <- match(tree1$tip.label, tree2$tip.label)
+ if (any(is.na(ind)) | length(tree1$tip.label) !=
+ length(tree2$tip.label))
+ stop("trees have different labels")
+ tree2$tip.label <- tree2$tip.label[ind]
+ # tree2$edge[match(ind, tree2$edge[, 2]), 2] <- 1:length(ind)
+ ind2 <- match(1:length(ind), tree2$edge[, 2])
+ tree2$edge[ind2, 2] <- order(ind)
+ }
+
+ if(!r1 | !r2){
+ if(r1) tree1 = unroot(tree1)
+ if(r2) tree2 = unroot(tree2)
+# ref1 <- Ancestors(tree1, 1, "parent")
+# tree1 <- reroot(tree1, ref1)
+# ref2 <- Ancestors(tree2, 1, "parent")
+# tree2 <- reroot(tree2, ref2)
+ }
+ if(!is.binary.tree(tree1) | !is.binary.tree(tree2))warning("Trees are not binary!")
+ bp1 = bipart(tree1)
+ bp2 = bipart(tree2)
+
+ bp1 <- SHORTwise(bp1, length(tree1$tip))
+ bp2 <- SHORTwise(bp2, length(tree2$tip))
+
+ RF = sum(match(bp1, bp2, nomatch=0L)==0L) + sum(match(bp2, bp1, nomatch=0L)==0L)
+ RF
+}
diff --git a/R/zzz.R b/R/zzz.R
new file mode 100644
index 0000000..12b83b2
--- /dev/null
+++ b/R/zzz.R
@@ -0,0 +1,14 @@
+## zzz.R
+
+.packageName <- "phangorn"
+
+.aamodels <- c("WAG", "JTT", "LG", "Dayhoff", "cpREV", "mtmam", "mtArt", "MtZoa", "mtREV24", "VT","RtREV", "HIVw", "HIVb", "FLU","Blosum62","Dayhoff_DCMut","JTT_DCMut")
+
+
+# if g[i] is smaller .gEps inv is increased w[i]
+.gEps <- 1e-30
+
+
+# .onLoad <- function(libname, pkgname) {
+# library.dynam("phangorn", pkgname, libname)
+#}
diff --git a/README.md b/README.md
new file mode 100644
index 0000000..ef6aaef
--- /dev/null
+++ b/README.md
@@ -0,0 +1,17 @@
+phangorn
+========================================================
+
+phangorn is a package for phylogenetic reconstruction and analysis in the R language. phangorn offers the possibility of reconstructing phylogenies with distance based methods, maximum parsimony or maximum likelihood (ML) and performing Hadamard conjugation. Extending the general ML framework, this package provides the possibility of estimating mixture and partition models. Furthermore, phangorn offers several functions for comparing trees, phylogenetic models or splits, simulating chara [...]
+
+You can install
+- the latest released version `install.packages("phangorn")`
+- the latest development version `devtools::install_github("KlausVigo/phangorn")`
+
+If you use phangorn please cite:
+
+Schliep K.P. 2011. phangorn: phylogenetic analysis in R. Bioinformatics, 27(4) 592-593
+
+
+License
+-------
+phangorn is licensed under the GPLv2.
diff --git a/build/vignette.rds b/build/vignette.rds
new file mode 100644
index 0000000..8dfe031
Binary files /dev/null and b/build/vignette.rds differ
diff --git a/data/Laurasiatherian.RData b/data/Laurasiatherian.RData
new file mode 100644
index 0000000..019f2a4
Binary files /dev/null and b/data/Laurasiatherian.RData differ
diff --git a/data/chloroplast.RData b/data/chloroplast.RData
new file mode 100644
index 0000000..791df13
Binary files /dev/null and b/data/chloroplast.RData differ
diff --git a/data/yeast.RData b/data/yeast.RData
new file mode 100644
index 0000000..09c6256
Binary files /dev/null and b/data/yeast.RData differ
diff --git a/inst/CITATION b/inst/CITATION
new file mode 100644
index 0000000..e7fb23a
--- /dev/null
+++ b/inst/CITATION
@@ -0,0 +1,17 @@
+citHeader("To cite phangorn in a publication use:")
+
+citEntry(entry="Article",
+ title = "phangorn: phylogenetic analysis in R",
+ author = personList(as.person("K.P. Schliep")),
+ journal = "Bioinformatics",
+ year = "2011",
+ volume = "27",
+ number = "4",
+ pages = "592--593",
+ textVersion = "Schliep K.P. 2011. phangorn: phylogenetic analysis in R. Bioinformatics, 27(4) 592-593")
+
+citFooter("As phangorn is evolving quickly, you may want to cite also its version number (found with 'library(help = phangorn)').")
+
+
+if(!exists("meta") || is.null(meta)) meta <- packageDescription("phangorn")
+
diff --git a/inst/README b/inst/README
new file mode 100644
index 0000000..d143825
--- /dev/null
+++ b/inst/README
@@ -0,0 +1,22 @@
+The following persons and institutions helped in the development of
+phangorn at one stage or another.
+
+
+ Emmanuel Paradis and all the other authors of the APE package.
+
+ Tim White for provinding some C-code to compute the Hadamard distances.
+
+ Bennet McComish for providing the allTrees function.
+
+ Francois-Joiseph Lapointe for feedback on clans and clips.
+
+ Further thanks to all the user that send bug reports/fixes and have helped
+ to improve this package.
+
+ Financial support was provided by the Alan Wilson Centre of Molecular Ecology
+ and Evolution and the Muséum national d'Histoire naturelle and Universidade de Vigo.
+
+
+
+
+
diff --git a/inst/doc/Ancestral.R b/inst/doc/Ancestral.R
new file mode 100644
index 0000000..efb8b47
--- /dev/null
+++ b/inst/doc/Ancestral.R
@@ -0,0 +1,110 @@
+### R code from vignette source 'Ancestral.Rnw'
+
+###################################################
+### code chunk number 1: Ancestral.Rnw:44-46
+###################################################
+options(width=70)
+foo <- packageDescription("phangorn")
+
+
+###################################################
+### code chunk number 2: Ancestral.Rnw:61-66
+###################################################
+library(phangorn)
+primates = read.phyDat("primates.dna", format = "phylip", type = "DNA")
+tree = pratchet(primates, trace=0)
+tree = acctran(tree, primates)
+parsimony(tree, primates)
+
+
+###################################################
+### code chunk number 3: Ancestral.Rnw:72-74
+###################################################
+anc.acctran = ancestral.pars(tree, primates, "ACCTRAN")
+anc.mpr = ancestral.pars(tree, primates, "MPR")
+
+
+###################################################
+### code chunk number 4: plotLOGO
+###################################################
+tmp <- require(seqLogo)
+if(tmp) seqLogo( t(subset(anc.mpr, getRoot(tree), 1:20)[[1]]), ic.scale=FALSE)
+
+
+###################################################
+### code chunk number 5: figLOGO
+###################################################
+getOption("SweaveHooks")[["fig"]]()
+tmp <- require(seqLogo)
+if(tmp) seqLogo( t(subset(anc.mpr, getRoot(tree), 1:20)[[1]]), ic.scale=FALSE)
+
+
+###################################################
+### code chunk number 6: Ancestral.Rnw:93-95
+###################################################
+options(SweaveHooks=list(fig=function()
+par(mar=c(2.1, 4.1, 2.1, 2.1))))
+
+
+###################################################
+### code chunk number 7: plotMPR
+###################################################
+par(mfrow=c(2,1))
+plotAnc(tree, anc.mpr, 17)
+title("MPR")
+plotAnc(tree, anc.acctran, 17)
+title("ACCTRAN")
+
+
+###################################################
+### code chunk number 8: figMPR
+###################################################
+getOption("SweaveHooks")[["fig"]]()
+par(mfrow=c(2,1))
+plotAnc(tree, anc.mpr, 17)
+title("MPR")
+plotAnc(tree, anc.acctran, 17)
+title("ACCTRAN")
+
+
+###################################################
+### code chunk number 9: Ancestral.Rnw:122-124
+###################################################
+fit = pml(tree, primates)
+fit = optim.pml(fit, model="F81", control = pml.control(trace=0))
+
+
+###################################################
+### code chunk number 10: Ancestral.Rnw:136-138
+###################################################
+anc.ml = ancestral.pml(fit, "ml")
+anc.bayes = ancestral.pml(fit, "bayes")
+
+
+###################################################
+### code chunk number 11: plotMLB
+###################################################
+par(mfrow=c(2,1))
+plotAnc(tree, anc.ml, 17)
+title("ML")
+plotAnc(tree, anc.bayes, 17)
+title("Bayes")
+
+
+###################################################
+### code chunk number 12: figMLB
+###################################################
+getOption("SweaveHooks")[["fig"]]()
+par(mfrow=c(2,1))
+plotAnc(tree, anc.ml, 17)
+title("ML")
+plotAnc(tree, anc.bayes, 17)
+title("Bayes")
+
+
+###################################################
+### code chunk number 13: Ancestral.Rnw:162-163
+###################################################
+toLatex(sessionInfo())
+
+
diff --git a/inst/doc/Ancestral.Rnw b/inst/doc/Ancestral.Rnw
new file mode 100644
index 0000000..09473be
--- /dev/null
+++ b/inst/doc/Ancestral.Rnw
@@ -0,0 +1,171 @@
+%\VignetteIndexEntry{Ancestral Sequence Reconstruction}
+%\VignetteKeywords{Documentation}
+%\VignettePackage{phangorn}
+%\VignetteEngine{Sweave}
+\documentclass[12pt]{article}
+
+\usepackage{times}
+\usepackage{hyperref}
+
+\newcommand{\Rfunction}[1]{{\texttt{#1}}}
+\newcommand{\Robject}[1]{{\texttt{#1}}}
+\newcommand{\Rpackage}[1]{{\textit{#1}}}
+\newcommand{\Rmethod}[1]{{\texttt{#1}}}
+\newcommand{\Rfunarg}[1]{{\texttt{#1}}}
+\newcommand{\Rclass}[1]{{\textit{#1}}}
+
+\textwidth=6.2in
+\textheight=8.5in
+%\parskip=.3cm
+\oddsidemargin=.1in
+\evensidemargin=.1in
+\headheight=-.3in
+
+\newcommand{\R}{\textsf{R}}
+\newcommand{\pml}{\Robject{pml}}
+\newcommand{\phangorn}{\Rpackage{phangorn}}
+\newcommand{\ape}{\Rpackage{ape}}
+\newcommand{\multicore}{\Rpackage{multicore}}
+
+\newcommand{\term}[1]{\emph{#1}}
+\newcommand{\mref}[2]{\htmladdnormallinkfoot{#2}{#1}}
+
+
+
+\begin{document}
+
+% Ross Ihakas extenstion for nicer representation
+\DefineVerbatimEnvironment{Sinput}{Verbatim} {xleftmargin=2em}
+\DefineVerbatimEnvironment{Soutput}{Verbatim}{xleftmargin=2em}
+\DefineVerbatimEnvironment{Scode}{Verbatim}{xleftmargin=2em}
+\fvset{listparameters={\setlength{\topsep}{0pt}}}
+\renewenvironment{Schunk}{\vspace{\topsep}}{\vspace{\topsep}}
+
+<<echo=FALSE>>=
+options(width=70)
+foo <- packageDescription("phangorn")
+@
+
+
+
+\title{Ancestral sequence reconstruction with phangorn (Version \Sexpr{foo$Version})} %$
+\author{\mref{mailto:klaus.schliep at gmail.com}{Klaus P. Schliep}}
+\maketitle
+
+\nocite{Paradis2006}
+\section{Introduction}
+
+These notes describe the ancestral sequence reconstruction using the \phangorn{} package \cite{Schliep2011}. \phangorn{} provides several methods to estimate ancestral character states with either Maximum Parsimony (MP) or Maximum Likelihood (ML). %For more background on all the methods see e.g. \cite{Felsenstein2004, Yang2006}.
+\section{Parsimony reconstructions}
+To reconstruct ancestral sequences we first load some data and reconstruct a tree:
+<<echo=TRUE>>=
+library(phangorn)
+primates = read.phyDat("primates.dna", format = "phylip", type = "DNA")
+tree = pratchet(primates, trace=0)
+tree = acctran(tree, primates)
+parsimony(tree, primates)
+@
+
+For parsimony analysis of the edge length represent the observed number of changes. Reconstructing ancestral states therefore defines also the edge lengths of a tree. However there can exist several equally parsimonious reconstructions or states can be ambiguous and therefore edge length can differ. %\phangorn{} brakes them equally down.
+"MPR" reconstructs the ancestral states for each (internal) node as if the tree would be rooted in that node. However the nodes are not independent of each other. If one chooses one state for a specific node, this can restrict the choice of neighbouring nodes (figure \ref{fig:Pars}).
+The function acctran (accelerated transformation) assigns edge length and internal nodes to the tree \cite{Swofford1987}.
+<<echo=TRUE>>=
+anc.acctran = ancestral.pars(tree, primates, "ACCTRAN")
+anc.mpr = ancestral.pars(tree, primates, "MPR")
+@
+
+All the ancestral reconstructions for parsimony are based on the fitch algorithm and so far only bifurcating trees are allowed. However trees can get pruned afterwards using the function \Rfunction{multi2di} from \ape{}.
+
+
+<<label=plotLOGO,include=FALSE>>=
+tmp <- require(seqLogo)
+if(tmp) seqLogo( t(subset(anc.mpr, getRoot(tree), 1:20)[[1]]), ic.scale=FALSE)
+@
+\begin{figure}
+\begin{center}
+<<label=figLOGO,fig=TRUE,echo=FALSE,width=6,height=4>>=
+<<plotLOGO>>
+@
+\caption{Representation for the reconstruction of the first 20 characters for the root node.}
+\end{center}
+\end{figure}
+
+<<echo=false>>=
+options(SweaveHooks=list(fig=function()
+par(mar=c(2.1, 4.1, 2.1, 2.1))))
+@
+
+<<label=plotMPR,include=FALSE>>=
+par(mfrow=c(2,1))
+plotAnc(tree, anc.mpr, 17)
+title("MPR")
+plotAnc(tree, anc.acctran, 17)
+title("ACCTRAN")
+@
+\begin{figure}
+\begin{center}
+<<label=figMPR,fig=TRUE,echo=FALSE,width=6,height=9>>=
+<<plotMPR>>
+@
+\caption{Ancestral reconstruction for one character for the "MPR" and "ACCTRAN" reconstruction.
+When nodes contain several colours reconstruction is not unique!}\label{fig:Pars}
+\end{center}
+\end{figure}
+
+
+
+\section{Likelihood reconstructions}
+
+\phangorn{} also offers the possibility to estimate ancestral states using a ML.
+The advantages of ML over parsimony is that the reconstruction accounts for different edge lengths.
+So far only a marginal construction is implemented (see \cite{Yang2006}).
+<<echo=TRUE>>=
+fit = pml(tree, primates)
+fit = optim.pml(fit, model="F81", control = pml.control(trace=0))
+@
+We can assign the ancestral states according to the highest likelihood ("ml"):
+\[
+P(x_r = A) = \frac{L(x_r=A)}{\sum_{k \in \{A,C,G,T\}}L(x_r=k)}
+\]
+and the highest posterior probability ("bayes") criterion:
+\[
+P(x_r=A) = \frac{\pi_A L(x_r=A)}{\sum_{k \in \{A,C,G,T\}}\pi_k L(x_r=k)},
+\]
+where $L(x_r)$ is the joint probability of states at the tips and the state at the root $x_r$ and $\pi_i$ are the estimated base frequencies of state $i$.
+Both methods agree if all states (base frequencies) have equal probabilities.
+<<echo=TRUE>>=
+anc.ml = ancestral.pml(fit, "ml")
+anc.bayes = ancestral.pml(fit, "bayes")
+@
+The differences of the two approaches for a specific site (17) are represented in figure\ref{fig:MLB}.
+<<label=plotMLB,include=FALSE>>=
+par(mfrow=c(2,1))
+plotAnc(tree, anc.ml, 17)
+title("ML")
+plotAnc(tree, anc.bayes, 17)
+title("Bayes")
+@
+\begin{figure}
+\begin{center}
+<<label=figMLB,fig=TRUE,echo=FALSE,width=6,height=9>>=
+<<plotMLB>>
+@
+\caption{Ancestral reconstruction for fig.\ref{fig:Pars} the using the maximum likelihood and (empirical) Bayesian reconstruction.}\label{fig:MLB}
+\end{center}
+\end{figure}
+
+\bibliographystyle{plain}
+\bibliography{phangorn}
+
+\section{Session Information}
+The version number of \R{} and packages loaded for generating the vignette were:
+<<echo=FALSE,results=tex>>=
+toLatex(sessionInfo())
+@
+
+\end{document}
+
+
+
+
+
diff --git a/inst/doc/Ancestral.pdf b/inst/doc/Ancestral.pdf
new file mode 100644
index 0000000..35de42c
Binary files /dev/null and b/inst/doc/Ancestral.pdf differ
diff --git a/inst/doc/Networx.R b/inst/doc/Networx.R
new file mode 100644
index 0000000..c8bce36
--- /dev/null
+++ b/inst/doc/Networx.R
@@ -0,0 +1,44 @@
+## ----, eval=TRUE---------------------------------------------------------
+library(phangorn)
+data(Laurasiatherian)
+data(yeast)
+
+## ----, eval=TRUE---------------------------------------------------------
+set.seed(1)
+bs <- bootstrap.phyDat(yeast, FUN = function(x)nj(dist.hamming(x)),
+ bs=100)
+tree <- nj(dist.hamming(yeast))
+par("mar" = rep(2, 4))
+tree <- plotBS(tree, bs, "phylogram")
+cnet <- consensusNet(bs, .3)
+plot(cnet, "2D", show.edge.label=TRUE)
+
+## ----, eval=FALSE--------------------------------------------------------
+# plot(cnet)
+# # rotate 3d plot
+# play3d(spin3d(axis=c(0,1,0), rpm=6), duration=10)
+# # create animated gif file
+# movie3d(spin3d(axis=c(0,1,0), rpm=6), duration=10)
+
+## ----, eval=TRUE---------------------------------------------------------
+dm <- dist.hamming(yeast)
+nnet <- neighborNet(dm)
+par("mar" = rep(2, 4))
+plot(nnet, "2D")
+
+## ----, eval=TRUE---------------------------------------------------------
+nnet <- addConfidences(nnet, tree)
+par("mar" = rep(2, 4))
+plot(nnet, "2D", show.edge.label=TRUE)
+
+## ----, eval=TRUE---------------------------------------------------------
+tree2 <- rNNI(tree, 2)
+tree2 <- addConfidences(tree2, tree)
+# several support values are missing
+plot(tree2, show.node.label=TRUE)
+
+## ----, eval=TRUE---------------------------------------------------------
+cnet <- nnls.networx(cnet, dm)
+par("mar" = rep(2, 4))
+plot(cnet, "2D", show.edge.label=TRUE)
+
diff --git a/inst/doc/Networx.Rmd b/inst/doc/Networx.Rmd
new file mode 100644
index 0000000..8acfaf9
--- /dev/null
+++ b/inst/doc/Networx.Rmd
@@ -0,0 +1,96 @@
+---
+title: "Splits and Networx"
+author: "Klaus Schliep"
+date: "`r format(Sys.time(), '%B %d, %Y')`"
+output: rmarkdown::html_vignette
+bibliography: phangorn.bib
+vignette: >
+ %\VignetteIndexEntry{Splits and Networx}
+ %\VignetteEngine{knitr::rmarkdown}
+ %\usepackage[utf8]{inputenc}
+---
+
+
+This tutorial gives a basic introduction on constructing phylogenetic networks and to add parameter to trees or networx using [phangorn](http://cran.r-project.org/web/packages/phangorn/) [@Schliep2011] in R.
+Splits graph or phylogenetic networks are a nice way to display conflict data or summarize different trees. Here we present to popular networks, consensus networks [@Holland2004]
+and neighborNet [@Bryant2004].
+Often trees or networks are missing either edge weights or support values about the edges. We show how to improve a tree/networx by adding support values or estimating edge weights using non-negative Least-Squares (nnls).
+
+We first load the phangorn package and a few data sets we use in this vignette.
+```{r, eval=TRUE}
+library(phangorn)
+data(Laurasiatherian)
+data(yeast)
+```
+## consensusNet
+A consensusNet [@Holland2004] is a generalization of a consensus tree. Instead only representing splits with at least 50% in a bootstrap or MCMC sample one can use a lower threshold. However of important competing splits are left out.
+
+The input for `consensusNet` is a list of trees i.e. an object of class `multiPhylo`.
+```{r, eval=TRUE}
+set.seed(1)
+bs <- bootstrap.phyDat(yeast, FUN = function(x)nj(dist.hamming(x)),
+ bs=100)
+tree <- nj(dist.hamming(yeast))
+par("mar" = rep(2, 4))
+tree <- plotBS(tree, bs, "phylogram")
+cnet <- consensusNet(bs, .3)
+plot(cnet, "2D", show.edge.label=TRUE)
+```
+
+Often `consensusNet` will return incompatible splits, which cannot plotted as a planar graph. A nice way to get still a good impression of the network is to plot it in 3 dimensions.
+
+```{r, eval=FALSE}
+plot(cnet)
+# rotate 3d plot
+play3d(spin3d(axis=c(0,1,0), rpm=6), duration=10)
+# create animated gif file
+movie3d(spin3d(axis=c(0,1,0), rpm=6), duration=10)
+```
+
+which will result in a spinning graph similar to this
+
+
+
+
+## neighborNet
+The function `neighborNet` implements the popular method of @Bryant2004. The Neighbor-Net algorithm extends the Neighbor joining allowing again algorithm is computed in 2 parts, the first computes a circular ordering. The second step involves estimation of edge weights using non-negative Least-Squares (nnls).
+
+```{r, eval=TRUE}
+dm <- dist.hamming(yeast)
+nnet <- neighborNet(dm)
+par("mar" = rep(2, 4))
+plot(nnet, "2D")
+```
+
+The advantage of Neighbor-Net is that it returns a circular split system which can be always displayed in a planar (2D) graph. The plots displayed in `phangorn` may not planar, but re-plotting may gives you a planar graph. This unwanted behavior will be improved in future version.
+The rendering of the `networx` is done using the the fantastic igraph package [@Csardi2006].
+
+
+## Adding support values
+
+We can use the generic function `addConfidences` to add support values from a tree, i.e. an object of class `phylo` to a `networx`, `splits` or `phylo` object. The Neighbor-Net object we computed above contains no support values. We can add the support values fro the tree we computed to the splits these two objects share.
+```{r, eval=TRUE}
+nnet <- addConfidences(nnet, tree)
+par("mar" = rep(2, 4))
+plot(nnet, "2D", show.edge.label=TRUE)
+```
+
+We can also add support values to a tree:
+```{r, eval=TRUE}
+tree2 <- rNNI(tree, 2)
+tree2 <- addConfidences(tree2, tree)
+# several support values are missing
+plot(tree2, show.node.label=TRUE)
+```
+
+## Estimating edge weights (nnls)
+
+Consensus networks on the other hand have information about support values corresponding to a split, but are generally without edge weights.
+Given a distance matrix we can estimate edge weights using non-negative Least-Squares.
+```{r, eval=TRUE}
+cnet <- nnls.networx(cnet, dm)
+par("mar" = rep(2, 4))
+plot(cnet, "2D", show.edge.label=TRUE)
+```
+
+## References
diff --git a/inst/doc/Networx.html b/inst/doc/Networx.html
new file mode 100644
index 0000000..bc15b66
--- /dev/null
+++ b/inst/doc/Networx.html
@@ -0,0 +1,143 @@
+<!DOCTYPE html>
+
+<html xmlns="http://www.w3.org/1999/xhtml">
+
+<head>
+
+<meta charset="utf-8">
+<meta http-equiv="Content-Type" content="text/html; charset=utf-8" />
+<meta name="generator" content="pandoc" />
+
+<meta name="author" content="Klaus Schliep" />
+
+<meta name="date" content="2015-02-13" />
+
+<title>Splits and Networx</title>
+
+
+
+<style type="text/css">code{white-space: pre;}</style>
+<style type="text/css">
+table.sourceCode, tr.sourceCode, td.lineNumbers, td.sourceCode {
+ margin: 0; padding: 0; vertical-align: baseline; border: none; }
+table.sourceCode { width: 100%; line-height: 100%; }
+td.lineNumbers { text-align: right; padding-right: 4px; padding-left: 4px; color: #aaaaaa; border-right: 1px solid #aaaaaa; }
+td.sourceCode { padding-left: 5px; }
+code > span.kw { color: #007020; font-weight: bold; }
+code > span.dt { color: #902000; }
+code > span.dv { color: #40a070; }
+code > span.bn { color: #40a070; }
+code > span.fl { color: #40a070; }
+code > span.ch { color: #4070a0; }
+code > span.st { color: #4070a0; }
+code > span.co { color: #60a0b0; font-style: italic; }
+code > span.ot { color: #007020; }
+code > span.al { color: #ff0000; font-weight: bold; }
+code > span.fu { color: #06287e; }
+code > span.er { color: #ff0000; font-weight: bold; }
+</style>
+<style type="text/css">
+ pre:not([class]) {
+ background-color: white;
+ }
+</style>
+
+
+<link href="data:text/css,body%20%7B%0A%20%20background%2Dcolor%3A%20%23fff%3B%0A%20%20margin%3A%201em%20auto%3B%0A%20%20max%2Dwidth%3A%20700px%3B%0A%20%20overflow%3A%20visible%3B%0A%20%20padding%2Dleft%3A%202em%3B%0A%20%20padding%2Dright%3A%202em%3B%0A%20%20font%2Dfamily%3A%20%22Open%20Sans%22%2C%20%22Helvetica%20Neue%22%2C%20Helvetica%2C%20Arial%2C%20sans%2Dserif%3B%0A%20%20font%2Dsize%3A%2014px%3B%0A%20%20line%2Dheight%3A%201%2E35%3B%0A%7D%0A%0A%23header%20%7B%0A%20%20text%2Dalign%3A% [...]
+
+</head>
+
+<body>
+
+
+
+<div id="header">
+<h1 class="title">Splits and Networx</h1>
+<h4 class="author"><em>Klaus Schliep</em></h4>
+<h4 class="date"><em>February 13, 2015</em></h4>
+</div>
+
+
+<p>This tutorial gives a basic introduction on constructing phylogenetic networks and to add parameter to trees or networx using <a href="http://cran.r-project.org/web/packages/phangorn/">phangorn</a> <span class="citation">(Schliep 2011)</span> in R. Splits graph or phylogenetic networks are a nice way to display conflict data or summarize different trees. Here we present to popular networks, consensus networks <span class="citation">(Holland et al. 2004)</span> and neighborNet <span cl [...]
+<p>We first load the phangorn package and a few data sets we use in this vignette.</p>
+<pre class="sourceCode r"><code class="sourceCode r"><span class="kw">library</span>(phangorn)</code></pre>
+<pre><code>## Loading required package: ape</code></pre>
+<pre class="sourceCode r"><code class="sourceCode r"><span class="kw">data</span>(Laurasiatherian)
+<span class="kw">data</span>(yeast)</code></pre>
+<div id="consensusnet" class="section level2">
+<h2>consensusNet</h2>
+<p>A consensusNet <span class="citation">(Holland et al. 2004)</span> is a generalization of a consensus tree. Instead only representing splits with at least 50% in a bootstrap or MCMC sample one can use a lower threshold. However of important competing splits are left out.</p>
+<p>The input for <code>consensusNet</code> is a list of trees i.e. an object of class <code>multiPhylo</code>.</p>
+<pre class="sourceCode r"><code class="sourceCode r"><span class="kw">set.seed</span>(<span class="dv">1</span>)
+bs <-<span class="st"> </span><span class="kw">bootstrap.phyDat</span>(yeast, <span class="dt">FUN =</span> function(x)<span class="kw">nj</span>(<span class="kw">dist.hamming</span>(x)),
+ <span class="dt">bs=</span><span class="dv">100</span>)
+tree <-<span class="st"> </span><span class="kw">nj</span>(<span class="kw">dist.hamming</span>(yeast))
+<span class="kw">par</span>(<span class="st">"mar"</span> =<span class="st"> </span><span class="kw">rep</span>(<span class="dv">2</span>, <span class="dv">4</span>))
+tree <-<span class="st"> </span><span class="kw">plotBS</span>(tree, bs, <span class="st">"phylogram"</span>)</code></pre>
+<p><img src="data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAASAAAAEgCAMAAAAjXV6yAAAC/VBMVEUAAAABAQECAgIDAwMEBAQFBQUGBgYHBwcICAgJCQkKCgoLCwsMDAwNDQ0ODg4PDw8QEBARERESEhITExMUFBQVFRUWFhYXFxcYGBgZGRkaGhobGxscHBwdHR0eHh4fHx8gICAhISEiIiIjIyMkJCQlJSUmJiYnJycoKCgpKSkqKiorKyssLCwtLS0uLi4vLy8wMDAxMTEyMjIzMzM0NDQ1NTU2NjY3Nzc4ODg5OTk6Ojo7Ozs8PDw9PT0+Pj4/Pz9AQEBBQUFCQkJDQ0NERERFRUVGRkZHR0dISEhJSUlKSkpLS0tMTExNTU1OTk5PT09QUFBRUVFSUlJTU1NUVFRVVVVWVlZXV1dYWFhZWVlaWlpbW1tcXFxdXV1eXl5fX19gYGBhYWFiYmJjY2NkZ [...]
+<pre class="sourceCode r"><code class="sourceCode r">cnet <-<span class="st"> </span><span class="kw">consensusNet</span>(bs, .<span class="dv">3</span>)
+<span class="kw">plot</span>(cnet, <span class="st">"2D"</span>, <span class="dt">show.edge.label=</span><span class="ot">TRUE</span>)</code></pre>
+<p><img src="data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAASAAAAEgCAIAAACb4TnXAAAACXBIWXMAAA7DAAAOwwHHb6hkAAAgAElEQVR4nO2deVxTV/r/PzcBQkgCIbLJEpRFNpFFFAW1LnU6Y1fr1r3T1qpt1WrHWnVal7E/W8dp7eJ0rJ06tbNY2zp1+da2YrF2qChhcUEQAVllJ6wJIcs9vz9umgACboRAct6vvvq6uc9NODfy4Zz7nGdhCCGgUCiWgWftAVAotgwVGIViQajAKBQLQgVGoVgQKjAKxYJQgVEoFoQKjEKxIFRgFIoFoQKjUCwIFRiFYkGowCgUC0IFRqFYECowCsWCUIFRKBaECoxCsSBUYBSKBaECo1AsCBUYhWJBqMAoFAtCBUahWBAqMArFglCBUSgWhAqMQrEgVGAUigWhAqNQLAgVGIViQajAKBQLQgVGoVgQKjAKxYJQgVEoF [...]
+<p>Often <code>consensusNet</code> will return incompatible splits, which cannot plotted as a planar graph. A nice way to get still a good impression of the network is to plot it in 3 dimensions.</p>
+<pre class="sourceCode r"><code class="sourceCode r"><span class="kw">plot</span>(cnet)
+<span class="co"># rotate 3d plot</span>
+<span class="kw">play3d</span>(<span class="kw">spin3d</span>(<span class="dt">axis=</span><span class="kw">c</span>(<span class="dv">0</span>,<span class="dv">1</span>,<span class="dv">0</span>), <span class="dt">rpm=</span><span class="dv">6</span>), <span class="dt">duration=</span><span class="dv">10</span>)
+<span class="co"># create animated gif file </span>
+<span class="kw">movie3d</span>(<span class="kw">spin3d</span>(<span class="dt">axis=</span><span class="kw">c</span>(<span class="dv">0</span>,<span class="dv">1</span>,<span class="dv">0</span>), <span class="dt">rpm=</span><span class="dv">6</span>), <span class="dt">duration=</span><span class="dv">10</span>)</code></pre>
+<p>which will result in a spinning graph similar to this</p>
+<p><img src="data:image/gif;base64,R0lGODlhAAEAAfQQAAAA/xgY9y8v719f3nd31kdH576+vo6OzqamxsbGxs7OztbW1t7e3ufn5+/v7/f39////wAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAAACH5BAAKAAAAIf8LTkVUU0NBUEUyLjADAQAAACwAAAAAAAEAAQAF/iAkjmRpnmiqrmzrvnAsz3Rt33iu73zv/8CgcEgsGo/IpHLJbDqf0Kh0Sq1ar9isdsvter/gsHhMLpvP6LR6zW673/C4fE6v2+/4vH7P7/v/gIGCg4SFhoeIiYqLjI2Oj5CRkpOUlZaXmJmam5ydnkIAoaGfmwAlpqSXqKeplqskrwYHBQ8joq+mo619uigBBgYJqLi2r7u8xiIADMAMw7C2x4O9EKbABg3KrNrS08MP18W3q8ndduXDzAYK0Sfl5nXoy [...]
+</div>
+<div id="neighbornet" class="section level2">
+<h2>neighborNet</h2>
+<p>The function <code>neighborNet</code> implements the popular method of <span class="citation">Bryant and Moulton (2004)</span>. The Neighbor-Net algorithm extends the Neighbor joining allowing again algorithm is computed in 2 parts, the first computes a circular ordering. The second step involves estimation of edge weights using non-negative Least-Squares (nnls).</p>
+<pre class="sourceCode r"><code class="sourceCode r">dm <-<span class="st"> </span><span class="kw">dist.hamming</span>(yeast)
+nnet <-<span class="st"> </span><span class="kw">neighborNet</span>(dm)
+<span class="kw">par</span>(<span class="st">"mar"</span> =<span class="st"> </span><span class="kw">rep</span>(<span class="dv">2</span>, <span class="dv">4</span>))
+<span class="kw">plot</span>(nnet, <span class="st">"2D"</span>)</code></pre>
+<p><img src="data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAASAAAAEgCAIAAACb4TnXAAAACXBIWXMAAA7DAAAOwwHHb6hkAAAgAElEQVR4nO3de3hTZZ4H8O9J0vSS9EKBNr0CvSVp2hQKtChVlBEdH0dHxcuIAyPsirgrio7r42V0YJzxMuyj464+42XUdZx9fHCHFZwFV0BEt0yBNIW2ofcKhdL7Lb2mSZuzf5xwmqb3yzmnTX6fxz84J036pvbb8+Z33gvDsiwIIcKQSd0AQrwZBYwQAVHACBEQBYwQAVHACBEQBYwQAVHACBEQBYwQAVHACBEQBYwQAVHACBEQBYwQAVHACBEQBYwQAVHACBEQBYwQAVHACBEQBYwQAVHACBEQBYwQAVHACBEQBYwQAVHACBEQBYwQAVHACBEQBYwQAVHACBEQBYwQAVHACBEQBYwQAVHACBEQBYwQAVHACBEQBYwQA [...]
+<p>The advantage of Neighbor-Net is that it returns a circular split system which can be always displayed in a planar (2D) graph. The plots displayed in <code>phangorn</code> may not planar, but re-plotting may gives you a planar graph. This unwanted behavior will be improved in future version. The rendering of the <code>networx</code> is done using the the fantastic igraph package <span class="citation">(Csardi and Nepusz 2006)</span>.</p>
+</div>
+<div id="adding-support-values" class="section level2">
+<h2>Adding support values</h2>
+<p>We can use the generic function <code>addConfidences</code> to add support values from a tree, i.e. an object of class <code>phylo</code> to a <code>networx</code>, <code>splits</code> or <code>phylo</code> object. The Neighbor-Net object we computed above contains no support values. We can add the support values fro the tree we computed to the splits these two objects share.</p>
+<pre class="sourceCode r"><code class="sourceCode r">nnet <-<span class="st"> </span><span class="kw">addConfidences</span>(nnet, tree)
+<span class="kw">par</span>(<span class="st">"mar"</span> =<span class="st"> </span><span class="kw">rep</span>(<span class="dv">2</span>, <span class="dv">4</span>))
+<span class="kw">plot</span>(nnet, <span class="st">"2D"</span>, <span class="dt">show.edge.label=</span><span class="ot">TRUE</span>)</code></pre>
+<p><img src="data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAASAAAAEgCAIAAACb4TnXAAAACXBIWXMAAA7DAAAOwwHHb6hkAAAgAElEQVR4nO3deXhU1f0/8PedLZlMlsmEkJUEEiAJSUgMhFiTgmBRqcojWrFqRaEswk+sS2ur1gr1cW9FvmoLPH7d+kW+WHwMfisoYBCFsEzCZlYCZCUbCdm3ycx8fn/c6yQB2ULu3Jnk83r44+aemcm5A2/uveece45ARGCMyUOldAUYG844YIzJiAPGmIw4YIzJiAPGmIw4YIzJiAPGmIw4YIzJiAPGmIw4YIzJiAPGmIw4YIzJiAPGmIw4YIzJiAPGmIw4YIzJiAPGmIw4YIzJiAPGmIw4YIzJiAPGmIw4YIzJiAPGmIw4YIzJiAPGmIw4YIzJiAPGmIw4YIzJiAPGmIw4YIzJiAPGmIw4YIzJiAPGmIw4YIzJiAPGm [...]
+<p>We can also add support values to a tree:</p>
+<pre class="sourceCode r"><code class="sourceCode r">tree2 <-<span class="st"> </span><span class="kw">rNNI</span>(tree, <span class="dv">2</span>)
+tree2 <-<span class="st"> </span><span class="kw">addConfidences</span>(tree2, tree)
+<span class="co"># several support values are missing</span>
+<span class="kw">plot</span>(tree2, <span class="dt">show.node.label=</span><span class="ot">TRUE</span>)</code></pre>
+<p><img src="data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAASAAAAEgCAMAAAAjXV6yAAAC61BMVEUAAAABAQECAgIDAwMEBAQFBQUGBgYHBwcICAgJCQkKCgoLCwsMDAwNDQ0ODg4PDw8QEBARERESEhITExMUFBQVFRUWFhYXFxcYGBgZGRkaGhobGxscHBwdHR0eHh4fHx8gICAhISEiIiIjIyMkJCQlJSUmJiYnJycoKCgpKSkqKiorKyssLCwtLS0uLi4vLy8wMDAxMTEyMjIzMzM0NDQ1NTU2NjY3Nzc4ODg5OTk6Ojo7Ozs8PDw9PT0+Pj4/Pz9AQEBBQUFCQkJERERFRUVGRkZISEhJSUlKSkpLS0tMTExNTU1OTk5PT09QUFBRUVFSUlJTU1NUVFRVVVVWVlZXV1dYWFhZWVlaWlpbW1tcXFxdXV1eXl5fX19gYGBhYWFiYmJkZGRlZWVmZmZnZ [...]
+</div>
+<div id="estimating-edge-weights-nnls" class="section level2">
+<h2>Estimating edge weights (nnls)</h2>
+<p>Consensus networks on the other hand have information about support values corresponding to a split, but are generally without edge weights. Given a distance matrix we can estimate edge weights using non-negative Least-Squares.</p>
+<pre class="sourceCode r"><code class="sourceCode r">cnet <-<span class="st"> </span><span class="kw">nnls.networx</span>(cnet, dm)
+<span class="kw">par</span>(<span class="st">"mar"</span> =<span class="st"> </span><span class="kw">rep</span>(<span class="dv">2</span>, <span class="dv">4</span>))
+<span class="kw">plot</span>(cnet, <span class="st">"2D"</span>, <span class="dt">show.edge.label=</span><span class="ot">TRUE</span>)</code></pre>
+<p><img src="data:image/png;base64,iVBORw0KGgoAAAANSUhEUgAAASAAAAEgCAIAAACb4TnXAAAACXBIWXMAAA7DAAAOwwHHb6hkAAAgAElEQVR4nO3deVhU59k/8O+ZGRhmhmEH2RERARFBXLBCjCYmGlOXGKPZtDVJK3nT5I1JaqNtjTZt2jS9YrNr2iymSayNeYPJW/NGE6P94RIHUBAXXAHZZV8GZr1/f5xxZkBARQ6DcH+u/MHMc2Y4g/nOOec59/M8AhGBMSYNmat3gLGhjAPGmIQ4YIxJiAPGmIQ4YIxJiAPGmIQ4YIxJiAPGmIQ4YIxJiAPGmIQ4YIxJiAPGmIQ4YIxJiAPGmIQ4YIxJiAPGmIQ4YIxJiAPGmIQ4YIxJiAPGmIQ4YIxJiAPGmIQ4YIxJiAPGmIQ4YIxJiAPGmIQ4YIxJiAPGmIQ4YIxJiAPGmIQ4YIxJiAPGmIQ4YIxJiAPGmIQ4YIxJi [...]
+<div class="references">
+<h2>References</h2>
+<p>Bryant, David, and Vincent Moulton. 2004. “Neighbor-Net: An Agglomerative Method for the Construction of Phylogenetic Networks.” <em>Molecular Biology and Evolution</em> 21 (2): 255–65. doi:<a href="http://dx.doi.org/10.1093/molbev/msh018">10.1093/molbev/msh018</a>. <a href="http://mbe.oxfordjournals.org/content/21/2/255.abstract">http://mbe.oxfordjournals.org/content/21/2/255.abstract</a>.</p>
+<p>Csardi, Gabor, and Tamas Nepusz. 2006. “The Igraph Software Package for Complex Network Research.” <em>InterJournal</em> Complex Systems: 1695. <a href="http://igraph.org">http://igraph.org</a>.</p>
+<p>Holland, Barbara R., Katharina T. Huber, Vincent Moulton, and Peter J. Lockhart. 2004. “Using Consensus Networks to Visualize Contradictory Evidence for Species Phylogeny.” <em>Molecular Biology and Evolution</em> 21 (7): 1459–61. doi:<a href="http://dx.doi.org/10.1093/molbev/msh145">10.1093/molbev/msh145</a>. <a href="http://mbe.oxfordjournals.org/content/21/7/1459.abstract">http://mbe.oxfordjournals.org/content/21/7/1459.abstract</a>.</p>
+<p>Schliep, Klaus Peter. 2011. “phangorn: Phylogenetic Analysis in R.” <em>Bioinformatics</em> 27 (4): 592–93. doi:<a href="http://dx.doi.org/10.1093/bioinformatics/btq706">10.1093/bioinformatics/btq706</a>. <a href="http://bioinformatics.oxfordjournals.org/content/27/4/592.abstract">http://bioinformatics.oxfordjournals.org/content/27/4/592.abstract</a>.</p>
+</div>
+</div>
+
+
+
+<!-- dynamically load mathjax for compatibility with self-contained -->
+<script>
+ (function () {
+ var script = document.createElement("script");
+ script.type = "text/javascript";
+ script.src = "https://cdn.mathjax.org/mathjax/latest/MathJax.js?config=TeX-AMS-MML_HTMLorMML";
+ document.getElementsByTagName("head")[0].appendChild(script);
+ })();
+</script>
+
+</body>
+</html>
diff --git a/inst/doc/Trees.R b/inst/doc/Trees.R
new file mode 100644
index 0000000..c307472
--- /dev/null
+++ b/inst/doc/Trees.R
@@ -0,0 +1,221 @@
+### R code from vignette source 'Trees.Rnw'
+
+###################################################
+### code chunk number 1: Trees.Rnw:48-50
+###################################################
+options(width=70)
+foo <- packageDescription("phangorn")
+
+
+###################################################
+### code chunk number 2: Trees.Rnw:66-68
+###################################################
+library(phangorn)
+primates = read.phyDat("primates.dna", format="phylip", type="DNA")
+
+
+###################################################
+### code chunk number 3: Trees.Rnw:75-78
+###################################################
+dm = dist.dna(as.DNAbin(primates))
+treeUPGMA = upgma(dm)
+treeNJ = NJ(dm)
+
+
+###################################################
+### code chunk number 4: plotNJ
+###################################################
+layout(matrix(c(1,2), 2, 1), height=c(1,2))
+par(mar = c(.1,.1,.1,.1))
+plot(treeUPGMA, main="UPGMA")
+plot(treeNJ, "unrooted", main="NJ")
+
+
+###################################################
+### code chunk number 5: figNJ
+###################################################
+getOption("SweaveHooks")[["fig"]]()
+layout(matrix(c(1,2), 2, 1), height=c(1,2))
+par(mar = c(.1,.1,.1,.1))
+plot(treeUPGMA, main="UPGMA")
+plot(treeNJ, "unrooted", main="NJ")
+
+
+###################################################
+### code chunk number 6: Trees.Rnw:100-102
+###################################################
+parsimony(treeUPGMA, primates)
+parsimony(treeNJ, primates)
+
+
+###################################################
+### code chunk number 7: Trees.Rnw:105-108
+###################################################
+treePars = optim.parsimony(treeUPGMA, primates)
+treeRatchet = pratchet(primates, trace = 0)
+parsimony(c(treePars, treeRatchet), primates)
+
+
+###################################################
+### code chunk number 8: Trees.Rnw:111-112 (eval = FALSE)
+###################################################
+## (trees <- bab(subset(primates,1:10)))
+
+
+###################################################
+### code chunk number 9: Trees.Rnw:118-120
+###################################################
+fit = pml(treeNJ, data=primates)
+fit
+
+
+###################################################
+### code chunk number 10: Trees.Rnw:123-124
+###################################################
+methods(class="pml")
+
+
+###################################################
+### code chunk number 11: Trees.Rnw:127-129
+###################################################
+fitJC = optim.pml(fit, TRUE)
+logLik(fitJC)
+
+
+###################################################
+### code chunk number 12: Trees.Rnw:132-136
+###################################################
+fitGTR = update(fit, k=4, inv=0.2)
+fitGTR = optim.pml(fitGTR, TRUE,TRUE, TRUE, TRUE, TRUE,
+ control = pml.control(trace = 0))
+fitGTR
+
+
+###################################################
+### code chunk number 13: Trees.Rnw:139-140
+###################################################
+anova(fitJC, fitGTR)
+
+
+###################################################
+### code chunk number 14: Trees.Rnw:143-145
+###################################################
+AIC(fitGTR)
+AIC(fitJC)
+
+
+###################################################
+### code chunk number 15: Trees.Rnw:148-149
+###################################################
+SH.test(fitGTR, fitJC)
+
+
+###################################################
+### code chunk number 16: Trees.Rnw:152-153
+###################################################
+load("Trees.RData")
+
+
+###################################################
+### code chunk number 17: Trees.Rnw:155-156 (eval = FALSE)
+###################################################
+## mt = modelTest(primates)
+
+
+###################################################
+### code chunk number 18: Trees.Rnw:160-162
+###################################################
+library(xtable)
+xtable(mt, caption="Summary table of modelTest", label="tab:modelTest")
+
+
+###################################################
+### code chunk number 19: Trees.Rnw:166-169
+###################################################
+env <- attr(mt, "env")
+ls(envir=env)
+(fit <- eval(get("HKY+G+I", env), env))
+
+
+###################################################
+### code chunk number 20: Trees.Rnw:173-175 (eval = FALSE)
+###################################################
+## bs = bootstrap.pml(fitJC, bs=100, optNni=TRUE,
+## control = pml.control(trace = 0))
+
+
+###################################################
+### code chunk number 21: plotBS
+###################################################
+par(mar=c(.1,.1,.1,.1))
+plotBS(fitJC$tree, bs)
+
+
+###################################################
+### code chunk number 22: figBS
+###################################################
+getOption("SweaveHooks")[["fig"]]()
+par(mar=c(.1,.1,.1,.1))
+plotBS(fitJC$tree, bs)
+
+
+###################################################
+### code chunk number 23: Trees.Rnw:199-201
+###################################################
+options(prompt=" ")
+options(continue=" ")
+
+
+###################################################
+### code chunk number 24: Trees.Rnw:203-226 (eval = FALSE)
+###################################################
+## library(parallel) # supports parallel computing
+## library(phangorn)
+## file="myfile"
+## dat = read.phyDat(file)
+## dm = dist.ml(dat)
+## tree = NJ(dm)
+## # as alternative for a starting tree:
+## tree <- pratchet(dat)
+##
+## # 1. alternative: estimate an GTR model
+## fitStart = pml(tree, dat, k=4, inv=.2)
+## fit = optim.pml(fitStart, TRUE, TRUE, TRUE, TRUE, TRUE)
+##
+## # 2. alternative: modelTest
+## (mt <- modelTest(dat, multicore=TRUE))
+## mt$Model[which.min(mt$BIC)]
+## # choose best model from the table, assume now GTR+G+I
+## env = attr(mt, "env")
+## fitStart = eval(get("GTR+G+I", env), env)
+## fitStart = eval(get(mt$Model[which.min(mt$BIC)], env), env)
+## fit = optim.pml(fitStart, optNni=TRUE, optGamma=TRUE, optInv=TRUE,
+## model="GTR")
+## bs = bootstrap.pml(fit, bs=100, optNni=TRUE, multicore=TRUE)
+
+
+###################################################
+### code chunk number 25: Trees.Rnw:230-244 (eval = FALSE)
+###################################################
+## library(parallel) # supports parallel computing
+## library(phangorn)
+## file="myfile"
+## dat = read.phyDat(file, type = "AA")
+## dm = dist.ml(dat, model="JTT")
+## tree = NJ(dm)
+##
+## (mt <- modelTest(dat, model=c("JTT", "LG", "WAG"), multicore=TRUE))
+## fitStart = eval(get(mt$Model[which.min(mt$BIC)], env), env)
+##
+## fitNJ = pml(tree, dat, model="JTT", k=4, inv=.2)
+## fit = optim.pml(fitNJ, optNni=TRUE, optInv=TRUE, optGamma=TRUE)
+## fit
+## bs = bootstrap.pml(fit, bs=100, optNni=TRUE, multicore=TRUE)
+
+
+###################################################
+### code chunk number 26: Trees.Rnw:252-253
+###################################################
+toLatex(sessionInfo())
+
+
diff --git a/inst/doc/Trees.Rnw b/inst/doc/Trees.Rnw
new file mode 100644
index 0000000..6af3b5a
--- /dev/null
+++ b/inst/doc/Trees.Rnw
@@ -0,0 +1,256 @@
+%\VignetteIndexEntry{Constructing phylogenetic trees}
+%\VignetteKeywords{Documentation}
+%\VignettePackage{phangorn}
+%\VignetteEngine{Sweave}
+\documentclass[12pt]{article}
+
+\usepackage{times}
+\usepackage{hyperref}
+
+
+\begin{document}
+
+\newcommand{\Rfunction}[1]{{\texttt{#1}}}
+\newcommand{\Robject}[1]{{\texttt{#1}}}
+\newcommand{\Rpackage}[1]{{\textit{#1}}}
+\newcommand{\Rmethod}[1]{{\texttt{#1}}}
+\newcommand{\Rfunarg}[1]{{\texttt{#1}}}
+\newcommand{\Rclass}[1]{{\textit{#1}}}
+
+\textwidth=6.2in
+\textheight=8.5in
+%\parskip=.3cm
+\oddsidemargin=.1in
+\evensidemargin=.1in
+\headheight=-.3in
+
+\newcommand{\R}{\textsf{R}}
+\newcommand{\pml}{\Robject{pml}}
+\newcommand{\phangorn}{\Rpackage{phangorn}}
+\newcommand{\ape}{\Rpackage{ape}}
+\newcommand{\multicore}{\Rpackage{multicore}}
+
+\newcommand{\term}[1]{\emph{#1}}
+\newcommand{\mref}[2]{\htmladdnormallinkfoot{#2}{#1}}
+
+% leave comments in the text
+\SweaveOpts{keep.source=TRUE}
+
+
+
+% Ross Ihakas extenstion for nicer representation
+\DefineVerbatimEnvironment{Sinput}{Verbatim} {xleftmargin=2em}
+\DefineVerbatimEnvironment{Soutput}{Verbatim}{xleftmargin=2em}
+\DefineVerbatimEnvironment{Scode}{Verbatim}{xleftmargin=2em}
+\fvset{listparameters={\setlength{\topsep}{0pt}}}
+\renewenvironment{Schunk}{\vspace{\topsep}}{\vspace{\topsep}}
+
+<<echo=FALSE>>=
+options(width=70)
+foo <- packageDescription("phangorn")
+@
+
+
+\title{Estimating phylogenetic trees with phangorn} %$ (Version \Sexpr{foo$Version})}
+\author{\mref{mailto:klaus.schliep at gmail.com}{Klaus P. Schliep}}
+\maketitle
+
+\nocite{Paradis2012}
+\section{Introduction}
+
+These notes should enable the user to estimate phylogenetic trees from alignment data with different methods using the \phangorn{} package \cite{Schliep2011}. Several functions of \phangorn{} are also described in more detail in \cite{Paradis2012}. For more theoretical background on all the methods see e.g. \cite{Felsenstein2004, Yang2006}. This document illustrates some of the \phangorn{} features to estimate phylogenetic trees using different reconstruction methods. Small adaptations t [...]
+\section{Getting started}
+The first thing we have to do is to read in an alignment. Unfortunately there exists many different file formats that alignments can be stored in. The function \Rfunction{read.phyDat} is used to read in an alignment. There are several functions to read in alignments depending on the format of the data set (nexus, phylip, fasta) and the kind of data (amino acid or nucleotides) in the \ape{} package \cite{Paradis2004} and \phangorn{}. The function \Rfunction{read.phyDat} calls these other [...]
+%When using the \Rfunction{read.dna} from \ape{} the parameter the we have to use as.character=TRUE.
+We start our analysis loading the \phangorn{} package and then reading in an alignment.
+<<echo=TRUE>>=
+library(phangorn)
+primates = read.phyDat("primates.dna", format="phylip", type="DNA")
+@
+%require("multicore")
+\section{Distance based methods}
+After reading in the alignment we can build a first tree with distance based methods. The function dist.dna from the ape package computes distances for many DNA substitution models. To use the function dist.dna we have to transform the data to class DNAbin. For amino acids the function dist.ml offers common substitution models ("WAG", "JTT", "LG", "Dayhoff", "cpREV", "mtmam", "mtArt", "MtZoa" and "mtREV24").
+
+After constructing a distance matrix we reconstruct a rooted tree with UPGMA and alternatively an unrooted tree using Neighbor Joining \cite{Saitou1987,Studier1988}.
+<<echo=TRUE>>=
+dm = dist.dna(as.DNAbin(primates))
+treeUPGMA = upgma(dm)
+treeNJ = NJ(dm)
+@
+We can plot the trees treeUPGMA and treeNJ (figure \ref{fig:NJ}) with the commands:
+<<label=plotNJ,include=FALSE>>=
+layout(matrix(c(1,2), 2, 1), height=c(1,2))
+par(mar = c(.1,.1,.1,.1))
+plot(treeUPGMA, main="UPGMA")
+plot(treeNJ, "unrooted", main="NJ")
+@
+\begin{figure}
+\begin{center}
+<<label=figNJ,fig=TRUE,echo=FALSE>>=
+<<plotNJ>>
+@
+\end{center}
+\caption{Rooted UPGMA tree and unrooted NJ tree}
+\label{fig:NJ}
+\end{figure}
+Distance based methods are very fast and we will use the UPGMA and NJ tree as starting trees for the maximum parsimony and maximum likelihood analyses.
+
+\section{Parsimony}
+The function parsimony returns the parsimony score, that is the number of changes which are at least necessary to describe the data for a given tree. We can compare the parsimony score or the two trees we computed so far:
+<<echo=TRUE>>=
+parsimony(treeUPGMA, primates)
+parsimony(treeNJ, primates)
+@
+The function optim.parsimony performs tree rearrangements to find trees with a lower parsimony score. So far the only tree rearrangement implemented is nearest-neighbor interchanges (NNI). However is also a version of the parsimony ratchet \cite{Nixon1999} implemented, which is likely to find better trees than just doing NNI rearrangements.
+<<echo=TRUE>>=
+treePars = optim.parsimony(treeUPGMA, primates)
+treeRatchet = pratchet(primates, trace = 0)
+parsimony(c(treePars, treeRatchet), primates)
+@
+For small data sets it is also possible to find all most parsimonious trees using a branch and bound algorithm \cite{Hendy1982}. For data sets with more than 10 taxa this can take a long time and depends strongly on how tree like the data are.
+<<echo=TRUE, eval=FALSE>>=
+(trees <- bab(subset(primates,1:10)))
+@
+
+\section{Maximum likelihood}
+The last method we will describe in this vignette is Maximum Likelihood (ML) as introduced by Felsenstein \cite{Felsenstein1981}.
+We can easily compute the likelihood for a tree given the data
+<<echo=TRUE>>=
+fit = pml(treeNJ, data=primates)
+fit
+@
+The function pml returns an object of class pml. This object contains the data, the tree and many different parameters of the model like the likelihood etc. There are many generic functions for the class pml available, which allow the handling of these objects.
+<<echo=TRUE>>=
+methods(class="pml")
+@
+The object fit just estimated the likelihood for the tree it got supplied, but the branch length are not optimized for the Jukes-Cantor model yet, which can be done with the function optim.pml.
+<<echo=TRUE, results=hide>>=
+fitJC = optim.pml(fit, TRUE)
+logLik(fitJC)
+@
+With the default values \Rfunction{pml} will estimate a Jukes-Cantor model. The function \Rfunction{update.pml} allows to change parameters. We will change the model to the GTR + $\Gamma(4)$ + I model and then optimize all the parameters.
+<<echo=TRUE>>=
+fitGTR = update(fit, k=4, inv=0.2)
+fitGTR = optim.pml(fitGTR, TRUE,TRUE, TRUE, TRUE, TRUE,
+ control = pml.control(trace = 0))
+fitGTR
+@
+We can compare the objects for the JC and GTR + $\Gamma(4)$ + I model using likelihood ratio statistic
+<<echo=TRUE>>=
+anova(fitJC, fitGTR)
+@
+with the AIC
+<<echo=TRUE>>=
+AIC(fitGTR)
+AIC(fitJC)
+@
+or the Shimodaira-Hasegawa test.
+<<echo=TRUE>>=
+SH.test(fitGTR, fitJC)
+@
+An alternative is to use the function \Rfunction{modelTest} to compare different models the AIC or BIC, similar to popular program of \cite{Posada1998, Posada2008}.
+<<echo=FALSE>>=
+load("Trees.RData")
+@
+<<echo=TRUE, eval=FALSE>>=
+mt = modelTest(primates)
+@
+The results of is illustrated in table \ref{tab:modelTest}
+\begin{center}
+<<echo=FALSE,results=tex>>=
+library(xtable)
+xtable(mt, caption="Summary table of modelTest", label="tab:modelTest")
+@
+\end{center}
+The thresholds for the optimization in \Rfunction{modelTest} are not as strict as for \Rfunction{optim.pml} and no tree rearrangements are performed. As \Rfunction{modelTest} computes and optimizes a lot of models it would be a waste of computer time not to save these results. The results are saved as call together with the optimized trees in an environment and this call can be evaluated to get a "pml" object back to use for further optimization or analysis.
+<<echo=TRUE>>=
+env <- attr(mt, "env")
+ls(envir=env)
+(fit <- eval(get("HKY+G+I", env), env))
+@
+
+At last we may want to apply bootstrap to test how well the edges of the tree are supported: %, results=hide
+<<echo=TRUE, eval=FALSE>>=
+bs = bootstrap.pml(fitJC, bs=100, optNni=TRUE,
+ control = pml.control(trace = 0))
+@
+
+%$
+Now we can plot the tree with the bootstrap support values on the edges
+<<label=plotBS,include=FALSE>>=
+par(mar=c(.1,.1,.1,.1))
+plotBS(fitJC$tree, bs)
+@
+%$
+\begin{figure}
+\begin{center}
+<<label=figBS,fig=TRUE,echo=FALSE>>=
+<<plotBS>>
+@
+\end{center}
+\caption{Unrooted tree with bootstrap support values}
+\label{fig:BS}
+\end{figure}
+
+Several analyses, e.g. \Rfunction{bootstrap} and \Rfunction{modelTest}, can be computationally demanding, but as nowadays most computers have several cores one can distribute the computations using the \multicore{} package. However it is only possible to use this approach if R is running from command line ("X11"), but not using a GUI (for example "Aqua" on Macs) and unfortunately the \multicore{} package does not work at all under Windows.
+\section{Appendix: Standard scripts for nucleotide or amino acid analysis}\label{sec:Appendix}
+Here we provide two standard scripts which can be adapted for the most common tasks.
+Most likely the arguments for \Rfunction{read.phyDat} have to be adapted to accommodate your file format. Both scripts assume that the \multicore{} package, see comments above.
+<<echo=FALSE>>=
+options(prompt=" ")
+options(continue=" ")
+@
+<<eval=FALSE>>=
+library(parallel) # supports parallel computing
+library(phangorn)
+file="myfile"
+dat = read.phyDat(file)
+dm = dist.ml(dat)
+tree = NJ(dm)
+# as alternative for a starting tree:
+tree <- pratchet(dat)
+
+# 1. alternative: estimate an GTR model
+fitStart = pml(tree, dat, k=4, inv=.2)
+fit = optim.pml(fitStart, TRUE, TRUE, TRUE, TRUE, TRUE)
+
+# 2. alternative: modelTest
+(mt <- modelTest(dat, multicore=TRUE))
+mt$Model[which.min(mt$BIC)]
+# choose best model from the table, assume now GTR+G+I
+env = attr(mt, "env")
+fitStart = eval(get("GTR+G+I", env), env)
+fitStart = eval(get(mt$Model[which.min(mt$BIC)], env), env)
+fit = optim.pml(fitStart, optNni=TRUE, optGamma=TRUE, optInv=TRUE,
+ model="GTR")
+bs = bootstrap.pml(fit, bs=100, optNni=TRUE, multicore=TRUE)
+@
+
+You can specify different several models build in which you can specify, e.g. "WAG", "JTT", "Dayhoff", "LG". Optimizing the rate matrix for amino acids is possible, but would take a long, a very long time. So make sure to set optBf=FALSE and optQ=FALSE in the function \Rfunction{optim.pml}, which is also the default.
+<<eval=FALSE>>=
+library(parallel) # supports parallel computing
+library(phangorn)
+file="myfile"
+dat = read.phyDat(file, type = "AA")
+dm = dist.ml(dat, model="JTT")
+tree = NJ(dm)
+
+(mt <- modelTest(dat, model=c("JTT", "LG", "WAG"), multicore=TRUE))
+fitStart = eval(get(mt$Model[which.min(mt$BIC)], env), env)
+
+fitNJ = pml(tree, dat, model="JTT", k=4, inv=.2)
+fit = optim.pml(fitNJ, optNni=TRUE, optInv=TRUE, optGamma=TRUE)
+fit
+bs = bootstrap.pml(fit, bs=100, optNni=TRUE, multicore=TRUE)
+@
+
+\bibliographystyle{plain}
+\bibliography{phangorn}
+
+\section{Session Information}
+The version number of \R{} and packages loaded for generating the vignette were:
+<<echo=FALSE,results=tex>>=
+toLatex(sessionInfo())
+@
+\end{document}
+
diff --git a/inst/doc/Trees.pdf b/inst/doc/Trees.pdf
new file mode 100644
index 0000000..a1a0de3
Binary files /dev/null and b/inst/doc/Trees.pdf differ
diff --git a/inst/doc/phangorn-specials.R b/inst/doc/phangorn-specials.R
new file mode 100644
index 0000000..d6dc383
--- /dev/null
+++ b/inst/doc/phangorn-specials.R
@@ -0,0 +1,109 @@
+### R code from vignette source 'phangorn-specials.Rnw'
+
+###################################################
+### code chunk number 1: phangorn-specials.Rnw:46-48
+###################################################
+options(width=70)
+foo <- packageDescription("phangorn")
+
+
+###################################################
+### code chunk number 2: phangorn-specials.Rnw:70-76
+###################################################
+library(phangorn)
+data = matrix(c("r","a","y","g","g","a","c","-","c","t","c","g",
+ "a","a","t","g","g","a","t","-","c","t","c","a",
+ "a","a","t","-","g","a","c","c","c","t","?","g"),
+ dimnames = list(c("t1", "t2", "t3"),NULL), nrow=3, byrow=TRUE)
+data
+
+
+###################################################
+### code chunk number 3: phangorn-specials.Rnw:79-81
+###################################################
+gapsdata1 = phyDat(data)
+gapsdata1
+
+
+###################################################
+### code chunk number 4: phangorn-specials.Rnw:84-87
+###################################################
+gapsdata2 = phyDat(data, type="USER", levels=c("a","c","g","t","-"),
+ ambiguity = c("?", "n"))
+gapsdata2
+
+
+###################################################
+### code chunk number 5: phangorn-specials.Rnw:91-106
+###################################################
+contrast = matrix(data = c(1,0,0,0,0,
+ 0,1,0,0,0,
+ 0,0,1,0,0,
+ 0,0,0,1,0,
+ 1,0,1,0,0,
+ 0,1,0,1,0,
+ 0,0,0,0,1,
+ 1,1,1,1,0,
+ 1,1,1,1,1),
+ ncol = 5, byrow = TRUE)
+dimnames(contrast) = list(c("a","c","g","t","r","y","-","n","?"),
+ c("a", "c", "g", "t", "-"))
+contrast
+gapsdata3 = phyDat(data, type="USER", contrast=contrast)
+gapsdata3
+
+
+###################################################
+### code chunk number 6: phangorn-specials.Rnw:137-142
+###################################################
+tree = unroot(rtree(3))
+fit = pml(tree, gapsdata3)
+fit = optim.pml(fit, optQ=TRUE, subs=c(1,0,1,2,1,0,2,1,2,2),
+ control=pml.control(trace=0))
+fit
+
+
+###################################################
+### code chunk number 7: phangorn-specials.Rnw:205-215
+###################################################
+library(phangorn)
+primates = read.phyDat("primates.dna", format="phylip", type="DNA")
+tree <- NJ(dist.ml(primates))
+dat <- phyDat(as.character(primates), "CODON")
+fit <- pml(tree, dat)
+fit0 <- optim.pml(fit, control = pml.control(trace = 0))
+fit1 <- optim.pml(fit, model="codon1", control=pml.control(trace=0))
+fit2 <- optim.pml(fit, model="codon2", control=pml.control(trace=0))
+fit3 <- optim.pml(fit, model="codon3", control=pml.control(trace=0))
+anova(fit0, fit2, fit3, fit1)
+
+
+###################################################
+### code chunk number 8: plotAll
+###################################################
+trees = allTrees(5)
+par(mfrow=c(3,5), mar=rep(0,4))
+for(i in 1:15)plot(trees[[i]], cex=1, type="u")
+
+
+###################################################
+### code chunk number 9: figAll
+###################################################
+getOption("SweaveHooks")[["fig"]]()
+trees = allTrees(5)
+par(mfrow=c(3,5), mar=rep(0,4))
+for(i in 1:15)plot(trees[[i]], cex=1, type="u")
+
+
+###################################################
+### code chunk number 10: phangorn-specials.Rnw:242-243
+###################################################
+trees = nni(trees[[1]])
+
+
+###################################################
+### code chunk number 11: phangorn-specials.Rnw:254-255
+###################################################
+toLatex(sessionInfo())
+
+
diff --git a/inst/doc/phangorn-specials.Rnw b/inst/doc/phangorn-specials.Rnw
new file mode 100644
index 0000000..9d33093
--- /dev/null
+++ b/inst/doc/phangorn-specials.Rnw
@@ -0,0 +1,258 @@
+%\VignetteIndexEntry{Advanced features}
+%\VignetteKeywords{Documentation}
+%\VignettePackage{phangorn}
+%\VignetteEngine{Sweave}
+\documentclass[12pt]{article}
+% setwd("/home/kschliep/Desktop/phangorn/vignettes")
+% Sweave("phangorn-specials.Rnw")
+% tools::texi2dvi("phangorn-specials.tex", pdf=TRUE)
+\usepackage{times}
+\usepackage{hyperref}
+
+\newcommand{\Rfunction}[1]{{\texttt{#1}}}
+\newcommand{\Robject}[1]{{\texttt{#1}}}
+\newcommand{\Rpackage}[1]{{\textit{#1}}}
+\newcommand{\Rmethod}[1]{{\texttt{#1}}}
+\newcommand{\Rfunarg}[1]{{\texttt{#1}}}
+\newcommand{\Rclass}[1]{{\textit{#1}}}
+
+\textwidth=6.2in
+\textheight=8.5in
+%\parskip=.3cm
+\oddsidemargin=.1in
+\evensidemargin=.1in
+\headheight=-.3in
+
+\newcommand{\R}{\textsf{R}}
+\newcommand{\pml}{\Robject{pml}}
+\newcommand{\phangorn}{\Rpackage{phangorn}}
+\newcommand{\ape}{\Rpackage{ape}}
+\newcommand{\multicore}{\Rpackage{multicore}}
+
+\newcommand{\term}[1]{\emph{#1}}
+\newcommand{\mref}[2]{\htmladdnormallinkfoot{#2}{#1}}
+
+
+
+\begin{document}
+
+% Ross Ihakas extenstion for nicer representation
+\DefineVerbatimEnvironment{Sinput}{Verbatim} {xleftmargin=2em}
+\DefineVerbatimEnvironment{Soutput}{Verbatim}{xleftmargin=2em}
+\DefineVerbatimEnvironment{Scode}{Verbatim}{xleftmargin=2em}
+\fvset{listparameters={\setlength{\topsep}{0pt}}}
+\renewenvironment{Schunk}{\vspace{\topsep}}{\vspace{\topsep}}
+
+<<echo=FALSE>>=
+options(width=70)
+foo <- packageDescription("phangorn")
+@
+
+
+\title{Special features of phangorn (Version \Sexpr{foo$Version})} %$
+\author{\mref{mailto:klaus.schliep at gmail.com}{Klaus P. Schliep}}
+\maketitle
+
+\nocite{Paradis2012}
+\section*{Introduction}
+This document illustrates some of the \phangorn{} \cite{Schliep2011} specialised features which are useful but maybe not as well-known or just not (yet) described elsewhere. This is mainly interesting for someone who wants to explore different models or set up some simulation studies. We show how to construct data objects for different character states other than nucleotides or amino acids or how to set up different models to estimate transition rate.
+
+The vignette \emph{Trees} describes in detail how to estimate phylogenies from nucleotide or amino acids.
+
+
+\section{User defined data formats}\label{sec:USER}
+
+To better understand how to define our own data type it is useful to know a bit more about the internal representation of \Robject{phyDat} objects. The internal representation of \Robject{phyDat} object is very similar to \Robject{factor} objects.
+
+As an example we will show here several possibilities to define nucleotide data with gaps defined as a fifth state. Ignoring gaps or coding them as ambiguous sites - as it is done in most programs, also in phangorn as default - may be misleading (see Warnow(2012)\cite{Warnow2012}). When the number of gaps is low and the gaps are missing at random coding gaps as separate state may be not important.
+
+Let assume we have given a matrix where each row contains a character vector of a taxonomical unit:
+<<echo=TRUE>>=
+library(phangorn)
+data = matrix(c("r","a","y","g","g","a","c","-","c","t","c","g",
+ "a","a","t","g","g","a","t","-","c","t","c","a",
+ "a","a","t","-","g","a","c","c","c","t","?","g"),
+ dimnames = list(c("t1", "t2", "t3"),NULL), nrow=3, byrow=TRUE)
+data
+@
+Normally we would transform this matrix into an phyDat object and gaps are handled as ambiguous character like "?".
+<<>>=
+gapsdata1 = phyDat(data)
+gapsdata1
+@
+Now we will define a "USER" defined object and have to supply a vector levels of the character states for the new data, in our case the for nucleotide states and the gap. Additional we can define ambiguous states which can be any of the states.
+<<echo=TRUE>>=
+gapsdata2 = phyDat(data, type="USER", levels=c("a","c","g","t","-"),
+ ambiguity = c("?", "n"))
+gapsdata2
+@
+This is not yet what we wanted as two sites of our alignment, which contain the ambiguous characters "r" and "y", got deleted.
+To define ambiguous characters like "r" and "y" explicitly we have to supply a contrast matrix similar to contrasts for factors.
+<<echo=TRUE>>=
+contrast = matrix(data = c(1,0,0,0,0,
+ 0,1,0,0,0,
+ 0,0,1,0,0,
+ 0,0,0,1,0,
+ 1,0,1,0,0,
+ 0,1,0,1,0,
+ 0,0,0,0,1,
+ 1,1,1,1,0,
+ 1,1,1,1,1),
+ ncol = 5, byrow = TRUE)
+dimnames(contrast) = list(c("a","c","g","t","r","y","-","n","?"),
+ c("a", "c", "g", "t", "-"))
+contrast
+gapsdata3 = phyDat(data, type="USER", contrast=contrast)
+gapsdata3
+@
+Here we defined "n" as a state which can be any nucleotide but not a gap "-" and "?" can be any state including a gap.
+
+These data can be used in all functions available in \phangorn{} to compute distance matrices or perform parsimony and maximum likelihood analysis.
+
+
+\section{Estimation of non-standard transition rate matrices}
+In the last section \ref{sec:USER} we described how to set up user defined data formats. Now we describe how to estimate transition matrices with pml.
+
+Again for nucleotide data the most common models can be called directly in the \Rfunction{optim.pml} function (e.g. "JC69", "HKY", "GTR" to name a few). Table \ref{models} lists all the available nucleotide models, which can estimated directly in \Rfunction{optim.pml}. For amino acids several transition matrices are available ("WAG", "JTT", "LG", "Dayhoff", "cpREV", "mtmam", "mtArt", "MtZoa", "mtREV24", "VT","RtREV", "HIVw", "HIVb", "FLU", "Blossum62", "Dayhoff\_DCMut" and "JTT-DCMut") o [...]
+
+
+We will now show how to estimate a rate matrix with different transition ($\alpha$) and transversion ratio ($\beta$) and a fixed rate to the gap state ($\gamma$) - a kind of Kimura two-parameter model (K81) for nucleotide data with gaps as fifth state (see table \ref{gaps}).
+
+\begin{table}[htbp]
+ \centering
+ \begin{tabular}{l|lllll}
+ & a & c & g & t & - \\
+ \hline
+ a & & & & & \\
+ c & $\beta$ & & & & \\
+ g & $\alpha$ & $\beta$ & & & \\
+ t & $\beta$ & $\alpha$ & $\beta$ & & \\
+ - & $\gamma$ & $\gamma$ & $\gamma$ & $\gamma$ & \\
+ \end{tabular}
+ \caption{Rate matrix K to optimise. }\label{gaps}
+\end{table}
+
+
+The parameters subs accepts a vector of consecutive integers and at least one element has to be zero (these gets the reference rate of 1).
+<<>>=
+tree = unroot(rtree(3))
+fit = pml(tree, gapsdata3)
+fit = optim.pml(fit, optQ=TRUE, subs=c(1,0,1,2,1,0,2,1,2,2),
+ control=pml.control(trace=0))
+fit
+@
+
+
+Here are some conventions how the models are estimated: \\
+
+If a model is supplied the base frequencies bf and rate matrix Q are optimised according to the model (nucleotides) or the adequate rate matrix and frequencies are chosen (for amino acids).
+If optQ=TRUE and neither a model or subs are supplied than a symmetric (optBf=FALSE) or reversible model (optBf=TRUE, i.e. the GTR for nucleotides) is estimated. This can be slow if the there are many character states, e.g. for amino acids.
+
+
+\begin{table}[htbp]
+ \centering
+ \begin{tabular}{|llllr|}
+ \hline
+ model & optQ & optBf & subs & df \\
+ \hline
+ JC & FALSE & FALSE & $c(0, 0, 0, 0, 0, 0)$ & 0 \\
+ F81 & FALSE & TRUE & $c(0, 0, 0, 0, 0, 0)$ & 3 \\
+ K80 & TRUE & FALSE & $c(0, 1, 0, 0, 1, 0)$ & 1 \\
+ HKY & TRUE & TRUE & $c(0, 1, 0, 0, 1, 0)$ & 4 \\
+ TrNe & TRUE & FALSE & $c(0, 1, 0, 0, 2, 0)$ & 2 \\
+ TrN & TRUE & TRUE & $c(0, 1, 0, 0, 2, 0)$ & 5 \\
+ TPM1 & TRUE & FALSE & $c(0, 1, 2, 2, 1, 0)$ & 2 \\
+ K81 & TRUE & FALSE & $c(0, 1, 2, 2, 1, 0)$ & 2 \\
+ TPM1u & TRUE & TRUE & $c(0, 1, 2, 2, 1, 0)$ & 5 \\
+ TPM2 & TRUE & FALSE & $c(1, 2, 1, 0, 2, 0)$ & 2 \\
+ TPM2u & TRUE & TRUE & $c(1, 2, 1, 0, 2, 0)$ & 5 \\
+ TPM3 & TRUE & FALSE & $c(1, 2, 0, 1, 2, 0)$ & 2 \\
+ TPM3u & TRUE & TRUE & $c(1, 2, 0, 1, 2, 0)$ & 5 \\
+ TIM1e & TRUE & FALSE & $c(0, 1, 2, 2, 3, 0)$ & 3 \\
+ TIM1 & TRUE & TRUE & $c(0, 1, 2, 2, 3, 0)$ & 6 \\
+ TIM2e & TRUE & FALSE & $c(1, 2, 1, 0, 3, 0)$ & 3 \\
+ TIM2 & TRUE & TRUE & $c(1, 2, 1, 0, 3, 0)$ & 6 \\
+ TIM3e & TRUE & FALSE & $c(1, 2, 0, 1, 3, 0)$ & 3 \\
+ TIM3 & TRUE & TRUE & $c(1, 2, 0, 1, 3, 0)$ & 6 \\
+ TVMe & TRUE & FALSE & $c(1, 2, 3, 4, 2, 0)$ & 4 \\
+ TVM & TRUE & TRUE & $c(1, 2, 3, 4, 2, 0)$ & 7 \\
+ SYM & TRUE & FALSE & $c(1, 2, 3, 4, 5, 0)$ & 5 \\
+ GTR & TRUE & TRUE & $c(1, 2, 3, 4, 5, 0)$ & 8 \\
+ \hline
+ \end{tabular}
+ \caption{DNA models available in phangorn, how they are defined and number of parameters to estimate. }\label{models}
+\end{table}
+
+\section{Codon substitution models}
+A special case of the transition rates are codon models. \phangorn{} now offers the possibility to estimate the $d_N/d_S$ ratio (sometimes called ka/ks), for an overview see \cite{Yang2006}. These functions extend the option to estimates the $d_N/d_S$ ratio for pairwise sequence comparison as it is available through the function \Rfunction{kaks} in \Rpackage{seqinr}. The transition rate between between codon $i$ and $j$ is defined as follows:
+\begin{eqnarray}
+q_{ij}=\left\{
+ \begin{array}{l@{\quad}l}
+ 0 & \textrm{if i and j differ in more than one position} \\
+ \pi_j & \textrm{for synonymous transversion} \\
+ \pi_j\kappa & \textrm{for synonymous transition} \\
+ \pi_j\omega & \textrm{for non-synonymous transversion} \\
+ \pi_j\omega\kappa & \textrm{for non synonymous transition}
+ \end{array}
+ \right. \nonumber
+\end{eqnarray}
+where $\omega$ is the $d_N/d_S$ ratio, $\kappa$ the transition transversion ratio and $\pi_j$ is the the equilibrium frequencies of codon $j$.
+For $\omega\sim1$ the an amino acid change is neutral, for $\omega < 1$ purifying selection and $\omega > 1$ positive selection.
+There are four models available:
+"codon0", where both parameter $\kappa$ and $\omega$ are fixed to 1, "codon1" where both parameters are estimated and "codon2" or "codon3" where $\kappa$ or $\omega$ is fixed to 1.
+
+We compute the $d_N/d_S$ for some sequences given a tree using the ML functions \Rfunction{pml} and \Rfunction{optim.pml}. First we have to transform the the nucleotide sequences into codons (so far the algorithms always takes triplets).
+<<echo=TRUE>>=
+library(phangorn)
+primates = read.phyDat("primates.dna", format="phylip", type="DNA")
+tree <- NJ(dist.ml(primates))
+dat <- phyDat(as.character(primates), "CODON")
+fit <- pml(tree, dat)
+fit0 <- optim.pml(fit, control = pml.control(trace = 0))
+fit1 <- optim.pml(fit, model="codon1", control=pml.control(trace=0))
+fit2 <- optim.pml(fit, model="codon2", control=pml.control(trace=0))
+fit3 <- optim.pml(fit, model="codon3", control=pml.control(trace=0))
+anova(fit0, fit2, fit3, fit1)
+@
+The models described here all assume equal frequencies for each codon (=1/61). One can optimise the codon frequencies setting the option to optBf=TRUE. As the convergence of the 61 parameters the convergence is likely slow set the maximal iterations to a higher value than the default (e.g. control = pml.control(maxit=50)).
+
+\section{Generating trees}
+\phangorn{} has several functions to generate tree topologies, which may are interesting for simulation studies. \Rfunction{allTrees} computes all possible bifurcating tree topologies either rooted or unrooted for up to 10 taxa. One has to keep in mind that the number of trees is growing exponentially, use \Rfunction(howmanytrees) from \ape{} as a reminder.
+
+%<<echo=TRUE>>=
+%trees = allTrees(5)
+%@
+<<label=plotAll,include=FALSE>>=
+trees = allTrees(5)
+par(mfrow=c(3,5), mar=rep(0,4))
+for(i in 1:15)plot(trees[[i]], cex=1, type="u")
+@
+\begin{figure}
+\begin{center}
+<<label=figAll,fig=TRUE,echo=FALSE>>=
+<<plotAll>>
+@
+\end{center}
+\caption{all (15) unrooted trees with 5 taxa}
+\label{fig:NJ}
+\end{figure}
+
+
+\Rfunction{nni} returns a list of all trees which are one nearest neighbor interchange away.
+<<echo=TRUE>>=
+trees = nni(trees[[1]])
+@
+\Rfunction{rNNI} and \Rfunction{rSPR} generate trees which are a defined number of NNI (nearest neighbor interchange) or SPR (subtree pruning and regrafting) away.
+
+
+
+\bibliographystyle{plain}
+\bibliography{phangorn}
+
+\section{Session Information}
+The version number of \R{} and packages loaded for generating the vignette were:
+<<echo=FALSE,results=tex>>=
+toLatex(sessionInfo())
+@
+
+\end{document}
diff --git a/inst/doc/phangorn-specials.pdf b/inst/doc/phangorn-specials.pdf
new file mode 100644
index 0000000..28b5022
Binary files /dev/null and b/inst/doc/phangorn-specials.pdf differ
diff --git a/inst/extdata/Blosum62.dat b/inst/extdata/Blosum62.dat
new file mode 100644
index 0000000..bb33360
--- /dev/null
+++ b/inst/extdata/Blosum62.dat
@@ -0,0 +1,22 @@
+
+0.735790389698
+0.485391055466 1.297446705134
+0.543161820899 0.500964408555 3.180100048216
+1.45999531047 0.227826574209 0.397358949897 0.240836614802
+1.199705704602 3.020833610064 1.839216146992 1.190945703396 0.32980150463
+1.1709490428 1.36057419042 1.24048850864 3.761625208368 0.140748891814 5.528919177928
+1.95588357496 0.418763308518 1.355872344485 0.798473248968 0.418203192284 0.609846305383 0.423579992176
+0.716241444998 1.456141166336 2.414501434208 0.778142664022 0.354058109831 2.43534113114 1.626891056982 0.539859124954
+0.605899003687 0.232036445142 0.283017326278 0.418555732462 0.774894022794 0.236202451204 0.186848046932 0.189296292376 0.252718447885
+0.800016530518 0.622711669692 0.211888159615 0.218131577594 0.831842640142 0.580737093181 0.372625175087 0.217721159236 0.348072209797 3.890963773304
+1.295201266783 5.411115141489 1.593137043457 1.032447924952 0.285078800906 3.945277674515 2.802427151679 0.752042440303 1.022507035889 0.406193586642 0.445570274261
+1.253758266664 0.983692987457 0.648441278787 0.222621897958 0.76768882348 2.494896077113 0.55541539747 0.459436173579 0.984311525359 3.364797763104 6.030559379572 1.073061184332
+0.492964679748 0.371644693209 0.354861249223 0.281730694207 0.441337471187 0.14435695975 0.291409084165 0.368166464453 0.714533703928 1.517359325954 2.064839703237 0.266924750511 1.77385516883
+1.173275900924 0.448133661718 0.494887043702 0.730628272998 0.356008498769 0.858570575674 0.926563934846 0.504086599527 0.527007339151 0.388355409206 0.374555687471 1.047383450722 0.454123625103 0.233597909629
+4.325092687057 1.12278310421 2.904101656456 1.582754142065 1.197188415094 1.934870924596 1.769893238937 1.509326253224 1.11702976291 0.35754441246 0.352969184527 1.752165917819 0.918723415746 0.540027644824 1.169129577716
+1.729178019485 0.914665954563 1.898173634533 0.934187509431 1.119831358516 1.277480294596 1.071097236007 0.641436011405 0.585407090225 1.17909119726 0.915259857694 1.303875200799 1.488548053722 0.488206118793 1.005451683149 5.15155629227
+0.465839367725 0.426382310122 0.191482046247 0.145345046279 0.527664418872 0.758653808642 0.407635648938 0.508358924638 0.30124860078 0.34198578754 0.6914746346 0.332243040634 0.888101098152 2.074324893497 0.252214830027 0.387925622098 0.513128126891
+0.718206697586 0.720517441216 0.538222519037 0.261422208965 0.470237733696 0.95898974285 0.596719300346 0.308055737035 4.218953969389 0.674617093228 0.811245856323 0.7179934869 0.951682162246 6.747260430801 0.369405319355 0.796751520761 0.801010243199 4.054419006558
+2.187774522005 0.438388343772 0.312858797993 0.258129289418 1.116352478606 0.530785790125 0.524253846338 0.25334079019 0.20155597175 8.311839405458 2.231405688913 0.498138475304 2.575850755315 0.838119610178 0.496908410676 0.561925457442 2.253074051176 0.266508731426 1
+
+0.074 0.052 0.045 0.054 0.025 0.034 0.054 0.074 0.026 0.068 0.099 0.058 0.025 0.047 0.039 0.057 0.051 0.013 0.032 0.073
diff --git a/inst/extdata/Dayhoff.dat b/inst/extdata/Dayhoff.dat
new file mode 100644
index 0000000..7951b2c
--- /dev/null
+++ b/inst/extdata/Dayhoff.dat
@@ -0,0 +1,22 @@
+
+27.00
+98.00 32.00
+120.00 0.00 905.00
+36.00 23.00 0.00 0.00
+89.00 246.00 103.00 134.00 0.00
+198.00 1.00 148.00 1153.00 0.00 716.00
+240.00 9.00 139.00 125.00 11.00 28.00 81.00
+23.00 240.00 535.00 86.00 28.00 606.00 43.00 10.00
+65.00 64.00 77.00 24.00 44.00 18.00 61.00 0.00 7.00
+41.00 15.00 34.00 0.00 0.00 73.00 11.00 7.00 44.00 257.00
+26.00 464.00 318.00 71.00 0.00 153.00 83.00 27.00 26.00 46.00 18.00
+72.00 90.00 1.00 0.00 0.00 114.00 30.00 17.00 0.00 336.00 527.00 243.00
+18.00 14.00 14.00 0.00 0.00 0.00 0.00 15.00 48.00 196.00 157.00 0.00 92.00
+250.00 103.00 42.00 13.00 19.00 153.00 51.00 34.00 94.00 12.00 32.00 33.00 17.00 11.00
+409.00 154.00 495.00 95.00 161.00 56.00 79.00 234.00 35.00 24.00 17.00 96.00 62.00 46.00 245.00
+371.00 26.00 229.00 66.00 16.00 53.00 34.00 30.00 22.00 192.00 33.00 136.00 104.00 13.00 78.00 550.00
+0.00 201.00 23.00 0.00 0.00 0.00 0.00 0.00 27.00 0.00 46.00 0.00 0.00 76.00 0.00 75.00 0.00
+24.00 8.00 95.00 0.00 96.00 0.00 22.00 0.00 127.00 37.00 28.00 13.00 0.00 698.00 0.00 34.00 42.00 61.00
+208.00 24.00 15.00 18.00 49.00 35.00 37.00 54.00 44.00 889.00 175.00 10.00 258.00 12.00 48.00 30.00 157.00 0.00 28.00
+
+0.087127 0.040904 0.040432 0.046872 0.033474 0.038255 0.049530 0.088612 0.033618 0.036886 0.085357 0.080482 0.014753 0.039772 0.050680 0.069577 0.058542 0.010494 0.029916 0.064718
diff --git a/inst/extdata/FLU.dat b/inst/extdata/FLU.dat
new file mode 100644
index 0000000..40f87f8
--- /dev/null
+++ b/inst/extdata/FLU.dat
@@ -0,0 +1,22 @@
+
+0.138658764751059
+0.0533665787145181 0.161000889039552
+0.584852305649886 0.00677184253227681 7.73739287051356
+0.0264470951166826 0.16720700818221 1.30249856764315e-005 0.014132062548787
+0.353753981649393 3.29271694159791 0.530642655337477 0.145469388422239 0.00254733397966779
+1.4842345032161 0.124897616909194 0.0616521921873234 5.37051127867923 3.91106992668137e-011 1.19562912226203
+1.13231312248046 1.19062446519178 0.322524647863997 1.93483278448943 0.116941459124876 0.108051341246072 1.59309882471598
+0.214757862168721 1.87956993845887 1.38709603234116 0.887570549414031 0.0218446166959521 5.33031341222104 0.256491863423002 0.0587745274250666
+0.149926734229061 0.246117171830255 0.21857197541607 0.0140859174993809 0.00111215807314139 0.0288399502994541 0.0142107118685268 1.62662283098296e-005 0.243190142026506
+0.0231169515264061 0.296045557460629 0.000835873174542931 0.00573068208525287 0.00561362724916376 1.02036695531654 0.016499535540562 0.00651622937676521 0.321611693603646 3.51207228207807
+0.474333610192982 15.3000966197798 2.6468479652886 0.290042980143818 3.83228119049152e-006 2.559587177122 3.88148880863814 0.264148929349066 0.347302791211758 0.227707997165566 0.129223639195248
+0.0587454231508643 0.890162345593224 0.00525168778853117 0.0417629637305017 0.111457310321926 0.190259181297527 0.313974351356074 0.00150046692269255 0.00127350890508147 9.01795420287895 6.74693648486614 1.33129161941264
+0.0804909094320368 0.0160550314767596 0.000836445615590923 1.0600102849456e-006 0.10405366623526 0.0326806570137471 0.00100350082518749 0.00123664495412902 0.119028506158521 1.46335727834648 2.98680003596399 0.319895904499071 0.279910508981581
+0.659311477863896 0.154027179890711 0.0364417719063219 0.188539456415654 1.59312060172652e-013 0.712769599068934 0.319558828428154 0.0386317614553493 0.924466914225534 0.0805433268150369 0.634308520867322 0.195750631825315 0.0568693216513547 0.0071324304661639
+3.01134451903854 0.950138410087378 3.88131053061457 0.338372183381345 0.336263344504404 0.487822498528951 0.307140298031341 1.58564657669139 0.580704249811294 0.290381075260226 0.570766693213698 0.283807671568883 0.00702658828739369 0.996685669575839 2.08738534433198
+5.4182981753166 0.183076905018197 2.14033231636063 0.135481232622983 0.011975265782196 0.60234096342392 0.2801248951174 0.0188080299490973 0.368713573381758 2.90405228596936 0.0449263566753846 1.52696419998775 2.03151132062208 0.000134906239484254 0.54225109402693 2.2068599339404
+0.195966354027106 1.36942940801512 0.000536284040016542 1.4893873721753e-005 0.0941066800969967 0.0440205200833047 0.155245492137294 0.196486447133033 0.0223729191088972 0.0321321499585514 0.431277662888057 4.97641445484395e-005 0.0704600385245663 0.814753093809928 0.000431020702277328 0.0998357527014247 0.207066205546908
+0.0182892882245349 0.0998554972524385 0.373101926513925 0.525398542949365 0.601692431136271 0.0722059354079545 0.104092870343653 0.0748149970972622 6.44895444648517 0.273934263183281 0.340058468374384 0.0124162215506117 0.874272174533394 5.39392424532822 0.000182294881489116 0.392552239890831 0.124898020409882 0.42775543040588
+3.53200526987468 0.103964386383736 0.0102575172450253 0.297123975243582 0.0549045639492389 0.406697814049488 0.285047948309311 0.337229618868315 0.0986313546653266 14.3940521944257 0.890598579382591 0.0731279296372675 4.90484223478739 0.592587985458668 0.0589719751511691 0.0882564232979724 0.654109108255219 0.256900461407996 0.167581646770807
+
+0.0470718 0.0509102 0.0742143 0.0478596 0.0250216 0.0333036 0.0545874 0.0763734 0.0199642 0.0671336 0.0714981 0.0567845 0.0181507 0.0304961 0.0506561 0.0884091 0.0743386 0.0185237 0.0314741 0.0632292
diff --git a/inst/extdata/HIVb.dat b/inst/extdata/HIVb.dat
new file mode 100644
index 0000000..3fc9d8a
--- /dev/null
+++ b/inst/extdata/HIVb.dat
@@ -0,0 +1,22 @@
+
+0.307507
+0.005 0.295543
+1.45504 0.005 17.6612
+0.123758 0.351721 0.0860642 0.005
+0.0551128 3.4215 0.672052 0.005 0.005
+1.48135 0.0749218 0.0792633 10.5872 0.005 2.5602
+2.13536 3.65345 0.323401 2.83806 0.897871 0.0619137 3.92775
+0.0847613 9.04044 7.64585 1.9169 0.240073 7.05545 0.11974 0.005
+0.005 0.677289 0.680565 0.0176792 0.005 0.005 0.00609079 0.005 0.103111
+0.215256 0.701427 0.005 0.00876048 0.129777 1.49456 0.005 0.005 1.74171 5.95879
+0.005 20.45 7.90443 0.005 0.005 6.54737 4.61482 0.521705 0.005 0.322319 0.0814995
+0.0186643 2.51394 0.005 0.005 0.005 0.303676 0.175789 0.005 0.005 11.2065 5.31961 1.28246
+0.0141269 0.005 0.005 0.005 9.29815 0.005 0.005 0.291561 0.145558 3.39836 8.52484 0.0342658 0.188025
+2.12217 1.28355 0.00739578 0.0342658 0.005 4.47211 0.0120226 0.005 2.45318 0.0410593 2.07757 0.0313862 0.005 0.005
+2.46633 3.4791 13.1447 0.52823 4.69314 0.116311 0.005 4.38041 0.382747 1.21803 0.927656 0.504111 0.005 0.956472 5.37762
+15.9183 2.86868 6.88667 0.274724 0.739969 0.243589 0.289774 0.369615 0.711594 8.61217 0.0437673 4.67142 4.94026 0.0141269 2.01417 8.93107
+0.005 0.991338 0.005 0.005 2.63277 0.026656 0.005 1.21674 0.0695179 0.005 0.748843 0.005 0.089078 0.829343 0.0444506 0.0248728 0.005
+0.005 0.00991826 1.76417 0.674653 7.57932 0.113033 0.0792633 0.005 18.6943 0.148168 0.111986 0.005 0.005 15.34 0.0304381 0.648024 0.105652 1.28022
+7.61428 0.0812454 0.026656 1.04793 0.420027 0.0209153 1.02847 0.953155 0.005 17.7389 1.41036 0.265829 6.8532 0.723274 0.005 0.0749218 0.709226 0.005 0.0410593
+
+0.060490222 0.066039665 0.044127815 0.042109048 0.020075899 0.053606488 0.071567447 0.072308239 0.022293943 0.069730629 0.098851122 0.056968211 0.019768318 0.028809447 0.046025282 0.05060433 0.053636813 0.033011601 0.028350243 0.061625237
diff --git a/inst/extdata/HIVw.dat b/inst/extdata/HIVw.dat
new file mode 100644
index 0000000..6ee5d9d
--- /dev/null
+++ b/inst/extdata/HIVw.dat
@@ -0,0 +1,22 @@
+
+0.0744808
+0.617509 0.16024
+4.43521 0.0674539 29.4087
+0.167653 2.86364 0.0604932 0.005
+0.005 10.6746 0.342068 0.005 0.005
+5.56325 0.0251632 0.201526 12.1233 0.005 3.20656
+1.8685 13.4379 0.0604932 10.3969 0.0489798 0.0604932 14.7801
+0.005 6.84405 8.59876 2.31779 0.005 18.5465 0.005 0.005
+0.005 1.34069 0.987028 0.145124 0.005 0.0342252 0.0390512 0.005 0.005
+0.16024 0.586757 0.005 0.005 0.005 2.89048 0.129839 0.0489798 1.76382 9.10246
+0.592784 39.8897 10.6655 0.894313 0.005 13.0705 23.9626 0.279425 0.22406 0.817481 0.005
+0.005 3.28652 0.201526 0.005 0.005 0.005 0.005 0.0489798 0.005 17.3064 11.3839 4.09564
+0.597923 0.005 0.005 0.005 0.362959 0.005 0.005 0.005 0.005 1.48288 7.48781 0.005 0.005
+1.00981 0.404723 0.344848 0.005 0.005 3.04502 0.005 0.005 13.9444 0.005 9.83095 0.111928 0.005 0.0342252
+8.5942 8.35024 14.5699 0.427881 1.12195 0.16024 0.005 6.27966 0.725157 0.740091 6.14396 0.005 0.392575 4.27939 14.249
+24.1422 0.928203 4.54206 0.630395 0.005 0.203091 0.458743 0.0489798 0.95956 9.36345 0.005 4.04802 7.41313 0.114512 4.33701 6.34079
+0.005 5.96564 0.005 0.005 5.49894 0.0443298 0.005 2.8258 0.005 0.005 1.37031 0.005 0.005 0.005 0.005 1.10156 0.005
+0.005 0.005 5.06475 2.28154 8.34835 0.005 0.005 0.005 47.4889 0.114512 0.005 0.005 0.579198 4.12728 0.005 0.933142 0.490608 0.005
+24.8094 0.279425 0.0744808 2.91786 0.005 0.005 2.19952 2.79622 0.827479 24.8231 2.95344 0.128065 14.7683 2.28 0.005 0.862637 0.005 0.005 1.35482
+
+0.0377494 0.057321 0.0891129 0.0342034 0.0240105 0.0437824 0.0618606 0.0838496 0.0156076 0.0983641 0.0577867 0.0641682 0.0158419 0.0422741 0.0458601 0.0550846 0.0813774 0.019597 0.0205847 0.0515639
diff --git a/inst/extdata/JTT.dat b/inst/extdata/JTT.dat
new file mode 100644
index 0000000..208abae
--- /dev/null
+++ b/inst/extdata/JTT.dat
@@ -0,0 +1,22 @@
+
+58.00
+54.00 45.00
+81.00 16.00 528.00
+56.00 113.00 34.00 10.00
+57.00 310.00 86.00 49.00 9.00
+105.00 29.00 58.00 767.00 5.00 323.00
+179.00 137.00 81.00 130.00 59.00 26.00 119.00
+27.00 328.00 391.00 112.00 69.00 597.00 26.00 23.00
+36.00 22.00 47.00 11.00 17.00 9.00 12.00 6.00 16.00
+30.00 38.00 12.00 7.00 23.00 72.00 9.00 6.00 56.00 229.00
+35.00 646.00 263.00 26.00 7.00 292.00 181.00 27.00 45.00 21.00 14.00
+54.00 44.00 30.00 15.00 31.00 43.00 18.00 14.00 33.00 479.00 388.00 65.00
+15.00 5.00 10.00 4.00 78.00 4.00 5.00 5.00 40.00 89.00 248.00 4.00 43.00
+194.00 74.00 15.00 15.00 14.00 164.00 18.00 24.00 115.00 10.00 102.00 21.00 16.00 17.00
+378.00 101.00 503.00 59.00 223.00 53.00 30.00 201.00 73.00 40.00 59.00 47.00 29.00 92.00 285.00
+475.00 64.00 232.00 38.00 42.00 51.00 32.00 33.00 46.00 245.00 25.00 103.00 226.00 12.00 118.00 477.00
+9.00 126.00 8.00 4.00 115.00 18.00 10.00 55.00 8.00 9.00 52.00 10.00 24.00 53.00 6.00 35.00 12.00
+11.00 20.00 70.00 46.00 209.00 24.00 7.00 8.00 573.00 32.00 24.00 8.00 18.00 536.00 10.00 63.00 21.00 71.00
+298.00 17.00 16.00 31.00 62.00 20.00 45.00 47.00 11.00 961.00 180.00 14.00 323.00 62.00 23.00 38.00 112.00 25.00 16.00
+
+0.076748 0.051691 0.042645 0.051544 0.019803 0.040752 0.061830 0.073152 0.022944 0.053761 0.091904 0.058676 0.023826 0.040126 0.050901 0.068765 0.058565 0.014261 0.032102 0.066005
diff --git a/inst/extdata/MtZoa.dat b/inst/extdata/MtZoa.dat
new file mode 100644
index 0000000..e9d4766
--- /dev/null
+++ b/inst/extdata/MtZoa.dat
@@ -0,0 +1,30 @@
+ 3.3
+ 1.7 33.6
+ 16.1 3.2 617.0
+ 272.5 61.1 94.6 9.5
+ 7.3 231.0 190.3 19.3 49.1
+ 17.1 6.4 174.0 883.6 3.4 349.4
+ 289.3 7.2 99.3 26.0 82.4 8.9 43.1
+ 2.3 61.7 228.9 55.6 37.5 421.8 14.9 7.4
+ 33.2 0.2 24.3 1.5 48.8 0.2 7.3 3.4 1.6
+ 15.6 4.1 7.9 0.5 59.7 23.0 1.0 3.5 6.6 425.2
+ 0.2 292.3 413.4 0.2 0.2 334.0 163.2 10.1 23.9 8.4 6.7
+ 136.5 3.8 73.7 0.2 264.8 83.9 0.2 52.2 7.1 449.7 636.3 83.0
+ 26.5 0.2 12.9 2.0 167.8 9.5 0.2 5.8 13.1 90.3 234.2 16.3 215.6
+ 61.8 7.5 22.6 0.2 8.1 52.2 20.6 1.3 15.6 2.6 11.4 24.3 5.4 10.5
+ 644.9 11.8 420.2 51.4 656.3 96.4 38.4 257.1 23.1 7.2 15.2 144.9 95.3 32.2 79.7
+ 378.1 3.2 184.6 2.3 199.0 39.4 34.5 5.2 19.4 222.3 50.0 75.5 305.1 19.3 56.9 666.3
+ 3.1 16.9 6.4 0.2 36.1 6.1 3.5 12.3 4.5 9.7 27.2 6.6 48.7 58.2 1.3 10.3 3.6
+ 2.1 13.8 141.6 13.9 76.7 52.3 10.0 4.3 266.5 13.1 5.7 45.0 41.4 590.5 4.2 29.7 29.0 79.8
+ 321.9 5.1 7.1 3.7 243.8 9.0 16.3 23.7 0.3 1710.6 126.1 11.1 279.6 59.6 17.9 49.5 396.4 13.7 15.6
+
+0.068880 0.021037 0.030390 0.020696 0.009966 0.018623 0.024989 0.071968 0.026814 0.085072 0.156717 0.019276 0.050652 0.081712 0.044803 0.080535 0.056386 0.027998 0.037404 0.066083
+ Ala Arg Asn Asp Cys Gln Glu Gly His Ile Leu Lys Met Phe Pro Ser Thr Trp Tyr Val
+
+// end of file
+
+Rota-Stabelli, O., Z. Yang, and M. Telford. 2009. MtZoa: a general mitochondrial amino acid substitutions model for animal evolutionary studies. Mol. Phyl. Evol.
+
+
+
+
diff --git a/inst/extdata/RtREV.dat b/inst/extdata/RtREV.dat
new file mode 100644
index 0000000..294be24
--- /dev/null
+++ b/inst/extdata/RtREV.dat
@@ -0,0 +1,22 @@
+
+34
+51 35
+10 30 384
+439 92 128 1
+32 221 236 78 70
+81 10 79 542 1 372
+135 41 94 61 48 18 70
+30 90 320 91 124 387 34 68
+1 24 35 1 104 33 1 1 34
+45 18 15 5 110 54 21 3 51 385
+38 593 123 20 16 309 141 30 76 34 23
+235 57 1 1 156 158 1 37 116 375 581 134
+1 7 49 1 70 1 1 7 141 64 179 14 247
+97 24 33 55 1 68 52 17 44 10 22 43 1 11
+460 102 294 136 75 225 95 152 183 4 24 77 1 20 134
+258 64 148 55 117 146 82 7 49 72 25 110 131 69 62 671
+5 13 16 1 55 10 17 23 48 39 47 6 111 182 9 14 1
+55 47 28 1 131 45 1 21 307 26 64 1 74 1017 14 31 34 176
+197 29 21 6 295 36 35 3 1 1048 112 19 236 92 25 39 196 26 59
+
+0.0646 0.0453 0.0376 0.0422 0.0114 0.0606 0.0607 0.0639 0.0273 0.0679 0.1018 0.0751 0.015 0.0287 0.0681 0.0488 0.0622 0.0251 0.0318 0.0619
diff --git a/inst/extdata/VT.dat b/inst/extdata/VT.dat
new file mode 100644
index 0000000..9fd1c10
--- /dev/null
+++ b/inst/extdata/VT.dat
@@ -0,0 +1,22 @@
+
+0.233108
+0.199097 0.210797
+0.265145 0.105191 0.883422
+0.227333 0.031726 0.027495 0.010313
+0.310084 0.493763 0.2757 0.205842 0.004315
+0.567957 0.25524 0.270417 1.599461 0.005321 0.960976
+0.876213 0.156945 0.362028 0.311718 0.050876 0.12866 0.250447
+0.078692 0.213164 0.290006 0.134252 0.016695 0.315521 0.104458 0.058131
+0.222972 0.08151 0.087225 0.01172 0.046398 0.054602 0.046589 0.051089 0.020039
+0.42463 0.192364 0.069245 0.060863 0.091709 0.24353 0.151924 0.087056 0.103552 2.08989
+0.393245 1.755838 0.50306 0.261101 0.004067 0.738208 0.88863 0.193243 0.153323 0.093181 0.201204
+0.21155 0.08793 0.05742 0.012182 0.02369 0.120801 0.058643 0.04656 0.021157 0.493845 1.105667 0.096474
+0.116646 0.042569 0.039769 0.016577 0.051127 0.026235 0.028168 0.050143 0.079807 0.32102 0.946499 0.038261 0.173052
+0.399143 0.12848 0.083956 0.160063 0.011137 0.15657 0.205134 0.124492 0.078892 0.054797 0.169784 0.212302 0.010363 0.042564
+1.817198 0.292327 0.847049 0.461519 0.17527 0.358017 0.406035 0.612843 0.167406 0.081567 0.214977 0.400072 0.090515 0.138119 0.430431
+0.877877 0.204109 0.471268 0.178197 0.079511 0.248992 0.321028 0.136266 0.101117 0.376588 0.243227 0.446646 0.184609 0.08587 0.207143 1.767766
+0.030309 0.046417 0.010459 0.011393 0.007732 0.021248 0.018844 0.02399 0.020009 0.034954 0.083439 0.023321 0.022019 0.12805 0.014584 0.035933 0.020437
+0.087061 0.09701 0.093268 0.051664 0.042823 0.062544 0.0552 0.037568 0.286027 0.086237 0.189842 0.068689 0.073223 0.898663 0.032043 0.121979 0.094617 0.124746
+1.230985 0.113146 0.049824 0.048769 0.163831 0.112027 0.205868 0.082579 0.068575 3.65443 1.337571 0.144587 0.307309 0.247329 0.129315 0.1277 0.740372 0.022134 0.125733
+
+0.078837 0.051238 0.042313 0.053066 0.015175 0.036713 0.061924 0.070852 0.023082 0.062056 0.096371 0.057324 0.023771 0.043296 0.043911 0.063403 0.055897 0.013272 0.034399 0.073101
diff --git a/inst/extdata/cpREV.dat b/inst/extdata/cpREV.dat
new file mode 100644
index 0000000..87561c4
--- /dev/null
+++ b/inst/extdata/cpREV.dat
@@ -0,0 +1,39 @@
+
+ 105
+ 227 357
+ 175 43 4435
+ 669 823 538 10
+ 157 1745 768 400 10
+ 499 152 1055 3691 10 3122
+ 665 243 653 431 303 133 379
+ 66 715 1405 331 441 1269 162 19
+ 145 136 168 10 280 92 148 40 29
+ 197 203 113 10 396 286 82 20 66 1745
+ 236 4482 2430 412 48 3313 2629 263 305 345 218
+ 185 125 61 47 159 202 113 21 10 1772 1351 193
+ 68 53 97 22 726 10 145 25 127 454 1268 72 327
+ 490 87 173 170 285 323 185 28 152 117 219 302 100 43
+ 2440 385 2085 590 2331 396 568 691 303 216 516 868 93 487 1202
+ 1340 314 1393 266 576 241 369 92 32 1040 156 918 645 148 260 2151
+ 14 230 40 18 435 53 63 82 69 42 159 10 86 468 49 73 29
+ 56 323 754 281 1466 391 142 10 1971 89 189 247 215 2370 97 522 71 346
+ 968 92 83 75 592 54 200 91 25 4797 865 249 475 317 122 167 760 10 119
+
+ 0.0755 0.0621 0.0410 0.0371 0.0091 0.0382 0.0495 0.0838 0.0246 0.0806 0.1011 0.0504 0.0220 0.0506 0.0431 0.0622 0.0543 0.0181 0.0307 0.0660
+
+ A R N D C Q E G H I L K M F P S T W Y V
+Ala Arg Asn Asp Cys Gln Glu Gly His Ile Leu Lys Met Phe Pro Ser Thr Trp Tyr Val
+
+Symmetrical part of the rate matrix and aa frequencies, estimated for
+plant chloroplast proteins, under the REVaa model. The first part is
+S_ij = S_ji, and the second part has the amino acid frequencies
+(\pi_i). The substitution rate from amino acid i to j is Q_ij =
+S_ij*PI_j. This is the cpREV model used in protml 2.3b6 (12/10/98),
+described by
+
+Adachi, J., P. J. Waddell, W. Martin, and M. Hasegawa. 2000. Plastid
+genome phylogeny and a model of amino acid substitution for proteins
+encoded by chloroplast DNA. Journal of Molecular Evolution 50:348-358.
+
+
+
diff --git a/inst/extdata/dayhoff-dcmut.dat b/inst/extdata/dayhoff-dcmut.dat
new file mode 100644
index 0000000..2c29ea8
--- /dev/null
+++ b/inst/extdata/dayhoff-dcmut.dat
@@ -0,0 +1,50 @@
+0.267828
+0.984474 0.327059
+1.199805 0.000000 8.931515
+0.360016 0.232374 0.000000 0.000000
+0.887753 2.439939 1.028509 1.348551 0.000000
+1.961167 0.000000 1.493409 11.388659 0.000000 7.086022
+2.386111 0.087791 1.385352 1.240981 0.107278 0.281581 0.811907
+0.228116 2.383148 5.290024 0.868241 0.282729 6.011613 0.439469 0.106802
+0.653416 0.632629 0.768024 0.239248 0.438074 0.180393 0.609526 0.000000 0.076981
+0.406431 0.154924 0.341113 0.000000 0.000000 0.730772 0.112880 0.071514 0.443504 2.556685
+0.258635 4.610124 3.148371 0.716913 0.000000 1.519078 0.830078 0.267683 0.270475 0.460857 0.180629
+0.717840 0.896321 0.000000 0.000000 0.000000 1.127499 0.304803 0.170372 0.000000 3.332732 5.230115 2.411739
+0.183641 0.136906 0.138503 0.000000 0.000000 0.000000 0.000000 0.153478 0.475927 1.951951 1.565160 0.000000 0.921860
+2.485920 1.028313 0.419244 0.133940 0.187550 1.526188 0.507003 0.347153 0.933709 0.119152 0.316258 0.335419 0.170205 0.110506
+4.051870 1.531590 4.885892 0.956097 1.598356 0.561828 0.793999 2.322243 0.353643 0.247955 0.171432 0.954557 0.619951 0.459901 2.427202
+3.680365 0.265745 2.271697 0.660930 0.162366 0.525651 0.340156 0.306662 0.226333 1.900739 0.331090 1.350599 1.031534 0.136655 0.782857 5.436674
+0.000000 2.001375 0.224968 0.000000 0.000000 0.000000 0.000000 0.000000 0.270564 0.000000 0.461776 0.000000 0.000000 0.762354 0.000000 0.740819 0.000000
+0.244139 0.078012 0.946940 0.000000 0.953164 0.000000 0.214717 0.000000 1.265400 0.374834 0.286572 0.132142 0.000000 6.952629 0.000000 0.336289 0.417839 0.608070
+2.059564 0.240368 0.158067 0.178316 0.484678 0.346983 0.367250 0.538165 0.438715 8.810038 1.745156 0.103850 2.565955 0.123606 0.485026 0.303836 1.561997 0.000000 0.279379
+
+
+0.087127 0.040904 0.040432 0.046872 0.033474 0.038255 0.049530 0.088612 0.033619 0.036886 0.085357 0.080481 0.014753 0.039772 0.050680 0.069577 0.058542 0.010494 0.029916 0.064718
+
+
+ A R N D C Q E G H I L K M F P S T W Y V
+Ala Arg Asn Asp Cys Gln Glu Gly His Ile Leu Lys Met Phe Pro Ser Thr Trp Tyr Val
+
+#
+#Dayhoff rate matrix prepared using the DCMut method*
+#----------------------------------------------------
+#
+#The first part above indicates the symmetric 'exchangeability' parameters s_ij,
+#where s_ij = s_ji.
+#The second part gives the amino acid equilibrium frequencies pi_i.
+#The net replacement rate from i to j is q_ij = pi_j*s_ij.
+#
+#This model is usually scaled so that the mean rate of change at
+#equilibrium, Sum_i Sum_j!=i pi_i*q_ij, equals 1. You should check this
+#scaling before using the matrix above. The PAML package will perform
+#this scaling.
+#
+#
+#
+#*Prepared by Carolin Kosiol and Nick Goldman, December 2003.
+#
+#See the following paper for more details:
+#Kosiol, C., and Goldman, N. 2005. Different versions of the Dayhoff rate matrix.
+#Molecular Biology and Evolution 22:193-199.
+#
+#See also http://www.ebi.ac.uk/goldman/dayhoff
diff --git a/inst/extdata/jtt-dcmut.dat b/inst/extdata/jtt-dcmut.dat
new file mode 100644
index 0000000..c1ff3c4
--- /dev/null
+++ b/inst/extdata/jtt-dcmut.dat
@@ -0,0 +1,50 @@
+0.531678
+0.557967 0.451095
+0.827445 0.154899 5.549530
+0.574478 1.019843 0.313311 0.105625
+0.556725 3.021995 0.768834 0.521646 0.091304
+1.066681 0.318483 0.578115 7.766557 0.053907 3.417706
+1.740159 1.359652 0.773313 1.272434 0.546389 0.231294 1.115632
+0.219970 3.210671 4.025778 1.032342 0.724998 5.684080 0.243768 0.201696
+0.361684 0.239195 0.491003 0.115968 0.150559 0.078270 0.111773 0.053769 0.181788
+0.310007 0.372261 0.137289 0.061486 0.164593 0.709004 0.097485 0.069492 0.540571 2.335139
+0.369437 6.529255 2.529517 0.282466 0.049009 2.966732 1.731684 0.269840 0.525096 0.202562 0.146481
+0.469395 0.431045 0.330720 0.190001 0.409202 0.456901 0.175084 0.130379 0.329660 4.831666 3.856906 0.624581
+0.138293 0.065314 0.073481 0.032522 0.678335 0.045683 0.043829 0.050212 0.453428 0.777090 2.500294 0.024521 0.436181
+1.959599 0.710489 0.121804 0.127164 0.123653 1.608126 0.191994 0.208081 1.141961 0.098580 1.060504 0.216345 0.164215 0.148483
+3.887095 1.001551 5.057964 0.589268 2.155331 0.548807 0.312449 1.874296 0.743458 0.405119 0.592511 0.474478 0.285564 0.943971 2.788406
+4.582565 0.650282 2.351311 0.425159 0.469823 0.523825 0.331584 0.316862 0.477355 2.553806 0.272514 0.965641 2.114728 0.138904 1.176961 4.777647
+0.084329 1.257961 0.027700 0.057466 1.104181 0.172206 0.114381 0.544180 0.128193 0.134510 0.530324 0.089134 0.201334 0.537922 0.069965 0.310927 0.080556
+0.139492 0.235601 0.700693 0.453952 2.114852 0.254745 0.063452 0.052500 5.848400 0.303445 0.241094 0.087904 0.189870 5.484236 0.113850 0.628608 0.201094 0.747889
+2.924161 0.171995 0.164525 0.315261 0.621323 0.179771 0.465271 0.470140 0.121827 9.533943 1.761439 0.124066 3.038533 0.593478 0.211561 0.408532 1.143980 0.239697 0.165473
+
+
+0.076862 0.051057 0.042546 0.051269 0.020279 0.041061 0.061820 0.074714 0.022983 0.052569 0.091111 0.059498 0.023414 0.040530 0.050532 0.068225 0.058518 0.014336 0.032303 0.066374
+
+
+ A R N D C Q E G H I L K M F P S T W Y V
+Ala Arg Asn Asp Cys Gln Glu Gly His Ile Leu Lys Met Phe Pro Ser Thr Trp Tyr Val
+
+
+#JTT rate matrix prepared using the DCMut method*
+#------------------------------------------------
+#
+#The first part above indicates the symmetric 'exchangeability' parameters s_ij,
+#where s_ij = s_ji.
+#The second part gives the amino acid equilibrium frequencies pi_i.
+#The net replacement rate from i to j is q_ij = pi_j*s_ij.
+#
+#This model is usually scaled so that the mean rate of change at
+#equilibrium, Sum_i Sum_j!=i pi_i*q_ij, equals 1. You should check this
+#scaling before using the matrix above. The PAML package will perform
+#this scaling.
+#
+#//
+#
+#*Prepared by Carolin Kosiol and Nick Goldman, December 2003.
+#
+#See the following paper for more details:
+#Kosiol, C., and Goldman, N. 2005. Different versions of the Dayhoff rate matrix.
+#Molecular Biology and Evolution 22:193-199.
+#
+#See also http://www.ebi.ac.uk/goldman/dayhoff
diff --git a/inst/extdata/lg.dat b/inst/extdata/lg.dat
new file mode 100644
index 0000000..3a00ea6
--- /dev/null
+++ b/inst/extdata/lg.dat
@@ -0,0 +1,22 @@
+
+0.425093
+0.276818 0.751878
+0.395144 0.123954 5.076149
+2.489084 0.534551 0.528768 0.062556
+0.969894 2.807908 1.695752 0.523386 0.084808
+1.038545 0.363970 0.541712 5.243870 0.003499 4.128591
+2.066040 0.390192 1.437645 0.844926 0.569265 0.267959 0.348847
+0.358858 2.426601 4.509238 0.927114 0.640543 4.813505 0.423881 0.311484
+0.149830 0.126991 0.191503 0.010690 0.320627 0.072854 0.044265 0.008705 0.108882
+0.395337 0.301848 0.068427 0.015076 0.594007 0.582457 0.069673 0.044261 0.366317 4.145067
+0.536518 6.326067 2.145078 0.282959 0.013266 3.234294 1.807177 0.296636 0.697264 0.159069 0.137500
+1.124035 0.484133 0.371004 0.025548 0.893680 1.672569 0.173735 0.139538 0.442472 4.273607 6.312358 0.656604
+0.253701 0.052722 0.089525 0.017416 1.105251 0.035855 0.018811 0.089586 0.682139 1.112727 2.592692 0.023918 1.798853
+1.177651 0.332533 0.161787 0.394456 0.075382 0.624294 0.419409 0.196961 0.508851 0.078281 0.249060 0.390322 0.099849 0.094464
+4.727182 0.858151 4.008358 1.240275 2.784478 1.223828 0.611973 1.739990 0.990012 0.064105 0.182287 0.748683 0.346960 0.361819 1.338132
+2.139501 0.578987 2.000679 0.425860 1.143480 1.080136 0.604545 0.129836 0.584262 1.033739 0.302936 1.136863 2.020366 0.165001 0.571468 6.472279
+0.180717 0.593607 0.045376 0.029890 0.670128 0.236199 0.077852 0.268491 0.597054 0.111660 0.619632 0.049906 0.696175 2.457121 0.095131 0.248862 0.140825
+0.218959 0.314440 0.612025 0.135107 1.165532 0.257336 0.120037 0.054679 5.306834 0.232523 0.299648 0.131932 0.481306 7.803902 0.089613 0.400547 0.245841 3.151815
+2.547870 0.170887 0.083688 0.037967 1.959291 0.210332 0.245034 0.076701 0.119013 10.649107 1.702745 0.185202 1.898718 0.654683 0.296501 0.098369 2.188158 0.189510 0.249313
+
+0.079066 0.055941 0.041977 0.053052 0.012937 0.040767 0.071586 0.057337 0.022355 0.062157 0.099081 0.064600 0.022951 0.042302 0.044040 0.061197 0.053287 0.012066 0.034155 0.069147
\ No newline at end of file
diff --git a/inst/extdata/mtArt.dat b/inst/extdata/mtArt.dat
new file mode 100644
index 0000000..b72ef1d
--- /dev/null
+++ b/inst/extdata/mtArt.dat
@@ -0,0 +1,113 @@
+
+0.2
+0.2 0.2
+1 4 500
+254 36 98 11
+0.2 154 262 0.2 0.2
+0.2 0.2 183 862 0.2 262
+200 0.2 121 12 81 3 44
+0.2 41 180 0.2 12 314 15 0.2
+26 2 21 7 63 11 7 3 0.2
+4 2 13 1 79 16 2 1 6 515
+0.2 209 467 2 0.2 349 106 0.2 0.2 3 4
+121 5 79 0.2 312 67 0.2 56 0.2 515 885 106
+13 5 20 0.2 184 0.2 0.2 1 14 118 263 11 322
+49 0.2 17 0.2 0.2 39 8 0.2 1 0.2 12 17 5 15
+673 3 398 44 664 52 31 226 11 7 8 144 112 36 87
+244 0.2 166 0.2 183 44 43 0.2 19 204 48 70 289 14 47 660
+0.2 0.2 8 0.2 22 7 11 2 0.2 0.2 21 16 71 54 0.2 2 0.2
+1 4 251 0.2 72 87 8 9 191 12 20 117 71 792 18 30 46 38
+340 0.2 23 0.2 350 0.2 14 3 0.2 1855 85 26 281 52 32 61 544 0.2 2
+
+0.054116 0.018227 0.039903 0.020160 0.009709 0.018781 0.024289 0.068183 0.024518 0.092638 0.148658 0.021718 0.061453 0.088668 0.041826 0.091030 0.049194 0.029786 0.039443 0.057700
+
+
+
+// this is the end of the file. The rest are notes.
+
+Ala Arg Asn Asp Cys Gln Glu Gly His Ile Leu Lys Met Phe Pro Ser Thr Trp Tyr Val
+
+This model has been derived from 36 artropoda mitochondrial genomes.
+
+Each gene of the given species was aligned individually. Then, alignments of the whole set
+of 13 genes where concatenated and passed through GBlocks (Castresana, 2000, in JME) with
+parameters and output:
+
+Minimum Number Of Sequences For A Conserved Position: 20
+Minimum Number Of Sequences For A Flanking Position: 32
+Maximum Number Of Contiguous Nonconserved Positions: 8
+Minimum Length Of A Block: 10
+Allowed Gap Positions: With Half
+Use Similarity Matrices: Yes
+
+Flank positions of the 40 selected block(s)
+Flanks: [6 22] [26 44] [61 70] [77 143] [145 185] [208 236] [309 640]
+[644 802] [831 941] [956 966] [973 1062] [1085 1339] [1343 1702]
+[1754 1831] [1840 1911] [1916 1987] [2011 2038] [2097 2118] [2125 2143]
+[2179 2215] [2243 2268] [2277 2288] [2333 2347] [2476 2518] [2539 2558]
+[2600 2613] [2637 2672] [2738 2759] [2784 2839] [2882 2924] [2948 3097]
+[3113 3123] [3210 3235] [3239 3322] [3348 3392] [3406 3526] [3588 3617]
+[3660 3692] [3803 3830] [3909 3928]
+
+New number of positions in MtArt-strict.phy.fasta-gb: <b> 2664 </b> (67% of the original 3933 positions)
+
+The species included in the analysis were:
+Harpiosquilla harpax [NCBI_TaxID 287944]
+Ixodes uriae [NCBI_TaxID 59655]
+Heptathela hangzhouensis [NCBI_TaxID 216259]
+Triops longicaudatus [NCBI_TaxID 58777]
+Gryllotalpa orientalis [NCBI_TaxID 213494]
+lepidopsocid RS-2001 [NCBI_TaxID 159971]
+Locusta migratoria [NCBI_TaxID 7004]
+Drosophila yakuba [NCBI_TaxID 7245]
+Ostrinia furnacalis [NCBI_TaxID 93504]
+Megabalanus volcano [NCBI_TaxID 266495]
+Periplaneta fuliginosa [NCBI_TaxID 36977]
+Thermobia domestica [NCBI_TaxID 89055]
+Aleurochiton aceris [NCBI_TaxID 266942]
+Schizaphis graminum [NCBI_TaxID 13262]
+Pteronarcys princeps [NCBI_TaxID 285953]
+Aleurodicus dugesii [NCBI_TaxID 30099]
+Pollicipes polymerus [NCBI_TaxID 36137]
+Gomphiocephalus hodgsoni [NCBI_TaxID 221270]
+Habronattus oregonensis [NCBI_TaxID 130930]
+Speleonectes tulumensis [NCBI_TaxID 84346]
+Hutchinsoniella macracantha [NCBI_TaxID 84335]
+Haemaphysalis flava [NCBI_TaxID 181088]
+Scutigera coleoptrata [NCBI_TaxID 29022]
+Vargula hilgendorfii [NCBI_TaxID 6674]
+Tricholepidion gertschi [NCBI_TaxID 89825]
+Varroa destructor [NCBI_TaxID 109461]
+Bombyx mandarina [NCBI_TaxID 7092]
+Thyropygus sp. [NCBI_TaxID 174155]
+Tribolium castaneum [NCBI_TaxID 7070]
+Pagurus longicarpus [NCBI_TaxID 111067]
+Limulus polyphemus [NCBI_TaxID 6850]
+Tetrodontophora bielanensis [NCBI_TaxID 48717]
+Penaeus monodon [NCBI_TaxID 6687]
+Daphnia pulex [NCBI_TaxID 6669]
+Apis mellifera [NCBI_TaxID 7469]
+Anopheles gambiae [NCBI_TaxID 7165]
+
+The topology used for inferring the model was:
+
+(((Daph_pulex,Trio_longi),((((((Aleu_aceri,Aleu_duges),Schi_grami),lepi_RS_20),
+((((Ostr_furna,Bomb_manda),(Dros_yakub,Anop_gambi)),Apis_melli),Trib_casta)),
+((Gryl_orien,Locu_migra),(Pter_princ,Peri_fulig))),(Tric_gerts,Ther_domes)),
+(Scut_coleo,Thyr_sp),Varg_hilge,Hutc_macra,((((Ixod_uriae,Haem_flava),Varr_destr),
+(Habr_orego,Hept_hangz)),Limu_polyp),(Poll_polym,Mega_volca),(Gomp_hodgs,Tetr_biela),
+((Pagu_longi,Pena_monod),Harp_harpa),Spel_tulum));
+
+Note this is not the ML topology but the consensus one (based on morphological data,
+phylogenetic reconstruction using nuclear genes, etc). Where relationships are
+not clear, a polytomy was introduced (it contains quite a lot of polytomies!).
+
+The model was estimated using Ziheng Yang's Paml software package.
+A four-categorized gamma distribution was used to account for heterogeneity (alpha
+was estimated to be 0.47821). Sites with ambiguity data were taken into account.
+
+
+Reference
+
+Abascal, F., D. Posada, and R. Zardoya. 2007. MtArt: A new Model of
+amino acid replacement for Arthropoda. Mol. Biol. Evol. 24:1-5.
diff --git a/inst/extdata/mtREV24.dat b/inst/extdata/mtREV24.dat
new file mode 100644
index 0000000..09d5f1f
--- /dev/null
+++ b/inst/extdata/mtREV24.dat
@@ -0,0 +1,39 @@
+ 23.18
+ 26.95 13.24
+ 17.67 1.90 794.38
+ 59.93 103.33 58.94 1.90
+ 1.90 220.99 173.56 55.28 75.24
+ 9.77 1.90 63.05 583.55 1.90 313.56
+ 120.71 23.03 53.30 56.77 30.71 6.75 28.28
+ 13.90 165.23 496.13 113.99 141.49 582.40 49.12 1.90
+ 96.49 1.90 27.10 4.34 62.73 8.34 3.31 5.98 12.26
+ 25.46 15.58 15.16 1.90 25.65 39.70 1.90 2.41 11.49 329.09
+ 8.36 141.40 608.70 2.31 1.90 465.58 313.86 22.73 127.67 19.57 14.88
+ 141.88 1.90 65.41 1.90 6.18 47.37 1.90 1.90 11.97 517.98 537.53 91.37
+ 6.37 4.69 15.20 4.98 70.80 19.11 2.67 1.90 48.16 84.67 216.06 6.44 90.82
+ 54.31 23.64 73.31 13.43 31.26 137.29 12.83 1.90 60.97 20.63 40.10 50.10 18.84 17.31
+ 387.86 6.04 494.39 69.02 277.05 54.11 54.71 125.93 77.46 47.70 73.61 105.79 111.16 64.29 169.90
+ 480.72 2.08 238.46 28.01 179.97 94.93 14.82 11.17 44.78 368.43 126.40 136.33 528.17 33.85 128.22 597.21
+ 1.90 21.95 10.68 19.86 33.60 1.90 1.90 10.92 7.08 1.90 32.44 24.00 21.71 7.84 4.21 38.58 9.99
+ 6.48 1.90 191.36 21.21 254.77 38.82 13.12 3.21 670.14 25.01 44.15 51.17 39.96 465.58 16.21 64.92 38.73 26.25
+ 195.06 7.64 1.90 1.90 1.90 19.00 21.14 2.53 1.90 1222.94 91.67 1.90 387.54 6.35 8.23 1.90 204.54 5.37 1.90
+
+
+0.072 0.019 0.039 0.019 0.006 0.025 0.024 0.056 0.028 0.088 0.169 0.023 0.054 0.061 0.054 0.072 0.086 0.029 0.033 0.043
+
+Ala Arg Asn Asp Cys Gln Glu Gly His Ile Leu Lys Met Phe Pro Ser Thr Trp Tyr Val
+
+
+S_ij = S_ji and PI_i for the mtREV24 model (Adachi and Hasegawa 1996).
+The PI's used to sum to 0.999 and I changed one of the freq from 0.168
+into 0.169 so that the sum is 1. Prepared by Z. Yang according to
+data sent by Dr M. Hasegawa. This matrix was obtained from the 12
+mitochondrial proteins encoded by the same strand of the DNA from a
+diverse range of species including bird, fish, frog, lamprey, as well
+as mammals (see Adachi and Hasegawa 1996 for details). The other
+matrix (mtmam.dat) included in the package is based on the same
+proteins from mammals only.
+
+Adachi, J. and Hasegawa, M. (1996) MOLPHY version 2.3: programs for
+molecular phylogenetics based on maximum likelihood. Computer Science
+Monographs of Institute of Statistical Mathematics 28:1-150.
diff --git a/inst/extdata/mtmam.dat b/inst/extdata/mtmam.dat
new file mode 100644
index 0000000..88f467d
--- /dev/null
+++ b/inst/extdata/mtmam.dat
@@ -0,0 +1,77 @@
+ 32
+ 2 4
+ 11 0 864
+ 0 186 0 0
+ 0 246 8 49 0
+ 0 0 0 569 0 274
+ 78 18 47 79 0 0 22
+ 8 232 458 11 305 550 22 0
+ 75 0 19 0 41 0 0 0 0
+ 21 6 0 0 27 20 0 0 26 232
+ 0 50 408 0 0 242 215 0 0 6 4
+ 76 0 21 0 0 22 0 0 0 378 609 59
+ 0 0 6 5 7 0 0 0 0 57 246 0 11
+ 53 9 33 2 0 51 0 0 53 5 43 18 0 17
+342 3 446 16 347 30 21 112 20 0 74 65 47 90 202
+681 0 110 0 114 0 4 0 1 360 34 50 691 8 78 614
+ 5 16 6 0 65 0 0 0 0 0 12 0 13 0 7 17 0
+ 0 0 156 0 530 54 0 1 1525 16 25 67 0 682 8 107 0 14
+398 0 0 10 0 33 20 5 0 2220 100 0 832 6 0 0 237 0 0
+
+
+0.0692 0.0184 0.0400 0.0186 0.0065 0.0238 0.0236 0.0557 0.0277 0.0905 0.1675 0.0221 0.0561 0.0611 0.0536 0.0725 0.0870 0.0293 0.0340 0.0428
+
+ A R N D C Q E G H I L K M F P S T W Y V
+Ala Arg Asn Asp Cys Gln Glu Gly His Ile Leu Lys Met Phe Pro Ser Thr Trp Tyr Val
+
+//End of File
+
+
+Symmetrical part of the rate matrix and aa frequencies, estimated from
+the 12 mt proteins (atp6 atp8 cox1 cox2 cox3 cytb nd1 nd2 nd3 nd4 nd4l
+nd5) on the same strand of the mitochondrial DNA (3331 sites). The
+data are from 20 species of mammals and three close outgroups
+(wallaroo, opossum, and platypus). The model used is
+REVaa+dGamma(K=8) with the estimated gamma parameter to be 0.37. The
+first part is S_ij = S_ji, and the second part has the amino acid
+frequencies (PI_i). The substitution rate from amino acid i to j is
+Q_ij=S_ij*PI_j.
+
+
+The data are from
+
+ Cao, Y. et al. 1998 Conflict amongst individual mitochondrial proteins
+ in resolving the phylogeny of eutherian orders. Journal of
+ Molecular Evolution 15:1600-1611.
+
+The species are listed below
+
+1 SB17F Homo sapiens (African) # D38112
+2 CHIMP Pan troglodytes (chimpanzee) # D38113
+3 PyGC Pan paniscus (bonobo) # D38116
+4 GORIL Gorilla gorilla (gorilla) # D38114
+5 ORANG Pongo pygmaeus (orangutan) # D38115
+6 Ponpy Pongo pygmaeus abelii (Sumatran orangutan) # X97707
+7 Hylla Hylobates lar (common gibbon) # X99256 (lar gibbon)
+8 Phovi Phoca vitulina (harbor seal) # X63726
+9 Halgr Halichoerus grypus (grey seal) # X72004
+10 Felca Felis catus (cat) # U20753
+11 Equca Equus caballus (horse) # X79547
+12 Rhiun Rhinoceros unicornis (Indian rhinoceros) # X97336
+13 Bosta Bos taurus (cow) # J01394
+14 Balph Balaenoptera physalus (fin whale) # X61145
+15 Balmu Balaenoptera musculus (blue whale) # X72204
+16 Ratno Rattus norvegicus (rat) # X14848
+17 Musmu Mus musculus (mouse) # J01420
+18 Macro Macropus robustus (wallaroo) # Y10524
+19 Didvi Didelphis virginiana (opossum) # Z29573
+20 Ornan Ornithorhynchus anatinus (platypus) # X83427
+
+
+The results and details of the model are published in
+
+ Yang, Z., R. Nielsen, and M. Hasegawa. 1998. Models of amino acid
+ substitution and applications to Mitochondrial protein evolution,
+ Molecular Biology and Evolution 15:1600-1611.
+
+Prepared by Z. Yang, April 1998.
diff --git a/inst/extdata/wag.dat b/inst/extdata/wag.dat
new file mode 100644
index 0000000..d90ffe5
--- /dev/null
+++ b/inst/extdata/wag.dat
@@ -0,0 +1,43 @@
+0.551571
+0.509848 0.635346
+0.738998 0.147304 5.429420
+1.027040 0.528191 0.265256 0.0302949
+0.908598 3.035500 1.543640 0.616783 0.0988179
+1.582850 0.439157 0.947198 6.174160 0.021352 5.469470
+1.416720 0.584665 1.125560 0.865584 0.306674 0.330052 0.567717
+0.316954 2.137150 3.956290 0.930676 0.248972 4.294110 0.570025 0.249410
+0.193335 0.186979 0.554236 0.039437 0.170135 0.113917 0.127395 0.0304501 0.138190
+0.397915 0.497671 0.131528 0.0848047 0.384287 0.869489 0.154263 0.0613037 0.499462 3.170970
+0.906265 5.351420 3.012010 0.479855 0.0740339 3.894900 2.584430 0.373558 0.890432 0.323832 0.257555
+0.893496 0.683162 0.198221 0.103754 0.390482 1.545260 0.315124 0.174100 0.404141 4.257460 4.854020 0.934276
+0.210494 0.102711 0.0961621 0.0467304 0.398020 0.0999208 0.0811339 0.049931 0.679371 1.059470 2.115170 0.088836 1.190630
+1.438550 0.679489 0.195081 0.423984 0.109404 0.933372 0.682355 0.243570 0.696198 0.0999288 0.415844 0.556896 0.171329 0.161444
+3.370790 1.224190 3.974230 1.071760 1.407660 1.028870 0.704939 1.341820 0.740169 0.319440 0.344739 0.967130 0.493905 0.545931 1.613280
+2.121110 0.554413 2.030060 0.374866 0.512984 0.857928 0.822765 0.225833 0.473307 1.458160 0.326622 1.386980 1.516120 0.171903 0.795384 4.378020
+0.113133 1.163920 0.0719167 0.129767 0.717070 0.215737 0.156557 0.336983 0.262569 0.212483 0.665309 0.137505 0.515706 1.529640 0.139405 0.523742 0.110864
+0.240735 0.381533 1.086000 0.325711 0.543833 0.227710 0.196303 0.103604 3.873440 0.420170 0.398618 0.133264 0.428437 6.454280 0.216046 0.786993 0.291148 2.485390
+2.006010 0.251849 0.196246 0.152335 1.002140 0.301281 0.588731 0.187247 0.118358 7.821300 1.800340 0.305434 2.058450 0.649892 0.314887 0.232739 1.388230 0.365369 0.314730
+
+0.0866279 0.043972 0.0390894 0.0570451 0.0193078 0.0367281 0.0580589 0.0832518 0.0244313 0.048466 0.086209 0.0620286 0.0195027 0.0384319 0.0457631 0.0695179 0.0610127 0.0143859 0.0352742 0.0708956
+
+
+ A R N D C Q E G H I L K M F P S T W Y V
+Ala Arg Asn Asp Cys Gln Glu Gly His Ile Leu Lys Met Phe Pro Ser Thr Trp Tyr Val
+
+
+#Symmetrical part of the WAG rate matrix and aa frequencies,
+#estimated from 3905 globular protein amino acid sequences forming 182
+#protein families.
+#The first part above indicates the symmetric 'exchangeability'
+#parameters, where s_ij = s_ji. The s_ij above are not scaled, but the
+#PAML package will perform this scaling.
+#The second part gives the amino acid frequencies (pi_i)
+#estimated from the 3905 sequences. The net replacement rate from i to
+#j is Q_ij = s_ij*pi_j.
+#Prepared by Simon Whelan and Nick Goldman, December 2000.
+#
+#Citation:
+#Whelan, S. and N. Goldman. 2001. A general empirical model of
+#protein evolution derived from multiple protein families using
+#a maximum likelihood approach. Molecular Biology and
+#Evolution 18:691-699.
diff --git a/man/Ancestors.Rd b/man/Ancestors.Rd
new file mode 100644
index 0000000..364c39a
--- /dev/null
+++ b/man/Ancestors.Rd
@@ -0,0 +1,49 @@
+\name{Ancestors}
+\alias{Ancestors}
+\alias{Children}
+\alias{Descendants}
+\alias{Siblings}
+\alias{mrca.phylo}
+\title{tree utility function}
+\description{
+Functions for describing relationships among phylogenetic nodes.
+}
+\usage{
+Ancestors(x, node, type=c("all","parent"))
+Children(x, node)
+Siblings(x, node, include.self=FALSE)
+Descendants(x, node, type=c("tips","children","all"))
+mrca.phylo(x, node)
+}
+\arguments{
+ \item{x}{a tree (a phylo object).}
+ \item{node}{an integer or a vector of integers corresponding to a node ID}
+ \item{type}{specify whether to return just direct
+ children / parents or all }
+ \item{include.self}{whether to include self in list of siblings}
+}
+\details{
+These functions are inspired by \code{treewalk} in phylobase package, but work on the
+S3 \code{phylo} objects.
+The nodes are the indices as given in edge matrix of an phylo object.
+From taxon labels these indices can be easily derived matching against the \code{tip.label}
+argument of an phylo object, see example below.
+All the functions allow \code{node} to be either a scalar or vector.
+}
+\value{
+ a vector or a list containing the indices of the nodes.
+}
+\seealso{\code{treewalk}, \code{phylo}}
+\examples{
+tree = rtree(10)
+plot(tree, show.tip.label = FALSE)
+nodelabels()
+tiplabels()
+Ancestors(tree, 1:3, "all")
+Children(tree, 11)
+Descendants(tree, 11, "tips")
+Siblings(tree, 3)
+mrca.phylo(tree, 1:3)
+mrca.phylo(tree, match(c("t1", "t2", "t3"), tree$tip))
+}
+\keyword{misc}
diff --git a/man/Laurasiatherian.Rd b/man/Laurasiatherian.Rd
new file mode 100644
index 0000000..abc2916
--- /dev/null
+++ b/man/Laurasiatherian.Rd
@@ -0,0 +1,18 @@
+\name{Laurasiatherian}
+\alias{Laurasiatherian}
+\docType{data}
+\title{ Laurasiatherian data (AWCMEE)}
+\description{
+ Laurasiatherian RNA sequence data
+}
+\usage{data(Laurasiatherian)}
+
+\source{
+Data have been taken from \url{http://www.allanwilsoncentre.ac.nz/}
+and were converted to R format by \email{klaus.schliep at gmail.com}.
+}
+\examples{
+data(Laurasiatherian)
+str(Laurasiatherian)
+}
+\keyword{datasets}
diff --git a/man/NJ.Rd b/man/NJ.Rd
new file mode 100644
index 0000000..55c33b6
--- /dev/null
+++ b/man/NJ.Rd
@@ -0,0 +1,42 @@
+\name{NJ}
+\alias{NJ}
+\alias{UNJ}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Neighbor-Joining}
+\description{
+This function performs the neighbor-joining tree estimation of Saitou
+and Nei (1987). UNJ is the unweighted version from Gascuel (1997).
+}
+\usage{
+NJ(x)
+UNJ(x)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x}{A distance matrix.}
+}
+
+\value{
+ an object of class \code{"phylo"}.
+}
+\references{Saitou, N. and Nei, M. (1987) The neighbor-joining method: a new
+method for reconstructing phylogenetic trees. \emph{Molecular Biology
+and Evolution}, \bold{4}, 406--425.
+
+Studier, J. A and Keppler, K. J. (1988) A Note on the Neighbor-Joining
+Algorithm of Saitou and Nei. \emph{Molecular Biology and Evolution},
+\bold{6}, 729--731.
+
+Gascuel, O. (1997) Concerning the NJ algorithm and its unweighted
+version, UNJ. in Birkin et. al. \emph{Mathematical Hierarchies and Biology},
+ 149--170.}
+\author{Klaus P. Schliep \email{klaus.schliep at gmail.com}}
+
+\seealso{ \code{\link[ape]{nj}}, \code{\link[ape]{dist.dna}}, \code{\link[phangorn]{dist.hamming}}, \code{\link[phangorn]{upgma}}, \code{\link[ape]{fastme}}}
+\examples{
+data(Laurasiatherian)
+dm <- dist.ml(Laurasiatherian)
+tree <- NJ(dm)
+plot(tree)
+}
+\keyword{ cluster }% at least one, from doc/KEYWORDS
diff --git a/man/SH.test.Rd b/man/SH.test.Rd
new file mode 100644
index 0000000..6568e0a
--- /dev/null
+++ b/man/SH.test.Rd
@@ -0,0 +1,48 @@
+\name{SH.test}
+\alias{SH.test}
+\title{Shimodaira-Hasegawa Test}
+\usage{
+SH.test(..., B = 10000, data=NULL)
+}
+\arguments{
+ \item{...}{either a series of objects of class \code{"pml"}
+ separated by commas, a list containing such objects
+ or an object of class \code{"pmlPart"}.}
+ \item{B}{the number of bootstrap replicates.}
+ \item{data}{an object of class \code{"phyDat"}.}
+}
+\description{
+ This function computes the Shimodaira--Hasegawa test for a set of
+ trees.
+}
+\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{Klaus Schliep \email{klaus.schliep at gmail.com}}
+\seealso{
+ \code{\link{pml}}, \code{\link{pmlPart}}, \code{\link{pmlCluster}}, \code{\link{SOWH.test}}
+}
+\examples{
+data(Laurasiatherian)
+dm <- dist.logDet(Laurasiatherian)
+tree1 <- NJ(dm)
+tree2 <- unroot(upgma(dm))
+fit1 <- pml(tree1, Laurasiatherian)
+fit2 <- pml(tree2, Laurasiatherian)
+fit1 <- optim.pml(fit1) # optimize edge weights
+fit2 <- optim.pml(fit2)
+SH.test(fit1, fit2, B=500)
+# in real analysis use larger B, e.g. 10000
+\dontrun{
+example(pmlPart)
+SH.test(sp, B=1000)
+}
+}
+\keyword{models}
diff --git a/man/SOWH.test.Rd b/man/SOWH.test.Rd
new file mode 100644
index 0000000..19076c2
--- /dev/null
+++ b/man/SOWH.test.Rd
@@ -0,0 +1,53 @@
+\name{SOWH.test}
+\alias{SOWH.test}
+\title{Swofford-Olsen-Waddell-Hillis Test}
+\usage{
+SOWH.test(x, n = 100, restricted = list(optNni=FALSE), optNni=TRUE, trace = 1, ...)
+}
+\arguments{
+ \item{x}{an object of class \code{"pml"}.}
+ \item{n}{the number of bootstrap replicates.}
+ \item{restricted}{list of restricted parameter settings.}
+ \item{optNni}{Logical value indicating whether topology gets optimized (NNI).}
+ \item{trace}{Show output during computations.}
+ \item{\dots}{Further arguments passed to \code{"optim.pml"}.}
+}
+\description{
+This function computes the Swofford--Olsen--Waddell--Hillis (SOWH) test, a parametric bootstrap test. The function is computational very demanding and likely to be very slow.
+}
+\details{
+\code{SOWH.test} performs a parametric bootstrap test to compare two trees.
+It makes extensive use \code{simSeq} and \code{optim.pml} and can take quite long.
+}
+\value{
+ an object of class SOWH. That is a list with three elements, one is a matrix
+ containing for each bootstrap replicate the (log-) likelihood of the restricted and unrestricted estimate and two pml objetcs of the restricted and unrestricted model.
+}
+\references{
+Goldman, N., Anderson, J. P., and Rodrigo, A. G. (2000) Likelihood
+-based tests of topologies in phylogenetics. \emph{Systematic Biology} \bold{49} 652-670.
+
+Swofford, D.L., Olsen, G.J., Waddell, P.J. and Hillis, D.M. (1996)
+Phylogenetic Inference in Hillis, D.M., Moritz, C. and Mable, B.K. (Eds.)
+\emph{Molecular Systematics} (2nd ed.) 407-514, Sunderland, MA: Sinauer
+}
+\author{Klaus Schliep \email{klaus.schliep at gmail.com}}
+\seealso{
+ \code{\link{pml}}, \code{\link{pmlPart}}, \code{\link{pmlCluster}}, \code{\link{simSeq}}, \code{\link{SH.test}}
+}
+\examples{
+# in real analysis use larger n, e.g. 500 preferably more
+\dontrun{
+data(Laurasiatherian)
+dm <- dist.logDet(Laurasiatherian)
+tree <- NJ(dm)
+fit <- pml(tree, Laurasiatherian)
+fit <- optim.pml(fit, TRUE)
+set.seed(6)
+tree <- rNNI(fit$tree, 1)
+fit <- update(fit, tree = tree)
+(res <- SOWH.test(fit, n=100))
+summary(res)
+}
+}
+\keyword{models}
diff --git a/man/allTrees.Rd b/man/allTrees.Rd
new file mode 100644
index 0000000..ea7d655
--- /dev/null
+++ b/man/allTrees.Rd
@@ -0,0 +1,30 @@
+\name{allTrees}
+\alias{allTrees}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Compute all trees topologies.}
+\description{
+\code{allTrees} computes all tree topologies for rooted or unrooted trees with up to 10 tips. \code{allTrees} returns bifurcating trees.
+}
+\usage{
+allTrees(n, rooted = FALSE, tip.label = NULL)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{n}{Number of tips (<=10).}
+ \item{rooted}{Rooted or unrooted trees (default: rooted). }
+ \item{tip.label}{Tip labels.}
+}
+\value{
+ an object of class multiPhylo.
+}
+\author{ Klaus Schliep \email{klaus.schliep at gmail.com} }
+
+% \seealso{}
+\examples{
+trees <- allTrees(5)
+par(mfrow = c(3,5))
+for(i in 1:15)plot(trees[[i]])
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ cluster }
diff --git a/man/ancestral.pml.Rd b/man/ancestral.pml.Rd
new file mode 100644
index 0000000..a2a840a
--- /dev/null
+++ b/man/ancestral.pml.Rd
@@ -0,0 +1,72 @@
+\name{ancestral.pml}
+\alias{ancestral.pml}
+\alias{ancestral.pars}
+\alias{pace}
+\alias{plotAnc}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{
+Ancestral character reconstruction.
+}
+\description{
+Marginal reconstruction of the ancestral character states.
+}
+\usage{
+ancestral.pml(object, type = c("ml", "bayes"))
+ancestral.pars(tree, data, type = c("MPR", "ACCTRAN"), cost = NULL)
+pace(tree, data, type = c("MPR", "ACCTRAN"), cost = NULL)
+plotAnc(tree, data, i, col=NULL, cex.pie=par("cex"), pos="bottomright", ...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{object}{an object of class pml}
+% \item{type}{either "ml" or "bayes"}
+ \item{tree}{a tree, i.e. an object of class pml}
+ \item{data}{an object of class phyDat}
+ \item{type}{method used to assign characters to internal nodes, see details.}
+ \item{i}{plots the i-th character of the \code{data}.}
+ \item{col}{a vector containing the colors for all possible states.}
+ \item{cex.pie}{a numeric defining the size of the pie graphs}
+ \item{pos}{a character string defining the positiond of the legend}
+ \item{cost}{A cost matrix for the transitions between two states.}
+ \item{\dots}{Further arguments passed to or from other methods.}
+}
+% \item{eps}{a small value to prevent rounding errors}
+\details{
+The argument "type" defines the criterion to assign the internal nodes. For \code{ancestral.pml} so far "ml" and
+(empirical) "bayes" and for \code{ancestral.pars} "MPR" and "ACCTRAN" are possible.
+
+With parsimony reconstruction one has to keep in mind that there will be often no unique solution.
+
+For further details see vignette("Ancestral").
+}
+\value{
+%A matrix containing the the estimates character states.
+An object of class "phyDat", containing the ancestral states of all nodes.
+}
+\references{
+Felsenstein, J. (2004). \emph{Inferring Phylogenies}. Sinauer Associates, Sunderland.
+
+Swofford, D.L., Maddison, W.P. (1987) Reconstructing ancestral character states under Wagner parsimony. \emph{Math. Biosci.} \bold{87}: 199--229
+
+Yang, Z. (2006). \emph{Computational Molecular evolution}. Oxford University Press, Oxford.
+}
+\author{Klaus Schliep \email{klaus.schliep at gmail.com}}
+\seealso{
+\code{pml}, \code{parsimony}, \code{ace}, \code{root}
+}
+\examples{
+example(NJ)
+fit = pml(tree, Laurasiatherian)
+anc.ml = ancestral.pml(fit, type = "ml")
+anc.p = ancestral.pars(tree, Laurasiatherian)
+\dontrun{
+require(seqLogo)
+seqLogo( t(subset(anc.ml, 48, 1:20)[[1]]), ic.scale=FALSE)
+seqLogo( t(subset(anc.p, 48, 1:20)[[1]]), ic.scale=FALSE)
+}
+plotAnc(tree, anc.ml, 1)
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ ~kwd1 }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
diff --git a/man/as.splits.Rd b/man/as.splits.Rd
new file mode 100644
index 0000000..7f7ee2e
--- /dev/null
+++ b/man/as.splits.Rd
@@ -0,0 +1,81 @@
+\name{as.splits}
+\alias{as.splits}
+\alias{as.prop.part.splits}
+\alias{as.splits.phylo}
+\alias{as.splits.multiPhylo}
+\alias{as.splits.networx}
+\alias{as.matrix.splits}
+\alias{as.Matrix}
+\alias{as.Matrix.splits}
+\alias{print.splits}
+\alias{write.splits}
+\alias{allSplits}
+\alias{compatible}
+\alias{write.nexus.splits}
+\alias{read.nexus.splits}
+\alias{as.phylo.splits}
+\alias{addConfidences}
+\alias{countCycles}
+\alias{presenceAbsence}
+\alias{addTrivialSplits}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{
+Splits representation of graphs and trees.
+}
+\description{
+\code{as.splits} produces a list of splits or bipartitions.
+}
+\usage{
+as.splits(x, ...)
+\method{as.splits}{phylo}(x, ...)
+\method{as.splits}{multiPhylo}(x, ...)
+\method{print}{splits}(x, maxp = getOption("max.print"), zero.print = ".",
+ one.print = "|", ...)
+\method{as.prop.part}{splits}(x, ...)
+compatible(obj)
+allSplits(k, labels = NULL)
+write.nexus.splits(obj, file="", weights=NULL)
+read.nexus.splits(file)
+addConfidences(obj, phy)
+presenceAbsence(x, y)
+addTrivialSplits(obj)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x}{An object of class phylo or multiPhylo.}
+ \item{y}{An object of class splits.}
+ \item{maxp}{integer, default from \code{options(max.print)}, influences how many entries of large matrices are printed at all.}
+ \item{zero.print}{character which should be printed for zeroes.}
+ \item{one.print}{character which should be printed for ones.}
+ \item{\dots}{Further arguments passed to or from other methods.}
+ \item{obj}{an object of class splits.}
+ \item{k}{number of taxa.}
+ \item{labels}{names of taxa.}
+ \item{file}{ a file name.}
+ \item{weights}{ Edge weights.}
+ \item{phy}{An object of class phylo or multiPhylo.}
+}
+\value{
+\code{as.splits} returns an object of class splits, which is mainly a list of splits and some attributes.
+\code{compatible} return a lower triangular matrix where an 1 indicates that two splits are incompatible.
+}
+\author{Klaus Schliep \email{klaus.schliep at gmail.com}}
+\note{
+The internal representation is likely to change.
+\code{read.nexus.splits} reads in the splits block of a nexus file. It assumes that different co-variables are tab delimited and the bipartition are separated with white-space. Comments in square brackets are ignored.
+}
+
+%% ~Make other sections like Warning with \section{Warning }{....} ~
+
+\seealso{
+\code{\link{prop.part}}, \code{\link{lento}}, \code{\link{distanceHadamard}}, \code{\link{as.networx}}
+}
+%% as.phylo.splits
+\examples{
+(sp <- as.splits(rtree(5)))
+write.nexus.splits(sp)
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ cluster }
+
diff --git a/man/bab.Rd b/man/bab.Rd
new file mode 100644
index 0000000..136ad84
--- /dev/null
+++ b/man/bab.Rd
@@ -0,0 +1,64 @@
+\name{bab}
+\alias{bab}
+\alias{BranchAndBound}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{
+Branch and bound for finding all most parsimonious trees
+}
+\description{
+\code{bab} finds all most parsimonious trees.
+}
+\usage{
+bab(data, tree = NULL, trace = 1, ...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{data}{
+an object of class phyDat.
+}
+ \item{tree}{
+a phylogenetic tree an object of class phylo, otherwise a pratchet search is performed.
+}
+ \item{trace}{
+defines how much information is printed during optimisation.
+}
+ \item{\dots}{
+Further arguments passed to or from other methods
+}
+}
+\details{
+This implementation is very slow and depending on the data may take very long time.
+In the worst case all (2n-5)!! possible trees have to be examined. For 10 species
+there are already 2027025 tip-labelled unrooted trees.
+It only uses some basic strategies to find a lower and upper bounds similar to penny from phylip.
+It uses a very basic heuristic approach of MinMax Squeeze (Holland et al. 2005) to improve the lower bound.
+On the positive side \code{bab} is not like many other implementations restricted to binary or nucleotide data.
+}
+\value{
+\code{bab} returns all most parsimonious trees in an object of class \code{multiPhylo}.
+}
+\references{
+Hendy, M.D. and Penny D. (1982) Branch and bound algorithms to determine minimal evolutionary trees.
+\emph{Math. Biosc.} \bold{59}, 277-290
+
+Holland, B.R., Huber, K.T. Penny, D. and Moulton, V. (2005) The MinMax Squeeze: Guaranteeing a Minimal Tree for Population Data, \emph{Molecular Biology and Evolution}, \bold{22}, 235--242
+
+White, W.T. and Holland, B.R. (2011) Faster exact maximum parsimony search with XMP. \emph{Bioinformatics}, \bold{27(10)},1359--1367
+}
+\author{
+Klaus Schliep \email{klaus.schliep at gmail.com} based on work on Liam Revell
+}
+\seealso{
+\code{\link{pratchet}}, \code{\link{dfactorial}}
+}
+\examples{
+data(yeast)
+dfactorial(11)
+# choose only the first two genes
+gene12 <- subset(yeast, , 1:3158, site.pattern=FALSE)
+trees <- bab(gene12)
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ cluster }
+\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
diff --git a/man/bootstrap.pml.Rd b/man/bootstrap.pml.Rd
new file mode 100644
index 0000000..123ab15
--- /dev/null
+++ b/man/bootstrap.pml.Rd
@@ -0,0 +1,104 @@
+\name{bootstrap.pml}
+%\Rdversion{1.1}
+\alias{bootstrap.pml}
+\alias{bootstrap.phyDat}
+\alias{plotBS}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{
+Bootstrap }
+\description{
+\code{bootstrap.pml} performs (non-parametric) bootstrap analysis and \code{bootstrap.phyDat} produces a list of bootstrapped data sets. \code{plotBS} plots a phylogenetic tree with the with the bootstrap values assigned to the (internal) edges.}
+\usage{
+bootstrap.pml(x, bs = 100, trees = TRUE, multicore=FALSE, ...)
+bootstrap.phyDat(x, FUN, bs = 100, mc.cores = 1L, ...)
+plotBS(tree, BStrees, type="unrooted", bs.col="black", bs.adj=NULL, ...)
+}
+\arguments{
+ \item{x}{
+an object of class \code{pml} or \code{phyDat}.
+}
+ \item{bs}{
+number of bootstrap samples.
+}
+ \item{trees}{
+return trees only (default) or whole \code{pml} objects.
+}
+ \item{multicore}{
+logical, if TRUE analysis is performed in parallel (see details).
+}
+ \item{mc.cores}{
+The number of cores to use during bootstrap. Only supported on UNIX-alike systems.
+}
+ \item{\dots}{
+further parameters used by \code{optim.pml} or \code{plot.phylo}.
+}
+ \item{FUN}{
+the function to estimate the trees.
+}
+ \item{tree}{
+The tree on which edges the bootstrap values are plotted.
+}
+ \item{BStrees}{
+a list of trees (object of class "multiPhylo").
+}
+ \item{type}{
+the type of tree to plot, so far "cladogram", "phylogram" and "unrooted" are supported.
+}
+ \item{bs.col}{
+color of bootstrap support labels.
+}
+ \item{bs.adj}{
+one or two numeric values specifying the horizontal and vertical justification of the bootstrap labels.
+}
+}
+\details{
+It is possible that the bootstrap is performed in parallel, with help of the multicore package.
+Unfortunately the multicore package does not work under windows or with GUI interfaces ("aqua" on a mac).
+However it will speed up nicely from the command line ("X11").
+}
+\value{
+\code{bootstrap.pml} returns an object of class \code{multi.phylo} or a list where each
+element is an object of class \code{pml}. \code{plotBS} returns silently a tree, i.e. an object of class \code{multi.phylo} with the bootstrap values as node labels.
+}
+\references{
+Felsenstein J. (1985) Confidence limits on phylogenies. An approach using the bootstrap. \emph{Evolution} \bold{39}, 783--791
+
+Penny D. and Hendy M.D. (1985) Testing methods evolutionary tree construction. \emph{Cladistics} \bold{1}, 266--278
+
+Penny D. and Hendy M.D. (1986) Estimating the reliability of evolutionary trees. \emph{Molecular Biology and Evolution} \bold{3}, 403--417
+}
+\author{
+Klaus Schliep \email{klaus.schliep at gmail.com}
+}
+\seealso{
+\code{\link{optim.pml}}, \code{\link{pml}}, \code{\link{plot.phylo}}, \code{\link{consensusNet}}
+}
+\examples{
+\dontrun{
+data(Laurasiatherian)
+dm <- dist.logDet(Laurasiatherian)
+tree <- NJ(dm)
+fit=pml(tree,Laurasiatherian)
+fit = optim.pml(fit,TRUE)
+
+set.seed(123)
+bs <- bootstrap.pml(fit, bs=100, optNni=TRUE)
+treeBS <- plotBS(fit$tree,bs)
+
+
+
+treeMP <- pratchet(Laurasiatherian)
+treeMP <- acctran(treeMP, Laurasiatherian)
+set.seed(123)
+BStrees <- bootstrap.phyDat(Laurasiatherian, pratchet, bs = 100)
+treeMP <- plotBS(treeMP, BStrees, "phylogram")
+add.scale.bar()
+
+# export tree with bootstrap values as node labels
+# write.tree(treeBS)
+}
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{cluster}
+
diff --git a/man/chloroplast.Rd b/man/chloroplast.Rd
new file mode 100644
index 0000000..a95638b
--- /dev/null
+++ b/man/chloroplast.Rd
@@ -0,0 +1,19 @@
+\name{chloroplast}
+\alias{chloroplast}
+\docType{data}
+\title{ Chloroplast alignment }
+\description{
+Amino acid alignment of 15 genes of 19 different chloroplast.}
+\usage{data(yeast)}
+
+%\references{
+%Nisbet R.E.R, Schliep K., Steel M.A., Knapp M. Howe C.J. and Lockhart P.J. (2009)
+%The slop of rocks and clocks
+%\emph{Potato growers weekly}, \bold{425}(6960): 798--804
+%}
+
+\examples{
+data(chloroplast)
+chloroplast
+}
+\keyword{datasets}
diff --git a/man/cladePar.Rd b/man/cladePar.Rd
new file mode 100644
index 0000000..c771e88
--- /dev/null
+++ b/man/cladePar.Rd
@@ -0,0 +1,63 @@
+\name{cladePar}
+\alias{cladePar}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{
+Utility function to plot.phylo
+}
+\description{
+cladePar can help you coloring (choosing edge width/type) of clades.
+}
+\usage{
+cladePar(tree, node, edge.color = "red", tip.color = edge.color, edge.width = 1,
+ edge.lty = 1, x = NULL, plot = FALSE, ...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{tree}{
+an object of class phylo.
+}
+ \item{node}{
+the node which is the common ancestor of the clade.
+}
+ \item{edge.color}{
+see plot.phylo.
+}
+ \item{tip.color}{
+see plot.phylo.
+}
+ \item{edge.width}{
+see plot.phylo.
+}
+ \item{edge.lty}{
+see plot.phylo.
+}
+ \item{x}{
+the result of a previous call to cladeInfo.
+}
+ \item{plot}{
+logical, if TRUE the tree is plotted.
+}
+ \item{\dots}{
+Further arguments passed to or from other methods.
+}
+}
+\value{
+A list containing the information about the edges and tips.
+}
+\author{
+Klaus Schliep \email{klaus.schliep at gmail.com}
+}
+\seealso{
+\code{\link{plot.phylo}}
+}
+\examples{
+tree = rtree(10)
+plot(tree)
+nodelabels()
+x = cladePar(tree, 12)
+cladePar(tree, 18, "blue", "blue", x=x, plot=TRUE)
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{plot}
+
diff --git a/man/consensusNet.Rd b/man/consensusNet.Rd
new file mode 100644
index 0000000..345328b
--- /dev/null
+++ b/man/consensusNet.Rd
@@ -0,0 +1,56 @@
+\name{consensusNet}
+\alias{consensusNet}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{
+Computes a consensusNetwork from a list of trees
+Computes a \code{networx} object from a collection of splits.
+}
+\description{
+Computes a consensusNetwork, i.e. an object of class \code{networx} from a list of trees, i.e. an class of class \code{multiPhylo}.
+Computes a \code{networx} object from a collection of splits.
+}
+\usage{
+consensusNet(obj, prob=.3, ...)
+
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{obj}{An object of class multiPhylo.}
+ \item{prob}{the proportion a split has to be present in all trees to be represented in the network.}
+ \item{\dots}{Further arguments passed to or from other methods.}
+}
+\value{
+\code{consensusNet} returns an object of class networx.
+This is just an intermediate to plot phylogenetic networks with igraph.
+}
+\author{Klaus Schliep \email{klaus.schliep at gmail.com}}
+
+
+
+%% ~Make other sections like Warning with \section{Warning }{....} ~
+
+\references{
+Holland B.R., Huber K.T., Moulton V., Lockhart P.J. (2004) Using consensus networks to visualize contradictory evidence for species phylogeny. \emph{Molecular Biology and Evolution}, \bold{21}, 1459--61
+}
+\seealso{
+\code{\link{splitsNetwork}}, \code{\link{neighborNet}}, \code{\link{lento}}, \code{\link{distanceHadamard}}, \code{\link{plot.networx}}
+}
+\examples{
+data(Laurasiatherian)
+set.seed(1)
+bs <- bootstrap.phyDat(Laurasiatherian, FUN = function(x)nj(dist.hamming(x)),
+ bs=50)
+class(bs) <- 'multiPhylo'
+cnet = consensusNet(bs, .3)
+plot(cnet, "2D")
+\dontrun{
+library(rgl)
+open3d()
+plot(cnet, show.tip.label=FALSE, show.nodes=TRUE)
+plot(cnet, type = "2D", show.edge.label=TRUE)
+}
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ hplot }
+
diff --git a/man/densiTree.Rd b/man/densiTree.Rd
new file mode 100644
index 0000000..ac4faa9
--- /dev/null
+++ b/man/densiTree.Rd
@@ -0,0 +1,83 @@
+\name{densiTree}
+\alias{densiTree}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{
+Plots a densiTree.
+}
+\description{
+An R function to plot trees similar to those produced by DensiTree.
+}
+\usage{
+densiTree(x, type = "cladogram", alpha = 1/length(x), consensus = NULL, optim = FALSE,
+ scaleX = FALSE, col = 1, width = 1, cex = 0.8, ...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+\item{x}{
+an object of class \code{multiPhylo}.
+}
+\item{type}{
+a character string specifying the type of phylogeny, so far "cladogram" (default) or "phylogram" (the default) are supported.
+}
+\item{alpha}{
+parameter for semi-transparent colors.
+}
+\item{consensus}{
+A tree which is used to define the order of the tip labels.
+}
+\item{optim}{
+not yet used.
+}
+\item{scaleX}{
+scale trees to have identical heights.
+}
+\item{col}{
+edge color.
+}
+\item{width}{
+edge width.
+}
+\item{cex}{
+a numeric value giving the factor scaling of the tip labels.
+}
+\item{\dots}{
+further arguments to be passed to plot.
+}
+}
+\details{
+If no consensus tree is provided \code{densiTree} computes a rooted mrp.supertree as a backbone. This should avoid too many unnecessary crossings of edges.
+Trees should be rooted, other wise the output may not make sense.
+}
+\references{
+densiTree is inspired from the great \href{www.cs.auckland.ac.nz/~remco/DensiTree}{DensiTree} program of Remco Bouckaert.
+}
+\author{
+Klaus Schliep \email{klaus.schliep at gmail.com}
+}
+
+%% ~Make other sections like Warning with \section{Warning }{....} ~
+
+\seealso{
+\code{\link{plot.phylo}}, \code{\link{plot.networx}}
+}
+\examples{
+data(Laurasiatherian)
+set.seed(1)
+bs <- bootstrap.phyDat(Laurasiatherian, FUN =
+ function(x)upgma(dist.hamming(x)), bs=25)
+# cladogram nice to show topological differences
+densiTree(bs, optim=TRUE, type="cladogram", col="blue")
+densiTree(bs, optim=TRUE, type="phylogram", col="green")
+\dontrun{
+# phylogram are nice to show different age estimates
+require(PhyloOrchard)
+data(BinindaEmondsEtAl2007)
+BinindaEmondsEtAl2007 <- .compressTipLabel(BinindaEmondsEtAl2007)
+densiTree(BinindaEmondsEtAl2007, type="phylogram", col="red")
+}
+
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{plot}
+
diff --git a/man/designTree.Rd b/man/designTree.Rd
new file mode 100644
index 0000000..573ad18
--- /dev/null
+++ b/man/designTree.Rd
@@ -0,0 +1,55 @@
+\name{designTree}
+\alias{designTree}
+\alias{designSplits}
+\alias{nnls.tree}
+\alias{nnls.phylo}
+\alias{nnls.splits}
+\alias{nnls.networx}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Compute a design matrix or non-negative LS }
+\description{
+\code{nnls.tree} estimates the branch length using non-negative least squares given a tree and a distance matrix.
+\code{designTree} and \code{designSplits} compute design matrices for the
+estimation of edge length of (phylogenetic) trees using linear models.
+For larger trees a sparse design matrix can save a lot of memory.
+%\code{designTree} also computes a contrast matrix if the method is "rooted".
+}
+\usage{
+designTree(tree, method = "unrooted", sparse=FALSE, ...)
+designSplits(x, splits = "all", ...)
+nnls.tree(dm, tree, rooted=FALSE, trace=1)
+nnls.phylo(x, dm, rooted=FALSE, trace=0)
+nnls.splits(x, dm, trace = 0)
+nnls.networx(x, dm)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{tree}{an object of class \code{phylo} }
+ \item{method}{design matrix for an "unrooted" or "rooted" ultrametric tree.}
+ \item{sparse}{return a sparse design matrix.}
+ \item{x}{number of taxa. }
+ \item{splits}{one of "all", "star".}
+ \item{dm}{a distance matrix.}
+ \item{rooted}{compute a "rooted" or "unrooted" tree.}
+ \item{trace}{defines how much information is printed during optimisation.}
+ \item{\dots}{further arguments, passed to other methods.}
+}
+\value{
+\code{nnls.tree} return a tree, i.e. an object of class \code{phylo}.
+\code{designTree} and \code{designSplits} a matrix, possibly sparse.
+}
+\author{ Klaus Schliep \email{klaus.schliep at gmail.com} }
+
+\seealso{ \code{\link[ape]{fastme}}, \code{\link[phangorn]{distanceHadamard}}, \code{\link[phangorn]{splitsNetwork}}, \code{\link[phangorn]{upgma}} }
+\examples{
+example(NJ)
+dm <- as.matrix(dm)
+y <- dm[lower.tri(dm)]
+X <- designTree(tree)
+lm(y~X-1)
+# avoids negative edge weights
+tree2 = nnls.tree(dm, tree)
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ cluster }
diff --git a/man/dfactorial.Rd b/man/dfactorial.Rd
new file mode 100644
index 0000000..73a7bc1
--- /dev/null
+++ b/man/dfactorial.Rd
@@ -0,0 +1,28 @@
+\name{dfactorial}
+\alias{dfactorial}
+\alias{ldfactorial}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Arithmetic Operators }
+\description{
+ double factorial function
+}
+\usage{
+dfactorial(x)
+ldfactorial(x)
+}
+\arguments{
+ \item{x}{ a numeric scalar or vector }
+}
+
+\value{
+\code{dfactorial(x)} returns the double factorial, that is \eqn{x\!\! = 1 * 3 * 5 * \ldots * x }
+and \code{ldfactorial(x)} is the natural logarithm of it.
+}
+
+\author{ Klaus Schliep \email{klaus.schliep at gmail.com} }
+
+\seealso{ \code{\link[base:Special]{factorial}} }
+\examples{
+dfactorial(1:10)
+}
+\keyword{ classif }% at least one, from doc/KEYWORDS
diff --git a/man/dist.hamming.Rd b/man/dist.hamming.Rd
new file mode 100644
index 0000000..c275e48
--- /dev/null
+++ b/man/dist.hamming.Rd
@@ -0,0 +1,49 @@
+\name{dist.hamming}
+\alias{dist.hamming}
+\alias{dist.logDet}
+\alias{dist.ml}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Pairwise Distances from Sequences}
+\description{
+\code{dist.hamming} and \code{dist.logDet} compute pairwise distances
+for an object of class \code{phyDat}. \code{dist.ml} fits distances
+for nucleotide and amino acid models.
+}
+\usage{
+dist.hamming(x, ratio = TRUE, exclude="none")
+dist.logDet(x)
+dist.ml(x, model="JC69", exclude="none", bf=NULL, Q=NULL, ...)
+}
+\arguments{
+ \item{x}{An object of class \code{phyDat}}
+ \item{ratio}{Compute uncorrected ('p') distance or character difference.}
+ \item{model}{One of "JC69" or one of 17 amino acid models see details.}
+ \item{exclude}{One of "none", "all", "pairwise" indicating whether to delete the sites with missing data (or ambigious states). The default is handle missing data as in pml.}
+ \item{bf}{A vector of base frequencies.}
+ \item{Q}{A vector containing the lower triangular part of the rate matrix.}
+ \item{\dots}{Further arguments passed to or from other methods.}
+}
+\value{
+ an object of class \code{dist}
+}
+\details{
+So far 17 amino acid models are supported ("WAG", "JTT", "LG", "Dayhoff", "cpREV", "mtmam", "mtArt", "MtZoa", "mtREV24", "VT","RtREV", "HIVw", "HIVb", "FLU", "Blossum62", "Dayhoff_DCMut" and "JTT_DCMut") and additional rate matrices and frequences can be supplied.
+}
+\references{
+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.
+}
+\author{Klaus Schliep \email{klaus.schliep at gmail.com}}
+
+\seealso{For more distance methods for nucleotide data see \code{\link[ape]{dist.dna}}}
+\examples{
+data(Laurasiatherian)
+dm1 <- dist.hamming(Laurasiatherian)
+tree1 <- NJ(dm1)
+dm2 <- dist.logDet(Laurasiatherian)
+tree2 <- NJ(dm2)
+treedist(tree1,tree2)
+}
+
+\keyword{ cluster }
diff --git a/man/dist.p.Rd b/man/dist.p.Rd
new file mode 100644
index 0000000..e8247c3
--- /dev/null
+++ b/man/dist.p.Rd
@@ -0,0 +1,71 @@
+\name{dist.p}
+\alias{dist.p}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Pairwise Polymorphism P-Distances from DNA Sequences}
+\description{
+This function computes a matrix of pairwise uncorrected polymorphism
+p-distances. Polymorphism p-distances include intra-individual site
+polymorphisms (2ISPs; e.g. "R") when calculating genetic distances.
+}
+\usage{
+dist.p(x, cost="polymorphism", ignore.indels=TRUE)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x}{a matrix cotaining DNA sequences; this must be of class
+ "phyDat" (use as.phyDat to convert from DNAbin objects).}
+ \item{cost}{A cost matrix or "polymorphism" for a pre defined one.}
+ \item{ignore.indels}{a logical indicating whether gaps are treated
+as fifth state or not. Warning, each gap site is treated as a
+characters, so an an indel that spans a number of base positions
+would be treated as multiple character states.}
+}
+\details{
+The polymorphism p-distances (Potts et al. in press) have been
+developed to analyse intra-individual variant polymorphism. For
+example, the widely used ribosomal internal transcribed spacer (ITS)
+region (e.g. Alvarez and Wendel, 2003) consists of 100's to 1000's
+of units within array across potentially multiple nucleolus organising
+regions (Bailey et al., 2003; Goeker and Grimm, 2008). This can give
+rise to intra-individual site polymorphisms (2ISPs) that can be
+detected from direct-PCR sequencing or cloning . Clone consensus
+sequences (see Goeker and Grimm, 2008) can be analysed with this
+function.
+}
+\value{
+ an object of class \code{dist}.
+}
+
+\references{Alvarez, I., and J. F. Wendel. (2003) Ribosomal ITS sequences and plant phylogenetic inference. \emph{ Molecular Phylogenetics and Evolution}, \bold{29}, 417--434.
+
+Bailey, C. D., T. G. Carr, S. A. Harris, and C. E. Hughes. (2003) Characterization of angiosperm nrDNA polymorphism, paralogy, and pseudogenes. \emph{Molecular Phylogenetics and Evolution} \bold{29}, 435--455.
+
+Goeker, M., and G. Grimm. (2008) General functions to transform associate data to host data, and their use in phylogenetic inference from sequences with intra-individual variability. \emph{BMC Evolutionary Biology}, \bold{8}:86.
+
+Potts, A.J., T.A. Hedderson, and G.W. Grimm. (2013) Constructing phylogenies in the presence of intra-individual site polymorphisms (2ISPs) with a focus on the nuclear ribosomal cistron. \emph{Systematic Biology}, \bold{doi 10.1093/sysbio/syt052}.
+}
+\author{Klaus Schliep and Alastair Potts}
+
+\seealso{ \code{\link[ape]{dist.dna}}, \code{\link[phangorn]{dist.hamming}}}
+\examples{
+data(Laurasiatherian)
+laura = as.DNAbin(Laurasiatherian)
+
+dm <- dist.p(Laurasiatherian, "polymorphism")
+
+########################################################
+# Dealing with indel 2ISPs
+# These can be coded using an "x" in the alignment. Note
+# that as.character usage in the read.dna() function.
+#########################################################
+cat("3 5",
+ "No305 ATRA-",
+ "No304 ATAYX",
+ "No306 ATAGA",
+ file = "exdna.txt", sep = "\n")
+(ex.dna <- read.dna("exdna.txt", format = "sequential", as.character=TRUE))
+dat= phyDat(ex.dna, "USER", levels=unique(as.vector(ex.dna)))
+dist.p(dat)
+
+}
+\keyword{ cluster }% at least one, from doc/KEYWORDS
diff --git a/man/distanceHadamard.Rd b/man/distanceHadamard.Rd
new file mode 100644
index 0000000..e8d72bb
--- /dev/null
+++ b/man/distanceHadamard.Rd
@@ -0,0 +1,37 @@
+\name{distanceHadamard}
+
+\alias{distanceHadamard}
+\title{Distance Hadamard}
+\description{
+Distance Hadamard produces spectra of splits from a distance matrix.
+}
+\usage{
+distanceHadamard(dm, eps=0.001)
+}
+\arguments{
+ \item{dm}{A distance matrix.}
+ \item{eps}{Threshold value for splits.}
+}
+
+\value{
+\code{distanceHadamard} returns a matrix. The first column
+contains the distance spectra, the second one the edge-spectra.
+If eps is positive an object of with all splits greater eps is returned.
+}
+\references{Hendy, M. D. and Penny, D. (1993). Spectral Analysis of Phylogenetic
+Data. \emph{Journal of Classification}, \bold{10}, 5-24.
+}
+\author{Klaus Schliep \email{klaus.schliep at gmail.com}, Tim White}
+\seealso{\code{\link{hadamard}}, \code{\link{lento}}, \code{\link{plot.networx}}}
+
+\examples{
+data(yeast)
+dm = dist.hamming(yeast)
+dm = as.matrix(dm)
+fit = distanceHadamard(dm)
+lento(fit)
+plot(as.networx(fit), "2D")
+}
+\keyword{ cluster }% at least one, from doc/KEYWORDS
+
+
diff --git a/man/getClans.Rd b/man/getClans.Rd
new file mode 100644
index 0000000..09cc3c1
--- /dev/null
+++ b/man/getClans.Rd
@@ -0,0 +1,122 @@
+\name{getClans}
+\alias{getClans}
+\alias{getClips}
+\alias{getSlices}
+\alias{getDiversity}
+\alias{diversity}
+\title{
+Clans, slices and clips
+}
+\description{
+Functions for clanistics to compute clans, slices, clips for unrooted trees and functions to quantify the fragmentation of trees.
+}
+\usage{
+getClans(tree)
+getClips(tree, all=TRUE)
+getSlices(tree)
+getDiversity(tree, x, norm=TRUE, var.names = NULL, labels="new")
+diversity(tree, X)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+\item{tree}{An object of class phylo or multiPhylo (getDiversity).}
+\item{all}{A logical, return all or just the largest clip. }
+\item{x}{An object of class phyDat. }
+\item{norm}{A logical, return Equitability Index (default) or Shannon Diversity. }
+\item{var.names}{A vector of variable names. }
+\item{labels}{see details. }
+\item{X}{a data.frame}
+}
+\details{
+Every split in an unrooted tree defines two complementary clans. Thus
+for an unrooted binary tree with \eqn{n} leaves there are \eqn{2n - 3} edges,
+and therefore \eqn{4n - 6} clans (including \eqn{n} trivial clans containing only
+one leave).
+
+Slices are defined by a pair of splits or tripartitions, which are not
+clans. The number of distinguishable slices for a binary tree with
+\eqn{n} tips is \eqn{2n^2 - 10n + 12}.
+
+%A clip is a different type of partition as it is defined by evolutionary or cophenetic distance and not by the topology. Namely clips are groups of leaves for which the maximum pairwise distance is smaller than threshold.
+%For a better separation we additionally demand that the maximum pairwise distance within a clip is lower than the distance between any member of the clip and any other tip.
+
+A clip is a different type of partition, defining groups of leaves that are related in terms of evolutionary distances and not only topology.
+Namely, clips are groups of leaves for which all pairwise path-length distances are smaller than a given threshold value (Lapointe et al. 2010).
+There exists different numbers of clips for different thresholds, the largest (and trivial) one being the whole tree.
+There is always a clip containing only the two leaves with the smallest pairwise distance.
+
+Clans, slices and clips can be used to characterize how well a vector of
+categorial characters (natives/intruders) fit on a tree. We will follow the definitions of Lapointe et al.(2010).
+A complete clan is a clan that contains all leaves of a given state/color, but can
+also contain leaves of another state/color. A clan is homogeneous if it
+only contains leaves of one state/color.
+
+\code{getDiversity} computes either the \cr
+Shannon Diversity: \eqn{H = -\sum_{i=1}^{k}(N_i/N) log(N_i/N), N=\sum_{i=1}^{k} N_i}{H = -sum(N_i/N) * log(N_i/N), N=sum(N_i)} \cr
+or the \cr
+Equitability Index: \eqn{E = H / log(N)} \cr
+where \eqn{N_i} are the sizes of the \eqn{k} largest homogeneous clans of intruders.
+If the categories of the data can be separated by an edge of the tree then the E-value will be zero,
+and maximum equitability (E=1) is reached if all intruders are in separate clans.
+getDiversity computes these Intruder indices for the whole tree, complete clans and complete slices.
+Additionally the parsimony scores (p-scores) are reported. The p-score indicates if the leaves contain only one color (p-score=0), if
+the the leaves can be separated by a single split (perfect clan, p-score=1) or by a pair of splits (perfect slice, p-score=2).
+
+So far only 2 states are supported (native, intruder), however it is also possible to recode several states
+into the native or intruder state using contrasts, for details see section 2 in vignette("phangorn-specials").
+Furthermore unknown character states are coded as ambiguous character, which can act either as native or intruder
+minimizing the number of clans or changes (in parsimony analysis) needed to describe a tree for given data.
+
+Set attribute labels to "old" for analysis as in Schliep et al. (2010) or to "new" for names which are more intuitive.
+
+\code{diversity} returns a data.frame with the parsimony score for each tree and each levels of the variables in \code{X}. \code{X} has to be a \code{data.frame} where each column is a factor and the rownames of \code{X} correspond to the tips of the trees.
+
+
+%TODO See also vignette("Clanistic").
+}
+\value{
+getClans, getSlices and getClips return a matrix of partitions, a matrix of ones and zeros where rows correspond to
+a clan, slice or clip and columns to tips. A one indicates that a tip belongs to a certain partition. \cr
+getDiversity returns a list with tree object, the first is a data.frame of the equitability index or Shannon divergence and parsimony scores (p-score)
+for all trees and variables. The data.frame has two attributes, the first is a splits object to identify the taxa of each tree and the second
+is a splits object containing all partitions that perfectly fit.
+}
+
+\references{
+Lapointe, F.-J., Lopez, P., Boucher, Y., Koenig, J., Bapteste, E. (2010) Clanistics: a multi-level perspective for harvesting unrooted gene trees. \emph{Trends in Microbiology} 18: 341-347
+
+Wilkinson, M., McInerney, J.O., Hirt, R.P., Foster, P.G., Embley, T.M. (2007) Of clades and clans: terms for phylogenetic relationships in unrooted trees. \emph{Trends in Ecology and Evolution} 22: 114-115
+
+Schliep, K., Lopez, P., Lapointe F.-J., Bapteste E. (2011) Harvesting Evolutionary Signals in a Forest of Prokaryotic Gene Trees, \emph{Molecular Biology and Evolution} 28(4): 1393-1405
+
+}
+\author{
+Klaus Schliep \email{klaus.schliep at snv.jussieu.fr}
+
+Francois-Joseph Lapointe \email{francois-joseph.lapointe at umontreal.ca}
+}
+
+\seealso{
+\code{\link{parsimony}}, Consistency index \code{\link{CI}}, Retention index \code{\link{RI}}, \code{\link{phyDat}}
+}
+
+
+\examples{
+set.seed(111)
+tree = rtree(10)
+getClans(tree)
+getClips(tree, all=TRUE)
+getSlices(tree)
+
+set.seed(123)
+trees = rmtree(10, 20)
+X = matrix(sample(c("red", "blue", "violet"), 100, TRUE, c(.5,.4, .1)), ncol=5,
+ dimnames=list(paste('t',1:20, sep=""), paste('Var',1:5, sep="_")))
+x = phyDat(X, type = "USER", levels = c("red", "blue"), ambiguity="violet")
+plot(trees[[1]], "u", tip.color = X[trees[[1]]$tip,1]) # intruders are blue
+
+(divTab <- getDiversity(trees, x, var.names=colnames(X)))
+summary(divTab)
+}
+\keyword{ cluster }
+
diff --git a/man/hadamard.Rd b/man/hadamard.Rd
new file mode 100644
index 0000000..298a861
--- /dev/null
+++ b/man/hadamard.Rd
@@ -0,0 +1,81 @@
+\name{hadamard}
+\alias{hadamard}
+\alias{fhm}
+\alias{h4st}
+\alias{h2st}
+\title{Hadamard Matrices and Fast Hadamard Multiplication}
+\description{
+A collection of functions to perform Hadamard conjugation.
+%Hv of a Hadamard matrix H with a vector v using fast Hadamard multiplication.
+}
+\usage{
+hadamard(x)
+fhm(v)
+h2st(obj, eps=0.001)
+h4st(obj, levels = c("a","c","g","t"))
+}
+\arguments{
+ \item{x}{ a vector of length \eqn{2^n}, where n is an integer. }
+ \item{v}{ a vector of length \eqn{2^n}, where n is an integer. }
+ \item{obj}{ a data.frame or character matrix, typical a sequence alignment.}
+ \item{eps}{Threshold value for splits.}
+ \item{levels}{ levels of the sequences.}
+}
+
+\details{
+\code{h2st} and \code{h4st} perform Hadamard conjugation
+for 2-state (binary, RY-coded) or 4-state (DNA/RNA) data.
+\code{write.nexus.splits} writes splits returned from \code{h2st} or
+\code{\link[phangorn]{distanceHadamard}} to a nexus file, which can be processed by
+Spectronet or Splitstree.
+}
+
+\value{
+\code{hadamard} returns a Hadamard matrix. \code{fhm} returns the
+fast Hadamard multiplication.
+}
+\references{Hendy, M.D. (1989). The relationship between simple evolutionary tree
+models and observable sequence data. \emph{Systematic Zoology}, \bold{38} 310--321.
+
+Hendy, M. D. and Penny, D. (1993). Spectral Analysis of Phylogenetic
+Data. \emph{Journal of Classification}, \bold{10}, 5--24.
+
+Hendy, M. D. (2005). Hadamard conjugation: an analytical tool for phylogenetics.
+In O. Gascuel, editor, \emph{Mathematics of evolution and phylogeny}, Oxford University Press, Oxford
+
+Waddell P. J. (1995). Statistical methods of phylogenetic analysis: Including hadamard conjugation,
+LogDet transforms, and maximum likelihood. \emph{PhD thesis}.
+}
+\author{Klaus Schliep \email{klaus.schliep at gmail.com}}
+\seealso{\code{\link{distanceHadamard}}, \code{\link{lento}}, \code{\link{plot.networx}}}
+
+\examples{
+H = hadamard(3)
+v = 1:8
+H%*%v
+fhm(v)
+
+data(yeast)
+dat = as.character(yeast)
+# RY-coding
+dat2 = dat
+dat2[dat=="a" | dat=="g"] = "r"
+dat2[dat=="c" | dat=="t"] = "y"
+dat2 = phyDat(dat2, type="USER", levels=c("r","y"), ambiguity=NULL)
+fit2 = h2st(dat2)
+lento(fit2)
+
+# write.nexus.splits(fit2, file = "test.nxs")
+# read this file into Spectronet or Splitstree to show the network
+\dontrun{
+dat4 = phyDat(dat, type="USER", levels=c("a","c", "g", "t"), ambiguity=NULL)
+fit4 = h4st(dat4)
+
+par(mfrow=c(3,1))
+lento(fit4[[1]], main="Transversion")
+lento(fit4[[2]], main="Transition 1")
+lento(fit4[[3]], main="Transition 2")
+}
+}
+\keyword{ cluster }% at least one, from doc/KEYWORDS
+
diff --git a/man/lento.Rd b/man/lento.Rd
new file mode 100644
index 0000000..ac2ff2e
--- /dev/null
+++ b/man/lento.Rd
@@ -0,0 +1,47 @@
+\name{lento}
+\alias{lento}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{
+Lento plot
+}
+\description{
+The lento plot represents support and conflict of splits/bipartitions.
+}
+\usage{
+lento(obj, xlim = NULL, ylim = NULL, main = "Lento plot", sub = NULL, xlab = NULL,
+ ylab = NULL, bipart=TRUE, trivial=FALSE,...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{obj}{an object of class phylo, multiPhylo or splits}
+ \item{xlim}{graphical parameter}
+ \item{ylim}{graphical parameter}
+ \item{main}{graphical parameter}
+ \item{sub}{graphical parameter}
+ \item{xlab}{graphical parameter}
+ \item{ylab}{graphical parameter}
+ \item{bipart}{plot bipartition information.}
+ \item{trivial}{logical, whether to present trivial splits (default is FALSE).}
+ \item{\dots}{Further arguments passed to or from other methods.}
+}
+\value{
+lento returns a plot.
+}
+\references{
+Lento, G.M., Hickson, R.E., Chambers G.K., and Penny, D. (1995) Use of spectral analysis to test hypotheses on the origin of pinninpeds. \emph{Molecular Biology and Evolution}, \bold{12}, 28-52.
+}
+\author{Klaus Schliep \email{klaus.schliep at gmail.com}}
+
+\seealso{
+\code{\link{as.splits}, \link{hadamard}}
+}
+\examples{
+data(yeast)
+yeast.ry = acgt2ry(yeast)
+splits.h = h2st(yeast.ry)
+lento(splits.h, trivial=TRUE)
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ cluster }
+\keyword{ plot }% __ONLY ONE__ keyword per line
diff --git a/man/midpoint.Rd b/man/midpoint.Rd
new file mode 100644
index 0000000..2c35bca
--- /dev/null
+++ b/man/midpoint.Rd
@@ -0,0 +1,50 @@
+\name{midpoint}
+\alias{midpoint}
+\alias{pruneTree}
+\alias{getRoot}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{Tree manipulation}
+\description{
+\code{midpoint} performs midpoint rooting of a tree.
+\code{pruneTree} produces a consensus tree.
+}
+\usage{
+midpoint(tree)
+pruneTree(tree, ..., FUN = ">=")
+getRoot(tree)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{tree}{an object of class \code{phylo} }
+ \item{FUN}{a function evaluated on the nodelabels, result must be logical.}
+ \item{\dots}{further arguments, passed to other methods. }
+}
+\details{
+\code{pruneTree} prunes back a tree and produces a consensus tree, for trees already containing nodelabels.
+It assumes that nodelabels are numerical or character genereated from numericals, it uses as.numeric(as.character(tree$node.labels))
+to convert them.
+\code{midpoint} so far does not transform node.labels properly.
+}
+\value{
+\code{pruneTree} and \code{midpoint} a tree. \code{getRoot} returns the root node.
+}
+\author{ Klaus Schliep \email{klaus.schliep at gmail.com} }
+
+\seealso{ \code{\link[ape]{consensus}}, \code{\link[ape]{root}}, \code{\link[ape]{di2multi}} }
+\examples{
+tree = unroot(rtree(10))
+tree$node.label = c("", round(runif(tree$Nnode-1), 3))
+
+tree2 = midpoint(tree)
+tree3 = pruneTree(tree, .5)
+
+par(mfrow = c(3,1))
+plot(tree, show.node.label=TRUE)
+plot(tree2, show.node.label=TRUE)
+plot(tree3, show.node.label=TRUE)
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ cluster }
+
+
diff --git a/man/modelTest.Rd b/man/modelTest.Rd
new file mode 100644
index 0000000..ac9a8c0
--- /dev/null
+++ b/man/modelTest.Rd
@@ -0,0 +1,67 @@
+\name{modelTest}
+\alias{modelTest}
+\title{
+ModelTest
+}
+\description{
+Comparison of different substition models
+}
+\usage{
+modelTest(object, tree=NULL, model = c("JC", "F81", "K80", "HKY", "SYM", "GTR"),
+ G = TRUE, I = TRUE, k = 4, control = pml.control(epsilon = 1e-08, maxit = 3,
+ trace = 1), multicore = FALSE)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{object}{an object of class phyDat or pml}
+ \item{tree}{a phylogenetic tree.}
+ \item{model}{a vector containing the substitution models to compare with each other}
+ \item{G}{logical, TRUE (default) if (discrete) Gamma modelshould be tested}
+ \item{I}{logical, TRUE (default) if invariant sites should be tested}
+ \item{k}{number of rate classes}
+ \item{control}{A list of parameters for controlling the fitting process.}
+ \item{multicore}{logical, whether models should estimated in parallel.}
+}
+\details{
+\code{modelTest} estimates all the specified models for a given tree and data.
+When the multicore package is available, the computations are done in parallel.
+This is only possible without GUI interface and under linux.
+Only nucleotide models are tested so far.
+}
+\value{
+A data.frame containing the log-likelihood, AIC and BIC all tested models.
+The data.frame has an attributes "env" which is an environment which contains all the trees, the data and the calls to allow get the estimated models, e.g. as a starting point for further analysis (see example).
+}
+\references{
+Posada, D. and Crandall, K.A. (1998) MODELTEST: testing the model of DNA substitution. \emph{Bioinformatics} \bold{14(9)}: 817-818
+
+Posada, D. (2008) jModelTest: Phylogenetic Model Averaging. \emph{Molecular Biology and Evolution} \bold{25}: 1253-1256
+
+Darriba D., Taboada G.L., Doallo R and Posada D. (2011) ProtTest 3: fast selection of best-fit models of protein evolution. . \emph{Bioinformatics} \bold{27}: 1164-1165
+}
+\author{Klaus Schliep \email{klaus.schliep at gmail.com}}
+
+%% ~Make other sections like Warning with \section{Warning }{....} ~
+
+\seealso{
+\code{\link{pml}}, \code{\link{anova}}
+}
+\examples{
+\dontrun{
+example(NJ)
+(mT <- modelTest(Laurasiatherian, tree))
+
+# some R magic
+env = attr(mT, "env")
+ls(env=env)
+(F81 <- get("F81+G", env)) # a call
+eval(F81, env=env)
+
+data(chloroplast)
+(mTAA <- modelTest(chloroplast, model=c("JTT", "WAG", "LG")))
+}
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{cluster}
+
diff --git a/man/neighborNet.Rd b/man/neighborNet.Rd
new file mode 100644
index 0000000..145b158
--- /dev/null
+++ b/man/neighborNet.Rd
@@ -0,0 +1,42 @@
+\name{neighborNet}
+\alias{neighborNet}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{
+Computes a neighborNet from a distance matrix
+}
+\description{
+Computes a neighborNet, i.e. an object of class \code{networx} from a distance matrix.
+}
+\usage{
+neighborNet(x, ord = NULL)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{x}{a distance matrix.}
+ \item{ord}{a circular ordering.}
+}
+\details{
+\code{neighborNet} is still experimental. The cyclic ordering sometimes differ from the SplitsTree implementation, the \emph{ord} argument can be used to enforce a certain circular ordering.
+}
+\value{
+\code{neighborNet} returns an object of class networx.
+}
+\author{Klaus Schliep \email{klaus.schliep at gmail.com}}
+%% ~Make other sections like Warning with \section{Warning }{....} ~
+
+\references{
+Bryant, D. & Moulton, V. (2004) Neighbor-Net: An Agglomerative Method for the Construction of Phylogenetic Networks. \emph{Molecular Biology and Evolution}, 2004, \bold{21}, 255-265
+}
+\seealso{
+\code{\link{splitsNetwork}}, \code{\link{consensusNet}}, \code{\link{plot.networx}}, \code{\link{lento}}
+}
+\examples{
+data(yeast)
+dm <- dist.ml(yeast)
+nnet <- neighborNet(dm)
+plot(nnet, "2D")
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ hplot }
+
diff --git a/man/nni.Rd b/man/nni.Rd
new file mode 100644
index 0000000..0197d36
--- /dev/null
+++ b/man/nni.Rd
@@ -0,0 +1,36 @@
+\name{nni}
+\alias{nni}
+\alias{rNNI}
+\alias{rSPR}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Tree rearrangements.}
+\description{
+\code{nni} returns a list of all trees which are one nearest neighbor interchange away. \code{rNNI} and \code{rSPR} are two methods which simulate random trees which are a specified number of rearrangement apart from the input tree. Both methods assume that the input tree is bifurcating. These methods may be useful in simulation studies.
+}
+\usage{
+nni(tree)
+rSPR(tree, moves=1, n=length(moves), k=NULL)
+rNNI(tree, moves=1, n=length(moves))
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{tree}{A phylogenetic \code{tree}, object of class \code{phylo}.}
+ \item{moves}{Number of tree rearrangements to be transformed on a tree.
+ Can be a vector}
+ \item{n}{Number of trees to be simulated.}
+ \item{k}{If defined just SPR of distance k are performed.}
+}
+\value{
+ an object of class multiPhylo.
+}
+\author{ Klaus Schliep \email{klaus.schliep at gmail.com} }
+
+% \seealso{ }
+\examples{
+tree = unroot(rtree(20))
+trees1 <- nni(tree)
+trees2 <- rSPR(tree, 2, 10)
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ cluster }
diff --git a/man/parsimony.Rd b/man/parsimony.Rd
new file mode 100644
index 0000000..de790ef
--- /dev/null
+++ b/man/parsimony.Rd
@@ -0,0 +1,81 @@
+\name{parsimony}
+\alias{parsimony}
+\alias{optim.parsimony}
+\alias{sankoff}
+\alias{fitch}
+\alias{PNJ}
+\title{Parsimony tree.}
+\alias{CI}
+\alias{RI}
+\alias{pratchet}
+\alias{random.addition}
+\alias{acctran}
+\description{
+
+\code{parsimony} returns the parsimony score of a tree using either the sankoff or the fitch algorithm.
+\code{optim.parsimony} tries to find the maximum parsimony tree using either Nearest Neighbor Interchange (NNI)
+rearrangements or sub tree pruning and regrafting (SPR). \code{pratchet} implements the parsimony ratchet (Nixon, 1999) and is the prefered way to search for the best tree.
+\code{random.addition} can be used to produce starting trees.
+\code{CI} and \code{RI} computes the consistency and retention index.
+}
+\usage{
+parsimony(tree, data, method="fitch", ...)
+optim.parsimony(tree, data, method="fitch", cost=NULL, trace=1, rearrangements="SPR", ...)
+pratchet(data, start=NULL, method="fitch", maxit=100, k=5, trace=1, all=FALSE,
+ rearrangements="SPR", ...)
+fitch(tree, data, site = "pscore")
+sankoff(tree, data, cost = NULL, site = "pscore")
+random.addition(data, method="fitch")
+CI(tree, data, cost = NULL)
+RI(tree, data, cost = NULL)
+acctran(tree, data)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{data}{A object of class phyDat containing sequences.}
+ \item{tree}{ tree to start the nni search from.}
+ \item{method}{one of 'fitch' or 'sankoff'.}
+ \item{cost}{A cost matrix for the transitions between two states.}
+ \item{site}{return either 'pscore' or 'site' wise parsimony scores.}
+ \item{trace}{defines how much information is printed during optimisation.}
+ \item{rearrangements}{SPR or NNI rearrangements.}
+ \item{start}{a starting tree can be supplied.}
+ \item{maxit}{maximum number of iterations in the ratchet.}
+ \item{k}{number of rounds ratchet is stopped, when there is no improvement.}
+ \item{all}{return all equally good trees or just one of them.}
+ \item{...}{Further arguments passed to or from other methods (e.g. model="sankoff" and cost matrix).}
+}
+\value{
+ \code{parsimony} returns the maximum parsimony score (pscore).
+ \code{optim.parsimony} returns a tree after NNI rearrangements.
+ \code{pratchet} returns a tree or list of trees containing the best tree(s) found during the search.
+ \code{acctran} returns a tree with edge length according to the ACCTRAN criterion.
+}
+\details{
+The "SPR" rearrangements are so far only available for the "fitch" method, "sankoff" only uses "NNI". The "fitch" algorithm only works correct for binary trees.
+}
+\references{
+Felsenstein, J. (2004). \emph{Inferring Phylogenies}. Sinauer Associates, Sunderland.
+
+Nixon, K. (1999) The Parsimony Ratchet, a New Method for Rapid Parsimony Analysis. \emph{Cladistics} \bold{15}, 407-414
+}
+\author{Klaus Schliep \email{klaus.schliep at gmail.com}}
+\seealso{\code{\link{bab}}, \code{\link{ancestral.pml}}, \code{\link{nni}}, \code{\link{NJ}}, \code{\link{pml}}, \code{\link{getClans}} ,\code{\link{ancestral.pars}}, \code{\link{bootstrap.pml}}}
+\examples{
+set.seed(3)
+data(Laurasiatherian)
+dm = dist.hamming(Laurasiatherian)
+tree = NJ(dm)
+parsimony(tree, Laurasiatherian)
+treeRA <- random.addition(Laurasiatherian)
+treeNNI <- optim.parsimony(tree, Laurasiatherian)
+treeRatchet <- pratchet(Laurasiatherian, start=tree)
+# assign edge length
+treeRatchet <- acctran(treeRatchet, Laurasiatherian)
+
+plot(midpoint(treeRatchet))
+add.scale.bar(0,0, length=100)
+
+parsimony(c(tree,treeNNI, treeRatchet), Laurasiatherian)
+}
+\keyword{cluster}
diff --git a/man/phangorn-package.Rd b/man/phangorn-package.Rd
new file mode 100644
index 0000000..5c3224c
--- /dev/null
+++ b/man/phangorn-package.Rd
@@ -0,0 +1,41 @@
+\name{phangorn-package}
+\alias{phangorn-package}
+\alias{phangorn}
+\docType{package}
+\title{
+Phylogenetic analysis in R
+}
+\description{
+Phylogenetic analysis in R (Estimation of phylogenetic
+trees and networks using Maximum Likelihood, Maximum Parsimony,
+Distance methods & Hadamard conjugation)
+
+The complete list of functions can be displayed with \code{library(help = phangorn)}.
+
+
+Further information is available in two vignettes.
+\tabular{ll}{
+\code{Trees} \tab Constructing phylogenetic trees (source, pdf) \cr
+\code{phangorn-specials} \tab Advanced features (source, pdf) \cr
+\code{Ancestral} \tab Ancestral sequence reconstruction (source, pdf) \cr
+}
+The first vignette (to display type \code{vignette('Trees')}) gives an introduction in phylogenetic analysis with phangorn, and
+the second vignette covers more advanced feature like defining special character spaces.
+}
+\author{
+Klaus Schliep
+
+Maintainer: Klaus Schliep <klaus.schliep at gmail.com>
+}
+\references{
+ Schliep K.P. (2011) phangorn: Phylogenetic analysis in R.
+ \emph{Bioinformatics}, 27(4) 592-593
+}
+\keyword{ package }
+%\seealso{
+%~~ Optional links to other man pages, e.g. ~~
+%~~ \code{\link[<pkg>:<pkg>-package]{<pkg>}} ~~
+%}
+%\examples{
+%~~ simple examples of the most important functions ~~
+%}
diff --git a/man/phyDat.Rd b/man/phyDat.Rd
new file mode 100644
index 0000000..ab2e200
--- /dev/null
+++ b/man/phyDat.Rd
@@ -0,0 +1,97 @@
+\name{phyDat}
+\alias{phyDat}
+\alias{as.phyDat.DNAbin}
+\alias{as.data.frame.phyDat}
+\alias{as.character.phyDat}
+\alias{as.DNAbin.phyDat}
+\alias{read.phyDat}
+\alias{write.phyDat}
+\alias{allSitePattern}
+\alias{as.phyDat}
+\alias{subset.phyDat}
+\alias{acgt2ry}
+\alias{baseFreq}
+\alias{cbind.phyDat}
+\alias{c.phyDat}
+\title{Conversion among Sequence Formats}
+\description{
+These functions transform several DNA formats into the \code{phyDat} format.
+\code{allSitePattern} generates an alignment of all possible site patterns.
+}
+\usage{
+phyDat(data, type = "DNA", levels = NULL, return.index=TRUE, ...)
+read.phyDat(file, format="phylip", type="DNA", ...)
+write.phyDat(x, file, format="phylip",...)
+\method{as.phyDat}{DNAbin}(x, ...)
+\method{as.character}{phyDat}(x, allLevels = TRUE, ...)
+\method{as.data.frame}{phyDat}(x, ...)
+\method{as.DNAbin}{phyDat}(x, ...)
+\method{subset}{phyDat}(x, subset, select, site.pattern = TRUE, ...)
+allSitePattern(n, levels=c("a","c","g","t"), names=NULL)
+acgt2ry(obj)
+baseFreq(obj, freq=FALSE, drop.unused.levels=FALSE)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{data}{An object containing sequences.}
+ \item{x}{An object containing sequences.}
+ \item{type}{Type of sequences ("DNA", "AA", "CODON" or "USER").}
+ \item{levels}{Level attributes.}
+ \item{return.index}{If TRUE returns a index of the site patterns.}
+ \item{file}{A file name.}
+ \item{format}{File format of the sequence alignment (see details).}
+ \item{n}{Number of sequences.}
+ \item{names}{Names of sequences.}
+ \item{subset}{a subset of taxa.}
+ \item{select}{a subset of characters.}
+ \item{site.pattern}{select site pattern or sites.}
+ \item{allLevels}{return original data.}
+ \item{obj}{as object of class phyDat}
+ \item{freq}{logical, if 'TRUE', frequencies or counts are returned otherwise proportions}
+ \item{drop.unused.levels}{logical, drop unused levels}
+ \item{...}{further arguments passed to or from other methods.}
+}
+\details{
+If \code{type} "USER" a vector has to be give to \code{levels}.
+For example c("a", "c", "g", "t", "-") would create a data object that
+can be used in phylogenetic analysis with gaps as fifth state.
+\code{allSitePattern} returns all possible site patterns and can
+be useful in simulation studies. For further details see the vignette
+phangorn-specials.
+
+\code{write.phyDat} calls the function write.dna or write.nexus.data and
+\code{read.phyDat} calls the function read.dna, read.aa or read.nexus.data
+see for more details over there.
+
+You may import data directly with \code{\link[ape]{read.dna}} or \code{\link[ape]{read.nexus.data}}
+and convert the data to class phyDat.
+
+The generic function \code{c} can be used to to combine sequences and \code{unique} to get
+all unique sequences or unique haplotypes.
+
+\code{acgt2ry} converts a \code{phyDat} object of nucleotides into an binary ry-coded dataset.
+
+There is a more detailed example for specifying USER defined data formats in the vignette advanced features.
+}
+\value{
+The functions return an object of class \code{phyDat}.
+}
+
+\author{Klaus Schliep \email{klaus.schliep at gmail.com}}
+
+\seealso{ \code{\link{DNAbin}}, \code{\link{as.DNAbin}}, \code{\link{read.dna}}, \code{\link{read.aa}} and \code{\link{read.nexus.data}} and
+the example of \code{\link{pmlMix}} for the use of \code{allSitePattern}}
+\examples{
+data(Laurasiatherian)
+class(Laurasiatherian)
+Laurasiatherian
+baseFreq(Laurasiatherian)
+subset(Laurasiatherian, subset=1:5)
+# transform into old ape format
+LauraChar <- as.character(Laurasiatherian)
+# and back
+Laura <- phyDat(LauraChar, return.index=TRUE)
+all.equal(Laurasiatherian, Laura)
+allSitePattern(5)
+}
+\keyword{cluster}
diff --git a/man/plot.networx.Rd b/man/plot.networx.Rd
new file mode 100644
index 0000000..ca2bc2a
--- /dev/null
+++ b/man/plot.networx.Rd
@@ -0,0 +1,117 @@
+\name{plot.networx}
+\alias{plot.networx}
+\alias{as.networx}
+\alias{as.networx.splits}
+%\alias{reorder.networx}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{
+Phylogenetic networks
+}
+\description{
+\code{as.networx} convert \code{splits} objects into a \code{networx} object.
+\code{plot.networx} plot phylogenetic network or split graphs.
+}
+\usage{
+as.networx(x, ...)
+\method{as.networx}{splits}(x, planar = FALSE, ...)
+\method{plot}{networx}(x, type="3D", use.edge.length = TRUE, show.tip.label=TRUE,
+ show.edge.label=FALSE, edge.label = NULL, show.node.label=FALSE,
+ node.label = NULL, show.nodes=FALSE, tip.color="blue",
+ edge.color="grey", edge.width=3, edge.lty=1, font=3,
+ cex=1, ...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+\item{x}{
+an object of class \code{"splits"} (as.networx) or \code{"networx"} (plot)
+}
+\item{planar}{
+logical whether to produce a planar graph from only cyclic splits
+(may excludes splits).
+}
+\item{type}{
+"3D" to plot using rgl or "2D" in the normal device.
+}
+\item{use.edge.length}{
+a logical indicating whether to use the edge weights of the network
+to draw the branches (the default) or not.
+}
+\item{show.tip.label}{
+a logical indicating whether to show the tip labels on the
+graph (defaults to \code{TRUE}, i.e. the labels are shown).
+}
+\item{show.edge.label}{
+a logical indicating whether to show the tip labels on the graph.
+}
+\item{edge.label}{
+an additional vector of edge labels (normally not needed).
+}
+\item{show.node.label}{
+a logical indicating whether to show the node labels (see example).
+}
+\item{node.label}{
+an additional vector of node labels (normally not needed).
+}
+\item{show.nodes}{
+a logical indicating whether to show the nodes (see example).
+}
+\item{tip.color}{
+the colors used for the tip labels.
+}
+\item{edge.color}{
+the colors used to draw edges.
+}
+\item{edge.width}{
+the width used to draw edges.
+}
+\item{edge.lty}{
+a vector of line types.
+}
+\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 labels.}
+\item{\dots}{
+Further arguments passed to or from other methods.
+}
+}
+\details{
+A \code{networx} object hold the information for a phylogenetic network
+and extends the \code{phylo} object. Therefore some generic function for
+\code{phylo} objects will also work for \code{networx} objects.
+The argument planar = FALSE will create a planar split graph based on a
+cyclic ordering. These objects can be nicely plotted in "2D".
+So far not all parameters behave the same on the the rgl "3D"
+and basic graphic "2D" device.
+}
+\note{
+The internal representation is likely to change.
+}
+\references{
+Dress, A.W.M. and Huson, D.H. (2004) Constructing Splits Graphs \emph{IEEE/ACM Transactions on Computational Biology and Bioinformatics (TCBB)}, \bold{1(3)}, 109--115
+}
+\author{
+Klaus Schliep \email{klaus.schliep at gmail.com}
+}
+\seealso{
+\code{\link{consensusNet}}, \code{\link{neighborNet}}, \code{\link{splitsNetwork}}, \code{\link{hadamard}},
+\code{\link{distanceHadamard}}, \code{\link{layout.kamada.kawai}},
+\code{\link[ape]{evonet}}, \code{\link[ape]{as.igraph}}, \code{\link{densiTree}}
+}
+\examples{
+set.seed(1)
+tree1 = rtree(20, rooted=FALSE)
+sp = as.splits(rNNI(tree1, n=10))
+net = as.networx(sp)
+plot(net)
+\dontrun{
+# also see example in consensusNet
+example(consensusNet)
+}
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{plot}
+
diff --git a/man/pml.Rd b/man/pml.Rd
new file mode 100644
index 0000000..dcf23cf
--- /dev/null
+++ b/man/pml.Rd
@@ -0,0 +1,152 @@
+\name{pml}
+\alias{pml}
+\alias{optim.pml}
+\alias{pml.control}
+\title{Likelihood of a tree.}
+\description{
+\code{pml} computes the likelihood of a phylogenetic tree
+given a sequence alignment and a model. \code{optim.pml} optimizes the
+different model parameters.
+}
+\usage{
+pml(tree, data, bf=NULL, Q=NULL, inv=0, k=1, shape=1, rate=1, model="", ...)
+optim.pml(object, optNni=FALSE, optBf=FALSE, optQ=FALSE, optInv=FALSE, optGamma=FALSE,
+ optEdge=TRUE, optRate=FALSE, optRooted=FALSE, control = pml.control(epsilon=1e-08,
+ maxit=10, trace=1), model = NULL, subs = NULL, ...)
+pml.control(epsilon = 1e-08, maxit = 10, trace = 1)
+}
+\arguments{
+ \item{tree}{A phylogenetic \code{tree}, object of class \code{phylo}. }
+ \item{data}{An alignment, object of class \code{phyDat}.}
+ \item{bf}{Base frequencies.}
+ \item{Q}{A vector containing the lower triangular part of the rate matrix.}
+ \item{inv}{Proportion of invariable sites.}
+ \item{k}{Number of intervals of the discrete gamma distribution.}
+ \item{shape}{Shape parameter of the gamma distribution.}
+ \item{rate}{Rate.}
+ \item{model}{allows to choose an amino acid models or nucleotide model, see details.}
+ \item{object}{An object of class \code{pml}.}
+ \item{optNni}{Logical value indicating whether toplogy gets optimized (NNI).}
+ \item{optBf}{Logical value indicating whether base frequencies gets optimized.}
+ \item{optQ}{Logical value indicating whether rate matrix gets optimized.}
+ \item{optInv}{Logical value indicating whether proportion of variable size gets optimized.}
+ \item{optGamma}{Logical value indicating whether gamma rate parameter gets optimized.}
+ \item{optEdge}{Logical value indicating the edge lengths gets optimized.}
+ \item{optRate}{Logical value indicating the overall rate gets optimized.}
+ \item{optRooted}{Logical value indicating if the edge lengths of a rooted tree get optimized.}
+ \item{control}{A list of parameters for controlling the fitting process.}
+ \item{subs}{A (integer) vector same length as Q to specify the optimization of Q}
+ \item{\dots}{Further arguments passed to or from other methods.}
+ \item{epsilon}{Stop criterion for optimisation (see details).}
+ \item{maxit}{Maximum number of iterations (see details).}
+ \item{trace}{Show output during otimization (see details).}
+}
+\details{
+The topology search uses a nearest neighbor interchange (NNI)
+and the implementation is similar to phyML.
+The option model in pml is only used for amino acid models.
+The option model defines the nucleotide model which is getting optmised,
+all models which are included in modeltest can be chosen. Setting this option
+(e.g. "K81" or "GTR") overrules options optBf and optQ.
+Here is a overview how to estimate different phylogenetic models
+with \code{pml}:
+\tabular{lll}{
+model \tab optBf \tab optQ \cr
+Jukes-Cantor \tab FALSE \tab FALSE \cr
+F81 \tab TRUE \tab FALSE \cr
+symmetric \tab FALSE \tab TRUE \cr
+GTR \tab TRUE \tab TRUE
+}
+Via model in optim.pml the following nucleotide models can be specified:
+JC, F81, K80, HKY, TrNe, TrN, TPM1, K81, TPM1u, TPM2, TPM2u, TPM3, TPM3u,
+TIM1e, TIM1, TIM2e, TIM2, TIM3e, TIM3, TVMe, TVM, SYM and GTR.
+These models are specified as in Posada (2008).
+
+So far 17 amino acid models are supported ("WAG", "JTT", "LG", "Dayhoff", "cpREV", "mtmam", "mtArt", "MtZoa", "mtREV24", "VT","RtREV", "HIVw", "HIVb", "FLU", "Blossum62", "Dayhoff_DCMut" and "JTT_DCMut") and additionally rate matrices and amino acid frequences can be supplied.
+
+If the option 'optRooted' is set to TRUE than the edge lengths of rooted tree are optimized.
+The tree has to be rooted and by now ultrametric! Optimising rooted trees is generally much slower.
+
+\code{pml.control} controls the fitting process. \code{epsilon} and \code{maxit} are only defined
+for the most outer loop, this affects \code{pmlCluster}, \code{pmlPart} and \code{pmlMix}.
+\code{epsilon} is defined as (logLik(k)-logLik(k+1))/logLik(k+1), this seems to be a good
+heuristics which works reasonalby for small and large trees or alignments.
+If \code{trace} is set to zero than no out put is shown, if functions are called internally
+than the trace is decreased by one, so a higher of trace produces more feedback.
+}
+\value{
+Returns a list of class \code{ll.phylo}
+ \item{logLik}{Log likelihood of the tree.}
+ \item{siteLik}{Site log likelihoods.}
+ \item{root}{likelihood in the root node.}
+ \item{weight}{Weight of the site patterns.}
+}
+\references{
+Felsenstein, J. (1981) Evolutionary trees from DNA sequences: a maxumum
+likelihood approach. \emph{Journal of Molecular Evolution}, \bold{17}, 368--376.
+
+Felsenstein, J. (2004). \emph{Inferring Phylogenies}. Sinauer Associates, Sunderland.
+
+Yang, Z. (2006). \emph{Computational Molecular evolution}. Oxford University Press, Oxford.
+
+Adachi, J., P. J. Waddell, W. Martin, and M. Hasegawa (2000)
+Plastid genome phylogeny and a model of amino acid substitution for proteins
+encoded by chloroplast DNA. \emph{Journal of Molecular Evolution}, \bold{50}, 348--358
+
+Rota-Stabelli, O., Z. Yang, and M. Telford. (2009) MtZoa: a general mitochondrial
+amino acid substitutions model for animal evolutionary studies. \emph{Mol. Phyl. Evol}, \bold{52(1)}, 268--72
+
+Whelan, S. and Goldman, N. (2001) A general empirical model of
+protein evolution derived from multiple protein families using
+a maximum-likelihood approach. \emph{Molecular Biology and Evolution}, \bold{18}, 691--699
+
+Le, S.Q. and Gascuel, O. (2008) LG: An Improved, General
+Amino-Acid Replacement Matrix \emph{Molecular Biology and Evolution}, \bold{25(7)}, 1307--1320
+
+Yang, Z., R. Nielsen, and M. Hasegawa (1998) Models of amino acid
+substitution and applications to Mitochondrial protein evolution.
+\emph{Molecular Biology and Evolution}, \bold{15}, 1600--1611
+
+Abascal, F., D. Posada, and R. Zardoya (2007) MtArt: A new Model of amino acid
+replacement for Arthropoda. \emph{Molecular Biology and Evolution}, \bold{24}, 1--5
+
+Kosiol, C, and Goldman, N (2005) Different versions of the Dayhoff rate matrix -
+\emph{Molecular Biology and Evolution}, \bold{22}, 193--199
+}
+\author{Klaus Schliep \email{klaus.schliep at gmail.com}}
+\seealso{
+\code{\link{bootstrap.pml}}, \code{\link{modelTest}}, \code{\link{pmlPart}}, \code{\link{pmlMix}}, \code{\link{plot.phylo}}, \code{\link{SH.test}}
+}
+% \note{For small trees the likelihood seems to be very similar to Paup* or PhyML.}
+\examples{
+ example(NJ)
+# Jukes-Cantor (starting tree from NJ)
+ fitJC <- pml(tree, Laurasiatherian)
+# optimize edge length parameter
+ fitJC <- optim.pml(fitJC)
+ fitJC
+
+\dontrun{
+# search for a better tree using NNI rearrangements
+ fitJC <- optim.pml(fitJC, optNni=TRUE)
+ fitJC
+ plot(fitJC$tree)
+
+# JC + Gamma + I - model
+ fitJC_GI <- update(fitJC, k=4, inv=.2)
+# optimize shape parameter + proportion of invariant sites
+ fitJC_GI <- optim.pml(fitJC_GI, optGamma=TRUE, optInv=TRUE)
+# GTR + Gamma + I - model
+ fitGTR <- optim.pml(fitJC_GI, optNni=TRUE, optGamma=TRUE, optInv=TRUE, model="GTR")
+}
+
+
+# 2-state data (RY-coded)
+ dat <- acgt2ry(Laurasiatherian)
+ fit2ST <- pml(tree, dat)
+ fit2ST <- optim.pml(fit2ST,optNni=TRUE)
+ fit2ST
+# show some of the methods available for class pml
+ methods(class="pml")
+}
+\keyword{ cluster }% at least one, from doc/KEYWORDS
diff --git a/man/pml.fit.Rd b/man/pml.fit.Rd
new file mode 100644
index 0000000..8db390e
--- /dev/null
+++ b/man/pml.fit.Rd
@@ -0,0 +1,79 @@
+\name{pml.fit}
+\alias{pml.fit}
+\alias{edQt}
+\alias{pml.init}
+\alias{pml.free}
+\alias{lli}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{
+Internal maximum likelihood functions.
+}
+\description{
+These functions are internally used for the liklihood computations in \code{pml} or \code{optim.pml}.
+}
+\usage{
+pml.fit(tree, data, bf=rep(1/length(levels), length(levels)), shape=1, k=1,
+ Q=rep(1, length(levels)*(length(levels)-1)/2), levels=attr(data, "levels"),
+ inv=0, rate=1, g=NULL, w=NULL, eig=NULL, INV=NULL, ll.0=NULL, llMix=NULL,
+ wMix=0, ..., site=FALSE)
+pml.init(data, k)
+pml.free()
+edQt(Q = c(1, 1, 1, 1, 1, 1), bf = c(0.25, 0.25, 0.25, 0.25))
+lli(data, tree, ...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{tree}{A phylogenetic \code{tree}, object of class \code{phylo}. }
+ \item{data}{An alignment, object of class \code{phyDat}.}
+ \item{bf}{Base frequencies.}
+ \item{shape}{Shape parameter of the gamma distribution.}
+ \item{k}{Number of intervals of the discrete gamma distribution.}
+ \item{Q}{A vector containing the lower triangular part of the rate matrix.}
+ \item{levels}{
+%% ~~Describe \code{levels} here~~
+}
+ \item{inv}{Proportion of invariable sites.}
+ \item{rate}{Rate.}
+ \item{g}{
+%% ~~Describe \code{g} here~~
+}
+ \item{w}{
+%% ~~Describe \code{w} here~~
+}
+ \item{eig}{Eigenvalue decomposition of Q}
+ \item{INV}{Sparse representation of invariant sites}
+ \item{ll.0}{
+%% ~~Describe \code{ll.0} here~~
+ }
+ \item{llMix}{
+%% ~~Describe \code{llMix} here~~
+ }
+ \item{wMix}{
+%% ~~Describe \code{wMix} here~~
+
+ }
+ \item{\dots}{Further arguments passed to or from other methods.}
+ \item{site}{
+%% ~~Describe \code{site} here~~
+}
+}
+\details{
+These functions are exported to be used in different packages so far only in the package coalescentMCMC, but are not intended for end user. Most of the functions call C code.
+}
+\value{
+\code{pml.fit} returns the logliklihood.
+}
+\references{
+Felsenstein, J. (1981) Evolutionary trees from DNA sequences: a maxumum
+likelihood approach. \emph{Journal of Molecular Evolution}, \bold{17}, 368--376.
+}
+\author{
+Klaus Schliep \email{klaus.schliep at gmail.com}
+}
+\seealso{
+\code{\link{pml}, \link{pmlPart}, \link{pmlMix}}
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ cluster }
+
diff --git a/man/pmlCluster.Rd b/man/pmlCluster.Rd
new file mode 100644
index 0000000..6784d97
--- /dev/null
+++ b/man/pmlCluster.Rd
@@ -0,0 +1,70 @@
+\name{pmlCluster}
+\alias{pmlCluster}
+%\alias{pmlCluster2}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Stochastic Partitioning }
+\description{
+ Stochastic Partitioning of genes into p cluster.
+}
+\usage{
+pmlCluster(formula, fit, weight, p=1:5, part=NULL, nrep = 10,
+ control=pml.control(epsilon=1e-8, maxit=10, trace=1),...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{formula}{ a formula object (see details).}
+ \item{fit}{ an object of class \code{pml}. }
+ \item{weight}{ \code{weight} is matrix of frequency of site patterns for all genes. }
+ \item{p}{ number of clusters. }
+ \item{part}{ starting partition, otherwise a random partition is generated. }
+ \item{nrep}{ number of replicates for each p. }
+ \item{control}{A list of parameters for controlling the fitting process.}
+ \item{\dots}{ Further arguments passed to or from other methods. }
+}
+\details{
+ The \code{formula} object allows to specify which parameter get
+ optimized. The formula is generally of the form \code{edge + bf + Q
+ ~ rate + shape + \dots}, on the left side are the parameters which
+ get optimized over all cluster, on the right the parameter which
+ are optimized specific to each cluster. The parameters available
+ are \code{"nni", "bf", "Q", "inv", "shape", "edge", "rate"}.
+ Each parameter can be used only once in the formula.
+ There are also some restriction on the combinations how parameters
+ can get used. \code{"rate"} is only available for the right side.
+ When \code{"rate"} is specified on the left hand side \code{"edge"}
+ has to be specified (on either side), if \code{"rate"} is specified on
+ the right hand side it follows directly that \code{edge} is too.
+}
+\value{
+ \code{pmlCluster} returns a list with elements
+ \item{logLik}{log-likelihood of the fit}
+ \item{trees}{a list of all trees during the optimization.}
+ \item{fits}{fits for the final partitions}
+}
+\references{
+K. P. Schliep (2009). Some Applications of statistical phylogenetics (PhD Thesis)
+
+Lanfear, R., Calcott, B., Ho, S.Y.W. and Guindon, S. (2012) PartitionFinder: Combined Selection of Partitioning Schemes and Substitution Models for Phylogenetic Analyses. \emph{Molecular Biology and Evolution}, \bold{29(6)}, 1695-1701
+}
+\author{Klaus Schliep \email{klaus.schliep at gmail.com}}
+\seealso{ \code{\link{pml}},\code{\link{pmlPart}},\code{\link{pmlMix}},\code{\link{SH.test}} }
+\examples{
+\dontrun{
+data(yeast)
+dm <- dist.logDet(yeast)
+tree <- NJ(dm)
+fit=pml(tree,yeast)
+fit = optim.pml(fit)
+
+weight=xtabs(~ index+genes,attr(yeast, "index"))
+set.seed(1)
+
+sp <- pmlCluster(edge~rate, fit, weight, p=1:4)
+sp
+SH.test(sp)
+}
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ cluster }
+%\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
diff --git a/man/pmlMix.Rd b/man/pmlMix.Rd
new file mode 100644
index 0000000..041c749
--- /dev/null
+++ b/man/pmlMix.Rd
@@ -0,0 +1,103 @@
+\name{pmlMix}
+\alias{pmlMix}
+\alias{pmlPen}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Phylogenetic mixture model }
+\description{
+ Phylogenetic mixture model.
+}
+\usage{
+pmlMix(formula, fit, m=2, omega=rep(1/m, m), control=pml.control(epsilon=1e-08,
+ maxit=20, trace=1),...)
+}
+\arguments{
+ \item{formula}{ a formula object (see details).}
+ \item{fit}{ an object of class \code{pml}. }
+ \item{m}{ number of mixtures. }
+ \item{omega}{ mixing weights.}
+ \item{control}{A list of parameters for controlling the fitting process.}
+ \item{\dots}{ Further arguments passed to or from other methods. }
+}
+\details{
+ The \code{formula} object allows to specify which parameter get
+ optimized. The formula is generally of the form \code{edge + bf + Q
+ ~ rate + shape + \dots}, on the left side are the parameters which
+ get optimized over all mixtures, on the right the parameter which
+ are optimized specific to each mixture. The parameters available
+ are \code{"nni", "bf", "Q", "inv", "shape", "edge", "rate"}.
+ Each parameters can be used only once in the formula.
+ \code{"rate"} and \code{"nni"} are only available for the right side
+ of the formula. On the other hand parameters for invariable sites
+ are only allowed on the left-hand side.
+ The convergence of the algorithm is very slow and is likely that the
+ algorithm can get stuck in local optima.
+}
+\value{
+ \code{pmlMix} returns a list with elements
+ \item{logLik}{log-likelihood of the fit}
+ \item{omega}{mixing weights.}
+ \item{fits}{fits for the final mixtures.}
+}
+\author{Klaus Schliep \email{klaus.schliep at gmail.com}}
+
+\seealso{ \code{\link{pml}},\code{\link{pmlPart}},\code{\link{pmlCluster}} }
+\examples{
+\dontrun{
+X <- allSitePattern(5)
+tree <- read.tree(text = "((t1:0.3,t2:0.3):0.1,(t3:0.3,t4:0.3):0.1,t5:0.5);")
+fit <- pml(tree,X, k=4)
+weights <- 1000*exp(fit$site)
+attr(X, "weight") <- weights
+fit1 <- update(fit, data=X, k=1)
+fit2 <- update(fit, data=X)
+
+(fitMixture <- pmlMix(edge~rate, fit1 , m=4))
+(fit2 <- optim.pml(fit2, optGamma=TRUE))
+
+
+data(Laurasiatherian)
+dm <- dist.logDet(Laurasiatherian)
+tree <- NJ(dm)
+fit=pml(tree, Laurasiatherian)
+fit = optim.pml(fit)
+
+fit2 <- update(fit, k=4)
+fit2 <- optim.pml(fit2, optGamma=TRUE)
+
+fitMix = pmlMix(edge ~ rate, fit, m=4)
+fitMix
+
+
+#
+# simulation of mixture models
+#
+\dontrun{
+X <- allSitePattern(5)
+tree1 <- read.tree(text = "((t1:0.1,t2:0.5):0.1,(t3:0.1,t4:0.5):0.1,t5:0.5);")
+tree2 <- read.tree(text = "((t1:0.5,t2:0.1):0.1,(t3:0.5,t4:0.1):0.1,t5:0.5);")
+tree1 <- unroot(tree1)
+tree2 <- unroot(tree2)
+fit1 <- pml(tree1,X)
+fit2 <- pml(tree2,X)
+
+weights <- 2000*exp(fit1$site) + 1000*exp(fit2$site)
+attr(X, "weight") <- weights
+
+fit1 <- pml(tree1, X)
+fit2 <- optim.pml(fit1)
+logLik(fit2)
+AIC(fit2, k=log(3000))
+
+fitMixEdge = pmlMix( ~ edge, fit1, m=2)
+logLik(fitMixEdge)
+AIC(fitMixEdge, k=log(3000))
+
+fit.p <- pmlPen(fitMixEdge, .25)
+logLik(fit.p)
+AIC(fit.p, k=log(3000))
+}
+}
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{ cluster }
diff --git a/man/pmlPart.Rd b/man/pmlPart.Rd
new file mode 100644
index 0000000..a03c7c0
--- /dev/null
+++ b/man/pmlPart.Rd
@@ -0,0 +1,73 @@
+\name{pmlPart}
+\alias{pmlPart}
+\alias{pmlPart2multiPhylo}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{ Partition model. }
+\description{
+ Model to estimate phylogenies for partitioned data.
+}
+\usage{
+pmlPart(formula, object, control = pml.control(epsilon=1e-8, maxit=10, trace=1),
+ model=NULL, rooted=FALSE, ...)
+pmlPart2multiPhylo(x)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+ \item{formula}{ a formula object (see details).}
+ \item{object}{ an object of class \code{pml} or a list of objects of class \code{pml} . }
+ \item{control}{A list of parameters for controlling the fitting process.}
+ \item{model}{A vector containing the models containing a model for each partition.}
+ \item{rooted}{Are the gene trees rooted (ultrametric) or unrooted.}
+ \item{\dots}{Further arguments passed to or from other methods. }
+ \item{x}{an object of class \code{pmlPart} }
+}
+\details{
+ The \code{formula} object allows to specify which parameter get
+ optimized. The formula is generally of the form \code{edge + bf + Q
+ ~ rate + shape + \dots}, on the left side are the parameters which
+ get optimized over all partitions, on the right the parameter which
+ are optimized specific to each partition. The parameters available
+ are \code{"nni", "bf", "Q", "inv", "shape", "edge", "rate"}.
+ Each parameters can be used only once in the formula.
+ \code{"rate"} and \code{"nni"} are only available for the right side
+ of the formula.
+
+ For partitions with different edge weights, but same topology, \code{pmlPen}
+ can try to find more parsimonious models (see example).
+
+ \code{pmlPart2multiPhylo} is a convenience function to extract the trees
+ out of a \code{pmlPart} object.
+}
+\value{
+ \code{kcluster} returns a list with elements
+ \item{logLik}{log-likelihood of the fit}
+ \item{trees}{a list of all trees during the optimization.}
+ \item{object}{an object of class \code{"pml"} or \code{"pmlPart"}}
+}
+%\references{ ~put references to the literature/web site here ~ }
+\author{Klaus Schliep \email{klaus.schliep at gmail.com}}
+
+\seealso{ \code{\link{pml}},\code{\link{pmlCluster}},\code{\link{pmlMix}},\code{\link{SH.test}} }
+\examples{
+data(yeast)
+dm <- dist.logDet(yeast)
+tree <- NJ(dm)
+fit <- pml(tree,yeast)
+fits <- optim.pml(fit)
+
+weight=xtabs(~ index+genes,attr(yeast, "index"))[,1:10]
+
+sp <- pmlPart(edge ~ rate + inv, fits, weight=weight)
+sp
+
+\dontrun{
+sp2 <- pmlPart(~ edge + inv, fits, weight=weight)
+sp2
+AIC(sp2)
+
+sp3 <- pmlPen(sp2, lambda = 2)
+AIC(sp3)
+}
+}
+\keyword{ cluster }
+%\keyword{ ~kwd2 }% __ONLY ONE__ keyword per line
diff --git a/man/read.aa.Rd b/man/read.aa.Rd
new file mode 100644
index 0000000..d746371
--- /dev/null
+++ b/man/read.aa.Rd
@@ -0,0 +1,43 @@
+\name{read.aa}
+\alias{read.aa}
+\title{Read Amino Acid Sequences in a File}
+\usage{
+read.aa(file, format = "interleaved", skip = 0,
+ nlines = 0, comment.char = "#", seq.names = NULL)
+}
+\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 until 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.}
+}
+\description{
+ This function reads amino acid sequences in a file, and returns a matrix
+ list of DNA sequences with the names of the taxa read in the file as
+ row names.}
+\value{
+ a matrix of amino acid sequences.
+}
+\references{
+% Anonymous. FASTA format description.
+% \url{http://www.ncbi.nlm.nih.gov/BLAST/fasta.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[ape]{read.dna}}, \code{\link[ape]{read.GenBank}},
+ \code{\link[phangorn]{phyDat}}, \code{\link[seqinr]{read.alignment}}
+}
+\author{Klaus Schliep \email{klaus.schliep at gmail.com}}
+\keyword{IO}
diff --git a/man/simSeq.Rd b/man/simSeq.Rd
new file mode 100644
index 0000000..6579c36
--- /dev/null
+++ b/man/simSeq.Rd
@@ -0,0 +1,74 @@
+\name{simSeq}
+\alias{simSeq}
+\alias{simSeq.phylo}
+\alias{simSeq.pml}
+\title{ Simulate sequences. }
+\description{
+Simulate sequences for a given evolutionary tree.
+}
+\usage{
+simSeq(x, ...)
+\method{simSeq}{phylo}(x, l=1000, Q=NULL, bf=NULL, rootseq=NULL, type="DNA",
+ model="", levels=NULL, rate=1, ancestral=FALSE, ...)
+\method{simSeq}{pml}(x, ancestral = FALSE, ...)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+\item{x}{ a phylogenetic tree \code{tree}, i.e. an object of class \code{phylo} or and object of class \code{pml}. }
+\item{l}{ length of the sequence to simulate. }
+\item{Q}{ the rate matrix. }
+\item{bf}{ base frequencies. }
+\item{rootseq}{a vector of length l containing the root sequence,
+other root sequence is randomly generated.}
+\item{type}{Type of sequences ("DNA", "AA" or "USER").}
+\item{model}{Amino acid models: one of "WAG", "JTT", "Dayhoff" or "LG"}
+\item{levels}{ \code{levels} takes a character vector of the different bases,
+default is for nucleotide sequences, only used when type = "USER".}
+\item{rate}{rate. }
+\item{ancestral}{Return ancestral sequences?}
+\item{\dots}{Further arguments passed to or from other methods.}
+}
+\details{
+\code{simSeq} is now a generic function to simulate sequence alignments.
+It is quite flexible and allows to generate DNA, RNA, amino acids or binary sequences.
+It is possible to give a \code{pml} object as input simSeq return a \code{phyDat}
+from these model.
+There is also a more low level version, which lacks rate variation, but one can combine different alignments having their own rate (see example).
+}
+\value{
+\code{simSeq} returns an object of class phyDat.
+}
+\author{ Klaus Schliep \email{klaus.schliep at gmail.com}}
+
+\seealso{ \code{\link{phyDat}}, \code{\link{pml}}, \code{\link{SOWH.test}}
+}
+\examples{
+\dontrun{
+data(Laurasiatherian)
+tree = nj(dist.ml(Laurasiatherian))
+fit = pml(tree, Laurasiatherian, k=4)
+fit = optim.pml(fit, optNni=TRUE, model="GTR", optGamma=TRUE)
+data = simSeq(fit)
+}
+
+tree = rtree(5)
+plot(tree)
+nodelabels()
+
+# Example for simple DNA alignment
+data = simSeq(tree, l = 10, type="DNA", bf=c(.1,.2,.3,.4), Q=1:6)
+as.character(data)
+
+# Example to simulate discrete Gamma rate variation
+rates = phangorn:::discrete.gamma(1,4)
+data1 = simSeq(tree, l = 100, type="AA", model="WAG", rate=rates[1])
+data2 = simSeq(tree, l = 100, type="AA", model="WAG", rate=rates[2])
+data3 = simSeq(tree, l = 100, type="AA", model="WAG", rate=rates[3])
+data4 = simSeq(tree, l = 100, type="AA", model="WAG", rate=rates[4])
+data <- c(data1,data2, data3, data4)
+
+write.phyDat(data, file="temp.dat", format="sequential",nbcol = -1, colsep = "")
+unlink("temp.dat")
+}
+\keyword{ cluster }% at least one, from doc/KEYWORDS
+
diff --git a/man/splitsNetwork.Rd b/man/splitsNetwork.Rd
new file mode 100644
index 0000000..c719184
--- /dev/null
+++ b/man/splitsNetwork.Rd
@@ -0,0 +1,56 @@
+\name{splitsNetwork}
+
+\alias{splitsNetwork}
+\title{Phylogenetic Network}
+\description{
+\code{splitsNetwork} estimates weights for a splits graph from a distance matrix.
+}
+\usage{
+splitsNetwork(dm, splits=NULL, gamma=.1, lambda=1e-6, weight=NULL)
+}
+\arguments{
+ \item{dm}{A distance matrix.}
+ \item{splits}{a splits object, containing all splits to consider,
+ otherwise all possible splits are used}
+ \item{gamma}{penalty value for the L1 constraint.}
+ \item{lambda}{penalty value for the L2 constraint.}
+ \item{weight}{a vector of weights.}
+}
+
+\details{
+\code{splitsNetwork} fits non-negative least-squares phylogenetic networks using L1 (LASSO), L2(ridge regression) constraints.
+The function minimizes the penalized least squares
+\deqn{\beta = min \sum(dm - X\beta)^2 + \lambda \|\beta \|^2_2 }{%
+beta = sum(dm - X*beta)^2 + lambda |beta|^2_2 }
+with respect to \deqn{\|\beta \|_1 <= \gamma, \beta >= 0}{%
+|beta|_1 = gamma, beta >= 0}
+where X is a design matrix constructed with \code{designSplits}.
+External edges are fitted without L1 or L2 constraints.
+}
+\value{
+\code{splitsNetwork} returns a splits object with a matrix added.
+The first column contains the indices of the splits, the second
+column an unconstrained fit without penalty terms and the third
+column the constrained fit.
+}
+\references{
+Efron, Hastie, Johnstone and Tibshirani (2003) "Least Angle Regression" (with discussion) Annals of Statistics
+
+K. P. Schliep (2009). Some Applications of statistical phylogenetics (PhD Thesis)
+}
+\author{Klaus Schliep \email{klaus.schliep at gmail.com}}
+\seealso{\code{\link[phangorn]{distanceHadamard}}, \code{\link[phangorn]{designTree}}
+\code{\link[phangorn]{consensusNet}}, \code{\link[phangorn]{plot.networx}}
+}
+
+\examples{
+data(yeast)
+dm = dist.ml(yeast)
+fit = splitsNetwork(dm)
+net = as.networx(fit)
+plot(net)
+write.nexus.splits(fit)
+}
+\keyword{ cluster }% at least one, from doc/KEYWORDS
+
+
diff --git a/man/superTree.Rd b/man/superTree.Rd
new file mode 100644
index 0000000..aa73553
--- /dev/null
+++ b/man/superTree.Rd
@@ -0,0 +1,70 @@
+\name{superTree}
+\alias{superTree}
+\alias{coalSpeciesTree}
+%- Also NEED an '\alias' for EACH other topic documented here.
+\title{
+Super Tree and Species Tree methods
+}
+\description{
+These function \code{superTree} allows the estimation of a rooted supertree from a set of rooted trees using Matrix representation parsimony. \code{coalSpeciesTree} estimates species trees and can multiple individuals per species.}
+\usage{
+superTree(tree, method = "optim.parsimony", rooted=TRUE, ...)
+coalSpeciesTree(tree, X, sTree = NULL)
+}
+%- maybe also 'usage' for other objects documented here.
+\arguments{
+\item{tree}{
+an object of class \code{multiPhylo}
+}
+\item{method}{
+An argument defining which algorithm is used to optimize the tree.
+}
+\item{rooted}{
+should the resulting supertrees be rooted.
+}
+\item{X}{
+A \code{phyDat} object to define which individual belongs to which species.
+}
+\item{sTree}{
+A species tree which forces the topology.
+}
+\item{\dots}{
+further arguments passed to or from other methods.
+}
+}
+\details{
+The function \code{superTree} extends the function mrp.supertree from Liam Revells,
+with artificial adding an outgroup on the root of the trees.
+This allows to root the supertree afterwards. The functions is internally used in DensiTree.
+
+\code{coalSpeciesTree} estimates a single linkage tree as suggested by Liu et al. (2010) from the element wise minima of the cophenetic matrices of the gene trees. It extends \code{speciesTree} in ape as it allows that have several individuals per gene tree.
+}
+\value{
+The function returns an object of class \code{phylo}.
+}
+\references{
+Liu, L., Yu, L. and Pearl, D. K. (2010) Maximum tree: a consistent estimator of the species tree. \emph{Journal of Mathematical Biology}, \bold{60}, 95--106.
+
+
+}
+\author{
+Klaus Schliep \email{klaus.schliep at gmail.com}
+Liam Revell
+Emmanuel Paradies
+}
+%% ~Make other sections like Warning with \section{Warning }{....} ~
+
+\seealso{
+\code{mrp.supertree}, \code{\link{speciesTree}}, \code{\link{densiTree}}, \code{\link{hclust}}
+}
+\examples{
+data(Laurasiatherian)
+set.seed(1)
+bs <- bootstrap.phyDat(Laurasiatherian, FUN = function(x)upgma(dist.hamming(x)), bs=50)
+class(bs) <- 'multiPhylo'
+plot(superTree(bs))
+}
+% Add one or more standard keywords, see file 'KEYWORDS' in the
+% R documentation directory.
+\keyword{cluster}
+
diff --git a/man/treedist.Rd b/man/treedist.Rd
new file mode 100644
index 0000000..9b40ebf
--- /dev/null
+++ b/man/treedist.Rd
@@ -0,0 +1,46 @@
+\name{treedist}
+\alias{treedist}
+\alias{RF.dist}
+%\alias{print.treedist}
+\title{ Distances between trees }
+\description{
+ \code{treedist} computes different tree distance methods and \code{RF.dist} the Robinson-Foulds or symmetric distance.
+}
+\usage{
+treedist(tree1, tree2, check.labels = TRUE)
+RF.dist(tree1, tree2=NULL, check.labels=TRUE)
+}
+\arguments{
+ \item{tree1}{ A phylogenetic tree (class \code{phylo})
+ or vector of trees (an object of class \code{multiPhylo}). See details }
+ \item{tree2}{ A phylogenetic tree. }
+ \item{check.labels}{compares labels of the trees.}
+}
+\value{
+ \code{treedist} returns a vector containing the following tree distance methods
+ \item{symmetric.difference}{symmetric.difference or Robinson-Foulds distance}
+ \item{branch.score.difference}{branch.score.difference}
+ \item{path.difference}{path.difference}
+ \item{weighted.path.difference}{weighted.path.difference}
+}
+\details{
+The Robinson-Foulds distance is well defined only for bifurcating trees.
+
+RF.dist returns the Robinson-Foulds distance between either 2 trees or computes
+a matrix of all pairwise distances if a \code{multiPhylo} object is given.
+For large number of trees RF.dist can use a lot of memory!
+
+% The function used internally is 2 * (nt - m) where nt is the number of tips and
+% m is the number of shared bipartitions. When there are multifurcations the
+% distance is therefore increasing!! This may be different to other implementations!
+
+}
+\references{Steel M. A. and Penny P. (1993) \emph{Distributions of tree comparison metrics - some new results}, Syst. Biol.,42(2), 126-141}
+\author{ Klaus P. Schliep \email{klaus.schliep at gmail.com}}
+\examples{
+tree1 <- rtree(100, rooted=FALSE)
+tree2 <- rSPR(tree1, 3)
+RF.dist(tree1, tree2)
+treedist(tree1, tree2)
+}
+\keyword{ classif }% at least one, from doc/KEYWORDS
diff --git a/man/upgma.Rd b/man/upgma.Rd
new file mode 100644
index 0000000..837d251
--- /dev/null
+++ b/man/upgma.Rd
@@ -0,0 +1,30 @@
+\name{upgma}
+\alias{upgma}
+\alias{wpgma}
+\title{ UPGMA and WPGMA }
+\description{
+ UPGMA and WPGMA clustering. Just a wrapper function around \code{\link[stats]{hclust}}.
+}
+\usage{
+upgma(D, method = "average", ...)
+wpgma(D, method = "mcquitty", ...)
+}
+\arguments{
+ \item{D}{A distance matrix.}
+ \item{method}{The agglomeration method to be used. This should be (an unambiguous abbreviation of) one of "ward", "single", "complete", "average", "mcquitty", "median" or "centroid". The default is "average".}
+ \item{\dots}{Further arguments passed to or from other methods.}
+}
+
+\value{
+A phylogenetic tree of class \code{phylo}.
+}
+\author{Klaus Schliep \email{klaus.schliep at gmail.com}}
+
+\seealso{ \code{\link{hclust}}, \code{\link{dist.hamming}}, \code{\link{NJ}}, \code{\link{as.phylo}}, \code{\link{fastme}}, \code{\link{nnls.tree}} }
+\examples{
+data(Laurasiatherian)
+dm = dist.ml(Laurasiatherian)
+tree = upgma(dm)
+plot(tree)
+}
+\keyword{cluster}
diff --git a/man/yeast.Rd b/man/yeast.Rd
new file mode 100644
index 0000000..ffb49ec
--- /dev/null
+++ b/man/yeast.Rd
@@ -0,0 +1,19 @@
+\name{yeast}
+\alias{yeast}
+\docType{data}
+\title{ Yeast alignment (Rokas et al.) }
+\description{
+Alignment of 106 genes of 8 different species of yeast.}
+\usage{data(yeast)}
+
+\references{
+Rokas, A., Williams, B. L., King, N., and Carroll, S. B. (2003)
+Genome-scale approaches to resolving incongruence in molecular phylogenies.
+\emph{Nature}, \bold{425}(6960): 798--804
+}
+
+\examples{
+data(yeast)
+str(yeast)
+}
+\keyword{datasets}
diff --git a/src/Makevars b/src/Makevars
new file mode 100644
index 0000000..b6b6fa5
--- /dev/null
+++ b/src/Makevars
@@ -0,0 +1,3 @@
+PKG_LIBS = $(LAPACK_LIBS) $(BLAS_LIBS) $(FLIBS) $(SHLIB_OPENMP_CFLAGS)
+PKG_CFLAGS = $(SHLIB_OPENMP_CFLAGS)
+
diff --git a/src/dist.c b/src/dist.c
new file mode 100644
index 0000000..1eb0bd6
--- /dev/null
+++ b/src/dist.c
@@ -0,0 +1,231 @@
+/*
+ * dist.c
+ *
+ * (c) 2008-2015 Klaus Schliep (klaus.schliep at gmail.com)
+ *
+ *
+ * This code may be distributed under the GNU GPL
+ *
+ */
+
+# define USE_RINTERNALS
+
+#include <Rmath.h>
+#include <math.h>
+#include <R.h>
+#include <R_ext/Lapack.h>
+#include <Rinternals.h>
+// #include "dist.h"
+
+
+// off-diagonal
+#define DINDEX(i, j) n*(i - 1) - i * (i - 1)/2 + j - i - 1
+// with diagonal (+i), R index (+1)
+#define DINDEX2(i, j) n*(i - 1) - i * (i - 1)/2 + j - 1
+
+// #define threshold parameters
+
+
+int give_index(int i, int j, int n)
+{
+ if (i > j) return(DINDEX(j, i));
+ else return(DINDEX(i, j));
+}
+
+
+int give_index2(int i, int j, int n)
+{
+ if (i > j) return(DINDEX2(j, i));
+ else return(DINDEX2(i, j));
+}
+
+
+
+void giveIndex(int *left, int* right, int *ll, int *lr, int *n, int *res){
+ int i, j, k;
+ k=0;
+ for (i = 0; i < *ll; i++){
+ for (j = 0; j < *lr; j++){
+ res[k] = give_index(left[i], right[j], *n);
+ k++;
+ }
+ }
+ }
+
+
+void giveIndex2(int *left, int* right, int *ll, int *lr, int *n, int *res){
+ int i, j, k;
+ k=0;
+ for (i = 0; i < *ll; i++){
+ for (j = 0; j < *lr; j++){
+ res[k] = give_index2(left[i], right[j], *n);
+ k++;
+ }
+ }
+ }
+
+
+
+
+void PD(int *x, int *y, int *n, int *weight){
+ int i, k; //n =length(x)
+ for(i=0; i< *n; i++){
+ k=give_index(x[i], y[i], *n);
+ weight[k]++;
+ }
+}
+
+
+void pwIndex(int *left, int* right, int *l, int *n, double *w, double *res){
+ int i, k;
+ k=0;
+ for (i = 0; i < *l; i++){
+ k = give_index2(left[i], right[i], *n);
+ res[k] += w[i];
+ }
+ }
+
+
+
+SEXP PWI(SEXP LEFT, SEXP RIGHT, SEXP L, SEXP N, SEXP W, SEXP LI){
+ int i, li=INTEGER(LI)[0];
+ SEXP res;
+ PROTECT(res = allocVector(REALSXP, li));
+ for(i = 0; i < li; i++)REAL(res)[i] = 0.0;
+ pwIndex(INTEGER(LEFT), INTEGER(RIGHT), INTEGER(L), INTEGER(N), REAL(W), REAL(res));
+ UNPROTECT(1);
+ return(res);
+}
+
+
+
+void C_fhm(double *v, int *n){
+ unsigned int level, i, j;
+ unsigned int start, step, num_splits;
+ double vi, vj;
+ num_splits = (1 << (*n));
+ step = 1;
+ for(level = 0; level < (*n); level++){
+ start = 0;
+ while(start < (num_splits-1)){
+ for(i = start; i < (start + step); i++){
+ j = i + step;
+ vi = v[i];
+ vj = v[j];
+ v[i] = vi + vj;
+ v[j] = vi - vj;
+ }
+ start = start + 2*step;
+ }
+ step *= 2;
+ }
+}
+
+
+void distance_hadamard(double *d, int n) {
+ unsigned int num_splits;
+ unsigned int x, r, nr, p, b, e;
+ unsigned int odd = 1; // The inner while loop can only terminate with odd == 1 so we don't need to set it inside the for loop.
+ double cost, best_cost;
+
+ num_splits = (1 << (n - 1));
+
+ for (x = 1; x < num_splits; ++x) {
+ r = (x - 1) & x; // r = x without LSB
+ nr = (r - 1) & r; // nr = r without LSB
+
+ if (nr) { // If x contains 1 or 2 bits only, then it has already been computed as a pairwise distance.
+ b = x - r; // b = LSB of x: the "fixed" taxon in the pair.
+ best_cost = 1e20;
+ e = 0; // e holds bits to the right of the current p.
+
+ while (1) {
+ p = r - nr; // p = 2nd half of pair
+ cost = d[nr + e] + d[p + b];
+ if (cost < best_cost) best_cost = cost;
+
+ if (!nr && odd) break; // Ensure we get the (LSB with reference taxon) pair when there are an odd number of taxa
+ r = nr;
+ e += p;
+ nr = (r - 1) & r; // nr = r without LSB
+ odd ^= 1;
+ }
+ d[x] = best_cost;
+ }
+ }
+
+ d[0] = 0.0;
+ }
+
+
+void pairwise_distances(double *dm, int n, int num_splits, double *d) {
+ int k=0;
+ unsigned int offset;
+ for (int i = 0; i < (n-1); ++i) {
+ for (int j = (i+1); j < n; ++j) {
+// Calculate the offset within the array to put the next value
+ offset = (1 << i);
+ if (j < n - 1) { // If i == n - 1 then this is a distance between the reference taxon and some other taxon.
+ offset += (1 << j); // Note that "+" is safe since (1 << i) and (1 << j) are always different bits.
+ }
+ d[offset]=dm[k];
+ k++;
+ }
+ }
+ }
+
+
+SEXP dist2spectra(SEXP dm, SEXP nx, SEXP ns) {
+ int n = INTEGER(nx)[0];
+ int nsp = INTEGER(ns)[0];
+ double *res;
+ SEXP result;
+ PROTECT(result = allocVector(REALSXP, nsp));
+ res = REAL(result);
+ pairwise_distances(REAL(dm), n, nsp, res);
+ distance_hadamard(res, n);
+ UNPROTECT(1);
+ return(result);
+}
+
+
+// speed up some code for NJ
+void out(double *d, double *r, int *n, int *k, int *l){
+ int i, j;
+ double res, tmp;
+ k[0]=1;
+ l[0]=2;
+ res = d[1] - r[0] - r[1];
+ for(i = 0; i < (*n-1); i++){
+ for(j = i+1; j < (*n); j++){
+ tmp = d[i*(*n)+j] - r[i] - r[j];
+ if(tmp<res){
+ k[0]=i+1;
+ l[0]=j+1;
+ res = tmp;
+ }
+ }
+
+ }
+ }
+
+
+// hamming distance
+void distHamming(int *x, double *weight, int *nr, int *l, double *d){
+ int i, j, k, m;
+ k = 0L;
+ for(i = 0; i< (*l-1L); i++){
+ for(j = (i+1L); j < (*l); j++){
+ for(m=0; m<(*nr); m++){
+ if(!(x[i*(*nr) + m] & x[j*(*nr) + m])) d[k] += weight[m];
+ }
+ k++;
+ }
+ }
+}
+
+
+
+
+
+
diff --git a/src/fitch.c b/src/fitch.c
new file mode 100644
index 0000000..1280729
--- /dev/null
+++ b/src/fitch.c
@@ -0,0 +1,741 @@
+#define USE_RINTERNALS
+
+#include <Rmath.h>
+#include <math.h>
+#include <R.h>
+#include <Rinternals.h>
+
+
+
+// use R_len_t stat int, e.g. nr
+double huge = 1.0e300;
+static int *data1, *data2;
+static double *weight;
+
+
+void fitch_free(){
+ free(data1);
+ free(data2);
+ free(weight);
+}
+
+// type of fitch depending on nc e.g. int, long generic C++
+void fitch_init(int *data, int *m, int *n, double *weights, int *nr)
+{
+ int i;
+ data1 = (int *) calloc(*n, sizeof(int));
+ data2 = (int *) calloc(*n, sizeof(int));
+ weight = (double *) calloc(*nr, sizeof(double));
+ for(i=0; i<*m; i++) data1[i] = data[i];
+ for(i=0; i<*nr; i++) weight[i] = weights[i];
+}
+
+
+SEXP getData(SEXP n, SEXP k){
+ int i, m=INTEGER(n)[0], l=INTEGER(k)[0];
+ SEXP DAT, DAT2, RESULT;
+ PROTECT(RESULT = allocVector(VECSXP, 2L));
+ PROTECT(DAT = allocMatrix(INTSXP, m, l));
+ PROTECT(DAT2 = allocMatrix(INTSXP, m, l));
+ for(i=0; i< m*l; i++) INTEGER(DAT)[i] = data1[i];
+ for(i=0; i< m*l; i++) INTEGER(DAT2)[i] = data2[i];
+ SET_VECTOR_ELT(RESULT, 0, DAT);
+ SET_VECTOR_ELT(RESULT, 1, DAT2);
+ UNPROTECT(3);
+ return(RESULT);
+}
+
+
+SEXP getWeight(SEXP n){
+ int i, m=INTEGER(n)[0];
+ SEXP RESULT;
+ PROTECT(RESULT = allocVector(REALSXP, m));
+ for(i=0; i<m; i++) REAL(RESULT)[i] = weight[i];
+ UNPROTECT(1);
+ return(RESULT);
+}
+
+
+int bitcount(int x){
+ int count;
+ for (count=0; x != 0; x>>=1)
+ if ( x & 01)
+ count++;
+ return count;
+}
+
+
+void bitCount(int *x, int *count){
+ count[0]=bitcount(x[0]);
+}
+
+
+void addOne(int *edge, int *tip, int *ind, int *l, int *m, int *result){
+ int add = 1L, j=0L, p, k, i, l2=*l+2L, ei;
+ p = edge[*ind-1L];
+ k = edge[*ind-1L + *l];
+ for(i=0; i<*l; i++){
+ ei = edge[i];
+ if( (add==1L) && (ei==p) ){
+ result[j] = *m;
+ result[j+l2] = k;
+ j++;
+ result[j] = *m;
+ result[j+l2] = *tip;
+ j++;
+ add=0L;
+ }
+ if(i== (*ind-1L)) result[j+l2] = *m;
+ else result[j+l2] = edge[i+ *l];
+ result[j] = edge[i];
+ j++;
+ }
+}
+
+
+SEXP AddOne(SEXP edge, SEXP tip, SEXP ind, SEXP l, SEXP m){
+ SEXP result;
+ PROTECT(result = allocMatrix(INTSXP, INTEGER(l)[0]+2L, 2L));
+ addOne(INTEGER(edge), INTEGER(tip), INTEGER(ind), INTEGER(l), INTEGER(m), INTEGER(result));
+ UNPROTECT(1);
+ return(result);
+}
+
+
+void fitch43(int *dat1, int *dat2, int *nr, int *pars, double *weight, double *w){
+ int k, tmp;
+ for(k = 0; k < (*nr); k++){
+ tmp = dat1[k] & dat2[k];
+ if(!tmp){
+ tmp = dat1[k] | dat2[k];
+ (pars[k])++;
+ (*w)+=weight[k];
+ }
+ dat1[k] = tmp;
+ }
+}
+
+
+void fitch44(int *res, int *dat1, int *dat2, int *nr, int *pars, double *weight, double *w){
+ int k, tmp;
+ for(k = 0; k < (*nr); k++){
+ tmp = dat1[k] & dat2[k];
+ if(!tmp){
+ tmp = dat1[k] | dat2[k];
+ (pars[k])++;
+ (*w)+=weight[k];
+ }
+ res[k] = tmp;
+ }
+}
+
+
+void fitch53(int *dat1, int *dat2, int *nr, double *weight, double *w){
+ int k, tmp;
+ for(k = 0; k < (*nr); k++){
+ tmp = dat1[k] & dat2[k];
+ if(!tmp){
+ tmp = dat1[k] | dat2[k];
+ (*w)+=weight[k];
+ }
+ dat1[k] = tmp;
+ }
+}
+
+
+void fitch54(int *res, int *dat1, int *dat2, int *nr, double *weight, double *w){
+ int k, tmp;
+ for(k = 0; k < (*nr); k++){
+ tmp = dat1[k] & dat2[k];
+ if(!tmp){
+ tmp = dat1[k] | dat2[k];
+ (*w)+=weight[k];
+ }
+ res[k] = tmp;
+ }
+}
+
+
+SEXP FITCHTRIP3(SEXP DAT3, SEXP nrx, SEXP edge, SEXP score, SEXP PS){
+ R_len_t i, m = length(edge);
+ int nr=INTEGER(nrx)[0], k, tmp, ei, *edges=INTEGER(edge);
+ int d3=INTEGER(DAT3)[0] - 1;
+ double *pvtmp;
+ double ps = REAL(PS)[0];
+ SEXP pvec;
+ PROTECT(pvec = allocVector(REALSXP, m));
+ pvtmp = REAL(pvec);
+ for(i=0; i<m; i++) pvtmp[i] = REAL(score)[i];
+/*
+#ifdef _OPENMP
+if(*nthreads <= 1){ *nthreads=1; }else{ *nthreads=(*nthreads < omp_get_max_threads()) ? (*nthreads) : (omp_get_max_threads()); }
+#endif
+
+#ifdef SUPPORT_OPENMP
+#pragma omp parallel for private(i, ei, k, tmp) shared(edges, data1, data2, d3, nr, weight, ps, pvtmp)
+#endif
+*/
+ for(i=0; i<m; i++){
+ ei = edges[i] - 1L;
+// pvtmp[i] = REAL(score)[ei];
+ for(k = 0; k < nr; k++){
+ tmp = data1[k + ei*nr] & data2[k + ei*nr];
+ if(!tmp){
+ tmp = data1[k + ei*nr] | data2[k + ei*nr];
+ pvtmp[i]+=weight[k];
+ }
+ tmp = tmp & data1[k + d3*nr];
+ if(!tmp){
+ pvtmp[i]+=weight[k];
+ }
+ if(pvtmp[i]>ps)break;
+ }
+// if(pvtmp[i]<ps) ps = pvtmp[i] + 1.0e-8 random.addition order
+ }
+ UNPROTECT(1);
+ return(pvec);
+}
+
+
+
+void fitch8(int *dat, int *nr, int *pars, int *node, int *edge, int *nl, double *weight, double *pvec, double *pscore)
+{
+ int i, ni=0L, ri, le;
+ i=0L;
+ while(i<(*nl - 1L)){
+ ni = node[i] - 1L;
+ le = edge[i] - 1L;
+ ri = edge[i+1] - 1L;
+ pvec[ni] = pvec[le] + pvec[ri];
+ fitch44(&dat[ni * (*nr)], &dat[le * (*nr)], &dat[ri * (*nr)], nr, pars, weight, &pvec[ni]);
+ i++;
+ i++;
+ }
+ if(i == (*nl-1L)){
+ le = edge[i] - 1L;
+ pvec[ni] += pvec[le];
+ fitch43(&dat[ni * (*nr)], &dat[le * (*nr)], nr, pars, weight, &pvec[ni]);
+ }
+ pscore[0]=pvec[ni];
+}
+
+
+void fitch9(int *dat, int *nr, int *node, int *edge, int *nl, double *weight, double *pvec, double *pscore)
+{
+ int i, ni=0L, ri, le;
+ i=0L;
+ while(i<(*nl - 1L)){
+ ni = node[i] - 1L;
+ le = edge[i] - 1L;
+ ri = edge[i+1] - 1L;
+ pvec[ni] = pvec[le] + pvec[ri];
+ fitch54(&dat[ni * (*nr)], &dat[le * (*nr)], &dat[ri * (*nr)], nr, weight, &pvec[ni]);
+ i++;
+ i++;
+ }
+ if(i == (*nl-1L)){
+ le = edge[i] - 1L;
+ pvec[ni] += pvec[le];
+ fitch53(&dat[ni * (*nr)], &dat[le * (*nr)], nr, weight, &pvec[ni]);
+ }
+ pscore[0]=pvec[ni];
+}
+
+
+// in fitch
+SEXP FITCH(SEXP dat, SEXP nrx, SEXP node, SEXP edge, SEXP l, SEXP weight, SEXP mx, SEXP q){
+ int *data, *nr=INTEGER(nrx), m=INTEGER(mx)[0], i, n=INTEGER(q)[0];
+ double *pvtmp;
+ SEXP DAT, pars, pvec, pscore, RESULT;
+ PROTECT(RESULT = allocVector(VECSXP, 4L));
+ PROTECT(pars = allocVector(INTSXP, *nr));
+ PROTECT(pscore = allocVector(REALSXP, 1L));
+ PROTECT(DAT = allocMatrix(INTSXP, nr[0], m));
+ PROTECT(pvec = allocVector(REALSXP, m));
+ pvtmp = REAL(pvec);
+ data = INTEGER(DAT);
+ for(i=0; i<m; i++) pvtmp[i] = 0.0;
+ for(i=0; i<*nr; i++) INTEGER(pars)[i] = 0L;
+ REAL(pscore)[0]=0.0;
+ for(i=0; i<(*nr * n); i++)data[i] = INTEGER(dat)[i];
+
+ fitch8(data, nr, INTEGER(pars), INTEGER(node), INTEGER(edge), INTEGER(l), REAL(weight), pvtmp, REAL(pscore));
+
+ SET_VECTOR_ELT(RESULT, 0, pscore);
+ SET_VECTOR_ELT(RESULT, 1, pars);
+ SET_VECTOR_ELT(RESULT, 2, DAT);
+ SET_VECTOR_ELT(RESULT, 3, pvec);
+ UNPROTECT(5);
+ return(RESULT);
+}
+
+
+/*
+ACCTRAN
+*/
+void fitchT(int *dat1, int *dat2, int *nr, double *pars, double *weight, double *w){
+ int k;
+ int tmp;
+ for(k = 0; k < (*nr); k++){
+ tmp = dat1[k] & dat2[k];
+ if(tmp > 0L){
+ dat1[k] = tmp;
+ }
+ }
+}
+
+
+void fitchT3(int *dat1, int *dat2, int *nr, double *pars, double *weight, double *w){
+ int k;
+ int tmp;
+ for(k = 0; k < (*nr); k++){
+ tmp = dat1[k] & dat2[k];
+ if(tmp==0L) {
+ (*w)+=weight[k];
+ pars[k] += 1;
+ }
+ if(tmp >0){
+ if(tmp < dat2[k]){
+ (*w)+= .5*weight[k];
+ pars[k] += .5;
+ }
+ }
+
+ }
+}
+
+
+// return lower and upper bound for the number of changes
+// upper bound very conservative
+void countMPR(double *res, int *dat1, int *dat2, int *nr, double *weight, int *external){
+ int k;
+ int tmp;
+ for(k = 0; k < (*nr); k++){
+ tmp = dat1[k] & dat2[k];
+
+ if(tmp==0){
+ res[0] += weight[k];
+ res[1] += weight[k];
+ }
+ else{
+ if( external[0]==0L){
+ if( bitcount(dat1[k] | dat2[k])>1L ) res[1] += weight[k]; // dat1[k] != dat2[k]
+ }
+ else{
+ if( tmp < dat2[k] ) res[1] += weight[k];
+ }
+ }
+ }
+}
+
+
+void ACCTRAN2(int *dat, int *nr, double *pars, int *node, int *edge, int *nl, double *weight, double *pvec, int *nTips)
+{
+ int i;
+ for (i=0; i< *nl; i++) {
+ if(edge[i]>nTips[0]) fitchT(&dat[(edge[i]-1L) * (*nr)], &dat[(node[i]-1) * (*nr)], nr, pars, weight, &pvec[i]);
+ }
+}
+
+
+void ACCTRAN3(int *dat, int *nr, double *pars, int *node, int *edge, int *nl, double *weight, double *pvec, int *nTips)
+{
+ int i;
+ for (i=0; i< *nr; i++)pars[i]=0.0;
+ for(i=0; i< *nl; i++)pvec[i] = 0.0;
+ for (i=0; i< *nl; i++) {
+ fitchT3(&dat[(edge[i]-1L) * (*nr)], &dat[(node[i]-1) * (*nr)], nr, pars, weight, &pvec[i]);
+ }
+}
+
+
+void fitchNNN(int d1, int d2){
+ int tmp;
+ tmp = d1 & d2;
+ if(tmp) d1 = tmp;
+ else d1 = d1 | d2;
+}
+
+// haeufig 0
+void fitchTripletNew(int *res, int *dat1, int *dat2, int *dat3, int *nr)
+{
+ int k, v1, v2, v3;
+
+ for(k = 0; k < (*nr); k++){
+ v1 = dat1[k];
+ fitchNNN(v1, dat2[k]);
+ fitchNNN(v1, dat3[k]);
+
+ v2 = dat1[k];
+ fitchNNN(v2, dat3[k]);
+ fitchNNN(v2, dat2[k]);
+
+ v3 = dat2[k];
+ fitchNNN(v3, dat3[k]);
+ fitchNNN(v3, dat1[k]);
+
+ res[k] = v1 & v2; // &v3[k];
+ res[k] = res[k] & v3;
+ }
+}
+
+void fitchN(int *dat1, int *dat2, int *nr){
+ int k;
+ int tmp;
+ for(k = 0; k < (*nr); k++){
+ tmp = dat1[k] & dat2[k];
+ if(tmp) dat1[k] = tmp;
+ else dat1[k] = dat1[k] | dat2[k];
+ }
+}
+
+// raus
+void fitchN2(int *res, int *dat, int *node, int *edge, int *nr, int *nl) {
+ int i;
+ for (i=0; i< *nl; i++) {
+ fitchN(&res[(node[i]-1L) * (*nr)], &dat[(edge[i]-1L) * (*nr)], nr);
+ }
+}
+
+// MPR reconstruction nicht immer gleiches ergebnis
+void fitchTriplet(int *res, int *dat1, int *dat2, int *dat3, int *nr)
+{
+ int k; // ni,
+// ni = 0;
+
+ int *v1, *v2, *v3;
+ v1 = (int *) R_alloc(*nr, sizeof(int));
+ v2 = (int *) R_alloc(*nr, sizeof(int));
+ v3 = (int *) R_alloc(*nr, sizeof(int));
+
+ for(k = 0; k < (*nr); k++) v1[k] = dat1[k];
+ fitchN(v1, dat2, nr);
+ fitchN(v1, dat3, nr);
+
+ for(k = 0; k < (*nr); k++) v2[k] = dat1[k];
+ fitchN(v2, dat3, nr);
+ fitchN(v2, dat2, nr);
+
+ for(k = 0; k < (*nr); k++) v3[k] = dat2[k];
+ fitchN(v3, dat3, nr);
+ fitchN(v3, dat1, nr);
+
+ for(k = 0; k < (*nr); k++)res[k] = v1[k] & v2[k]; // &v3[k];
+ for(k = 0; k < (*nr); k++)res[k] = res[k] & v3[k];
+}
+
+
+void prepRooted(int *res, int *nr, int *kids){ //int *data1,
+ fitchTriplet(res, &data1[*nr * (kids[0]-1L)], &data1[*nr * (kids[1]-1L)],
+ &data1[*nr * (kids[2]-1L)], nr);
+}
+
+
+void C_MPR(int *res, int *nr, int *parent, int *kids, int *nl) {
+ int p, k1, k2;
+ int i = *nl -1;
+ while (i > 0L) {
+ p = parent[i] - 1L;
+ k1 = kids[i] - 1L;
+ k2 = kids[i-1L] - 1L;
+ fitchTriplet(&res[*nr * p], &data1[*nr* (k1)], &data1[*nr* (k2) ], &data2[*nr * p], nr);
+ i -= 2L;
+ }
+}
+
+
+SEXP C_MPR2(SEXP nrx, SEXP PARENT, SEXP KIDS, SEXP nlx, SEXP M) {
+ int nr=INTEGER(nrx)[0], nl=INTEGER(nlx)[0], m=INTEGER(M)[0], *res;
+ int *parent = INTEGER(PARENT), *kids=INTEGER(KIDS);
+ int j, p, k1, k2;
+ int i = nl -1;
+ SEXP RES;
+ PROTECT(RES = allocVector(INTSXP, nr * m));
+ res = INTEGER(RES);
+ for(j = 0; j < (nr * m); j++) res[j]=0;
+ while (i > 0L) {
+ p = parent[i] - 1L;
+ k1 = kids[i] - 1L;
+ k2 = kids[i-1L] - 1L;
+ fitchTripletNew(&res[nr * p], &data1[nr * k1], &data1[nr * k2], &data2[nr * p], &nr);
+ i -= 2L;
+ }
+ UNPROTECT(1);
+ return(RES);
+}
+
+
+
+void fitchNACC2(int *root, int *dat, int *nr, double *pars, int *result, double *weight, double *pars1){
+ int k;
+ int tmp;
+ for(k = 0; k < (*nr); k++){
+// result[k] = 0L;
+ tmp = root[k] & dat[k];
+ if(tmp==0L) {
+ pars[0] += weight[k];
+ pars1[k] += weight[k];
+ }
+ if(tmp >0){
+ if(tmp < root[k]){
+ pars[0] += .5*weight[k];
+ pars1[k] += .5*weight[k];
+ result[k] += 1L;
+ }
+ }
+ }
+}
+
+
+void fitchTripletACC4(int *root, int *dat1, int *dat2, int *dat3, int *nr, double *p1, double *p2, double *p3, double *weight, double *pars1, int *v1)
+{
+ int k;
+
+ int tmp, a, b, c, t1, t2, t3;
+ double d, f;
+ for(k = 0; k < (*nr); k++){
+ tmp = root[k];
+ a = dat1[k] & dat2[k];
+ b = dat1[k] & dat3[k];
+ c = dat2[k] & dat3[k];
+ if((a+b+c) == 0L){
+ d = (2.0/3.0) * weight[k];
+ p1[0] += d;
+ p2[0] += d;
+ p3[0] += d;
+ pars1[k] += 2*weight[k];
+ v1[k] = 2L;
+ }
+ else{
+ f = 0.0;
+ d = weight[k];
+ t1 = 0.0;
+ t2 = 0.0;
+ t3 = 0.0;
+ if( (dat1[k] & tmp)<tmp){
+ t1 = d;
+ f+=1.0;
+ }
+ if( (dat2[k] & tmp)<tmp){
+ t2 = d;
+ f+=1.0;
+ }
+ if( (dat3[k] & tmp)<tmp){
+ t3 = d;
+ f+=1.0;
+ }
+ if(f>0.0){
+ pars1[k] += weight[k];
+ p1[0] += t1/f;
+ p2[0] += t2/f;
+ p3[0] += t3/f;
+ v1[k] += 1L;
+ }
+ }
+ }
+}
+
+
+
+SEXP FITCH345(SEXP nrx, SEXP node, SEXP edge, SEXP l, SEXP mx, SEXP ps){
+ int *nr=INTEGER(nrx), m=INTEGER(mx)[0], i;
+ double *pvtmp;
+ SEXP pars, pscore;
+ PROTECT(pars = allocVector(INTSXP, *nr));
+ PROTECT(pscore = allocVector(REALSXP, 1L));
+ pvtmp = (double *) R_alloc(m, sizeof(double));
+ for(i=0; i<m; i++) pvtmp[i] = 0.0;
+ for(i=0; i<*nr; i++) INTEGER(pars)[i] = 0L;
+ REAL(pscore)[0]=0.0;
+ fitch8(data1, nr, INTEGER(pars), INTEGER(node), INTEGER(edge), INTEGER(l), weight, pvtmp, REAL(pscore));
+
+ UNPROTECT(2);
+ if(INTEGER(ps)[0]==1)return(pscore);
+ else return(pars);
+}
+
+
+void FN4(int *dat, int *res, int *nr, int *node, int *edge, int *nl, int *pc, double *weight, double *tmpvec, double *pvec) {
+ int i=0L, ni, le, ri;
+ while(i< *nl) {
+ ni = node[i] - 1L;
+ le = edge[i] - 1L;
+ ri = edge[i+1L] - 1L;
+ if(pc[i+1L]==0L){
+ pvec[ni] = tmpvec[le] + tmpvec[ri];
+ fitch54(&res[ni * (*nr)], &dat[(edge[i]-1L) * (*nr)], &dat[ri * (*nr)], nr, weight, &pvec[ni]);
+ }
+ else{
+ pvec[ni] = tmpvec[le] + pvec[ri];
+ fitch54(&res[ni * (*nr)], &dat[le * (*nr)], &res[ri * (*nr)], nr, weight, &pvec[ni]);
+ }
+ i++;
+ i++;
+ }
+}
+
+
+void sibs(int *node, int *n, int *start, int *end){
+ int tmp, k, i;
+ tmp=node[0];
+ k=node[0];
+ start[k]=0L;
+ for (i = 0L; i < *n; i++) {
+ tmp = node[i];
+ if(tmp!=k){
+ end[k] = i-1L;
+ start[tmp] = i;
+ k=tmp;
+ }
+ }
+ end[tmp] = i-1L;
+}
+
+
+void fnindex(int *nodes, int* edges, int *nNodes, int *start, int *end, int *root, int *res1, int *res2, int *pc){
+ int i, j, p, k, ni, nj, m;
+ k=0L;
+ for(i=0; i<*nNodes; i++){
+ m = *nNodes-(1L+i);
+ p = nodes[m];
+ ni = edges[m];
+ for(j=start[p]; j<=end[p]; j++){
+ nj = edges[j];
+ if(ni!=nj){
+ res1[k] = nj;
+ res2[k] = ni;
+ pc[k] = 0L;
+ k++;
+ }
+ }
+ if(p!=*root){
+ res1[k] = p;
+ res2[k] = ni;
+ pc[k] = 1L;
+ k++;
+ }
+ }
+}
+
+
+void fnhelp(int *node, int * edge, int *n, int *m, int *root, int *edge2, int *node2, int *pc){
+ int *startv, *endv, i;
+ startv = (int *) R_alloc(*m, sizeof(int));
+ endv = (int *) R_alloc(*m, sizeof(int));
+ for(i=0; i<*m; i++){
+ startv[i] = 0L;
+ endv[i] = 0L;
+ }
+ sibs(node, n, startv, endv);
+ fnindex(node, edge, n, startv, endv, root, edge2, node2, pc);
+}
+
+
+SEXP FNALL_NNI(SEXP nrx, SEXP node, SEXP edge, SEXP l, SEXP mx, SEXP my, SEXP root){
+ int *nr=INTEGER(nrx), m=INTEGER(mx)[0], i, *n=INTEGER(l); //*pars,
+ double *pvtmp, *pvtmp2, pscore=0.0;
+ SEXP pvec1, pvec2, res;
+ int *pc, *edge2, *node2;
+/* edge2, node2, pc ausserhalb definieren? */
+ edge2 = (int *) R_alloc(2L * *n, sizeof(int));
+ node2 = (int *) R_alloc(2L * *n, sizeof(int));
+ pc = (int *) R_alloc(2L * *n, sizeof(int));
+
+// pvtmp2 = (double *) R_alloc(m, sizeof(double));
+ PROTECT(res = allocVector(VECSXP, 2L));
+ PROTECT(pvec1 = allocVector(REALSXP, m));
+ PROTECT(pvec2 = allocVector(REALSXP, m));
+
+ pvtmp2 = REAL(pvec2);
+ pvtmp = REAL(pvec1);
+ for(i=0; i<m; i++){
+ pvtmp[i] = 0.0;
+ pvtmp2[i] = 0.0;
+ }
+ fnhelp(INTEGER(node), INTEGER(edge), n, &m, INTEGER(root), edge2, node2, pc);
+ fitch9(data1, nr, INTEGER(node), INTEGER(edge), INTEGER(l), weight, pvtmp, &pscore);
+ FN4(data1, data2, nr, node2, edge2, INTEGER(my), pc, weight, pvtmp, pvtmp2); // pars,
+// fitchQuartet(int *index, int *n, nr, double *psc1, double *psc2, weight, double *res);
+ SET_VECTOR_ELT(res, 0, pvec1);
+ SET_VECTOR_ELT(res, 1, pvec2);
+ UNPROTECT(3);
+ return(res);
+}
+
+// mpr2 fnodesNew5
+SEXP FNALL5(SEXP nrx, SEXP node, SEXP edge, SEXP l, SEXP mx, SEXP my, SEXP root){
+ int *nr=INTEGER(nrx), m=INTEGER(mx)[0], i, *n=INTEGER(l); //*pars,
+ double *pvtmp, *pvtmp2, pscore=0.0;
+ SEXP pvec;
+ // fnhelp
+ int *pc, *edge2, *node2;
+/* edge2, node2, pc ausserhalb definieren? */
+ edge2 = (int *) R_alloc(2L * *n, sizeof(int));
+ node2 = (int *) R_alloc(2L * *n, sizeof(int));
+ pc = (int *) R_alloc(2L * *n, sizeof(int));
+
+// pars = (int *) R_alloc(*nr, sizeof(int)); // raus
+ pvtmp2 = (double *) R_alloc(m, sizeof(double));
+
+ PROTECT(pvec = allocVector(REALSXP, m));
+
+ pvtmp = REAL(pvec);
+ for(i=0; i<m; i++){
+ pvtmp[i] = 0.0;
+ pvtmp2[i] = 0.0;
+ }
+ fnhelp(INTEGER(node), INTEGER(edge), n, &m, INTEGER(root), edge2, node2, pc);
+// fitch8(data1, nr, pars, INTEGER(node), INTEGER(edge), INTEGER(l), weight, pvtmp, &pscore);
+ fitch9(data1, nr, INTEGER(node), INTEGER(edge), INTEGER(l), weight, pvtmp, &pscore);
+// FN3(data1, data2, nr, pars, node2, edge2, INTEGER(my), pc, weight, pvtmp, pvtmp2);
+ FN4(data1, data2, nr, node2, edge2, INTEGER(my), pc, weight, pvtmp, pvtmp2); // pars,
+ for(i=0; i<m; i++) pvtmp[i] += pvtmp2[i];
+// return(pvtmp[edge])??
+ UNPROTECT(1);
+ return(pvec);
+}
+
+// inside optNNI Ziel 3* schneller , double best
+void fitchquartet(int *dat1, int *dat2, int *dat3, int *dat4, int *nr, double *weight, double *pars){
+ int k, tmp1, tmp2;
+ pars[0] = 0.0;
+ for(k = 0; k < *nr; k++){
+ tmp1 = dat1[k] & dat2[k];
+ tmp2 = dat3[k] & dat4[k];
+ if(!tmp1){
+ tmp1 = dat1[k] | dat2[k];
+ pars[0]+=weight[k];
+ }
+ if(!tmp2){
+ tmp2 = dat3[k] | dat4[k];
+ pars[0]+=weight[k];
+ }
+ tmp1 = tmp1 & tmp2;
+ if(!tmp1){
+ pars[0]+=weight[k];
+ }
+ }
+}
+
+// weight raus double *weight,
+void fitchQuartet(int *index, int *n, int *nr, double *psc1, double *psc2, double *weight, double *res){
+ int i, e1, e2, e3, e4;
+ for(i=0; i<*n; i++){
+ e1=index[(i* 6L)] - 1L;
+ e2=index[1L + (i* 6L)] - 1L;
+ e3=index[2L + (i* 6L)] - 1L;
+ e4=index[3L + (i* 6L)] - 1L;
+
+ if(index[5L + (i* 6L)] == 1){
+ fitchquartet(&data2[e1 * (*nr)], &data1[e2 * (*nr)], &data1[e3 * (*nr)], &data1[e4 * (*nr)], nr, weight, &res[i]);
+ res[i] += psc2[e1] + psc1[e2] + psc1[e3] + psc1[e4]; // stimmt
+ }
+ else{
+ fitchquartet(&data1[e1 * (*nr)], &data1[e2 * (*nr)], &data1[e3 * (*nr)], &data1[e4 * (*nr)], nr, weight, &res[i]);
+ res[i] += psc1[e1] + psc1[e2] + psc1[e3] + psc1[e4];
+ }
+ }
+}
+
+
+
diff --git a/src/ml.c b/src/ml.c
new file mode 100644
index 0000000..5e094b8
--- /dev/null
+++ b/src/ml.c
@@ -0,0 +1,1134 @@
+/*
+ * ml.c
+ *
+ * (c) 2008-2015 Klaus Schliep (klaus.schliep at gmail.com)
+ *
+ *
+ * This code may be distributed under the GNU GPL
+ *
+ */
+
+# define USE_RINTERNALS
+
+#include <Rmath.h>
+#include <math.h>
+#include <R.h>
+#include <R_ext/Lapack.h>
+#include <Rinternals.h>
+
+
+#define LINDEX(i, k) (i - ntips - 1L) * (nr * nc) + k * ntips * (nr * nc)
+// index for LL
+#define LINDEX2(i, k) (i - *ntips - 1L) * (*nr* *nc) + k * *ntips * (*nr * *nc)
+// index for scaling matrix SCM
+#define LINDEX3(i, j) (i - *ntips - 1L) * *nr + j * *ntips * *nr
+
+char *transa = "N", *transb = "N";
+double one = 1.0, zero = 0.0;
+int ONE = 1L;
+const double ScaleEPS = 1.0/4294967296.0;
+const double ScaleMAX = 4294967296.0;
+
+// 2^64 = 18446744073709551616
+
+static double *LL, *ROOT;
+static int *SCM, *XXX;
+
+
+void ll_free(){
+ free(LL);
+ free(SCM);
+ free(ROOT);
+// free(XX);
+}
+
+
+/*
+LL likelihood for internal edges
+SCM scaling coefficients
+nNodes, nTips, kmax
+*/
+void ll_init(int *nr, int *nTips, int *nc, int *k)
+{
+ int i;
+ LL = (double *) calloc(*nr * *nc * *k * *nTips, sizeof(double));
+ ROOT = (double *) calloc(*nr * *nc * *k, sizeof(double));
+ SCM = (int *) calloc(*nr * *k * *nTips, sizeof(int)); // * 2L
+ for(i =0; i < (*nr * *k * *nTips); i++) SCM[i] = 0L;
+}
+
+
+// contrast und nr,nc,k
+void ll_free2(){
+ free(LL);
+ free(SCM);
+ free(ROOT);
+ free(XXX);
+}
+
+
+void ll_init2(int *data, int *weights, int *nr, int *nTips, int *nc, int *k)
+{
+ int i;
+ LL = (double *) calloc(*nr * *nc * *k * *nTips, sizeof(double));
+ ROOT = (double *) calloc(*nr * *nc * *k, sizeof(double));
+ XXX = (int *) calloc(*nr * *nTips, sizeof(int));
+ SCM = (int *) calloc(*nr * *k * *nTips, sizeof(int)); // * 2L
+ for(i =0; i < (*nr * *k * *nTips); i++) SCM[i] = 0L;
+ for(i =0; i < (*nr * *nTips); i++) XXX[i] = data[i];
+}
+
+
+
+void matm(int *x, double *contrast, int *nr, int *nc, int *nco, double *result){
+ int i, j;
+ for(i = 0; i < (*nr); i++){
+ for(j = 0; j < (*nc); j++) result[i + j*(*nr)] *= contrast[x[i] - 1L + j*(*nco)];
+ }
+}
+
+
+SEXP invSites(SEXP dlist, SEXP nr, SEXP nc, SEXP contrast, SEXP nco){
+ R_len_t n = length(dlist);
+ int nrx=INTEGER(nr)[0], ncx=INTEGER(nc)[0], i, j;
+ SEXP result;
+ PROTECT(result = allocMatrix(REALSXP, nrx, ncx));
+ double *res;
+ res = REAL(result);
+ for(j=0; j < (nrx * ncx); j++) res[j] = 1.0;
+ for(i=0; i < n; i++) matm(INTEGER(VECTOR_ELT(dlist, i)), REAL(contrast), INTEGER(nr), INTEGER(nc), INTEGER(nco), res);
+ UNPROTECT(1); // result
+ return(result);
+}
+
+
+void scaleMatrix(double *X, int *nr, int *nc, int *result){
+ int i, j;
+ double tmp;
+ for(i = 0; i < *nr; i++) {
+ tmp = 0.0;
+ for(j = 0; j < *nc; j++) tmp += X[i + j* *nr];
+ while(tmp < ScaleEPS){
+ for(j = 0; j < *nc; j++) X[i + j* *nr] *=ScaleMAX;
+ result[i] +=1L;
+ tmp *= ScaleMAX;
+ }
+ }
+}
+
+
+// contrast to full
+void matp(int *x, double *contrast, double *P, int *nr, int *nc, int *nrs, double *result){
+ int i, j;
+ double *tmp;
+ tmp = (double *) R_alloc((*nc) *(*nrs), sizeof(double));
+// matprod(contrast, (*nrs), (*nc), P, (*nc), (*nc), tmp);
+ F77_CALL(dgemm)(transa, transb, nrs, nc, nc, &one, contrast, nrs, P, nc, &zero, tmp, nrs);
+ for(i = 0; i < (*nr); i++){
+ for(j = 0; j < (*nc); j++) result[i + j*(*nr)] = tmp[x[i] - 1L + j*(*nrs)];
+ }
+}
+
+static R_INLINE void getP(double *eva, double *ev, double *evi, int m, double el, double w, double *result){
+ int i, j, h;
+ double tmp[m], res;
+ for(i = 0; i < m; i++) tmp[i] = exp(eva[i] * w * el);
+ for(i = 0; i < m; i++){
+ for(j = 0; j < m; j++){
+ res = 0.0;
+ for(h = 0; h < m; h++) res += ev[i + h*m] * tmp[h] * evi[h + j*m];
+ result[i+j*m] = res;
+ }
+ }
+}
+
+
+
+SEXP getPM(SEXP eig, SEXP nc, SEXP el, SEXP w){
+ R_len_t i, j, nel, nw, k;
+ int m=INTEGER(nc)[0], l=0;
+ double *ws=REAL(w);
+ double *edgelen=REAL(el);
+ double *eva, *eve, *evei;
+ SEXP P, RESULT;
+ nel = length(el);
+ nw = length(w);
+ if(!isNewList(eig)) error("'eig' must be a list");
+ eva = REAL(VECTOR_ELT(eig, 0));
+ eve = REAL(VECTOR_ELT(eig, 1));
+ evei = REAL(VECTOR_ELT(eig, 2));
+ PROTECT(RESULT = allocVector(VECSXP, nel*nw));
+ for(j=0; j<nel; j++){
+ for(i=0; i<nw; i++){
+ PROTECT(P = allocMatrix(REALSXP, m, m));
+ if(edgelen[j]==0.0 || ws[i]==0.0){
+ for(k=0; k<(m*m);k++)REAL(P)[k]=0.0;
+ for(k=0; k<m; k++)REAL(P)[k+k*m]=1.0;
+ }
+ else getP(eva, eve, evei, m, edgelen[j], ws[i], REAL(P));
+ SET_VECTOR_ELT(RESULT, l, P);
+ UNPROTECT(1);
+ l++;
+ }
+ }
+ UNPROTECT(1);//RESULT
+ return(RESULT);
+}
+
+
+void lll(SEXP dlist, double *eva, double *eve, double *evei, double *el, double g, int *nr, int *nc, int *node, int *edge, int nTips, double *contrast, int nco, int n, int *scaleTmp, double *bf, double *TMP, double *ans){
+ int ni, ei, j, i, rc; // R_len_t i, n = length(node);
+ double *rtmp, *P;
+
+ ni = -1;
+ rc = *nr * *nc;
+ rtmp = (double *) R_alloc(*nr * *nc, sizeof(double));
+ P = (double *) R_alloc(*nc * *nc, sizeof(double));
+
+ for(j=0; j < *nr; j++) scaleTmp[j] = 0L;
+ for(i = 0; i < n; i++) {
+ getP(eva, eve, evei, *nc, el[i], g, P);
+ ei = edge[i];
+ if(ni != node[i]){
+ if(ni>0)scaleMatrix(&ans[ni * rc], nr, nc, scaleTmp); // (ni-nTips)
+ ni = node[i];
+ if(ei < nTips)
+ matp(INTEGER(VECTOR_ELT(dlist, ei)), contrast, P, nr, nc, &nco, &ans[ni * rc]);
+ else
+ F77_CALL(dgemm)(transa, transb, nr, nc, nc, &one, &ans[(ei-nTips) * rc], nr, P, nc, &zero, &ans[ni * rc], nr);
+ }
+ else {
+ if(ei < nTips)
+ matp(INTEGER(VECTOR_ELT(dlist, ei)), contrast, P, nr, nc, &nco, rtmp);
+ else
+ F77_CALL(dgemm)(transa, transb, nr, nc, nc, &one, &ans[(ei-nTips) * rc], nr, P, nc, &zero, rtmp, nr);
+ for(j=0; j < rc; j++) ans[ni * rc + j] *= rtmp[j];
+ }
+ }
+ scaleMatrix(&ans[ni * rc], nr, nc, scaleTmp);
+ F77_CALL(dgemv)(transa, nr, nc, &one, &ans[ni * rc], nr, bf, &ONE, &zero, TMP, &ONE);
+}
+
+
+// neue Version: keine SEXP (dlist)
+// Ziel: openMP fuer Gamma (4 mal schneller)
+void lll0(int *X, double *eva, double *eve, double *evei, double *el, double g, int *nr, int *nc, int *node, int *edge, int nTips, double *contrast, int nco, int n, int *scaleTmp, double *bf, double *TMP, double *ans){
+ int ni, ei, j, i, rc; // R_len_t i, n = length(node);
+ double *rtmp, *P;
+
+ ni = -1;
+ rc = *nr * *nc;
+ rtmp = (double *) R_alloc(*nr * *nc, sizeof(double));
+ P = (double *) R_alloc(*nc * *nc, sizeof(double));
+
+ for(j=0; j < *nr; j++) scaleTmp[j] = 0L;
+ for(i = 0; i < n; i++) {
+ getP(eva, eve, evei, *nc, el[i], g, P);
+ ei = edge[i];
+ if(ni != node[i]){
+ if(ni>0)scaleMatrix(&ans[ni * rc], nr, nc, scaleTmp); // (ni-nTips)
+ ni = node[i];
+ if(ei < nTips)
+ matp(&X[ei * *nr], contrast, P, nr, nc, &nco, &ans[ni * rc]);
+ else
+ F77_CALL(dgemm)(transa, transb, nr, nc, nc, &one, &ans[(ei-nTips) * rc], nr, P, nc, &zero, &ans[ni * rc], nr);
+ }
+ else {
+ if(ei < nTips)
+ matp(&X[ei * *nr], contrast, P, nr, nc, &nco, rtmp);
+ else
+ F77_CALL(dgemm)(transa, transb, nr, nc, nc, &one, &ans[(ei-nTips) * rc], nr, P, nc, &zero, rtmp, nr);
+ for(j=0; j < rc; j++) ans[ni * rc + j] *= rtmp[j];
+ }
+ }
+ scaleMatrix(&ans[ni * rc], nr, nc, scaleTmp);
+ F77_CALL(dgemv)(transa, nr, nc, &one, &ans[ni * rc], nr, bf, &ONE, &zero, TMP, &ONE);
+}
+
+
+
+// this seems to work perfectly
+void lll3(SEXP dlist, double *eva, double *eve, double *evei, double *el, double g, int *nr, int *nc, int *node, int *edge,
+ int nTips, double *contrast, int nco, int n, int *scaleTmp, double *bf, double *TMP, double *ans, int *SC){
+ int ni, ei, j, i, rc; // R_len_t i, n = length(node);
+ double *rtmp, *P;
+ ni = -1L;
+ rc = *nr * *nc;
+ rtmp = (double *) R_alloc(*nr * *nc, sizeof(double));
+ P = (double *) R_alloc(*nc * *nc, sizeof(double));
+
+ for(j=0; j < *nr; j++) scaleTmp[j] = 0L;
+
+ for(i = 0; i < n; i++) {
+ getP(eva, eve, evei, *nc, el[i], g, P);
+ ei = edge[i];
+ if(ni != node[i]){
+ if(ni>0)scaleMatrix(&ans[ni * rc], nr, nc, &SC[ni * *nr]); // (ni-nTips)
+ ni = node[i];
+ for(j=0; j < *nr; j++) SC[j + ni * *nr] = 0L;
+ if(ei < nTips)
+ matp(INTEGER(VECTOR_ELT(dlist, ei)), contrast, P, nr, nc, &nco, &ans[ni * rc]);
+ else{
+ F77_CALL(dgemm)(transa, transb, nr, nc, nc, &one, &ans[(ei-nTips) * rc], nr, P, nc, &zero, &ans[ni * rc], nr);
+ for(j=0; j < *nr; j++) SC[ni * *nr + j] = SC[(ei-nTips) * *nr + j];
+ }
+ }
+ else {
+ if(ei < nTips)
+ matp(INTEGER(VECTOR_ELT(dlist, ei)), contrast, P, nr, nc, &nco, rtmp);
+ else{
+ F77_CALL(dgemm)(transa, transb, nr, nc, nc, &one, &ans[(ei-nTips) * rc], nr, P, nc, &zero, rtmp, nr);
+ for(j=0; j < *nr; j++) SC[ni * *nr + j] += SC[(ei-nTips) * *nr + j];
+ }
+ for(j=0; j < rc; j++) ans[ni * rc + j] *= rtmp[j];
+ }
+ }
+ scaleMatrix(&ans[ni * rc], nr, nc, &SC[ni * *nr]);
+ for(j=0; j < *nr; j++) scaleTmp[j] = SC[ni * *nr + j];
+
+ F77_CALL(dgemv)(transa, nr, nc, &one, &ans[ni * rc], nr, bf, &ONE, &zero, TMP, &ONE);
+}
+
+// ohne openMP
+SEXP PML_NEW2(SEXP EL, SEXP W, SEXP G, SEXP NR, SEXP NC, SEXP K, SEXP eig, SEXP bf, SEXP node, SEXP edge, SEXP NTips, SEXP root, SEXP nco, SEXP contrast, SEXP N){
+ int nr=INTEGER(NR)[0], nc=INTEGER(NC)[0], k=INTEGER(K)[0], i, indLL;
+ int nTips = INTEGER(NTips)[0], *SC;
+// int *nodes=INTEGER(node),
+ double *g=REAL(G), *tmp, logScaleEPS;
+ SEXP TMP;
+
+ double *eva, *eve, *evei;
+
+ eva = REAL(VECTOR_ELT(eig, 0));
+ eve = REAL(VECTOR_ELT(eig, 1));
+ evei = REAL(VECTOR_ELT(eig, 2));
+
+ SC = (int *) R_alloc(nr * k, sizeof(int));
+
+ PROTECT(TMP = allocMatrix(REALSXP, nr, k)); // changed
+ tmp=REAL(TMP);
+ for(i=0; i<(k*nr); i++)tmp[i]=0.0;
+ indLL = nr * nc * nTips;
+ for(i=0; i<k; i++){
+ lll0(XXX, eva, eve, evei, REAL(EL), g[i], &nr, &nc, INTEGER(node), INTEGER(edge), nTips, REAL(contrast), INTEGER(nco)[0], INTEGER(N)[0], &SC[nr * i], REAL(bf), &tmp[i*nr], &LL[indLL *i]);
+ }
+
+ logScaleEPS = log(ScaleEPS);
+ for(i=0; i<(k*nr); i++) tmp[i] = logScaleEPS * SC[i] + log(tmp[i]); //log
+
+ UNPROTECT(1);
+ return TMP;
+}
+
+// mit openMP
+SEXP PML_NEW(SEXP EL, SEXP W, SEXP G, SEXP NR, SEXP NC, SEXP K, SEXP eig, SEXP bf, SEXP node, SEXP edge, SEXP NTips, SEXP root, SEXP nco, SEXP contrast, SEXP N){
+ int nr=INTEGER(NR)[0], nc=INTEGER(NC)[0], k=INTEGER(K)[0], i, indLL, n=INTEGER(N)[0], ncontr=INTEGER(nco)[0];
+ int nTips = INTEGER(NTips)[0], *SC;
+ int *nodes=INTEGER(node), *edges=INTEGER(edge);
+ double *el=REAL(EL), *bfreq=REAL(bf), *contr=REAL(contrast);
+ double *g=REAL(G), *tmp, logScaleEPS;
+ SEXP TMP;
+
+ double *eva, *eve, *evei;
+
+ eva = REAL(VECTOR_ELT(eig, 0));
+ eve = REAL(VECTOR_ELT(eig, 1));
+ evei = REAL(VECTOR_ELT(eig, 2));
+
+ SC = (int *) R_alloc(nr * k, sizeof(int));
+
+ PROTECT(TMP = allocMatrix(REALSXP, nr, k)); // changed
+ tmp=REAL(TMP);
+ for(i=0; i<(k*nr); i++)tmp[i]=0.0;
+ indLL = nr * nc * nTips;
+/*
+#ifdef _OPENMP
+if(*nthreads <= 1){ *nthreads=1; }else{ *nthreads=(*nthreads < omp_get_max_threads()) ? (*nthreads) : (omp_get_max_threads()); }
+#endif
+
+#ifdef SUPPORT_OPENMP
+#pragma omp parallel for private(i)
+#endif
+*/
+ for(i=0; i<k; i++){
+ lll0(XXX, eva, eve, evei, el, g[i], &nr, &nc, nodes, edges, nTips, contr, ncontr, n, &SC[nr * i], bfreq, &tmp[i*nr], &LL[indLL *i]);
+ }
+
+ logScaleEPS = log(ScaleEPS);
+ for(i=0; i<(k*nr); i++) tmp[i] = logScaleEPS * SC[i] + log(tmp[i]); //log
+
+ UNPROTECT(1);
+ return TMP;
+}
+
+
+SEXP PML3(SEXP dlist, SEXP EL, SEXP W, SEXP G, SEXP NR, SEXP NC, SEXP K, SEXP eig, SEXP bf, SEXP node, SEXP edge, SEXP NTips, SEXP root, SEXP nco, SEXP contrast, SEXP N){
+ int nr=INTEGER(NR)[0], nc=INTEGER(NC)[0], k=INTEGER(K)[0], i, indLL;
+ int nTips = INTEGER(NTips)[0], *SC;
+ double *g=REAL(G), *tmp, logScaleEPS;
+ SEXP TMP;
+ double *eva, *eve, *evei;
+
+ eva = REAL(VECTOR_ELT(eig, 0));
+ eve = REAL(VECTOR_ELT(eig, 1));
+ evei = REAL(VECTOR_ELT(eig, 2));
+
+ SC = (int *) R_alloc(nr * k, sizeof(int));
+
+ PROTECT(TMP = allocMatrix(REALSXP, nr, k)); // changed
+ tmp=REAL(TMP);
+ for(i=0; i<(k*nr); i++)tmp[i]=0.0;
+ indLL = nr * nc * nTips;
+ for(i=0; i<k; i++){
+ lll3(dlist, eva, eve, evei, REAL(EL), g[i], &nr, &nc, INTEGER(node), INTEGER(edge), nTips, REAL(contrast), INTEGER(nco)[0], INTEGER(N)[0], &SC[nr * i], REAL(bf), &tmp[i*nr], &LL[indLL *i], &SCM[nr * nTips * i]);
+ }
+ logScaleEPS = log(ScaleEPS);
+ for(i=0; i<(k*nr); i++) tmp[i] = logScaleEPS * SC[i] + log(tmp[i]);
+ UNPROTECT(1);
+ return TMP;
+}
+
+
+SEXP PML0(SEXP dlist, SEXP EL, SEXP W, SEXP G, SEXP NR, SEXP NC, SEXP K, SEXP eig, SEXP bf, SEXP node, SEXP edge, SEXP NTips, SEXP root, SEXP nco, SEXP contrast, SEXP N){
+ int nr=INTEGER(NR)[0], nc=INTEGER(NC)[0], k=INTEGER(K)[0], i, indLL;
+ int nTips = INTEGER(NTips)[0], *SC;
+ double *g=REAL(G), *tmp, logScaleEPS;
+ SEXP TMP;
+ double *eva, *eve, *evei;
+
+ eva = REAL(VECTOR_ELT(eig, 0));
+ eve = REAL(VECTOR_ELT(eig, 1));
+ evei = REAL(VECTOR_ELT(eig, 2));
+
+ SC = (int *) R_alloc(nr * k, sizeof(int));
+
+ PROTECT(TMP = allocMatrix(REALSXP, nr, k)); // changed
+ tmp=REAL(TMP);
+ for(i=0; i<(k*nr); i++)tmp[i]=0.0;
+ indLL = nr * nc * nTips;
+ for(i=0; i<k; i++){
+ lll(dlist, eva, eve, evei, REAL(EL), g[i], &nr, &nc, INTEGER(node), INTEGER(edge), nTips, REAL(contrast), INTEGER(nco)[0], INTEGER(N)[0], &SC[nr * i], REAL(bf), &tmp[i*nr], &LL[indLL *i]);
+ }
+
+ logScaleEPS = log(ScaleEPS);
+ for(i=0; i<(k*nr); i++) tmp[i] = logScaleEPS * SC[i] + log(tmp[i]);
+
+ UNPROTECT(1);
+ return TMP;
+}
+
+
+// replace child with LL
+void moveLLNew(double *LL, double *child, double *P, int *nr, int *nc, double *tmp, int *LLSC, int *CSC){
+ int j, a;
+ F77_CALL(dgemm)(transa, transb, nr, nc, nc, &one, child, nr, P, nc, &zero, tmp, nr);
+ for(j=0; j<(*nc * *nr); j++) LL[j]/=tmp[j]; // new child
+ F77_CALL(dgemm)(transa, transb, nr, nc, nc, &one, LL, nr, P, nc, &zero, tmp, nr);
+ for(j=0; j<(*nc * *nr); j++) child[j] *= tmp[j];
+ for(j=0; j<*nr; j++){
+ a = LLSC[j];
+ LLSC[j] -= CSC[j];
+ CSC[j] = a;
+ }
+}
+
+
+void moveLL0(double *LL, double *child, double *P, int *nr, int *nc, double *tmp){
+ int j;
+ F77_CALL(dgemm)(transa, transb, nr, nc, nc, &one, child, nr, P, nc, &zero, tmp, nr);
+ for(j=0; j<(*nc * *nr); j++) LL[j]/=tmp[j]; // new child
+ F77_CALL(dgemm)(transa, transb, nr, nc, nc, &one, LL, nr, P, nc, &zero, tmp, nr);
+ for(j=0; j<(*nc * *nr); j++) child[j] *= tmp[j];
+}
+
+
+void moveLL2(int *loli, int *nloli, double *eva, double *eve, double *evi, double *el, double *g, int *nr, int *nc, int *k, int *ntips){
+ double *tmp, *P;
+ int j;
+ tmp = (double *) R_alloc(*nr * *nc, sizeof(double));
+ P = (double *) R_alloc(*nc * *nc, sizeof(double));
+ for(j = 0; j < *k; j++){
+ getP(eva, eve, evi, *nc, el[0], g[j], P);
+ moveLLNew(&LL[LINDEX2(*loli, j)], &LL[LINDEX2(*nloli, j)], P, nr, nc, tmp,
+ &SCM[LINDEX3(*loli, j)], &SCM[LINDEX3(*nloli, j)]);
+ }
+}
+
+void moveLLtmp(double *LL, double *child, double *P, int *nr, int *nc, double *tmp){
+ int j;
+ F77_CALL(dgemm)(transa, transb, nr, nc, nc, &one, child, nr, P, nc, &zero, tmp, nr);
+ for(j=0; j<(*nc * *nr); j++) LL[j]/=tmp[j];
+ F77_CALL(dgemm)(transa, transb, nr, nc, nc, &one, LL, nr, P, nc, &zero, tmp, nr);
+ for(j=0; j<(*nc * *nr); j++) LL[j]=tmp[j] * child[j];
+}
+
+
+void moveLL5(double *LL, double *child, double *P, int *nr, int *nc, double *tmp){
+ int j;
+ F77_CALL(dgemm)(transa, transb, nr, nc, nc, &one, child, nr, P, nc, &zero, tmp, nr);
+ for(j=0; j<(*nc * *nr); j++) LL[j]/=tmp[j];
+ F77_CALL(dgemm)(transa, transb, nr, nc, nc, &one, LL, nr, P, nc, &zero, tmp, nr);
+ for(j=0; j<(*nc * *nr); j++) child[j] *= tmp[j];
+}
+
+
+SEXP moveloli(SEXP CH, SEXP PA, SEXP eig, SEXP EL, SEXP W, SEXP G,
+ SEXP NR, SEXP NC, SEXP NTIPS){
+ int i, k=length(W);
+ int nc=INTEGER(NC)[0], nr=INTEGER(NR)[0], ntips=INTEGER(NTIPS)[0]; //, blub
+ int pa=INTEGER(PA)[0], ch=INTEGER(CH)[0];
+ double *g=REAL(G); //*w=REAL(W),
+ double el=REAL(EL)[0];
+ double *eva, *eve, *evei, *tmp, *P;
+ tmp = (double *) R_alloc(nr * nc, sizeof(double));
+ P = (double *) R_alloc(nc * nc, sizeof(double));
+
+// SEXP X, RESULT;
+// PROTECT(RESULT = allocVector(VECSXP, k));
+
+ eva = REAL(VECTOR_ELT(eig, 0));
+ eve = REAL(VECTOR_ELT(eig, 1));
+ evei = REAL(VECTOR_ELT(eig, 2));
+
+ for(i = 0; i < k; i++){
+// PROTECT(X = allocMatrix(REALSXP, nr, nc));
+ getP(eva, eve, evei, nc, el, g[i], P);
+ moveLL5(&LL[LINDEX(ch, i)], &LL[LINDEX(pa, i)], P, &nr, &nc, tmp);
+// blub = LINDEX(ch, i);
+// for(j=0; j< (nr*nc); j++) REAL(X)[j] = LL[blub+j];
+// SET_VECTOR_ELT(RESULT, i, X);
+// UNPROTECT(1);
+ }
+// UNPROTECT(1); //RESULT
+// return(RESULT);
+ return ScalarReal(1L);
+}
+
+// dad / child * P
+void helpDADI(double *dad, double *child, double *P, int nr, int nc, double *res){
+ F77_CALL(dgemm)(transa, transb, &nr, &nc, &nc, &one, child, &nr, P, &nc, &zero, res, &nr);
+ for(int j=0; j<(nc * nr); j++) dad[j]/=res[j];
+}
+
+// braucht Addition skalierte Werte
+//
+void helpPrep(double *dad, double *child, double *eve, double *evi, int nr, int nc, double *tmp, double *res){
+ F77_CALL(dgemm)(transa, transb, &nr, &nc, &nc, &one, child, &nr, eve, &nc, &zero, res, &nr);
+ F77_CALL(dgemm)(transa, transb, &nr, &nc, &nc, &one, dad, &nr, evi, &nc, &zero, tmp, &nr);
+ for(int j=0; j<(nc * nr); j++) res[j]*=tmp[j];
+}
+
+
+void helpDAD2(double *dad, int *child, double *contrast, double *P, int nr, int nc, int nco, double *res){
+ matp(child, contrast, P, &nr, &nc, &nco, res);
+ for(int j=0; j<(nc * nr); j++) res[j]=dad[j]/res[j];
+}
+
+void helpDAD5(double *dad, int *child, double *contrast, double *P, int nr, int nc, int nco, double *res){
+ matp(child, contrast, P, &nr, &nc, &nco, res);
+ for(int j=0; j<(nc * nr); j++) dad[j]/=res[j];
+}
+
+
+SEXP getDAD2(SEXP dad, SEXP child, SEXP contrast, SEXP P, SEXP nr, SEXP nc, SEXP nco){
+ R_len_t i, n=length(P);
+ int ncx=INTEGER(nc)[0], nrx=INTEGER(nr)[0], nrs=INTEGER(nco)[0]; //, j
+ SEXP TMP, RESULT;
+ PROTECT(RESULT = allocVector(VECSXP, n));
+ for(i=0; i<n; i++){
+ PROTECT(TMP = allocMatrix(REALSXP, nrx, ncx));
+ helpDAD2(REAL(VECTOR_ELT(dad, i)), INTEGER(child), REAL(contrast), REAL(VECTOR_ELT(P, i)), nrx, ncx, nrs, REAL(TMP));
+ SET_VECTOR_ELT(RESULT, i, TMP);
+ UNPROTECT(1); // TMP
+ }
+ UNPROTECT(1); //RESULT
+ return(RESULT);
+ }
+
+
+
+void helpPrep2(double *dad, int *child, double *contrast, double *evi, int nr, int nc, int nrs, double *res){
+ int i, j;
+ F77_CALL(dgemm)(transa, transb, &nr, &nc, &nc, &one, dad, &nr, evi, &nc, &zero, res, &nr);
+ for(i = 0; i < nr; i++){
+ for(j = 0; j < nc; j++) res[i + j*nr] *= contrast[child[i] - 1L + j*nrs];
+ }
+}
+
+
+SEXP getPrep2(SEXP dad, SEXP child, SEXP contrast, SEXP evi, SEXP nr, SEXP nc, SEXP nco){
+ R_len_t i, n=length(dad);
+ int ncx=INTEGER(nc)[0], nrx=INTEGER(nr)[0], ncs=INTEGER(nco)[0];
+ SEXP TMP, RESULT;
+ PROTECT(RESULT = allocVector(VECSXP, n));
+ for(i=0; i<n; i++){
+ PROTECT(TMP = allocMatrix(REALSXP, nrx, ncx));
+ helpPrep2(REAL(VECTOR_ELT(dad, i)), INTEGER(child), REAL(contrast), REAL(evi), nrx, ncx, ncs, REAL(TMP));
+ SET_VECTOR_ELT(RESULT, i, TMP);
+ UNPROTECT(1);
+ }
+ UNPROTECT(1);
+ return(RESULT);
+}
+
+
+// works
+SEXP moveDad(SEXP dlist, SEXP PA, SEXP CH, SEXP eig, SEXP EVI, SEXP EL, SEXP W, SEXP G, SEXP NR,
+ SEXP NC, SEXP NTIPS, SEXP CONTRAST, SEXP CONTRAST2, SEXP NCO){
+ int i, k=length(W);
+ int nc=INTEGER(NC)[0], nr=INTEGER(NR)[0], ntips=INTEGER(NTIPS)[0];
+ int pa=INTEGER(PA)[0], ch=INTEGER(CH)[0], nco =INTEGER(NCO)[0];
+ double *g=REAL(G), *evi=REAL(EVI), *contrast=REAL(CONTRAST), *contrast2=REAL(CONTRAST2); //*w=REAL(W),
+ double el=REAL(EL)[0];
+ double *eva, *eve, *evei, *tmp, *P;
+ tmp = (double *) R_alloc(nr * nc, sizeof(double));
+ P = (double *) R_alloc(nc * nc, sizeof(double));
+
+ SEXP X, RESULT;
+ PROTECT(RESULT = allocVector(VECSXP, k));
+
+ eva = REAL(VECTOR_ELT(eig, 0));
+ eve = REAL(VECTOR_ELT(eig, 1));
+ evei = REAL(VECTOR_ELT(eig, 2));
+ if(ch>ntips){
+ for(i = 0; i < k; i++){
+ PROTECT(X = allocMatrix(REALSXP, nr, nc));
+ getP(eva, eve, evei, nc, el, g[i], P);
+ helpDADI(&LL[LINDEX(pa, i)], &LL[LINDEX(ch, i)], P, nr, nc, tmp);
+ helpPrep(&LL[LINDEX(pa, i)], &LL[LINDEX(ch, i)], eve, evi, nr, nc, tmp, REAL(X));
+ SET_VECTOR_ELT(RESULT, i, X);
+ UNPROTECT(1);
+ }
+ }
+ else{
+ for(i = 0; i < k; i++){
+ PROTECT(X = allocMatrix(REALSXP, nr, nc));
+ getP(eva, eve, evei, nc, el, g[i], P);
+// helpDAD2(double *dad, int *child, double *contrast, double *P, int nr, int nc, int nco, double *res)
+ helpDAD5(&LL[LINDEX(pa, i)], INTEGER(VECTOR_ELT(dlist, ch-1L)), contrast, P, nr, nc, nco, tmp);
+// void helpPrep2(double *dad, int *child, double *contrast, double *evi, int nr, int nc, int nrs, double *res)
+ helpPrep2(&LL[LINDEX(pa, i)], INTEGER(VECTOR_ELT(dlist, ch-1L)), contrast2, evi, nr, nc, nco, REAL(X)); //;
+ SET_VECTOR_ELT(RESULT, i, X);
+ UNPROTECT(1);
+ }
+ }
+ UNPROTECT(1); //RESULT
+ return(RESULT);
+}
+
+
+// child *= (dad * P)
+void goDown(double *dad, double *child, double *P, int nr, int nc, double *res){
+ F77_CALL(dgemm)(transa, transb, &nr, &nc, &nc, &one, dad, &nr, P, &nc, &zero, res, &nr);
+ for(int j=0; j<(nc * nr); j++) child[j]*=res[j];
+}
+
+// dad *= (child * P)
+void goUp(double *dad, int *child, double *contrast, double *P, int nr, int nc, int nco, double *res){
+ matp(child, contrast, P, &nr, &nc, &nco, res);
+ for(int j=0; j<(nc * nr); j++) dad[j]*=res[j];
+}
+
+
+SEXP updateLL(SEXP dlist, SEXP PA, SEXP CH, SEXP eig, SEXP EL, SEXP W, SEXP G, SEXP NR,
+ SEXP NC, SEXP NTIPS, SEXP CONTRAST, SEXP NCO){
+// SEXP RESULTS, X;
+ int i, k=length(W);
+ int nc=INTEGER(NC)[0], nr=INTEGER(NR)[0], ntips=INTEGER(NTIPS)[0]; //, j, blub
+ int pa=INTEGER(PA)[0], ch=INTEGER(CH)[0], nco =INTEGER(NCO)[0];
+ double *g=REAL(G), *contrast=REAL(CONTRAST); //*w=REAL(W),
+ double el=REAL(EL)[0];
+ double *eva, *eve, *evei, *tmp, *P;
+ tmp = (double *) R_alloc(nr * nc, sizeof(double));
+ P = (double *) R_alloc(nc * nc, sizeof(double));
+
+// PROTECT(RESULT = allocVector(VECSXP, k))
+
+ eva = REAL(VECTOR_ELT(eig, 0));
+ eve = REAL(VECTOR_ELT(eig, 1));
+ evei = REAL(VECTOR_ELT(eig, 2));
+ if(ch>ntips){
+ for(i = 0; i < k; i++){
+ getP(eva, eve, evei, nc, el, g[i], P);
+ goDown(&LL[LINDEX(pa, i)], &LL[LINDEX(ch, i)], P, nr, nc, tmp);
+ }
+ }
+ else{
+ for(i = 0; i < k; i++){
+ getP(eva, eve, evei, nc, el, g[i], P);
+ goUp(&LL[LINDEX(pa, i)], INTEGER(VECTOR_ELT(dlist, ch-1L)), contrast, P, nr, nc, nco, tmp);
+ }
+ }
+ return ScalarReal(1L);
+// return(NULL);
+}
+
+
+SEXP extractI(SEXP CH, SEXP W, SEXP G, SEXP NR, SEXP NC, SEXP NTIPS){
+ int i, k=length(W);
+ int nc=INTEGER(NC)[0], nr=INTEGER(NR)[0], ntips=INTEGER(NTIPS)[0], j, blub;
+ int ch=INTEGER(CH)[0];
+// double *w=REAL(W), *g=REAL(G);
+
+ SEXP X, RESULT;
+ PROTECT(RESULT = allocVector(VECSXP, k));
+
+ for(i = 0; i < k; i++){
+ PROTECT(X = allocMatrix(REALSXP, nr, nc));
+ blub = LINDEX(ch, i);
+ for(j=0; j< (nr*nc); j++) REAL(X)[j] = LL[blub+j];
+ SET_VECTOR_ELT(RESULT, i, X);
+ UNPROTECT(1);
+ }
+ UNPROTECT(1); //RESULT
+ return(RESULT);
+}
+
+
+SEXP extractScale(SEXP CH, SEXP W, SEXP G, SEXP NR, SEXP NC, SEXP NTIPS){
+ int i, k=length(W);
+ int *nr=INTEGER(NR), *ntips=INTEGER(NTIPS), j, blub;
+ int ch=INTEGER(CH)[0];
+ SEXP RESULT;
+ PROTECT(RESULT = allocMatrix(REALSXP, *nr, k));
+ for(i = 0; i < k; i++){
+ blub = LINDEX3(ch, i);
+ for(j=0; j< (*nr); j++) REAL(RESULT)[j +i * *nr] = SCM[blub+j];
+ }
+ UNPROTECT(1); //RESULT
+ return(RESULT);
+}
+
+
+// old version
+void moveLL(double *LL, double *child, double *P, int *nr, int *nc, double *tmp){
+ int j;
+ F77_CALL(dgemm)(transa, transb, nr, nc, nc, &one, child, nr, P, nc, &zero, tmp, nr);
+ for(j=0; j<(*nc * *nr); j++) LL[j]/=tmp[j];
+ F77_CALL(dgemm)(transa, transb, nr, nc, nc, &one, LL, nr, P, nc, &zero, tmp, nr);
+ for(j=0; j<(*nc * *nr); j++) tmp[j] *= child[j];
+}
+
+
+void helpDAD3(double *dad, double *child, double *P, int *nr, int *nc, double *res){
+ F77_CALL(dgemm)(transa, transb, nr, nc, nc, &one, child, nr, P, nc, &zero, res, nr);
+ for(int j=0; j<(*nc * *nr); j++) dad[j]/=res[j];
+}
+
+void getDAD3(int *dad, int *child, double *eva, double *eve, double *evi, double *el, double *g, int *nr, int *nc, int *k, int *ntips){
+ double *tmp, *P;
+ int j;
+ tmp = (double *) R_alloc(*nr * *nc, sizeof(double));
+ P = (double *) R_alloc(*nc * *nc, sizeof(double));
+ for(j = 0; j < *k; j++){
+ getP(eva, eve, evi, *nc, el[0], g[j], P);
+ helpDAD3(&LL[LINDEX2(*dad, j)], &LL[LINDEX2(*child, j)], P, nr, nc, tmp);
+ }
+}
+
+
+// children
+void helpDAD4(double *dad, int *child, double *contrast, double *P, int *nr, int *nc, int *nco, double *res){
+ matp(child, contrast, P, nr, nc, nco, res);
+ for(int j=0; j<(*nc * *nr); j++) res[j]=dad[j]/res[j];
+}
+
+
+void getDAD4(int *dad, int *child, double *contrast, double *eva, double *eve, double *evi, double *el, double *g, int *nr, int *nc, int *nco, int *k, int *ntips){
+ double *tmp, *P;
+ int j;
+ tmp = (double *) R_alloc(*nr * *nc, sizeof(double));
+ P = (double *) R_alloc(*nc * *nc, sizeof(double));
+ for(j = 0; j < *k; j++){
+ getP(eva, eve, evi, *nc, el[0], g[j], P);
+ helpDAD4(&LL[LINDEX2(*dad, j)], child, contrast, P, nr, nc, nco, tmp);
+ }
+}
+
+
+// dad / child * P
+void helpDAD(double *dad, double *child, double *P, int nr, int nc, double *res){
+ F77_CALL(dgemm)(transa, transb, &nr, &nc, &nc, &one, child, &nr, P, &nc, &zero, res, &nr);
+ for(int j=0; j<(nc * nr); j++) res[j]=dad[j]/res[j];
+}
+
+
+SEXP getDAD(SEXP dad, SEXP child, SEXP P, SEXP nr, SEXP nc){
+ R_len_t i, n=length(P);
+ int ncx=INTEGER(nc)[0], nrx=INTEGER(nr)[0]; //, j
+ SEXP TMP, RESULT;
+ PROTECT(RESULT = allocVector(VECSXP, n));
+ for(i=0; i<n; i++){
+ PROTECT(TMP = allocMatrix(REALSXP, nrx, ncx));
+ helpDAD(REAL(VECTOR_ELT(dad, i)), REAL(VECTOR_ELT(child, i)), REAL(VECTOR_ELT(P, i)), nrx, ncx, REAL(TMP));
+ SET_VECTOR_ELT(RESULT, i, TMP);
+ UNPROTECT(1); // TMP
+ }
+ UNPROTECT(1); //RESULT
+ return(RESULT);
+ }
+
+
+
+// SEXP mixture of prepFS, prepFS & getPrep
+// while loop for moveLL mit LINDEX 1050 auf 900 ?
+void prepFS(double *XX, int ch, int pa, double *eva, double *eve, double *evi, double el, double *g, int nr, int nc, int ntips, int k){
+ int i;
+ double *P, *tmp;
+ tmp = (double *) R_alloc(nr * nc, sizeof(double));
+ P = (double *) R_alloc(nc * nc, sizeof(double));
+ for(i=0; i<k; i++){
+ getP(eva, eve, evi, nc, el, g[i], P);
+ helpDAD(&LL[LINDEX(pa, i)], &LL[LINDEX(ch, i)], P, nr, nc, tmp); //&LL[LINDEX(pa, i)]
+ helpPrep(&LL[LINDEX(ch, i)], &LL[LINDEX(pa, i)], eve, evi, nr, nc, tmp, &XX[i*nr*nc]);
+ }
+}
+
+
+
+SEXP getPrep(SEXP dad, SEXP child, SEXP eve, SEXP evi, SEXP nr, SEXP nc){
+ R_len_t i, n=length(dad);
+ int ncx=INTEGER(nc)[0], nrx=INTEGER(nr)[0]; //, j
+ double *tmp;
+ SEXP TMP, RESULT;
+ tmp = (double *) R_alloc(nrx*ncx, sizeof(double));
+ PROTECT(RESULT = allocVector(VECSXP, n));
+ for(i=0; i<n; i++){
+ PROTECT(TMP = allocMatrix(REALSXP, nrx, ncx));
+ helpPrep(REAL(VECTOR_ELT(dad, i)), REAL(VECTOR_ELT(child, i)), REAL(eve), REAL(evi), nrx, ncx, tmp, REAL(TMP));
+ SET_VECTOR_ELT(RESULT, i, TMP);
+ UNPROTECT(1); // TMP
+ }
+ UNPROTECT(1); //RESULT
+ return(RESULT);
+ }
+
+
+
+
+void prepFSE(double *XX, int *ch, int pa, double *eva, double *eve, double *evi, double el, double *g, int nr, int nc, int ntips, int k, double *contrast, double *contrast2, int ncs){
+ int i;
+ double *P; //, *tmp
+// tmp = (double *) R_alloc(nr * nc, sizeof(double));
+ P = (double *) R_alloc(nc * nc, sizeof(double));
+ for(i=0; i<k; i++){
+ getP(eva, eve, evi, nc, el, g[i], P);
+ helpDAD2(&ROOT[i * nr * nc], ch, contrast, P, nr, nc, ncs, &LL[LINDEX(pa, i)]);
+// helpDAD(&ROOT[i * nr * nc], &LL[LINDEX(ch, i)], P, nr, nc, &LL[LINDEX(pa, i)]);
+// helpPrep(&LL[LINDEX(ch, i)], &LL[LINDEX(pa, i)], eve, evi, nr, nc, tmp, &XX[i*nr*nc]);
+ helpPrep2(&LL[LINDEX(pa, i)], ch, contrast2, evi, nr, nc, ncs, &XX[i*nr*nc]);
+ }
+}
+
+
+SEXP getSCM(SEXP kk, SEXP nrx, SEXP nTips){
+ int j, nr = INTEGER(nrx)[0], ntips = INTEGER(nTips)[0], k = INTEGER(kk)[0]-1L;
+ SEXP RES;
+ PROTECT(RES = allocMatrix(INTSXP, nr, ntips));
+ for(j=0; j< (nr * ntips); j++) INTEGER(RES)[j] = SCM[j + k * nr *ntips];
+ UNPROTECT(1);
+ return(RES);
+}
+
+
+SEXP getLL(SEXP ax, SEXP bx, SEXP nrx, SEXP ncx, SEXP nTips){
+ int j, nc = INTEGER(ncx)[0], nr = INTEGER(nrx)[0], ntips = INTEGER(nTips)[0], a = INTEGER(ax)[0], b = INTEGER(bx)[0];
+ SEXP RES;
+ PROTECT(RES = allocMatrix(REALSXP, nr, nc));
+ for(j=0; j<(nr*nc); j++) REAL(RES)[j] = LL[j + LINDEX(a, b)];
+ UNPROTECT(1);
+ return(RES);
+}
+
+SEXP getROOT(SEXP ax, SEXP nrx, SEXP ncx){
+ int j, nc = INTEGER(ncx)[0], nr = INTEGER(nrx)[0], a = INTEGER(ax)[0];
+ SEXP RES;
+ PROTECT(RES = allocMatrix(REALSXP, nr, nc));
+ for(j=0; j<(nr*nc); j++) REAL(RES)[j] = ROOT[j + a * nr * nc];
+ UNPROTECT(1);
+ return(RES);
+}
+
+
+// ch * (pa %*% P)
+void getMI(int child, int parent, double el, double *eva, double *eve, double *evi, double *g, int nr, int nc, int k, int ntips){
+ int i, a, j;
+ double *P;
+ P = (double *) R_alloc(nc * nc, sizeof(double));
+ for(i=0; i<k; i++){
+ getP(eva, eve, evi, nc, el, g[i], P);
+ a = i * nr * nc;
+ F77_CALL(dgemm)(transa, transb, &nr, &nc, &nc, &one, &LL[LINDEX(parent, i)], &nr, P, &nc, &zero, &ROOT[a], &nr);
+ for(j=0; j<(nc * nr); j++) ROOT[a + j]*=LL[LINDEX(child, i) + j];
+ }
+}
+
+// (ch %*% P) * pa
+void getME(int *child, int parent, double el, double *eva, double *eve, double *evi, double *g, int nr,
+ int nc, int k, int ntips, double *contrast, int nrs){
+ int i, a, j;
+ double *P;
+ P = (double *) R_alloc(nc * nc, sizeof(double));
+ for(i=0; i<k; i++){
+ getP(eva, eve, evi, nc, el, g[i], P);
+ a = i * nr * nc;
+ matp(child, contrast, P, &nr, &nc, &nrs, &ROOT[a]);
+ for(j=0; j<(nc * nr); j++) ROOT[a + j]*=LL[LINDEX(parent, i) + j];
+ }
+}
+
+
+void NR55(double *eva, int nc, double el, double *w, double *g, SEXP X, int ld, int nr, double *f, double *res){
+ int i, j, k;
+ double *tmp;
+ tmp = (double *) R_alloc(nc, sizeof(double));
+
+ for(k=0; k<nr; k++) res[k] = 0.0;
+
+ for(j=0;j<ld;j++){
+ for(i=0; i<nc ;i++) tmp[i] = (eva[i] * g[j] * el) * exp(eva[i] * g[j] * el);
+ F77_CALL(dgemv)(transa, &nr, &nc, &w[j], REAL(VECTOR_ELT(X, j)), &nr, tmp, &ONE, &one, res, &ONE);
+ }
+ for(i=0; i<nr ;i++) res[i]/=f[i];
+}
+
+
+void NR555(double *eva, int nc, double el, double *w, double *g, SEXP X, int ld, int nr, double *f, double *res){
+ int i, j, k;
+ double *tmp;
+ tmp = (double *) R_alloc(nc, sizeof(double));
+
+ for(k=0; k<nr; k++) res[k] = 0.0;
+
+ for(j=0;j<ld;j++){
+ for(i=0; i<nc ;i++) tmp[i] = (eva[i] * g[j]) * exp(eva[i] * g[j] * el);
+ F77_CALL(dgemv)(transa, &nr, &nc, &w[j], REAL(VECTOR_ELT(X, j)), &nr, tmp, &ONE, &one, res, &ONE);
+ }
+ for(i=0; i<nr ;i++) res[i]/=f[i];
+}
+
+
+void NR66(double *eva, int nc, double el, double *w, double *g, SEXP X, int ld, int nr, double *res){
+ int i, j;
+ double *tmp; //*res, *dF,
+
+ tmp = (double *) R_alloc(nc, sizeof(double));
+
+ for(j=0;j<ld;j++){
+ for(i=0; i<nc ;i++) tmp[i] = exp(eva[i] * g[j] * el);
+ // alpha = w[j]
+ F77_CALL(dgemv)(transa, &nr, &nc, &w[j], REAL(VECTOR_ELT(X, j)), &nr, tmp, &ONE, &one, res, &ONE);
+ }
+}
+
+
+
+// in ancestral.pml
+SEXP LogLik2(SEXP dlist, SEXP P, SEXP nr, SEXP nc, SEXP node, SEXP edge, SEXP nTips, SEXP mNodes, SEXP contrast, SEXP nco){
+ R_len_t i, n = length(node);
+ int nrx=INTEGER(nr)[0], ncx=INTEGER(nc)[0], nt=INTEGER(nTips)[0], mn=INTEGER(mNodes)[0];
+ int ni, ei, j, *edges=INTEGER(edge), *nodes=INTEGER(node);
+ SEXP ans, result;
+ double *res, *rtmp;
+ if(!isNewList(dlist)) error("'dlist' must be a list");
+ ni = nodes[0];
+ PROTECT(ans = allocVector(VECSXP, mn));
+ PROTECT(result = allocMatrix(REALSXP, nrx, ncx));
+ res = REAL(result);
+ rtmp = (double *) R_alloc(nrx*ncx, sizeof(double));
+ for(j=0; j < (nrx * ncx); j++) res[j] = 1.0;
+ for(i = 0; i < n; i++) {
+ ei = edges[i];
+ if(ni != nodes[i]){
+ SET_VECTOR_ELT(ans, ni, result);
+ UNPROTECT(1); //result
+ PROTECT(result = allocMatrix(REALSXP, nrx, ncx));
+ res = REAL(result);
+ ni = nodes[i];
+ if(ei < nt)
+ matp(INTEGER(VECTOR_ELT(dlist, ei)), REAL(contrast), REAL(VECTOR_ELT(P, i)), INTEGER(nr), INTEGER(nc), INTEGER(nco), res);
+ else
+ F77_CALL(dgemm)(transa, transb, &nrx, &ncx, &ncx, &one, REAL(VECTOR_ELT(ans, ei-nt)), &nrx,
+ REAL(VECTOR_ELT(P, i)), &ncx, &zero, res, &nrx);
+ }
+ else {
+ if(ei < nt)
+ matp(INTEGER(VECTOR_ELT(dlist, ei)), REAL(contrast), REAL(VECTOR_ELT(P, i)), INTEGER(nr), INTEGER(nc), INTEGER(nco), rtmp);
+ else
+ F77_CALL(dgemm)(transa, transb, &nrx, &ncx, &ncx, &one, REAL(VECTOR_ELT(ans, ei-nt)), &nrx,
+ REAL(VECTOR_ELT(P, i)), &ncx, &zero, rtmp, &nrx);
+ for(j=0; j < (nrx*ncx); j++) res[j] *= rtmp[j];
+ }
+ }
+ SET_VECTOR_ELT(ans, ni, result);
+ UNPROTECT(2); // result ans
+ return(ans);
+}
+
+//raus
+static R_INLINE void matprod(double *x, int nrx, int ncx, double *y, int nry, int ncy, double *z)
+{
+ F77_CALL(dgemm)(transa, transb, &nrx, &ncy, &ncx, &one, x, &nrx, y, &nry, &zero, z, &nrx);
+}
+
+
+SEXP getM3(SEXP dad, SEXP child, SEXP P, SEXP nr, SEXP nc){
+ R_len_t i, n=length(P);
+ int ncx=INTEGER(nc)[0], nrx=INTEGER(nr)[0], j;
+ SEXP TMP, RESULT;
+ double *tmp, *daddy;
+ PROTECT(RESULT = allocVector(VECSXP, n));
+ for(i=0; i<n; i++){
+ PROTECT(TMP = allocMatrix(REALSXP, nrx, ncx));
+ tmp = REAL(TMP);
+ matprod(REAL(VECTOR_ELT(child, i)), nrx, ncx, REAL(VECTOR_ELT(P, i)), ncx, ncx, tmp);
+ daddy = REAL(VECTOR_ELT(dad, i));
+ for(j=0; j<(ncx * nrx); j++) tmp[j]*=daddy[j];
+ SET_VECTOR_ELT(RESULT, i, TMP);
+ UNPROTECT(1); // TMP
+ }
+ UNPROTECT(1); //RESULT
+ return(RESULT);
+ }
+
+
+SEXP FS4(SEXP eig, SEXP nc, SEXP el, SEXP w, SEXP g, SEXP X, SEXP dad, SEXP child, SEXP ld, SEXP nr,
+ SEXP basefreq, SEXP weight, SEXP f0, SEXP retA, SEXP retB)
+{
+ SEXP RESULT, EL, P;
+ double *tmp, *f, *wgt=REAL(weight), edle, ledle, newedle, eps=10, *eva=REAL(VECTOR_ELT(eig,0));
+ double ll, lll, delta=0.0, scalep = 1.0, *ws=REAL(w), *gs=REAL(g), l1=0.0, l0=0.0;
+ double y;
+ int i, k=0, ncx=INTEGER(nc)[0], nrx=INTEGER(nr)[0];
+ tmp = (double *) R_alloc(nrx, sizeof(double));
+ f = (double *) R_alloc(nrx, sizeof(double));
+ PROTECT(RESULT = allocVector(VECSXP, 4));
+ edle = REAL(el)[0];
+
+ for(i=0; i<nrx; i++)f[i] = REAL(f0)[i];
+ NR66(eva, ncx, edle, ws, gs, X, INTEGER(ld)[0], nrx, f); // ncx-1L !!!
+ for(i=0; i<nrx ;i++) l0 += wgt[i] * log(f[i]);
+
+ while ( (eps > 1e-05) && (k < 5) ) {
+ if(scalep>0.6){
+ NR55(eva, ncx-1L, edle, ws, gs, X, INTEGER(ld)[0], nrx, f, tmp);
+ ll=0.0;
+ lll=0.0;
+// for(i=0; i<nrx ;i++) ll+=wgt[i]*tmp[i];
+// for(i=0; i<nrx ;i++) lll+=wgt[i]*tmp[i]*tmp[i];
+
+ for(i=0; i<nrx ;i++){
+ y = wgt[i]*tmp[i];
+ ll+=y;
+ lll+=y*tmp[i];
+ }
+ delta = ((ll/lll) < 3) ? (ll/lll) : 3;
+ } // end if
+ ledle = log(edle) + scalep * delta;
+ newedle = exp(ledle);
+// some error handling avoid too big small edges & too big steps
+ if (newedle > 10.0) newedle = 10.0;
+ if (newedle < 1e-8) newedle = edle/2;
+ if (newedle < 1e-8) newedle = 1e-8; // 1e-8 phyML
+
+ for(i=0; i<nrx; i++)f[i] = REAL(f0)[i];
+ NR66(eva, ncx, newedle, ws, gs, X, INTEGER(ld)[0], nrx, f);
+ l1 = 0.0;
+ for(i=0; i<nrx ;i++) l1 += wgt[i] * log(f[i]); // + log
+ eps = l1 - l0;
+// some error handling
+ if (eps < 0 || ISNAN(eps)) {
+ if (ISNAN(eps))eps = 0;
+ else {
+ scalep = scalep/2.0;
+ eps = 1.0;
+ }
+ newedle = edle;
+ l1 = l0;
+ }
+ else scalep = 1.0;
+ edle=newedle;
+ l0 = l1;
+ k ++;
+ }
+ PROTECT(EL = ScalarReal(edle));
+ PROTECT(P = getPM(eig, nc, EL, g));
+ SET_VECTOR_ELT(RESULT, 0, EL);
+ if(INTEGER(retA)[0]>0L)SET_VECTOR_ELT(RESULT, 1, getM3(child, dad, P, nr, nc));
+ if(INTEGER(retB)[0]>0L)SET_VECTOR_ELT(RESULT, 2, getM3(dad, child, P, nr, nc));
+// add variance ??
+ SET_VECTOR_ELT(RESULT, 3, ScalarReal(l1));
+ UNPROTECT(3);
+ return (RESULT);
+}
+
+
+SEXP FS5(SEXP eig, SEXP nc, SEXP el, SEXP w, SEXP g, SEXP X, SEXP ld, SEXP nr, SEXP basefreq, SEXP weight, SEXP f0)
+{
+ SEXP RESULT; // EL, P;
+ double *tmp, *f, *wgt=REAL(weight), edle, ledle, newedle, eps=10, *eva=REAL(VECTOR_ELT(eig,0));
+ double ll, lll, delta=0.0, scalep = 1.0, *ws=REAL(w), *gs=REAL(g), l1=0.0, l0=0.0;
+ double y;
+ int i, k=0, ncx=INTEGER(nc)[0], nrx=INTEGER(nr)[0];
+ tmp = (double *) R_alloc(nrx, sizeof(double));
+ f = (double *) R_alloc(nrx, sizeof(double));
+ PROTECT(RESULT = allocVector(REALSXP, 3));
+ edle = REAL(el)[0];
+
+ for(i=0; i<nrx; i++)f[i] = REAL(f0)[i];
+ NR66(eva, ncx, edle, ws, gs, X, INTEGER(ld)[0], nrx, f); // ncx-1L !!!
+ for(i=0; i<nrx ;i++) l0 += wgt[i] * log(f[i]);
+
+ while ( (eps > 1e-05) && (k < 5) ) {
+ if(scalep>0.6){
+ NR55(eva, ncx-1L, edle, ws, gs, X, INTEGER(ld)[0], nrx, f, tmp);
+ ll=0.0;
+ lll=0.0;
+ for(i=0; i<nrx ;i++){
+ y = wgt[i]*tmp[i];
+ ll+=y;
+ lll+=y*tmp[i];
+ }
+ delta = ((ll/lll) < 3) ? (ll/lll) : 3;
+ } // end if
+ ledle = log(edle) + scalep * delta;
+ newedle = exp(ledle);
+// some error handling avoid too big small edges & too big steps
+ if (newedle > 10.0) newedle = 10.0;
+// if (newedle < 1e-8) newedle = edle/2;
+ if (newedle < 1e-8) newedle = 1e-8; // 1e-8 phyML
+
+ for(i=0; i<nrx; i++)f[i] = REAL(f0)[i];
+ NR66(eva, ncx, newedle, ws, gs, X, INTEGER(ld)[0], nrx, f);
+ l1 = 0.0;
+ for(i=0; i<nrx ;i++) l1 += wgt[i] * log(f[i]); // + log
+ eps = l1 - l0;
+// some error handling
+ if (eps < 0 || ISNAN(eps)) {
+ if (ISNAN(eps))eps = 0;
+ else {
+ scalep = scalep/2.0;
+ eps = 1.0;
+ }
+ newedle = edle;
+ l1 = l0;
+ }
+ else scalep = 1.0;
+ edle=newedle;
+ l0 = l1;
+ k ++;
+ }
+// variance
+ NR555(eva, ncx-1L, edle, ws, gs, X, INTEGER(ld)[0], nrx, f, tmp);
+ lll=0.0;
+ for(i=0; i<nrx ;i++) lll+=wgt[i]*tmp[i]*tmp[i];
+ REAL(RESULT)[0] = edle;
+ REAL(RESULT)[1] = 1.0/ lll; // variance
+ REAL(RESULT)[2] = l0;
+ UNPROTECT(1);
+ return (RESULT);
+}
+
+
+
+
diff --git a/src/phangorn.c b/src/phangorn.c
new file mode 100644
index 0000000..9af27ca
--- /dev/null
+++ b/src/phangorn.c
@@ -0,0 +1,868 @@
+/*
+ * phangorn.c
+ *
+ * (c) 2008-2015 Klaus Schliep (klaus.schliep at gmail.com)
+ *
+ *
+ * This code may be distributed under the GNU GPL
+ *
+ */
+
+# define USE_RINTERNALS
+
+#include <Rmath.h>
+#include <math.h>
+#include <R.h>
+#include <R_ext/Lapack.h>
+#include <Rinternals.h>
+
+
+
+// off-diagonal
+#define DINDEX(i, j) n*(i - 1) - i * (i - 1)/2 + j - i - 1
+// with diagonal (+i), R index (+1)
+#define DINDEX2(i, j) n*(i - 1) - i * (i - 1)/2 + j - 1
+
+// index likelihood pml
+// need to define nr, nc, nTips, nNodes k
+#define LINDEX(i) (i-nTips) * (nr*nc) //+ k * nTips * (nr * nc)
+#define LINDEX2(i, k) (i-nTips) * (nr*nc) + k * nTips * (nr * nc)
+#define LINDEX3(i, k) (i-*nTips-1L) * (*nr* *nc) + k * *nTips * (*nr * *nc)
+
+// index sankoff
+#define SINDEX(i) i * (nr*nc)
+
+/* from coalescentMCMC
+void get_single_index_integer(int *x, int *val, int *index)
+{
+ int i = 0, v = *val;
+ while (x[i] != v) i++;
+ *index = i + 1;
+}
+
+void get_two_index_integer(int *x, int *val, int *index)
+{
+ int i1 = 0, i2, v = *val;
+ while (x[i1] != v) i1++;
+ i2 = i1 + 1;
+ while (x[i2] != v) i2++;
+ index[0] = i1 + 1;
+ index[1] = i2 + 1;
+}
+*/
+
+
+void countCycle(int *M, int *l, int *m, int *res){
+ int j, i, tmp;
+ res[0]=0L;
+ for (i=0; i<*l; i++) {
+ tmp = 0;
+ if(M[i] != M[i + (*m -1) * *l])tmp++;
+ for (j=1; j<*m; j++) {
+ if(M[i + (j-1)* *l] != M[i + j * *l])tmp++;
+ }
+ if(tmp>2L)res[0]+=tmp;
+ }
+}
+
+
+void countCycle2(int *M, int *l, int *m, int *res){
+ int j, i, tmp;
+ for (i=0; i<*l; i++) {
+ tmp = 0L;
+ if(M[i] != M[i + (*m -1) * *l])tmp=1L;
+ for (j=1; j<*m; j++) {
+ if(M[i + (j-1L)* *l] != M[i + j * *l])tmp++;
+ }
+ res[i]=tmp;
+ }
+}
+
+
+
+void nodeH(int *edge, int *node, double *el, int *l, double *res){
+ int ei, i;
+ for (i=*l-1L; i>=0; i--) {
+ ei = edge[i] - 1L;
+ res[ei] = res[node[i]-1L] + el[ei];
+ }
+}
+
+
+SEXP rowMax(SEXP sdat, SEXP sn, SEXP sk){
+ int i, h, n=INTEGER(sn)[0], k=INTEGER(sk)[0];
+ double x, *res, *dat;
+ SEXP result;
+ PROTECT(result = allocVector(REALSXP, n));
+ res = REAL(result);
+ PROTECT(sdat = coerceVector(sdat, REALSXP));
+ dat = REAL(sdat);
+ for(i = 0; i < n; i++){
+ x = dat[i];
+ for(h = 1; h< k; h++) {if(dat[i + h*n] > x) x=dat[i + h*n];}
+ res[i] = x;
+ }
+ UNPROTECT(2);
+ return(result);
+}
+
+/*
+static R_INLINE void getP00(double *eva, double *ev, double *evi, int m, double el, double w, double *result){
+ int i, j, h;
+ double tmp, res;
+ for(i = 0; i < m; i++){
+ tmp = exp(eva[i] * w * el);
+ for(j=0; j<m; j++) evi[i + j*m] *= tmp;
+ }
+ for(i = 0; i < m; i++){
+ for(j = 0; j < m; j++){
+ res = 0.0;
+ for(h = 0; h < m; h++) res += ev[i + h*m] * evi[h + j*m];
+ result[i+j*m] = res;
+ }
+ }
+}
+*/
+
+
+static R_INLINE void getPP(double *eva, double *ev, double *evi, int m, double el, double w, double *result){
+ int i, j, h;
+ double tmp[m];
+ for(i = 0; i < m; i++) tmp[i] = exp(eva[i] * w * el);
+ for(i = 0; i < m; i++){
+ for(j = 0; j < m; j++){
+ result[i+j*m] = 0;
+ for(h = 0; h < m; h++) result[i+j*m] += ev[i + h*m] * tmp[h] * evi[h + j*m];
+ }
+ }
+}
+
+
+void getdP(double *eva, double *ev, double *evi, int m, double el, double w, double *result){
+ int i, j, h;
+ double tmp[m], res;
+ for(i = 0; i < m; i++) tmp[i] = (eva[i] * w * el) * exp(eva[i] * w * el);
+ for(i = 0; i < m; i++){
+ for(j = 0; j < m; j++){
+ res = 0.0;
+ for(h = 0; h < m; h++) res += ev[i + h*m] * tmp[h] * evi[h + j*m];
+ result[i+j*m] = res;
+ }
+ }
+}
+
+
+void getdP2(double *eva, double *ev, double *evi, int m, double el, double w, double *result){
+ int i, j, h;
+ double tmp[m], res;
+ for(i = 0; i < m; i++) tmp[i] = (eva[i] * w) * exp(eva[i] * w * el);
+ for(i = 0; i < m; i++){
+ for(j = 0; j < m; j++){
+ res = 0.0;
+ for(h = 0; h < m; h++) res += ev[i + h*m] * tmp[h] * evi[h + j*m];
+ result[i+j*m] = res;
+ }
+ }
+}
+
+
+void getd2P(double *eva, double *ev, double *evi, int m, double el, double w, double *result){
+ int i, j, h;
+ double tmp[m], res;
+ for(i = 0; i < m; i++) tmp[i] = (eva[i] * w * el) * (eva[i] * w * el) * exp(eva[i] * w * el);
+ for(i = 0; i < m; i++){
+ for(j = 0; j < m; j++){
+ res = 0.0;
+ for(h = 0; h < m; h++) res += ev[i + h*m] * tmp[h] * evi[h + j*m];
+ result[i+j*m] = res;
+ }
+ }
+}
+
+
+void getd2P2(double *eva, double *ev, double *evi, int m, double el, double w, double *result){
+ int i, j, h;
+ double tmp[m], res;
+ for(i = 0; i < m; i++) tmp[i] = (eva[i] * w) * (eva[i] * w) * exp(eva[i] * w * el);
+ for(i = 0; i < m; i++){
+ for(j = 0; j < m; j++){
+ res = 0.0;
+ for(h = 0; h < m; h++) res += ev[i + h*m] * tmp[h] * evi[h + j*m];
+ result[i+j*m] = res;
+ }
+ }
+}
+
+
+SEXP getPM2(SEXP eig, SEXP nc, SEXP el, SEXP w){
+ R_len_t i, j, nel, nw;
+ int m=INTEGER(nc)[0], l=0;
+ double *ws=REAL(w);
+ double *edgelen=REAL(el);
+ double *eva, *eve, *evei;
+ SEXP P, RESULT;
+ nel = length(el);
+ nw = length(w);
+ if(!isNewList(eig)) error("'eig' must be a list");
+ eva = REAL(VECTOR_ELT(eig, 0));
+ eve = REAL(VECTOR_ELT(eig, 1));
+ evei = REAL(VECTOR_ELT(eig, 2));
+ PROTECT(RESULT = allocVector(VECSXP, nel*nw));
+ for(j=0; j<nel; j++){
+ for(i=0; i<nw; i++){
+ PROTECT(P = allocMatrix(REALSXP, m, m));
+ getPP(eva, eve, evei, m, edgelen[j], ws[i], REAL(P));
+ SET_VECTOR_ELT(RESULT, l, P);
+ UNPROTECT(1);
+ l++;
+ }
+ }
+ UNPROTECT(1);//RESULT
+ return(RESULT);
+}
+
+
+SEXP getdPM(SEXP eig, SEXP nc, SEXP el, SEXP w){
+ R_len_t i, j, nel, nw;
+ int m=INTEGER(nc)[0], l=0;
+ double *ws=REAL(w);
+ double *edgelen=REAL(el);
+ double *eva, *eve, *evei;
+ SEXP P, RESULT;
+ nel = length(el);
+ nw = length(w);
+ eva = REAL(VECTOR_ELT(eig, 0));
+ eve = REAL(VECTOR_ELT(eig, 1));
+ evei = REAL(VECTOR_ELT(eig, 2));
+ PROTECT(RESULT = allocVector(VECSXP, nel*nw));
+ double *p;
+ if(!isNewList(eig)) error("'dlist' must be a list");
+ for(j=0; j<nel; j++){
+ for(i=0; i<nw; i++){
+ PROTECT(P = allocMatrix(REALSXP, m, m));
+ p = REAL(P);
+ getdP(eva, eve, evei, m, edgelen[j], ws[i], p);
+ SET_VECTOR_ELT(RESULT, l, P);
+ UNPROTECT(1); //P
+ l++;
+ }
+ }
+ UNPROTECT(1);//RESULT
+ return(RESULT);
+}
+
+
+SEXP getdPM2(SEXP eig, SEXP nc, SEXP el, SEXP w){
+ R_len_t i, j, nel, nw;
+ int m=INTEGER(nc)[0], l=0;
+ double *ws=REAL(w);
+ double *edgelen=REAL(el);
+ double *eva, *eve, *evei;
+ SEXP P, RESULT;
+ nel = length(el);
+ nw = length(w);
+ eva = REAL(VECTOR_ELT(eig, 0));
+ eve = REAL(VECTOR_ELT(eig, 1));
+ evei = REAL(VECTOR_ELT(eig, 2));
+ PROTECT(RESULT = allocVector(VECSXP, nel*nw));
+ double *p;
+ if(!isNewList(eig)) error("'dlist' must be a list");
+ for(j=0; j<nel; j++){
+ for(i=0; i<nw; i++){
+ PROTECT(P = allocMatrix(REALSXP, m, m));
+ p = REAL(P);
+ getdP2(eva, eve, evei, m, edgelen[j], ws[i], p);
+ SET_VECTOR_ELT(RESULT, l, P);
+ UNPROTECT(1); //P
+ l++;
+ }
+ }
+ UNPROTECT(1); //RESULT
+ return(RESULT);
+}
+
+
+SEXP getd2PM(SEXP eig, SEXP nc, SEXP el, SEXP w){
+ R_len_t i, j, nel, nw;
+ int m=INTEGER(nc)[0], l=0;
+ double *ws=REAL(w);
+ double *edgelen=REAL(el);
+ double *eva, *eve, *evei;
+ SEXP P, RESULT;
+ nel = length(el);
+ nw = length(w);
+ eva = REAL(VECTOR_ELT(eig, 0));
+ eve = REAL(VECTOR_ELT(eig, 1));
+ evei = REAL(VECTOR_ELT(eig, 2));
+ PROTECT(RESULT = allocVector(VECSXP, nel*nw));
+ double *p;
+ if(!isNewList(eig)) error("'dlist' must be a list");
+ for(j=0; j<nel; j++){
+ for(i=0; i<nw; i++){
+ PROTECT(P = allocMatrix(REALSXP, m, m));
+ p = REAL(P);
+ getd2P(eva, eve, evei, m, edgelen[j], ws[i], p);
+ SET_VECTOR_ELT(RESULT, l, P);
+ UNPROTECT(1); //P
+ l++;
+ }
+ }
+ UNPROTECT(1); //RESULT
+ return(RESULT);
+}
+
+
+SEXP getd2PM2(SEXP eig, SEXP nc, SEXP el, SEXP w){
+ R_len_t i, j, nel, nw;
+ int m=INTEGER(nc)[0], l=0;
+ double *ws=REAL(w);
+ double *edgelen=REAL(el);
+ double *eva, *eve, *evei;
+ SEXP P, RESULT;
+ nel = length(el);
+ nw = length(w);
+ eva = REAL(VECTOR_ELT(eig, 0));
+ eve = REAL(VECTOR_ELT(eig, 1));
+ evei = REAL(VECTOR_ELT(eig, 2));
+ PROTECT(RESULT = allocVector(VECSXP, nel*nw));
+ double *p;
+ if(!isNewList(eig)) error("'dlist' must be a list");
+ for(j=0; j<nel; j++){
+ for(i=0; i<nw; i++){
+ PROTECT(P = allocMatrix(REALSXP, m, m));
+ p = REAL(P);
+ getd2P2(eva, eve, evei, m, edgelen[j], ws[i], p);
+ SET_VECTOR_ELT(RESULT, l, P);
+ UNPROTECT(1); //P
+ l++;
+ }
+ }
+ UNPROTECT(1); //RESULT
+ return(RESULT);
+}
+
+
+/*
+static R_INLINE void emult(double *x, double *y, int n){
+ for(int i=0; i<n; i++) x[i]*=y[i];
+}
+*/
+
+
+void tabulate(int *x, int *n, int *nbin, int *ans){
+ int i, tmp;
+ for (i=0; i < *nbin; i++) ans[i]=0L;
+ for (i=0; i < *n; i++) {
+ tmp = x[i];
+ if( (tmp>0) & (tmp<(*nbin+1L)) )
+ ans[tmp-1L] ++;
+ }
+}
+
+
+void C_reorder(int *from, int *to, int *n, int *sumNode, int *neworder, int *root){
+ int i, j, sum=0, k, Nnode, ind, *ord, *csum, *tips, *stack, z=0; // l,
+ double *parent;
+ int m=sumNode[0];
+ parent = (double *) R_alloc((*n), sizeof(double));
+ tips = (int *) R_alloc(m, sizeof(int));
+ ord = (int *) R_alloc((*n), sizeof(int));
+ csum = (int *) R_alloc( (m+1), sizeof(int));
+ stack = (int *) R_alloc(m, sizeof(int));
+ for(j=0;j<(*n);j++) parent[j] = (double)from[j];
+
+ for(j=0;j<(*n);j++) ord[j] = j;
+ for(j=0;j<m;j++) tips[j] = 0;
+
+ rsort_with_index(parent, ord, *n);
+ tabulate(from, n, sumNode, tips);
+ csum[0]=0;
+ for(i=0;i<(*sumNode);i++){
+ sum+=tips[i];
+ csum[i+1] = sum;
+ }
+ k = (*n)-1;
+ Nnode = 0;
+ stack[0] = *root;
+
+ while(z > -1){
+ j=stack[z];
+ if(tips[j]>0){
+ for(i=csum[j];i<csum[j+1];i++){
+ ind = ord[i];
+ neworder[k] = ind + 1;
+ stack[z] = to[ind]-1;
+ k -=1;
+ z++;
+ }
+ Nnode += 1;
+ }
+ z--;
+ }
+ root[0]=Nnode;
+}
+
+
+
+SEXP AllChildren(SEXP children, SEXP parent, SEXP M){
+ int i, j, k, l=0L, m=INTEGER(M)[0], *tab, p;
+ R_len_t n=length(parent);
+ SEXP RESULT, TMP;
+ tab = (int*)R_alloc(m, sizeof(int));
+ for(i=0; i<m; i++)tab[i]=0L;
+ j=0;
+ p = INTEGER(parent)[0];
+ for(i=0; i<n; i++){
+ if(INTEGER(parent)[i]!=p){
+ p = INTEGER(parent)[i];
+ j=j+1;
+ }
+ tab[j] += 1L;
+ }
+// for(i=0; i<n; i++) tab[INTEGER(parent)[i] - 1L] ++; // 7 Zeilen weniger
+ PROTECT(RESULT = allocVector(VECSXP, m));
+
+ i=0L;
+ while(l<n){
+ k=tab[i];
+ PROTECT(TMP = allocVector(INTSXP, k));
+ p = INTEGER(parent)[l]-1;
+ for(j=0; j<k; j++){
+ INTEGER(TMP)[j] = INTEGER(children)[l];
+ l++;
+ }
+ SET_VECTOR_ELT(RESULT, p, TMP);
+ UNPROTECT(1);
+ i++;
+ }
+ UNPROTECT(1);
+ return(RESULT);
+}
+
+
+void AllKids(int *children, int *parents, int *nTips, int *nNode, int *lp, int *kids, int *lkids, int *pkids){
+ int i, k, m=nNode[0], p; // l=0L, *tab , j
+ int n=lp[0];
+ for(i=0; i<m; i++){
+ pkids[i]=0L;
+ lkids[i]=0L;
+ }
+ for(i=0; i<lp[0]; i++)kids[i]=0L;
+// j=0;
+ p = 0L;
+ for(i=0; i<n; i++){
+ p = parents[i] - 1L - nTips[0];
+ pkids[p] += 1L;
+ }
+ for(i=0; i<*nNode; i++)lkids[i+1] = lkids[i] + pkids[i];
+
+ i=0L;
+ k=0;
+ p=0L;
+ for(i=0; i<n; i++){
+ if(parents[i]!=p){
+ p=parents[i];
+ k=lkids[p- nTips[0] -1L];
+ }
+ else k++;
+ kids[k] = children[i];
+ }
+
+}
+
+
+/*
+library(phangorn)
+tree = rtree(10)
+
+allDesc = function(x, node){
+ x = reorder(x, "postorder")
+ parent = x$edge[, 1]
+ children = x$edge[, 2]
+ .Call("AllDesc", as.integer(children), as.integer(parent), as.integer(max(parent)), as.integer(node))
+}
+
+allDesc(tree, 14)
+ */
+
+SEXP AllDesc(SEXP child, SEXP parent, SEXP M, SEXP NODE){
+ int i, m=INTEGER(M)[0]+1, *tab, *res, p, node=INTEGER(NODE)[0];
+ R_len_t n=length(parent);
+ SEXP RESULT;
+ tab = (int*)R_alloc( m, sizeof(int));
+ for(i=0; i<m; i++)tab[i]=0L;
+ tab[node] = 1L;
+ PROTECT(RESULT = allocVector(INTSXP, n));
+ res = INTEGER(RESULT);
+ for(i=0; i<n; i++)res[i]=0L;
+
+ for(i=n-1L; i>=0L; i--){
+ p = INTEGER(parent)[i];
+ if(tab[p]==1L){
+ res[i] = 1L;
+ tab[INTEGER(child)[i]] = 1L;
+ }
+ }
+
+ UNPROTECT(1);
+ return(RESULT);
+}
+
+
+// combine two sorted vectors
+void crsort(double *x, double *y, int *a, int *b, double *res){
+ double xi, yi;
+ int i, j, k;
+ i=0;
+ j=0;
+ k=0;
+ xi=x[0];
+ yi=y[0];
+ while(k<((*a)+(*b))){
+ if(i<(*a)){
+ if( (xi<yi) | (j==((*b))) ){ //-1L
+ res[k]=xi;
+ i++;
+ if(i<(*a))xi=x[i];
+ k++;
+ }
+ else{
+ j++;
+ res[k]=yi;
+ if(j<(*b))yi=y[j];
+ k++;
+ }
+ }
+ else{
+ j++;
+ res[k]=yi;
+ if(j<(*b))yi=y[j];
+ k++;
+ }
+ }
+}
+
+
+void cisort(int *x, int *y, int *a, int *b, int *res){
+ int xi, yi;
+ int i, j, k;
+ i=0;
+ j=0;
+ k=0;
+ xi=x[0];
+ yi=y[0];
+ while(k<((*a)+(*b))){
+ if(i<(*a)){
+ if( (xi<yi) | (j==((*b))) ){ //-1L
+ res[k]=xi;
+ i++;
+ if(i<(*a))xi=x[i];
+ k++;
+ }
+ else{
+ j++;
+ res[k]=yi;
+ if(j<(*b))yi=y[j];
+ k++;
+ }
+ }
+ else{
+ j++;
+ res[k]=yi;
+ if(j<(*b))yi=y[j];
+ k++;
+ }
+ }
+}
+
+void cisort2(int *x, int *y, int a, int b, int *res){
+ int xi, yi;
+ int i, j, k;
+ i=0;
+ j=0;
+ k=0;
+ xi=x[0];
+ yi=y[0];
+ while(k<((a)+(b))){
+ if(i<(a)){
+ if( (xi<yi) | (j==b) ){ //-1L
+ res[k]=xi;
+ i++;
+ if(i<(a))xi=x[i];
+ k++;
+ }
+ else{
+ j++;
+ res[k]=yi;
+ if(j<(b))yi=y[j];
+ k++;
+ }
+ }
+ else{
+ j++;
+ res[k]=yi;
+ if(j<(b))yi=y[j];
+ k++;
+ }
+ }
+}
+
+// faster cophenetic
+
+void C_bipHelp(int *parents, int *children, int *ntips, int *mp, int *l, int *ltips, int *ptips){
+ int p, k, i;
+ for(i=0; i<*ntips; i++)ltips[i]=1L;
+ for(i=*ntips; i<*mp; i++)ltips[i]=0L;
+ for(i=0; i<*l; i++){
+ p = parents[i]-1L;
+ k = children[i]-1L;
+ ltips[p]+=ltips[k];
+ }
+ for(i=0; i<(*mp+1); i++)ptips[i]=0L;
+ for(i=0; i<*mp; i++)ptips[i+1]=ptips[i] + ltips[i];
+}
+
+
+void C_bip2(int *parents, int *children, int *ntips, int *mp, int *l, int *ltips, int *ptips, int *tips){
+ int eins=1L, i, j, p, pi, ci, ltmp;
+ int *tmp, *tmp2;
+ tmp = (int *) R_alloc(*mp, sizeof(int));
+ tmp2 = (int *) R_alloc(*mp, sizeof(int));
+ for(i=0; i<*ntips; i++)tips[i]=i+1L;
+ for(i=*ntips; i<ptips[*mp]; i++)tips[i]=0L;
+ p=parents[0];
+
+ tmp[0] = 0L; //children[0];
+ ltmp= 0L; //1L;
+ for(i=0; i<*l; i++){
+ pi = parents[i];
+ ci = children[i];
+ if(pi==p){
+ if(ci < (*ntips+1L)){
+ cisort(&ci, tmp, &eins, <mp, tmp2);
+ ltmp += 1L;
+ for(j=0; j<ltmp; j++) tmp[j] = tmp2[j];
+ }
+ else{
+ cisort(&tips[ptips[ci-1L]], tmp, &(ltips[ci-1L]), <mp, tmp2);
+ ltmp += ltips[ci-1L]; // lch[ci];
+// ltmp += lch[ci];
+ for(j=0; j<ltmp; j++) tmp[j] = tmp2[j];
+ }
+// kl[pi]=k;
+// lch[pi] = ltmp;
+ }
+ else{
+ for(j=0; j<ltmp; j++) tips[ptips[p-1L]+j] = tmp2[j];//tmp2[j]
+ if(ci < (*ntips+1)){
+ tmp[0]=ci;
+ ltmp=1L;
+ }
+ else{
+ ltmp=ltips[ci-1L];
+ for(j=0; j<ltmp; j++)tmp[j] = tips[ptips[ci-1L]+j]; // , ci-1L))[j];
+ }
+// k += 1L;
+ p = pi;
+ }
+ }
+ for(j=0; j<ltmp; j++) tips[ptips[p-1L]+j] = tmp2[j];
+}
+
+// doppelt
+int give_index3(int i, int j, int n)
+{
+ if (i > j) return(DINDEX(j, i));
+ else return(DINDEX(i, j));
+}
+
+// faster and less memory consuming cophenetic
+void copheneticHelp(int *left, int *right, int *ll, int *lr, int h, double *nh, int *nTips, double *dm){
+ int i, j, ind;
+ for(i=0; i<*ll; i++){
+ for(j=0; j<*lr; j++){
+ ind = give_index3(left[i], right[j], *nTips);
+ dm[ind] = 2.0*nh[h] - nh[left[i]-1L] - nh[right[j]-1L];
+ }
+ }
+}
+
+
+void C_coph(int *tips, int *kids, int *ptips, int *pkids, int *ltips, int *lkids, int*Nnode, double *nh, int *nTips, double *dm){
+ int h, j, k, lk, pk, lt, rt, leftk, rightk;
+ for(h=0; h<*Nnode; h++){
+ lk=lkids[h];
+ pk=pkids[h];
+ for(j=0; j<(lk-1L); j++){
+ leftk=kids[pk+j] - 1L;
+ lt=ptips[leftk];
+ for(k=j+1L; k<lk; k++) {
+ rightk=kids[pk+k] - 1L;
+ rt = ptips[rightk];
+ copheneticHelp(&tips[lt], &tips[rt], <ips[leftk], <ips[rightk], (*nTips+h), nh, nTips, dm);
+ }
+ }
+ }
+}
+
+
+void C_cophenetic(int *children, int *parents, double *el, int *lp, int *m, int *nTips, int *nNode, double *res){
+ double *nh, maxNH;
+ int i, lt;
+ int *kids, *lkids, *pkids;
+ int *tips, *ltips, *ptips;
+ nh = (double *) calloc(*m, sizeof(double));
+ kids = (int *) R_alloc(*lp, sizeof(int));
+ lkids = (int *) R_alloc(*nNode + 1L, sizeof(int));
+ pkids = (int *) R_alloc(*nNode, sizeof(int));
+ ltips = (int *) R_alloc(*m, sizeof(int));
+ ptips = (int *) R_alloc(*m + 1L, sizeof(int));
+ //nodeH(int *edge, int *node, double *el, int *l, double *res)
+ nodeH(children, parents, el, lp, nh);
+ maxNH=nh[0];
+ for(i=1; i<*m; i++)if(maxNH<nh[i]) maxNH=nh[i];
+ for(i=0; i<*m; i++)nh[i] = maxNH - nh[i];
+// tmp <- .C("AllKids", kids, parents, nTips, nNode, lp, integer(lp), integer(nNode+1L),
+// integer(nNode))
+// void AllKids(int *children, int *parents, int *nTips, int *nNode, int *lp, int *kids, int *lkids, int *pkids){
+ AllKids(children, parents, nTips, nNode, lp, kids, lkids, pkids);
+//tmp2 = .C("C_bipHelp", parents, kids, nTips, m, lp, integer(m), integer(m+1L))
+ C_bipHelp(parents, children, nTips, m, lp, ltips, ptips);
+// tips <- .C("C_bip2", parents, kids, nTips, m, lp, ltips=tmp2[[6]], ptips=tmp2[[7]], integer(sum(tmp2[[6]])))[[8]]
+ lt = 0;
+ for(i=0; i<*m; i++)lt += ltips[i];
+ tips = (int *) R_alloc(lt, sizeof(int));
+ C_bip2(parents, children, nTips, m, lp, ltips, ptips, tips);
+ //void coph(int *tips, int *kids, int *ptips, int *pkids, int *ltips, int *lkids, int*Nnode, double *nh, int *nTips, double *dm)
+ C_coph(tips, kids, ptips, lkids, ltips, pkids, nNode, nh, nTips, res);
+}
+
+
+// a bit faster
+SEXP C_bip(SEXP parent, SEXP child, SEXP nTips, SEXP maxP){ //, SEXP Nnode){
+ int eins=1L, i, j, k, l=length(child), *tmp, *tmp2, *lch, *kl, pi, ci, p, nt=INTEGER(nTips)[0], mp=INTEGER(maxP)[0], ltmp;
+ SEXP ans, ktmp;
+ tmp = (int *) R_alloc(mp, sizeof(int));
+ tmp2 = (int *) R_alloc(mp, sizeof(int));
+ lch = (int *) R_alloc(mp+1L, sizeof(int));
+ kl = (int *) R_alloc(mp+1L, sizeof(int));
+ PROTECT(ans = allocVector(VECSXP, mp)); //INTEGER(Nnode)[0]));
+ for(i=0; i<nt; i++) SET_VECTOR_ELT(ans, i, ScalarInteger(i+1L));
+ p=INTEGER(parent)[0];
+ pi = INTEGER(parent)[1];
+ k=0L;
+ kl[p]=0;
+ lch[p]=1;
+ tmp[0] = INTEGER(child)[0];
+ ltmp=1L;
+ for(i=1; i<l; i++){
+ pi = INTEGER(parent)[i];
+ ci = INTEGER(child)[i];
+ if(pi==p){
+ if(ci < (nt+1L)){
+ cisort(&ci, tmp, &eins, <mp, tmp2);
+ ltmp += 1L;
+ for(j=0; j<ltmp; j++) tmp[j] = tmp2[j];
+ }
+ else{
+ cisort(INTEGER(VECTOR_ELT(ans, ci-1L)), tmp, &(lch[ci]), <mp, tmp2);
+ ltmp += lch[ci];
+ for(j=0; j<ltmp; j++) tmp[j] = tmp2[j];
+ }
+ kl[pi]=k;
+ lch[pi] = ltmp;
+ }
+ else{
+ PROTECT(ktmp = allocVector(INTSXP, ltmp));
+ for(j=0; j<ltmp; j++)INTEGER(ktmp)[j] = tmp2[j];
+// k???
+ SET_VECTOR_ELT(ans, p-1L, ktmp);
+ UNPROTECT(1); // ktmp
+
+ if(ci < (nt+1)){
+ tmp[0]=ci;
+ ltmp=1L;
+ }
+ else{
+ ltmp=lch[ci];
+ for(j=0; j<ltmp; j++)tmp[j] = INTEGER(VECTOR_ELT(ans, ci-1L))[j];
+ }
+ k += 1L;
+ p = pi;
+ }
+ }
+ PROTECT(ktmp = allocVector(INTSXP, ltmp));// mp+1L
+ for(j=0; j<ltmp; j++)INTEGER(ktmp)[j] = tmp2[j];
+ SET_VECTOR_ELT(ans, pi-1L, ktmp);
+ UNPROTECT(2);
+ return(ans);
+}
+
+
+SEXP C_bipart(SEXP parent, SEXP child, SEXP nTips, SEXP maxP){ //, SEXP Nnode){
+ int eins=1L, i, j, k, l=length(child), *tmp, *tmp2, *lch, *kl, pi, ci, p, nt=INTEGER(nTips)[0], mp=INTEGER(maxP)[0], ltmp;
+ SEXP ans, ktmp;
+ int nnode=1L;
+ for(i=1; i<l; i++){
+ if(INTEGER(parent)[i-1L] != INTEGER(parent)[i])nnode+=1L;
+ }
+ tmp = (int *) R_alloc(mp, sizeof(int));
+ tmp2 = (int *) R_alloc(mp, sizeof(int));
+ lch = (int *) R_alloc(mp+1L, sizeof(int));
+ kl = (int *) R_alloc(mp+1L, sizeof(int));
+// Nnode
+ PROTECT(ans = allocVector(VECSXP, nnode)); //INTEGER(Nnode)[0]));
+ p=INTEGER(parent)[0];
+ pi=INTEGER(parent)[1];
+ k=0L;
+ kl[p]=0;
+ lch[p]=1;
+ tmp[0] = INTEGER(child)[0];
+ ltmp=1L;
+ for(i=1; i<l; i++){
+ pi = INTEGER(parent)[i];
+ ci = INTEGER(child)[i];
+ if(pi==p){
+ if(ci < (nt+1L)){
+ cisort(&ci, tmp, &eins, <mp, tmp2);
+ ltmp += 1L;
+ for(j=0; j<ltmp; j++) tmp[j] = tmp2[j];
+ }
+ else{
+ cisort(INTEGER(VECTOR_ELT(ans, kl[ci])), tmp, &(lch[ci]), <mp, tmp2);
+ ltmp += lch[ci];
+ for(j=0; j<ltmp; j++) tmp[j] = tmp2[j];
+ }
+ kl[pi]=k;
+ lch[pi] = ltmp;
+ }
+ else{
+ PROTECT(ktmp = allocVector(INTSXP, ltmp));
+ for(j=0; j<ltmp; j++)INTEGER(ktmp)[j] = tmp2[j];
+// k???
+ SET_VECTOR_ELT(ans, k, ktmp);
+ UNPROTECT(1); // ktmp
+
+ if(ci < (nt+1)){
+ tmp[0]=ci;
+ ltmp=1L;
+ }
+ else{
+ ltmp=lch[ci];
+ for(j=0; j<ltmp; j++)tmp[j] = INTEGER(VECTOR_ELT(ans, kl[ci]))[j];
+ }
+ k += 1L;
+ p = pi;
+ }
+ }
+// k ??
+ PROTECT(ktmp = allocVector(INTSXP, ltmp));// mp+1L
+ for(j=0; j<ltmp; j++)INTEGER(ktmp)[j] = tmp2[j];
+ SET_VECTOR_ELT(ans, k, ktmp);
+ UNPROTECT(2);
+ return(ans);
+}
+
+
+
+
diff --git a/src/read_aa.c b/src/read_aa.c
new file mode 100644
index 0000000..bdae3a8
--- /dev/null
+++ b/src/read_aa.c
@@ -0,0 +1,153 @@
+#include <R.h>
+#include <Rinternals.h>
+
+// The initial code defining and initialising the translation table:
+//
+//"a" "r" "n" "d" "c" "q" "e" "g" "h" "i" "l" "k" "m" "f" "p" "s" "t" "w" "y" "v" "b" "z" "x"
+// "-" "?"
+//
+// for (i = 0; i < 122; i++) tab_trans[i] = 0x00;
+//
+// tab_trans[65] = 0x88; /* A */
+// tab_trans[71] = 0x48; /* G */
+// tab_trans[67] = 0x28; /* C */
+// tab_trans[84] = 0x18; /* T */
+// tab_trans[82] = 0xc0; /* R */
+// tab_trans[77] = 0xa0; /* M */
+// tab_trans[87] = 0x90; /* W */
+// tab_trans[83] = 0x60; /* S */
+// tab_trans[75] = 0x50; /* K */
+// tab_trans[89] = 0x30; /* Y */
+// tab_trans[86] = 0xe0; /* V */
+// tab_trans[72] = 0xb0; /* H */
+// tab_trans[68] = 0xd0; /* D */
+// tab_trans[66] = 0x70; /* B */
+// tab_trans[78] = 0xf0; /* N */
+//
+// tab_trans[97] = 0x88; /* a */
+// tab_trans[103] = 0x48; /* g */
+// tab_trans[99] = 0x28; /* c */
+// tab_trans[116] = 0x18; /* t */
+// tab_trans[114] = 0xc0; /* r */
+// tab_trans[109] = 0xa0; /* m */
+// tab_trans[119] = 0x90; /* w */
+// tab_trans[115] = 0x60; /* s */
+// tab_trans[107] = 0x50; /* k */
+// tab_trans[121] = 0x30; /* y */
+// tab_trans[118] = 0xe0; /* v */
+// tab_trans[104] = 0xb0; /* h */
+// tab_trans[100] = 0xd0; /* d */
+// tab_trans[98] = 0x70; /* b */
+// tab_trans[110] = 0xf0; /* n */
+//
+// tab_trans[45] = 0x04; /* - */
+// tab_trans[63] = 0x02; /* ? */
+
+
+static const int tab_trans2[] = {
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 0-9 */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 10-19 */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 20-29 */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 30-39 */
+ 0, 0, 0, 0, 0, 24, 0, 0, 0, 0, /* 40-49 */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 50-59 */
+ 0, 0, 0, 25, 0, 1, 21, 5, 4, 7, /* 60-69 */
+ 14, 8, 9, 10, 0, 12, 11, 13, 3, 0, /* 70-79 */
+ 15, 6, 2, 16, 17, 0, 20, 18, 23, 19, /* 80-89 */
+ 22, 0, 0, 0, 0, 0, 0, 1, 21, 5, /* 90-99 */
+ 4, 7, 14, 8, 9, 10, 0, 12, 11, 13, /* 100-109 */
+ 3, 0, 15, 6, 2, 16, 17, 0, 20, 18, /* 110-119 */
+ 23, 19, 22, 0, 0, 0, 0, 0, 0, 0, /* 120-129 */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 130-139 */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 140-149 */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 150-159 */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 160-169 */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 170-179 */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 180-189 */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 190-199 */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 200-209 */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 210-219 */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 220-229 */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 230-239 */
+ 0, 0, 0, 0, 0, 0, 0, 0, 0, 0, /* 240-249 */
+ 0, 0, 0, 0, 0, 0}; /* 250-255 */
+
+
+static const unsigned char hook = 0x3e;
+static const unsigned char lineFeed = 0x0a;
+/* static const unsigned char space = 0x20; */
+
+
+// needs buffer seq
+// + buffer names
+SEXP rawStream2phyDat(SEXP x)
+{
+ int N, i, j, k, n, startOfSeq;
+ unsigned char *xr, *bufferNames;
+ int *rseq, *buffer, tmp;
+ SEXP obj, nms, seq;
+
+ PROTECT(x = coerceVector(x, RAWSXP));
+ N = LENGTH(x);
+ xr = RAW(x);
+
+/* do a 1st pass to find the number of sequences
+
+ this code should be robust to '>' present inside
+ a label or in the header text before the sequences */
+
+ n = j = 0; /* use j as a flag */
+ if (xr[0] == hook) {
+ j = 1;
+ startOfSeq = 0;
+ }
+ i = 1;
+ for (i = 1; i < N; i++) {
+ if (j && xr[i] == lineFeed) {
+ n++;
+ j = 0;
+ } else if (xr[i] == hook) {
+ if (!n) startOfSeq = i;
+ j = 1;
+ }
+ }
+
+ PROTECT(obj = allocVector(VECSXP, n));
+ PROTECT(nms = allocVector(STRSXP, n));
+
+/* Refine the way the size of the buffer is set? */
+ buffer = (int *)R_alloc(N, sizeof(int *));
+ bufferNames = (unsigned char *)R_alloc(N, sizeof(unsigned char *));
+
+ i = startOfSeq;
+ j = 0; /* gives the index of the sequence */
+ while (i < N) {
+ /* 1st read the label... */
+ i++;
+ k = 0;
+ while (xr[i] != lineFeed) bufferNames[k++] = xr[i++];
+ bufferNames[k] = '\0';
+ SET_STRING_ELT(nms, j, mkChar((char *)bufferNames));
+ /* ... then read the sequence */
+ n = 0;
+ while (i < N && xr[i] != hook) {
+ tmp = tab_trans2[xr[i++]];
+/* If we are sure that the FASTA file is correct (ie, the sequence on
+ a single line and only the IUAPC code (plus '-' and '?') is used,
+ then the following check would not be needed; additionally the size
+ of tab_trans could be restriced to 0-121. This check has the
+ advantage that all invalid characters are simply ignored without
+ causing error -- except if '>' occurs in the middle of a sequence. */
+ if(tmp) buffer[n++] = tmp;
+ }
+ PROTECT(seq = allocVector(INTSXP, n));
+ rseq = INTEGER(seq);
+ for (k = 0; k < n; k++) rseq[k] = buffer[k];
+ SET_VECTOR_ELT(obj, j, seq);
+ UNPROTECT(1);
+ j++;
+ }
+ setAttrib(obj, R_NamesSymbol, nms);
+ UNPROTECT(3);
+ return obj;
+}
diff --git a/src/sankoff.c b/src/sankoff.c
new file mode 100644
index 0000000..3a1ff8c
--- /dev/null
+++ b/src/sankoff.c
@@ -0,0 +1,256 @@
+/*
+ * dist.c
+ *
+ * (c) 2008-2015 Klaus Schliep (klaus.schliep at gmail.com)
+ *
+ *
+ * This code may be distributed under the GNU GPL
+ *
+ */
+
+
+# define USE_RINTERNALS
+
+#include <Rmath.h>
+#include <math.h>
+#include <R.h>
+#include <R_ext/Lapack.h>
+#include <Rinternals.h>
+
+
+
+
+SEXP C_rowMin(SEXP sdat, SEXP sn, SEXP sk){
+ int i, h, n=INTEGER(sn)[0], k=INTEGER(sk)[0];
+ double x, *res, *dat;
+ SEXP result;
+ PROTECT(result = allocVector(REALSXP, n));
+ res = REAL(result);
+ PROTECT(sdat = coerceVector(sdat, REALSXP));
+ dat = REAL(sdat);
+ for(i = 0; i < n; i++){
+ x = dat[i];
+ for(h = 1; h< k; h++) {if(dat[i + h*n] < x) x=dat[i + h*n];}
+ res[i] = x;
+ }
+ UNPROTECT(2);
+ return(result);
+}
+
+
+void rowMin2(double *dat, int n, int k, double *res){
+ int i, h;
+ double x;
+ for(i = 0; i < n; i++){
+ x = dat[i];
+ for(h = 1; h< k; h++) {if(dat[i + h*n] < x) x=dat[i + h*n];}
+ res[i] = x;
+ }
+ }
+
+
+void rowMinInt(int *dat, int n, int k, double *res){
+ int i, h;
+ int x;
+ for(i = 0; i < n; i++){
+ x = dat[i];
+ for(h = 1; h< k; h++) {if(dat[i + h*n] < x) x=dat[i + h*n];}
+ res[i] = x;
+ }
+ }
+
+
+void sankoff4(double *dat, int n, double *cost, int k, double *result){
+ int i, j, h;
+ double tmp[k], x;
+ for(i = 0; i < n; i++){
+ for(j = 0; j < k; j++){
+ for(h = 0; h< k; h++){tmp[h] = dat[i + h*n] + cost[h + j*k];}
+ x = tmp[0];
+ for(h = 1; h< k; h++) {if(tmp[h]<x) {x=tmp[h];}}
+ result[i+j*n] += x;
+ }
+ }
+}
+
+
+SEXP sankoffQuartet(SEXP dat, SEXP sn, SEXP scost, SEXP sk){
+ int j, n=INTEGER(sn)[0], k = INTEGER(sk)[0];
+ double *cost, *res, *rtmp;
+ SEXP result;
+ PROTECT(result = allocVector(REALSXP, n));
+ rtmp = (double *) R_alloc(n*k, sizeof(double));
+ res = (double *) R_alloc(n*k, sizeof(double));
+ PROTECT(scost = coerceVector(scost, REALSXP));
+ cost = REAL(scost);
+ for(j=0; j<(n*k); j++) rtmp[j] = 0.0;
+ for(j=0; j<(n*k); j++) res[j] = 0.0;
+ sankoff4(REAL(VECTOR_ELT(dat,0)), n, cost, k, rtmp);
+ sankoff4(REAL(VECTOR_ELT(dat,1)), n, cost, k, rtmp);
+ sankoff4(rtmp, n, cost, k, res);
+ sankoff4(REAL(VECTOR_ELT(dat,2)), n, cost, k, res);
+ sankoff4(REAL(VECTOR_ELT(dat,3)), n, cost, k, res);
+ rowMin2(res, n, k, REAL(result)); //res, sn sk
+ UNPROTECT(2);
+ return(result);
+}
+
+
+SEXP sankoff3(SEXP dlist, SEXP scost, SEXP nr, SEXP nc, SEXP node, SEXP edge, SEXP mNodes, SEXP tips){
+ R_len_t i, n = length(node), nt = length(tips);
+ int nrx=INTEGER(nr)[0], ncx=INTEGER(nc)[0], mn=INTEGER(mNodes)[0];
+ int ni, ei, j, *edges=INTEGER(edge), *nodes=INTEGER(node);
+ SEXP result, dlist2; //tmp,
+ double *res, *cost; // *rtmp,
+ cost = REAL(scost);
+ if(!isNewList(dlist)) error("'dlist' must be a list");
+ ni = nodes[0];
+ PROTECT(dlist2 = allocVector(VECSXP, mn));
+ PROTECT(result = allocMatrix(REALSXP, nrx, ncx));
+ res = REAL(result);
+ for(i = 0; i < nt; i++) SET_VECTOR_ELT(dlist2, INTEGER(tips)[i], VECTOR_ELT(dlist, INTEGER(tips)[i]));
+ for(j=0; j<(nrx * ncx); j++) res[j] = 0.0;
+
+ for(i = 0; i < n; i++) {
+ ei = edges[i];
+ if(ni == nodes[i]){
+ sankoff4(REAL(VECTOR_ELT(dlist2,ei)), nrx, cost, ncx, res);
+ }
+ else{
+ SET_VECTOR_ELT(dlist2, ni, result);
+ UNPROTECT(1);
+ PROTECT(result = allocMatrix(REALSXP, nrx, ncx));
+ res = REAL(result);
+ for(j=0; j<(nrx * ncx); j++) res[j] = 0.0;
+ ni = nodes[i];
+ sankoff4(REAL(VECTOR_ELT(dlist2,ei)), nrx, cost, ncx, res);
+ }
+ }
+ SET_VECTOR_ELT(dlist2, ni, result);
+ UNPROTECT(2);
+ return(dlist2);
+}
+
+
+
+void sankoffTips(int *x, double *tmp, int nr, int nc, int nrs, double *result){
+ int i, j;
+ for(i = 0; i < (nr); i++){
+ for(j = 0; j < (nc); j++) result[i + j*(nr)] += tmp[x[i] - 1L + j*(nrs)];
+ }
+}
+
+
+// sankoffNew
+SEXP sankoff3B(SEXP dlist, SEXP scost, SEXP nr, SEXP nc, SEXP node, SEXP edge, SEXP mNodes, SEXP tips, SEXP contrast, SEXP nrs){
+ R_len_t i, n = length(node); //, nt = length(tips);
+ int nrx=INTEGER(nr)[0], ncx=INTEGER(nc)[0], mn=INTEGER(mNodes)[0], nrc = INTEGER(nrs)[0];
+ int ni, ei, j, *edges=INTEGER(edge), *nodes=INTEGER(node), ntips=INTEGER(tips)[0];
+ SEXP result, dlist2; //tmp,
+ double *res, *cost, *tmp; // *rtmp,
+ tmp = (double *) R_alloc(ncx * nrc, sizeof(double));
+ for(j=0; j<(ncx * nrc); j++) tmp[j] = 0.0;
+ cost = REAL(scost);
+ sankoff4(REAL(contrast), nrc, cost, ncx, tmp);
+
+ if(!isNewList(dlist)) error("'dlist' must be a list");
+ ni = nodes[0];
+ PROTECT(dlist2 = allocVector(VECSXP, mn));
+ PROTECT(result = allocMatrix(REALSXP, nrx, ncx));
+ res = REAL(result);
+// die naechte Zeile vielleicht raus
+// for(i = 0; i < nt; i++) SET_VECTOR_ELT(dlist2, INTEGER(tips)[i], VECTOR_ELT(dlist, INTEGER(tips)[i]));
+ for(j=0; j<(nrx * ncx); j++) res[j] = 0.0;
+
+ for(i = 0; i < n; i++) {
+ ei = edges[i];
+ if(ni == nodes[i]){
+ if(ei < ntips) sankoffTips(INTEGER(VECTOR_ELT(dlist,ei)), tmp, nrx, ncx, nrc, res);
+ else sankoff4(REAL(VECTOR_ELT(dlist2,ei)), nrx, cost, ncx, res);
+ }
+ else{
+ SET_VECTOR_ELT(dlist2, ni, result);
+ UNPROTECT(1);
+ PROTECT(result = allocMatrix(REALSXP, nrx, ncx));
+ res = REAL(result);
+ for(j=0; j<(nrx * ncx); j++) res[j] = 0.0;
+ ni = nodes[i];
+ if(ei < ntips) sankoffTips(INTEGER(VECTOR_ELT(dlist,ei)), tmp, nrx, ncx, nrc, res);
+ else sankoff4(REAL(VECTOR_ELT(dlist2,ei)), nrx, cost, ncx, res);
+ }
+ }
+ SET_VECTOR_ELT(dlist2, ni, result);
+ UNPROTECT(2);
+ return(dlist2);
+}
+
+
+SEXP pNodes(SEXP data, SEXP scost, SEXP nr, SEXP nc, SEXP node, SEXP edge){
+ R_len_t n = length(node);
+ int nrx=INTEGER(nr)[0], ncx=INTEGER(nc)[0];
+ int k, pj, i, j, start, *edges=INTEGER(edge), *nodes=INTEGER(node);
+ SEXP result, dlist;
+ double *res, *tmp, *cost;
+ cost = REAL(scost);
+ pj = nodes[n-1L];
+ start = n-1L;
+ PROTECT(dlist = allocVector(VECSXP, length(data)));
+ tmp = (double *) R_alloc(nrx*ncx, sizeof(double));
+ for(i=0; i<(nrx * ncx); i++) tmp[i] = 0.0;
+ for(j=n-1L; j>=0; j--) {
+ PROTECT(result = allocMatrix(REALSXP, nrx, ncx));
+ res = REAL(result);
+ if (pj != nodes[j]) {
+ for(i=0; i<(nrx * ncx); i++) tmp[i] = 0.0;
+ sankoff4(REAL(VECTOR_ELT(dlist, nodes[j])), nrx, cost, ncx, tmp);
+ for(i=0; i<(nrx * ncx); i++) res[i] = tmp[i] ;
+ pj = nodes[j];
+ start = j;
+ }
+ else for(i=0; i<(nrx * ncx); i++) res[i] = tmp[i] ;
+ k = start;
+ while (k >= 0 && pj == nodes[k]) {
+ if (k != j)
+ sankoff4(REAL(VECTOR_ELT(data, edges[k])), nrx, cost, ncx, res);
+ k--;
+ }
+ SET_VECTOR_ELT(dlist, edges[j], result);
+ UNPROTECT(1);
+ }
+ UNPROTECT(1);
+ return(dlist);
+}
+
+
+SEXP sankoffMPR(SEXP dlist, SEXP plist, SEXP scost, SEXP nr, SEXP nc, SEXP node, SEXP edge){
+ R_len_t i, n = length(node);
+ int nrx=INTEGER(nr)[0], ncx=INTEGER(nc)[0], n0;
+ int ei, j, *nodes=INTEGER(node), *edges=INTEGER(edge);
+ SEXP result, dlist2; //tmp,
+ double *res, *cost; // *rtmp,
+ cost = REAL(scost);
+ n0 = nodes[n-1L];
+ PROTECT(dlist2 = allocVector(VECSXP, n+1L));
+ PROTECT(result = allocMatrix(REALSXP, nrx, ncx));
+ res = REAL(result);
+ for(j=0;j<(nrx*ncx);j++)res[j]=0.0;
+ for(j=n-1L; j>=0; j--) {
+ if(nodes[j]!=n0){
+ SET_VECTOR_ELT(dlist2, n0, result);
+ UNPROTECT(1);
+ n0 = nodes[j];
+ PROTECT(result = allocMatrix(REALSXP, nrx, ncx));
+ res = REAL(result);
+ for(i=0; i<(nrx * ncx); i++) res[i] = 0.0;
+ sankoff4(REAL(VECTOR_ELT(plist,nodes[j])), nrx, cost, ncx, res);
+ }
+ ei = edges[j];
+ sankoff4(REAL(VECTOR_ELT(dlist,ei)), nrx, cost, ncx, res);
+
+ }
+ SET_VECTOR_ELT(dlist2, n0, result);
+ UNPROTECT(2);
+ return(dlist2);
+}
+
+
diff --git a/vignettes/Ancestral.Rnw b/vignettes/Ancestral.Rnw
new file mode 100644
index 0000000..09473be
--- /dev/null
+++ b/vignettes/Ancestral.Rnw
@@ -0,0 +1,171 @@
+%\VignetteIndexEntry{Ancestral Sequence Reconstruction}
+%\VignetteKeywords{Documentation}
+%\VignettePackage{phangorn}
+%\VignetteEngine{Sweave}
+\documentclass[12pt]{article}
+
+\usepackage{times}
+\usepackage{hyperref}
+
+\newcommand{\Rfunction}[1]{{\texttt{#1}}}
+\newcommand{\Robject}[1]{{\texttt{#1}}}
+\newcommand{\Rpackage}[1]{{\textit{#1}}}
+\newcommand{\Rmethod}[1]{{\texttt{#1}}}
+\newcommand{\Rfunarg}[1]{{\texttt{#1}}}
+\newcommand{\Rclass}[1]{{\textit{#1}}}
+
+\textwidth=6.2in
+\textheight=8.5in
+%\parskip=.3cm
+\oddsidemargin=.1in
+\evensidemargin=.1in
+\headheight=-.3in
+
+\newcommand{\R}{\textsf{R}}
+\newcommand{\pml}{\Robject{pml}}
+\newcommand{\phangorn}{\Rpackage{phangorn}}
+\newcommand{\ape}{\Rpackage{ape}}
+\newcommand{\multicore}{\Rpackage{multicore}}
+
+\newcommand{\term}[1]{\emph{#1}}
+\newcommand{\mref}[2]{\htmladdnormallinkfoot{#2}{#1}}
+
+
+
+\begin{document}
+
+% Ross Ihakas extenstion for nicer representation
+\DefineVerbatimEnvironment{Sinput}{Verbatim} {xleftmargin=2em}
+\DefineVerbatimEnvironment{Soutput}{Verbatim}{xleftmargin=2em}
+\DefineVerbatimEnvironment{Scode}{Verbatim}{xleftmargin=2em}
+\fvset{listparameters={\setlength{\topsep}{0pt}}}
+\renewenvironment{Schunk}{\vspace{\topsep}}{\vspace{\topsep}}
+
+<<echo=FALSE>>=
+options(width=70)
+foo <- packageDescription("phangorn")
+@
+
+
+
+\title{Ancestral sequence reconstruction with phangorn (Version \Sexpr{foo$Version})} %$
+\author{\mref{mailto:klaus.schliep at gmail.com}{Klaus P. Schliep}}
+\maketitle
+
+\nocite{Paradis2006}
+\section{Introduction}
+
+These notes describe the ancestral sequence reconstruction using the \phangorn{} package \cite{Schliep2011}. \phangorn{} provides several methods to estimate ancestral character states with either Maximum Parsimony (MP) or Maximum Likelihood (ML). %For more background on all the methods see e.g. \cite{Felsenstein2004, Yang2006}.
+\section{Parsimony reconstructions}
+To reconstruct ancestral sequences we first load some data and reconstruct a tree:
+<<echo=TRUE>>=
+library(phangorn)
+primates = read.phyDat("primates.dna", format = "phylip", type = "DNA")
+tree = pratchet(primates, trace=0)
+tree = acctran(tree, primates)
+parsimony(tree, primates)
+@
+
+For parsimony analysis of the edge length represent the observed number of changes. Reconstructing ancestral states therefore defines also the edge lengths of a tree. However there can exist several equally parsimonious reconstructions or states can be ambiguous and therefore edge length can differ. %\phangorn{} brakes them equally down.
+"MPR" reconstructs the ancestral states for each (internal) node as if the tree would be rooted in that node. However the nodes are not independent of each other. If one chooses one state for a specific node, this can restrict the choice of neighbouring nodes (figure \ref{fig:Pars}).
+The function acctran (accelerated transformation) assigns edge length and internal nodes to the tree \cite{Swofford1987}.
+<<echo=TRUE>>=
+anc.acctran = ancestral.pars(tree, primates, "ACCTRAN")
+anc.mpr = ancestral.pars(tree, primates, "MPR")
+@
+
+All the ancestral reconstructions for parsimony are based on the fitch algorithm and so far only bifurcating trees are allowed. However trees can get pruned afterwards using the function \Rfunction{multi2di} from \ape{}.
+
+
+<<label=plotLOGO,include=FALSE>>=
+tmp <- require(seqLogo)
+if(tmp) seqLogo( t(subset(anc.mpr, getRoot(tree), 1:20)[[1]]), ic.scale=FALSE)
+@
+\begin{figure}
+\begin{center}
+<<label=figLOGO,fig=TRUE,echo=FALSE,width=6,height=4>>=
+<<plotLOGO>>
+@
+\caption{Representation for the reconstruction of the first 20 characters for the root node.}
+\end{center}
+\end{figure}
+
+<<echo=false>>=
+options(SweaveHooks=list(fig=function()
+par(mar=c(2.1, 4.1, 2.1, 2.1))))
+@
+
+<<label=plotMPR,include=FALSE>>=
+par(mfrow=c(2,1))
+plotAnc(tree, anc.mpr, 17)
+title("MPR")
+plotAnc(tree, anc.acctran, 17)
+title("ACCTRAN")
+@
+\begin{figure}
+\begin{center}
+<<label=figMPR,fig=TRUE,echo=FALSE,width=6,height=9>>=
+<<plotMPR>>
+@
+\caption{Ancestral reconstruction for one character for the "MPR" and "ACCTRAN" reconstruction.
+When nodes contain several colours reconstruction is not unique!}\label{fig:Pars}
+\end{center}
+\end{figure}
+
+
+
+\section{Likelihood reconstructions}
+
+\phangorn{} also offers the possibility to estimate ancestral states using a ML.
+The advantages of ML over parsimony is that the reconstruction accounts for different edge lengths.
+So far only a marginal construction is implemented (see \cite{Yang2006}).
+<<echo=TRUE>>=
+fit = pml(tree, primates)
+fit = optim.pml(fit, model="F81", control = pml.control(trace=0))
+@
+We can assign the ancestral states according to the highest likelihood ("ml"):
+\[
+P(x_r = A) = \frac{L(x_r=A)}{\sum_{k \in \{A,C,G,T\}}L(x_r=k)}
+\]
+and the highest posterior probability ("bayes") criterion:
+\[
+P(x_r=A) = \frac{\pi_A L(x_r=A)}{\sum_{k \in \{A,C,G,T\}}\pi_k L(x_r=k)},
+\]
+where $L(x_r)$ is the joint probability of states at the tips and the state at the root $x_r$ and $\pi_i$ are the estimated base frequencies of state $i$.
+Both methods agree if all states (base frequencies) have equal probabilities.
+<<echo=TRUE>>=
+anc.ml = ancestral.pml(fit, "ml")
+anc.bayes = ancestral.pml(fit, "bayes")
+@
+The differences of the two approaches for a specific site (17) are represented in figure\ref{fig:MLB}.
+<<label=plotMLB,include=FALSE>>=
+par(mfrow=c(2,1))
+plotAnc(tree, anc.ml, 17)
+title("ML")
+plotAnc(tree, anc.bayes, 17)
+title("Bayes")
+@
+\begin{figure}
+\begin{center}
+<<label=figMLB,fig=TRUE,echo=FALSE,width=6,height=9>>=
+<<plotMLB>>
+@
+\caption{Ancestral reconstruction for fig.\ref{fig:Pars} the using the maximum likelihood and (empirical) Bayesian reconstruction.}\label{fig:MLB}
+\end{center}
+\end{figure}
+
+\bibliographystyle{plain}
+\bibliography{phangorn}
+
+\section{Session Information}
+The version number of \R{} and packages loaded for generating the vignette were:
+<<echo=FALSE,results=tex>>=
+toLatex(sessionInfo())
+@
+
+\end{document}
+
+
+
+
+
diff --git a/vignettes/Networx.Rmd b/vignettes/Networx.Rmd
new file mode 100644
index 0000000..8acfaf9
--- /dev/null
+++ b/vignettes/Networx.Rmd
@@ -0,0 +1,96 @@
+---
+title: "Splits and Networx"
+author: "Klaus Schliep"
+date: "`r format(Sys.time(), '%B %d, %Y')`"
+output: rmarkdown::html_vignette
+bibliography: phangorn.bib
+vignette: >
+ %\VignetteIndexEntry{Splits and Networx}
+ %\VignetteEngine{knitr::rmarkdown}
+ %\usepackage[utf8]{inputenc}
+---
+
+
+This tutorial gives a basic introduction on constructing phylogenetic networks and to add parameter to trees or networx using [phangorn](http://cran.r-project.org/web/packages/phangorn/) [@Schliep2011] in R.
+Splits graph or phylogenetic networks are a nice way to display conflict data or summarize different trees. Here we present to popular networks, consensus networks [@Holland2004]
+and neighborNet [@Bryant2004].
+Often trees or networks are missing either edge weights or support values about the edges. We show how to improve a tree/networx by adding support values or estimating edge weights using non-negative Least-Squares (nnls).
+
+We first load the phangorn package and a few data sets we use in this vignette.
+```{r, eval=TRUE}
+library(phangorn)
+data(Laurasiatherian)
+data(yeast)
+```
+## consensusNet
+A consensusNet [@Holland2004] is a generalization of a consensus tree. Instead only representing splits with at least 50% in a bootstrap or MCMC sample one can use a lower threshold. However of important competing splits are left out.
+
+The input for `consensusNet` is a list of trees i.e. an object of class `multiPhylo`.
+```{r, eval=TRUE}
+set.seed(1)
+bs <- bootstrap.phyDat(yeast, FUN = function(x)nj(dist.hamming(x)),
+ bs=100)
+tree <- nj(dist.hamming(yeast))
+par("mar" = rep(2, 4))
+tree <- plotBS(tree, bs, "phylogram")
+cnet <- consensusNet(bs, .3)
+plot(cnet, "2D", show.edge.label=TRUE)
+```
+
+Often `consensusNet` will return incompatible splits, which cannot plotted as a planar graph. A nice way to get still a good impression of the network is to plot it in 3 dimensions.
+
+```{r, eval=FALSE}
+plot(cnet)
+# rotate 3d plot
+play3d(spin3d(axis=c(0,1,0), rpm=6), duration=10)
+# create animated gif file
+movie3d(spin3d(axis=c(0,1,0), rpm=6), duration=10)
+```
+
+which will result in a spinning graph similar to this
+
+
+
+
+## neighborNet
+The function `neighborNet` implements the popular method of @Bryant2004. The Neighbor-Net algorithm extends the Neighbor joining allowing again algorithm is computed in 2 parts, the first computes a circular ordering. The second step involves estimation of edge weights using non-negative Least-Squares (nnls).
+
+```{r, eval=TRUE}
+dm <- dist.hamming(yeast)
+nnet <- neighborNet(dm)
+par("mar" = rep(2, 4))
+plot(nnet, "2D")
+```
+
+The advantage of Neighbor-Net is that it returns a circular split system which can be always displayed in a planar (2D) graph. The plots displayed in `phangorn` may not planar, but re-plotting may gives you a planar graph. This unwanted behavior will be improved in future version.
+The rendering of the `networx` is done using the the fantastic igraph package [@Csardi2006].
+
+
+## Adding support values
+
+We can use the generic function `addConfidences` to add support values from a tree, i.e. an object of class `phylo` to a `networx`, `splits` or `phylo` object. The Neighbor-Net object we computed above contains no support values. We can add the support values fro the tree we computed to the splits these two objects share.
+```{r, eval=TRUE}
+nnet <- addConfidences(nnet, tree)
+par("mar" = rep(2, 4))
+plot(nnet, "2D", show.edge.label=TRUE)
+```
+
+We can also add support values to a tree:
+```{r, eval=TRUE}
+tree2 <- rNNI(tree, 2)
+tree2 <- addConfidences(tree2, tree)
+# several support values are missing
+plot(tree2, show.node.label=TRUE)
+```
+
+## Estimating edge weights (nnls)
+
+Consensus networks on the other hand have information about support values corresponding to a split, but are generally without edge weights.
+Given a distance matrix we can estimate edge weights using non-negative Least-Squares.
+```{r, eval=TRUE}
+cnet <- nnls.networx(cnet, dm)
+par("mar" = rep(2, 4))
+plot(cnet, "2D", show.edge.label=TRUE)
+```
+
+## References
diff --git a/vignettes/Trees.RData b/vignettes/Trees.RData
new file mode 100644
index 0000000..59a91ab
Binary files /dev/null and b/vignettes/Trees.RData differ
diff --git a/vignettes/Trees.Rnw b/vignettes/Trees.Rnw
new file mode 100644
index 0000000..6af3b5a
--- /dev/null
+++ b/vignettes/Trees.Rnw
@@ -0,0 +1,256 @@
+%\VignetteIndexEntry{Constructing phylogenetic trees}
+%\VignetteKeywords{Documentation}
+%\VignettePackage{phangorn}
+%\VignetteEngine{Sweave}
+\documentclass[12pt]{article}
+
+\usepackage{times}
+\usepackage{hyperref}
+
+
+\begin{document}
+
+\newcommand{\Rfunction}[1]{{\texttt{#1}}}
+\newcommand{\Robject}[1]{{\texttt{#1}}}
+\newcommand{\Rpackage}[1]{{\textit{#1}}}
+\newcommand{\Rmethod}[1]{{\texttt{#1}}}
+\newcommand{\Rfunarg}[1]{{\texttt{#1}}}
+\newcommand{\Rclass}[1]{{\textit{#1}}}
+
+\textwidth=6.2in
+\textheight=8.5in
+%\parskip=.3cm
+\oddsidemargin=.1in
+\evensidemargin=.1in
+\headheight=-.3in
+
+\newcommand{\R}{\textsf{R}}
+\newcommand{\pml}{\Robject{pml}}
+\newcommand{\phangorn}{\Rpackage{phangorn}}
+\newcommand{\ape}{\Rpackage{ape}}
+\newcommand{\multicore}{\Rpackage{multicore}}
+
+\newcommand{\term}[1]{\emph{#1}}
+\newcommand{\mref}[2]{\htmladdnormallinkfoot{#2}{#1}}
+
+% leave comments in the text
+\SweaveOpts{keep.source=TRUE}
+
+
+
+% Ross Ihakas extenstion for nicer representation
+\DefineVerbatimEnvironment{Sinput}{Verbatim} {xleftmargin=2em}
+\DefineVerbatimEnvironment{Soutput}{Verbatim}{xleftmargin=2em}
+\DefineVerbatimEnvironment{Scode}{Verbatim}{xleftmargin=2em}
+\fvset{listparameters={\setlength{\topsep}{0pt}}}
+\renewenvironment{Schunk}{\vspace{\topsep}}{\vspace{\topsep}}
+
+<<echo=FALSE>>=
+options(width=70)
+foo <- packageDescription("phangorn")
+@
+
+
+\title{Estimating phylogenetic trees with phangorn} %$ (Version \Sexpr{foo$Version})}
+\author{\mref{mailto:klaus.schliep at gmail.com}{Klaus P. Schliep}}
+\maketitle
+
+\nocite{Paradis2012}
+\section{Introduction}
+
+These notes should enable the user to estimate phylogenetic trees from alignment data with different methods using the \phangorn{} package \cite{Schliep2011}. Several functions of \phangorn{} are also described in more detail in \cite{Paradis2012}. For more theoretical background on all the methods see e.g. \cite{Felsenstein2004, Yang2006}. This document illustrates some of the \phangorn{} features to estimate phylogenetic trees using different reconstruction methods. Small adaptations t [...]
+\section{Getting started}
+The first thing we have to do is to read in an alignment. Unfortunately there exists many different file formats that alignments can be stored in. The function \Rfunction{read.phyDat} is used to read in an alignment. There are several functions to read in alignments depending on the format of the data set (nexus, phylip, fasta) and the kind of data (amino acid or nucleotides) in the \ape{} package \cite{Paradis2004} and \phangorn{}. The function \Rfunction{read.phyDat} calls these other [...]
+%When using the \Rfunction{read.dna} from \ape{} the parameter the we have to use as.character=TRUE.
+We start our analysis loading the \phangorn{} package and then reading in an alignment.
+<<echo=TRUE>>=
+library(phangorn)
+primates = read.phyDat("primates.dna", format="phylip", type="DNA")
+@
+%require("multicore")
+\section{Distance based methods}
+After reading in the alignment we can build a first tree with distance based methods. The function dist.dna from the ape package computes distances for many DNA substitution models. To use the function dist.dna we have to transform the data to class DNAbin. For amino acids the function dist.ml offers common substitution models ("WAG", "JTT", "LG", "Dayhoff", "cpREV", "mtmam", "mtArt", "MtZoa" and "mtREV24").
+
+After constructing a distance matrix we reconstruct a rooted tree with UPGMA and alternatively an unrooted tree using Neighbor Joining \cite{Saitou1987,Studier1988}.
+<<echo=TRUE>>=
+dm = dist.dna(as.DNAbin(primates))
+treeUPGMA = upgma(dm)
+treeNJ = NJ(dm)
+@
+We can plot the trees treeUPGMA and treeNJ (figure \ref{fig:NJ}) with the commands:
+<<label=plotNJ,include=FALSE>>=
+layout(matrix(c(1,2), 2, 1), height=c(1,2))
+par(mar = c(.1,.1,.1,.1))
+plot(treeUPGMA, main="UPGMA")
+plot(treeNJ, "unrooted", main="NJ")
+@
+\begin{figure}
+\begin{center}
+<<label=figNJ,fig=TRUE,echo=FALSE>>=
+<<plotNJ>>
+@
+\end{center}
+\caption{Rooted UPGMA tree and unrooted NJ tree}
+\label{fig:NJ}
+\end{figure}
+Distance based methods are very fast and we will use the UPGMA and NJ tree as starting trees for the maximum parsimony and maximum likelihood analyses.
+
+\section{Parsimony}
+The function parsimony returns the parsimony score, that is the number of changes which are at least necessary to describe the data for a given tree. We can compare the parsimony score or the two trees we computed so far:
+<<echo=TRUE>>=
+parsimony(treeUPGMA, primates)
+parsimony(treeNJ, primates)
+@
+The function optim.parsimony performs tree rearrangements to find trees with a lower parsimony score. So far the only tree rearrangement implemented is nearest-neighbor interchanges (NNI). However is also a version of the parsimony ratchet \cite{Nixon1999} implemented, which is likely to find better trees than just doing NNI rearrangements.
+<<echo=TRUE>>=
+treePars = optim.parsimony(treeUPGMA, primates)
+treeRatchet = pratchet(primates, trace = 0)
+parsimony(c(treePars, treeRatchet), primates)
+@
+For small data sets it is also possible to find all most parsimonious trees using a branch and bound algorithm \cite{Hendy1982}. For data sets with more than 10 taxa this can take a long time and depends strongly on how tree like the data are.
+<<echo=TRUE, eval=FALSE>>=
+(trees <- bab(subset(primates,1:10)))
+@
+
+\section{Maximum likelihood}
+The last method we will describe in this vignette is Maximum Likelihood (ML) as introduced by Felsenstein \cite{Felsenstein1981}.
+We can easily compute the likelihood for a tree given the data
+<<echo=TRUE>>=
+fit = pml(treeNJ, data=primates)
+fit
+@
+The function pml returns an object of class pml. This object contains the data, the tree and many different parameters of the model like the likelihood etc. There are many generic functions for the class pml available, which allow the handling of these objects.
+<<echo=TRUE>>=
+methods(class="pml")
+@
+The object fit just estimated the likelihood for the tree it got supplied, but the branch length are not optimized for the Jukes-Cantor model yet, which can be done with the function optim.pml.
+<<echo=TRUE, results=hide>>=
+fitJC = optim.pml(fit, TRUE)
+logLik(fitJC)
+@
+With the default values \Rfunction{pml} will estimate a Jukes-Cantor model. The function \Rfunction{update.pml} allows to change parameters. We will change the model to the GTR + $\Gamma(4)$ + I model and then optimize all the parameters.
+<<echo=TRUE>>=
+fitGTR = update(fit, k=4, inv=0.2)
+fitGTR = optim.pml(fitGTR, TRUE,TRUE, TRUE, TRUE, TRUE,
+ control = pml.control(trace = 0))
+fitGTR
+@
+We can compare the objects for the JC and GTR + $\Gamma(4)$ + I model using likelihood ratio statistic
+<<echo=TRUE>>=
+anova(fitJC, fitGTR)
+@
+with the AIC
+<<echo=TRUE>>=
+AIC(fitGTR)
+AIC(fitJC)
+@
+or the Shimodaira-Hasegawa test.
+<<echo=TRUE>>=
+SH.test(fitGTR, fitJC)
+@
+An alternative is to use the function \Rfunction{modelTest} to compare different models the AIC or BIC, similar to popular program of \cite{Posada1998, Posada2008}.
+<<echo=FALSE>>=
+load("Trees.RData")
+@
+<<echo=TRUE, eval=FALSE>>=
+mt = modelTest(primates)
+@
+The results of is illustrated in table \ref{tab:modelTest}
+\begin{center}
+<<echo=FALSE,results=tex>>=
+library(xtable)
+xtable(mt, caption="Summary table of modelTest", label="tab:modelTest")
+@
+\end{center}
+The thresholds for the optimization in \Rfunction{modelTest} are not as strict as for \Rfunction{optim.pml} and no tree rearrangements are performed. As \Rfunction{modelTest} computes and optimizes a lot of models it would be a waste of computer time not to save these results. The results are saved as call together with the optimized trees in an environment and this call can be evaluated to get a "pml" object back to use for further optimization or analysis.
+<<echo=TRUE>>=
+env <- attr(mt, "env")
+ls(envir=env)
+(fit <- eval(get("HKY+G+I", env), env))
+@
+
+At last we may want to apply bootstrap to test how well the edges of the tree are supported: %, results=hide
+<<echo=TRUE, eval=FALSE>>=
+bs = bootstrap.pml(fitJC, bs=100, optNni=TRUE,
+ control = pml.control(trace = 0))
+@
+
+%$
+Now we can plot the tree with the bootstrap support values on the edges
+<<label=plotBS,include=FALSE>>=
+par(mar=c(.1,.1,.1,.1))
+plotBS(fitJC$tree, bs)
+@
+%$
+\begin{figure}
+\begin{center}
+<<label=figBS,fig=TRUE,echo=FALSE>>=
+<<plotBS>>
+@
+\end{center}
+\caption{Unrooted tree with bootstrap support values}
+\label{fig:BS}
+\end{figure}
+
+Several analyses, e.g. \Rfunction{bootstrap} and \Rfunction{modelTest}, can be computationally demanding, but as nowadays most computers have several cores one can distribute the computations using the \multicore{} package. However it is only possible to use this approach if R is running from command line ("X11"), but not using a GUI (for example "Aqua" on Macs) and unfortunately the \multicore{} package does not work at all under Windows.
+\section{Appendix: Standard scripts for nucleotide or amino acid analysis}\label{sec:Appendix}
+Here we provide two standard scripts which can be adapted for the most common tasks.
+Most likely the arguments for \Rfunction{read.phyDat} have to be adapted to accommodate your file format. Both scripts assume that the \multicore{} package, see comments above.
+<<echo=FALSE>>=
+options(prompt=" ")
+options(continue=" ")
+@
+<<eval=FALSE>>=
+library(parallel) # supports parallel computing
+library(phangorn)
+file="myfile"
+dat = read.phyDat(file)
+dm = dist.ml(dat)
+tree = NJ(dm)
+# as alternative for a starting tree:
+tree <- pratchet(dat)
+
+# 1. alternative: estimate an GTR model
+fitStart = pml(tree, dat, k=4, inv=.2)
+fit = optim.pml(fitStart, TRUE, TRUE, TRUE, TRUE, TRUE)
+
+# 2. alternative: modelTest
+(mt <- modelTest(dat, multicore=TRUE))
+mt$Model[which.min(mt$BIC)]
+# choose best model from the table, assume now GTR+G+I
+env = attr(mt, "env")
+fitStart = eval(get("GTR+G+I", env), env)
+fitStart = eval(get(mt$Model[which.min(mt$BIC)], env), env)
+fit = optim.pml(fitStart, optNni=TRUE, optGamma=TRUE, optInv=TRUE,
+ model="GTR")
+bs = bootstrap.pml(fit, bs=100, optNni=TRUE, multicore=TRUE)
+@
+
+You can specify different several models build in which you can specify, e.g. "WAG", "JTT", "Dayhoff", "LG". Optimizing the rate matrix for amino acids is possible, but would take a long, a very long time. So make sure to set optBf=FALSE and optQ=FALSE in the function \Rfunction{optim.pml}, which is also the default.
+<<eval=FALSE>>=
+library(parallel) # supports parallel computing
+library(phangorn)
+file="myfile"
+dat = read.phyDat(file, type = "AA")
+dm = dist.ml(dat, model="JTT")
+tree = NJ(dm)
+
+(mt <- modelTest(dat, model=c("JTT", "LG", "WAG"), multicore=TRUE))
+fitStart = eval(get(mt$Model[which.min(mt$BIC)], env), env)
+
+fitNJ = pml(tree, dat, model="JTT", k=4, inv=.2)
+fit = optim.pml(fitNJ, optNni=TRUE, optInv=TRUE, optGamma=TRUE)
+fit
+bs = bootstrap.pml(fit, bs=100, optNni=TRUE, multicore=TRUE)
+@
+
+\bibliographystyle{plain}
+\bibliography{phangorn}
+
+\section{Session Information}
+The version number of \R{} and packages loaded for generating the vignette were:
+<<echo=FALSE,results=tex>>=
+toLatex(sessionInfo())
+@
+\end{document}
+
diff --git a/vignettes/exdna.txt b/vignettes/exdna.txt
new file mode 100644
index 0000000..aa19eed
--- /dev/null
+++ b/vignettes/exdna.txt
@@ -0,0 +1,4 @@
+3 40
+No305 NTTCGAAAAACACACCCACTACTAAAANTTATCAGTCACT
+No304 ATTCGAAAAACACACCCACTACTAAAAATTATCAACCACT
+No306 ATTCGAAAAACACACCCACTACTAAAAATTATCAATCACT
diff --git a/vignettes/movie.gif b/vignettes/movie.gif
new file mode 100644
index 0000000..6d8b670
Binary files /dev/null and b/vignettes/movie.gif differ
diff --git a/vignettes/phangorn-specials.Rnw b/vignettes/phangorn-specials.Rnw
new file mode 100644
index 0000000..9d33093
--- /dev/null
+++ b/vignettes/phangorn-specials.Rnw
@@ -0,0 +1,258 @@
+%\VignetteIndexEntry{Advanced features}
+%\VignetteKeywords{Documentation}
+%\VignettePackage{phangorn}
+%\VignetteEngine{Sweave}
+\documentclass[12pt]{article}
+% setwd("/home/kschliep/Desktop/phangorn/vignettes")
+% Sweave("phangorn-specials.Rnw")
+% tools::texi2dvi("phangorn-specials.tex", pdf=TRUE)
+\usepackage{times}
+\usepackage{hyperref}
+
+\newcommand{\Rfunction}[1]{{\texttt{#1}}}
+\newcommand{\Robject}[1]{{\texttt{#1}}}
+\newcommand{\Rpackage}[1]{{\textit{#1}}}
+\newcommand{\Rmethod}[1]{{\texttt{#1}}}
+\newcommand{\Rfunarg}[1]{{\texttt{#1}}}
+\newcommand{\Rclass}[1]{{\textit{#1}}}
+
+\textwidth=6.2in
+\textheight=8.5in
+%\parskip=.3cm
+\oddsidemargin=.1in
+\evensidemargin=.1in
+\headheight=-.3in
+
+\newcommand{\R}{\textsf{R}}
+\newcommand{\pml}{\Robject{pml}}
+\newcommand{\phangorn}{\Rpackage{phangorn}}
+\newcommand{\ape}{\Rpackage{ape}}
+\newcommand{\multicore}{\Rpackage{multicore}}
+
+\newcommand{\term}[1]{\emph{#1}}
+\newcommand{\mref}[2]{\htmladdnormallinkfoot{#2}{#1}}
+
+
+
+\begin{document}
+
+% Ross Ihakas extenstion for nicer representation
+\DefineVerbatimEnvironment{Sinput}{Verbatim} {xleftmargin=2em}
+\DefineVerbatimEnvironment{Soutput}{Verbatim}{xleftmargin=2em}
+\DefineVerbatimEnvironment{Scode}{Verbatim}{xleftmargin=2em}
+\fvset{listparameters={\setlength{\topsep}{0pt}}}
+\renewenvironment{Schunk}{\vspace{\topsep}}{\vspace{\topsep}}
+
+<<echo=FALSE>>=
+options(width=70)
+foo <- packageDescription("phangorn")
+@
+
+
+\title{Special features of phangorn (Version \Sexpr{foo$Version})} %$
+\author{\mref{mailto:klaus.schliep at gmail.com}{Klaus P. Schliep}}
+\maketitle
+
+\nocite{Paradis2012}
+\section*{Introduction}
+This document illustrates some of the \phangorn{} \cite{Schliep2011} specialised features which are useful but maybe not as well-known or just not (yet) described elsewhere. This is mainly interesting for someone who wants to explore different models or set up some simulation studies. We show how to construct data objects for different character states other than nucleotides or amino acids or how to set up different models to estimate transition rate.
+
+The vignette \emph{Trees} describes in detail how to estimate phylogenies from nucleotide or amino acids.
+
+
+\section{User defined data formats}\label{sec:USER}
+
+To better understand how to define our own data type it is useful to know a bit more about the internal representation of \Robject{phyDat} objects. The internal representation of \Robject{phyDat} object is very similar to \Robject{factor} objects.
+
+As an example we will show here several possibilities to define nucleotide data with gaps defined as a fifth state. Ignoring gaps or coding them as ambiguous sites - as it is done in most programs, also in phangorn as default - may be misleading (see Warnow(2012)\cite{Warnow2012}). When the number of gaps is low and the gaps are missing at random coding gaps as separate state may be not important.
+
+Let assume we have given a matrix where each row contains a character vector of a taxonomical unit:
+<<echo=TRUE>>=
+library(phangorn)
+data = matrix(c("r","a","y","g","g","a","c","-","c","t","c","g",
+ "a","a","t","g","g","a","t","-","c","t","c","a",
+ "a","a","t","-","g","a","c","c","c","t","?","g"),
+ dimnames = list(c("t1", "t2", "t3"),NULL), nrow=3, byrow=TRUE)
+data
+@
+Normally we would transform this matrix into an phyDat object and gaps are handled as ambiguous character like "?".
+<<>>=
+gapsdata1 = phyDat(data)
+gapsdata1
+@
+Now we will define a "USER" defined object and have to supply a vector levels of the character states for the new data, in our case the for nucleotide states and the gap. Additional we can define ambiguous states which can be any of the states.
+<<echo=TRUE>>=
+gapsdata2 = phyDat(data, type="USER", levels=c("a","c","g","t","-"),
+ ambiguity = c("?", "n"))
+gapsdata2
+@
+This is not yet what we wanted as two sites of our alignment, which contain the ambiguous characters "r" and "y", got deleted.
+To define ambiguous characters like "r" and "y" explicitly we have to supply a contrast matrix similar to contrasts for factors.
+<<echo=TRUE>>=
+contrast = matrix(data = c(1,0,0,0,0,
+ 0,1,0,0,0,
+ 0,0,1,0,0,
+ 0,0,0,1,0,
+ 1,0,1,0,0,
+ 0,1,0,1,0,
+ 0,0,0,0,1,
+ 1,1,1,1,0,
+ 1,1,1,1,1),
+ ncol = 5, byrow = TRUE)
+dimnames(contrast) = list(c("a","c","g","t","r","y","-","n","?"),
+ c("a", "c", "g", "t", "-"))
+contrast
+gapsdata3 = phyDat(data, type="USER", contrast=contrast)
+gapsdata3
+@
+Here we defined "n" as a state which can be any nucleotide but not a gap "-" and "?" can be any state including a gap.
+
+These data can be used in all functions available in \phangorn{} to compute distance matrices or perform parsimony and maximum likelihood analysis.
+
+
+\section{Estimation of non-standard transition rate matrices}
+In the last section \ref{sec:USER} we described how to set up user defined data formats. Now we describe how to estimate transition matrices with pml.
+
+Again for nucleotide data the most common models can be called directly in the \Rfunction{optim.pml} function (e.g. "JC69", "HKY", "GTR" to name a few). Table \ref{models} lists all the available nucleotide models, which can estimated directly in \Rfunction{optim.pml}. For amino acids several transition matrices are available ("WAG", "JTT", "LG", "Dayhoff", "cpREV", "mtmam", "mtArt", "MtZoa", "mtREV24", "VT","RtREV", "HIVw", "HIVb", "FLU", "Blossum62", "Dayhoff\_DCMut" and "JTT-DCMut") o [...]
+
+
+We will now show how to estimate a rate matrix with different transition ($\alpha$) and transversion ratio ($\beta$) and a fixed rate to the gap state ($\gamma$) - a kind of Kimura two-parameter model (K81) for nucleotide data with gaps as fifth state (see table \ref{gaps}).
+
+\begin{table}[htbp]
+ \centering
+ \begin{tabular}{l|lllll}
+ & a & c & g & t & - \\
+ \hline
+ a & & & & & \\
+ c & $\beta$ & & & & \\
+ g & $\alpha$ & $\beta$ & & & \\
+ t & $\beta$ & $\alpha$ & $\beta$ & & \\
+ - & $\gamma$ & $\gamma$ & $\gamma$ & $\gamma$ & \\
+ \end{tabular}
+ \caption{Rate matrix K to optimise. }\label{gaps}
+\end{table}
+
+
+The parameters subs accepts a vector of consecutive integers and at least one element has to be zero (these gets the reference rate of 1).
+<<>>=
+tree = unroot(rtree(3))
+fit = pml(tree, gapsdata3)
+fit = optim.pml(fit, optQ=TRUE, subs=c(1,0,1,2,1,0,2,1,2,2),
+ control=pml.control(trace=0))
+fit
+@
+
+
+Here are some conventions how the models are estimated: \\
+
+If a model is supplied the base frequencies bf and rate matrix Q are optimised according to the model (nucleotides) or the adequate rate matrix and frequencies are chosen (for amino acids).
+If optQ=TRUE and neither a model or subs are supplied than a symmetric (optBf=FALSE) or reversible model (optBf=TRUE, i.e. the GTR for nucleotides) is estimated. This can be slow if the there are many character states, e.g. for amino acids.
+
+
+\begin{table}[htbp]
+ \centering
+ \begin{tabular}{|llllr|}
+ \hline
+ model & optQ & optBf & subs & df \\
+ \hline
+ JC & FALSE & FALSE & $c(0, 0, 0, 0, 0, 0)$ & 0 \\
+ F81 & FALSE & TRUE & $c(0, 0, 0, 0, 0, 0)$ & 3 \\
+ K80 & TRUE & FALSE & $c(0, 1, 0, 0, 1, 0)$ & 1 \\
+ HKY & TRUE & TRUE & $c(0, 1, 0, 0, 1, 0)$ & 4 \\
+ TrNe & TRUE & FALSE & $c(0, 1, 0, 0, 2, 0)$ & 2 \\
+ TrN & TRUE & TRUE & $c(0, 1, 0, 0, 2, 0)$ & 5 \\
+ TPM1 & TRUE & FALSE & $c(0, 1, 2, 2, 1, 0)$ & 2 \\
+ K81 & TRUE & FALSE & $c(0, 1, 2, 2, 1, 0)$ & 2 \\
+ TPM1u & TRUE & TRUE & $c(0, 1, 2, 2, 1, 0)$ & 5 \\
+ TPM2 & TRUE & FALSE & $c(1, 2, 1, 0, 2, 0)$ & 2 \\
+ TPM2u & TRUE & TRUE & $c(1, 2, 1, 0, 2, 0)$ & 5 \\
+ TPM3 & TRUE & FALSE & $c(1, 2, 0, 1, 2, 0)$ & 2 \\
+ TPM3u & TRUE & TRUE & $c(1, 2, 0, 1, 2, 0)$ & 5 \\
+ TIM1e & TRUE & FALSE & $c(0, 1, 2, 2, 3, 0)$ & 3 \\
+ TIM1 & TRUE & TRUE & $c(0, 1, 2, 2, 3, 0)$ & 6 \\
+ TIM2e & TRUE & FALSE & $c(1, 2, 1, 0, 3, 0)$ & 3 \\
+ TIM2 & TRUE & TRUE & $c(1, 2, 1, 0, 3, 0)$ & 6 \\
+ TIM3e & TRUE & FALSE & $c(1, 2, 0, 1, 3, 0)$ & 3 \\
+ TIM3 & TRUE & TRUE & $c(1, 2, 0, 1, 3, 0)$ & 6 \\
+ TVMe & TRUE & FALSE & $c(1, 2, 3, 4, 2, 0)$ & 4 \\
+ TVM & TRUE & TRUE & $c(1, 2, 3, 4, 2, 0)$ & 7 \\
+ SYM & TRUE & FALSE & $c(1, 2, 3, 4, 5, 0)$ & 5 \\
+ GTR & TRUE & TRUE & $c(1, 2, 3, 4, 5, 0)$ & 8 \\
+ \hline
+ \end{tabular}
+ \caption{DNA models available in phangorn, how they are defined and number of parameters to estimate. }\label{models}
+\end{table}
+
+\section{Codon substitution models}
+A special case of the transition rates are codon models. \phangorn{} now offers the possibility to estimate the $d_N/d_S$ ratio (sometimes called ka/ks), for an overview see \cite{Yang2006}. These functions extend the option to estimates the $d_N/d_S$ ratio for pairwise sequence comparison as it is available through the function \Rfunction{kaks} in \Rpackage{seqinr}. The transition rate between between codon $i$ and $j$ is defined as follows:
+\begin{eqnarray}
+q_{ij}=\left\{
+ \begin{array}{l@{\quad}l}
+ 0 & \textrm{if i and j differ in more than one position} \\
+ \pi_j & \textrm{for synonymous transversion} \\
+ \pi_j\kappa & \textrm{for synonymous transition} \\
+ \pi_j\omega & \textrm{for non-synonymous transversion} \\
+ \pi_j\omega\kappa & \textrm{for non synonymous transition}
+ \end{array}
+ \right. \nonumber
+\end{eqnarray}
+where $\omega$ is the $d_N/d_S$ ratio, $\kappa$ the transition transversion ratio and $\pi_j$ is the the equilibrium frequencies of codon $j$.
+For $\omega\sim1$ the an amino acid change is neutral, for $\omega < 1$ purifying selection and $\omega > 1$ positive selection.
+There are four models available:
+"codon0", where both parameter $\kappa$ and $\omega$ are fixed to 1, "codon1" where both parameters are estimated and "codon2" or "codon3" where $\kappa$ or $\omega$ is fixed to 1.
+
+We compute the $d_N/d_S$ for some sequences given a tree using the ML functions \Rfunction{pml} and \Rfunction{optim.pml}. First we have to transform the the nucleotide sequences into codons (so far the algorithms always takes triplets).
+<<echo=TRUE>>=
+library(phangorn)
+primates = read.phyDat("primates.dna", format="phylip", type="DNA")
+tree <- NJ(dist.ml(primates))
+dat <- phyDat(as.character(primates), "CODON")
+fit <- pml(tree, dat)
+fit0 <- optim.pml(fit, control = pml.control(trace = 0))
+fit1 <- optim.pml(fit, model="codon1", control=pml.control(trace=0))
+fit2 <- optim.pml(fit, model="codon2", control=pml.control(trace=0))
+fit3 <- optim.pml(fit, model="codon3", control=pml.control(trace=0))
+anova(fit0, fit2, fit3, fit1)
+@
+The models described here all assume equal frequencies for each codon (=1/61). One can optimise the codon frequencies setting the option to optBf=TRUE. As the convergence of the 61 parameters the convergence is likely slow set the maximal iterations to a higher value than the default (e.g. control = pml.control(maxit=50)).
+
+\section{Generating trees}
+\phangorn{} has several functions to generate tree topologies, which may are interesting for simulation studies. \Rfunction{allTrees} computes all possible bifurcating tree topologies either rooted or unrooted for up to 10 taxa. One has to keep in mind that the number of trees is growing exponentially, use \Rfunction(howmanytrees) from \ape{} as a reminder.
+
+%<<echo=TRUE>>=
+%trees = allTrees(5)
+%@
+<<label=plotAll,include=FALSE>>=
+trees = allTrees(5)
+par(mfrow=c(3,5), mar=rep(0,4))
+for(i in 1:15)plot(trees[[i]], cex=1, type="u")
+@
+\begin{figure}
+\begin{center}
+<<label=figAll,fig=TRUE,echo=FALSE>>=
+<<plotAll>>
+@
+\end{center}
+\caption{all (15) unrooted trees with 5 taxa}
+\label{fig:NJ}
+\end{figure}
+
+
+\Rfunction{nni} returns a list of all trees which are one nearest neighbor interchange away.
+<<echo=TRUE>>=
+trees = nni(trees[[1]])
+@
+\Rfunction{rNNI} and \Rfunction{rSPR} generate trees which are a defined number of NNI (nearest neighbor interchange) or SPR (subtree pruning and regrafting) away.
+
+
+
+\bibliographystyle{plain}
+\bibliography{phangorn}
+
+\section{Session Information}
+The version number of \R{} and packages loaded for generating the vignette were:
+<<echo=FALSE,results=tex>>=
+toLatex(sessionInfo())
+@
+
+\end{document}
diff --git a/vignettes/phangorn.bib b/vignettes/phangorn.bib
new file mode 100644
index 0000000..2c958ef
--- /dev/null
+++ b/vignettes/phangorn.bib
@@ -0,0 +1,400 @@
+ at Article{ Rambaut1997,
+ Author = "A. Rambaut and N.C. Grassly",
+ Title = "Seq-Gen: an application for the Monte Carlo simulation of DNA sequence evolution along phylogenetic trees",
+ Journal = "Comput Appl Biosci",
+ Volume = "13",
+ Pages = "235--238",
+ Year = "1997"
+}
+
+
+ at Article{Revell2012,
+ title = {phytools: An R package for phylogenetic comparative biology (and other things).},
+ author = {Liam J. Revell},
+ journal = {Methods in Ecology and Evolution},
+ year = {2012},
+ volume = {3},
+ pages = {217-223},
+}
+
+
+ at Article{Revell2014,
+ Title = {Rphylip: an R interface for PHYLIP},
+ Author = {Revell, Liam J. and Chamberlain, Scott A.},
+ Journal = {Methods in Ecology and Evolution},
+ Year = {2014},
+ Number = {9},
+ Pages = {976--981},
+ Volume = {5},
+ Doi = {10.1111/2041-210X.12233},
+ ISSN = {2041-210X},
+ Keywords = {phylogeny, statistics, computational biology, evolution},
+ Url = {http://dx.doi.org/10.1111/2041-210X.12233}
+}
+
+ at article{Holland2004,
+ author = {Holland, Barbara R. and Huber, Katharina T. and Moulton, Vincent and Lockhart, Peter J.},
+ title = {Using Consensus Networks to Visualize Contradictory Evidence for Species Phylogeny},
+ volume = {21},
+ number = {7},
+ pages = {1459-1461},
+ year = {2004},
+ doi = {10.1093/molbev/msh145},
+ URL = {http://mbe.oxfordjournals.org/content/21/7/1459.abstract},
+ eprint = {http://mbe.oxfordjournals.org/content/21/7/1459.full.pdf+html},
+ journal = {Molecular Biology and Evolution}
+}
+
+ at article{Bryant2004,
+ author = {Bryant, David and Moulton, Vincent},
+ title = {Neighbor-Net: An Agglomerative Method for the Construction of Phylogenetic Networks},
+ volume = {21},
+ number = {2},
+ pages = {255-265},
+ year = {2004},
+ doi = {10.1093/molbev/msh018},
+ URL = {http://mbe.oxfordjournals.org/content/21/2/255.abstract},
+ eprint = {http://mbe.oxfordjournals.org/content/21/2/255.full.pdf+html},
+ journal = {Molecular Biology and Evolution}
+}
+
+
+ at Article{Csardi2006,
+ title = {The igraph software package for complex network research},
+ author = {Gabor Csardi and Tamas Nepusz},
+ journal = {InterJournal},
+ volume = {Complex Systems},
+ pages = {1695},
+ year = {2006},
+ url = {http://igraph.org},
+ }
+
+ at Article{ Stefankovic2007a,
+ Author = "D. Stefankovic and E. Vigoda",
+ Title = "Pitfalls of heterogeneous processes for phylogenetic reconstruction",
+ Journal = "Systematic Biology",
+ Volume = "56",
+ Number = "1",
+ Pages = "113--124",
+ Year = "2007"
+}
+
+ at Article{ Nixon1999,
+ Author = "K. Nixon",
+ Title = "The Parsimony Ratchet, a New Method for Rapid Rarsimony Analysis",
+ Journal = "Cladistics",
+ Volume = "15",
+ Pages = "407--414",
+ Year = "1999"
+}
+
+ at Article{ Matsen2007,
+ Author = "F. A. Matsen and M. Steel",
+ Title = "Phylogenetic mixtures on a single tree can mimic a tree of another topology",
+ Journal = "Systematic Biology",
+ Volume = "56",
+ Number = "5",
+ Pages = "767--775",
+ Year = "2007"
+}
+
+ at Article{ Pagel2004,
+ Author = "Mark Pagel and Andrew Meade",
+ Title = "A Phylogenetic Mixture Model for Detecting Pattern-Heterogeneity in Gene Sequence or Character-State Data",
+ Journal = "Systematic Biology",
+ Volume = "53",
+ Number = "4",
+ Pages = "571--581",
+ Year = "2004"
+}
+
+ at Article{ Thornton2004,
+ Author = "B. Kolaczkowski and J. W. Thornton",
+ Title = "Performance of maximum parsimony and likelihood phylogenetics when evolution is heterogeneous",
+ Journal = "Nature",
+ Volume = "431",
+ Number = "7011",
+ Pages = "980--984",
+ Year = "2004"
+}
+
+ at Article{ Studier1988,
+ Author = "J. A. Studier and K. J. Keppler",
+ Title = "A Note on the Neighbor-Joining Algorithm of Saitou and Nei",
+ Journal = "Molecular Biology and Evolution",
+ Volume = "5",
+ Number = "6",
+ Pages = "729--731",
+ Year = "1988"
+}
+
+ at Article{ Saitou1987,
+ Author = "N. Saitou and M. Nei",
+ Title = "The Neighbor-Joining Method - a New Method for Reconstructing Phylogenetic Trees",
+ Journal = "Molecular Biology and Evolution",
+ Volume = "4",
+ Number = "4",
+ Pages = "406--425",
+ Year = "1987"
+}
+
+ at Article{ Pagel2008,
+ Author = "Mark Pagel and Andrew Meade",
+ Title = "Modelling heterotachy in phylogenetic inference by reversible-jump Markov chain Monte Carlo",
+ Journal = "Philosophical Transactions of the Royal Society B",
+ Volume = "363",
+ Pages = "3955--3964",
+ Year = "2008"
+}
+
+ at Article{ Shimodaira1999,
+ Author = "Shimodaira, H. and Hasegawa, M.",
+ Title = "Multiple comparisons of log-likelihoods with applications to phylogenetic inference.",
+ Journal = "Molecular Biology and Evolution",
+ Volume = "16",
+ Pages = "1114–1116",
+ Year = "1999"
+}
+
+ at InCollection{ Pagel2005,
+ Author = "Mark Pagel and Andrew Meade",
+ Title = "Mixture models in phylogenetic inference",
+ BookTitle = "Mathematics of evolution and phylogeny",
+ Editor = "Olivier Gascuel",
+ Publisher = "Oxford",
+ Address = "New York",
+ Year = "2005"
+}
+
+ at InCollection{ Swofford1996,
+ Author = "Swofford, D.L. and Olsen, G.J. and Waddell, P.J. and Hillis, D.M.",
+ Title = "Phylogenetic Inference",
+ BookTitle = "Molecular Systematics",
+ Editor = "Hillis, D.M. and Moritz, C. and Mable, B.K",
+ Edition = "Second",
+ Publisher = "Sinauer",
+ Address = "Sunderland, MA",
+ Year = "1996"
+}
+
+ at Article{ Kolaczkowski2008,
+ Author = "Bryan Kolaczkowski and Joseph W. Thornton",
+ Title = "A Mixed Branch Length Model of Heterotachy Improves Phylogenetic Accuracy",
+ Journal = "Molecular Biology and Evolution",
+ Volume = "25",
+ Number = "6",
+ Pages = "1054--1066",
+ Year = "2008"
+}
+
+ at Article{ Dempster1977,
+ Author = "A. P. Dempster and N. M. Laird and D. B. Rubin",
+ Title = "Maximum likelihood from incomplete data via the EM algorithm",
+ Journal = "Journal of the Royal Statistical Society B",
+ Volume = "39",
+ Number = "1",
+ Pages = "1--38",
+ Year = "1977"
+}
+
+ at Book{ Felsenstein2004,
+ Author = "Joseph Felsenstein",
+ Title = "Inferring Phylogenies",
+ Publisher = "Sinauer Associates",
+ Address = "Sunderland",
+ Year = "2004"
+}
+
+ at Article{ Felsenstein1981,
+ Author = "Joseph Felsenstein",
+ Title = "Evolutionary trees from DNA sequences: a maxumum likelihood approach",
+ Journal = "Journal of Molecular Evolution",
+ Volume = "17",
+ Pages = "368--376",
+ Year = "1981"
+}
+
+ at Book{ Yang2006,
+ Author = "Ziheng Yang",
+ Title = "Computational Molecular evolution",
+ Publisher = "Oxford University Press",
+ Address = "Oxford",
+ Year = "2006"
+}
+
+ at Article{ Paradis2004,
+ Author = "E. Paradis and J. Claude and K. Strimmer",
+ Title = "APE: Analyses of Phylogenetics and Evolution in R language",
+ Journal = "Bioinformatics",
+ Volume = "20",
+ Number = "2",
+ Pages = "289--290",
+ Year = "2004"
+}
+
+ at Book{ Paradis2006,
+ Author = "Emmanuel Paradis",
+ Title = "Analysis of Phylogenetics and Evolution with R",
+ Publisher = "Springer",
+ Address = "New York",
+ Year = "2006"
+}
+
+
+ at Book{ Paradis2012,
+ Author = "Emmanuel Paradis",
+ Title = "Analysis of Phylogenetics and Evolution with R",
+ Edition = "Second",
+ Publisher = "Springer",
+ Address = "New York",
+ Year = "2012"
+}
+
+
+ at InCollection{ seqinr,
+ author = "D. Charif and J.R. Lobry",
+ title = "Seqin{R} 1.0-2: a contributed package to the {R} project for statistical computing devoted to biological sequences retrieval and analysis.",
+ booktitle = "Structural approaches to sequence evolution: Molecules, networks, populations",
+ year = "2007",
+ editor = "M. Porto H.E. Roman {U. Bastolla} and M. Vendruscolo",
+ series = "Biological and Medical Physics, Biomedical Engineering",
+ pages = "207--232",
+ address = "New York",
+ publisher = "Springer Verlag",
+ note = "{ISBN :} 978-3-540-35305-8"
+}
+
+ at Article{ Mathews2010,
+ Author = "S. Mathews and M.D. Clements and M.A. Beilstein",
+ Title = "A duplicate gene rooting of seed plants and the phylogenetic position of flowering plants.",
+ Journal = "Phil. Trans. R. Soc. B",
+ Volume = "365",
+ Pages = "383--395",
+ Year = "2010"
+}
+
+ at Article{ Schliep2011,
+ title = "phangorn: Phylogenetic analysis in {R}",
+ author = "Klaus Peter Schliep",
+ journal = "Bioinformatics",
+ year = "2011",
+ volume = "27",
+ number = "4",
+ pages = "592--593",
+ doi = {10.1093/bioinformatics/btq706},
+ URL = {http://bioinformatics.oxfordjournals.org/content/27/4/592.abstract},
+ eprint = {http://bioinformatics.oxfordjournals.org/content/27/4/592.full.pdf+html},
+}
+
+
+ at Thesis{Schliep2009,
+ author = "Klaus Schliep",
+ title = "Some Applications of statistical phylogenetics",
+ year = 2009
+}
+
+
+ at article{Lanfear2012,
+ author = {Lanfear, Robert and Calcott, Brett and Ho, Simon Y. W. and Guindon, Stephane},
+ title = {PartitionFinder: Combined Selection of Partitioning Schemes and Substitution Models for Phylogenetic Analyses},
+ volume = {29},
+ number = {6},
+ pages = {1695-1701},
+ year = {2012},
+ doi = {10.1093/molbev/mss020},
+ URL = {http://mbe.oxfordjournals.org/content/29/6/1695.abstract},
+ eprint = {http://mbe.oxfordjournals.org/content/29/6/1695.full.pdf+html},
+ journal = {Molecular Biology and Evolution}
+}
+
+ at Article{ Schliep2011b,
+ title = "Harvesting Evolutionary Signals in a Forest of Prokaryotic Gene Trees",
+ author = "Klaus Schliep and Philippe Lopez and Fran\c{c}ois-Joseph Lapointe and Eric Bapteste",
+ journal = "Molecular Biology and Evolution",
+ year = "2011",
+ volume = "28",
+ number = "4",
+ pages = "1393--1405"
+}
+
+ at Article{ Swofford1987,
+ title = "Reconstructing ancestral character states under Wagner parsimony",
+ author = "D.L. Swofford and W.P. Maddison",
+ journal = "Math. Biosci.",
+ year = "1987",
+ Volume = "87",
+ pages = "199--229"
+}
+
+ at article{Posada1998,
+ author = {Posada, D. and Crandall, K.A.},
+ title = {MODELTEST: testing the model of DNA substitution.},
+ volume = {14},
+ number = {9},
+ pages = {817-818},
+ year = {1998},
+ journal = {Bioinformatics}
+}
+
+ at article{Posada2008,
+ author = {Posada, David},
+ title = {jModelTest: Phylogenetic Model Averaging},
+ volume = {25},
+ number = {7},
+ pages = {1253-1256},
+ year = {2008},
+ URL = {http://mbe.oxfordjournals.org/content/25/7/1253.abstract},
+ journal = {Molecular Biology and Evolution}
+}
+
+ at article{Hendy1982,
+ author = {Hendy, M.D. and Penny D.},
+ title = {Branch and bound algorithms to determine minimal evolutionary trees},
+ volume = {59},
+ pages = {277-290},
+ year = {1982},
+ journal = {Math. Biosc.}
+}
+
+ at Book{ Rao1973,
+ Author = "C.R. Rao",
+ Title = "Linear statistical inference and its applications",
+ Publisher = "John Wiley",
+ Address = "New York",
+ Year = "1973"
+}
+
+
+
+ at Article{ Lapointe2010,
+ title = "Clanistics: a multi-level perspective for harvesting unrooted gene trees",
+ journal = "Trends in Microbiology",
+ volume = "18",
+ number = "8",
+ pages = "341--347",
+ year = "2010",
+ url = "http://www.sciencedirect.com/science/article/pii/S0966842X10000570",
+ author = "Fran\c{c}ois-Joseph Lapointe and Philippe Lopez and Yan Boucher and Jeremy Koenig and Eric Bapteste"
+}
+
+
+ at article{Wilkinson2007,
+ title = "Of clades and clans: terms for phylogenetic relationships in unrooted trees",
+ journal = "Trends in Ecology and Evolution",
+ volume = "22",
+ number = "3",
+ pages = "114--115",
+ year = "2007",
+ url = "http://www.sciencedirect.com/science/article/pii/S016953470700019",
+ author = "Mark Wilkinson and James O. McInerney and Robert P. Hirt and Peter G. Foster and T. Martin Embley"
+}
+
+
+ at article{Warnow2012,
+ title = "Standard maximum likelihood analyses of alignments with gaps can be statistically inconsistent",
+ journal = "PLOS Currents Tree of Life",
+ year = "2012",
+ doi = "10.1371/currents.RRN1308",
+ author = "Tandy Warnow"
+}
+
diff --git a/vignettes/primates.dna b/vignettes/primates.dna
new file mode 100644
index 0000000..507b365
--- /dev/null
+++ b/vignettes/primates.dna
@@ -0,0 +1,61 @@
+ 14 232
+Mouse ACCAAAAAAA CATCCAAACA CCAACCCCAG CCCTTACGCA ATAGCCATAC AAAGAATATT
+Bovine ACCAAACCTG TCCCCACCAT CTAACACCAA CCCACATATA CAAGCTAAAC CAAAAATACC
+Lemur ACCAAACTAA CATCTAACAA CTACCTCCAA CTCTAAAAAA GCACTCTTAC CAAACCCATC
+Tarsier ATCTACCTTA TCTCCCCCAA TCAATACCAA CCTAAAAACT CTACAATTAA AAACCCCACC
+Squir MonkACCCCAGCAA CTCGTTGTGA CCAACATCAA TCCAAAATTA GCAAACGTAC CAACAATCTC
+Jpn Macaq ACTCCACCTG CTCACCTCAT CCACTACTAC TCCTCAAGCA ATACATAAAC TAAAAACTTC
+Rhesus MacACTTCACCCG TTCACCTCAT CCACTACTAC TCCTCAAGCG ATACATAAAT CAAAAACTTC
+Crab-E.MacACCCCACCTA CCCGCCTCGT CCGCTACTGC TTCTCAAACA ATATATAGAC CAACAACTTC
+BarbMacaq ACCCTATCTA TCTACCTCAC CCGCCACCAC CCCCCAAACA ACACACAAAC CAACAACTTT
+Gibbon ACTATACCCA CCCAACTCGA CCTACACCAA TCCCCACATA GCACACAGAC CAACAACCTC
+Orang ACCCCACCCG TCTACACCAG CCAACACCAA CCCCCACCTA CTATACCAAC CAATAACCTC
+Gorilla ACCCCATTTA TCCATAAAAA CCAACACCAA CCCCCATCTA ACACACAAAC TAATGACCCC
+Chimp ACCCCATCCA CCCATACAAA CCAACATTAC CCTCCATCCA ATATACAAAC TAACAACCTC
+Human ACCCCACTCA CCCATACAAA CCAACACCAC TCTCCACCTA ATATACAAAT TAATAACCTC
+
+ ATACTACTAA AAACTCAAAT TAACTCTTTA ATCTTTATAC AACATTCCAC CAACCTATCC
+ ATACAACCAT AAATAAGACT AATCTATTAA AATAACCCAT TACGATACAA AATCCCTTTC
+ ACAACTCTAT CAACCTAACC AAACTATCAA CATGCCCTCT CCTAATTAAA AACATTGCCA
+ GCTCAATTAC TAGCAAAAAT AGACATTCAA CTCCTCCCAT CATAACATAA AACATTCCTC
+ CCAAATTTAA AAACACATCC TACCTTTACA ATTAATAACC ATTGTCTAGA TATACCCCTA
+ TCACCTCTAA TACTACACAC CACTCCTGAA ATCAATGCCC TCCACTAAAA AACATCACCA
+ TCACCTCCAA TACTACGCAC CGCTCCTAAA ATCAATGCCC CCCACCAAAA AACATCACCA
+ TCACCTTTAA CACTACATAT CACTCCTGAG CTTAACACCC TCCGCTAAAA AACACCACTA
+ TTATCTTTAG CACCACACAT CACCCCCAAA AGCAATACCC TTCACCAAAA AGCACCATCA
+ CCACCTTCCA TACCAAGCCC CGACTTTACC GCCAACGCAC CTCATCAAAA CATACCTACA
+ TCAACCCCTA AACCAAACAC TATCCCCAAA ACCAACACAC TCTACCAAAA TACACCCCCA
+ CCACCCTCAA AGCCAAACAC CAACCCTATA ATCAATACGC CTTATCAAAA CACACCCCCA
+ CCACTCTTCA GACCGAACAC CAATCTCACA ACCAACACGC CCCGTCAAAA CACCCCTTCA
+ CCACCTTCAG AACTGAACGC CAATCTCATA ACCAACACAC CCCATCAAAG CACCCCTCCA
+
+ ACACAAAAAA ACTCATATTT ATCTAAATAC GAACTTCACA CAACCTTAAC ACATAAACAT
+ GTCTAGATAC AAACCACAAC ACACAATTAA TACACACCAC AATTACAATA CTAAACTCCC
+ CACTAAACCT ACACACCTCA TCACCATTAA CGCATAACTC CTCAGTCATA TCTACTACAC
+ GCTCCAATAA ACACATCACA ATCCCAATAA CGCATATACC TAAATACATC ATTTAATAAT
+ AAATAAATGA ATATAAACCC TCGCCGATAA CATA-ACCCC TAAAATCAAG ACATCCTCTC
+ GCCCAAACAA ACACCTATCT ACCCCCCCGG TCCACGCCCC TAACTCCATC ATTCCCCCTC
+ ACCCAAACAA ACACCTACCC ATCCCCCCGG TTCACGCCTC AAACTCCATC ATTCCCCCTC
+ ACCCAAACAA ACACCTATCT ATCCCCCCGG TCCACGCCCC AAACCCCGCT ATTCCCCCCT
+ AATCAAACAA ACACCTATTT ATTCCCCTAA TTCACGTCCC AAATCCCATT ATCTCTCCCC
+ ACACAAACAA ATGCCCCCCC ACCCTCCTTC TTCAAGCCCA CTAGACCATC CTACCTTCCT
+ ATTCACATCC GCACACCCCC ACCCCCCCTG CCCACGTCCA TCCCATCACC CTCTCCTCCC
+ ACATAAACCC ACGCACCCCC ACCCCTTCCG CCCATGCTCA CCACATCATC TCTCCCCTTC
+ GCACAAATTC ATACACCCCT ACCTTTCCTA CCCACGTTCA CCACATCATC CCCCCCTCTC
+ ACACAAACCC GCACACCTCC ACCCCCCTCG TCTACGCTTA CCACGTCATC CCTCCCTCTC
+
+ ACCCCAGCCC AACACCCTTC CACAAATCCT TAATATACGC ACCATAAATA AC
+ ATCCCACCAA ATCACCCTCC ATCAAATCCA CAAATTACAC AACCATTAAC CC
+ ACCCTAACAA TTTATCCCTC CCATAATCCA AAAACTCCAT AAACACAAAT TC
+ AATACTCCAA CTCCCATAAC ACAGCATACA TAAACTCCAT AAGTTTGAAC AC
+ ACAACGCCAA ACCCCCCTCT CATAACTCTA CAAAATACAC AATCACCAAC AC
+ AATACATCAA ACAATTCCCC CCAATACCCA CAAACTGCAT AAGCAAACAG AC
+ AATACATCAA ACAATTCCCC CCAATACCCA CAAACTACAT AAACAAACAA AC
+ AATACACCAA ACAATTTTCT CCAACACCCA CAAACTGTAT AAACAAACAA AC
+ AACATACCAA ACAATTCTCC CTAATATACA CAAACCACGC AAACAAACAA AC
+ AGCACGCCAA GCTCTCTACC ATCAAACGCA CAACTTACAC ATACAGAACC AC
+ AACACCCTAA GCCACCTTCC TCAAAATCCA AAACCCACAC AACCGAAACA AC
+ AACACCTCAA TCCACCTCCC CCCAAATACA CAATTCACAC AAACAATACC AC
+ AACATCTTGA CTCGCCTCTC TCCAAACACA CAATTCACGC AAACAACGCC AC
+ AACACCTTAA CTCACCTTCT CCCAAACGCA CAATTCGCAC ACACAACGCC AC
+
--
Alioth's /usr/local/bin/git-commit-notice on /srv/git.debian.org/git/debian-med/r-cran-phangorn.git
More information about the debian-med-commit
mailing list