phytools/0000755000176200001440000000000014547214442012142 5ustar liggesusersphytools/NAMESPACE0000644000176200001440000003267414546006234013372 0ustar liggesusers## names exported by phytools export(add.arrow, add.color.bar, add.everywhere, add.random, add.simmap.legend) export(add.species.to.genus, aic.w, allFurcTrees, allRotations, anc.Bayes, anc.ML) export(anc.trend, ancr, ancThresh, ansi_phylo, applyBranchLengths, arc.cladelabels, as.multiPhylo) export(as.prcomp, as.princomp, as.Qmatrix, ave.rates, averageTree) export(backbone.toPhylo, bd, bmPlot, bind.tip, bind.tree.simmap, biplot.phyl.pca) export(branching.diffusion, brownie.lite, brownieREML) export(cladelabels, coef.phyl.RMA, collapse.to.star, collapseTree, compare.chronograms) export(consensus.edges, contMap, cophylo, countSimmap, compute.mr, cotangleplot, cospeciation) export(ctt) export(density.anc.Bayes, density.multiSimmap, densityMap, densityTree, describe.simmap) export(di2multi.simmap, dot.legend, dotTree, drop.clade, drop.leaves, drop.tip.contMap) export(drop.tip.densityMap, drop.tip.multiSimmap, drop.tip.simmap, drop.tip.singleton, Dtest) export(edge.widthMap, edgelabels.cophylo, edgeProbs, errorbar.contMap, estDiversity) export(evol.rate.mcmc, evol.vcv, evolvcv.lite, exhaustiveMP, expand.clade, export.as.xml) export(extract.clade.simmap, extract.strahlerNumber) export(fancyTree, fastAnc, fastBM, fastDist, fastHeight, fastMRCA, findMRCA, fit.bd) export(fit.yule, fitBayes, fitgammaMk, fitHRM, fitMk, fitMk.parallel, fitmultiMk, fitpolyMk) export(fitDiversityModel, fitPagel, force.ultrametric) export(gamma_pruning, gammatest, genus.to.species.tree, genSeq, geo.palette, geo.legend, get.treepos) export(getCladesofSize, getDescendants, getExtant, getExtinct, getnode, getParent) export(getSisters, getStates, graph.polyMk, gtt) export(hide.hidden) export(keep.tip.contMap, keep.tip.densityMap, keep.tip.multiSimmap, keep.tip.simmap) export(labelnodes, ladderize.simmap, lambda.transform, lik.bd, likMlambda) export(likSurface.rateshift, linklabels, locate.fossil, locate.yeti) export(ls.consensus, ls.tree, ltt, ltt95, ltt.multiPhylo, ltt.multiSimmap, ltt.phylo, ltt.simmap) export(make.era.map, make.simmap, make.transparent, map.overlap, Map.Overlap) export(map.to.singleton, mapped.states, markChanges, matchLabels, matchNodes, mccr) export(mcmcMk, mergeMappedStates, midpoint.root, midpoint_root, minRotate, minSplit, minTreeDist) export(modified.Grafen, mrp.supertree, multi.mantel, multiC, multiOU, multiRF) export(multirateBM) export(nodeheight, nodeHeights, nodelabels.cophylo, node.paths) export(optim.phylo.ls, orderMappedEdge) export(paintBranches, paintSubTree, paste.tree, pbtree, pgls.Ives, pgls.SEy, phenogram) export(phenogram95, phyl.cca, phyl.pairedttest, phyl.pca, phyl.resid, phyl.RMA) export(phyl.vcv, phylo.heatmap, phylo.impute, phylo.toBackbone, phylo.to.map, phylANOVA) export(phyloDesign, phylomorphospace, phylomorphospace3d, phyloScattergram, phylosig) export(plot.anc.Bayes, plot.ancr, plot.changesMap, plot.contMap, plot.cophylo, plot.densityMap) export(plot.edge.widthMap, plot.fitMk, plot.fitPagel, plot.gfit, plot.phyl.RMA) export(plot.phylo.to.map, plot.Qmatrix, plot.simBMphylo, plotBranchbyTrait, plot.phylosig) export(plotSimmap, plotThresh, plotTree, plotTree.barplot, plotTree.boxplot) export(plotTree.datamatrix, plotTree.errorbars, plotTree.singletons, plotTree.splits) export(plotTree.wBars, posterior.evolrate, posthoc, posthoc.ratebytree, print.Qmatrix) export(project.phylomorphospace, pscore) export(ratebystate, ratebytree, rateshift, read.newick, read.simmap, readNexus) export(reorder.backbonePhylo, reorderSimmap, rep.multiPhylo, rep.phylo, repPhylo, reroot) export(rerootingMethod, rescale, rescale.multiSimmap, rescale.simmap, rescaleSimmap, resolveAllNodes) export(resolveNode, rootedge.to.singleton, rotate.multi, rotateNodes, roundBranches, roundPhylogram) export(rstate) export(sampleFrom, scores, scores.phyl.pca, setMap, sigmoidPhylogram, sim.corrs, sim.ctt) export(sim.history, sim.Mk, sim.multiCtt, sim.multiMk, sim.ratebystate, sim.rates) export(simBMphylo, simmap, skewers, splinePhylogram, splitEdgeColor, splitplotTree, splitTree) export(starTree, strahlerNumber) export(threshBayes, threshDIC, threshState, tiplabels.cophylo, tipRotate, to.matrix) export(tree.grow, treeSlice) export(untangle) export(vcvPhylo) export(write.simmap, writeAncestors, writeNexus) ## S3 methods S3method(plot, densityMap) S3method(plot, contMap) S3method(plot, phylo.to.map) S3method(plot, backbonePhylo) S3method(reorder, backbonePhylo) S3method(print, backbonePhylo) S3method(print, phyl.pca) S3method(summary, phyl.pca) S3method(biplot, phyl.pca) S3method(print, brownie.lite) S3method(print, densityMap) S3method(print, contMap) S3method(print, rateshift) S3method(logLik, rateshift) S3method(print, evol.vcv) S3method(plot, ltt95) S3method(print, ltt95) S3method(plot, describe.simmap) S3method(print, describe.simmap) S3method(rep, phylo) S3method(rep, multiPhylo) S3method(print, fitPagel) S3method(print, ltt) S3method(print, multiLtt) S3method(plot, ltt) S3method(plot, multiLtt) S3method(plot, cophylo) S3method(print, cophylo) S3method(plot, simmap) S3method(print, simmap) S3method(summary, simmap) S3method(plot, multiSimmap) S3method(print, multiSimmap) S3method(summary, multiSimmap) S3method(reorder, simmap) S3method(plot, rateshift) S3method(print, fastAnc) S3method(print, anc.ML) S3method(print, fitMk) S3method(summary, fitMk) S3method(logLik, fitMk) S3method(print, brownieREML) S3method(print, phylo.to.map) S3method(as.phylo, simmap) S3method(as.multiPhylo, multiSimmap) S3method(as.multiPhylo, phylo) S3method(plot, fitPagel) S3method(plot, fitMk) S3method(plot, gfit) S3method(plot, phyl.pca) S3method(summary, cophylo) S3method(print, multiCophylo) S3method(plot, multiCophylo) S3method(logLik, simmap) S3method(logLik, multiSimmap) S3method(plot, cospeciation) S3method(print, cospeciation) S3method(density, multiSimmap) S3method(plot, changesMap) S3method(print, changesMap) S3method(plot, phyloScattergram) S3method(print, phyloScattergram) S3method(di2multi, simmap) S3method(print, aic.w) S3method(print, phyl.RMA) S3method(coef, phyl.RMA) S3method(residuals, phyl.RMA) S3method(plot, phyl.RMA) S3method(print, ratebytree) S3method(print, evolvcv.lite) S3method(print, expand.clade) S3method(plot, expand.clade) S3method(posthoc, ratebytree) S3method(print, posthoc.ratebytree) S3method(AIC, ratebytree) S3method(print, fit.bd) S3method(logLik, fit.bd) S3method(print, anc.trend) S3method(logLik, anc.trend) S3method(print, ancThresh) S3method(plot, ancThresh) S3method(print, evol.rate.mcmc) S3method(print, threshBayes) S3method(plot, threshBayes) S3method(print, rerootingMethod) S3method(plot, rerootingMethod) S3method(logLik, rerootingMethod) S3method(print, fitBayes) S3method(plot, fitBayes) S3method(print, ratebystate) S3method(print, phylANOVA) S3method(print, pgls.Ives) S3method(logLik, pgls.Ives) S3method(print, phyl.cca) S3method(print, anc.Bayes) S3method(plot, anc.Bayes) S3method(print, phyl.pairedttest) S3method(print, multi.mantel) S3method(residuals, multi.mantel) S3method(fitted, multi.mantel) S3method(print, ctt) S3method(print, multiCtt) S3method(plot, ctt) S3method(plot, multiCtt) S3method(print, fitmultiMk) S3method(summary, fitmultiMk) S3method(logLik, fitmultiMk) S3method(plot, gtt) S3method(print, gtt) S3method(print, mcmcMk) S3method(print, Dtest) S3method(print, mccr) S3method(plot, mccr) S3method(print, fitpolyMk) S3method(logLik, fitpolyMk) S3method(plot, fitpolyMk) S3method(plot, mcmcMk) S3method(summary, mcmcMk) S3method(density, mcmcMk) S3method(print, density.mcmcMk) S3method(plot, density.mcmcMk) S3method(multi2di, simmap) S3method(di2multi, multiSimmap) S3method(multi2di, multiSimmap) S3method(di2multi, contMap) S3method(multi2di, contMap) S3method(di2multi, densityMap) S3method(multi2di, densityMap) S3method(summary, evol.rate.mcmc) S3method(print, summary.evol.rate.mcmc) S3method(plot, summary.evol.rate.mcmc) S3method(setMap, contMap) S3method(setMap, densityMap) S3method(setMap, phyloScattergram) S3method(print, fitDiversityModel) S3method(logLik, fitDiversityModel) S3method(print, gammatest) S3method(print, geo.legend) S3method(print, geo.palette) S3method(scores, phyl.pca) S3method(logLik, brownie.lite) S3method(plot, simBMphylo) S3method(print, simBMphylo) S3method(print, phylosig) S3method(plot, phylosig) S3method(density, threshBayes) S3method(plot, density.threshBayes) S3method(as.Qmatrix, fitMk) S3method(print, Qmatrix) S3method(density, anc.Bayes) S3method(summary, anc.Bayes) S3method(plot, Qmatrix) S3method(logLik, anc.ML) S3method(print, edge.widthMap) S3method(plot, edge.widthMap) S3method(plot, fitHRM) S3method(print, fitHRM) S3method(as.Qmatrix, corhmm) S3method(plot, multirateBM) S3method(print, multirateBM) S3method(logLik, multirateBM) S3method(plot, multirateBM_plot) S3method(setMap, multirateBM_plot) S3method(print, multirateBM_plot) S3method(as.princomp, phyl.pca) S3method(ltt, phylo) S3method(ltt, multiPhylo) S3method(ltt, simmap) S3method(plot, ltt.simmap) S3method(print, ltt.simmap) S3method(ltt, multiSimmap) S3method(print, ltt.multiSimmap) S3method(plot, ltt.multiSimmap) S3method(as.Qmatrix, fitpolyMk) S3method(anova, evolvcv.lite) S3method(anova, fitPagel) S3method(anova, fit.bd) S3method(anova, fitMk) S3method(as.Qmatrix, matrix) S3method(drop.tip, singleton) S3method(drop.tip, simmap) S3method(drop.tip, contMap) S3method(drop.tip, densityMap) S3method(drop.tip, multiSimmap) S3method(keep.tip, contMap) S3method(keep.tip, densityMap) S3method(keep.tip, multiSimmap) S3method(keep.tip, simmap) S3method(anova, fitpolyMk) S3method(rescale, simmap) S3method(rescale, multiSimmap) S3method(simmap, fitMk) S3method(simmap, anova.fitMk) S3method(simmap, fitpolyMk) S3method(Ntip, contMap) S3method(Nnode, contMap) S3method(Nedge, contMap) S3method(Ntip, densityMap) S3method(Nnode, densityMap) S3method(Nedge, densityMap) S3method(simmap, simmap) S3method(ancr, fitMk) S3method(logLik, ancr) S3method(print, ancr) S3method(ancr, fitpolyMk) S3method(ancr, fitHRM) S3method(ancr, anova.fitMk) S3method(anova, fitHRM) S3method(hide.hidden, ancr) S3method(plot, ancr) S3method(c, simmap) S3method(c, multiSimmap) S3method(midpoint, root) S3method(as.Qmatrix, ace) S3method(as.prcomp, phyl.pca) S3method(print, fitgammaMk) S3method(logLik,fitgammaMk) S3method(anova, fitgammaMk) S3method(ancr, fitgammaMk) S3method(as.Qmatrix, fitgammaMk) S3method(plot, fitgammaMk) ## default methods S3method(ancr, default) S3method(as.Qmatrix, default) S3method(as.princomp, default) S3method(hide.hidden, default) S3method(ltt, default) S3method(rescale, default) S3method(scores, default) S3method(setMap, default) S3method(simmap, default) S3method(as.prcomp, default) ## names imported from other packages importFrom(ape, .PlotPhyloEnv, .uncompressTipLabel, ace, all.equal.phylo, as.DNAbin) importFrom(ape, as.phylo, bind.tree, branching.times, collapse.singles, consensus) importFrom(ape, compute.brlen, cophenetic.phylo, corBrownian, di2multi, dist.dna) importFrom(ape, dist.nodes, drop.tip, edgelabels, extract.clade, getMRCA, is.binary) importFrom(ape, is.monophyletic, is.rooted, is.ultrametric, keep.tip, ladderize, matexpo, mrca) importFrom(ape, multi2di, nodelabels, Nedge, Nnode, Ntip, pic, plot.phylo, prop.part) importFrom(ape, read.nexus, read.tree, reorder.phylo, root.phylo, rotate, rtree, stree) importFrom(ape, tiplabels, unroot, vcv, vcv.phylo, write.tree) importFrom(coda, as.mcmc, HPDinterval) importFrom(combinat, permn) importFrom(clusterGeneration, genPositiveDefMat) importFrom(doParallel, registerDoParallel) importFrom(expm, expm) importFrom(foreach, "%dopar%", foreach) importFrom(graphics, strwidth, par, segments, locator, lines, text, strheight, symbols) importFrom(graphics, plot, layout, plot.new, title, axis, points, plot.window, polygon) importFrom(graphics, rect, curve, image, mtext, arrows, barplot, boxplot, contour, hist) importFrom(graphics, abline, legend, grid, clip) importFrom(grDevices, palette, palette.colors, colors, dev.hold, dev.flush, rainbow, heat.colors, gray) importFrom(grDevices, colorRamp, colorRampPalette, dev.new, rgb, pdf, dev.off, col2rgb, dev.size) importFrom(grDevices, xy.coords, dev.cur) importFrom(maps, map) importFrom(MASS, ginv) importFrom(methods, hasArg, is) importFrom(mnormt, dmnorm, pd.solve) importFrom(nlme, gls, varFixed) importFrom(numDeriv, hessian) importFrom(optimParallel, optimParallel) importFrom(parallel, detectCores, makeCluster, stopCluster) importFrom(phangorn, allTrees, Ancestors, as.phyDat, dist.hamming, midpoint, NJ, nni) importFrom(phangorn, nnls.tree, optim.parsimony, parsimony, phyDat, pratchet, treedist) importFrom(phangorn, RF.dist, KF.dist, path.dist, SPR.dist, Children, Descendants) importFrom(phangorn, threshStateC) importFrom(scatterplot3d, scatterplot3d) importFrom(stats, cophenetic, reorder, runif, setNames, optim, dexp, dnorm, rnorm, var) importFrom(stats, nlminb, biplot, pchisq, rexp, optimize, logLik, as.dist, pnorm, median) importFrom(stats, cor, aggregate, rgamma, dgamma, lm, rbinom, rgeom, pt, anova, p.adjust) importFrom(stats, screeplot, rchisq, optimHess, rmultinom, sd, dunif, dist, plogis) importFrom(stats, density, coef, cmdscale, AIC, smooth.spline, predict, qgamma) importFrom(utils, flush.console, head, installed.packages, str, capture.output, combn) ## restore if plotrix unorphaned on CRAN ## importFrom(plotrix, arctext, draw.arc, draw.circle, draw.ellipse, textbox) phytools/data/0000755000176200001440000000000014530650104013042 5ustar liggesusersphytools/data/datalist0000644000176200001440000000101614530650323014573 0ustar liggesusersanole.data anoletree ant.geog ant.tree bat.tree bat_virus.data betaCoV.tree butterfly.data butterfly.tree bonyfish.data bonyfish.tree cordylid.data cordylid.tree darter.tree eel.data eel.tree elapidae.tree flatworm.data flatworm.tree liolaemid.data liolaemid.tree mammal.data mammal.geog mammal.tree primate.data primate.tree salamanders sunfish.data sunfish.tree tortoise.geog tortoise.tree tropidurid.data tropidurid.tree vertebrate.data vertebrate.tree wasp.data wasp.trees whale.tree phytools/data/mammal.data.rda0000644000176200001440000000204014375517350015716 0ustar liggesusersmU]lURI1j Jv#-Jʖ-K+44Nٽ,wg }ƄM$Kyi Q^x'R!>a}Fc_0{̎ 4www~nZ9Z*AIut(6Osx`׀CI)8svl&1wG3@2n̲AonƂ!Eӯe8OSEaxd/r0:(:"azmzcFoyW_ݕAsQ?G[d3"$]axq4 MŞ]D(NIҢCec?4aCj{_gFnϖAD^^uG{BF9r~mhwQ=d ԯHݏH=8=*#2[}~Q-GZ!=Я_]H=|_ErϾʞg4!y RgE;hOo{y}="EW [~)F; ?T` cٔv9Yw;üj_:`F}1 `]pvQUČPF;d+A#r q7BngP0aV#v_Uu+#^_ʼn|!U 8j`fiUu‰1LzSfR uƌ@5<@q/ \ŶCy3Ķ#4` d &'x5؎sgsehp}\_s *(j0"?̓q]GyXÉQ6Wm09r< V ;A>F"*;M M٨;Mgb'.߳xszޖ3OY4QdnAgYS_#phytools/data/primate.tree.rda0000644000176200001440000000570214376237255016155 0ustar liggesusers TLJFD%*bV! jx}0g8g@ՔD*iudkD[YeRt3]_{{gFF^p#]] 7x$y`)f*x Vb䱫՘Ux5Z#m=l970r6[6`;^`1.Nݘ=yZM`/Pal{ab_-<06p8 c1aaڐF8_z<ߞ_~"spo}_P~ "j/ ~C0?ÁDW @$k8hBp 0%C]@05< N(MF]5$# Eф` 5<>F#>'t ?H(% EPL \@ L$t g%Y g9TB4Bo.0s f~YlBBo>0[f`eyRsů)H;4Gꥏ:t(Eo Fa1i ?ZoAqg<>%x敬xӯ.yؑzϽ{ƀY(W䏼s@@ 7UU-پD{(2-6Nrfc ~4s{F1ndݒ[QЈslϵӏz$.3Ŕ)9\ 1c/=3"y)'k}u#Egzfc<9\mj%sPqojv] oɏ_fcdLJ'|yՃӶ?cY 3|xmǿ"KVemBOͶ(2hPorTw,aMLz~I(5l΢WVߨڀ|;ObuQU~OK[ZR-(}Q'zɢ?~ȻnsD 2̛OQ/7'd&|ybeÀ9\֕TP־7wΤK۠皾@C> p1-% mGnM"K_֢"ߖ%?f^m46T"bњ45o|<n 4ߑwߞo8W䄓kL>yE]z^^44~,uzrMNټlf'lqG?íyYߒ)/E+flj.Z6q5-ai()":\3=2(ns(bxu823rw˜4;l텺 =0\b8wd{ݐ?4[*ډ2U+hv;![R7ߟ1ݎqBJZ`88Eٵ{) Km|/s| C!N̮jBtJkKUљV|f/sY݆oxCAgB܁~62?qQDŜՉXӲ^kЩ%h QGՍ^A\34\3+݊/]W-Q Wฯ>vKŢH4kvC5OԜ C"QЦFz[G3q ZUCѬ-{deZ4{̫b# 6|hE\km4pJWKvTEɑH^۹+pL m 8(eX LgZaa%-5D3VM2eXQp< SK&B9LI>̫L,ob9>D)+r8C_XQXN]*(fi7t˫mTnmkW˚YBj7)3+esF V-2:%D+<8N~yEzF7+0b2X@K5H[3e&pp.&yQdYp8u3 a}(Z;T`Tsp\gHYYӆR\$F3o*jryXFkO369 %ՏD_Fl&˂vHy}JqHkeSF^ɤY~Xڤ)&d ,Ԕ9.-,E0fvA2%!NGq)H1Eze3<'9ըIduDp/ Vg&e ;ؠʭ--JE YV6Z~S_G` xF%F!?5]PP0͈ғnbjJ9,%GJ@mӦ.9R/ڜ+,D8vY zNsXZuhNo8E[^A9PIAdF 2SQżZ]#Sw fIN;5Q#@-buzO V"( um\\AW[# ePtXQbMP\m&P B(3! _yQ8~#4M]Vz@d-wE;}5gSCGeaz݆gPBAB(#|1K%, }qz/ xKK+KvlGR0G2Ij+36PQKHi5)NrnYhHXF˾M@nȒt:Kb PWYYѪQ,t!$^-Pq)8Fnp,"c (K䎝Ȩ"a7FI S9ޠƽ$֚)cg3kN >G L9~?߭zphytools/data/bonyfish.tree.rda0000644000176200001440000000625214375517350016332 0ustar liggesusers xE;$9s r&pg* $ɅLAOw2. ,QnAt9eUE@\Dc}5]=_^ի{=3>"UE+af͘Ph2%a bB`%[UW?My! Ӭ-<`>,e>#,,,k3u_@=<@!,,Q5+^E!c/)x2e :zF Mf iol lv;׀ׁQ^}(;鳻=t ^ Y;15L`ƧwC$U~3~[0IҐ"m aji1Á5 {X@ G 8 ہ15t:1M5xx tejqG wgtzތDFo c\d`w MeL ҀLS Cc2~S#tFׯ ft0~G1~sV>HHݙww㔻1_oĞ[T[v𶳨;Eek&%Bi{Zs1\B hDcC>Ŗz<#,E'S*n^4lF[˘U wˮ͆ڢW6@ϖּX.rF6Ctʻ]9ihO+^ѨOubo0e-/ν<6CO9yStpQ}[QЪ{˾ B1 )aZ~??~̅Tw&ʸ64c}b|>F?1l󮧆~ˢڝke5 gȐ>}J5fޣ!:KsخW )]K ٶ'V݂zo-|0ėPj/\Q˴QQ?E==eN',Y(7mOc]rѨ 7NHC%}2lT!C{Pv [ڌN(wJVyu6i@{APdމ+Fi؁|ˍ#)94`ʫ+\IڼnH|Jyءe2o؁'u]f/8\Df6/kۆY~scֹwQȲW3l}Q%kȵ/bymŖu(^WnBAʇ3Qσ׮],qwKP^ߖ :||JkY QAdo1'[ԛMI3GplE2ݻ k]L΃sjd[{}]RsPinx隗 Xh}ݐUݗv] 9?I\}~Ԡ>vorƹGzο><9*lMsUۈ EI{n&]fOaq[ZFmҚ|{8~dMɅ:*T^s%ve!qK-'o-q#WE8b}sjcM)[cUdS7iuq0D4*ȵoDɡOFinu;ٰ7?3bXM@{N˿?]V1g©C(iX#ULOq_ݏ,w3w5Giֿkz7ퟎvĵ wB@;=?emq}YSЌoWf!G⯯ BI%nei{բI?ɁrrxQe֖>mPr_:p_IKyx/JnyT Y.H/j 8$ӑV1k*±K2^Y`Ƌ]T;N"˜ˬa'1\^2EXT{`f˨a%˿hQƺٙͱ6ypnw4U?_`I hjpJcVDP"ub ~(.,yEe7«IN%l UDUn;̳ 0+e "B_QIaP5^$D$4F$@g /`!mX8Û5q.AC%VT8X[IOhRV4\0"GD1cAeL!p[j9`zqz$jiNȰ)"=( jm(E E]V8XWM#%ʐ8EO[$K/C1p,T5x'@BI:63骙Jʝt虤Zhr'? ?&YhrS)RgS7UPrS,Zb3SZ.IKJ,T5Jj$>I5ЯZh/ LѠ\BIz֛)-e$,{J,B BA7J/rXh9B9z3̔@|WbG A6@<ȷ4v'逻zЖ D𠿥qP~@@DXA x^8u% x7Iy?#:Jx @o6B88@tW | !4P "GW;Za? x2 ~'wP]I;F_qGt:JƿQEP(nimnBA_|2 4Aqp4ȏb+\q22L15@!- aػ`Z"40,- ţK#R-RJ20Q,S҈^Gyf\Ea H Wx[ Zhɘ%?\^?Eg{ái(3,MӉ2-Rp (6,r~Cހkpg b `F$^FTă^?2SPIz(J gH bFgg"a\Z܇kGۢ\D![Fc1r|XigЂ@H#%D@ FaV@(X~N? kz,1gcX+^pS鴼Wp,  J8O[0WڋN/-jBI?HɎ/L 07uԂ1\Cv +pЋQSMl D[p/(w~'0~@q[Tw30mL]{cFxYA }N`=wnEPG=g.-c!Yx_kapisn;2Ga(ό߱7l$ =cN_cO_􈡍e1C%@8dC?>aC$6 3&a3Bp8$℈ݕObD.RMc4W$$+)T -WbxdK--L3p2TAD*+R i$**USLʴj"5OTESJ(4WHNf mVXeCIiTHtL lVWZF+И9 H%,՚UhNcb݃`-Xi$&0_ |g߀ֿkN^3QSЁ_O[atoH߯A9aQz*g[W_^|a?:rkM;1t?_{n݈Ya}7vjZ=TantWquǥ=ѧ]6 Jkv>wy~εt_ymjakh6տPzߍX2j;WW/MW~Ftч_4cK蘜딞_檹{zׄ:ns3ϡwo-Dϙ1=__#u~r LU` tnt˯rj_peE{2\q~f'TV-| _2rG 5:|=5NUSU??RM?yO֢g׿!mߊNiTݰ|p~5v?fMqOծy{WGHPShϿ6=Nj?^ڦ0>@lǫ]kxM奓 { eg^@罂e)=zoW=яxz$ZvAB՜]>whTgC>p=T6eS\3f؃Oըu{Qɵg ~zZ#Oqly>aZ4Ok?4ҧQ]Mx:}9Bsl!nS}GA~%^5V_}Y.FGzs5'}nW#u|6}0:{QkrL5lfhʅ)^X<Goh[fժ^C.N}5kaQJߚ>TϫЙY$jeγgQp[^5۷xNvVˀV+zks&N_}>/ (8\wTWQ]8/.J7IkQCޒZp yhw|a}c3j#чǫ dIt̔-&Tvu^9}޸{qtja\>Xp @G-y켺Gf՜n?;{11q^Pa% zj6VB%I)@7r܈&fk43VvhXqaȉ5dJа.C+nXr>Ͱ}&˜=3XUm3qΧ@?ڮ5m훝j[.[{NZ'JzpꆽN4pa%%hس;'wvx}a/qT*Fh^ݘAk48Ѱ 4ڎahdzb-hF$ڎ6Mryuk7H ;3eDn)'RSY5Zr {)@љ1M-3'oy+͇&{לag;5n9=uNݰΉ}hr֟tYs~')Aé'.8p9sNpZ‰| 7@!Npn9(yDhOvi暍S[RSi μ8p2Ɖ3N4 'vh8Dg_3BN4$rj8o h8Lx8zcv)Py˾kܕs.h8M ΃Ԙof̝BSh蒶7~䁝\ ?@v$zGb,B\z|_rgpdzʝŋeߥp@/;|Ysu:׾xDp=V4wPK;Dۺ/T;TMˡ}%[+%lv3"gd,ߴ`-}BS]`izzFSK-~BO~؁;^l;.@^7~?pi~x)R0v#یo&]޷3y=qm+_FO}r+kl2?- n2V(n'eEvS-=|`y'?f$w AdxD㠌CHL5= P!q\_jzփ͢s#_3&: ϣ$|!dzS2%3ɢ8M eEAaC@c&gS3v9PY{D6؇=+3nɚ sѲGp&N11/8&ulسR0ەQ`LaNPpYǜhh)MbM qIf D5Y*A&S<`~ȜLgRL:2d>q&^j'Nlu'6m=6 nC1%'> 1ӵH3~Lbptkoe>Z d*pFȰ=W~_3O2A-J~<@̌ʱT/cH99O%kgk?!,x_phytools/data/ant.tree.rda0000644000176200001440000000575014530650057015270 0ustar liggesusers{tU/mRPni`MM@[ !b&d IgT@A eEQÃTd , @* ;NgMs߽Ɣz@E"Cd  "d?  \q6  'L`~Je6J9S*)y.R(v isP8J5rR\OG!܀B i)^J E>ˀB@-B~[zCEYLye Z K-&=̧᩸Ϳ5Qo2BM-NwNgpqŷ\IaS:Ϋi"bob+|یz;s )T\dYg-nѥu['6a.*N^SLE%Z̹^b\hqr OG~w-7)ϼv:;EN'G*&2|d-<-_r}쯖n4NSw_~sX[-tkgYq^9f|G,yCy۹Zxldxb98*F-F 6{~eHyy1֨x:g6b>3ʟDIF|^11f2oMl=g=m[#ox -=3}O2wws^wy{h\L"-pp۾?ņs5bմ9|c鶝KԈ|\}}\؜dknȩ9Grqƒ8z{[ZshXg2BW8uޏZ2Gt'o&95W̥_td;\Z,ؔ*M6* 'kطw g.b;wOO zĆe+o}KwM٬F5aU@Rp-C/h1if=5Zڅ`UJmj..)>_)l+1B%+yx''=j֤I z[PY-r"}b4OINc>.+qvփZNy%J}q B-%y $sW?x'X[Dh6arC%S'#k=ϥJ Nإ۫+9q'UKf+T9Md1*b9PY+9`"SD{yRيdVm LF]ZI9aݽ.fl٨S~q.i^IP"+Z8^8ᣮmFX< ~A|;PE08oҼ8۰{NPe yP|86jn[gvy_w,J?zMt"4Mfk S#6nэU)vKzS$Ylӝb#l|d#XY,r Ρ'E 5RUd.,PaJ<FY]L 2,JM* "NpyEM: d.oCHOK⿇3]/[^g T9d ){ㅝ'ᒮlH2e?ec){Y+Gߋ?phytools/data/flatworm.tree.rda0000644000176200001440000000222014375517350016333 0ustar liggesusers]kLE/p\hy]+TX-W*PHMӪ7sw{'lgw{c&jC@#~ Mj6MS>>Hgarˇ_93gɶoLۖx<^O') Ǜ_ ]ΰB X8I\7Eg}P 8뛁[$zVs6Dr;F8{JJ%/ KRKu[R%q|Ւ{$EMK4%-w59KzI=/NSZt`0#NSԓdK=9R?Nu@ԓ)_X) KRM(;vNUVlځ.~jLtҵ?T0t}=94}W6W?se=K_E3ϓYYLs\$zf?=]vTWPoMm"ͧЧwzrj;}14\x5(::ݑ8:6ϭ)w}J}wo@tKՃKf3v/4a-x0y͑L~eIhFjgFGOR{=Mr rY#_ufaWpP21̖s[8ZVlf :A. .9uĈ`b 7qp؁T`BH\ase>MhTu)"N'Mt6Դ"Bl!z7`R3l UpA}37Ղ .l3Mٵq]*UY`[5 v̔E=Y %+`Tmrn ",kAFl1S~ 0,Lt\n7(b-!hnV8;po!4y*R)k~v,Y1J[NwFiҡgQ#pXfiD_ %;}p\%Qjoc"phytools/data/tropidurid.data.rda0000644000176200001440000000413314376013105016632 0ustar liggesusers}Vy\YpFJQk{ ģ*UOX.x'~L#zFIL9d9<*ލ)Z%hb0[ݝ(ʛu:[)}܉CGSX^MoOUȤ4Ĩ 6 Nu7.MݴQOA}6TAz򜱽2'A3IC!mJYpe"B?PHmwz=)gYn)Mлˑ[_!Ƕf;~{>DUv8(;7vTx s4guO^I9߁#n;mIu|7@c[d^ܾwr~2Z啶@8&UZ')>} v2?y,)K}6k5>?ȟcawC:i\7]}AkaGCcwڱHw}7楸wm3/{$x^9u bxv}r y!\1Pwk¿R6ܜjwD@w@H~u+o<v@`KCs͐ k~ ))!g&A*ATH(itR7q!kvREIa;+=n|/3Z§;u[fBQKٸP7D3v!\Έ5xpzȊe.拣\Hxz/({ ubDrՇ EEtZd ]ΞH b \)QkƏnX+p?KVo'}략quːڋn u} l6)3{yU7S|8/z;COүV ުO\Z5dsӾL'e!ԧLX*:߸ ZY? gj/f߰H/]i-P}ٓ-Cnå˝ GcŁ`i&?yp@uwiV%i0j37WګhjӘ1ԛSh *:τO'[u壌}cNGW5QM\ʙ z _wƇM6 #P0v++p48vDǻE9]v^6ʱᰣvK[Hm*8!F湗@cVA'ZW5wk%ICܕ@m3瀺s6Vm̴ZnVeQ+W֞^dN^,",屫Q2R,2[WYQ_*cϯd)s1%!ה@C@Ȩ wC #IB'+722cDNTC!`ʉXCf1.AIGRqn@73 fg8QpGMdw:MG,AƋTI(qjvu˗լ2b 6E̞,H qQ9L+Kd`TH2"dNA+@dv1[@ Feq;SB&ΣIJȊ)=6 DqI9!O*Y#&gDIt5( eƆ}\; \m?Gl>Cb.l7u{a/}8oG"I)Oևo߇ڞ{o`W<2t j^{q7RLβUh^Z l-&Aխ@pS~\ւugԿB wf!:(u.6e[ ߟewxTٓ~smU= )kRn_^l9_w֪[s {r6d%QN3_=sS?{jR&0ߒMXin.jT/~i~vV .LdTx{\R/r6=B3+gKE(Θv yW12h;n˵PMledCv9(ZPʊѕԶP6xq+i3wWA[Z&JS\!]WO $Mȶ6952 ~ AɽUn_WE5\nH [ UPyCYP> L} rf7ˎ߯L)L,AOoV!`ak@I~kp~!\<Ľ6)G_BzC V}4?Pƶ:A~jgxKPƞG)Id8$|ζzps@ݬ]]XgMAUfnXW~$+ʃ}g2#P߱͠u6? ]օ(q³9D=K6qwvB:Bpf`HG6Xt I)0];Mh`dC QS RKWρW9?JgYeީ1wHuA;'t @z֘y\yɋ!}HZ$tD_Ϸk?w.P_9귉S%z%\Ǿhr1=BQ$.ޘрP<6jS"e综 |,$6uءyXk`3+۶ok7=ZtJsw}c xrlsxՖ S.B2s_P!j#@n\[|t؟/w<{{Y1aP^cPoT3 !]늻I"(ٻAO$PJh}%5.!MI֙2 `Ea ?eEo6wdrGl&/JGyALg0a6\y.I[X>~*8 C1K#vawUi[(>w' h M;g k<=쿭cV_SuYE"&t [.^n{G6 _'& |_ &Am/s{-, Tbݚِ4ZaO#fں2Pn8i H}!)e F.;aZ_'Um6F̍=͗%"Z? S. =* LE'-u{ˇ4B;I:a"Ǐitu^(U CQc4W^4AN>K ż+N'ӟ\v [ EqEpINdڎ;o5~ Ӟ>ܸNq2( gH!<`9YGr*fZ ? %|7Cz%,;9δƀYty0e&32{{ϒt Js4 AXX=%V*ӟ}>iWBMu1cԜ9cLK\K _2Bm:jB%h7Y|p']sf<3>vдݐ"((C6L`H?,8ǽ +qtP&O3H§A:<_ iS[ALοf QC] YWݸ?۰൝eVfiYSOЃPY_>L`c< qӼXmf>Ao""ݍמ'}+p&tw (HQ! Fq:鏭:[fNBd}p:p[%Ȁ*mp5DA!@ Mބrd)#F6|tC@}ԀGGAҕbKP3 }|~*3:A[4qL>:~/w*w|үU{LtyGځ;{^D7첸߃*aМX٪o=~xb& qۅ{fwvTOz:.wLOL9xA?t)3 ˺린߀?/\ t_v\lZ2lX- Jo0^Ӽdr~eVG[#ܷ(c/m|U^aG%C6FVo2#֒%,1Ť1Bmrbl%Lܳ%Z9a#%[Eh\Ûf\:Dz8ޤ7kz{LvK{ ;tOaaX0ro0i eQJnXZvZ,cJʵVKo!'3Z-Rq:;Ѽj13b,fdPDgζ%_HgF7Ċ洔 qwWIFmEcјuWdzY4jCRdGmvt}V!+=ߒE$LCY%w6 dNp핲xSĝΣO o~H%t>$[:wi27=.e}^#)eGZ[U at:>$XE/Y@y۹Crνw9y}>iphytools/data/primate.data.rda0000644000176200001440000000427314422241102016103 0ustar liggesusersYMlWIZvDmH !XljS'}o޵gN̼x#Jt(B*B+6@b`V!B`U;ߝ7I&j:=sϝrԕ;tgٶuN:/gb%;6*נs&J{FZy36:QrI<./H!hjquۣÞ'$5ZW(u=9Y<ZLܟӺ5Mz~:#L:=na'X̟|f7{w-_Y|tv:\L/KesU/; q.vWr^G'ܮנ`yu~-qD4ki{$;}79yx2 8[ j,Ǎa| oط;qb,֗5OYׇQN'ǀ?ǺvBo XBA< w C~v߱ƾ]X#6ކVi[p'>ވeۇ̓gï!?bB~ z_[>wt7?@ρA|gqu{7>h6؇|ϻGَ[S5%o[kڧ?SyڞrqY}?Ž@e8ˆ}qiO҈NDrtI)3mwXs!]_8c}}jЇշޝ6?,m>ޣz7 i5pD" vXA'w>NjC0R؆R"y>Ϥ2I%reRwF 1c-O3= KY5;$D-"hv,ԁvmjuzY\ <6wtAeքJsuI(bl V%lWęԬ4n"R69, UZpX˔R=E bMDzSOT@De/L{JU`gMQ v|]>%UBYGJgE 굵oů&| 5Q޹,af~v7q]\z`&[f Oʲ45?I(Ϟ3Rs3iT Pt``RgZ)dEc Qa=OEJ9ePհ$);fO%r]*"Kȣo3- P"&gص0-fX,HMeSJ.&=@CDtE cšSSTMXISX `i^՝ENW/#$t($n%lT:\[CdEUEV[TfSЍsDzƗD e\ܷe)3gIxUWT3^WM̫,ž0LӲt";Hr* -G(冞dUݲS'ڃiB.zxd5I1|E:sj]LUQmS)A-k-BJsyOEPBOEݐeL- ?+R(꽥扨%HJq+oeXsA+$jODs7?ɋ.?b˫\Z[di7?iי/iyp;phytools/data/vertebrate.tree.rda0000644000176200001440000000067714375517350016661 0ustar liggesusers]RN@$% ) IQ?OQg@pO`Ϊn U*~_1Q33;>;u-h[ӫBM>q`DQ8'Faa(=ƈ1f_ iNEEuXl:S,ثJdyţ.D8%|/[aɿ8~|k8ʿd}^ 8g]o& (+xTqk cSa3FPmєVw4uN*,E;w=)g!6>c|S]N*t\an__kSW̪WnIWlٍ;Y]"VDꥠȜ:>/(h[0X㝄@VdHڌ܃k6M5o"aO[١(~BT'o{)Iف¡x"SIv%Y}OΪ0weO/ œ5}K/āje +!>ymj͍E{hŃ@\ƣPNqn>)㇛Cg^Kj ]jMH:ĻS\.yE{x~2 "4WoLXHHY`79 MCEk=׃W|\BU:_0Azx m2P E8_Cz/Ak Jj?\2W-2}{#/N-X "7}R,n;oFxTH{DK붵( b&ӿ#AƓ_E٥jjY AI+{_oh[4 .%ă$va3 L3 USYk 1N Wt p'Q%'^J9ף*}A:f1CRT֞}9aO8&\3ً2_TjG G߿B*J,i?ӡDiz#}q'卲=,C mmޱz3Ҥxw~ Xmh8* x}H ߦ(t4x"f@}Zy 4Nyw a3<=2ߜ4_ta–F #M4n6X'\WP%kՁ^zr?d'|mH?(G=Eax74MEU&MxyWou$0e7^I 6\4y(#BX" -yd+&4>.Al2EeH} ;ID=xȱ:K1s,M i$'BXF9rDzw,'c ǿCJ>":cF<{#=AM3gF#5|N,\hQISڄ9N[@pz8b /X>R'!_ &yKr\Jr  `T@l>$9)n15J'MvdA 2S $Jro {`\{ljSIB3P E?:6WX3ّ]gn ̔TVqKڤ[>VHP~f„喼4Ʌ(H $c=nx1lu~qߝ:YW. 1k phytools/data/mammal.tree.rda0000644000176200001440000000202214375517350015744 0ustar liggesusersuv7'.)R(brP IB32WIy>JOb>Ҍ̏omI-qX983393mY8& , Y&s̟C uӝE KPpPZ-x#!cjN4 Bմ -BŞ?j)ψmvO.s^S^W?*oB[k㼟f6}̼PǮ.G@=,8E&ϐg90OH弿>&/)4 _Mp|"+%߿&oL"$ 4][J^I0S^@]B.ǢlֶۊQ붂8{y pĒggH,OVOxISX* ̡8OD\U:L#]aymuX.'c/MLdmY.!1ёi8n̈́uه6f3lQDe<q y͂jSuyͫ0q "/8c܏U7,0ՋC=ϠXc(%Hq:|2oǾ?߷\:Ni phytools/data/cordylid.tree.rda0000644000176200001440000000202514376226073016314 0ustar liggesusersklUǧn[R,h+n]-T$$֠V)+]q;ݹ;;:{gG"BĘHhmb/B, ( )E(-R AF%l)jB%+ %J\'fH*$'Jt)NdR dqѨsQ۽(hN(6 ՝nb:-Eu4q@I)+cpNhLդ17mzGݚ5NM&lto![ؒ /ip[#}DKQ=DIAtՄDzo^7GEU侵 Ŭ"fLF^n"Ϭ/nWvD5'+33[|+vJ:a̿J phytools/data/butterfly.data.rda0000644000176200001440000000523014375745637016511 0ustar liggesusersYKs^ZJ%˺$]-+J*C|I9Umaf;g);3KRU95bq{p8\bX8v^7 8 _09XMr1[δ[tn\tù_6~^r8X\`q3_[~w=_Mߎs9_ogt?k/燋RM۷ov=:X.-ïcjnz͇➣=ݤӛ|b_FrQx(w+2Q's= +gXUz#gⳂN e H̭EZrVT ?=Jů;N;5;zݯzV+'yW1h&ZeG˾Z]\hbcnz[5i6R+?lj 3.*3tb#8s5H+FiHBvc B+gœr'DSuϨ)QDoUg|ERBnAzH/] 9"n1]E L'kjcoH.gov.qr?tQ֭^%EN&|0w2U ^7)wZ:ѭZBB4|=qf͆}L^ѭ$O"i`Qo.vʑAfQǿHBТ12U+zSNTio`!QQ¤8:+eխ:ڎA.4r^ش(\-dץ؁-HFzEZԦ7M3X`qOс;H5M!l8ӅQF4AZwJ"g0ћ֫~D i~"L wA-E%ӺV\(0{IERw )h'~ [{ y.uR*ˮIUᄝ sI:,NqLc/TQi_jE2V9х3`6bKMv/Pm(+9Qޫ̏tȼ2췴GE,N>vPT.G©%:u[Y/?K/y''x߽XiWd }0W`%-|7VhS%xhzV-rQ.bO&#t}^>vZ⹏IF"#3Qk5 OwHbIUe ?Pw)ƾ99ڈ:uæd*`IS[(- GsLq@5Dhn~zn2i)/Mptެl/P je* DPVb":!2b$)AoAYo#'An-gER;,>lQ,TPEQ4gPxxѮtXMo*.aՅAzdX  co~ѯTi N(Pװ|WkΊ:a hMxOkA9/YG[ ]e [IR޼pORy%p Y~\=wUeTbBw1*&TO?e96OԺ4RU]Gah@whШ'eHv\ ُ\ \Mwm[r'fNSMZ{0V`3TJzȰ9 U{mbO~e6Uq+@Ā8PnV)SPI-pANwDP:*Z$3Px®(E)RD1 }$ZTqn6;УǽKV#aF^M6㩕WXY7ɗgU'w!p!m;-Xgע/3á\PˎA xGUE~8C嗡ڋ 2yAC~S39BTٌ]M/ \Fq"ǽ{W2U.HotM6Rݠ|6{%m#H՘ބA!hw㘁@&G|U0gsc<y__0<=iG?gr" {ySrI,ݢ1-d)zh g'y z#ˎ ϪK~K3hyD0$zBmԊEt;\`J {9&9|q%ؔf6p{'Stn/QXq 8uMǓ2f iSF"q{`*u(5Un\*sYKU驈ZoL;QaQ4&phytools/data/liolaemid.data.rda0000644000176200001440000000671314451602234016413 0ustar liggesusersZk$Wnv;W&;yP$1GI!ޮ}3Uuk1;!"h@B A`>P QQdbaP"1"s}*;uwy|sϭ_IJk;_} ڷ~Y< 1 첄2kzg^Sz~~E2vcõt[9e{QZ6Vεy-%g7_|MFjb6ztG/?x,Χԙ ,7{ߴYe>cYm S>[oHx y:xM>:pE?w56cjh=節==C`zgsZ@oGQxV=>MW4fIVҧP'v(=COj&,:oy2?ё9} Z"Ay 8#ȅyc_IsLU*ΆgohYVqq q=kEnk>=Oa&ct9 =@~i;l+z`ǺIQܩ=ȍ\叒Ue\ն,P՘3VMf˓X*C)vʇlsƳ||ȹ)U,''olmknR^?x~i,gK?0Ώz|?{aڇGN%S3Zw2r=x؋0+ٳ^N%;=moC5LvtD isWe=oaRϫ|@Ϟ 濦̘qoL}yX+zYkym5{=оot[}U[.h~p~S+AF(oV-*1niֿZjN3ruigE-wqPg0ҼUoiΧ*?v-_%DKN`U?s#:_oes0/П38  p aW1+@=%s9Oc.!e'w!O7o%{d-!^5 +gqӸsw miSj'#},!h^~.b~Lsb~,sW<>93" ;q^s?gPo k1 Y\w㴂u<#9p gQ\^yf42yx Oca|>,!磄]r)_q^ 㐟W lX:1֣?ge<ڽuvU 9W~,2ڹ/)Cп0/ׅ|uQNs̃>zy~!Dsї.ǡ>۾ȼD$i{@G,I#꾠7"zJzGrP'-ၬy&)G6`'t$>O> H3l?H|x@rI|* |lGAI|* J%[.e骡:_N'U(ɘj82t%&kҒi]Ԯqc#q5ٵXZSR-XI5ҵHl(fwJf(K1͔܉1p{z =#iMJɚnQ+u͚TAKdQHk礣8xIqa%a*d+#=3 ELLM=b}y3?D%PcIjKi-TKIQ \U2pVos+G2M]\'s))ˮEFyjs4RRd:Q<1?PAS4`$ Ҕ@S"MUTBH/ZA `,jRd(gH}0)G=eJtbI[Ge h:?yq`~]u;s1zmua+#NZh]̚ #[];O C~[tpƐ)nvꅑc겳¥?<;F>F]puŔ >)Ql<zOV3S3UUUӒUUUkUKU3/OrX̓ YY)I[ Hrذ$mMG`6Z>Vض[~U[u1gl^u?}.CY)f=fz8p82̛ef]5wV9\-Xpa]-pQw;PpbYw5"wcÝ/ozzdk|#79l7]rs[ٷߎWd7=ْo:g֡m=Y/JZXBO^ pZ$ Eb/RF @ EjH^ EU/)8M+yɑ: Q"WR"ċaJ#vUDzU(U@SE+Ӑh$ 1D5$$jH|iHR8 vSNC Q#\FYm@l#He )e |f>Le )oU#h$>h3A>neC&9|Fx%#ϯES 3J(&EGqFY)F̺̊ /8P<MNK|36! _qEȓE]'!#p17g1؃rEi"H̑Ϙk,EYc nOmٸaT9wܺײeE{kz2k`Ώg7Ut9 ^xIJIܖ}0[(h)'geꆈ ;}; }~[4)-SWנ ^Y[ҲC-=ļU1 gAzGvwnj7ΝN(8NkĵM(_vaW1{' 1~UK0fJIwRHd? "W>w!&[hb]_)YF&ݽxqe Ƚwx'!sš@r۳_/Y~zx 迩z`Ď/|iQV'T[v.m g./J; Em=O\no{2kE͔^C^WO5$Կ艧`ҒK[^lNίY۫GB.yl_Yv g?^r??H֭Y6A坹 ڽ`s辫7; y/uZ9mAn鬅)'`[_![^K© 4xdז6?M34>!绐<֚J(ɉʟ-vyE>l“ga|jJy54 μIPYY2N|mzټ{cO[vքe=.~{o <:qRwQ*ռ)邗L5}U!*#N6"QI|3FY%U^VO%+KV c`Hj ~ ;, (+?e 3 TQXð\Ȟ+DUc)?nj?o@#Pe/BuJ8O<0-NRD42)aGw[D,R#]TѬx먦UqS+R2TJ~š.b.h"R+0n[$˛84LgHZC3XI63Y6SSڀ V4zPnˇۘn|Pl-bsCr5TBr)5xf2(DgcOW0nY2sdOJl1B!(G!fmzj=Se,$'qfpm͍wd)TI?H#fi$n$=FYބOPu\žB-tlbw07iô{Jd>x:L,s?J𸰳 nb\_̃YQ%5PUn 5z\m0E< )6mCO d݁bY U9xmTz=.` fMubBe*0'VXղ}[ͨRA#:}Bߍ%خ٘J@G~I~f?ց w4R">c0Ɋ1h9_Gs$m4G)weAO_{MYqSϛQ8MۘJ{SA"Wphytools/data/flatworm.data.rda0000644000176200001440000000107114375517350016310 0ustar liggesusersTj@Us+q//.:m! MVciJFv>tjش3gϜ93SEnD3:?>hoGn/$s(7S&.)8U25k`]ooo6!Wu_#ymy%ms#K(6//!6VrS-!SJSgbmT+2c բ8琑rv.%%x>b9 J2PBC/4c~ 2*I[ :"PL!6KA*m]Ng qsUzvCThr4Fj@h`%x qVN8EnF BYC zך lmHYZeJF|&&z'6|rC^I_NY+_$`Ժ5 .|;1~4ܱ g1қ5LG"˰j#=(-Y'#^ަtżx~FFkHTTL]:dXú_icy~phytools/data/tortoise.geog.rda0000644000176200001440000000102114462276316016331 0ustar liggesusers r0b```f`afd`f2XCCt-XFN [_TY )b{ssΰ"t߳=uY(oWz̜;/P}}{E2f_3g3Ӧބ9׽M~ߨj O? lmcH>6;L4@؍'$:y`%a797<Vcׁ^Ue^ a|'F?T-@ر K02d@bKM-2dI,2Yrp!J8ŧ%'gb(  eA@~Yfrf^"\?P(9#$h@$I0@&ge"Y+-<@d]ldd0eb:I(4$ ļԢҢ df&dTB 5 saA JI,IK+;phytools/data/sunfish.data.rda0000644000176200001440000000152314375517350016136 0ustar liggesusersTmHA>=;4? )~D *E$YADD67w72;#~Ee!Q&RVQяkvowo=fgy}}go\ @Ζ@N]S⥋L!irMz"[@0_r$d[ArUhI4HuY֕l@ݍbP1q9 ͪZy/O;=zVK nY :?ÕoF[ƞ},}<ѷ`šq m^~]K_!0pqe6ǀ88#N3ӬAy8g\`вKT .3WWXՌkupŸ 񌻬<`g1#1x g1@ôQ ?# G4BG4g`ڏ/>D#Ch?1!qhQ/>Dh?x!G0G4>hh /ƣ1@CcP_C?A<G}~# ?b hPFA}ih{hh#E/>D%ڏ Q# tA2ڏ qh0|# ~A ~DXƣy>_D}# h?Xb!hQF%#K#h#hh;Hi?>zGv47GPh#'##Z m>t~ZXZ`X*bK+fKDW t |;/e]My*iv<W gb~{ͬJWp{,˶5iA^uc7?-"u+dqc~_1 ?̾w] Q+ pӮop[9P8'dG⼞'U+=w֩_µkȨm_z}d{ae1SFN.gӼBpm凧[s~8€?Vm1YbmweDt]\Rsgb}8OGfMd|oբ/Z6&# =~gNb KMUϮ5 3Yv(iw.ǑC rY?tL\Xo>:߾'v{M>/ͱJl\r6O֤{Vc{aQRdvz_{jV9lo>5tj6&l8=(Xܔ0X30-N?xb'f;ڮe$RW<-}?Dž]t-8bC,_vdqAbmh Q7ͳĢqyHCuޯijߌkўw&#\r7z>n6lȷFqvncތaf[ۋt9X}pSO Jبx7A'l6YR{Yٶzxsg0[ u~9";j:]V'?,^Xws$9z2X~;7~K,L?g{E~3G9W3n~6YRwk*i-%uߎU 81ᎤJƥS^58uWuv3O)i]t@xgk)SYM5Yfo?o}Nwۜ". f[pz䏁no7wdSϽjXOГ&/z!՛9q6(~#RE8bb=?oRKy.}ט[.3YR훟zhn i/4Y|כm7]6Cԕ6#e.3g_"DO,ۮM|?.̏~Xgf&*Aߖz 5jqX8 KdX忔Ek$SzkۤsO"myZV{p_J?}6ܼ{&Ks$._ӱ/.īU &K<<5?&N^7Y\;%ՓNt)ltGRuk…g553XدqJ7j<'_h`8\0^oj?cؖ? = svubuifu XN}|I$?z7bڸ?V@qA?͏^',ZF$jS{jl33FX,qߢn~Iaw-#h0u8m{m^3q=N:fnZWOz_去ޝSo'Kl3~F0^}#=暭پ?0%ߝ-;Y7^>zk{>Gmk .]LX.j8ʉToSX+oVqO wŃ#l/69,&>0~rIqރu/V YvGu1M&O0ۯ #1a/-,j}@bĔMq* 39FGz?-ٵ䅷_<;79o-:lꖲO'{pD _]~u꜉ξX~з.OٴRM{I5ۚ>Mlgln^RW\y`>w€=k[+f[vX Pz<o8'}}I&K6dQ*Xq/Gj=8Zt61:p&KLrBy)E&G$ƤA5pa>>yF۰ۘsê3H*3./=xg~#n}(؇ NJNop&{%M嘋DŽIYNH޽/Aq뾺OYFJ^v׭PdͰ'K&Q!gf(.Uw\=T^;.RK\N`zR7h1B88"=ɿĶg}xg=QzǟqYڴ_mٱ0u-N[z2;o-bxMwc;>fxћ%u덓n+>i/_.,ig']&-.uXY ZpZ v/S||*ib=O(joqX[8LsfG^~sZ-X mUyNaNH0>aEGݶuj/&ޟ3v?-_mdOe̤+OgO܎_Ol]f;vk&_wYSe3f8NuejˆƖ/k-u)(Loth`ԏ8Ӱ גpQ'ãV,qR ^g55Jj18/,Q FSKIS)BFӣjJt֨W )鉊T*N(kmR3D3a!>*Di#JN7I2:^c щz=/U&nAQkBx̫4T&ǒ*7V^] ey/J :j*v+)ujN1jh^DWr`2 x"KFͫ8YjfFq y^*D RCa`8w8 /3CPFPeh,*V0n#WixɞfώI˅ɭWLڡ@;E#aTIN%^gPtwqjAǗd XGtN.!/ηuK鹦+OjJVijm,Rz;(>.dOCn%_25ˊkY4QxI$j$盤AAPYP&ɃS)e<Qe5Tn+yE u0 2+ P؉n rCፐ0˿FH*)j`<ߡF;ZݭSzFfB"T&e[3-$z|T2CiW. j*0BC'Dd5/ YApO\J"w+UTގ pM5UGer`׃ r-($TBʢ|Q}Kaˬw8R48*EEcn\xHHw)|HѨIrTۅmT-+E8 2.NzpNf$<0ӯ$p jȤ8rҡ!DW.Y3QK<20+8M\"98jQ%o]J͐J-˾]S:!sG2U[CnتM/. E%]I˴WkH\e&04FeV/ RnOn2{xTJ<5QKe^('E2&` +MT% ;jaKAQp2+ks:.]J^#B"+5MRJa>G%4}eI(wϕ$/ UC!^425}$5TTZ>!/e|:VPޡr [FkJR3KMɥ]ZYLeѶrY a QYv\ tVZ]Z˛WV-i0v->JWWُ:eBVUhMaGka_UP5$5>+RjiGVr*;nK?Uh/b+?PQoEeކT*ky 5Kukwgy;0T"JSQE;`ȸ"iB(R#'i, GO-]RkTWiȚVaoo`b=@) Azhb*Љ8BG)TTG Q*lKQ)f' z9 ALD<phytools/data/bonyfish.data.rda0000644000176200001440000000255514375517350016306 0ustar liggesusersVMs6Uљqb[ӟ\zUQSTi' g BA@ʏO@&i{Daw^=Fۣ.GG{}Fgy‚11a{gL|>uP'|TOMͭY+nUג7:z7*z槎B{ǝ잵Ѳ{o6w*zYIinT"~Aϖ95o {쿒ڔ+kh-g[#XJבؕoT yej]]^[XY>Ʈ*GYXx&uϝC.W7ݑ Y v[׹B.1LX:)-mRGɒ-V*o5kS+?r Pft%w @xes%ɕq!J3RZU R4}?R֞T}~\2jE/"uU۟E% kпB"UUpf25w$y4+)X2\>-kJZgf=|X 5D y˕ R43e{齧'&P含)M̴*t>s=&%&yT@Or66khEџvrx5 nY+ *S?泐~(nr6rfxصiNRv2up$g4@bqae_[`zcm]r͞ $ӓJ(=Dvy|i]A2l;Ybncv̜Lcf3XWGNNE %,yߕqV!#8q˭ l{P;[W84d<`<.ySHdoGsP_ ;XHkˍp"S6UaጞypdpUaY(HTT8o'Hj/k-`agIH/dugDUK8 (@r#)$-^UU.e<=mڽCXi  W4o.JZg0 .Z(( cS7UiG ;r #1ף,]2Rkθ;Cp/5u8Xٿ PO yW +2\euh@ɤO!tﵱGSpH7>";ޔB^ iB^q7BkG phytools/data/betaCoV.tree.rda0000644000176200001440000001222614405405572016026 0ustar liggesusers] y{q:NFB> a.:ҝb#^ر>]!cl _πq`CBp\T9*'vJ߻?w۽٪_g]'+l,ewAPuݰELU:蔒n+qq1`/n t .#3 t,QoЎ,BۮLW5t ~B{@]Mh 1^٩tdL)6xݺ0Џ%J?_ҹ~/OLU{~V? uk17x{o?}<;{3?%x+wk<}ͷ_j%\~vs0tzg 7]W|cbo|w' XDw=+̣O<s<5ywOt *,SvLMz+^_or|rbo_cbb|dz[w\OMVS[Yz7NV~``*ՕMfaVDƝaDŽtxl.`\ Jl3kMjd~fn6s )rAs,]tX|q:Wp.bUyMjR1%?Xq^Y1?k1c1H&8 wp7 p/ p? *^MkHx- 3aeM?t(1ۤ-\LH;zB䩗74mi_LOGzWrlt8^Ga~&K!etYYs҇gJEmT ŅxdiM{LZ7a3U{t.{(rZ~,KU-_ޟ'ij^'ʿj:O,v|x SoåsM+d9dIrW!YJLMXUM![1^gEi<|[u{jܒznLn wKden&i܍sݼ[UV7r/_BepA&>BSqSuuU[q.lss{ tzDߏ }O>~Dk{&m`)3b6u}HGtdchI@zԓv2RY[a5 ,D-j6ua_x^yYx!׌S=aUձ*fEUcTUm Wd)iToǮ5b+WmE¨:}Gfr6g45-oxJ3F5o i!y8㡥mdPR!--RࡤsRYJ>4C>5~#Ixye9='C[|Gx4Xhi߸np1G(ox%\ǹlwTm AzW:Keo u4VHBlYj%R] TR󐶹JL= CImujyH.w=pPN!-+.p(?-/,3(/'G1sp|~Tӯ=T4u6R=b3kNǧHhT#b/=ukJ[dvjVBC_ҼO}\Tfu ]IgZf._[:peWaS[T<Kb`1Pb5%gg b a-cs8[1b) z%0p>B4ww޵,[t.[*$K ܢ;a_nhՎF] m[fSx^K3x~47BZ,nlugv%MrL1;*~zgwq75 )A[\^  p)2W\ [U&=nx5`?w^Hwp0Hfr϶G1m _ x.op^}}?Nx7=~|aG|I)> < /2ીS x𗀿<ΧVSJJwZ<9SGdId|Jjeմc3No+_Z*񹭐;6W6Qym~`@:R΅9W)@ͣa b̀/V>mojSb~vm ʵkL*C;6f嵫[}6u\UꍪlW޳Hǔ;YY_1=b^q:іIŮy{x;$TZqqOcN+ٯe)_uDL9wdZ*#K>ْ>K,Ne49O c:|xw0 \PS.?(GϚ̞e7{eGQ㕓EknwgL.%)8B!=dl=aUz6ڄq#&M^\wspTUd6ti\3t&SY9sfs\o1[3kh{\0n|(Bxm.Mi. -afPJƚ׬׹_\5/3_?C"3 xw>\宂]'\ [; mm]0v]6hB+n]ٽ*xg&J;.F@ڵJ(nTIE  |n0~;Tc;AQ)]O+N甼[k & ( m1Uލ.'OOi~PIMzCы&Z7mhV$O[&N7'½B\=hz$_0Z=A(_6-C2aP/=PO#mWb 4'"rB:u[ƻsݵTb~V&m+yWk7*חW2n0@q!jux_ z=^mu)w/j0m%t>aϻIyyWzu)}5GmjwGbɼo[f3dUIg<wOYy1P]<}'}(0N5ב7uy؄%GnKS^o\ն1y|/ u[*X>RLQs^[e3j?hKM 3䲡t,!)-cy ,.:oɃKv'>HmJ,N)Rb:l-@}/.t%E<.q כ aےlh.RXyw~i0_il\/G\~s_8$;$K>1!H4/#>Kc[N#jO~4Mj|Z!>>?e Kro/DAA\Fb}ᥔ?׃f?w\#/yu*ߊ?_+.Vɟ˅y$=Op:x?#/X AВmOM7:H:JM x$>>R H+K+iH{WK:,@U bWTǗ/WmUײNP4=ULxD_dHgu*J[n¦kOapxY굷YBrLRNΒ9iX(=׉Q֬;d)˲=$p1sgg7 mu#B|t}x49z"~06[4.T%:p`܏HdK$o;uEPPmlphytools/data/bat_virus.data.rda0000644000176200001440000000053614376767200016462 0ustar liggesusersՓ]K0>`(_ٚR(ʔVg kJN󗋩՝? B}9ms:iR'ZԛnK#N\i>LcU[kX[13Ia3 63rP)Dhe)A+)xiM*B|o{Tjl.j Q ,3J;[RynmUoإm&g%_pQx1?)#Š O?! ;F}"(""!h&MjEqqZX=dlk/۹|]=0`ʄbY;|}6t phytools/data/eel.data.rda0000644000176200001440000000211614377162342015222 0ustar liggesusersVnDvHDCنHoRo)4iBIC6Zpdziw\q;8⫀Nhk~Ĺ؍ݢ=awi}~dÆrKym~߶'| M_T{ab%|h̀R;z7L'?39OvhWfv]@,q`ONϿ Odi:3;/ڻvdm^CLw 9z^F:.>pwtyx!CZ8LƎ[k'p^< Y֪/,j݌L5%vNY*ώ{5"E2#l6Yt]9W5 Mv\tTq-D2R\Ҹ g\k'B:P)C` ]##dJ9 F?ʩzmiEJbR%H FrIXɨ<wE3A3P +/2\b }$ W1mjMIOBR|o8ґ%{阥d jeT6ZJ~#} g  #%MyJΚ@߁Y͘xSnN(Tr+Δ*˙LJ=MYE'bB<, ?#'Z-3蘒*QG$nB :AStd+ * BHjFCAͿл݆| phytools/data/bat.tree.rda0000644000176200001440000001100014376752012015237 0ustar liggesusers\ U&bB#5(D !D(w$!"(* ( > @DFYM]]SgvIH=UW3KsAub˗|p =ǯu*A}NDF!TEh*o&jO/j9כ[<0_VKߟ^-U8ҶTJRM+t$P*WA$,Ɨ'[ AU+Hֶ|޼Ʈ:̛kZx,0 7kΜ+^f\/sܽFY'17$U[ynu~w|D:'#6\pQʝj8d0wB =tjnPsSyz ]Rc7Ngt^ΎQ&@5nUAA47IJ16;ʸ=x: 7.TW˵-%ꩮS79rL D[V-k!C O&6x 4׭YG<~8Vot%lCKeMɟ~̶oMu}98Ư%޸ ٿ?$ޥd+el'NTV:VI;2b/$[N7>AkKמAEu--MdqxI?w<:J7xج?cKYl2K!,Wc%_6_=($m$ۆ kAiXdچDK8)4q۾7.lҢ#/6cx#oWL8 r6*UT[4jv!=8 kf,?^>/=EJrǴeٵ4_3dut-XtY[@ ̆^0/u&qF:5~S1 ~>%2%"0h SjS0!S8V9RrLm {02rcޢ YqbWQA樠v07l7o|+>FV+Ѹ*g twg^VEn+"\RrMeWo7u[hbЌ+涄05a;Dx5bg.]3!'хPoB,@ވ7"Q:D~E"B8q(0#KG""B,C шcoC*!G#9ĉdYN`f(_&0{ 0jh#m%kYz95m504孧԰z,-& S2a&\=[J}BTbP5 60UD]V6^imM뷣iw9`Sw2??E\TnU5W(*J..zg5uG%aWGzMiR^͕Ճ}&>5t[zF\O&jz3~:.m\ 3׷Q񊥃FZ++uurVC4awJltIvlnTl\m<t"C-?W+z:Ǫ6c>d D!(3;)RXRHRMb a(@OO6` &Axn0ق) q^rm{ ~zoWNiLJP35vPaN39 :4I< h@ )>ؗ`!D A z:Zl#,( b94#c̩qWƓ^skN} riɸ(Bt*\8BxZ0Scsr,eh, p:DgBfs|ij8(.$'$Z@d||TceS+!Qʂ!QlBxmN?Q! !< ijInƌUp3Ke [ɏ4TO lf5H90善6p\fe4a_㺡I\?=.] ?Q:ۛI^MdH"#)K*,syຠy'<۪n[;)5qI)6C?۵m9I2H2qڬlǹ8f FCO>6)$}OZ?dr]%9(=]9G\Ifmr{x,[b'ng+q_{=׿Ɠx=L {1۾$dq-|,[K\.]Hi/$iOᱎ!oӫKҞNۤgN)f9y"׷T/'}eMO6~^oVx=mygeߦW)~J=C,6n[OI7I6.a~lShlFSmX%;Oҥ4MzF7V+)~j8JӶXbd7 Qˏ)&m>G~\<&:).@Yډϵ[r2l~;z}P~~ҿOnvWFۙORH2ogWEkS?>WTƗՈCCXh tN ڙ St3"e5mCSZVgJZTqY9+=~-W*-GυiB}&[$MN4;M^g&p c%T%iwSlZ cgzPeOR+IU$UIT%J6{$ɜphytools/data/tropidurid.tree.rda0000644000176200001440000001072014376013062016661 0ustar liggesusers\ EnFn9t0m++.e7lɮJRhE9dEQnDPAChی2:Ya#;82i {gd9|Xؖ ?Ӥ)45r-!.Bc*7YӈfL]ǔǓ[IE#,hD%` |ȅPNI?BUh \XB8҉cl +]{HˋH8E.tay\XD2q.9UƉ<.J'NȉdM$X] K\I`? 7i Iy ID^ HکsaNkE.$\XB#׸Ή'^iOB~i 'V/s!+SWzq ;N]G'?$7߇PMDzH| (THd{AI9S>"O!2ؓI| $PO!(') x)zn'2I|W"\Dʡ"@wħ;gȀ$>=OAS@??I|zA RNAO`IʡwI`G]DOwDOd{Rj@hħ!`7솂|85=gt/C?H|*zI|*{>I|xSp‡I|P>X <eym1J!1-M4 iPvr(#i$LhuhZ"54tRbLĠfSXJ3HyMH7B࠙|^YVOfb`lB78+Z:mDlޢKPե)=)c:ɖ:C3+ҩ򊲆eT*;9|eR5"f**am&2a; M'š4ʘfhI6^evLQAz*1ʱ ]jL32t1TFCt&ВI!ODL%eVa4H+ǾyZ#zB3+Cf\\;HGRT$Ŏq`&O;-&JMYTnڍ宊TNVNH%3U$J-$O͊L̤>qoQTFt5|t6εRE9G:0N3.T*U$Y2ZmZR;)з7<Է=x6[G㚻cMмc,=~:xg@zTʮ;+F?jwaRLۇ⦑9Ď؃kE?8sI1zgu;݉_2v/7Z5.k#c|ۯzz kNCjUhUݩhKc7NN[g:loэ['zoYom_cӿov~_ꋪD;7+˞A XQ09̂mVyJ}zS|׹K-h˅-άB[rʫyrċh۬3=2TgZ2)wo; k_Ђn nQ|Bozg,iy;{Đvs&Fc3nNz|u]kک 4we_|m>;rU硧7V)<k'Pm)էС7/-}w:z_; לhr< f7k{[{ѡ-Oj_92?Vg/%ןAήQZ\VC GՋk7v xϘ1S<. zwKQ[m לmvKhZ{eV Z7ڧY'y҃W_w E&u?#4o[nڲyW߼p`ƴO]?xjZ?q;Sq)ھHzk-"\}嫎AKfNu/޽?o?zyսfw ՛S4kZT-蝷9*.gݻ8TgF[N=1Zy '/{YG<€H'Xب   ٍʀ x0m$p x 0)ʀ X1G5t1]L[*]X0 Xx^ xck򿞺©q'WoK9Wj=} tWSX ֌ʀV X 0`5,uV X 0`.u}2` ]33 !d.Fmw3Ja;8U+`Q䙱w"k[{O*ݫ =s2`?.0; egD֝v.Bae-ycۙX0L0C^l!=dzrP1>E2]\•̽ 87Tν_Y'">Y7ۧʀ}}"S6sFe>-`H>YNp%ϷO"c_u-3H'r";N| 8' 8[lT[ 0Sg">5Y#">cXg"%9͍'}Rw+k?w+ɿ[?M/ ݳ^+n-sBW˗ncVe鰫0\E#Y}gyK+x|_zݕ^VbJK>̮ )}k[okR0D$_:Ò]8!V!YRk^{%?^VI! bU P*(?BjTBApaMG IB ]05 {%e%YXL7ʛ1"o-!T~_^/97/Y@ SpP[B xaNYK _J>$;,e%-)2-9ĢL~ܒdʔD񷥀N-I2 BLiu(ȔA@%S$c${L!Q"uW?ohnI2]XȜ'$yK%+wHg=y*)#Xe-s,2Wv$$d)sT6$sT!1p(Q  D."AX}\=RYAa8jPR$s͇猏9lBaI旂(EN4eFI~!q I~\TOiM0/Cz6iM(KӔSQXz!q>HqGE>)g={jX {%|~<嗥X߱iqt$-#?7l:,E(/[?Yq=YrBc?Lz>Ri$nXE<”M34b[2[=: Jphytools/data/ant.geog.rda0000644000176200001440000000243114530650123015235 0ustar liggesusersWo6Vc:t;`ǒ-?i7Gaɀ 4EK$R#)/?Hh(SOǻw?M=` {`߿`/Oa>CL}34Ax3`no6:xcȺi:}co޽z3T 6!8\$?Kb:%*QpZaǜ :֯;֢f1N{VXqYQƥpF*Am~ڱ2+DRѬD ŵ.DY܂} ^Wu+*8<%V4v@%bnQl{1X iR|k'n71u' ov,+|?7g{N;cpmB((0CgM< Pm Ow 3Hy2^̢XW( Fa)3v\ڧpRxZ7CQG]|@)jP ("`e>E[@)R"b:%@ *e)ee9ee%eEmxx)nMJe#E}g9 LQ[m\AmަCQ]Ey{Z 즨uSP5KG]m4OUUOkYP=mLWCiy S!v t5iFtU=SdLW;H 2]AH+<4OiwyLWi'<}&i<} 荚Ei2<4O ` <LW#!?Ht(7Ty:i@#Qy,2] Ac8`<<4O'sH4 LWtu*<GӐi&0if!l8Ϋzz؈4 #]K">#$$GL-"cS;柨5T#6]s^1~kTׯ$ڹ'?n6[Hh潲 j4YäW}ޞNy4nxWG(  ["^1`f)YkY,$*_ҎC_<۽$9:{_?EVWW?Oz-ʩ ]znS# z}{CGt|p떾)HW[~NƗg]Ir!Ӹn;aViJ뛧CIґk#ZY}#X27dkxa{1%hj?֙EK$1ߣϽo`߯S+>r#d GZ0e{sՊG\Jvv6|'aLRf_Es ǯ: {!w?GW냋K/5L@;:~;5'^D~e(yp)`S )?<?8S:yFz/~Lu\ZTŦ]ei/j(e}t)@1H3d[ǃzHɟ֫*n>FIGpӑ9V9p/Y= z$%·W)mqҨ#vbK𵏓ӗ#~/n|tQDG=|OS@T\;)o.eMɈ);)ǚ*yW9l,nڜo$!/_fƧ7<.]TZƍ[*/f"$̴>͂7][71oV% =v8!%ߺ2b._e\;D63~ǷPzli3zWuC"wMm?X:IX΃'GGd}2,+vtnY 2(E+rs.pFˈR1Cf3iVHvI$N+s/ Ӫ|~K#y6 ^y̭ $m3<+\NN1 !Ȣ2o!acx(N/.Z2w̕$% "˳@Is) ŤK9ʒ'#pn%x6';XnCh:!$9E!sH}ryԗM*KR_,# Nf3N`I99D3>uv{"pLQKZ-2JψƼMY>Z%- 6P3:NuC缛>՗XYq}1|<07F+%G#gX$YON$oYE"4l'0z&v2?oe?id8n[,Z-;=;ͷ 4+>ox@`^_hqK6jM'.>_݋LJ}ArJn֎ʄz%H߫LIGX'/FV(ʃcb%pZ$d}"zx|wow\ue} _>03t^uvtn+gWD4=2ܑ$ٙfK)SRԳ} ߼Q -p ˘7.; =~ާs)_ >F ZFX7HYXPx,.ќd%y8CqDu8)7y {.2h26,2y Aݡ 86Cw'IQ ?(IIsߓ%K7@lVphytools/data/wasp.trees.rda0000644000176200001440000000146014375517350015642 0ustar liggesusersTS@i@ TAE-g=xrp$f5ٍutMb.{?;yeYVͪk̲6 kQ/Q+D۰~< ҢSoHԢLLÈ)^}+WpmB*R.YQƉt}ƗrX F&,)yr*Tx O`)M^s ACl'5Ygޔ/Bz楅^@ߔHn@cxAF,UO<*M-ټJe Ł})Li SZӝ:5ãQZ:fp:fpNa` rm][)0-A´Wuh8cZ[| t35dt2鑊LYq>*䱱b3/0 /<0UI!VT-%UpAyJ*$W4)\L4q9E]I2"Y:Q0c,A4T@ƅψyXkhIhXD|`Z~jkɵUcWfhiyj)ʜphytools/data/elapidae.tree.rda0000644000176200001440000001252014432737561016252 0ustar liggesusersm{@UrXxW,s,1/$~ʧ&;.AL %S󖨩Z^3RP47+3w=3<9N7!y?=#QF<DZy=@Bn54T(iɔIR&RR)(RR()ɔW(/SQRPFS^$QFR^@A28JoJ/JOJJwJ7JWJJgJ,%MH@DR"(0J(%L h(?ŏKxS(m)J;ō$SJ@yByLyDyHy@OCRQj(SRP)QnSTQܢܤܠTRSQRP.S.Q.R.PSQR~F9E9ISNPS(RQ~L9J9B9LRJr e?ee/e{wݔ]o);()(PR_H\_ I ࿨9}} C5Z$y./ZV"/w ]9}-CNEKρϐè) >K࿨(DNEH]9- #]49}>D]>r.zxI w() fo#s,-`&&<r(A"R||; "7$EVw( 0QύK=@&`s(Ы||T ~X@ ..S$EDcӨSFDkA&.,.$."TwﶥK*9FDsDDc.%> C?s.DkwAw&#9}@wN%K<2hd߭@h. |0]1;&Z "НwAsN%9=/ h%!Йć!7Кw6@shć&# ZBDws黠7wˑ  "5D[=!Нs朾K4CjJ5! (99kj[ng3|]^ {c\<?;v'Rz.3e]NŚ_:9h˜73>qha+qID∨S%m>c.}؁#aeWJz*ss[WdKFw\e{G?W^E1YO*cW0O~뿲+-տm` gf&1T1~3:k^~XI09-L3̛iX4aa- cqipЀUvE'rb1ӳ)ncW|I}㴐_>m ^^̟9G;,5S} 0gmfYׂ_+zLO,\x]a^KO-ii=[(37j[9,,~vqvgYgVIi F9z^+3#8~ ݭǞ֎\ڷS{OĞ^}0הo,;?>{1a뺆4R?m ثFÞ;8~ĸ>E_vZ푲y75[_+i>dܛ=p=>Q*Ǯj2Ovtr ўsGV>o ᠉gk5㐧?e9f/v+4l2W=L=n [>gUv ۸Si~/qyN5xd} VSno~gc`9x'nVQH^]an:'>CfQQ%i+?Ѕl!Y+7^r&qOֿ1fxBCwŐ7fMwlen9;8Ne]n)n']{=/R|FfU?du'ոevf惗OEdʱ%EkqTQZm8˞m=<7+fԎoGvmԯ^fn]-9mdr71~c7<[7jn0G.P|aϺ4/ȱ_eѵ5d j~=ev/rC ?~Ayxͧ\7e$mzFt]ܪ!yp]m@);{P6lSnY7e.u+r$w◅b?_#v7k5o`9Gna=ڙƆB]xߪ|0`9w(iH~%3mQT?9F~u>7-݃;'ne9vݱ+.Y~{)Ri٭e5ˋqseP-qiM35zk N;1cW>Ӵ"z`O;&]zn \[xv+->'cF3v{㫰Klpg{s8WC6WO:}+_w#9 6ؘƓu1 kpuɽq 7|,Sw?\>jw/E>uq>_QUc&4?dmcLFWAUy]Tajܭ]9E8fɺ69Q}6?%4ۡyD&\/&uMaSINgvr,+{Fr(>D0&eRf›LDp\(3Z", B5@&}" ;m&*g3bT+_8D]Gir ʰRlC/IJ&;Jr*uUu,8gvaW^8xXe/@xF8T`jd܄\6_yb;M hz c8mWC C)tC[5" `r&Ds3쪮Cπ'#)qRUIM@ _qIw,&q"tGNY ȫJ0U z!Rl4LґFt?)ڠYiy_3;+!#X?*K9`iP5@m?q)%(&f]gU"eTR-UTH2ꕁP`o͵9KRs(*.Ǫ Bd2VM,uV&D J%&Բ`S By;.<`CsŠ1W/E;x\BBZf=+怡γXGWǬNFr-̘dkũFaWN[/Dɴ2{T950,B} V*WR2Ϊ '80x?z\ GBoR7/rs_g1]/۞8]GÂ3YgbmF(LB+QAͯ RRS{pqމ_!L< y)phytools/data/cordylid.data.rda0000644000176200001440000000220514376226115016263 0ustar liggesusersm}Pu׃kx mDD#IxgX D#{w{{Nj !K21ТIC8D)"ߢw0No?|>'afY 1 ϭ"cfYf)R)Q:Y0{Avn} N:^;I%AomZX]Jmˊ}CȞf( )Tɱm dͮJI,̎?̀ iWsӂ׶ɭD3ƫkO)Y趯\ ӝ}Ѥd#hsQmۋ-sJ~gL}V[a;ܝ+#aи}=RwrThizlMzZ}yN9̱o A[I-$.[sЛ$.qH= *avbSGO_Ofr0Dt%`GPKhhkd_'`j+К\/|Sܿ6ÆqMdN|fmlِ>7|U δF6\ G)R1O-p] [b}RPQxCl.g;*S8MΧ~n!k } KВ Bs&"QH)wkN)6vJd8K*`hv} ^(B) !`iFMkH ,oMhhGGLOSGI$u:ReqDHґJ,ך|C%2 nCY4 23;_!=x" !BaxD\9Bn#MR=Eyx1r`xNN3Yp\.W5:Kd[ Z6u ceid!<RnjTF0Ogs3|1K+k xdoL xxby#}fd_[th(pci pCFaV(P `gX#8K+GPA}?cyLIdΚ12@Y(ʰw @Ęh^e}7Q%V Uj@u+>dмZ@m>1wh]9ߠ{h40@SМhhfbymL[33a4euoN,3 Е%g݁@O7Зч ` d bм `(01 g`m薣Eo(`41s(c{ḱj€p F`aD<+`DѲv`, 1 (PX^ 0Yk0A'1&Yd{} } L3O,O,m6c&{w+;E,Ap\ 11a@h#;9}jh7QzhMCGNB%/:@BT@xBWt ~z@@gN-CTǨ8} v3:@ڥzhBa>*4  !t^1@_QxMBT4ށ@hBcj;D7}B[jڅ@թD t Qm@jw /څT8!KtfBTtv!QtA-w -Dy BEh4@yBS?BtD5DyB_j=BTw ,D )ziQbށ@Dt Q@MjZ@%@TOFw ,ZhQs@!GtA*w /:v}BKj@|h9}-K(73R~EyV<ށVkP@k7:O;z?/zlBwH lCw ؅'@x`r !o0r:EN@ǀHt9}%'|WB&)nͦRGe&[:~o -#`{mZ6ĸg -GJ7hstxy Oo[pZYe^~_/}q'{3ewZ"SU=w(x_ܷu8}OƩ Lk4Є}S~;5oU?7vAm6@~z9q 5fd_t 3 C8k;B.e9]58}~M|M^_6?YysϭQʶq=goqҫYU7y1lT$XP  wT\15Umua`i |uoŮnGTs H= +Ixg|5q ald0}-Ոt>U(?u_D|)-BWc礴RAxRO(|bGpj>I‰-m/4j;C Rfb fhOij߽?f}"qR|eڑ"~qrf˳C/qE|M3v %8;lټp"Yʉm '57z`G&ގ`>9/j?EFCx鷮NAM^Hj|'6')?=bꂓ%3O9J|d 4PcA|WvWFJئF }N|o=הTw3+L:.nVۤ*'/Z/ǿSgx$ ǙJV-#n>ӽ|SM_6~b67OSEY2t:aImFH<ǵITNXvt y]桧> ʍC^ L yLah/T/7~:(!F,bبMwE6;8ëb8vLRӄmo?#/}FKD ^i:k5`~t2dI7eJΝįj/o7ymJy)qEVbf7vl@ } M$p֘Vɕ)~_oVi3 j.G>-ӾV[ƏCۯZ]R_O;3.NXQҽ՘gdUg-QـYQ㳕)GKoMU[ףI@PmLox^欠ƐGu0O'M) j#?RŊ'nV ;6YhN<,X')~w+,j tǥ יOcpmUz?FuDKiRԂvzQc]/"5=k^?D|vzV􇒎ˈ ۜE<8zSjD= %, ?~Ҫ z1oϼ gMp-i }>W+X [8yտRMP5>ѽJ}O4]x_ kghc]Bk5 :'N)ұƠ n=lրήh[c۝ٯWƝ_^-}r|Ampfn@0]o}ݫ}jsYjæWtE{ĔoI<,IvK=wERW|CJu^ qid{ ~=qSʅ_\<= zoZ=V H~ sgl<)RԎXdޤzm|m1oH뙏n]~3\:N-=m\jLL-|.3iͧ7Έ^ꊤDf3g_Ɨ_v1\mr$fJƺ~pq\]PB:'ҫF/!G\mx6=C/ᮈe6߂H Ulĭnplq> K7ʅxoc:|{X].%SC"W/C'&ϛ^tN^$>rɚ= ^В wvzl't9>c[Y&~Z3_2H ۔L7T%,4Pag.kijaآG>qjQΘW%k2 P{ӌxcyV'&%$$L9Q<.۳ywsӝjLgL٩)G[v[v)~7Zǯo_6\I\d@ReEibĻ8sw~&e'j *]A?j++U.NDJVݐs!5ۑKnï|/\IGY&v}u^ar.3/ʊhF/+* 6 &^)Pdbt$ʩ᪰&Kl6&r,&OFI+T̜ekr-16cn49DguZ)-f˓ZaM8AWۋPNxoy^H\L< i( 5Nf^bhQe18zcA;(sΈy)R@HY d:L"Βrm$؄ܮiƿO6*09,\r0ź2CO$A;6Fn?eUCE-`1,(mV sn)XC]h,X8uj'1TNAҗ -5۰TޑtaIo[x+,Z9Xݐ5˂"D84]Yv^2n*E-*F8d**LIQ^Q$6#,N`8NOr,"ttg.6b%.t_F~PZ-ޖ6!`Pc,\H:xѮURGM P^&\&12pQ~daMT=Y#o׵KEr 9~XyΤEPumzv`4;MD6w /(fIfk;i3CXQfrC)M`a* St"*3X.V5+$",<;r,_c,YGIxSTi.q6u_"h;INcޜ?KI5g<+%!`vHas9.:E,]0m?nCHj:¸"ӟ\[+csb#euXY-ީ*ʆNu. F˰1?Wxp^7~!I(;oT!ͳwp=Up/aMsE`[S H$z9CJb b<'Т#n@z=FLřu7^JhaW>ww.*LEV8t)U6' JCg՜0PTBkVQtwtLr qSomF8n+zSګ7c\=kgkcWhaRYfalTO%5YV~"_M^$Bu^#ջz)Fv A輙F31TlP)PZTL`]o{#p !j[] s _pxYx*\Ҷ(g/L/,A(JGV1g•%"wHq7rLkq1VN `$J۾+/s5"ar?cd onuC_۹ki笄ZS_i o5'͒yc,1%,\&J#gUY,xF91m䎏, \(l̜ߕDw8}{:\1@<@9ϑf#%YMW1׼M(n⣠(L@S/phytools/data/butterfly.tree.rda0000644000176200001440000002063514375745611016535 0ustar liggesusersuw`E.BB*:$@ 뱹݆+i4ɋ4HQt_: (E E:R %gwgOĐ!?RJ'~P$vn؂@БR$bX)FN(Q-E>B4 ͅpa\TԀ qa\M@\M@f\I\kΕ›Zr}V֠6\ĸqa=W~MPGNΠ.\@AraW7ԓc.'\}r4 A@AC@P0 hP2dХpa9dI\#̼. pὬ\ ̅}I>ٹ\s\\X9eqa9 544)3 \̅)AS9k: .5k6ח\y5kyۅ\x"bo--2\f;J*j\y:zu˵;F&\ʵ sA?pr'.Џvr g^ v{=~aü εc\qa8߹|4\s\]E.|%e.,_]2k렿@7nnqur.>{.!CǠ'<\@Ϲυ\O^qzÅTUąwbW).@\X mJsna9 U+HhP WyP,Wy^W Vk+q*@Ur:8չÙ^_=.6pzj{xzp59`}z8$.,oՒ9oo՚ sm<7Zrw99HLacL`C` e! 9qG!0!0=.:r#09Ɨx 99PuuM`ܑs q!G !菆uxE+~OzY ?ucCs2 pAoso2` !A?4Cp!Ȃ%X_P:8gA!AsxE sxE+\C+8?ȀuzC?:A_4CWuz/C/dC  jXg9|#Y  8w!ȉ9 !!la|C sr!gWpA98 jXO}Z8O}!A&!pG?:}D;dE 'r!Ȋ!wAN!!gC; !A.԰A>԰ANCC"#n!A>!xF3la!r!xE+^q!pAߐ sxE 5C+ALk1һA6|LNO۶6~l;e{rQeE}X}O/=ߴk_6/|͗\v~OgK (ڸUx=}f౼,Z*wzj e\sDzgЫ03w1ökܽ{,ʻc+dնvYj\Q}V%ۈ+XrAsѼSq۟J/Z>*zoMw#ϱ(ݴU,fZWc #V"͓1f`wV<7X!~cW/g^OY >f鴶&~K/.82f}H>E/ah}y=ʲ_Bf 3O~ϛvǢƇw\]26XD?9 ?HNRuj5 a>3IOYf/J_a/;O*Uir2r0/cL MyCn]p-}-/)_iz{NߊL?˳\Ucy=ϴ ͥ;/=ŒJdV_߾1l<5}~{eʥN[Y ^8 jv'~uaRe{j73>Fz f|ܞEn}l#+av^)+u35e1&9_]]ܒɋZkC{=qY]^L>kÏ>Ty0snj vYYY3 є!ͬ:u&lNUZh/S"v#&zqzfZ1]k<.fL_.kjnq,|٫;>=#͊B5nx ^|/VѿٓcH';lq" odCY\m+.;#esGOYFϋtI'Eo89U2.>nG҅=x3v)b.NzT<ƿ{׬Lr+Onv6z7R1iY^,yU2 K"H9O8|+Nm,Y_ȪF,40Һߕgr9:`Iq͛??.z޼<^-,x٩j +o?`SI& eXNXz5NwzY#bu9U\8yExV{}jm5qWXD[g +8翼IG7m_X>sݷon4-:/(paǘDc4/Gj\|킕UXieiAby*nKp|I$+`=g(V8Gdl$jelO܆skҫt-`!a#o ӷ -H*/5*~Wu [Kczl{U]0~W1SҞOE7G=7q->0ilS2b}}};5weYU'˝tozXbmN9׭5ZO_şY@r+Ч 띫:ޘ>yUtW M'i[Z)8c`ߩJdѡ{hhb8 }ufgqY?WO8{q zM}uO/+5mfq:| >\lXV{zᙂxzL.Vcj˝vf:ZYdGћvWVd'},\_Y~ݾB*o(}/kin) 2d֬{;XhϝZ/fWen,!+M:ڋ9xټԱN4a~<iv6,_18 ~h?vǝo7iAiX}Ygjժ8Jb,Gǃ\GlR4V&XNׇau҆ؔ,>;Z kFTRcQ=joHb {oo]ip⧉ݪ:. >o%v-d&MS6i{[$IL Dz~_ݦy+t>o4PB-ϙNR/GS'WbQO*8TsA}BGT)ӕ7z/)t,zl~~͂'Dzvdh =Ǎ h6XNɛu4lԻV爼?_KV^?4Z0^wX|r2I i?~EET":ZhpE,ζr)>:3u1Cy-L{&n1 8_O`mꣴ\ۇ)EuݱíaxWêirW*ܼ˵h.׶sͭeD=?Fޖ=t}Z*h4ӋnRK펯*ѿN 8Vwҧ:1e&K@fw}]vAg5/~5~]X/rV'OL;8V78嫫FI3ey+鳣};tf5z^Ѧxr6Ii&XnDj`]a6.8EMiYsV![v:Mc(9.!Y'C¿W%ePZAv>Y2%脻'(yL&i;/؜Y\lr "%4r6-ydbM٪ Lk`>yEJoRa3d3a2x,lf)t2E:f!}9çW!Lu_!0J"ܝLY6IZ+j;\nl>Ft,1$6v4$$hfXRb6Mоan 61.!)Qt]Lv(IRm&vjVBhm>%jN U `A()22ɆfMKΧ ,-;CgZh.UC y K-U64Wr|f)( eON;!aϑ IZBzo}]' Ԏ 2` -Zj!%<^Z 5 9 I Mx$m~`H>#mDߑ݉>8}R"|& Y8(x&F!qV 2ڧJR|RpIuzyOg3$4ӎ^]DwS#X`YX՝' 3C6%i/ NA3@`1e=0R$gD兴UY}el,^Ť+YoAHv'Sp4:%v?& >^o*[dmItQٮܷH<(çHfn:]Nmq%N[ྵnˎl)jSfR\61;l (je,s;-eYĉh33.{Vơ}sR>`dL `MǍG^UwtO4h N/4`n`H-SۥZE PyòK&,`̆Bjh_+*:Tx{<'f-?"}{'s_-hȶd`]>YeXNBM{8ynYH]<ٴ/&zI1lnbD|$ffI ib$ZL>Ivh]>ȷbF Ff Qق-]GwU)imTI R*OY:}-)bkhQ'kYLI8V ,Qv" _R/}mm?[y#z:"CwHM94T>˺p(*{V(ad͹Y%SvwƊ. 𹗀-1쩾7r;I2,NWϢ(wͰa Yz[4^V _#ޏye}EkdoF&X@o;|$K9~ڡvc7@T| s[:fqpSJlC5 dtsOLѻٸtovW:|kבnm3] ~TOu &bsPES4;ez+,=gijs`Y8ތ?$hڢE߻ՙNY8'uf7JbְI;$8c+ݕ.,y9 b|%j=+dN~d/\V>_1k~ɦn5}Nm?{QN$KTUfPS1ٿ X_ȂE;-CL7g+Rh Kx;w#D4ܽ=phytools/data/tortoise.tree.rda0000644000176200001440000010753114462276163016364 0ustar liggesusers} ^WY{׽t I(@YD4Li2̄ɤ(.Ȣ+("oΝI&|w=>sf2}ObE"VxYTOa_[)MYb 773;73or$8(qu81y}RFsSS3קeѼwYS_@~)*ױ$s?)s

1=9oj֍m,Ķ;fejs&vM6h6mKkn'fo2'C]33;lSq4y1ͳwON}m=kCpc Yݷ}fv2礼_99}KVqaoZ51sfv716lݝ-yh^'2kzyڼ^c^515#%7O0יD$dT(I?K[nLo=.Ǯt]-}kjUbi;S^Zg۾뫊|8c-8)Ƕy}߶bHnڹk-ӿٚvv)Cm"v-_,_~M_1bۿgmi#'"n|[PT%nY`/Ci1\ ŵOOݰʍ[u쎉 kSuU7_y[u춙٩Az ۿ{Drjr`sS[x|ʦ]Sr|mM{< zsӣYsGy|By]j|>8m4t^>10*>)_lKS7]Z9A~x._s5H|X/7Q1^~Z|b6-UiZ%K5{1 xd2۳]{Uk}#ne7ʋyc3.̸(れ3q3.˸_ƥ387㜌3okEy͸3fmneysj<ʌܼ fgqS{n(./{-h8MbW39ݹf 6XbKn퍰7{#p?Е@)OW+p۬b?gkXh/V5L}_Zۿ炵tkm;Q9gK6߬߰~ԼUQP5fO qܟӫ/GTN|Ӕ659oW.==o6oFijc񖽸+<.ܱ(O1Zު )i%ȋ ?Yڻ+EU<1x|R.~1zQh1}kwr1={(^]~ώ~cB^ߞok~Um}=F{9Uks*^;bӼ>G)s%=c#+];_2>{Ԛs̹}<&_PZ1f2=Ns.ͮt/4kMyҢot})>{Վ#1Gֱ4h۲\>)+.q̻P>괪[+9U۪(frnٳ<)~1w޺ry˱VcԏLjsMm׶>87UW2jsQVs*\S8)]VkΟ*ŕbtʶ9UXx9U\S>y7둽A=ǴkeKx܊̟q67ިr{z"*^N3uv#qQmFK(zj(+m|s_[98)]Vku~OQq5/>O~t\c= zӠXZ몆Y*Mxxao>@=k8XaPbXڶcz`TqnlQ塜~syƨxx9Rn5ȱaOSfsUy(`b|y$c8ޜ9>{]grlw>cHcלU96ĔǢ\ykG?=xt1>o}L7o}RjN{o.>F,mRֶq/ucڟkh>W/ +ircfj) /GG>fԵ>FqciuPzsp.C'ywعq޺Ǝٕ{oոX>FsWy~s~4x˗~cc{bÜS֨w,͡zy6X]9*o<{s+16N~ъo<UXCGFTVսكY7+0WvrpcqzygcmJ1j|Ny(H=Wnj␽v19_tʇǗQVx} ǀñdU9T79s|~-C'y(16eV|ynwzZ𘽼{V O Lv|;.?S5]Q~ejq81^8}{8Hqګ>fǰݝ1<s,}D{>Fq1}\_zyf.{81f<^ר1NyN\vcc;1Q˥ñQcSU{UUeٱYi 痽b%W9*w\9X/7Aϣ>m{\X37j`1Q^zWő./1ߣ1Wqayb9)R5Guþe}֨õI?7'X1*oFi,Գ]ۜoLqN=@͕>Ň˚p Kg]+SsVSQʡQۘWXX^ض9w̽q1. yFy3ĺ391k{MyuPUWcmr܎}׿_iQ͙}G͕ʯ٣>zrbT-[/'ms1S\QS=ycf*SkCa~<^}})0׼|xcuMy}ŝaY^[3j=ޣ|=/r-5 /HysWk9X>f]:`>x}Ɋʓ{lY{J6w}L4p{>jI}x\J^RazR={Tfnvck˝{U.} ,1S\Y>Fa} W*Q}ʽҜґ}0?$PcF[Ry]0x,*]1;5g1ָLjs{c=wvsU[x]1)=p||{K1ߛ@H1D+_5cSifqcXjnQ=0=fnc*Υ5skm{} bս*G><&o\~47Ը%իkoq1\oYc8o]awc8F.m·7ǡ#e1\9N3kQ|^sXa[c{mRtܦ7QkKyjq} ׫%kRsG_f֨էu]~DZSqc|y}:=Z/q;^WsRm{jۨ}ҕ|>&н*qǰ*3} ϹaS~y6iʻTNw,8\gM}.ǰ7zϏ΍7^#e>ċ+ϕ4{øQ{.UXah)s^uJYhctlmG*a=(5?@G1K6}?WD56/sPy4G?{W/Α׫>f)}r\q(=Y ɫ=qΚ1cjR7gj/g*>:1~-48jc } \*]On<{"_kcVmod[ҽgcGy(]3֎{'UkTcךQˑzbI|/ωṪW}vxͯxr눮XA5?O۞VsVR~֋8g~\x'=]x)~/5Nu~/x]V1Uizqh1^y=\ /=~{Ź++Z?RI\<,P_XAUޔ=mvܼﶟg)t>K?˾QqΆ׊O|4mwŚU q(wNW7y[C(.muFgǥUܥ+Fg5c17lޣ|Rqī#J#*\]˛A?,ϕϗXj_t<-uO]xv~;85{P,<┚3Iϼx=zHON?võ6\q1{j_tʣnj+bCn63=1;zڣoڰk6\֍#oOͭ_;&禶=1+wM힜޷0^y#MO휜͟\o>5=^l 'AlvMNNn19m]Mgj]MŽ3sZ=%_vb<7nvӵfۦwj>)_lkff}|m0s&vyb)um۟>(rWoF~o11{Bhr&v#jӆ&_losą!Q:9s\x[n&j{Yf`UqT|u:_;;b{qq-V{ϥx {L^{nodz&my>=gkqfm-.LǙvf6W<ɹM{_v޼\Z>?(mˎ?vlkLos~~-qܖbҩGOf],sy_ec]eڷZ^Mm_vԯƆckslQ?¶Uԯ]slO僖5oy~v (?rqW[=6qu*hSuG_{;'i{m5=۫Z :R9tUsV[xoL9~3=7;MLX_}}{}T]qq,7k8\ï{A1ż1gzbd#}RlsfjwmOyfv-K_/ÂsCM}sqob~pp1p?`C1P xp=P#G<xpw';= V3[ۀ <n^x=~wU}>&aw|SπO>_ wgO? _| Wuĺ# Dq*ADKDc,dJa .B .B .'Ey:pp&~GyR^\+%R^\35f)F (`Cpf)?哀' <6|*OPAMa)=SE {g̋ EDM*gTQ> Jp[ ~!,˗/^%8Y,_8h ? x jVpEn n n-\.\. v nv1pKpc1dp> >`!p?@@4? xd¹ @JX&•p-=!@ ZAx0 -o G"@t]"@m){&mh#@K͂  HF4h$th$JVh%^Kh&@3 L^h%@+: INOJV36z K^Lf4+t^ Mnt&@7 Mnt%@/z KNth$@F@=G>P4B@]K^P4h&@/Z JVh&@3eiMf"4D%B/ tDh$B#HDIN"tMDh">D"BFDHF"4xmPN"jGDJDK^"Dԍ,&B7Mf"&77ND]Mn"jKDmO~"@}Q-E_"tE(Dԙ=E)BOzS"=E)BOzS"=E)BOz;T"4_@WU"t]E*BWU"jQ"Q"mEԡ}E+B_Wz)BcG:? @kg-Boz["Eh-BkZZ"tE,BgX"4}E+B_u).E,BgX"4EԢE,Eh-Bk:Y"tE,Bg:Y"ZZ}E+B_V"]EC`%*AS J?YCW 'AW JU4=%ԝPwN4y=%)5{d)AO zJSP4=%)AK kf %4 %Ԟ%h(A? u'A? 'AC IO,AC JP4 %h(AC (A? IO~$h&A3 IK^]k'p> O{'< Nux^': Nux^':$p; NtBH NX{%p; Nvn': Nu:+ NtV Nt8P?8N'p: |NrBHs'p8 N _+x|.W _+x|]+p+{ \    \|/+/+/+/+/+Vf߭ [W+/++p*š+Y*Y*pVc>V | | \ \<k𱆧~Z5</k𲆯e ?~Z5Y57ki ~g ~Xg ~X[ckxl l Z5x[5ZcR55Z5Z5)55|k h h ~58YGkpc >c .b 55xXo5Vo5Vk5Vku㣋bVXNwmnq/48jܩ9sjʚ3'dxrQ _dAΡYT;A)@gTE\y(//4gWX+ Q?e?γ,xǢ,G(rU WrU?g]W|s\9+R oK#óGYrXKgb%b͙r;<C^ GY4gQ?geydaYtva<χsݨ3,Ξygp[{^/:Kpy۸go go™[{޶ܳ \b϶͍bq7bw(*svkgXo FC 3gkmNV%=zTc{׶rr$P;j,|/x^ugKy퍗۷mDV:|mڶX_=oyi/҃q Ԇ?]ۦtQ,+)8G*6W91xy*v~5O'z;o;BEW~}< Ursj9桦8&޿Rc{`ޗMOcVK^Q, ~xnOV128Y{>s[]-l=o~a⟿-Ss7]+nM]u7Llb+mض+zvr͙m1o~>ӌ%g\qQg7>g\qK3gqn9ggq338`UFss|Lc94^W{3crB_9>ϡ2coCy|7cty~{q&)c?Z`M矤YwjVhMןK<9ih_QZp:`fd!-~~/A_ޥ;' ;7wm B~y/W!g/⚽3`,9C+m3j/[Ň= e\Qv pR%/cg''ɹ]3;ĕ{NNNL;?Ycǧ\98`M>7}1sy3/:E"µ!?wnjzx義=3ӷ|_1;_____r/͟c8#Os/ } x ~/3m/K/ôwrn-gLTYe__?WM4w_q`qݰzbǎslhonbvk|M?m./PځutQ]~ӛo.Ǎ7Wcƻ1_JrgW 9m.>xxm˸q3Nv\r9._TrrQNx}{ur.è*Xx<3渒uWGW]Wupw͡kn^[߮q?;Xymv`ϯt^]c롚GUۅڛrU_J}09ծŸϮk:LJwv]Xc<;jƨ1,w}ԜƍWWSsZ3//F{1 ɣumTy>\Qmva,qT/skTG}>ǽ_}CŃ])˭<3k9PƨrumWWrܘt͡ɓzk8sTsZiƝg׽<ole0>/˙GרZ/W-?e" !_xIK3~e3^aJUfj5k?x7? x ᧀ~Y?0mb/o~yLcxgƻڣKxC|uoZ~0[Gv-~ 3$|z ;Xீv7cog3ese3>_Z& |n 7?| 2ܡQ+SČtebX8f   88X7DऌNNgg ,lu>oE\ lL\l66+3^!6o7ߴ <\ C|3[2(7ɸx,8M'O |+:Toؚ4``!v`nvfʘwO Y!`/ `>`[ ցgb|ls <x>W/G/K~#˖ xU~x:xq׏7?qFMOo&e TO?񳄟x+6_~ xN]~EW ~ x~  |=?8 O3;ig˿˿?.?k=r}pm eKeKe1}lyB|W /,/,߄%_:u3'n0E/J{UXsc258p/ gY{p2S8T{pfOS8:L)v",{p,H~$`?6A^(lÄ+ o õ3 u{ o[ sGf` 7d`n~+`=W+` s\{=U*`O O¶ 8{=N&x:{Ik}J$`O؋C#p  ?@⌗d`vX ^ Ï ë;ux;`MXַ&sֶ-aOgL֮ ]֮k׀k5` x']4`~Ȁ5dx֋Apud2`  que -֖ >F:3` ud:2`>ud1`V 1`F X o2 X~k_kXw뻀u].`v X/|%kZ:-`m XsU먀uT=(,Pz(MZ(b XDs1XDk"1똈K\guL:&bvd`VX3FL½328;똈uL<x_[XDA" kG#b X XM]5+fEԬQ"jU|@jQD-Eu(EԛzQk"jMD3a7%DԖo@m+u%DԔQS"jJDM)5%DԔQSwdħPc"KD};2&3Pg"LD S!qOFD݈"^DԋQ#- Dԁ:Qs P "?#|?#|?#|?22>5 u_7#|;¯#:¯#<:£#9›#9›[3]4Fjg[#|4G#<4CG3~~^^^>>>>>>>>>+<0<0 `&_%_%^%^%^%]%]%]%x]%x]%xX%Vgs2[ ~W >S Q Q Q Q K I E ^E ^E ^̀%xQ%xQ&xRڒ_Jxp))|)|)|)=*I I I I I I I I G ~A Ai|(<(<(s<'o&k&k&k&k\&g|&g|&='{<'}w|'w^УG#X#qX6^xk5f`O/!`/H $3^J WH'$ ^O{3`HG$#G$# }D>"a{.݄_ 5{H{$= {ACi}H-؋$E! E" {H^$a/>`/ G# H~$a?I؏$G# H,H3'Iؓ$I$ {=I!=f=_4/_O{~^?aO' {t{>ݟG   2j`Uj`Mڌcc{'AƉI)iss.... q.qTr`}`202*j1qmf|#M"{~{ Kѫ9xxA+W? j5k?xCO I[:Ϭ?{92~_x;;D0]G *k{|uo~0[G~݌|3L(ǟ |GC?qDSG>=Kீ& o `'W߀>FW_5n(pP!# zX8&،{'p"pp2p p*pt LY9s..\.ʸ..>5&555 ?k?k?k7k7k7k7k1k'kkf<,5555555555555'//++++++ 7;kkkkkkkkgd.+''ַ <9CCCCCCCC/4x2=g=g=gCw? NB3oxt^5k mC֋bX<>{W3sjg i.Nܔv{cs9 ^o=|yΗk4U$U+YmgPm͟h>mcgs V{ub9{6͡ɹcL<&wٸqcHW=ƴ[Xnjysgj *s,wۿu;WZcZ_iu:Ͻmdz\*FZ]CC~^X'{[۶6ǫE~T,Yp=֣ٿy̶=k'P,?)p]h}XOn_|퇹źhf?މ}okAUOGK*n㶊Q4oBmSqM;U_06Vovjc߯.56U-'kWhON?bk"8ms=3{ñU71Q?Xyy۷>c}q|q mnk]1[ոr^G܃ш9їW51/W9>yW{6vzʯ=3w;?^x{[Cő7˯7q_~u}<;K/+*ڎcC8uˏ@sny9NX7gPqnzT}{`ir޷ˋXRqKSB1yZ{֩jrǼyޕ3qܦ=CYg^MC?= (莰go2{Ł;.f Z,\qqƅe\q~}3qye˸4c}yfqvY83㌌ :?m&}mEy86coAy͜Nα_ʌÆm}iD>'gig/os9-g ܸ[N=/_:Q7]y^![On^=7mx5\|u7֯sS[hIa뻦vON[ G޼צvNgLmh/6 6s&gh|M'LLݶv&\3}vf&rޙٹ\zi;S7]Zyl3؉mS;wLO /6s53>xjiˉ]{TDL<źIӶOZ7#?ujz!49 MwffiC/6طN'vG$4cd~fnj&w1'Sdk^{f/;"74FjorbvsHQnr3;y~^ñ7vb,6cy|[m2co 0s`h00BWAjl)W3"izS(һHOEz)bPKJ(4.5Z*"\pH;EsoSK*3vK2MYywn"=EzgR/4=E ꛦ>jx|~ԡ!FO):yҿ~8_ O ~&8#~8iݳԍ:YBcM?o(4k3xӴxu1վ"s3z]d.")")wQ yjmԞiwFAs)itj)vb1.?hҭlKóXз yY&xk3ޖv-]jǻRkX[WwE wi&;&o7PwE{gS^<=|GL~GӻJ]"ثڇ/ /=g'o3(dO:zK?;r?m4Sʅ8@?An-黽^6kH^cIm1y\ gl[5#%R;/:!+Dr>xn[]q(=€c^tesy9Fa.1'b8GqضesͼڵZVSuCi>shTUϼzyunc~6JKNg@ؼ)xюωX)ޞ\=gqً[C~OCW.~v~A}y TR[]^ZX {^#<~Fppnw*\oq+=zz{}5rΔC;jl*'u,O{j=/bk5U'Cqj}RϪ9yuK۶r`Dy<'g]uǃ T9Һ'xnJGk;5;PQW-;<{sSuuУDwVXNb=DW|u?q x.W~5a ۖړZשϜ`kמ|cj| "omѾ^Yie9D9'stQ\-/oϥbi <8՜#oy1eq8f]k)uNޞL_k O?48qܛ7Ǎ|;9q|N5)ϸ~y:*.ʗ禞gs^ϾUWgu :TDkγ!;nK^iNJΉz5G=8ߖ?C^/qۼ7T~uyW_9Q{yƟy5Ɵ%[}k;F^;_^_znP,L5Nv eye^Fj'jSBv?'Rqzjy%Zr[91sNaMz~q^iן]m3ZʇןsxלR[˵{hS}ui_DF7i#ݘ]a>+]{*5<^={Юv:O Y^q{.P?^5Oz뜈uxV1u]zkOE6^Әmyz'ƽZze9i_q@֋5k[w,mzyBN4^*9Q_G9{N䭓.Zp<29Ql,l^x]UM`PmbiXC6P Qmr芳#?'zfyk \i\^S}qUn?S{xW1ωKqurw>'Ro4c/g{#9zУG#wƵ~^K~/=^ⵛ}*KRp@xuCiLe٨㮷7_.B]ռ|=՞g(8|Z=(ǂJj +nsjzQz[9j-tWċ-a]:X+{U>08w^3ұ:|fP;߰cU~e>޳9bY,M:'|Oy KA+~+V>`mܟҗ3.q/j]m(]͓󧼑yb|:jY_Oq8tsnӉ7Ξ>Xϊ=4<3 缨זQa**Fo>{{7״T蹴xgk]c8˼a.6+_c%3},Kl=ouN^׵.[r=T? |8ǀ}ωOïy<#~ͻHSIj9}3x}mxk,oqɫPu}:}<.3ytyFZq3UNs"只vg*}xw(ω8G63D/nNjʭj~*>U[~TPqXۜ nrNq] }jo;F[y7z8D8TOԥ5]5I=9QNDv^SuVџ󲱾8nܫ~U?=}9R{s^coU^ꄊ#_ݧ@XU9ʛY]++sAJ7\wT<*ZV{".]ߔy`k6ۏSmc(y~x ;/o4 nj-ƹSgb)7C?'b,>J@JճGo|Bh61PS'x.դ.SVmV#srq᭝ʃ%p <Kqƺkc+~l_c#^[{w1-ênqapng*%ڎۇۘZg+=jTbiOW> o _}1O?x6a{l_Sѫ-_}&)ǜ=~8u+f3{;<2W=?Ơ:R~źV<#ߥ kZ#2'zЕ;ϻybgHiFi+*j o*Fj}^*/P:W9yԽ9j,ʛY]>k._Yk(RQǾy<81T8Yv=?VcnPk6*c(9~x/ ;/ot nj-Wgb)7C?'b,m_*?꺍 scfqXΡ60{c޽j޾5v8k,;~Ʈ+F^=_X֋.[gb\xo}uן!ǚsqP3 召1OO<6sU>TbY^gZ'y\Z߹=o_qS~jz~Nrg`zRq()M1ה/68\875y'r1Xŵk~AϫoM&x |AuR9Q}8j,?k*{sAՏ3/ӣ{cUbnq(Z9vLZK(?/sV~bix ^b}(N}Ͼo< Úl X'kGZMu`*x~|v=_S|O͛mXʫ8gW_,YqcT]a<[^_/uI9AI2ym^X<{=9光{UUV[on= 뎟g>+m{y銑{YDz^gw_?M[ ?C5>ic3{#M߳Y.wyykyfs{/ʯTP"I^g0qZvMi|IZƹQϨ+ͫR1Uq X8/CU.瘃gsO7+^=1Gƪr:cQoQs v{9+V?%Y37u[웼px>Iۮ}fp8'ꊫX6UyVkK;e=p~;|[us^ӌ=5o"[W\Z#(vVUW oίp5NNx<׻Clc\7&Χ2j<#ϵ+TMPmx|<^pwuY5>Oi^s\)OQV38ޚ5/^(~xREb nǾSV*unm:̼Rr{&׸}͸ph/P_l?j tq1嵯Z0xxAa۱CX:'ZW,>ga:??_~9=ΛZr<.־RqN]~}kO]ʩZn'rjZ#(oGy缺5b)~<2/CVK귪Cv\/l\<1g<0g8VV%՗޾L~s9jѕG'oVd 6,OG9J_5˺\2zD={*WyQ9FXv>*}H~y~fy9d>%^v?Wy^_g{Ps ]7~ɕ֣.yܱ+e5?ǡ@Xr[]|tqkǠk,5/]q{sQm{>ß{8YOOtyEW[\W5P{?aI}ڵCIm$Zb}X_IԇQ+sŝwW/{:׻m^[WO>טCZMy``x׻r^cϸO;W5]i֫ ثU>m_쩜c͞+(yVP\ARyK^_'޾=.8lWؕ?YC<. #QΩ7?oRgUqya0Ju4y*WyQb>FXv>*XpQ~lȎj1듽#6Zray렸1y~{勪~y4{=_5:X*SqX<Z'剬5剜o΍s+%[;Qu땪磸1sbTSm3ʟ=N)>tE7|T.=j "68zd/QxuT%BXs;ϻY>8\sX3<1bA?u]uSV+?і^~ypoէOScj5X76Ν<>9vyYDbixmz۱TVc^ڣίq'qݥ9W5eU>iκ1s".i++go<9wN<^{:b="j^-Me1*F^)3wԸo<X(?͟y^9Oc+Vlay3'=~Ԧ{>S R4f*Bk%˾V(OcSs[<ث_v]9(=*?anzyf?.et\q;/}*ccmyS{nn_yl~|Kc?C孫ƨw,GMiAՏsWc9 Cg~U VWUU?}1ѣGONk7lro;1cbԾ|GtW^{ևl>1mfzbvj{Gߴa5lrխG\ߔ[ wLNMm߿{bnSW'姇=9oa' zF\99?_2}jzÑ؀ ;O횜521crvٝ'˛pyٙnl8]{gfzJrM3'Ny7otkՓ`'MM13=6|R}ڦa,'vMQ53}}s3S&M&?}jQތߺcb֩44MFnݿ M`'&{rCRw. w\oX|A(pv6Y,-hp\n|}ǘ׫gxNϯj*'"}gxL~]Sl^oW1֦̳K\k@_5͕; 6ֱ//>rxum5-I]cR+q.W?^-؋Û_׼bp0Vr=XndnG bwϻ:n:ǡ%m 銏^[;Q[ͣMG]s6v~0XeiNѡ׮yu8k y)h?;lo"5| U3 z&߾hϻp}ў/޾}}}}1ݾҾ|~g#.x t&.&0b>ǽ>Q.Q[8qǵqxShטKs?wۋei#1뽻n~",{L6eԺx$(cn<`;x:,on x6ແ^|GW~x Z7o~ 9_xnW~>  O?> | _57Gs? +o|e+__kׁW̳O2Vme %_"%_y,+\(\(dT(O(8WKpW+p ;7|Cu\|N ?|d[OViCo@QNTa(BSXxƼPRҔ|pJp|[}h|r8Y%8Yj,uh hj o~g_~ x;n n 8\:A\.\.򷀏 nv n~Kp?^%^//|/KK5@]E.t]xn6"@a60 4h$@# HF<9@': IF<9|/h%@+Z JV‹%f4%@/Z JV$h%@+: ?@+Z o%@/z h&@3 @7 &@7 Mnt&@7 K^$@': IFmԃ}#@5!@# .ԅ%@/!@3 Lfh%@+Z z K? Lf4ӬJD&B3K^"D$B#HF"4:D$BDD}E."t//Dh$B#$vDԎDԎD%B/zKD݈:n"tDh&bmxp#DԕD&DԖD'B?ԗE(NR%BG:Q"LDS"=E)BOzS"=E)BOzS"MEh*BSt]E*BWU"t]E*Eh+B[(B_ڊVDW"}E"4z"E-BozZ"Eh-Bg:Y"tEh,BcW"Q"R"tEh,BcXD-Y"P"E,Bg:Y"tEh,B_EڊEW"mEh+B[U)cՆRGJU4PR.OtM%h*AO zJ; u'$ԝm%h*AK =%)AO zJSj6S=%)$h*AS zJS` :J.JX'h(AC J= :JP~N~jOY4 %h(AC JPjQ~$h'A7 ILf4$h%A+ H/G~8'p> \Ozx': Nux^': Nux:^': #^':an'p; NvG^': N'p: NX[%p: NtBHt8N'9 5# |Nsx'p8F$8 _[+|\+x|㼌s38;㬌{gqFAX{]<7dq_f{39Hq_̩]S92c? f1;'ay ??ӊGb/3-̼ #?䎝wOlZ ӘoO+e_\wSEno8{ qfEKSsw9.=Ϝ3];ߴQ3̏[ۡE7ǛÚ>/ݦ ůG.GFsٹ&fUdƥM6Eh,y#{8ڪ4Ռ}cdZS1Łrw|-k{C5e)qZQ<%6ZHhSd룅"˪_=E.LEzY_=EzH]i~FZ6gCЦ\J}r,ZݧXLsZ*]RWK- cmCߎ7䱞vIc;ڌoKf- 0. } \value{ An object of class \code{"anc.trend"} with the following components: \item{ace}{a vector with the ancestral states.} \item{mu}{a trend parameter per unit time.} \item{sig2}{the variance of the BM process, \eqn{\sigma^2}.} \item{logL}{the log-likelihood.} \item{convergence}{the value of \code{$convergence} returned by \code{optim()} (0 is good).} } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ace}}, \code{\link{anc.Bayes}}, \code{\link{anc.ML}}, \code{\link{optim}} } \examples{ ## simulate tree & data using fastBM with a trend (m!=0) tree<-rtree(n=26,tip.label=LETTERS) x<-fastBM(tree,mu=4,internal=TRUE) a<-x[as.character(1:tree$Nnode+Ntip(tree))] x<-x[tree$tip.label] ## fit no trend model fit.bm<-anc.ML(tree,x,model="BM") print(fit.bm) ## fit trend model fit.trend<-anc.trend(tree,x) print(fit.trend) ## compare trend vs. no-trend models & estimates AIC(fit.bm,fit.trend) layout(matrix(c(3,4,1,2,5,6),3,2,byrow=TRUE), heights=c(1.5,3,1.5),widths=c(3,3)) xlim<-ylim<-range(c(a,fit.bm$ace, fit.trend$ace)) plot(a,fit.bm$ace,pch=19, col=make.transparent("blue",0.5), xlab="true ancestral states", ylab="ML estimates", main=paste("Comparison of true and estimated", "\nstates under a no-trend model"),font.main=3, cex.main=1.2,bty="l",cex=1.5, xlim=xlim,ylim=ylim) lines(xlim,ylim,lty="dotted") plot(a,fit.trend$ace,pch=19, col=make.transparent("blue",0.5), xlab="true ancestral states", ylab="ML estimates", main=paste("Comparison of true and estimated", "\nstates under a trend model"),font.main=3, cex.main=1.2,bty="l",cex=1.5, xlim=xlim,ylim=ylim) lines(xlim,ylim,lty="dotted") par(mfrow=c(1,1)) } \keyword{ancestral states} \keyword{phylogenetics} \keyword{comparative method} \keyword{maximum likelihood} \keyword{continuous character} phytools/man/estDiversity.Rd0000644000176200001440000000526714546012527015713 0ustar liggesusers\name{estDiversity} \alias{estDiversity} \title{Estimate diversity at each node of the tree} \usage{ estDiversity(tree, x, method=c("asr","simulation"), model="ER", ...) } \arguments{ \item{tree}{is a phylogenetic tree in \code{"phylo"} format.} \item{x}{a vector containing the biogeographic area for each of the tip taxa.} \item{method}{method for reconstructing ancestral biogeography.} \item{model}{model for ancestral character estimation. In theory, any model from \code{\link{ace}}; however only symmetric models permitted for \code{method="asr"}.} \item{...}{optional arguments. So far, this includes only \code{nsim}, the number of stochastic mappings to conduct using \code{\link{make.simmap}} for \code{method="simulation"}.} } \description{ Estimates the lineage density at each node in the tree based on a biogeographic model (similar to Mahler et al. 2010). } \details{ Two different methods are implemented in the current version. For \code{method="asr"} the state at the current node, and at each position along each co-extant internal edge, is computed as the marginal (empirical Bayesian) ancestral state reconstruction using the re-rooting method of Yang (2006). The lineage density is then computed as the sum of the marginal reconstructions (posterior probabilities) times the summed marginal ancestral reconstructions across co-extant edges. For \code{method="simulation"}, stochastic character mapping is used to generate optional argument \code{nsim} stochastic maps of ancestral biogeography. Then the lineage density at each node is computed as the number of co-existing lineages with the same biogeography as the focal node, averaged across stochastic maps. The importance of this distinction may depend on the degree to which reconstructions at internal nodes are independent, which relates to the distinction between marginal and joint reconstruction (e.g., see Yang 2006). } \value{ A vector containing the estimated lineage density at each node } \references{ Mahler, D. L, L. J. Revell, R. E. Glor, and J. B. Losos. (2010) Ecological opportunity and the rate of morphological evolution in the diversification of Greater Antillean anoles. \emph{Evolution}, \bold{64}, 2731-2745. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. Yang, Z. (2006) \emph{Computational Molecular Evolution}. Oxford University Press. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{fitDiversityModel}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{maximum likelihood} \keyword{continuous character} \keyword{diversification} phytools/man/pbtree.Rd0000644000176200001440000001124014546014526014463 0ustar liggesusers\name{pbtree} \alias{pbtree} \title{Simulate pure-birth or birth-death stochastic tree or trees} \usage{ pbtree(b=1, d=0, n=NULL, t=NULL, scale=NULL, nsim=1, type=c("continuous", "discrete"), ...) } \arguments{ \item{b}{birth rate or speciation rate for \code{type="continuous"}; the probability of speciating per time-step for \code{type="discrete"}.} \item{d}{death rate or extinction rate for \code{type="continuous"}; the probability of going extinct per time-step for \code{type="discrete"}.} \item{n}{desired number of species (i.e., taxa-stop criterion).} \item{t}{total time for simulation (i.e., time-stop criterion).} \item{scale}{if set, rescales tree to have total length \code{scale}.} \item{nsim}{number of simulated trees to return.} \item{type}{string to indicate whether to simulate trees in continuous or discrete time. If the former, then wait times between speciation events are drawn from an exponential distribution; whereas if the latter then wait times comes from a geometric distribution.} \item{...}{optional arguments including \code{ape}, a logical value indicating whether to return nodes in a 'ape' compatible ordering (default is \code{TRUE}); \code{extant.only} a logical value indicating whether or not to return only extant species (defaults to \code{FALSE}); \code{max.count} a numeric value indicating the maximum number of iterations to run is sampling conditioned on both \code{n} and \code{t} (defaults to \code{1e5}); \code{method} gives the method used for simultaneously conditioning on \code{n} and \code{t} - options are \code{"rejection"} and \code{"direct"}; \code{tip.label}, a vector of tip labels (only works for \code{n!=NULL}); and, finally, \code{quiet}, a logical value indicating whether or not to suppress certain message (defaults to \code{FALSE}).} } \details{ Simulate stochastic birth-death trees. } \description{ This function simulates stochastic birth-death trees. Simulation can be performed conditioning on \code{n}, on \code{t}, or on both simultaneously. If both, then (for optional argument \code{method="rejection"}) rejection sampling is performed whereby trees are simulated given \code{b} and \code{t} until a tree containing \code{n} taxa is found. The giving-up point can be set using the optional argument \code{max.count}. Simulations can also be performed in continuous time (the default) or discrete time; the difference being that wait times in the continuous-time simulation come from the exponential distribution; whereas waiting times in discrete-time simulations come from the geometric distribution. In addition, discrete-time simulations allow for the possibility that multiple speciation events can occur at (exactly) the same time, so long as they are on separate branches. Finally, sometimes for stopping criterion \code{n} in discrete-time there will be a number of tips different from \code{n}. This indicates that the last event contained more than one speciation event, and a warning is printed. \code{method="direct"} is presently experimental. It does not really perform direct sampling; however waiting times & birth or death events are sampled first - with only wait-times consistent with \code{n} and \code{t} being retained. This rejection sampling occurs one layer earlier than for \code{method="rejection"}. This results in a significant (several-fold) speed-up of the code and enables sampling conditioned on \code{n} and \code{t} simultaneously for much higher \code{b} and \code{d}. At the present time, \code{extant.only=TRUE} does not work for this mode, nor does \code{type="discrete"}. Note that if \code{ape=FALSE}, then the function will run faster, and the tree is theoretically compatible with the ape \code{"phylo"} standard; however some downstream errors with functions such as \code{\link{bind.tree}} have been observed. Lastly, under the taxon number stopping criterion (\code{n}) for a non-zero extinction rate (\code{d>0}) sometimes a tree containing fewer than \code{n} extant tips is returned because it has gone completely extinct before the end of the simulation. } \value{ A tree or set of trees as an object of class \code{"phylo"} or \code{"multiPhylo"}, respectively. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \examples{ ## simulate a pure-birth tree with 400 tips ## scaled to a length of 1.0 tree<-pbtree(n=400,scale=1) ## simulate a pure-birth tree conditioning on n & t tt<-log(50)-log(2) tree<-pbtree(n=50,t=tt) } \keyword{phylogenetics} \keyword{simulation} \keyword{diversification} phytools/man/add.random.Rd0000644000176200001440000000353114546010706015211 0ustar liggesusers\name{add.random} \alias{add.random} \title{Add tips at random to the tree} \usage{ add.random(tree, n=NULL, tips=NULL, edge.length=NULL, order=c("random","input")) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{n}{a number of tips to add to the tree. If \code{NULL}, will use \code{length(tips)}. If \code{tips} is specified, then \code{n} is also ignored, regardless of its value.} \item{tips}{a set of tip names for the added tips. If \code{NULL}, names will be supplied} \item{edge.length}{terminal edge length for the added tips. If \code{NULL}, and \code{is.ultrametric(tree)} \code{==TRUE}, then edge lengths will be assigned to keep the tree ultrametric. Note that if edge lengths are assigned and \code{n>1}, then the assigned terminal edge lengths are not guaranteed as subsequent random tip addition could occur along the new terminal edge.} \item{order}{addition order for the new tips.} } \description{ This function adds new tips at random to a tree with branch lengths. } \details{ If no edge lengths are provided, and the tree is ultrametric, then edge lengths are assigned to keep the tree ultrametric. The probability that at new tip is added along any branch is directly proportional to the length of the branch. Note that sometimes the resultant tree plotted with \code{\link{plot.phylo}} or \code{\link{plotSimmap}} may display with branches crossing. If so, the tree can be 'untangled' using \code{\link{untangle}}. } \value{ An object of class \code{"phylo"}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{allFurcTrees}}, \code{\link{add.everywhere}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/plotTree.datamatrix.Rd0000644000176200001440000000173714546016532017146 0ustar liggesusers\name{plotTree.datamatrix} \alias{plotTree.datamatrix} \title{Plot a tree with a discrete character data matrix at the tips} \usage{ plotTree.datamatrix(tree, X, ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{X}{a data frame with columns as factors.} \item{...}{optional arguments.} } \description{ Plots a phylogeny next to a matrix of discrete character data. } \value{ Invisibly returns a list containing the font size, a list of the colors used for each column of the plotted data matrix, and the x-coordinate of the rightmost edge of the matrix. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{dotTree}}, \code{\link{phylo.heatmap}} } \keyword{phylogenetics} \keyword{plotting} \keyword{comparative method} \keyword{discrete character} phytools/man/allFurcTrees.Rd0000644000176200001440000000263014546010755015600 0ustar liggesusers\name{allFurcTrees} \alias{allFurcTrees} \title{Generate all bi- and multifurcating unrooted trees} \usage{ allFurcTrees(n, tip.label=NULL, to.plot=TRUE) } \arguments{ \item{n}{an integer giving the desired number of species.} \item{tip.label}{an optional vector of length n containing the tip names.} \item{to.plot}{an optional logical value indicating whether or not to plot the trees.} } \description{ This function creates all possible unrooted bi- and multifurcating trees and returns a list of trees as an object of class \code{"multiPhylo"}. } \details{ This function should be used with extreme caution for \code{n} greater than about 8, as in this case the number of possible trees is extremely large. } \value{ A list of trees as an object of class \code{"multiPhylo"}. } \references{ Felsenstein, J. 2004. \emph{Inferring Phylogenies}. Sinauer. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{add.everywhere}}, \code{\link{exhaustiveMP}} } \examples{ ## compute & plot all bi- and multifurcating ## trees for six taxa trees<-allFurcTrees(n=6) par(mfrow=c(16,15)) nulo<-sapply(trees,plot,type="unrooted", no.margin=TRUE) par(mfrow=c(1,1)) } \keyword{phylogenetics} \keyword{phylogeny inference} phytools/man/writeNexus.Rd0000644000176200001440000000137614546020444015364 0ustar liggesusers\name{writeNexus} \alias{writeNexus} \title{Write a tree to file in Nexus format} \usage{ writeNexus(tree, file="") } \arguments{ \item{tree}{object of class \code{"phylo"} or \code{"multiPhylo"}.} \item{file}{file name for output.} } \description{ Writes one or multiple phylogenetic trees to file in NEXUS format. Somewhat redundant with \code{\link{write.nexus}}. } \value{ Trees written to file. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{write.simmap}}, \code{\link{write.nexus}} } \keyword{phylogenetics} \keyword{input/output} phytools/man/sim.corrs.Rd0000644000176200001440000000326514546017702015130 0ustar liggesusers\name{sim.corrs} \alias{sim.corrs} \title{Multivariate Brownian simulation with multiple correlations and rates} \usage{ sim.corrs(tree, vcv, anc=NULL, internal=FALSE) } \arguments{ \item{tree}{an object of class \code{"phylo"} or \code{"simmap"}.} \item{vcv}{is a square covariance matrix or named list of matrices (one for each mapped state on the tree).} \item{anc}{optional vector of values for the root state.} \item{internal}{logical value indicating whether to return states at internal nodes.} } \description{ Simulates multivariate Brownian motion evolution on a tree with multiple evolutionary correlation/covariance matrices. } \details{ This function conducts BM simulation on a tree with multiple rates and/or multiple evolutionary correlations between characters. If \code{vcv} is a single matrix, instead of a list of matrices, \code{sim.corrs} will simulate multivariate BM with a single rate matrix. } \value{ A matrix containing the multivariate tip states for the \code{n} species in the tree (and nodes if \code{internal=} \code{TRUE}). } \references{ Revell, L. J., and D. C. Collar (2009) Phylogenetic analysis of the evolutionary correlation using likelihood. \emph{Evolution}, \bold{63}, 1090-1100. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{fastBM}}, \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{sim.history}}, \code{\link{sim.rates}} } \keyword{phylogenetics} \keyword{simulation} \keyword{comparative method} \keyword{continuous character} phytools/man/bmPlot.Rd0000644000176200001440000000754014546011661014444 0ustar liggesusers\name{bmPlot} \alias{bmPlot} \title{Simulates and visualizes discrete-time Brownian evolution on a phylogeny} \usage{ bmPlot(tree, type="BM", anc=0, sig2=1/1000, ngen=1000, ...) } \arguments{ \item{tree}{a phylogenetic tree in \code{"phylo"} format.} \item{type}{the type of plot to create. See Description.} \item{anc}{the ancestral value for the root node.} \item{sig2}{the BM rate (variance of the Brownian evolution process), \eqn{\sigma^2}.} \item{ngen}{number of generations for the simulation: will rescale the tree to this total length.} \item{...}{arguments to be passed to different methods.} } \description{ Conducts a discrete-time Brownian motion simulation on an input tree, plots the outcome, and returns the tip and internal node states to the user as a named vector. } \details{ The function will first rescale and round the branch lengths to integer length, if they are not already in integer values. If integer branch lengths are provided, the user should also set \code{ngen} to be equal to the total height of the tree in generations (and thus avoid rescaling). For \code{type="threshold"} the visualization is of the threshold model (Felsenstein 2012), in which the evolving character is liability and the segments of evolution are colored by their value for the threshold trait. If \code{type="threshold"} is used, the function requires at least one addition input: \code{thresholds}, a vector containing the ordered thresholds between states. The user can also provide the colors for plotting in \code{colors}. Note that one more color than threshold should be provided as one threshold implies two states; two thresholds, three states; etc. If no value for \code{colors} is provided, the function will recycle a set of four colors up to the number of times required by \code{thresholds}. Finally, the optional argument \code{return.tree=TRUE} will tell the function to return a list with the tip and note states and an object of class \code{"phylo"} with (for \code{type="threshold"}), the state for the threshold model through time mapped on the branches of the tree in discrete time. } \value{ This function conducts and plots discrete time Brownian simulation and returns a vector containing the simulated states at internal nodes and tips of the tree. It also returns, by default (although this can be turned off) a tree with the branch lengths in discrete time and with a mapped discrete character (for \code{type="threshold"}). } \references{ Felsenstein, J. (2012) A comparative method for both discrete and continuous characters using the threshold model. \emph{American Naturalist}, \bold{179}, 145-156. Revell, L. J. (2014) Ancestral character estimation under the threshold model from quantitative genetics. \emph{Evolution}, \bold{68}, 743-759. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{fastBM}}, \code{\link{pbtree}}, \code{\link{phenogram}}, \code{\link{threshBayes}} } \examples{ set.seed(999) ## plot BM simulation on 12 taxon tree tree<-pbtree(n=12) par(mfrow=c(1,2),mar=c(5.1,4.1,4.1,0.1)) x<-bmPlot(tree,bty="l") plotTree(tree,direction="upwards", mar=c(5.1,0.1,4.1,1.1),ftype="off") ## reset par to default values par(mfrow=c(1,1),mar=c(5.1,4.1,4.1,2.1)) ## plot simulation of a threshold character par(mfrow=c(1,2),mar=c(5.1,4.1,4.1,0.1)) tt<-bmPlot(tree,type="threshold",thresholds=c(0,1,2), bty="l") plot(tt$tree,direction="upwards", mar=c(5.1,0.1,4.1,1.1),ftype="off", colors=setNames(c("black","red","blue"), letters[1:3]),lwd=3) ## reset par to default values par(mfrow=c(1,1),mar=c(5.1,4.1,4.1,2.1)) } \keyword{phylogenetics} \keyword{plotting} \keyword{simulation} \keyword{continuous character} phytools/man/sim.history.Rd0000644000176200001440000000755714546017711015511 0ustar liggesusers\name{sim.history} \alias{sim.history} \alias{sim.Mk} \alias{sim.multiMk} \title{Simulate character history or a discrete character at the tips of the tree under some model} \usage{ sim.history(tree, Q, anc=NULL, nsim=1, direction=c("column_to_row","row_to_column"), ...) sim.Mk(tree, Q, anc=NULL, nsim=1, ...) sim.multiMk(tree, Q, anc=NULL, nsim=1, ...) } \arguments{ \item{tree}{a phylogenetic tree as an object of class \code{"phylo"}. For the case of \code{sim.multiMk} \code{tree} should be an object of class \code{"simmap"} in which the regimes for simulation have been mapped onto the tree.} \item{Q}{a matrix containing the instantaneous transition rates between states. Note that for \code{sim.history} \emph{by default} (i.e., when \code{direction="column_to_row"}, see below) normally this is the \emph{transpose} of the matrix produced by \code{fitDiscrete} in the \pkg{geiger} package or \code{\link{make.simmap}} in \pkg{phytools}; that is to say the transition rate from \code{i -> j} should be given by \code{Q[j,i]}. However, if your matrix is properly conformed (i.e., rows \emph{or} columns sum to 0), then \code{sim.history} will attempt to transpose your matrix correctly & will return an informative message (if \code{message=TRUE}, see below). For \code{sim.Mk} and \code{sim.multiMk} this matrix has the same conformation as in \code{fitContinuous} and \code{make.simmap}. For \code{sim.multiMk} \code{Q} should be a list of transition matrices with names that correspond to the states mapped onto the tree.} \item{anc}{an optional value for the state at the root node; if \code{NULL}, a random state will be assigned. \code{anc} can be a vector of states, in which one of the states will be chosen randomly for each simulation. For \code{sim.history} \code{anc} can be a vector of probabilities with names, in which case a state will be chosen in proportion to the given probabilities.} \item{nsim}{number of simulations.} \item{direction}{row/column direction of the input transition matrix, \code{Q}. \code{"column_to_row"} indicates that the transition rate from \code{i -> j} should be given by \code{Q[j,i]}, while \code{"row_to_column"} indicates the converse.} \item{...}{other optional arguments. Currently only \code{internal}, a logical value indicating whether or not to return internal node states (defaults to \code{internal=FALSE}; and \code{message}, a logical indicating whether or not to turn on informational messages (defaults to \code{message=TRUE}).} } \description{ Simulates discrete character evolution on a phylogenetic tree. } \details{ The function \code{sim.history} simulates a stochastic character history for a discretely valued character trait on the tree. The resultant tree is stored as a modified \code{"phylo"} object in stochastic character map (e.g., \code{\link{make.simmap}}) format. The function \code{sim.Mk} simulates the states for a discrete character at the tips of the tree only. Finally, the function \code{sim.multiMk} is the same as \code{sim.Mk} except that it permits the user to simulate under different values of \code{Q} in different parts of the tree. } \value{ \code{sim.history} returns an object of class \code{"simmap"} (a tree with a mapped discrete character) or \code{"multiSimmap"} for \code{nsim} greater than one. \code{sim.Mk} and \code{sim.multiMk} return a factor with the states of our discrete character at the tips of the tree only. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{fitMk}}, \code{\link{fitmultiMk}}, \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{plotSimmap}}, \code{\link{sim.rates}} } \keyword{phylogenetics} \keyword{simulation} \keyword{discrete character} phytools/man/skewers.Rd0000644000176200001440000000400714546017754014676 0ustar liggesusers\name{skewers} \alias{skewers} \title{Matrix comparison using the method of random skewers} \usage{ skewers(X, Y, nsim=100, method=NULL) } \arguments{ \item{X}{covariance matrix.} \item{Y}{covariance matrix.} \item{nsim}{number of random vectors.} \item{method}{method to generate a null distribution of the random skewers correlation between matrices. If \code{method=NULL} then the correlation will be compared to the correlation between random vectors; however this test has type I error substantially above the nominal level for ostensibly random matrices. Other values of \code{method} will be passed as \code{covMethod} to \code{genPositiveDefMat} for a more robust hypothesis test (see below). Recommended values include \code{"unifcorrmat"}.} } \description{ Performs the random skewers matrix comparison method of Cheverud (1996). } \details{ This function performs the random skewers matrix comparison method of Cheverud (1996; also see Cheverud & Marroig 2007 for more details). In addition, it includes a more robust hypothesis test in which random covariance matrices are simulated under a variety of models, and then the mean correlation between response vectors to random skewers are computed. } \value{ A list with the following components: \item{r}{mean random skewers correlation.} \item{p}{p-value from simulation.} } \references{ Cheverud, J. M. (1996) Quantitative genetic analysis of cranial morphology in the cotton-top (\emph{Saguinus oedipus}) and saddle-back (\emph{S. fuscicollis}) tamarins. \emph{J. Evol. Biol.}, \bold{9}, 5--42. Cheverud, J. M. and G. Marroig (2007) Comparing covariance matrices: Random skewers method compared to the common principal components model. \emph{Genetics & Molecular Biology}, \bold{30}, 461--469. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{comparative method} \keyword{statistics} phytools/man/phytools-package.Rd0000644000176200001440000000240614546016412016454 0ustar liggesusers\name{phytools-package} \alias{phytools-package} \alias{phytools} \docType{package} \title{ phytools: Phylogenetic Tools for comparative biology (and other things) } \description{ \pkg{phytools} provides functions for phylogenetic biology: focused on phylogenetic comparative analysis, but including methods to simulate data and trees, to visualize trees and fitted models, and to analyze and manipulate phylogenetic trees and data. The complete list of functions can be displayed with \code{library(help=phytools)}. The \pkg{phytools} development page is \url{https://github.com/liamrevell/phytools/}. More information on \pkg{phytools} can also be found at \url{http://blog.phytools.org} or \url{http://www.phytools.org}. If you use \pkg{phytools} (or other packages that depend on \pkg{phytools}) in a publication, please \emph{cite it}. The appropriate citation for \pkg{phytools} is listed below or can be obtained using \code{citation("phytools")} with the package installed. } \author{ Liam J. Revell Maintainer: Liam J. Revell } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \keyword{package} phytools/man/splitEdgeColor.Rd0000644000176200001440000000205414546017763016132 0ustar liggesusers\name{splitEdgeColor} \alias{splitEdgeColor} \title{Split edge colors when descendant edges have different mapped states} \usage{ splitEdgeColor(tree,colors,lwd=2) } \arguments{ \item{tree}{object of class \code{"simmap"}.} \item{colors}{named vector of colors to be used for plotting.} \item{lwd}{width of the plotted lines.} } \description{ Splits the vertical linking-line color on a plotted tree to match the daughter edges. } \details{ This function splits the vertical line colors to match the daughter edges when the daughters have different states. Mostly to be used with trees generated using \code{\link{paintBranches}} or \code{\link{paintSubTree}}. Also used internally by \code{\link{plotSimmap}}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{plotSimmap}} } \keyword{phylogenetics} \keyword{plotting} \keyword{comparative method} phytools/man/countSimmap.Rd0000644000176200001440000000365214546012203015477 0ustar liggesusers\name{countSimmap} \alias{countSimmap} \title{Counts the number of character changes on a object of class \code{"simmap"} or \code{"multiSimmap"}} \usage{ countSimmap(tree, states=NULL, message=TRUE) } \arguments{ \item{tree}{an object of class \code{"simmap"} or \code{"multiSimmap"}.} \item{states}{optional argument with the states for the mapped character. If not provided, these will be computed from the tree. This is useful if averaging across many trees, some of which may lack certain states.} \item{message}{optional logical argument indicating whether or not to return an informative message about the function output.} } \description{ Count the number of changes of different types on a stochastically mapped trees or set of trees (objects of class \code{"simmap"} or \code{"multiSimmap"}). } \details{ This function takes a tree or a set of trees with a mapped discrete character (that is, an object of class \code{"simmap"} or \code{"multiSimmap"}), and computes the total number of character changes as well as the number of character changes between all states. } \value{ A list with up to three elements: \code{N} is an integer value giving the total number of character changes on the tree; \code{Tr} gives the number of of transitions between row and column states (or a matrix containing both \code{N} and the transitions between states, in rows, for an object of class \code{"multiPhylo"}); and (optionally) \code{message} contains an explanatory message about the function output. } \examples{ ## load data from Revell & Collar (2009) data(anoletree) anoletree countSimmap(anoletree) } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{ancestral states} \keyword{phylogenetics} \keyword{utilities} \keyword{discrete character} phytools/man/sim.ratebystate.Rd0000644000176200001440000000400014546017716016320 0ustar liggesusers\name{sim.ratebystate} \alias{sim.ratebystate} \title{Conduct simulation of state dependent rate variation} \usage{ sim.ratebystate(tree, sig2x=1, sig2y=1, beta=c(0,1), ...) } \arguments{ \item{tree}{phylogenetic tree.} \item{sig2x}{variance of the Brownian process of evolution for \emph{x}, \eqn{\sigma_x^2}.} \item{sig2y}{variance of the Brownian process of evolution for \emph{y} when \code{x-min(x)==1} (for \code{logarithm=FALSE}) or \code{x==0} (for \code{logarithm=TRUE}).} \item{beta}{intercept and slope of the relationship between the value of \emph{x} and the Brownian rate in \emph{y}.} \item{...}{optional arguments which include \code{method} (\code{"by.node"} or \code{"by.branch"} indicating whether to assume the rate varies as a function of the node state or the mean branch state); \code{plot}, a logical value indicating whether or not to plot a traitgram ("phenogram") with the branches used for simulation of \code{y} after rescaling by the state of \code{x}; and \code{logarithm}, a logical value indicating whether or not simulate changes in the variance of Brownian evolution for \code{y} as an additive \code{logarithm=FALSE} or multiplicative function of \code{x}. The default is \code{logarithm=FALSE}.} } \description{ Simulates two characters under a model in which the rate of one depends on the state of the other. } \details{ This function attempts to simulate two characters under a model in which the rate of evolution for the second (\emph{y}) depends on the states for the first (\emph{x}). See \code{\link{ratebystate}} for more details. } \value{ This function returns a matrix. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{fastBM}}, \code{\link{ratebystate}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{simulation} \keyword{continuous character} phytools/man/vcvPhylo.Rd0000644000176200001440000000221014546020415015003 0ustar liggesusers\name{vcvPhylo} \alias{vcvPhylo} \title{Calculates cophenetic (i.e., phylogenetic VCV) matrix} \usage{ vcvPhylo(tree, anc.nodes=TRUE, ...) } \arguments{ \item{tree}{object of class \code{"phylo"}.} \item{anc.nodes}{logical value indicating whether or not to include ancestral nodes.} \item{...}{optional arguments including \code{internal} (synonym of \code{anc.nodes}) and \code{model} (can be \code{"BM"}, \code{"OU"}, or \code{"lambda"}.} } \description{ Computes a phylogenetic variance-covariance matrix. } \details{ This function returns a so-called \emph{phylogenetic variance covariance matrix} (e.g., see \code{\link{vcv.phylo}}), but (optionally) including ancestral nodes, as well as under multiple evolutionary models. \code{vcvPhylo} is designed primarily for internal use by other \emph{phytools} functions. } \value{ A matrix. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{statistics} \keyword{utilities} phytools/man/brownieREML.Rd0000644000176200001440000000554314546011764015341 0ustar liggesusers\name{brownieREML} \alias{brownieREML} \title{REML version of brownie.lite} \usage{ brownieREML(tree, x, maxit=2000, ...) } \arguments{ \item{tree}{an object of class \code{"phylo"} or \code{"simmap"}. (See \code{\link{read.simmap}} and \code{\link{make.simmap}} for more information about the latter object class.)} \item{x}{a vector of tip values for species. \code{names(x)} should be the species names.} \item{maxit}{an optional integer value indicating the maximum number of iterations for optimization - may need to be increased for large trees.} \item{...}{optional arguments.} } \description{ Fits a multi-rate Brownian motion evolution model using REML. (See \code{\link{brownie.lite}} for more details.) } \details{ This function takes an object of class \code{"phylo"} or an object of class \code{"simmap"} with a mapped binary or multi-state trait (see \code{\link{read.simmap}}) and data for a single continuously valued character. It then uses restricted maximum likelihood (REML) to fit the Brownian rate variation ("noncensored") model of O'Meara et al. (2006; \emph{Evolution}). This function is similar to \code{\link{brownie.lite}} but uses REML (which is faster and unbiased) instead of ML. REML optimization takes advantage of Felsenstein's (1985) contrasts algorithm. } \value{ An object of class \code{"brownieREML"} containing the following components: \item{sig2.single}{is the rate, \eqn{\sigma^2}, for a single rate model - this is usually the "null" model.} \item{logL1}{log-likelihood of the single-rate model.} \item{sig2.multiple}{is a length \emph{p} (for \emph{p} rates) vector of BM rates (\eqn{\sigma_1^2}, \eqn{\sigma_2^2}, and so on) from the multi-rate model.} \item{logL2}{log-likelihood of the multi-rate model.} \item{convergence}{numerical value from \code{\link{optim}}.} } \references{ Felsenstein, J. (1985) Phylogenies and the comparative method. \emph{American Naturalist}, \bold{125}, 1-15. O'Meara, B. C., C. Ane, M. J. Sanderson, and P. C. Wainwright (2006) Testing for different rates of continuous trait evolution using likelihood. \emph{Evolution}, \bold{60}, 922-933. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{brownie.lite}}, \code{\link{evol.vcv}}, \code{\link{evol.rate.mcmc}}, \code{\link{ratebytree}} } \examples{ ## load data from Revell & Collar (2009) data(sunfish.tree) data(sunfish.data) ## extract character of interest gape.width<-setNames(sunfish.data$gape.width, rownames(sunfish.data)) ## fit model multiBM.reml<-brownieREML(sunfish.tree, gape.width) print(multiBM.reml) } \keyword{phylogenetics} \keyword{comparative method} \keyword{continuous character} \keyword{maximum likelihood} phytools/man/phylomorphospace.Rd0000644000176200001440000001102314546015372016575 0ustar liggesusers\name{phylomorphospace} \alias{phylomorphospace} \alias{project.phylomorphospace} \title{Creates phylomorphospace plot} \usage{ phylomorphospace(tree, X, A=NULL, label=c("radial","horizontal","off"), control=list(), ...) project.phylomorphospace(tree, X, nsteps=200, sleep=0, direction=c("to","from","both"), ...) } \arguments{ \item{tree}{a phylogenetic tree in \code{"phylo"} format, or a modified \code{"phylo"} object with a mapped discrete character.} \item{X}{an \code{n} x 2 matrix of tip values for two characters in \code{n} species.} \item{A}{an optional \code{m} x 2 matrix (for \code{m} nodes) of values for two traits at internal nodes in the tree - if not supplied, these values will be estimated using \code{\link{fastAnc}}.} \item{label}{string indicating whether to plot the tip labels in the same direction as the terminal edge (\code{label="radial"}), horizontally \code{label="horizontal"}, or not at all \code{"off"}. \code{label=TRUE} and \code{label=FALSE} are also acceptable, for compatibility with phytools <= 0.3-03.} \item{control}{a list containing the following optional control parameters: \code{col.edge}: a vector of edge colors; and \code{col.node}: a vector of node colors.} \item{nsteps}{for \code{project.phylomorphospace} the number of frames in the animation between the phylogeny & the phylomorphospace or \emph{vice versa}.} \item{sleep}{for \code{project.phylomorphospace} the time between frames.} \item{direction}{for \code{project.phylomorphospace} whether to morph \code{"to"} a phylomorphospace, \code{"from"} a phylomorphospace, or there & back again (\code{"both"}).} \item{...}{optional arguments for plotting, including \code{xlim}, \code{ylim}, \code{xlab}, \code{ylab}, \code{lwd}, \code{colors}, \code{fsize}, and \code{node.by.map}. \code{colors} is only used when there is a mapped discrete character on the tree, in which case \code{control$col.edge} is ignored. \code{fsize} is relative to the default, which is \code{textxy(...,cx=0.75)}. \code{node.by.map} is a logical value (defaults to \code{FALSE} which tells the function whether or not to plot the node colors using the colors of the mapped discrete character. Setting this option to \code{TRUE} will cause \code{control$col.node} to be ignored. \code{node.size} is a vector containing the point size relative to the default (see \code{\link{par}} for plotted internal nodes and tips, respectively. Defaults to \code{node.size=c(1,1.3)}. If only one number is provided it will be recycled. \code{axes} is a logical value indicating whether or not axes should be plotted (see \code{\link{plot.default}}. Finally, \code{add} indicates whether to add the phylomorphospace to the current plot.} } \description{ Project a phylogeny into morphospace. } \details{ This function creates a phylomorphospace plot (a projection of the tree into morphospace) for two characters following Sidlauskas (2008; \emph{Evolution}). It will also plot a discrete character mapped on tree. \code{project.phylomorphospace} animates the phylomorphospace projection. } \value{ This function creates a phylomorphospace plot } \references{ Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-90. Revell, L. J. (2014) Graphical methods for visualizing comparative data on phylogenies. Chapter 4 in \emph{Modern phylogenetic comparative methods and their application in evolutionary biology: Concepts and practice} (L. Z. Garamszegi ed.), pp. 77-103. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. Sidlauskas, B. (2008) Continuous and arrested morphological diversification in sister clades of characiform fishes: A phylomorphospace approach. \emph{Evolution}, \bold{62}, 3135-3156. } \author{Liam Revell \email{liam.revell@umb.edu}} \examples{ ## load tree & data from Revell & Collar (2009) data(sunfish.tree) data(sunfish.data) ## set colors for mapped discrete character cols<-setNames(c("blue","red"), levels(sunfish.data$feeding.mode)) phylomorphospace(sunfish.tree,sunfish.data[,3:2], colors=cols,bty="l",ftype="off",node.by.map=TRUE, node.size=c(0,1.2),xlab="relative buccal length", ylab="relative gape width") title(main="Phylomorphospace of buccal morphology in Centrarchidae", font.main=3) } \keyword{ancestral states} \keyword{phylogenetics} \keyword{comparative method} \keyword{plotting} \keyword{continuous character} phytools/man/roundBranches.Rd0000644000176200001440000000177514546017473016017 0ustar liggesusers\name{roundBranches} \alias{roundBranches} \title{Rounds the branch lengths of a tree} \usage{ roundBranches(tree, digits) } \arguments{ \item{tree}{an object of class \code{"phylo"}, \code{"multiPhylo"}, \code{"simmap"}, or \code{"multiSimmap"}.} \item{digits}{number of digits for rounding. Passed to \code{\link{round}}.} } \description{ Rounds the branch lengths of a phylogenetic tree. } \details{ This function rounds the branch lengths of a tree or trees to a precision indicated by \code{digits}, and reconciles any mappings for objects of class \code{"simmap"} or \code{"multiSimmap"}. } \value{ An object of class \code{"phylo"}, \code{"multiPhylo"}, \code{"simmap"}, or \code{"multiSimmap"}, with rounded edge lengths. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/add.everywhere.Rd0000644000176200001440000000164314546010677016127 0ustar liggesusers\name{add.everywhere} \alias{add.everywhere} \title{Add tip to all edges in a tree} \usage{ add.everywhere(tree, tip.name) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{tip.name}{a string containing the name of the tip to add.} } \description{ This function adds a tip to all branches of the tree and returns a a list of trees as an object of class \code{"multiPhylo"}. } \value{ A list of trees as an object of class \code{"multiPhylo"}. Since the tip can be added to any branch, the length of the list is equal to the number of edges in \code{tree}. } \author{Liam Revell \email{liam.revell@umb.edu}} \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \seealso{ \code{\link{allFurcTrees}}, \code{\link{exhaustiveMP}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/linklabels.Rd0000644000176200001440000000247114546013462015326 0ustar liggesusers\name{linklabels} \alias{linklabels} \title{Function to add tip labels to a plotted tree with linking lines} \usage{ linklabels(text,tips,link.type=c("bent","curved","straight"), ...) } \arguments{ \item{text}{text string or vector to be used as labels.} \item{tips}{node numbers (indices) for the tips to be labeled.} \item{link.type}{manner in which to draw the linking lines.} \item{...}{optional arguments, including \code{cex}, \code{lty}, \code{lwd}, and \code{col}.} } \description{ Adds tip labels to a plotted tree by drawing curved, bent, or straight linking lines. } \details{ The idea underlying this function is that the user should first plot the tree without tip labels, but set the area of the plotting device to be sufficient to accommodate the tip labels once they have been added. The function then can be called to add tip labels connected by linking lines to the tips of the plotted tree. } \value{ This function annotates a plot. } \seealso{ \code{\link{cladelabels}}, \code{\link{nodelabels}}, \code{\link{tiplabels}} } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{plotting} \keyword{utilities} phytools/man/rescale.Rd0000644000176200001440000000243214546017555014630 0ustar liggesusers\name{rescale} \alias{rescale} \title{Rescale phylogenetic objects of different types} \usage{ rescale(x, ...) } \arguments{ \item{x}{phylogenetic tree object to be rescaled: e.g., object of class \code{"phylo"} or \code{"simmap"}.} \item{...}{other arguments to be used in rescaling, depending on the object class. (E.g., see \code{\link[geiger]{rescale.phylo}} in \pkg{geiger} and \code{\link{rescale.simmap}}.)} } \description{ Generic method for rescaling different types of phylogenetic trees. } \details{ See \code{\link[geiger]{rescale.phylo}} in \pkg{geiger} and \code{\link{rescale.simmap}} for details. } \value{ A rescaled phylogenetic tree object. } \references{ Pennell, M.W., J. M. Eastman, G. J. Slater, J. W. Brown, J. C. Uyeda, R. G. FitzJohn, M. E. Alfaro, and L. J. Harmon (2014) geiger v2.0: an expanded suite of methods for fitting macroevolutionary models to phylogenetic trees. \emph{Bioinformatics}, \bold{30}, 2216-2218. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link[geiger]{rescale.phylo}}, \code{\link{rescale.simmap}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/paste.tree.Rd0000644000176200001440000000164314546014521015255 0ustar liggesusers\name{paste.tree} \alias{paste.tree} \title{Paste two trees together} \usage{ paste.tree(tr1, tr2) } \arguments{ \item{tr1}{receptor tree.} \item{tr2}{donor clade.} } \description{ Internal function for \code{\link{posterior.evolrate}}. } \details{ Primarily designed as an internal function for \code{\link{posterior.evolrate}}; however, can be used to graft a clade onto a receptor tree at the "sticky tip" labeled with \code{"NA"}. The donor clade needs to have a root edge, even if it is zero length. } \value{ A tree. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \examples{ tr1<-rtree(10) tr2<-rtree(10) tr1$tip.label[1]<-"NA" tr2$root.edge<-0 tr3<-paste.tree(tr1,tr2) } \keyword{phylogenetics} \keyword{utilities} phytools/man/bind.tip.Rd0000644000176200001440000000501314546011610014701 0ustar liggesusers\name{bind.tip} \alias{bind.tip} \title{Attaches a new tip to a tree} \usage{ bind.tip(tree, tip.label, edge.length=NULL, where=NULL, position=0, interactive=FALSE, ...) } \arguments{ \item{tree}{receptor tree.} \item{tip.label}{a string containing the species name for the new tip.} \item{edge.length}{edge length for the new tip (a scalar).} \item{where}{node number to attach new tip. If \code{position>0} then then tip will be attached \emph{rootward} of the specified node. Node numbers can also be tips, in which case the new tip will be added along the terminal edge. To find out the tip number for given species with name \emph{"species"} type: \code{which(tree$tip.label=="species")}.} \item{position}{distance \emph{rootward} of the node to add the new tip.} \item{interactive}{logical value indicating whether or not the species should be added interactively. (Defaults to \code{FALSE}.)} \item{...}{arguments to be passed to \code{plotTree} (for \code{interactive=TRUE}.)} } \description{ Adds a new tip to the tree. } \details{ If the tree is ultrametric and no branch length is specified, then \code{edge.length} is scaled so that the tree remains ultrametric after the new tip is added. Wrapper function for \pkg{ape} \code{\link{bind.tree}}. Note that \code{interactive=TRUE} works only for right-facing phylograms. } \value{ An object of class \code{"phylo"}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \examples{ set.seed(123) par(mfrow=c(3,1)) ## generate tree tree<-pbtree(b=0.1, n=10) ## plot original tree plotTree(tree,mar=c(2.1,0.1,2.1,0.1)) axisPhylo() mtext("a)",adj=0) ## add an extant tip ("t_extant") sister to taxon 't5' ## with divergence time of 4.5 Ma node <- which(tree$tip.label=="t5") tree <- bind.tip(tree, tip.label="t_extant", where=node, position=4.5) # plot to see the result plotTree(tree,mar=c(2.1,0.1,2.1,0.1)) axisPhylo() mtext("b)",adj=0) ## add an extinct tip ("t_extinct") sister to 't2' with ## divergence time of 7.8 Ma and duration (edge length) of ## 3.3 Ma node <- which(tree$tip.label=="t2") tree <- bind.tip(tree, tip.label="t_extinct", where=node, position=7.8, edge.length=3.3) ## plot to see the result plotTree(tree,mar=c(2.1,0.1,2.1,0.1)) axisPhylo() mtext("c)",adj=0) par(mar=c(5.1,4.1,4.1,2.1),mfrow=c(1,1)) } \keyword{phylogenetics} \keyword{utilities} phytools/man/ratebystate.Rd0000644000176200001440000000456514546016766015555 0ustar liggesusers\name{ratebystate} \alias{ratebystate} \title{Method for investigating the rate of one trait as a function of the state of another} \usage{ ratebystate(tree, x, y, nsim=100, corr=c("pearson","spearman"), ...) } \arguments{ \item{tree}{phylogenetic tree.} \item{x}{a continuous character - the dependent variable in the model.} \item{y}{a second continuous trait - the response variable.} \item{nsim}{number of simulations for hypothesis testing.} \item{corr}{correlation method to use. Same as in \code{\link{cor}}.} \item{...}{optional arguments which include \code{sim.method} (\code{"fastBM"} or \code{"sim.corrs"}; see \code{\link{fastBM}} and \code{\link{sim.corrs}}); \code{method} (\code{"by.node"} or \code{"by.branch"} indicating whether to assume the rate varies as a function of the node state or the mean branch state); \code{message} - a logical value indicating whether or not to return \code{corr} and \code{method}; finally \code{logarithm} - indicating whether or not to fit a model in which the variance of Brownian evolution in \code{y} changes as a multiplicative function of \code{x}. The default is \code{logarithm=FALSE}.} } \description{ Statistical test of whether the rate of a continuous character might be influenced by the state of another. } \details{ This function attempts to ask if the rate of a continuous character, \code{y}, depends on the state of a separate continuous trait, \code{x}. This is accomplished by regressing the squared contrasts in \code{y} on the branch or node ancestral estimates of \code{x}. } \value{ This function returns an object of class \code{"ratebystate"} with up to the following four elements: \item{beta}{value of the regression coefficient for square of the contrasts in \code{y} regressed on the ancestral or branch-wise estimated states for \code{x}.} \item{r}{correlation coefficient for \code{corr=corr}.} \item{corr}{string giving the value of \code{corr}.} \item{method}{string giving the value of \code{method}.} } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{fastAnc}}, \code{\link{pic}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{continuous character} \keyword{maximum likelihood} phytools/man/phylo.impute.Rd0000644000176200001440000000323314546016205015636 0ustar liggesusers\name{phylo.impute} \alias{phylo.impute} \title{Phylogenetic imputation for multivariate continuous character data} \usage{ phylo.impute(tree, X, ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{X}{data matrix with species names as row labels. Missing data to be imputed should be coded \code{NA}.} \item{...}{optional arguments.} } \description{ This function performs phylogenetic multiple imputation using maximum likelihood. } \details{ This function performs phylogenetic imputation in which the evolution of the characters in \code{X} is assumed to have occurred by correlation multivariate Brownian motion. Missing values are imputed by maximizing their likelihood jointly with the parameters of the Brownian model. The function \code{\link{evol.vcv}} is used internally to compute the likelihood. Note that the \pkg{Rphylopars} package also does phylogenetic imputation for multivariate trait data and it seems to be much faster. } \value{ An object of class \code{"phylo.impute"} consisting of a complete data frame with missing values imputed. Since optimization is performed numerically using likelihood, a summary of the optimization can be seen by evaluating \code{attr(object,"optim")}, in which \code{object} is of class \code{"phylo.impute"}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{evol.vcv}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{continuous character} \keyword{statistics} phytools/man/anc.ML.Rd0000644000176200001440000000555514546011000014246 0ustar liggesusers\name{anc.ML} \alias{anc.ML} \title{Ancestral character estimation using likelihood} \usage{ anc.ML(tree, x, maxit=2000, model=c("BM","OU","EB"), ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{x}{a vector of tip values for species; \code{names(x)} should be the species names.} \item{maxit}{an optional integer value indicating the maximum number of iterations for optimization.} \item{model}{model of continuous character evolution on the tree. It's possible that only \code{model="BM"} & \code{model="EB"} work in the present version as \code{model="OU"} has not be thoroughly tested & some bugs were reported for an earlier version.} \item{...}{optional arguments.} } \description{ This function estimates the evolutionary parameters and ancestral states for Brownian evolution using likelihood. It is also possible (for \code{model="BM"}) to allow for missing data for some tip taxa. } \details{ Because this function relies on a high dimensional numerical optimization of the likelihood function, \code{\link{fastAnc}} should probably be preferred for most purposes. If using \code{\link{anc.ML}}, users should be cautious to ensure convergence. This issue has been ameliorated in \pkg{phytools} >= 0.2-48 by seeding the ML optimization with the result from \code{\link{fastAnc}}. For \code{model="EB"} this should also not be a problem as the numerical optimization is performed for only \code{sig2} and \code{r}, while the ML values of the ancestral states are obtained during every iteration of the optimization algorithmically using the re-rooting method. } \value{ An object of class \code{"anc.ML"} with at least the following four elements (if not more, depending on \code{model}): \item{sig2}{the variance of the BM process.} \item{ace}{a vector with the ancestral states.} \item{logLik}{the log-likelihood.} \item{convergence}{the value of \code{convergence} returned by \code{\link{optim}} (0 is good).} } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. Schluter, D., Price, T., Mooers, A. O., and Ludwig, D. (1997) Likelihood of ancestor states in adaptive radiation. \emph{Evolution} \bold{51}, 1699-1711. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ace}}, \code{\link{anc.Bayes}}, \code{\link{fastAnc}}, \code{\link{optim}} } \examples{ ## load data from Garland et al. (1992) data(mammal.tree) data(mammal.data) ## extract character of interest ln.bodyMass<-log(setNames(mammal.data$bodyMass, rownames(mammal.data))) ## estimate ancestral state under BM model fit.BM<-anc.ML(mammal.tree,ln.bodyMass) print(fit.BM) } \keyword{ancestral states} \keyword{phylogenetics} \keyword{comparative method} \keyword{maximum likelihood} \keyword{continuous character} phytools/man/phenogram.Rd0000644000176200001440000001156114546015413015164 0ustar liggesusers\name{phenogram} \alias{phenogram} \title{Plot traitgram (phenogram)} \usage{ phenogram(tree, x, fsize=1.0, ftype="reg", colors=NULL, axes=list(), add=FALSE, ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}, with or without a mapped discrete character.} \item{x}{a vector containing the states at the tips \emph{or} the states at all the tips and the internal nodes of the tree.} \item{fsize}{relative font size for tip labels.} \item{ftype}{font type - options are \code{"reg"}, \code{"i"} (italics), \code{"b"} (bold), or \code{"bi"} (bold-italics).} \item{colors}{colors for plotting the mapped character (if available) in \code{tree}. If no character is mapped on the tree, then a single color for all the branches of the tree can be provided.} \item{axes}{list of axis dimensions. Items are \code{time} and \code{trait}.} \item{add}{optional logical value indicating whether to add to an open plot. If \code{TRUE}, then new axes will not be plotted.} \item{...}{optional arguments including \code{xlim}, \code{ylim}, \code{log}, \code{main}, \code{sub}, \code{xlab}, \code{ylab}, \code{asp}, \code{type}, \code{lty}, \code{lwd}, \code{offset}, and \code{digits} are as in \code{\link{plot.default}} or \code{\link{par}}. Note that \code{axes} overrides \code{xlim} and \code{ylim}. \code{spread.labels} is a logical value indicating whether or not to minimize tip label overlap (default is \code{TRUE}); \code{spread.cost} is a numeric vector indicating the relative penalty to be used for label overlap and deviance, respectively (if \code{spread.labels=TRUE}); \code{spread.range} is the range over which to (potentially) spread the labels - note that if labels do not overlap, not all of that range will be used; finally, \code{link} is a numeric value by which to offset the tip labels, linking them to the tips with a dashed line (default is \code{0}, if \code{spread.labels=FALSE}, or 10\% of the total tree length otherwise). The optional argument \code{offsetFudge} "fudges" the computation of label offset in scaling \code{xlim}. It is 1.37, which is the correct fudge in the Windows R GUI, but this may need to be changed in other systems. \code{hold} indicates whether (or not) the output to the graphical device should be held using \code{\link{dev.hold}} before plotting (defaults to \code{hold=TRUE}). \code{quiet} suppresses some system messages if set to \code{quiet=TRUE}.} } \description{ Plots a phylogenetic traitgram (Evans et al., 2009). } \details{ Function plots a traitgram (Evans et al. 2009), that is, a projection of the phylogenetic tree in a space defined by phenotype (on the \emph{y} axis) and time (on the \emph{x}). If a discrete character is mapped on the tree this will also be plotted. For \code{spread.labels=TRUE} numerical optimization is performed to optimize the distribution of the labels vertically, where the solution depends on the vector \code{spread.cost} containing the cost of overlap (first) and the cost of deviation from the vertical position of the tip. Note that because this is done via numerical optimization, plotting may hang briefly while the best solution is found (especially for large trees). } \value{ Plots a traitgram, optionally with a mapped discrete character, and (invisibly) returns a matrix containing the coordinates of the plotted tip labels. } \references{ Evans, M. E. K., Smith, S. A., Flynn, R. S., Donoghue, M. J. (2009) Climate, niche evolution, and diversification of the "bird-cage" evening primroses (Oenothera, sections Anogra and Kleinia). \emph{American Naturalist}, \bold{173}, 225-240. Revell, L. J. (2013) Two new graphical methods for mapping trait evolution on phylogenies. \emph{Methods in Ecology and Evolution}, \bold{4}, 754-759. Revell, L. J. (2014) Graphical methods for visualizing comparative data on phylogenies. Chapter 4 in \emph{Modern phylogenetic comparative methods and their application in evolutionary biology: Concepts and practice} (L. Z. Garamszegi ed.), pp. 77-103. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. Revell, L. J., K. Schliep, E. Valderrama, and J. E. Richardson (2018) Graphs in phylogenetic comparative analysis: Anscombe's quartet revisited. \emph{Methods in Ecology and Evolution}, \bold{9}, 2145-2154. } \author{Liam Revell \email{liam.revell@umb.edu}} \examples{ ## load data from Garland et al. (1992) data(mammal.tree) data(mammal.data) ## extract character of interest ln.bodyMass<-log(setNames(mammal.data$bodyMass, rownames(mammal.data))) ## plot traitgram phenogram(mammal.tree,ln.bodyMass,ftype="i", spread.cost=c(1,0),fsize=0.7,color=palette()[4], xlab="time (ma)",ylab="log(body mass)",las=1) } \keyword{ancestral states} \keyword{phylogenetics} \keyword{plotting} \keyword{comparative method} \keyword{continuous character} phytools/man/plotTree.wBars.Rd0000644000176200001440000001146014546016562016063 0ustar liggesusers\name{plotTree.wBars} \alias{plotTree.wBars} \alias{plotTree.barplot} \alias{plotTree.boxplot} \title{Plot a tree with bars at the tips} \usage{ plotTree.wBars(tree, x, scale=NULL, width=NULL, type="phylogram", method="plotTree", tip.labels=FALSE, col="grey", border=NULL, ...) plotTree.barplot(tree, x, args.plotTree=list(), args.barplot=list(), ...) plotTree.boxplot(tree, x, args.plotTree=list(), args.boxplot=list(), ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{x}{a named vector or matrix of trait values. For \code{plotTree.boxplot}, the names should repeat for multiple observations per species. For \code{plotTree.boxplot} \code{x} can also be supplied as a formula, though in that case the factor levels need to be provided in a valid cladewise order of the tips in \code{tree}. This order doesn't need to correspond with the current order of the tip labels. For \code{plotTree.barplot} \code{x} can be a matrix (or a data frame) in which columns are the values of multiple traits to be simultaneously plotted on the tree.} \item{scale}{scaling factor for the tip bars (relative to the total tree height). If left as \code{NULL} a reasonable scaling factor is computed automatically.} \item{width}{width of the tip bars.} \item{type}{plot type. Can be \code{"phylogram"} or \code{"fan"}.} \item{method}{plotting method to use. Can be \code{"plotTree"} (for \code{\link{plotTree}}) or \code{"plotSimmap"} (for \code{\link{plotSimmap}}).} \item{tip.labels}{argument indicating whether or not tip labels should be plotted. Defaults to \code{tip.labels=FALSE}.} \item{col}{colors of the plotted bars. Can be a single value or a vector with length equal to the number of tips in the tree.} \item{border}{single value specifying the color of the border for the plotted bars. Defaults to \code{border=NULL}, which means that black borders will be plotted.} \item{args.plotTree}{in \code{plotTree.barplot}, arguments to be passed to \code{\link{plotTree}}.} \item{args.barplot}{in \code{plotTree.barplot}, arguments to be passed to \code{\link{barplot}}.} \item{args.boxplot}{in \code{plotTree.boxplot}, arguments to be passed to \code{\link{boxplot}}.} \item{...}{optional arguments to be passed to \code{\link{plotTree}} or \code{\link{plotSimmap}} in the case of \code{plotTree.wBars}. For \code{plotTree.barplot}, the only optional arguments are \code{add} and \code{ylim}. Generally \code{add} should not be used; however it can be employed to tell the function to draw the tree & barplot, respectively, in the next two open plotting devices - rather than creating a table of figures in the current plotting device. \code{ylim} (which is also an optional argument for \code{plotTree.boxplot} should be supplied here rather than using \code{args.plotTree}, \code{args.boxplot}, or \code{args.barplot} because \emph{y} axis limits must match exactly between the two plots.} } \description{ Plots a phylogenetic tree with adjacent boxplot or barplot. } \details{ \code{plotTree.wbars} plots a phylogeny in phylogram or fan style with bars at the tips representing the values for a phenotypic trait. \code{plotTree.barplot} creates a split plot in which a right-facing phylogram is on the left, and a bar plot is shown on the right. \code{plotTree.boxplot} creates a split plot in which a right-facing phylogram is on the left, and a box plot is shown on the right. } \value{ Plots a tree with an associated bar plot for a continuously valued character at the tips. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{barplot}}, \code{\link{dotTree}}, \code{\link{plotSimmap}}, \code{\link{plotTree}} } \examples{ ## load data from Mahler et al. (2010) data(anoletree) data(anole.data) ## extract overall body size (SVL) svl<-setNames(anole.data$SVL,rownames(anole.data)) ## plotTree.wBars plotTree.wBars(anoletree,svl,type="fan",scal=0.5) par(mar=c(5.1,4.1,4.1,2.1)) ## plotTree.barplot plotTree.barplot(anoletree,exp(svl), args.plotTree=list(fsize=0.5), args.barplot=list(xlab="SVL (mm)")) ## load vertebrate tree and data data(vertebrate.tree) data(vertebrate.data) ## plotTree.barplot options(scipen=4) ## change sci-notation par(cex.axis=0.8) plotTree.barplot(vertebrate.tree, setNames(vertebrate.data$Mass, rownames(vertebrate.data)), args.barplot=list( log="x", xlab="mass (kg)", xlim=c(0.01,500000), col=palette()[4])) options(scipen=0) ## reset par to defaults par(mfrow=c(1,1),mar=c(5.1,4.1,4.1,2.1),cex.axis=1) } \keyword{phylogenetics} \keyword{plotting} \keyword{comparative method} \keyword{continuous character} phytools/man/brownie.lite.Rd0000644000176200001440000000757014546011756015620 0ustar liggesusers\name{brownie.lite} \alias{brownie.lite} \title{Likelihood test for rate variation in a continuous trait} \usage{ brownie.lite(tree, x, maxit=2000, test="chisq", nsim=100, se=NULL, ...) } \arguments{ \item{tree}{a phylogenetic tree either as an object of class \code{"phylo"} or \code{"simmap"}. (See \code{\link{read.simmap}}, \code{\link{make.simmap}}, or \code{\link{paintSubTree}} for more details about the latter object class.)} \item{x}{a vector of tip values for species. \code{names(x)} should be the species names.} \item{maxit}{an optional integer value indicating the maximum number of iterations for optimization - may need to be increased for large trees.} \item{test}{an optional string indicating the method for hypothesis testing - options are \code{"chisq"} or \code{"simulation"}.} \item{nsim}{number of simulations (only used if \code{test="simulation"}).} \item{se}{a vector containing the standard errors for each estimated mean in \code{x}.} \item{...}{optional arguments.} } \description{ Fits a multi-rate Brownian motion evolution model using maximum likelihood. } \details{ This function takes an object of class \code{"phylo"} or class \code{"simmap"} with a mapped binary or multi-state trait (see \code{\link{read.simmap}}) and data for a single continuously valued character. It then fits the Brownian rate variation ("noncensored") model of O'Meara et al. (2006; \emph{Evolution}). This is also the basic model implemented in Brian O'Meara's \emph{Brownie} software. Sampling error in the estimation of species means can also be accounted for by assigning the vector \code{se} with the species specific sampling errors for \code{x}. } \value{ An object of class \code{"brownie.lite"} containing the following elements: \item{sig2.single}{is the rate, \eqn{\sigma^2}, for a single-rate model. This is usually the "null" model.} \item{a.single}{is the estimated state at the root node for the single rate model.} \item{var.single}{variance on the single rate estimator - obtained from the Hessian.} \item{logL1}{log-likelihood of the single-rate model.} \item{k1}{number of parameters in the single rate model (always 2).} \item{sig2.multiple}{is a length \emph{p} (for \emph{p} rates) vector of BM rates (\eqn{\sigma_1^2}, \eqn{\sigma_2^2}, and so on) from the multi-rate model.} \item{a.multiple}{is the estimated state at the root node for the multi-rate model.} \item{var.multiple}{\emph{p} x \emph{p} variance-covariance matrix for the \emph{p} rates - the square-roots of the diagonals should give the standard error for each rate.} \item{logL.multiple}{log-likelihood of the multi-rate model.} \item{k2}{number of parameters in the multi-rate model (\emph{p}+1).} \item{P.chisq}{P-value for a likelihood ratio test against the \eqn{\chi^2} distribution; or} \item{P.sim}{P-value for a likelihood ratio test against a simulated null distribution.} \item{convergence}{logical value indicating if the likelihood optimization converged.} } \references{ O'Meara, B. C., C. Ane, M. J. Sanderson, and P. C. Wainwright (2006) Testing for different rates of continuous trait evolution using likelihood. \emph{Evolution}, \bold{60}, 922-933. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{brownieREML}}, \code{\link{evol.vcv}}, \code{\link{ratebytree}} } \examples{ ## load data from Revell & Collar (2009) data(sunfish.tree) data(sunfish.data) ## extract character of interest buccal.length<-setNames(sunfish.data$buccal.length, rownames(sunfish.data)) ## fit model multiBM.fit<-brownie.lite(sunfish.tree, buccal.length) print(multiBM.fit) } \keyword{phylogenetics} \keyword{comparative method} \keyword{maximum likelihood} \keyword{continuous character} phytools/man/setMap.Rd0000644000176200001440000000361614546017645014450 0ustar liggesusers\name{setMap} \alias{setMap} \alias{setMap.contMap} \alias{setMap.densityMap} \alias{setMap.phyloScattergram} \alias{setMap.multirateBM_plot} \title{Set color map for various phylogenetic objects of classes} \usage{ setMap(x, ...) \method{setMap}{contMap}(x, ...) \method{setMap}{densityMap}(x, ...) \method{setMap}{phyloScattergram}(x, ...) \method{setMap}{multirateBM_plot}(x, ...) } \arguments{ \item{x}{an object of class \code{"contMap"}, \code{"densityMap"}, \code{"phyloScattergram"}, or \code{"multirateBM_plot"}.} \item{...}{arguments to be passed to \code{\link{colorRampPalette}}. Also, the argument \code{invert} which (if \code{invert=TRUE}) will just flip the current color ramp.} } \description{ Changes the color map (ramp) in an object of class \code{"contMap"}, \code{"densityMap"}, \code{"phyloScattergram"}, or \code{"multirateBM_plot"}. } \value{ An object of class \code{"contMap"}, \code{"densityMap"}, \code{"phyloScattergram"}, or \code{"multirateBM_plot"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Revell, L. J. (2013) Two new graphical methods for mapping trait evolution on phylogenies. \emph{Methods in Ecology and Evolution}, \bold{4}, 754-759. Revell, L. J. (2014) Graphical methods for visualizing comparative data on phylogenies. Chapter 4 in \emph{Modern phylogenetic comparative methods and their application in evolutionary biology: Concepts and practice} (L. Z. Garamszegi ed.), pp. 77-103. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{contMap}}, \code{\link{densityMap}}, \code{\link{multirateBM}} } \keyword{phylogenetics} \keyword{plotting} phytools/man/fitMk.Rd0000644000176200001440000002647514546017157014277 0ustar liggesusers\name{fitMk} \alias{fitMk} \alias{plot.fitMk} \alias{plot.gfit} \alias{fitmultiMk} \alias{fitpolyMk} \alias{graph.polyMk} \alias{plot.fitpolyMk} \alias{mcmcMk} \alias{plot.mcmcMk} \alias{density.mcmcMk} \alias{plot.density.mcmcMk} \alias{fitHRM} \alias{plot.fitHRM} \alias{fitMk.parallel} \alias{fitgammaMk} \title{Fits extended M\emph{k} model for discrete character evolution} \usage{ fitMk(tree, x, model="SYM", fixedQ=NULL, ...) \method{plot}{fitMk}(x, ...) \method{plot}{gfit}(x, ...) fitmultiMk(tree, x, model="ER", ...) fitpolyMk(tree, x, model="SYM", ordered=FALSE, ...) graph.polyMk(k=2, model="SYM", ordered=FALSE, ...) \method{plot}{fitpolyMk}(x, ...) mcmcMk(tree, x, model="ER", ngen=10000, ...) \method{plot}{mcmcMk}(x, ...) \method{density}{mcmcMk}(x, ...) \method{plot}{density.mcmcMk}(x, ...) fitHRM(tree, x, model="ARD", ncat=2, ...) \method{plot}{fitHRM}(x, ...) fitMk.parallel(tree, x, model="SYM", ncores=1, ...) fitgammaMk(tree, x, model="ER", fixedQ=NULL, nrates=8, ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}. In the case of \code{fitmultiMk} an object of class \code{"simmap"} with a mapped discrete character.} \item{x}{a vector of tip values for species; \code{names(x)} should be the species names. In the case of \code{plot} and \code{density} methods, an object of the appropriate class.} \item{model}{model. See \code{make.simmap} or \code{ace} for details.} \item{fixedQ}{fixed value of transition matrix \code{Q}, if one is desired.} \item{ordered}{for \code{fitpolyMk}, a logical value indicating whether or not the character should be treated as ordered. For now the function assumes alphanumerical order (i.e., numbers sorted by their initial and then successive digits followed by characters or character strings in alphabetical order).} \item{k}{For \code{graph.polyMk}, the number of monomorphic states for the discrete trait.} \item{ngen}{number of generations of MCMC for \code{mcmcMk}.} \item{ncat}{number of rate categories (per level of the discrete trait) in the hidden-rate model.} \item{ncores}{number of cores for \code{fitMk.parallel}.} \item{nrates}{number of rate categories for discretized \eqn{\Gamma} distribution.} \item{...}{optional arguments, including \code{pi}, the prior distribution at the root node (defaults to \code{pi="equal"}). Other options for \code{pi} include \code{pi="fitzjohn"} (which implements the prior distribution of FitzJohn et al. 2009), \code{pi="estimated"} (which finds the stationary distribution of state frequencies and sets that as the prior), or an arbitrary prior distribution specified by the user. For \code{plot} method optional arguments include (but may not be limited to): \code{signif}, the number of digits for the rates to be plotted; \code{main}, a character vector of length two with the headings for each subplot; \code{cex.main}, \code{cex.traits}, and \code{cex.rates}, font sizes for the various text elements of the plot; and \code{show.zeros}, a logical argument specifying whether or not to plot arrows with the ML estimated transition rate is not different from zero (with tolerance specified by the optional argument \code{tol}). Finally, for \code{fitpolyMk}, both \code{order} (an evolutionary sequence for the monomorphic condition) and \code{max.poly} can be set for the \code{ordered=TRUE} model. If not set, \code{order} defaults to alphanumeric order, and \code{max.poly} defaults to the highest level of polymorphism observed in the data.} } \description{ The functions \code{fitMk}, \code{fitmultiMk}, \code{fitpolyMk}, \code{fitHRM}, \code{fitMk.parallel}, \code{fitgammaMk}, and \code{mcmcMk} fit various flavors of the extended M\emph{k} model (Lewis, 2001) for discrete character evolution on a reconstructed phylogeny. } \details{ The function \code{fitMk} fits a so-called extended M\emph{k} model for discrete character evolution (Lewis, 2001). \code{plot.fitMk} plots an object of class \code{"fitMk"} returned by \code{fitMk}. \code{plot.gfit} plots an object of class \code{"gfit"} from \pkg{geiger}'s \code{fitDiscrete} function. Both plots portray the fitted model using a graph of arrows connecting states. The function \code{fitmultiMk} fits an M\emph{k} model in which the transition rates between character states are allowed to vary depending on the mapped state of a discrete character on the tree. It can be combined with, for example, \code{\link{paintSubTree}} to test hypotheses about how the process of discrete character evolution for \code{x} varies between different parts of the tree. The function \code{fitgammaMk} fits an M\emph{k} model in which the edge rates are assumed to have been sampled randomly from a \eqn{\Gamma} distribution with mean of 1.0 and shape parameter \eqn{\alpha}. The function \code{fitpolyMk} fits an M\emph{k} model to data for a discrete character with intraspecific polymorphism. Polymorphic species should be coded with the name of the two or more states recorded for the species separated by a plus sign \code{+} (e.g., \code{A+B} would indicate that both states \code{A} and \code{B} are found in the corresponding taxon). Invariably it's assumed that transitions between states must occur through a polymorphic condition, whereas transitions \emph{cannot} occur directly between two incompatible polymorphic conditions. For instance, a transition between \code{A+B} and \code{B+C} would have to occur through the monomorphic state \code{B}. At time of writing, this function permits the models \code{"ER"} (equal rates for all permitted transitions), \code{"SYM"} (symmetric backward & forward rates for all permitted transitions), \code{"ARD"} (all-rates-different for permitted transitions), and a new model called \code{"transient"} in which the acquisition of polymorphism (e.g., \code{A -> A+B}) is assumed to occur at a different rate than its loss (e.g., \code{A+B -> B}). The method \code{plot.fitpolyMk} plots the fitted M\emph{k} model with intraspecific polymorphism. The function \code{mcmcMk} runs a Bayesian MCMC version of \code{fitMk}. The shape of the prior distribution of the transition rates is \eqn{\Gamma}, with \eqn{\alpha} and \eqn{\beta} via the argument \code{prior}, which takes the form of a list. The default value of \eqn{\alpha} is 0.1, and \eqn{\beta} defaults to a value such that \eqn{\alpha/\beta} is equal to the parsimony score for \code{x} divided by the sum of the edge lengths of the tree. The shape of the proposal distribution is normal, with mean zero and a variance that can be controlled by the user via the optional argument \code{prior.var}. The argument \code{auto.tune}, if \code{TRUE} or \code{FALSE}, indicates whether or not to 'tune' the proposal variance up or down to target a particular acceptance rate (defaults to 0.5). \code{auto.tune} can also be a numeric value between 0 and 1, in which case this value will be the target acceptance ratio. The argument \code{plot} indicates whether the progress of the MCMC should be plotted (defaults to \code{TRUE}, but runs much faster when set to \code{FALSE}). The method \code{plot.mcmcMk} plots a log-likelihood trace and a trace of the rate parameters from the MCMC. (This the same graph that is created by setting \code{plot=TRUE} in \code{mcmcMk}.) The method \code{density.mcmcMk} computes a posterior density on the transition rates in the model from the posterior sample obtained in the MCMC, will import the package \pkg{coda} if it is available, and returns an object of class \code{"density.mcmcMk"}. Finally, the method \code{plot.density.mcmcMk} creates a plot of the posterior density (or a set of plots) for the transition rates between states. Finally, the function \code{fitHRM} fits a hidden-rate M\emph{k} model following Beaulieu et al. (2013). For the hidden-rate model we need to specify a number of rate categories for each level of the trait - and this can be a vector of different values for each trait. We can also choose a model (\code{"ER"}, \code{"SYM"}, or \code{"ARD"}), as well as whether or not to treat the character as a 'threshold' trait (\code{umbral=TRUE}, defaults to \code{FALSE}). This latter model is basically one that allows absorbing conditions for some hidden states. Since this can be a difficult optimization problem, the optional argument \code{niter} sets the number of optimization iterations to be run. \code{niter} defaults to \code{niter=10}. Note that (by default) both \code{fitMk} and \code{fitmultiMk} recycle code from \code{\link{ace}} in the \pkg{ape} package for computing the likelihood. (If the optional argument \code{pruning=TRUE} then alternative, slightly faster, \pkg{phytools} code for the pruning algorithm is used.) \code{fitpolyMk}, \code{mcmcMk}, and \code{fitHRM} use \code{fitMk} internally to compute the likelihood. } \value{ An object of class \code{"fitMk"}, \code{"fitmultiMk"}, \code{"fitpolyMk"}, \code{"mcmcMk"}, \code{"fitHRM"}, or \code{"fitgammaMk"}. In the case of \code{density.mcmcMk} an object of class \code{"density.mcmcMk"}. \code{plot.fitMk}, \code{plot.gfit}, and \code{plot.HRM} invisibly return the coordinates of vertices of the plotted \bold{Q}-matrix. } \references{ Beaulieu, J. M., B. C. O'Meara, and M. J. Donoghue (2013) Identifying hidden rate changes in the evolution of a binary morphological character: The evolution of plant habit in campanulid angiosperms. \emph{Systematic Biology}, \bold{62}, 725-737. FitzJohn, R. G., W. P. Maddison, and S. P. Otto (2009) Estimating trait-dependent speciation and extinction rates from incompletely resolved phylogenies. \emph{Systematic Biology}, \bold{58}, 595-611. Lewis, P. O. (2001) A likelihood approach to estimating phylogeny from discrete morphological character data. \emph{Systematic Biology}, \bold{50}, 913-925. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. Revell, L. J. and L. J. Harmon (2022) \emph{Phylogenetic Comparative Methods in R}. Princeton University Press. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ace}}, \code{\link{make.simmap}} } \examples{ ## load tree and data from Revell & Collar (2009) data(sunfish.tree) data(sunfish.data) ## extract discrete character (feeding mode) fmode<-setNames(sunfish.data$feeding.mode, rownames(sunfish.data)) ## fit "ER" model fit.ER<-fitMk(sunfish.tree,fmode,model="ER") print(fit.ER) ## fit "ARD" model fit.ARD<-fitMk(sunfish.tree,fmode,model="ARD") print(fit.ARD) ## compare the models AIC(fit.ER,fit.ARD) ## load tree and data from Benitez-Alvarez et al. (2000) data(flatworm.data) data(flatworm.tree) ## extract discrete character (habitat) habitat<-setNames(flatworm.data$Habitat, rownames(flatworm.data)) ## fit polymorphic models "ER" and "transient" fitpoly.ER<-fitpolyMk(flatworm.tree,habitat, model="ER") fitpoly.transient<-fitpolyMk(flatworm.tree,habitat, model="transient") ## print fitted models print(fitpoly.ER) print(fitpoly.transient) ## compare model AIC(fitpoly.ER,fitpoly.transient) ## plot models par(mfrow=c(2,1)) plot(fitpoly.ER) mtext("a) ER polymorphic model",adj=0,line=1) plot(fitpoly.transient) mtext("b) Transient polymorphic model",adj=0, line=1) par(mfrow=c(1,1)) } \keyword{phylogenetics} \keyword{comparative method} \keyword{maximum likelihood} \keyword{bayesian} \keyword{discrete character} phytools/man/phylo.to.map.Rd0000644000176200001440000000764214546015314015541 0ustar liggesusers\name{phylo.to.map} \alias{phylo.to.map} \alias{plot.phylo.to.map} \title{Plot tree with tips linked to geographic coordinates} \usage{ phylo.to.map(tree, coords, rotate=TRUE, ...) \method{plot}{phylo.to.map}(x, type=c("phylogram","direct"), ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{coords}{a matrix containing the latitude (in column 1) and the longitude of all tip species in the tree. The row names should be the same as \code{tree$tip.label}; however, more than one set of coordinates per species can be supplied by duplicating some row names.} \item{rotate}{a logical value indicating whether or not to rotate nodes of the tree to better match longitudinal positions.} \item{x}{for \code{plot.phylo.to.map}, an object of class \code{"phylo.to.map"}.} \item{type}{a string indicating whether to map the tips of the tree onto a geographic map from a square phylogram (\code{type="phylogram"}) or to project the tree directly onto the map (\code{type="direct"}).} \item{...}{various optional arguments. For the function \code{phylo.to.map}, which first creates an object of the special class \code{"phylo.to.map"} and then (optionally) plots this object, arguments include: \code{database} and \code{regions} (see \code{\link{map}}), as well as any arguments that should be passed to \code{plot.phylo.to.map} internally. For \code{phylo.to.map}, optional arguments \code{xlim} and \code{ylim}, which control the plot area for the map; \code{fsize} for the font size of plot labels and \code{ftype} for the font type (following \code{\link{plotSimmap}}; \code{split} which controls the proportion of vertical (or horizontal) space for the tree (first) and map, in a vector; \code{psize} the size of the plotted points on the map - or \code{cex.points}, a vector contain the size of the tip points and geographic coordinate points, respectively; \code{from.tip} a logical value indicating whether to plot the linking lines from the tips (if \code{TRUE}) or from the end of the tip label, the default; \code{colors}, a single value or a vector of colors for the points and the linking lines; \code{pch} a single value or a vector of point types; \code{lwd} and \code{lty} for the linking lines; and \code{pts} a logical value indicating whether or not to plot points at the tips of the tree. \code{mar} and \code{asp} are as in \code{\link{par}}.} } \description{ Project a phylogeny on a geographic map. } \details{ \code{phylo.to.map} creates an object of class \code{"phylo.to.map"} and (optionally) plots that object. \code{plot.phylo.to.map} plots an object of class \code{"phylo.to.map"} in which the tips of the tree point to coordinates on a geographic map. } \value{ \code{phylo.to.map} creates an object of class \code{"phylo.to.map"} and (if \code{plot=TRUE}) plots a phylogeny projected onto a geographic map. \code{plot.phylo.to.map} plots on object of class \code{"phylo.to.map"}. } \references{ Revell, L. J. (2014) Graphical methods for visualizing comparative data on phylogenies. Chapter 4 in \emph{Modern phylogenetic comparative methods and their application in evolutionary biology: Concepts and practice} (L. Z. Garamszegi ed.), pp. 77-103. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \examples{ ## generally recommend using higher resolution map ## e.g., from mapdata package data(tortoise.tree) data(tortoise.geog) tortoise.phymap<-phylo.to.map(tortoise.tree, tortoise.geog,plot=FALSE,direction="rightwards", regions="Ecuador") plot(tortoise.phymap,direction="rightwards",pts=FALSE, xlim=c(-92.25,-89.25),ylim=c(-1.8,0.75),ftype="i", fsize=0.8,lty="dashed",map.bg="lightgreen", colors="slategrey") ## reset margins par(mar=c(5.1,4.1,4.1,2.1)) } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{plotting} \keyword{biogeography} phytools/man/getDescendants.Rd0000644000176200001440000000235314546013306016135 0ustar liggesusers\name{getDescendants} \alias{getDescendants} \alias{getParent} \title{Get descendant node numbers} \usage{ getDescendants(tree, node, curr=NULL) getParent(tree, node) } \arguments{ \item{tree}{a phylogenetic tree as an object of class \code{"phylo"}.} \item{node}{an integer specifying a node number in the tree.} \item{curr}{the set of previously stored node numbers - used in recursive function calls.} } \description{ Returns the descendants or parent of a specified node. } \details{ \code{getDescendants} returns the set of node & tip numbers descended from \code{node}. \code{getParent} returns the \emph{single} parent node of a specified node number (or \code{NULL} if \code{node} is already the root). } \value{ The set of node and tip numbers for the nodes and tips descended from \code{node} in a vector, or for \code{getParent} the single node preceding \code{node} in the tree. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{Descendants}}, \code{\link{paintSubTree}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/map.overlap.Rd0000644000176200001440000000410214546013603015420 0ustar liggesusers\name{map.overlap} \alias{map.overlap} \alias{Map.Overlap} \title{Proportional overlap between two mapped character histories on a tree} \usage{ map.overlap(tree1, tree2, tol=1e-6, ...) Map.Overlap(tree1, tree2, tol=1e-06, standardize=TRUE, ...) } \arguments{ \item{tree1}{an object of class \code{"simmap"}.} \item{tree2}{an object of class \code{"simmap"}.} \item{tol}{an optional tolerance value.} \item{standardize}{for \code{Map.Overlap}, a logical value indicating whether or not to standardize overlap by dividing by the summed branch length of the tree.} \item{...}{optional arguments, such as \code{check.equal}, a logical value indicating whether or not to check if \code{tree1} and \code{tree2} match in underlying topology and branch lengths (they should). This value is \code{TRUE} by default, but can be set to \code{FALSE} if \code{tree1} and \code{tree2} are known to be equal to speed up calculation.} } \description{ Calculates the similarity of two different stochastically mapped character histories. } \details{ \code{map.overlap} computes a single quantity giving the overall similarity of the maps, consequently this measure only makes sense of some or all of the states are shared between the two mapped tress. In \code{Map.Overlap} what is computed instead is a matrix in which the rows correspond to the states observed in \code{tree1} and the columns give the states for \code{tree2}, with the numerical values of the matrix showing the total overlap between each pair of mapped states on the two trees. } \value{ A numerical value on the interval (0, 1), for \code{map.overlap}; or a matrix whose elements should sum to 1.0 (\code{Map.Overlap}). } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{make.simmap}}, \code{\link{read.simmap}} } \keyword{ancestral states} \keyword{phylogenetics} \keyword{comparative method} \keyword{discrete character} phytools/man/posthoc.Rd0000644000176200001440000000132014546016642014660 0ustar liggesusers\name{posthoc} \alias{posthoc} \title{Generic post-hoc test} \usage{ posthoc(x, ...) } \arguments{ \item{x}{an object on which to conduct a post-hoc test.} \item{...}{optional arguments to be passed to method.} } \description{ Conducts posthoc test. } \details{ So far is only implemented for object class \code{"ratebytree"}. } \value{ An object of the appropriate class containing the results of a posthoc test. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ratebytree}} } \keyword{statistics} phytools/man/make.simmap.Rd0000644000176200001440000002227614546017303015413 0ustar liggesusers\name{make.simmap} \alias{make.simmap} \alias{simmap} \title{Simulate stochastic character maps on a phylogenetic tree or trees} \usage{ make.simmap(tree, x, model="SYM", nsim=1, ...) simmap(object, ...) } \arguments{ \item{tree}{a phylogenetic tree as an object of class \code{"phylo"}, or a list of trees as an object of class \code{"multiPhylo"}.} \item{x}{a vector containing the tip states for a discretely valued character, or a matrix containing the prior probabilities of tip states in rows and character states as column names. The names (if \code{x} is a vector) or row names (if \code{x} is a matrix) should match the tip labels of the tree. The vector can be of class \code{"factor"}, \code{"character"}, or \code{"numeric"} (although in the lattermost case its content should obviously be only integer values).} \item{model}{a character string containing the model or a transition model specified in the form of a matrix. See \code{\link{ace}} for more details.} \item{nsim}{number of simulations. If \code{tree} is an object of class \code{"multiPhylo"}, then \code{nsim} simulations will be conducted \emph{per} input tree.} \item{...}{optional arguments. So far, \code{pi} gives the prior distribution on the root node of the tree. Acceptable values for \code{pi} are \code{"equal"}, \code{"estimated"}, or a vector with the frequencies. If \code{pi="estimated"} then the stationary distribution is estimated by numerically solving \code{pi*Q=0} for \code{pi}, and this is used as a prior on the root. If \code{pi="fitzjohn"}, then the Fitzjohn et al. (2009) root prior is used. Finally, if \code{pi} is a numeric vector then the root state will be sampled from this vector. The function defaults to \code{pi="equal"} which results in the root node being sampled from the conditional scaled likelihood distribution at the root. \code{message} tells whether or not to print a message containing the rate matrix, \emph{Q} and state frequencies. \code{message} defaults to \code{TRUE}. For optional argument \code{Q="mcmc"} (see below) the mean value of \code{Q} from the posterior sample is printed. \code{tol} gives the tolerance for zero elements in \code{Q}. (Elements less then \code{tol} will be reset to \code{tol}). Optional argument \code{Q} can be a string (\code{"empirical"} or \code{"mcmc"}), or a fixed value of the transition matrix, \emph{Q}. If \code{"empirical"} than a single value of \emph{Q}, the most likely value, is used for all simulations. If \code{"mcmc"}, then \code{nsim} values of \emph{Q} are first obtained from the posterior distribution for \emph{Q} using Bayesian MCMC, then a simulated stochastic character map is generated for each sampled value of \emph{Q}. Optional argument \code{vQ} can consist of a single numeric value or a vector containing the variances of the (normal) proposal distributions for the MCMC. The order of \code{vQ} is assumed to be in the order of the \code{index.matrix} in \code{\link{ace}} for the chosen model. \code{prior} is a list containing \code{alpha} and \code{beta} parameters for the \eqn{\Gamma} prior distribution on the transition rates in \emph{Q}. Note that \code{alpha} and \code{beta} can be single values or vectors, if different priors are desired for each value in the transition matrix \emph{Q}. As for \code{vQ}, the order of \code{prior} is assumed to correspond with the order of \code{index.matrix} as in \code{\link{ace}}. \code{prior} can also be given the optional logical value \code{use.empirical} which tells the function whether or not to give the prior distribution the empirical mean for \emph{Q}. If \code{TRUE} then only \code{prior$beta} is used and \code{prior$alpha} is set equal to \code{prior$beta} times the empirical mean of \emph{Q}. \code{burnin} and \code{samplefreq} are burn-in and sample frequency for the MCMC, respectively.} \item{object}{for generic \code{simmap} method, object of various classes: for instance, an object of class \code{"fitMk"} from \code{\link{fitMk}}.} } \description{ Performs stochastic character mapping (Huelsenbeck et al., 2003) using several different alternative methods. } \details{ For \code{Q="empirical"}, \code{make.simmap} first fits a continuous-time reversible Markov model for the evolution of \code{x} and then simulates stochastic character histories using that model and the tip states on the tree. This is the same procedure that is described in Bollback (2006), except that simulation is performed using a fixed value of the transition matrix, \emph{Q}, instead of by sampling \emph{Q} from its posterior distribution. For \code{Q="mcmc"}, \code{make.simmap} first samples \emph{Q} \code{nsim} times from the posterior probability distribution of \emph{Q} using MCMC, then it simulates \code{nsim} stochastic maps conditioned on each sampled value of \emph{Q}. For \code{Q} set to a matrix, \code{make.simmap} samples stochastic mappings conditioned on the fixed input matrix. \code{make.simmap} uses code that has been adapted from \pkg{ape}'s function \code{\link{ace}} (by Paradis et al.) to perform Felsenstein's pruning algorithm to compute the likelihood. As of \pkg{phytools} >= 0.2-33 \code{x} can be a vector of states or a matrix containing the prior probabilities of tip states in rows. In this case the column names of \code{x} should contain the states, and the row names should contain the tip names. Note that there was a small (but potentially significant) bug in how node states were simulated by \code{make.simmap} in versions of \pkg{phytools} <= 0.2-26. Between \pkg{phytools} 0.2-26 and 0.2-36 there was also a bug for asymmetric models of character change (e.g., \code{model="ARD"}). Finally, between \pkg{phytools} 0.2-33 and \pkg{phytools} 0.2-47 there was an error in use of the conditional likelihoods for the root node, which caused the root node of the tree to be sampled incorrectly. Giorgio Bianchini pointed out that in \pkg{phytools} 1.0-1 (and probably prior recent versions) there was an error sampling the state at the root node of the tree based on the input prior (\code{pi}) supplied by a user -- except for \code{pi="equal"} (a flat prior, the default) or for a prior distribution in which one or another state was known to be the global root state (e.g., \code{pi=c(1,0)}, \code{pi=c(0,1)}, etc.). All of these issues should be fixed in the current and all later versions. If \code{tree} is an object of class \code{"multiPhylo"} then \code{nsim} stochastic maps are generated for each input tree. } \value{ A object of class \code{"simmap"} or \code{"multiSimmap"} which consists of an object of class \code{"phylo"} (or a list of such objects with class \code{"multiPhylo"}), with the following additional elements: \item{maps}{a list of named vectors containing the times spent in each state on each branch, in the order in which they occur.} \item{mapped.edge}{a matrix containing the total time spent in each state along each edge of the tree.} \item{Q}{the assumed or sampled value of \code{Q}.} \item{logL}{the log-likelihood of the assumed or sampled \code{Q}.} } \references{ Bollback, J. P. (2006) Stochastic character mapping of discrete traits on phylogenies. \emph{BMC Bioinformatics}, \bold{7}, 88. FitzJohn, R. G., W. P. Maddison, and S. P. Otto (2009) Estimating trait-dependent speciation and extinction rates from incompletely resolved phylogenies. \emph{Systematic Biology}, \bold{58}, 595-611. Huelsenbeck, J. P., R. Neilsen, and J. P. Bollback (2003) Stochastic mapping of morphological characters. \emph{Systematic Biology}, \bold{52}, 131-138. Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. Revell, L. J. and L. J. Harmon (2022) \emph{Phylogenetic Comparative Methods in R}. Princeton University Press. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{brownie.lite}}, \code{\link{brownieREML}}, \code{\link{countSimmap}}, \code{\link{describe.simmap}}, \code{\link{evol.vcv}}, \code{\link{plotSimmap}}, \code{\link{read.simmap}}, \code{\link{write.simmap}} } \examples{ \dontrun{ ## load tree and data from Revell & Collar (2009) data(sunfish.tree) data(sunfish.data) ## extract discrete character (feeding mode) fmode<-setNames(sunfish.data$feeding.mode, rownames(sunfish.data)) ## fit model er_model<-fitMk(sunfish.tree,fmode,model="ER", pi="fitzjohn") ## do stochastic mapping sunfish_smap<-simmap(er_model) ## print a summary of the stochastic mapping summary(sunfish_smap) ## plot a posterior probabilities of ancestral states cols<-setNames(c("blue","red"),levels(fmode)) plot(summary(sunfish_smap),colors=cols,ftype="i") legend("topleft",c("non-piscivorous","piscivorous"), pch=21,pt.bg=cols,pt.cex=2) par(mar=c(5.1,4.1,4.1,2.1),las=1) ## plot posterior density on the number of changes plot(density(sunfish_smap),bty="l") title(main="Posterior distribution of changes of each type", font.main=3)} } \keyword{ancestral states} \keyword{phylogenetics} \keyword{comparative method} \keyword{simulation} \keyword{bayesian} \keyword{discrete character} phytools/man/get.treepos.Rd0000644000176200001440000000213414546013266015443 0ustar liggesusers\name{get.treepos} \alias{get.treepos} \alias{getnode} \title{Get position or node of a plotted tree interactively} \usage{ get.treepos(message=TRUE, ...) getnode(...) } \arguments{ \item{message}{for \code{get.treepos}, a logical value indicating whether or not to print an instructional message.} \item{...}{optional arguments.} } \description{ Return the phylogenetic position of a mouse click on a plotted tree. } \details{ Both \code{get.treepos} and \code{getnode} are primarily meant for internal use in other \pkg{phytools} functions. \code{get.treepos} returns the index of the node at the end of the selected edge, along with the branch distance to that node. \code{getnode} simply returns the closest node to the user mouse click. } \value{ A list for \code{get.treepos} and a node number for \code{getnode}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{utilities} \keyword{plotting} phytools/man/fitPagel.Rd0000644000176200001440000000774714546013201014743 0ustar liggesusers\name{fitPagel} \alias{fitPagel} \alias{plot.fitPagel} \title{Function to test for correlated evolution of binary traits} \usage{ fitPagel(tree, x, y, method="fitMk", model="ARD", dep.var="xy", ...) \method{plot}{fitPagel}(x, ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{x}{a vector of phenotypic values for a binary trait for the species in \code{tree}; or a matrix in which the rows of \code{x} give the probability of being in each column state. (The latter option is only supported for \code{method="fitMk"}.) For S3 \code{plot} method, an object of class \code{"fitPagel"}.} \item{y}{a second binary character for the species in \code{tree}; or a matrix in which the rows give the probability of being in each column state.} \item{method}{function to use for optimization (defaults to \code{method="fitMk"}). Other options are \code{"ace"} to use the \code{\link{ace}} function in \pkg{ape} for optimization, or to \code{"fitDiscrete"} (if the \pkg{geiger} package is installed) to use \pkg{geiger}'s \code{fitDiscrete} for optimization.} \item{model}{model of evolution for the individual characters. Can be \code{model="ER"}, \code{"SYM"} (equivalent to \code{"ER"} in this case), and \code{"ARD"}.} \item{dep.var}{dependent variable. If \code{dep.var="xy"} than the rate of substitution in \code{x} depends on \code{y} & vice versa. If \code{dep.var="x"} than the substitution rate in \code{x} depends on \code{y}, but not the converse. Finally, if \code{dep.var="y"} than the rate of substitution in \code{y} depends on \code{x}, but not the converse.} \item{...}{optional arguments to be passed to \code{\link{fitMk}}, \code{\link{ace}}, or \code{fitDiscrete}. For \code{plot} method optional arguments include (but may not be limited to): \code{signif}, the number of digits for the rates to be plotted; \code{main}, a character vector of length two with the headings for each subplot; \code{cex.main}, \code{cex.sub}, \code{cex.traits}, and \code{cex.rates}, font sizes for the various text elements of the plot; and \code{lwd.by.rate}, a logical argument specifying whether or not to scale arrow line widths in proportion to the estimated rates.} } \description{ Fits Pagel's (1994) model for the correlated evolution of two binary characters. } \details{ \code{fitPagel} fits both an independent evolution model, as well as Pagel's (1994) binary dependent model, and compares them with a likelihood-ratio test. \code{plot.fitPagel} plots the fitted models using arrows. } \value{ An object of class \code{"fitPagel"} which contains the optimized matrices under an independence & a dependence model, log-likelihoods, a likelihood ratio, and a P-value for the independence model based on a chi-squared test. \code{plot.fitPagel} creates a plot showing the different fitted models with arrows. } \references{ Pagel, M. (1994) Detecting correlated evolution on phylogenies: A general method for the comparative analysis of discrete characters. \emph{Proceedings of the Royal Society B}, \bold{255}, 37-45. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ace}}, \code{\link{fitMk}}, \code{\link{make.simmap}} } \examples{ \dontrun{ ## load data data(bonyfish.tree) data(bonyfish.data) ## extract discrete characters spawning_mode<-setNames(bonyfish.data$spawning_mode, rownames(bonyfish.data)) paternal_care<-setNames(bonyfish.data$paternal_care, rownames(bonyfish.data)) ## fit correlational model bonyfish.pagel<-fitPagel(bonyfish.tree,paternal_care, spawning_mode) ## test for a difference between models anova(bonyfish.pagel) ## plot fitted models plot(bonyfish.pagel,lwd.by.rate=TRUE) ## reset par par(mar=c(5.1,4.1,4.1,2.1), mfrow=c(1,1))} } \keyword{phylogenetics} \keyword{comparative method} \keyword{discrete character} \keyword{maximum likelihood} phytools/man/pscore.Rd0000644000176200001440000000246714546016734014513 0ustar liggesusers\name{pscore} \alias{pscore} \title{Compute the parsimony score} \usage{ pscore(tree, x, ...) } \arguments{ \item{tree}{object of class \code{"phylo"}.} \item{x}{vector (e.g., factor vector), matrix, or data frame. Should contain names or row names.} \item{...}{optional arguments.} } \description{ Calculates the parsimony score using the Fitch algorithm. } \details{ Mostly for diagnostic purposes. Users interested in using Maximum Parsimony for phylogeny inference or ancestral state reconstruction should refer to the \pkg{phangorn} package. } \value{ A numerical value or vector of values. } \references{ Felsenstein, J. (2004) \emph{Inferring Phylogenies}. Sinauer. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{fitMk}}, \code{\link{sim.Mk}} } \examples{ ## load tree and data from Revell & Collar (2009) data(sunfish.tree) data(sunfish.data) ## extract discrete character (feeding mode) fmode<-setNames(sunfish.data$feeding.mode, rownames(sunfish.data)) ## compute the parsimony score pscore(sunfish.tree,fmode) } \keyword{phylogenetics} \keyword{comparative method} \keyword{maximum likelihood} phytools/man/ratebytree.Rd0000644000176200001440000001606214546017037015357 0ustar liggesusers\name{ratebytree} \alias{ratebytree} \alias{posthoc.ratebytree} \title{Likelihood test for rate variation among trees, clades, or traits} \usage{ ratebytree(trees, x, ...) \method{posthoc}{ratebytree}(x, ...) } \arguments{ \item{trees}{an object of class \code{"multiPhylo"}. If \code{x} consists of a list of different traits to be compared, then \code{trees} could also be a simple set of duplicates of the same tree, e.g., \code{rep(tree,length(x))}.} \item{x}{a list of trait vectors for a continuous trait in which the names of each vectors correspond to the tip labels of \code{trees}. This is not used if \code{type="diversification"}. In the case of \code{posthoc.ratebytree}, an object of class \code{"ratebytree"}.} \item{...}{optional arguments, including the argument \code{type} (\code{"continuous"}, \code{"discrete"}, or \code{"diversification"}), which, if not specified, the function will attempt to ascertain. See \code{Details} for more information.} } \description{ Multiple methods for comparing the rate or process of evolution between trees. } \details{ This function essentially implements three different methods for comparing the rate or process of evolution between trees: one for continuously-valued traits, a second for discrete characters, and a third for the rate of diversification (speciation & extinction). In all cases, the function takes an object of class \code{"multiPhylo"} containing two or more phylogenies (\code{trees}), and (for the first two analyses) a list of trait vectors (\code{x}). For continuous traits, the function then proceeds to fit two models: one in which the rate (or regime, for models \code{"OU"} and \code{"EB"}) of trait evolution is equal among all trees; and a second in which the rates or regimes can differ between trees. The latter model corresponds to an extension of the \emph{censored} approach of O'Meara et al. (2006; Revell et al. 2018) and should also be related to the method of Adams (2012) for comparing rates among traits. See \code{\link{brownie.lite}} for a different implementation of the \emph{noncensored} approach of O'Meara et al. (2006). For discrete traits, the function instead proceeds to fit two variants of the M\emph{k} model (Lewis 2001): one in which the parameters values (transition rates) of the process are free to vary between trees, and a second in which they are fixed to be the same. For diversification alone, the function fits two different diversification (speciation & extinction) models (Nee et al. 1994; Stadler 2012): one in which the birth (speciation) and death (extinction) rates are identical between the trees, and a second in which they are permitted to differ in various ways depending on the value of \code{"model"} (Revell 2018). The method \code{posthoc} conducts a post-hoc comparison of parameter estimates between trees in the multi-rate or multi-process model. The parameter that is compared depends on the fitted model. For instance, in \code{model="BM"} posthoc comparison is made of \code{sig2}; if \code{model="OU"} fitted values of \code{alpha} are compared; and so on. The argument \code{p.adjust.method} can be used to specify a method for adjusting P-values for multiple tests following \code{p.adjust} (defaults to \code{p.adjust.method="none"}. At present it is not possible to specify different models to fit for the different trees - although if (for instance) character evolution on tree 1 proceeded by a strong \emph{OU} process while character evolution on tree 2 was by \emph{BM}, we would probably reject a constant-process model and tree 2 should show a very low value of \code{alpha}. To compute the standard errors for each fitted parameter value, the function computes the negative inverse of the Hessian matrix at the MLEs; however, if this matrix is computationally singular the generalized inverse (\code{\link{ginv}}) will be used instead without warning. The function also conducts a likelihood-ratio test to compare the two models. For continuous character, optional arguments presently include the following: \code{model}, the model of continuous trait evolution (options are \code{"BM"}, the default, \code{"OU"}, and \code{"EB"}). \code{tol}, used as a minimum value for the fitting rates, to prevent problems in optimization. \code{trace}, a logical value indicating whether or not to report progress in the optimization. \code{test}, the method for hypothesis testing (options are \code{"chisq"} and \code{"simulation"}). \code{quiet}, a logical value indicating whether or not to run perfectly quietly. Finally, \code{se}, a list of vectors containing the standard errors for each value of \code{x}. For \code{type="discrete"} the optional arguments are slightly different. The argument \code{model} can be used, but it must assume the values \code{"ER"}, \code{"SYM"}, \code{"ARD"}, or a numeric matrix following \code{\link{ace}}. Finally, for \code{type= "diversification"} models are so far \code{"birth-death"}, \code{"equal-extinction"}, and \code{"equal-specation"}, and \code{"Yule"}. It is also important to consider supplying the sampling fractions, \code{rho}, which is a vector of values between 0 and 1 of the same length as \code{trees}. If not provided the method will assume a sampling fraction of 1.0 for all trees - which is seldom true of empirical studies. } \value{ An object of class \code{"ratebytree"} or an object of class \code{"posthoc.ratebytree"} in the case of the method \code{posthoc}. } \references{ Adams, D. C. (2012) Comparing evolutionary rates for different phenotypic traits on a phylogeny using likelihood. \emph{Syst. Biol.}, \bold{62}, 181-192. Lewis, P. O. (2001) A likelihood approach to estimating phylogeny from discrete morphological character data. \emph{Systematic Biology}, \bold{50}, 913-925. Nee, S., May, R. M. and Harvey, P. H. (1994) The reconstructed evolutionary process. \emph{Philosophical Transactions of the Royal Society of London B}, \bold{344}, 305-311. O'Meara, B. C., C. Ane, M. J. Sanderson, and P. C. Wainwright. (2006) Testing for different rates of continuous trait evolution using likelihood. \emph{Evolution}, \bold{60}, 922-933. Revell, L. J. (2018) Comparing the rates of speciation and extinction between phylogenetic trees. \emph{Ecology and Evolution}, \bold{8}, 5303-5312. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. Revell, L. J., Gonzalez-Valenzuela, L. E., Alfonso, A., Castellanos-Garcia, L. A., Guarnizo, C. E., and Crawford, A. J. (2018) Comparing evolutionary rates between trees, clades, & traits. \emph{Methods Ecol. Evol.}, \bold{9}, 994-1005. Stadler, T. (2012) How can we improve the accuracy of macroevolutionary rate estimates? \emph{Systematic Biology}, \bold{62}, 321-329. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{brownie.lite}}, \code{\link{fitMk}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{maximum likelihood} \keyword{continuous character} \keyword{discrete character} phytools/man/simBMphylo.Rd0000644000176200001440000000341614546017731015274 0ustar liggesusers\name{simBMphylo} \alias{simBMphylo} \alias{plot.simBMphylo} \title{Creates a graphical illustration of Brownian motion evolution on a phylogeny} \usage{ simBMphylo(n, t, sig2, plot=TRUE, ...) \method{plot}{simBMphylo}(x, ...) } \arguments{ \item{n}{number of taxa to simulate in the output tree.} \item{t}{total time for the simulation.} \item{sig2}{the rate of evolution under Brownian motion, \eqn{\sigma^2}, or a vector of rates. If the latter the length of the vector must exactly match \code{t}, otherwise the first element of \code{sig2} will just be duplicated \code{t} times.} \item{plot}{optional logical value indicating whether or not the simulated object should be plotted.} \item{...}{optional arguments to be passed to the \code{plot} method.} \item{x}{in \code{plot} method, object of class \code{"simBMphylo"}.} } \description{ Simulates a discrete time phylogeny and Brownian motion trait, and generates a plot. } \details{ The function simulates a discrete-time pure-birth phylogeny (for fixed \emph{N} and \emph{t} using rejection sampling) and then discrete-time Brownian motion on that tree. It then proceeds to generating a plot of the results. } \value{ An object of class \code{"simBMphylo"} or a plot. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{bmPlot}}, \code{\link{fastBM}}, \code{\link{pbtree}} } \examples{ set.seed(777) simBMphylo(n=6,t=100,sig2=0.01) ## reset par to defaults par(mfrow=c(1,1)) par(mar=c(5.1,4.1,4.1,2.1)) } \keyword{comparative method} \keyword{phylogenetics} \keyword{plotting} \keyword{continuous character} phytools/man/as.Qmatrix.Rd0000644000176200001440000000237014546011527015233 0ustar liggesusers\name{as.Qmatrix} \alias{as.Qmatrix} \alias{as.Qmatrix.fitMk} \alias{plot.Qmatrix} \alias{print.Qmatrix} \title{Convert a fitted M\emph{k} model to a Q-matrix} \usage{ as.Qmatrix(x, ...) \method{as.Qmatrix}{fitMk}(x, ...) \method{plot}{Qmatrix}(x, ...) \method{print}{Qmatrix}(x, ...) } \arguments{ \item{x}{fitted M\emph{k} model. (For instance, an object of class \code{"fitMk"}.) In the case of \code{print.Qmatrix}, an object of class \code{"Qmatrix"}.} \item{...}{optional arguments.} } \description{ Extracts a \bold{Q}-matrix from a fitted M\emph{k} model. } \details{ This function extracts a \bold{Q}-matrix (in the form of an object of class \code{"Qmatrix"}) from a fitted M\emph{k} model. } \value{ An object of class \code{"Qmatrix"}. \code{plot.Qmatrix} invisibly returns the coordinates of vertices of the plotted \bold{Q}-matrix. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{fitMk}} } \keyword{phylogenetics} \keyword{maximum likelihood} \keyword{comparative method} \keyword{discrete character} \keyword{utilities} phytools/man/drop.tip.multiSimmap.Rd0000644000176200001440000000243514546012460017242 0ustar liggesusers\name{drop.tip.multiSimmap} \alias{drop.tip.multiSimmap} \alias{keep.tip.multiSimmap} \title{Drop or keep tip or tips from an object of class \code{"multiSimmap"}} \usage{ \method{drop.tip}{multiSimmap}(phy, tip, ...) \method{keep.tip}{multiSimmap}(phy, tip, ...) } \arguments{ \item{phy}{an object of class \code{"multiSimmap"}.} \item{tip}{name or names of species to be dropped, in a vector.} \item{...}{optional arguments to be passed to \code{\link{drop.tip.simmap}}. Most optional arguments work, with the exception of \code{interactive=TRUE} which will return an error.} } \description{ This function drops or keeps one or multiple tips from all the trees of an object of class \code{"multiSimmap"}. } \details{ Equivalent to \code{\link{drop.tip}} and \code{\link{keep.tip}} in \pkg{ape}. This function merely wraps \code{\link{drop.tip.simmap}}. } \value{ An object of class \code{"multiSimmap"}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{drop.tip}}, \code{\link{drop.tip.multiPhylo}}, \code{\link{drop.tip.simmap}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/collapse.to.star.Rd0000644000176200001440000000161314546012021016364 0ustar liggesusers\name{collapse.to.star} \alias{collapse.to.star} \title{Collapse a subtree to a star phylogeny} \usage{ collapse.to.star(tree, node) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{node}{node for the clade to be collapsed.} } \description{ Collapses a subtree to a star. } \details{ If the tree has edge lengths, the function will keep the tips at the same height above the root as in the original tree. If \code{node} is the global root of the tree a star phylogeny will be created. } \value{ An object of class \code{"phylo"}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{splitTree}}, \code{\link{starTree}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/plotThresh.Rd0000644000176200001440000000415314546016523015342 0ustar liggesusers\name{plotThresh} \alias{plotThresh} \title{Tree plotting with posterior probabilities of ancestral states from the threshold model} \usage{ plotThresh(tree, x, mcmc, burnin=NULL, piecol, tipcol="input", legend=TRUE, ...) } \arguments{ \item{tree}{phylogenetic tree.} \item{x}{a named vector containing discrete character states; or a matrix containing the tip species, in rows, and probabilities of being in each state, in columns.} \item{mcmc}{list object returned by \code{\link{ancThresh}}.} \item{burnin}{number of generations (not samples) to exclude as burn in; if \code{NULL} then 20\% of generations are excluded as burn-in.} \item{piecol}{a named vector containing the colors for the posterior probabilities plotted as pie charts at internal nodes.} \item{tipcol}{a string indicating whether the tip colors should be based on the input data (\code{"input"}) or sampled tip liabilities (\code{"estimated"}). These will only differ if there is uncertainty in the tip states.} \item{legend}{logical value or text to be plotted in the legend.} \item{...}{other arguments to be passed to \code{\link{plot.phylo}} - \code{label.offset} should be >0 so that tip labels and species names do not overlap.} } \description{ Plots estimated posterior probabilities at nodes under the threshold model. } \details{ This function uses the object returned by \code{\link{ancThresh}} to plot the posterior probabilities of ancestral states under the threshold model. It is also called internally by \code{\link{ancThresh}}. } \value{ Plots a tree. } \references{ Revell, L. J. (2014) Ancestral character estimation under the threshold model from quantitative genetics. \emph{Evolution}, \bold{68}, 743-759. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ancThresh}}, \code{\link{plot.phylo}} } \keyword{ancestral states} \keyword{phylogenetics} \keyword{comparative method} \keyword{bayesian} \keyword{discrete character} phytools/man/drop.clade.Rd0000644000176200001440000000134314546012413015211 0ustar liggesusers\name{drop.clade} \alias{drop.clade} \title{Drop a clade from a tree} \usage{ drop.clade(tree, tip) } \arguments{ \item{tree}{object of class \code{"phylo"}.} \item{tip}{set of tips in a clade.} } \description{ Internal function for \code{\link{posterior.evolrate}}. } \details{ Function drops the clade containing the species in \code{tip}. Probably should not use unless you know what you're doing. } \value{ An object of class \code{"phylo"}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/modified.Grafen.Rd0000644000176200001440000000252514546013761016171 0ustar liggesusers\name{modified.Grafen} \alias{modified.Grafen} \alias{node.paths} \title{Computes modified Grafen edge lengths} \usage{ modified.Grafen(tree, power=2) node.paths(tree, node) } \arguments{ \item{tree}{object of class \code{"phylo"}.} \item{power}{power to raise the depths of each node (in nodes).} \item{node}{node number for \code{node.paths}.} } \description{ Computes modified Grafen (1989) edge lengths. } \details{ This function computes modified Grafen edge lengths in which the length of the edge is determined not by the number of descendant leaves, but instead by the maximum number of node lengths in the path from the node to any leaf. \code{node.paths} is used internally by \code{modified.Grafen} and computes the set of paths from a node to all tips descended from that node. } \value{ An object of class \code{"phylo"} with edge lengths. } \references{ Grafen, A. (1989) The phylogenetic regression. \emph{Philosophical Transactions of the Royal Society of London. Series B. Biological Sciences}, \bold{326}, 119-157. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{compute.brlen}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/force.ultrametric.Rd0000644000176200001440000000365014546013210016625 0ustar liggesusers\name{force.ultrametric} \alias{force.ultrametric} \title{Coerces a phylogenetic tree to be ultrametric} \usage{ force.ultrametric(tree, method=c("nnls","extend"), ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{method}{the method to use to force the tree to be ultrametric. Options are \code{"nnls"} (which uses the \pkg{phangorn} function \code{\link{nnls.tree}} internally), or \code{"extend"}.} \item{...}{optional arguments: principally, \code{message}. This argument (if set to \code{FALSE}) can be used to suppress the default warning message that \code{force.ultrametric} \emph{should not} be used as a formal statistical method to ultrametricize a tree.} } \description{ Coerces an object of class \code{"phylo"} to be ultrametric. } \details{ \code{force.ultrametric} coerces a non-ultrametric tree to be ultrametric. This is achieved either by using \code{\link{nnls.tree}} from the \pkg{phangorn} package to compute the set of edge lengths that result in a minimized sum-of-squares distance between the patristic distance of the output and input trees (\code{method="nnls"}); or by simply extending all the external edges of the tree to match the external edge with the greatest total height (\code{method="extend"}). Note that neither of these should be treated as formal statistical methods for inferring an ultrametric tree. Rather, this method can be deployed when a genuinely ultrametric tree read from file fails \code{\link{is.ultrametric}} for reasons of numerical precision. } \value{ An ultrametric tree in an object of class \code{"phylo"}. } \seealso{ \code{\link{is.ultrametric}}, \code{\link{nnls.tree}} } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{statistics} \keyword{utilities} phytools/man/plotTree.errorbars.Rd0000644000176200001440000000220314546016542016777 0ustar liggesusers\name{plotTree.errorbars} \alias{plotTree.errorbars} \title{Plot a tree with error bars around divergence dates} \usage{ plotTree.errorbars(tree, CI, ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{CI}{confidence intervals around internal nodes of the tree, measured in time since the present.} \item{...}{optional arguments to be passed to \code{\link{plotTree}}.} } \description{ Plots a tree with error bars around divergence times (nodes). } \details{ The matrix CI show contain (in rows) the lower & upper confidence bounds in time since the present. Optional arguments specific to the error bar plot include \code{gridlines}, \code{bar.lwd},\code{cex} (for the points plotted at nodes), and \code{bar.col}. } \value{ Plots a tree with error bars around internal nodes.. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ltt}}, \code{\link{plotTree}} } \keyword{phylogenetics} \keyword{plotting} phytools/man/paintSubTree.Rd0000644000176200001440000000406014546014135015605 0ustar liggesusers\name{paintSubTree} \alias{paintSubTree} \alias{paintBranches} \title{Paint sub-trees with a discrete character} \usage{ paintSubTree(tree, node, state, anc.state="1", stem=FALSE) paintBranches(tree, edge, state, anc.state="1") } \arguments{ \item{tree}{a phylogenetic tree as an object of class \code{"phylo"} or a modified object with mapped character traits.} \item{node}{an integer specifying the node number tipward of which the function should paint the derived state.} \item{edge}{an integer or vector of integers specifying the node or tip numbers of the edges that should be painted in \code{paintBranches}.} \item{state}{a string (or numeric value) specifying the state to paint on the tree tipward of \code{node}.} \item{anc.state}{the ancestral state to use; will only be applied if there are presently no character values mapped on the tree.} \item{stem}{logical or numeric value indicating whether to use the derived state on the stem leading to \code{node} (or not, if \code{stem=FALSE}), or, alternatively, what fraction of the stem should be assigned to the derived clade. Note that for tip clades \code{stem=FALSE} is not allowed.} } \description{ Paints regimes on a tree to create an object of class \code{"simmap"} with mapped regimes. } \details{ These functions map or "paint" arbitrary (i.e., user-specified) discrete character histories on the tree. \code{paintSubTree} paints the clade downstream of \code{node} with a particular state; whereas \code{paintBranches} paints only a specified branch. } \value{ An object of class \code{"simmap"} that contains the specified paintings as a mapped discrete character. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{plotSimmap}}, \code{\link{sim.history}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{utilities} phytools/man/writeAncestors.Rd0000644000176200001440000000324614546020435016221 0ustar liggesusers\name{writeAncestors} \alias{writeAncestors} \title{Write a tree to file with ancestral states and (optionally) CIs at nodes} \usage{ writeAncestors(tree, Anc=NULL, file="", digits=6, format=c("phylip","nexus"), ...) } \arguments{ \item{tree}{a phylogenetic tree or set of trees as an object of class \code{"phylo"} or \code{"multiPhylo"}.} \item{Anc}{a vector of ancestral states, a list containing the ancestral states and 95\% confidence intervals (as from \code{\link{fastAnc}} or \code{\link{ace}}, or a list of such results.} \item{file}{an optional string with the filename for output.} \item{digits}{an integer indicating the number of digits to print for branch lengths and ancestral character values.} \item{format}{a string indicating whether to output the result in simple Newick (i.e., \code{"phylip"}) or Nexus format.} \item{...}{additional arguments including \code{x}: a vector of character values, in which case ancestral states are estimated internally using \code{fastAnc}; and \code{CI}: a logical value indicating whether or not to estimate 95\% confidence intervals.} } \description{ This function writes a tree to file with ancestral character states and (optionally) 95\% confidence intervals stored as node value. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \value{ A file, string, or vector of strings. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ace}}, \code{\link{fastAnc}}, \code{\link{write.tree}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{input/output} phytools/man/midpoint.root.Rd0000644000176200001440000000366214546013660016016 0ustar liggesusers\name{midpoint_root} \alias{midpoint_root} \alias{midpoint.root} \title{Midpoint root a phylogeny} \usage{ midpoint_root(tree) \method{midpoint}{root}(tree, node.labels="support", ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{node.labels}{argument to be passed to \code{\link{midpoint}}.} \item{...}{optional arguments to be passed to \code{\link{midpoint}}.} } \description{ These functions midpoint root a rooted or unrooted tree (Farris 1972). } \details{ Midpoint rooting involves locating the midpoint of the longest path between any two tips and putting the root in that location. The function \code{midpoint_root} performs the same operation as \code{\link{midpoint}} in the \pkg{phangorn} package, but uses no \pkg{phangorn} (Schliep, 2011) code internally. The function \code{midpoint.root} is a pseudo S3 method for the object class \code{"root"} that exists because when \code{\link{midpoint}} was created in \pkg{phangorn} it was not defined as a generic method. This function merely points to \code{\link{midpoint}} and is being deprecated out. } \value{ An object of class \code{"phylo"} containing a rooted phylogenetic tree. } \references{ Farris, J. (1972) Estimating phylogenetic trees from distance matrices. \emph{American Naturalist}, \bold{106}, 645-667. Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. Schliep K. P. (2011) phangorn: phylogenetic analysis in R. \emph{Bioinformatics}, \bold{27}, 592-593. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{midpoint}}, \code{\link{reroot}}, \code{\link{root}} } \keyword{phylogenetics} \keyword{utilities} \keyword{phylogeny inference} phytools/man/minSplit.Rd0000644000176200001440000000303714546013751015005 0ustar liggesusers\name{minSplit} \alias{minSplit} \title{Finding the minimum (median) split in the posterior sample} \usage{ minSplit(tree, split.list, method="sum", printD=FALSE) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{split.list}{either a matrix with two named columns, \code{"node"} and \code{"bp"}; a \code{$mcmc} matrix from \code{evol.rate.mcmc()}; or the entire raw output from \code{evol.rate.mcmc()}.} \item{method}{an optional string indicating the criterion to minimize: options are \code{"sum"} and \code{"sumsq"}.} \item{printD}{logical specifying whether to print distances to screen (\code{FALSE} by default).} } \description{ This function takes a phylogenetic tree and a list of splits and identifies the split with the smallest summed or summed squared distances to all the other splits. } \value{ A list with the following elements: \item{node}{node for the minimum split.} \item{bp}{location on the branch leading to \code{node} of the minimum split.} } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. Revell, L. J., D. L. Mahler, P. Peres-Neto, and B. D. Redelings (2012) A new method for identifying exceptional phenotypic diversification. \emph{Evolution}, \bold{66}, 135-146. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{evol.rate.mcmc}}, \code{\link{posterior.evolrate}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{bayesian} phytools/man/cladelabels.Rd0000644000176200001440000000476314546012002015434 0ustar liggesusers\name{cladelabels} \alias{cladelabels} \alias{arc.cladelabels} \title{Add labels to subtrees of a plotted phylogeny} \usage{ cladelabels(tree=NULL, text, node, offset=NULL, wing.length=NULL, cex=1, orientation="vertical") arc.cladelabels(tree=NULL, text, node=NULL, ln.offset=1.02, lab.offset=1.06, cex=1, orientation="curved", stretch=1, ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}. If not supplied, the function will obtain the last plotted phylogeny from the environmental variable \code{last_plot.phylo}.} \item{text}{desired clade label text.} \item{node}{node number for the most recent common ancestor of members of the clade. For \code{arc.cladelabels} this defaults to \code{NULL} which means that the node of the clade to be labeled should be specified interactively (that is, by clicking on the graphical device).} \item{offset}{offset (as a multiplier of character width) for the label. Defaults to \code{offset=1} if \code{tree} is supplied or \code{offset=8} otherwise.} \item{wing.length}{length of the wings to add to the top & bottom of the label bar (in character widths).} \item{cex}{character expansion factor.} \item{orientation}{orientation of the text. Can be \code{orientation = "vertical"} (the default) or \code{"horizontal"}.} \item{ln.offset}{line offset (as a function of total tree height) for \code{arc.cladelabels}.} \item{lab.offset}{label offset for \code{arc.cladelabels}.} \item{stretch}{argument for \code{arc.cladelabels} to be passed to \code{arctext}.} \item{...}{optional arguments for \code{arc.cladelabels}.} } \description{ This function adds clade labels to a plotted tree. } \details{ \code{cladelabels} presently works only for rightward facing plotted phylogenies - but no warning will be returned if your tree does not conform to this requirement! \code{arc.cladelabels} is designed to do a similar thing to \code{cladelabels}, but for plotted fan trees. This function checks to ensure that the most recently plotted tree was plotted with \code{type="fan"} style. } \references{ Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{nodelabels}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/splitTree.Rd0000644000176200001440000000167514546017775015201 0ustar liggesusers\name{splitTree} \alias{splitTree} \title{Split tree at a point} \usage{ splitTree(tree, split) } \arguments{ \item{tree}{phylogenetic tree.} \item{split}{split encoded as a list with two elements: \code{node}: the node number tipward of the split; and \code{bp}: the position along the branch to break the tree, measured from the rootward end of the edge.} } \description{ Internal function for \code{\link{posterior.evolrate}}. } \details{ This function splits the tree at a given point, and returns the two subtrees as an object of class \code{"multiPhylo"}. Probably do not use this unless you can figure out what you are doing. } \value{ Two trees in a list. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/minRotate.Rd0000644000176200001440000000354314546013674015156 0ustar liggesusers\name{minRotate} \alias{minRotate} \alias{tipRotate} \title{Rotates all nodes of the tree to minimize the difference in order with a vector} \usage{ minRotate(tree, x, ...) tipRotate(tree, x, ...) } \arguments{ \item{tree}{tree.} \item{x}{numeric vector.} \item{...}{optional arguments to be used by \code{tipRotate}. Presently optional arguments can be \code{fn}, function to be used to compute the distance between the order of the tip labels in \code{tree} and the numeric vector \code{x} (presently \code{fn=function(x) x^2} by default); \code{methods}, the method or methods of tree traversal (can be \code{"pre"}, \code{"post"}, or \code{c("pre","post")}, for pre-, post-, or both pre- and post-order tree traversal); \code{rotate.multi}, whether to rotate multifurcations in all possible ways using \code{rotate.multi} (defaults to \code{FALSE}); and \code{print}, a logical argument specifying whether to print the search progress or to behave quietly. Only the option \code{print} is available for \code{minRotate}.} } \description{ Rotates all the nodes of the tree to try and minimize the different between the order of the tips and the rank-order of a numeric vector \code{x} or (in the case of \code{tipRotate}) the actual integer vector, \code{x}. } \details{ Both \code{minRotate} and \code{tipRotate} are designed primarily to be used internally by other \pkg{phytools} functions and particularly by \code{\link{phylo.to.map}} (in the case of \code{minRotate}) and by \code{\link{cophylo}} (in the case of \code{tipRotate}). } \value{ A node-rotated object of class \code{"phylo"}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/pgls.Ives.Rd0000644000176200001440000001077014546014221015053 0ustar liggesusers\name{pgls.Ives} \alias{pgls.Ives} \alias{pgls.SEy} \title{Phylogenetic regression with intraspecific sampling error} \usage{ pgls.Ives(tree, X, y, Vx=NULL, Vy=NULL, Cxy=NULL, lower=c(1e-8,1e-8), fixed.b1=NULL) pgls.SEy(model, data, corClass=corBrownian, tree, se=NULL, method=c("REML","ML"), interval=c(0,1000), ...) } \arguments{ \item{tree}{a phylogeny as an object of class \code{"phylo"}.} \item{X}{a named vector containing a \emph{single} independent variable (multiple independent variables to be added in future). \code{X} can contain the species means, or a single long vector containing the sample of values for each species. In the latter case the \code{names(X)} will be repeating - all samples from the same species should have the same name.} \item{y}{vector the dependent variable. Can be species means or individual values, as for \code{X}.} \item{Vx}{sampling variances for \code{X}. If \code{NULL}, then the within-species variance is computed from the data assuming that individual samples, not species means, have been provided in \code{X}.} \item{Vy}{sampling variances for \code{y}. If \code{NULL}, then the within-species variance is computed from the data assuming that individual samples, not species means, have been provided in \code{y}.} \item{Cxy}{sampling covariances between \code{X} and \code{y}. This will also be computed from the data if \code{Cxy==NULL}. Note than in this case - but not for the calculation of \code{Vx} and \code{Vy}, the same number of observations and the same ordering must be provided for \code{X} and \code{y}. If this is not the case, then it is assumed that different individuals have been sampled for \code{X} and \code{y} and thus \code{Cxy} is assumed to be zero for all species.} \item{lower}{vector specifying the lower bounds for estimation for \eqn{\sigma_x^2} and \eqn{\sigma_y^2}, respectively. (Must be > 0.)} \item{fixed.b1}{fixed regression slope, \eqn{\beta}. Usually set to zero for null hypothesis testing.} \item{model}{model to fit. (For \code{pgls.SEy}.)} \item{data}{data frame. (For \code{pgls.SEy}.)} \item{corClass}{correlation structure. (For \code{pgls.SEy}.)} \item{se}{vector of standard errors in \emph{y}. (For \code{pgls.SEy}.)} \item{method}{optimization method. (For \code{pgls.SEy}.)} \item{interval}{interval over which to perform optimization. (For \code{pgls.SEy}.)} \item{...}{optional arguments. (For \code{pgls.SEy}.)} } \description{ Phylogenetic regression with within-species sampling error following Ives et al. (2007). } \details{ \code{pgls.Ives} fits the phylogenetic regression model with within-species sampling error following Ives et al. (2007). \code{pgls.SEy} fits a simpler model in which only sampling error in \code{y} is taken into account. This function uses \code{\link{gls}} from the \pkg{nlme} package internally for optimization and returns an object of class \code{"gls"} that is compatible with all methods for that object class. In the case of \code{pgls.Ives}, only the bivariate regression model is implemented. Note that some problems have been reported with the optimization algorithm for this model, which is simple and thus may fail to find the ML solution. In the case of \code{pgls.SEy} the user can (theoretically) specify any class of linear model permitted by \code{\link{gls}}. } \value{ In the case of \code{pgls.Ives}, an object of class \code{"pgls.Ives"} with the following elements: \item{beta}{a vector or matrix of regression coefficients.} \item{sig2x}{fitted BM rate for \code{X}.} \item{sig2y}{fitted BM rate for \code{y}.} \item{a}{fitted ancestral states for \code{X} and \code{y}.} \item{logL}{log-likelihood.} \item{convergence}{a value for convergence. \code{convergence=0} is good; see \code{\link{optim}} for more details.} \item{message}{a message for convergence.} In the case of \code{pgls.SEy}, an object of class \code{"gls"}. } \references{ Ives, A. R., P. E. Midford, and T. Garland Jr. (2007) Within-species measurement error in phylogenetic comparative methods. \emph{Systematic Biology}, \bold{56}, 252-270. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{brownie.lite}}, \code{\link{phylosig}}, \code{\link{phyl.resid}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{statistics} \keyword{least squares} \keyword{maximum likelihood} phytools/man/anoletree.Rd0000644000176200001440000003133014530651303015153 0ustar liggesusers\name{anoletree} \alias{anole.data} \alias{anoletree} \alias{ant.geog} \alias{ant.tree} \alias{bat.tree} \alias{bat_virus.data} \alias{betaCoV.tree} \alias{bonyfish.data} \alias{bonyfish.tree} \alias{butterfly.data} \alias{butterfly.tree} \alias{cordylid.data} \alias{cordylid.tree} \alias{darter.tree} \alias{eel.data} \alias{eel.tree} \alias{elapidae.tree} \alias{flatworm.data} \alias{flatworm.tree} \alias{liolaemid.data} \alias{liolaemid.tree} \alias{mammal.data} \alias{mammal.geog} \alias{mammal.tree} \alias{primate.data} \alias{primate.tree} \alias{salamanders} \alias{sunfish.data} \alias{sunfish.tree} \alias{tortoise.geog} \alias{tortoise.tree} \alias{tropidurid.data} \alias{tropidurid.tree} \alias{vertebrate.data} \alias{vertebrate.tree} \alias{wasp.data} \alias{wasp.trees} \alias{whale.tree} \title{Phylogenetic datasets} \description{ Various phylogenetic datasets for comparative analysis. } \details{ \code{anoletree} is a phylogeny of Greater Antillean anole species with a mapped discrete character - \emph{ecomorph class}. \code{anole.data} is a data frame of morphological characters. Data and tree are from Mahler et al. (2010). \code{ant.tree} is a phylogeny containing 84 species of fungus farming attine ants. \code{ant.geog} is a vector containing biogegraphic information for the species of the tree. Both the phylogeny and biogeographic information were originally published by Branstetter et al. (2017). \code{bat.tree} is a ML phylogeny of bats from the families Mormoopidae, Molossidae, and Phyllostomidae, based on GenBank accession numbers reported in Caraballo (2022) and estimated using \pkg{phangorn}. \code{betaCoV.tree} is a ML phylogenetic tree of betacoronaviruses based on GenBank accession numbers reported in Caraballo (2022) and estimated using \pkg{phangorn}. \code{bat_virus.data} is an association table of host and virus from Caraballo (2022). \code{butterfly.tree} and \code{butterfly.data} are a phylogeny and dataset of habitat use in Mycalesina butterflies from Halali et al. (2020). The phylogeny of that study was adapted from one originally published by Brattstrom et al. (2020). \code{bonyfish.tree} and \code{bonyfish.data} are a phylogeny and dataset of spawning mode and parental care in bony fishes from Benun Sutton and Wilson (2019). Their phylogenetic tree was adapted from a tree originally published by Betancur-R et al. (2017) \code{cordylid.tree} and \code{cordylid.data} are a phylogeny and dataset of morphological traits for three different principal components axes from Broeckhoven et al. (2016). \code{darter.tree} is a phylogeny of 201 species of darter fish (Etheostomatinae) from Near et al. (2011). \code{eel.tree} and \code{eel.data} are a phylogeny and dataset of feeding mode and maximum total length from 61 species of elopomorph eels from Collar et al. (2014). \code{elapidae.tree} is a reconstructed phylogeny containing 175 species of snakes of the family Elapidae from Lee et al. (2016). \code{flatworm.tree} and \code{flatworm.data} are a phylogeny and dataset of habitat preferences for flatworms from Benitez-Alvarez et al. (2020). \code{flatworm.tree} has been made ultrametric using penalized likelihood. \code{liolaemid.tree} and \code{liolaemid.data} are a phylogenetic tree and phenotypic trait dataset of lizards from the family Liolaemidae from Esquerre et al. (2019). \code{mammal.tree} and \code{mammal.data} are the phylogeny and dataset for mammal body size and home range size from Garland et al. (1992). \code{mammal.geog} is a matrix containing geographic coordinates for various of the species in \code{mammal.tree} pulled from citizen science observations registered on the \emph{iNaturalist} web platform. \code{primate.tree} and \code{primate.data} are a phylogeny and phenotypic trait dataset from Kirk and Kay (2004). \code{salamanders} is a phylogeny of \emph{Plethodon} salamanders from Highton and Larson (1979). According to Wikipedia, the genus \emph{Plethodon} contains 55 species in total. \code{sunfish.tree} and \code{sunfish.data} are the phylogeny and dataset for Centrarchidae and buccal morphology (respectively) from Revell and Collar (2009). \code{tortoise.tree} and \code{tortoise.geog} are a phylogeny and dataset of geographic coordinates for Galapagos tortoises. The geographic locality information was approximated from Figure 1 of Poulakakis et al. (2020), and the tree was estimated from nucleotide sequence data published with the same study. \code{tropidurid.tree} and \code{tropidurid.data} are the phylogeny and bivariate quantitative trait dataset of tropidurid lizards from Revell et al. (2022). \code{vertebrate.tree} is a time-calibrated phylogeny of vertebrates and \code{vertebrate.data} is a dataset of phenotypic traits. The phylogeny is from \url{http://www.timetree.org/} (Hedges et al. 2006). \code{wasp.trees} and \code{wasp.data} are the phylogeny and host-parasite associations from Lopez-Vaamonde et al. (2001). \code{whale.tree} is a phylogeny of cetaceans originally published in Steeman et al. (2009). } \usage{ data(anole.data) data(anoletree) data(ant.geog) data(ant.tree) data(bat.tree) data(bat_virus.data) data(betaCoV.tree) data(bonyfish.data) data(bonyfish.tree) data(butterfly.data) data(butterfly.tree) data(cordylid.data) data(cordylid.tree) data(darter.tree) data(eel.data) data(eel.tree) data(elapidae.tree) data(flatworm.data) data(flatworm.tree) data(liolaemid.tree) data(mammal.data) data(mammal.geog) data(mammal.tree) data(primate.data) data(primate.tree) data(salamanders) data(sunfish.data) data(sunfish.tree) data(tortoise.geog) data(tortoise.tree) data(tropidurid.data) data(tropidurid.tree) data(vertebrate.data) data(vertebrate.tree) data(wasp.data) data(wasp.trees) data(whale.tree) } \format{ \code{anoletree} is an object of class \code{"simmap"}. \code{anole.data} is a data frame. \code{ant.tree} is an object of class \code{"phylo"}. \code{ant.geog} is a vector. \code{bat.tree} and \code{betaCoV.tree} are objects of class \code{"phylo"}. \code{bat_virus.data} is a data frame. \code{bonyfish.tree} is an object of class \code{"phylo"}. \code{bonyfish.data} is a data frame. \code{butterfly.tree} is an object of class \code{"phylo"}. \code{butterfly.data} is a data frame. \code{cordylid.tree} is an object of class \code{"phylo"}. \code{cordylid.data} is a data frame. \code{darter.tree} is an object of class \code{"phylo"}. \code{eel.tree} is an object of class \code{"phylo"}. \code{eel.data} is a data frame. \code{elapidae.tree} is an object of class \code{"phylo"}. \code{flatworm.tree} is an object of class \code{"phylo"}. \code{flatworm.data} is a data frame. \code{liolaemid.tree} is an object of class \code{"phylo"}. \code{liolaemid.data} is a data frame. \code{mammal.tree} is an object of class \code{"phylo"}. \code{mammal.data} is a data frame. \code{mammal.geog} is a numerical matrix. \code{primate.tree} is an object of class \code{"phylo"}. \code{primate.data} is a data frame. \code{salamanders} is an object of class \code{"phylo"}. \code{sunfish.tree} is an object of class \code{"simmap"}. \code{sunfish.data} is a data frame. \code{tortoise.tree} is an object of class \code{"phylo"}. \code{tortoise.geog} is a data frame. \code{tropidurid.tree} is an object of class \code{"simmap"}. \code{tropidurid.data} is a data frame. \code{vertebrate.tree} is an object of class \code{"phylo"}. \code{vertebrate.data} is a data frame. \code{wasp.trees} is an object of class \code{"multiPhylo"}. \code{wasp.data} is a data frame. \code{whale.tree} is an object of class \code{"phylo"}. } \source{ Benitez-Alvarez, L., A. Maria Leal-Zanchet, A. Oceguera-Figueroa, R. Lopes Ferreira, D. de Medeiros Bento, J. Braccini, R. Sluys, and M. Riutort (2020) Phylogeny and biogeography of the Cavernicola (Platyhelminthes: Tricladida): Relicts of an epigean group sheltering in caves? \emph{Molecular Phylogenetics and Evolution}, \bold{145}, 106709. Benun Sutton, F., and A. B. Wilson (2019) Where are all the moms? External fertilization predicts the rise of male parental care in bony fishes. \emph{Evolution}, \bold{73}, 2451-2460. Betancur-R, R., E. O. Wiley, G. Arratia, A. Acero, N. Bailly, M. Miya, G. Lecointre, and G. Orti (2017) Phylogenetic classification of bony fishes. \emph{BMC Ecology and Evolution}, \bold{17}, 162. Branstetter, M. G., A. Jesovnik, J. Sosa-Calvo, M. W. Lloyd, B. C. Faircloth, S. G. Brady, and T. R. Schultz (2017) Dry habitats were crucibles of domestication in the evolution of agriculture in ants. \emph{Proceedings of the Royal Society B}, \bold{284}, 20170095. Brattstrom, O., K. Aduse-Poku, E. van Bergen, V. French, and P. M. Brakefield (2020) A release from developmental bias accelerates morphological diversification in butterfly eyespots. \emph{Proceedings of the National Academy of Sciences}, \bold{177}, 27474-27480. Broeckhoven, C., G. Diedericks, C. Hui, B. G. Makhubo, P. le Fras N. Mouton (2016) Enemy at the gates: Rapid defensive trait diversification in an adaptive radiation of lizards. \emph{Evolution}, \bold{70}, 2647-2656. Caraballo, D. A. (2022) Cross-species transmission of bat coronaviruses in the Americas: Contrasting patterns between alphacoronavirus and betacoronavirus. \emph{Microbiology Spectrum}, \bold{10}, e01411-22. Collar, D. C., P. C. Wainwright, M. E. Alfaro, L. J. Revell, and R. S. Mehta (2014) Biting disrupts integration to spur skull evolution in eels. \emph{Nature Communications}, \bold{5}, 5505. Esquerre, D., D. Ramirez-Alvarez, C. J. Pavon-Vazquez, J. Troncoso-Palacios, C. F. Garin, J. S. Keogh, and A. D. Leache (2019) Speciation across mountains: Phylogenomics, species delimitation and taxonomy of the \emph{Liolaemus leopardinus} clade (Squamata, Liolaemidae). \emph{Molecular Phylogenetics and Evolution}, \bold{139}, 106524. Garland, T., Jr., P. H. Harvey, and A. R. Ives (1992) Procedures for the analysis of comparative data using phylogenetically independent contrasts. \emph{Systematic Biology}, \bold{41}, 18-32. Kirk, E. C., and R. F. Kay (2004) The evolution of high visual acuity in the Anthropoidea. In: Ross, C. F., Kay R. F. (Eds), \emph{Anthropoid Origins. Developments in Primatology: Progress and Prospects}, 539-602. Springer, Boston, MA. Halali, S., E. van Bergen, C. J. Breuker, P. M. Brakefield, and O. Brattstrom (2020) Seasonal environments drive convergent evolution of a faster pace-of-life in tropical butterflies. \emph{Ecology Letters}, \bold{24}, 102-112. Hedges, S. B., J. Dudley, and S. Kumar (2006) TimeTree: A public knowledgebase of divergence times among organisms. \emph{Bioinformatics}, \bold{22}, 2971-2972. Highton, R., and A. Larson (1979) The genetic relationships of the salamanders of the genus \emph{Plethodon}. \emph{Systematic Zoology}, \bold{28}, 579-599. Lee, M. S. Y., K. L. Saunders, B. King, and A. Palci (2016) Diversification rates and phenotypic evolution in venomous snakes (Elapidae). \emph{Royal Society Open Science}, \bold{3}, 150277. Lopez-Vaamonde, C., J. Y. Rasplus, G. D. Weiblen, and J. M. Cook (2001) Molecular phylogenies of fig wasps: Partial cocladogenesis of pollinators and parasites. \emph{Molecular Phylogenetics and Evolution}, \bold{21}, 55-71. Mahler, D. L, L. J. Revell, R. E. Glor, and J. B. Losos (2010) Ecological opportunity and the rate of morphological evolution in the diversification of Greater Antillean anoles. \emph{Evolution}, \bold{64}, 2731-2745. Near, T. J., C. M. Bossu, G. S. Bradburd, R. L. Carlson, R. C. Harrington, P. R. Hollingsworth Jr., B. P. Keck, and D. A. Etnier. (2011) Phylogeny and temporal diversification of darters (Percidae: Etheostomatinae). \emph{Systematic Biology}, \bold{60}, 565-595. Poulakakis, N., J. M. Miller, E. L. Jensen, L. B. Beheregaray, M. A. Russello, S. Glaberman, J. Boore, and A. Caccone. (2020) Colonization history of Galapagos giant tortoises: Insights from mitogenomes support the progression rule. \emph{Journal of Zoological Systematics and Evolutionary Research}, \bold{58}, 1262-1275. Revell, L. J., and D. C. Collar (2009) Phylogenetic analysis of the evolutionary correlation using likelihood. \emph{Evolution}, \bold{63}, 1090-1100. Revell, L. J., K. S. Toyama, and D. L. Mahler (2022) A simple hierarchical model for heterogeneity in the evolutionary correlation a phylogenetic tree. \emph{PeerJ}, \bold{10}, e13910. Steeman, M. E., M. B. Hebsgaard, R. E. Fordyce, S. Y. W. Ho, D. L. Rabosky, R. Nielsen, C. Rahbek, H. Glenner, M. V. Sorensen, and E. Willerslev (2009) Radiation of extant cetaceans driven by restructuring of the oceans. \emph{Systematic Biology}, \bold{58}, 573-585. } \keyword{datasets} phytools/man/ave.rates.Rd0000644000176200001440000000203414546011556015073 0ustar liggesusers\name{ave.rates} \alias{ave.rates} \title{Average the posterior rates} \usage{ ave.rates(tree, shift, tips, sig1, sig2, ave.shift, showTree=TRUE) } \arguments{ \item{tree}{a tree.} \item{shift}{the shift point for this sample.} \item{tips}{tip names tipward of \code{shift}.} \item{sig1}{\eqn{\sigma_1^2}.} \item{sig2}{\eqn{\sigma_2^2}.} \item{ave.shift}{average shift from all samples.} \item{showTree}{logical value indicating whether to plot the rate-stretched tree.} } \description{ Internal function for \code{\link{posterior.evolrate}}. } \value{ A list of the rates. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{evol.rate.mcmc}}, \code{\link{minSplit}}, \code{\link{posterior.evolrate}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{bayesian} \keyword{continuous characters} \keyword{math} phytools/man/multiC.Rd0000644000176200001440000000224414546014020014430 0ustar liggesusers\name{multiC} \alias{multiC} \title{Returns a list with phylogenetic VCV matrix for each mapped state} \usage{ multiC(tree, internal=FALSE) } \arguments{ \item{tree}{an object of class \code{"simmap"} consisting of a phylogeny with a mapped discrete character.} \item{internal}{logical value indicating whether or not internal nodes should be returned.} } \description{ Computes phylogenetic covariance matrices from a \code{"simmap"} object. } \details{ This function takes a modified \code{"phylo"} object as input and returns a set of so-called phylogenetic covariance matrices (e.g., see \code{\link{vcv.phylo}}) as a list: one for each mapped state. Used internally by multiple \pkg{phytools} functions, such as \code{\link{brownie.lite}}. } \value{ A list of matrices. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{evolvcv.lite}}, \code{\link{read.simmap}}, \code{\link{vcvPhylo}}, \code{\link{vcv.phylo}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/add.species.to.genus.Rd0000644000176200001440000000560714546010730017130 0ustar liggesusers\name{add.species.to.genus} \alias{add.species.to.genus} \alias{genus.to.species.tree} \title{Add species to genus on a phylogeny or bind simulated species subtrees to a backbone genus tree} \usage{ add.species.to.genus(tree, species, genus=NULL, where=c("root","random")) genus.to.species.tree(tree, species) } \arguments{ \item{tree}{an object of class \code{"phylo"}. In the case of \code{genus.to.species.tree} this should be a genus-level backbone tree.} \item{species}{string contain species name in the format \code{"Genus_species"} or \code{"Genus species"}.} \item{genus}{for \code{add.species.to.genus}, optional argument containing the genus to which \code{species} is to be attached. If \code{NULL} then \code{genus} will be extracted from \code{species}.} \item{where}{for \code{add.species.to.genus}, the location to attach \code{species} to the tree. \code{where=} \code{"root"} will cause the species to be attached to the MRCA of all members of \code{genus}. \code{where="random"} will cause \code{species} to be attached at random to the subtree descended from the MRCA of all members of \code{genus}.} } \description{ \code{add.species.to.genus} adds an additional species to a genus on a phylogeny. \code{genus.to.species.tree} simulates pure-birth subtrees and then binds them at a random height along the terminal edge leading to each corresponding genus on a genus-level backbone tree. } \details{ For \code{add.species.to.genus}, if \code{genus} contains only one species and \code{where="root"}, then \code{species} will be attached midway along the branch leading to the one species. If \code{where="random"} then \code{species} will be added at a random position along the edge. If \code{genus} cannot be found in the tree, then the original tree is returned and a warning printed. If the tree is not ultrametric, then the resultant tree may not contain branch lengths and a warning will be printed. Note that for some cases in which a tree is read in from file, R may initially think it is ultrametric, but then later (as tips are added) decide that it is not due to rounding of the edge lengths when it was written to file. This can most likely be resolved by using \code{\link{force.ultrametric}} to coerce the tree to be exactly ultrametric (to the maximum numerical precision permitted by R) before adding tips to the tree. If \code{genus} is non-monophyletic then \code{species} will be attached to the most inclusive group containing members of \code{genus} and a warning will be printed. } \value{ An object of class \code{"phylo"}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{add.random}}, \code{\link{bind.tip}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/exhaustiveMP.Rd0000644000176200001440000000315214546012726015627 0ustar liggesusers\name{exhaustiveMP} \alias{exhaustiveMP} \title{Exhaustive and branch & bound MP optimization} \usage{ exhaustiveMP(data, tree=NULL, method="branch.and.bound") } \arguments{ \item{data}{is a \code{\link{phyDat}} (Schliep 2011) object containing DNA or other data.} \item{tree}{an optional input tree (used only with \code{method="branch.and.bound"}).} \item{method}{an optional string indicating which method to use: \code{"branch.and.bound"}, implementing a branch-and-bound search (obviously), or \code{"exhaustive"}.} } \description{ This function does exhaustive and branch & bound MP searches. } \details{ Should probably not be used for more than about 8 species (and definitely not more than 10 species). Performs parsimony calculations using \code{\link{parsimony}} in the \pkg{phangorn} package (Schliep, 2011). } \value{ A \code{"phylo"} or \code{"multiPhylo"} object that is the MP tree or set of MP trees. It also returns the parsimony scores in \code{attr(trees,"pscore")} or \code{attr(trees[[i]],"pscore")} for the \emph{i}th tree. } \references{ Felsenstein, J. (2004) \emph{Inferring Phylogenies}. Sinauer. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. Schliep, K. P. (2011) phangorn: phylogenetic analysis in R. \emph{Bioinformatics}, \bold{27}, 592-593. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{mrp.supertree}}, \code{\link{optim.parsimony}}, \code{\link{pratchet}} } \keyword{phylogenetics} \keyword{phylogeny inference} \keyword{parsimony} phytools/man/phyl.resid.Rd0000644000176200001440000000470014546016037015265 0ustar liggesusers\name{phyl.resid} \alias{phyl.resid} \title{Phylogenetic size-correction via GLS regression} \usage{ phyl.resid(tree, x, Y, method="BM") } \arguments{ \item{tree}{a phylogenetic tree in \code{"phylo"} format.} \item{x}{vector containing the single independent variable (e.g., size), or matrix with multiple independent variables in columns.} \item{Y}{vector or matrix with one or multiple dependent variables in columns.} \item{method}{method to obtain the correlation structure: can be \code{"BM"} or \code{"lambda"}.} } \description{ Computes the residuals from the phylogenetic regression of multiple \emph{y} variables (in a matrix) on a single \emph{x}. } \details{ This function fits one or multiple phylogenetic regressions (depending on the number of columns in \code{Y}) and computes the residuals. Designed for phylogenetic size correction using GLS regression (e.g., Revell 2009). Optionally fits \eqn{\lambda} for each regression model. Likelihood optimization of \eqn{\lambda} is performed for \code{method=} \code{"lambda"} using \code{\link{optimize}} on the interval (0,1). This function is theoretically redundant with \code{residuals} applied to a \code{"gls"} object class in which the correlation structure is based on \code{corBrownian} or \code{corPagel}; however some users may find this method simpler, and it provides a good way to cross-check your results & make sure that you are using \code{gls} correctly. } \value{ A list with the following elements: \item{beta}{a vector or matrix of regression coefficients.} \item{resid}{a vector or matrix of residuals for species.} \item{lambda}{a vector of \eqn{\lambda} values (\code{method="lambda"} only).} \item{logL}{a vector of log-likelihoods (\code{method="lambda"} only).} } \references{ Revell, L. J. (2009) Size-correction and principal components for interspecific comparative studies. \emph{Evolution}, \bold{63}, 3258-3268. Revell, L. J. (2010) Phylogenetic signal and linear regression on species data. \emph{Methods in Ecology and Evolution}, \bold{1}, 319-329. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{phyl.pca}}, \code{\link{gls}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{statistics} \keyword{least squares} \keyword{maximum likelihood} phytools/man/plot.backbonePhylo.Rd0000644000176200001440000000373514546016456016755 0ustar liggesusers\name{plot.backbonePhylo} \alias{plot.backbonePhylo} \title{Plots backbone tree with triangles as clades} \usage{ \method{plot}{backbonePhylo}(x, ...) } \arguments{ \item{x}{an object of class \code{"backbonePhylo"}.} \item{...}{optional arguments. Includes \code{vscale} (to rescale the vertical dimension in plotting), \code{fixed.height} (logical value to fix the plotted height of subtree triangles), \code{print.clade.size} (logical), \code{fixed.n1} (logical value indicating whether or not to use the fixed triangle height for subtrees containing only one taxon, or to plot as a leaf - defaults to \code{FALSE}), and \code{col} (a single value, or a vector with names, giving the clade colors), as well as \code{xlim}, \code{ylim}, and \code{lwd} (as well as perhaps other standard plotting arguments).} } \description{ Plots a backbone tree (stored as an object of class \code{"backbonePhylo"}) with triangles as subtrees. } \value{ Plots a tree. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{phylo.toBackbone}} } \examples{ ## first create our backbone tree with ## random subtree diversities tree<-phytools:::lambdaTree(pbtree(n=10),lambda=0.5) ## create a translation table ## leaving a couple of single-taxon clades for fun tip.label<-sample(tree$tip.label,8) clade.label<-LETTERS[1:8] N<-ceiling(runif(n=8,min=1,max=20)) ## set crown node depth to 1/2 the maximum depth depth<-sapply(tip.label,function(x,y) 0.5*y$edge.length[which(tree$edge[,2]== which(y$tip.label==x))],y=tree) trans<-data.frame(tip.label,clade.label,N,depth) rownames(trans)<-NULL ## here's what trans looks like print(trans) ## convert obj<-phylo.toBackbone(tree,trans) ## plot plot(obj) par(mar=c(5.1,4.1,4.1,2.1)) ## reset par } \keyword{phylogenetics} \keyword{plotting} phytools/man/nodeHeights.Rd0000644000176200001440000000355714546014101015444 0ustar liggesusers\name{nodeHeights} \alias{nodeHeights} \alias{nodeheight} \title{Compute the heights above the root of each node} \usage{ nodeHeights(tree, ...) nodeheight(tree, node, ...) } \arguments{ \item{tree}{a phylogeny as an object of class \code{"phylo"}.} \item{node}{for \code{nodeheight}, the node for which we want to compute a height above the root (or including the root edge, for \code{root.edge=TRUE}).} \item{...}{optional arguments - presently only \code{root.edge}, a logical value indicating whether or not to include the root edge length in the calculation of node heights.} } \description{ \code{nodeHeights} computes the height above the root for all nodes in the tree. \code{nodeheight} computes the height above the root for a single node. } \details{ The function \code{nodeHeights} also gives a handy way to get the total length of the tree from the root to the highest tip which will be given by \code{max(nodeHeights(tree))}. Generally speaking, \code{nodeHeights} will be faster if the heights of all or a large proportion of nodes is needed, whereas \code{nodeheight} will be faster if the height of one or a small number of nodes are needed. } \value{ Either a matrix of the same dimensions as \code{tree$edge} containing the height above the root of each node in \code{edge} (for \code{nodeHeights}); or a single positive number (for \code{nodeheight}). } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{vcvPhylo}} } \examples{ ## load tree data(vertebrate.tree) ## compute height of all nodes H<-nodeHeights(vertebrate.tree) print(H) ## compute total tree depth max(H) } \keyword{phylogenetics} \keyword{utilities} \keyword{comparative method} phytools/man/likMlambda.Rd0000644000176200001440000000207014546013453015236 0ustar liggesusers\name{likMlambda} \alias{likMlambda} \title{Likelihood for joint \eqn{\lambda}} \usage{ likMlambda(lambda, X, C) } \arguments{ \item{lambda}{scalar, usually on the interval 0,1 (although not required to be).} \item{X}{data for various continuous character, in the form of a matrix.} \item{C}{\emph{n} x \emph{n} matrix (for \emph{n} taxa) containing the height above the root for each pair of taxa in the tree (e.g., \code{\link{vcv.phylo}}).} } \description{ Likelihood function for joint estimation of Pagel's \eqn{\lambda} parameter. } \details{ Generally intended to be used internally by other methods that do joint optimization of \eqn{\lambda} (e.g., \code{\link{phyl.pca}}). } \value{ The log-likelihood. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{math} \keyword{comparative method} \keyword{utilities} \keyword{maximum likelihood} phytools/man/compare.chronograms.Rd0000644000176200001440000000176114546012037017153 0ustar liggesusers\name{compare.chronograms} \alias{compare.chronograms} \title{Compares two chronograms with precisely matching nodes in a visual manner} \usage{ compare.chronograms(t1, t2, ...) } \arguments{ \item{t1}{object of class \code{"phylo"}.} \item{t2}{object of class \code{"phylo"} that matches \code{t1} precisely in topology & node rotations, but differs in edge lengths.} \item{...}{optional arguments.} } \description{ Creates a visual comparison of two chronograms that differ in edge lengths but not topology. } \details{ This function plots two trees, with semi-transparent colors by default, & uses arrows to highlight differences in depth of corresponding nodes between the trees. } \value{ Function creates a plot. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{plotting} phytools/man/add.arrow.Rd0000644000176200001440000000470114546010626015064 0ustar liggesusers\name{add.arrow} \alias{add.arrow} \title{Add an arrow pointing to a tip or node on the tree} \usage{ add.arrow(tree=NULL, tip, ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}, \code{"contMap"}, or \code{"densityMap"}. If not supplied, the function will obtain the last plotted phylogeny from the environmental variable \code{last_plot.phylo}.} \item{tip}{label of tip or tip or node number; or vector of such values. If \code{tree=NULL} then the tip label(s) or node number(s) must be supplied.} \item{...}{optional arguments to control the shape and size of the arrow including: its length (\code{arrl}) in the units of the plot; the length of the arrowhead (\code{hedl}); the total angle between the wings in the arrowhead (\code{angle}); the line width for the plotted lines (\code{lwd}); the offset from the tip or end of tip label, in character widths (\code{offset}); and the color (\code{col}).} } \description{ Adds an arrow or a set of arrows to a plotted tree. } \details{ Trees can be plotted using \pkg{phytools} function \code{plotTree}, \code{plotSimmap}, \code{contMap}, \code{densityMap}, and \pkg{ape} S3 method \code{plot.phylo}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{nodelabels}} } \examples{ ## show arrows with a black outline data(anoletree) plotTree(anoletree,type="fan",fsize=0.7,ftype="i") add.arrow(anoletree,tip=c("cuvieri","krugi", "pulchellus","poncensis","stratulus", "evermanni","cooki","cristatellus", "gundlachi","occultus"),lwd=5,arrl=1) add.arrow(anoletree,tip="cuvieri",col="green", lwd=3,arrl=1) add.arrow(anoletree,tip=c("krugi","pulchellus", "poncensis"),col="#E4D96F",lwd=3,arrl=1) add.arrow(anoletree,tip=c("stratulus","evermanni"), col="darkgreen",lwd=3,arrl=1) add.arrow(anoletree,tip=c("cooki","cristatellus", "gundlachi"),col="brown",lwd=3,arrl=1) add.arrow(anoletree,tip="occultus",col="darkgrey", lwd=3,arrl=1) legend(x="topleft",c("crown-giant","grass-bush","trunk-crown","trunk-ground", "twig"),pch=22,pt.bg=c("green","#E4D96F","darkgreen", "brown","darkgrey"),cex=0.9, pt.cex=2,title="PR ecomorphs",bty="n") par(mar=c(5.1,4.1,4.1,2.1)) ## reset margins to default } \keyword{phylogenetics} \keyword{utilities} \keyword{plotting} phytools/man/rerootingMethod.Rd0000644000176200001440000000637714546017425016373 0ustar liggesusers\name{rerootingMethod} \alias{rerootingMethod} \title{Get marginal ancestral state reconstructions by re-rooting} \usage{ rerootingMethod(tree, x, model=c("ER","SYM"), ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{x}{a vector of tip values for species, or a matrix containing the prior probability that the tip is in each state. If \code{x} is a vector, then \code{names(x)} should be the species names. If \code{x} is a matrix of prior probabilities, then rownames should be species names, column names should be states for the discrete character, and rows of the matrix should sum to 1.0.} \item{model}{any reversible model. \code{model=c("ER","SYM")} recommended.} \item{...}{optional arguments. Presently the logical argument \code{tips}. If \code{tips=TRUE}, then the function will also compute the empirical Bayes posterior probabilities of the tips following Yang (2006). Note that \code{...} is passed internally to \code{fitMk}, but should be used in this way with caution because any arguments that conflict with the default arguments of the method will cause the function execution to fail. The most practical use of this would be to force a particular value of the transition matrix, \code{Q}, via the argument \code{fixedQ}.} } \description{ Computes marginal ancestral states for a discrete character using the re-rooting method of Yang et al. (1995). In general, this function is \bold{redundant} with \code{\link{ancr}} for circumstances in which it is valid (i.e., symmetric \bold{Q} matrices), and improper otherwise. In general \code{\link{ancr}} should be preferred. } \details{ This function uses the re-rooting method of Yang et al. (1995) to get the marginal ancestral state estimates for each internal node of the tree using likelihood. This method get the conditional scaled likelihoods for the root node (which is the same as the marginal ancestral state reconstruction for that node) and successively moves the root to each node in the tree. The function can also return the posterior probabilities for the tip nodes of the tree. \code{rerootingMethod} calls \code{\link{fitMk}} internally. \code{fitMk} uses some code adapted from \code{ace} in the \pkg{ape} package. } \value{ An object of class \code{"rerootingMethod"} containing at least the following elements: \item{loglik}{the log-likelihood.} \item{Q}{the fitted transition matrix between states.} \item{marginal.anc}{the marginal ancestral state reconstructions for each node (and, optionally, each tip).} } \references{ Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. Yang, Z., Kumar, S., Nei, M. (1995) A new method of inference of ancestral nucleotide and amino acid sequences. \emph{Genetics}, \bold{141}, 1641-1650. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ace}}, \code{\link{ancr}}, \code{\link{fitMk}}, \code{\link{make.simmap}} } \keyword{phylogenetics} \keyword{bayesian} \keyword{comparative method} \keyword{maximum likelihood} \keyword{ancestral states} phytools/man/drop.leaves.Rd0000644000176200001440000000141714546012710015422 0ustar liggesusers\name{drop.leaves} \alias{drop.leaves} \title{Drop all the leaves (tips) from a tree} \usage{ drop.leaves(tree, ...) } \arguments{ \item{tree}{object of class \code{"phylo"}.} \item{...}{optional arguments. Presently includes only the logical value \code{keep.tip.labels} which tells the function how to labels the tips on the reduced tree.} } \description{ Drops all the leaves from a tree, leaving behind only the structure leading to internal nodes. } \value{ An object of class \code{"phylo"}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/getCladesofSize.Rd0000644000176200001440000000146414546013274016263 0ustar liggesusers\name{getCladesofSize} \alias{getCladesofSize} \title{Get all subtrees larger than or equal to a specified size} \usage{ getCladesofSize(tree, clade.size=2) } \arguments{ \item{tree}{is an object of class \code{"phylo"}.} \item{clade.size}{subtree size.} } \description{ This function gets all subtrees that cannot be further subdivided into two reciprocally monophyletic subtrees of size \code{>= clade.size}. } \value{ An object of class \code{"multiPhylo"}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{extract.clade}}, \code{\link{getDescendants}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/gamma_pruning.Rd0000644000176200001440000000155614546007172016036 0ustar liggesusers\name{gamma_pruning} \alias{gamma_pruning} \title{Internally used function} \usage{ gamma_pruning(par, nrates=4, tree, x, model=NULL, median=TRUE, ...) } \arguments{ \item{par}{function parameters.} \item{nrates}{number of discrete rate categories.} \item{tree}{object of class \code{"phylo"}.} \item{x}{data in the form of a binary matrix.} \item{model}{design matrix of fitted model.} \item{median}{use the median of each rate category.} \item{...}{optional arguments.} } \description{ Internally used function to compute the likelihood under a \eqn{\Gamma} model. } \value{ A value of the log-likelihood. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{utilities} phytools/man/ladderize.simmap.Rd0000644000176200001440000000163114546013436016434 0ustar liggesusers\name{ladderize.simmap} \alias{ladderize.simmap} \title{Ladderize a tree with a mapped discrete character} \usage{ ladderize.simmap(tree, right=TRUE) } \arguments{ \item{tree}{an object of class \code{"simmap"}.} \item{right}{a logical specifying how the tree should be ladderized.} } \description{ Ladderizes an object of class \code{"simmap"}. } \details{ This function 'ladderizes' an object of class \code{"simmap"} with a mapped discrete character. For more information see \code{\link{ladderize}}. } \value{ A ladderized object of class \code{"simmap"}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{make.simmap}}, \code{\link{ladderize}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/plotSimmap.Rd0000644000176200001440000001363614546015702015337 0ustar liggesusers\name{plotSimmap} \alias{plotSimmap} \alias{plot.simmap} \alias{plot.multiSimmap} \title{Plot stochastic character mapped tree} \usage{ plotSimmap(tree, colors=NULL, fsize=1.0, ftype="reg", lwd=2, pts=FALSE, node.numbers=FALSE, mar=NULL, add=FALSE, offset=NULL, direction="rightwards", type="phylogram", setEnv=TRUE, part=if(type=="arc") 0.5 else 1.0, xlim=NULL, ylim=NULL, nodes="intermediate", tips=NULL, maxY=NULL, hold=TRUE, split.vertical=FALSE, lend=2, asp=NA, outline=FALSE, plot=TRUE, underscore=FALSE, arc_height=2) \method{plot}{simmap}(x, ...) \method{plot}{multiSimmap}(x, ...) } \arguments{ \item{tree}{an object of class \code{"simmap"} or \code{"multiSimmap"} containing a stochastic mapping or set of mappings (e.g., see \code{\link{read.simmap}} & \code{\link{make.simmap}}).} \item{colors}{a vector with names translating the mapped states to colors - see \code{Examples}.} \item{fsize}{relative font size for tip labels.} \item{ftype}{font type - options are \code{"reg"}, \code{"i"} (italics), \code{"b"} (bold), or \code{"bi"} (bold-italics).} \item{lwd}{line width for plotting.} \item{pts}{logical value indicating whether or not to plot filled circles at each vertex of the tree, as well as at transition points between mapped states. Default is \code{FALSE}.} \item{node.numbers}{a logical value indicating whether or not node numbers should be plotted.} \item{mar}{vector containing the margins for the plot to be passed to \code{\link{par}}. If not specified, the default margins are [0.1,0.1,0.1,0.1].} \item{add}{a logical value indicating whether or not to add the plotted tree to the current plot (\code{TRUE}) or create a new plot (\code{FALSE}, the default).} \item{offset}{offset for the tip labels in character widths.} \item{direction}{plotting direction. Options are \code{"rightwards"} (the default), \code{"leftwards"}, \code{"upwards"} or \code{"downwards"}. For \code{method="fan"} \code{direction} is ignored.} \item{type}{plot type. Can be \code{"phylogram"}, \code{"fan"}, or \code{"cladogram"}. Only a subset of options are presently available for \code{type="fan"}.} \item{setEnv}{logical value indicating whether or not to set the environment \code{.PlotPhyloEnv}. Setting this to \code{TRUE} (the default) will allow compatibility with \pkg{ape} labeling functions such as \code{\link{nodelabels}}.} \item{part}{value between 0 and 1 for \code{type="fan"} indicating what fraction of the full circular tree to use as plotting area. For instance, \code{part=0.5} will plot a half fan phylogeny. It also affects the axis scaling used.} \item{xlim}{x-limits for the plot.} \item{ylim}{y-limits for the plot.} \item{nodes}{node placement following Felsenstein (2004; pp. 574-576). Can be \code{"intermediate"}, \code{"centered"}, \code{"weighted"}, or \code{"inner"}. So far only works for \code{type="phylogram"}.} \item{tips}{labeled vector containing the vertical position of tips. Normally this will be \code{1:N} for \code{N} tips in the tree.} \item{maxY}{maximum value of y to use before rotating a tree into fan configuration. This will only make a difference if different from \code{Ntip(tree)}.} \item{hold}{logical argument indicating whether or not to hold the output to the graphical device before plotting. Defaults to \code{hold=TRUE}.} \item{split.vertical}{split the color of the vertically plotted edges by the state of the daughter edges. Only applies if the edge state changes exactly at a node.} \item{lend}{line end style. See \code{\link{par}}.} \item{asp}{aspect ratio. See \code{\link{plot.window}}.} \item{outline}{logical value indicating whether or not to draw a black outline around the plotted edges of the tree.} \item{plot}{logical value indicating whether or not to actually plot the tree. (See equivalent argument in \code{\link{plot.phylo}}.)} \item{underscore}{logical value indicating whether to plot the underscore character, \code{"_"} (if \code{underscore=TRUE}) or substitute for a space. Defaults to \code{underscore=FALSE}.} \item{arc_height}{for \code{type="arc"} trees, the height of the arc in units of total tree depth.} \item{x}{for S3 plotting method, object of class \code{"simmap"} or \code{"multiSimmap"}.} \item{...}{for S3 plotting method, other arguments to be passed to \code{\link{plotSimmap}}.} } \description{ Plots one or multiple stochastic character mapped trees. } \value{ Plots a tree. } \references{ Bollback, J. P. (2006) Stochastic character mapping of discrete traits on phylogenies. \emph{BMC Bioinformatics}, \bold{7}, 88. Felsenstein, J. (2004) \emph{Inferring Phylogenies}. Sinauer. Huelsenbeck, J. P., R. Neilsen, and J. P. Bollback (2003) Stochastic mapping of morphological characters. \emph{Systematic Biology}, \bold{52}, 131-138. Revell, L. J. (2014) Graphical methods for visualizing comparative data on phylogenies. Chapter 4 in \emph{Modern phylogenetic comparative methods and their application in evolutionary biology: Concepts and practice} (L. Z. Garamszegi ed.), pp. 77-103. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{densityMap}}, \code{\link{make.simmap}}, \code{\link{read.simmap}} } \examples{ data(anoletree) cols<-setNames(c("green","#E4D96F","darkgreen", "brown","black","darkgrey"), c("CG","GB","TC","TG","Tr","Tw")) plot(anoletree,cols,fsize=0.5,ftype="i",outline=TRUE, lwd=3,ylim=c(0,Ntip(anoletree)), mar=c(0.1,0.1,1.1,0.1)) add.simmap.legend(colors=cols,prompt=FALSE,x=0,y=-0.5, vertical=FALSE) title(main="Caribbean ecomorphs of anoles",font.main=3, line=0) par(mar=c(5.1,4.1,4.1,2.1)) ## reset margins to default } \keyword{ancestral states} \keyword{phylogenetics} \keyword{plotting} \keyword{comparative method} \keyword{discrete character} phytools/man/fastBM.Rd0000644000176200001440000000375514546013024014362 0ustar liggesusers\name{fastBM} \alias{fastBM} \title{(Reasonably) fast quantitative trait simulation on phylogenies} \usage{ fastBM(tree, a=0, mu=0, sig2=1, bounds=c(-Inf,Inf), internal=FALSE, nsim=1, ...) } \arguments{ \item{tree}{is a phylogenetic tree in \code{"phylo"} format.} \item{a}{a value for ancestral state at the root node.} \item{mu}{an optional value for the mean of random normal changes along branches of the tree - can be used to simulate a trend if \code{mu!=0}.} \item{sig2}{instantaneous variance of the BM process, \eqn{\sigma^2}.} \item{bounds}{a vector with the lower and upper bounds (respectively) for bounded Brownian simulation - by default simulation is unbounded.} \item{internal}{logical value indicating whether or not to return states for internal nodes.} \item{nsim}{number of simulations.} \item{...}{optional arguments \code{alpha} and \code{theta} used for OU simulation. If \code{alpha} is set then \code{mu} and \code{bounds} are ignored with a warning.} } \description{ Simulates one or multiple continuous traits on the tree under various evolutionary models. } \details{ This function conducts (reasonably) fast quantitative trait simulation on a phylogeny under several different models: Brownian motion (default), BM with a trend (for \code{mu!=0}), bounds (for \code{bounds!=c(-Inf,} \code{Inf)}), and OU. } \value{ A vector (for \code{nsim=1}) or matrix containing the tip states for the \code{n} species in the tree, and (optionally) the ancestral states for internal nodes. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{sim.corrs}} } \examples{ ## simulate 10 characters on the Anolis tree ## under Brownian motion data(anoletree) X<-fastBM(anoletree,nsim=10) head(X) } \keyword{phylogenetics} \keyword{simulation} \keyword{continuous character} phytools/man/phylo.toBackbone.Rd0000644000176200001440000000270214546016247016410 0ustar liggesusers\name{phylo.toBackbone} \alias{phylo.toBackbone} \alias{backbone.toPhylo} \title{Converts tree to backbone or vice versa} \usage{ phylo.toBackbone(x, trans, ...) backbone.toPhylo(x) } \arguments{ \item{x}{an object of class \code{"phylo"} (for the function \code{phylo.toBackbone}), or an object of the special class \code{"backbonePhylo"} (for \code{backbone.toPhylo}).} \item{trans}{data frame containing the attributes necessary to translate a backbone tree to an object of class \code{"backbonePhylo"}. The data frame should contain the following variables: \code{tip.label}: the tip labels in the input tree (not all need be included); \code{clade.label}: labels for the unobserved subtrees; \code{N}: number of species in each subtree; and \code{depth}: desired depth of each subtree. \code{depth} for each terminal taxon in \code{x} cannot be greater than the terminal edge length for that taxon.} \item{...}{optional arguments.} } \description{ Converts between \code{"phylo"} and \code{"backbonePhylo"}. } \value{ Either an object of class \code{"phylo"} or an object of class \code{"backbonePhylo"}, depending on the method. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{plot.backbonePhylo}} } \keyword{phylogenetics} \keyword{plotting} phytools/man/multirateBM.Rd0000644000176200001440000000636714546014047015443 0ustar liggesusers\name{multirateBM} \alias{multirateBM} \title{Function to fit a multi-rate Brownian evolution model} \usage{ multirateBM(tree, x, method=c("ML","REML"), optim=c("L-BFGS-B","Nelder-Mead","BFGS","CG"), maxit=NULL, n.iter=1, lambda=1, ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{x}{a named numerical vector. Names should correspond to the species names of \code{tree}.} \item{method}{method of optimization. Currently only \code{method="ML"}.} \item{optim}{optimization routine to be used by \code{\link{optim}}. If more than one is specified and \code{n.iter>1} then they will be alternated. (This is recommended to improve optimization.)} \item{maxit}{to be passed to \code{optim}. If set to \code{maxit=NULL}, the default value of \code{maxit} will be used, depending on the optimization method.} \item{n.iter}{number of times to reiterate failed optimization.} \item{lambda}{lambda penalty term. High values of \code{lambda} correspond to high penalty for rate heterogeneity among edges. Low values of \code{lambda} correspond to low penalty.} \item{...}{optional arguments.} } \description{ Fits a flexible multi-rate Brownian motion evolution model using penalized likelihood. } \details{ This function fits a flexible Brownian multi-rate model using penalized likelihood. The model that is being fit is one in which the rate of Brownian motion evolution itself evolves from edge to edge in the tree under a process of geometric Brownian evolution (i.e., Brownian motion evolution on a log scale). The penalty term, \code{lambda}, determines the cost of variation in the rate of evolution from branch to branch. If lambda is \emph{high}, then the rate of evolution will vary relatively little between edges (and in the limiting case converge to the single-rate MLE estimate of the rate). By contrast, if the value of \code{lambda} is set to be low, then the rate of evolution can vary from edge to edge with relatively little penalty. Decreasing the penalty term, however, is not without cost. As \code{lambda} is decreased towards zero, estimated rates will tend to become less and less accurate. } \value{ An object of class \code{"multirateBM"}. } \references{ Revell, L. J. (2021) A variable-rate quantitative trait evolution model using penalized-likelihood. \emph{PeerJ}, \bold{9}, e11997. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{brownie.lite}}, \code{\link{evol.rate.mcmc}} } \examples{ \dontrun{ ## load data data(sunfish.tree) data(sunfish.data) ## convert from "simmap" to "phylo" sunfish.tree<-as.phylo(sunfish.tree) ## extract character of interest gw<-setNames(sunfish.data$gape.width, rownames(sunfish.data)) ## run penalized-likelihood optimization ## lambda=0.1 is arbitrary fitBM<-multirateBM(sunfish.tree,gw, lambda=0.01) ## print and plot the results print(fitBM) plot(fitBM,ftype="i",fsize=0.8,lwd=6, outline=TRUE) ## reset par par(mar=c(5.1,4.1,4.1,2.1))} } \keyword{phylogenetics} \keyword{comparative method} \keyword{continuous character} \keyword{maximum likelihood} phytools/man/phyl.RMA.Rd0000644000176200001440000000623514546016050014576 0ustar liggesusers\name{phyl.RMA} \alias{phyl.RMA} \alias{coef.phyl.RMA} \alias{plot.phyl.RMA} \title{Phylogenetic reduced major axis (RMA) regression} \usage{ phyl.RMA(x, y, tree, method="BM", lambda=NULL, fixed=FALSE, h0=1.0) \method{coef}{phyl.RMA}(object, ...) \method{plot}{phyl.RMA}(x, ...) } \arguments{ \item{x}{vector with names. In the case of the S3 \code{plot} method \code{x} is an object of class \code{"phyl.RMA"}.} \item{y}{vector with names.} \item{tree}{a phylogenetic tree in \code{"phylo"} format.} \item{method}{method to obtain the correlation structure: can be \code{"BM"} or \code{"lambda"}.} \item{lambda}{value of \code{lambda} for fixed \eqn{\lambda}.} \item{fixed}{logical value indicating whether or not \eqn{\lambda} should be optimized using likelihood.} \item{h0}{null hypothesis for \eqn{\beta}. Defaults to 1.0. Note that a null hypothesis of 0.0 is not allowed.} \item{object}{for \code{coef} method, an object of class \code{"phyl.RMA"}.} \item{...}{optional arguments for S3 methods.} } \description{ Phylogenetic reduced major axis (RMA) regression. } \details{ Optionally jointly estimates \eqn{\lambda} if \code{method="lambda"}. Likelihood optimization of \eqn{\lambda} is performed using \code{\link{optimize}} on the interval (0,1). The statistical hypothesis testing is based on Clarke (1980; reviewed in McArdle 1988), which differs from some other implementations of non-phylogenetic major axis regression in R. Note that some statistician think there is \emph{never} a condition in which a reduced-major-axis regression is appropriate. } \value{ An object of class \code{"phyl.RMA"} consisting of a list with the following elements: \item{RMA.beta}{a vector of RMA regression coefficients.} \item{V}{a VCV matrix for the traits.} \item{lambda}{fitted value of \eqn{\lambda} (\code{method="lambda"} only).} \item{logL}{log-likelihood (\code{method="lambda"} only).} \item{test}{a vector containing results for hypothesis tests on \eqn{\beta}.} \item{resid}{a vector of residuals for \code{y} given \code{x}.} } \references{ Clarke, M. R. B. (1980) The reduced major axis of a bivariate sample. \emph{Biometrika}, \bold{67}, 441-446. McArdle, B. H. (1988) The structural relationship: Regression in biology. \emph{Can. J. Zool.}, \bold{66}, 2329-2339. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{phyl.cca}}, \code{\link{phyl.pca}}, \code{\link{phyl.resid}} } \examples{ ## load data from Garland et al. (1992) data(mammal.data) data(mammal.tree) ## pull out & log transform variables lnBodyMass<-setNames(log(mammal.data$bodyMass), rownames(mammal.data)) lnHomeRange<-setNames(log(mammal.data$homeRange), rownames(mammal.data)) ## fit RMA regression & print results fitted.rma<-phyl.RMA(lnBodyMass,lnHomeRange, mammal.tree) print(fitted.rma) ## plot fitted RMA par(las=1,bty="n") plot(fitted.rma,las=1,bty="n") } \keyword{phylogenetics} \keyword{comparative method} \keyword{maximum likelihood} \keyword{statistics} phytools/man/fit.bd.Rd0000644000176200001440000000700414546013076014352 0ustar liggesusers\name{fit.bd} \alias{fit.bd} \alias{fit.yule} \alias{lik.bd} \alias{print.fit.bd} \title{Fits birth-death (speciation/extinction) model to reconstructed phylogeny} \usage{ fit.bd(tree, b=NULL, d=NULL, rho=1, ...) fit.yule(tree, b=NULL, d=NULL, rho=1, ...) lik.bd(theta, t, rho=1, N=NULL) \method{print}{fit.bd}(x, ...) } \arguments{ \item{tree}{object of class \code{"phylo"}.} \item{b}{birth (speciation) rate. Presently doesn't do anything as the rate cannot be fixed.} \item{d}{death (extinction) rate. Presently doesn't do anything as the rate cannot be fixed.} \item{rho}{sampling fraction.} \item{theta}{vector of \code{b} and \code{d} for likelihood function.} \item{t}{branching times for calculation of the likelihood.} \item{N}{number of tips in the tree.} \item{x}{object of class \code{"fit.bd"} for \code{print} method.} \item{...}{optional arguments.} } \description{ Fits a birth-death (\code{fit.bd}) or pure-birth (\code{fit.yule}) model to a reconstructed phylogenetic tree with branch lengths. } \details{ The function \code{fit.bd} fits a birth-death model to a phylogenetic tree with edge lengths and a (potentially) incomplete sampling fraction. The function \code{fit.yule} fits a pure-birth model with a (potentially) incomplete sampling fraction. The function \code{lik.bd} computes the likelihood of a set of birth & death rates given the set of branching times computed for a tree and a sampling fraction. } \value{ \code{fit.bd} returns an object of class \code{"fit.bd"} which can be printed. This object is a list containing the fitted model parameters, likelihood, optimization conditions, a summary of the optimization, and a likelihood function. \code{fit.yule} returns an object of class \code{"fit.yule"}. This object is a list containing the fitted model parameter, likelihood, optimization conditions, a summary of the optimization, and a likelihood function. } \references{ Nee, S., May, R. M. and Harvey, P. H. (1994) The reconstructed evolutionary process. \emph{Philosophical Transactions of the Royal Society of London B}, \bold{344}, 305-311. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. Stadler, T. (2012) How can we improve the accuracy of macroevolutionary rate estimates? \emph{Systematic Biology}, \bold{62}, 321-329. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{birthdeath}} } \examples{ data(salamanders) ## compute sampling fraction based on 55 species of Plethodon sampling.f<-Ntip(salamanders)/55 ## fit birth-death model bd.fit<-fit.bd(salamanders,rho=sampling.f) print(bd.fit) ## fit Yule model yule.fit<-fit.yule(salamanders,rho=sampling.f) print(yule.fit) ## compare b-d and yule models anova(yule.fit,bd.fit) ## create a likelihood surface for b-d model ngrid<-100 b<-seq(0.01,0.06,length.out=ngrid) d<-seq(0.005,0.03,length.out=ngrid) logL<-sapply(d,function(d,b) sapply(b,function(b,d) bd.fit$lik(c(b,d)),d=d),b=b) contour(x=b,y=d,logL,nlevels=100, xlab=expression(lambda), ylab=expression(mu),bty="l") title(main="Likelihood surface for plethodontid diversification", font.main=3) points(bd.fit$b,bd.fit$d,cex=1.5,pch=4, col="blue",lwd=2) legend("bottomright","ML solution",pch=4,col="blue", bg="white",pt.cex=1.5,pt.lwd=2) } \keyword{comparative methods} \keyword{diversification} \keyword{phylogenetics} \keyword{diversification} \keyword{maximum likelihood} phytools/man/rstate.Rd0000644000176200001440000000147714546017513014516 0ustar liggesusers\name{rstate} \alias{rstate} \title{Pick a random state according to a vector of probabilities} \usage{ rstate(y) } \arguments{ \item{y}{vector of probabilities. Must have names & should probably add to \code{1.0}.} } \description{ Internal function for \code{\link{make.simmap}}. } \details{ This function picks a random element in a vector according to the probability assigned that element. It returns the name. Uses \code{\link{rmultinom}}. } \value{ A character or string. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{math} \keyword{utilities} \keyword{statistics} \keyword{discrete character} \keyword{simulation} phytools/man/ancr.Rd0000644000176200001440000000744314546011225014130 0ustar liggesusers\name{ancr} \alias{ancr} \alias{hide.hidden} \alias{plot.ancr} \title{Compute marginal or joint ancestral state estimates} \usage{ ancr(object, ...) hide.hidden(object, ...) \method{plot}{ancr}(x, args.plotTree=list(...), args.nodelabels=list(...), ...) } \arguments{ \item{object}{fitted M\emph{k} model (presently object of class \code{"fitMk"}, \code{"fitpolyMk"}, and \code{"fitHRM"}), or a set of models in the form of a table from \code{anova} comparison. For \code{hide.hidden}, object of class \code{"ancr"}.} \item{...}{optional arguments.} \item{x}{in the case of \code{plot.ancr}, an object of class \code{"ancr"}.} \item{args.plotTree}{arguments to be passed to \code{\link{plotTree}}, in a list.} \item{args.nodelabels}{arguments to be passed to \code{\link{nodelabels}}, in a list.} } \description{ By default, \code{ancr} computes marginal ancestral states, also known as empirical Bayes posterior probabilities, conditioning on the fitted (or set) model of \code{object}. Can also perform \emph{joint} ancestral state estimation, if the optional argument \code{type} is set to \code{type="joint"}. \code{hide.hidden} merges hidden states (if any). } \details{ If the optional argument \code{tips=TRUE}, then the matrix returned contains empirical Bayes posterior probabilities (marginal scaled likelihoods) for both tips \emph{and} internal nodes. Otherwise (the default) only node marginal states are returned. If the input object is a set of models (in the form of an \code{anova} table), then \code{ancr} will compute model-averaged marginal ancestral states (for \code{type="marginal"}, unless the optional argument \code{weighted=FALSE}, in which case only the best-supported model is used. } \value{ An object of class \code{"ancr"}. In the case of \code{type="marginal"}, this object consists of a matrix of marginal (empirical Bayes) probabilities and a likelihood. In the case of \code{type="joint"}, the object contains a set of most-likely internal node states stored in a data frame. } \references{ Pagel, M. (1999) The Maximum Likelihood approach to reconstructing ancestral character states of discrete characters on phylogenies. \emph{Systematic Biology}, \bold{3}, 612-622. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{fitMk}} } \examples{ ## load tree and data from Revell & Collar (2009) data(sunfish.tree) data(sunfish.data) ## extract discrete character (feeding mode) fmode<-setNames(sunfish.data$feeding.mode, rownames(sunfish.data)) ## fit ARD model ard_fmode<-fitMk(sunfish.tree,fmode,model="ARD", pi="fitzjohn") ## compute ancestral states anc_fmode<-ancr(ard_fmode) ## plot the results par(mfrow=c(2,1)) cols<-setNames(c("blue","red"),levels(fmode)) plot(anc_fmode, args.plotTree=list(lwd=2,direction="upwards", mar=c(0.1,1.1,2.1,1.1),fsize=0.8), args.nodelabels=list(piecol=cols), args.tiplabels=list(cex=0.3), legend="bottomright") mtext("a) marginal states under ARD model",adj=0) ## fit ER model er_fmode<-fitMk(sunfish.tree,fmode,model="ER", pi="fitzjohn") ## compare models aov_fmode<-anova(er_fmode,ard_fmode) ## compute model-averaged ancestral states anc_fmode_model.averaged<-ancr(aov_fmode) plot(anc_fmode_model.averaged, args.plotTree=list(lwd=2,direction="upwards", mar=c(0.1,1.1,2.1,1.1),fsize=0.8), args.nodelabels=list(piecol=cols), args.tiplabels=list(cex=0.3), legend="bottomright") mtext("b) marginal states model-averaging ER & ARD models", adj=0) par(mar=c(5.1,4.1,4.1,2.1),mfrow=c(1,1)) } \keyword{ancestral states} \keyword{phylogenetics} \keyword{comparative method} \keyword{maximum likelihood} phytools/man/reorder.backbonePhylo.Rd0000644000176200001440000000147014546017372017431 0ustar liggesusers\name{reorder.backbonePhylo} \alias{reorder.backbonePhylo} \title{Reorders a backbone phylogeny} \usage{ \method{reorder}{backbonePhylo}(x, order="cladewise", ...) } \arguments{ \item{x}{an object of class \code{"backbonePhylo"}.} \item{order}{order. See \code{\link{reorder.phylo}} for possible orderings.} \item{...}{optional arguments.} } \description{ Function reorders an object of class \code{"backbonePhylo"}. } \value{ An object of class \code{"backbonePhylo"}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{phylo.toBackbone}} } \keyword{phylogenetics} \keyword{plotting} \keyword{utilities} phytools/man/markChanges.Rd0000644000176200001440000000327214546013633015431 0ustar liggesusers\name{markChanges} \alias{markChanges} \title{Add marked changes to a plotted tree with mapped discrete character} \usage{ markChanges(tree, colors=NULL, cex=1, lwd=2, plot=TRUE) } \arguments{ \item{tree}{an object of class \code{"simmap"}.} \item{colors}{a named vector of colors used to plot the stochastically mapped character on the tree.} \item{cex}{expansion factor for line height.} \item{lwd}{line width.} \item{plot}{logical value indicating whether the changes should be plotted or not.} } \description{ Adds the reconstructed changes to a plotted tree with a stochastically mapped discrete character. } \value{ This function returns (invisibly) a matrix containing the x & y coordinates of the marked changes on the plotted tree. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{plotSimmap}} } \examples{ ## load tree and data from Revell & Collar (2009) data(sunfish.tree) data(sunfish.data) ## extract discrete character (feeding mode) fmode<-setNames(sunfish.data$feeding.mode, rownames(sunfish.data)) ## fit model er_model<-fitMk(sunfish.tree,fmode,model="ER", pi="fitzjohn") ## generate single stochastic map sunfish_smap<-simmap(er_model,nsim=1) ## plot stochastic map & mark changes cols<-setNames(c("blue","red"),levels(fmode)) plot(sunfish_smap,cols,ftype="i") markChanges(sunfish_smap,colors=cols,lwd=6) par(mar=c(5.1,4.1,4.1,2.1)) } \keyword{ancestral states} \keyword{bayesian} \keyword{phylogenetics} \keyword{plotting} \keyword{discrete character} phytools/man/fancyTree.Rd0000644000176200001440000001454014546015536015132 0ustar liggesusers\name{fancyTree} \alias{fancyTree} \alias{phyloScattergram} \alias{phenogram95} \title{Plots special types of phylogenetic trees} \usage{ fancyTree(tree, type=c("extinction","traitgram3d","droptip","densitymap", "contmap","phenogram95","scattergram"), ..., control=list()) phyloScattergram(tree, X=NULL, ...) phenogram95(tree, x=NULL, ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{type}{the type of special plot to create. See Description.} \item{...}{arguments to be passed to different methods. See Description.} \item{control}{a list of control parameters, depending on \code{type}.} \item{X}{in \code{phyloScattergram}, a matrix of continuous trait values. Row names in the matrix should correspond to species names in the tree.} \item{x}{in \code{phenogram95}, a named vector with values for a continuously distributed trait.} } \description{ Plots phylogenies (or phylogenetic trees and comparative data) in a variety of different styles. } \details{ This function plots a phylogeny or phylogenetic tree and comparative data in a variety of different styles, depending on the value of \code{type}. In some instances, \code{fancyTree} is now just a wrappe for other \pkg{phytools} functions, such as \code{\link{contMap}} and \code{\link{densityMap}}. If \code{type="extinction"} (or any unambiguous abbreviation) the function will plot a tree in which branches preceding the MRCA of all extant taxa and branches leading only to extinct lineages are plotted with dashed red lines. If \code{type="traitgram3d"} the function will plot a three dimensional traitgram (that is, a projection of the tree into three dimensional morphospace where two dimensions are the phenotypic trait and the third axis is time since the root). In this case, the additional argument \code{X}, a matrix containing the tip values of all species (with species IDs as row names) should be supplied. Optionally, the user can also supply the matrix \code{A}, which contains the ancestral states in the tree with rows labeled by node number. If \code{type="droptip"} the function will create a two panel figure in which the first panel is the tree with lineages to be pruned highlighted; and the second panel is the pruned tree. In this case, the additional argument \code{tip}, the tip name or vector of tip names to be dropped, must be supplied. If \code{type="densitymap"}, a posterior probability density "heat-map" is created based on a set of trees in a \code{"multiSimmap"} object containing a binary [0,1] mapped character. (See \code{\link{densityMap}} for additional optional arguments if \code{type="densitymap"}.) If \code{type="contmap"}, reconstructed continuous trait evolution is mapped on the tree. Again, see \code{\link{contMap}} for additional arguments if \code{type="contmap"}. If \code{type="phenogram95"} a 95\% traitgram (aka. "phenogram") is plotted using transparency to visualize uncertainty at ancestral nodes and along branches. Most of the options of \code{\link{phenogram}} are available. Finally, if \code{type="scattergram"} a phylogenetic scatter plot matrix containing \code{\link{contMap}} style trees on the diagonal and \code{\link{phylomorphospace}} plots in non-diagonal panels is produced. For this type a trait matrix \code{X} must also be supplied. The only additional arguments available for this type are \code{ftype}, \code{fsize}, \code{colors}, and \code{label}. (See \code{\link{phylomorphospace}} for details on how these arguments should be used.) This function calls \code{\link{phyloScattergram}} (which is also now exported to the name space) internally. In addition to creating a plot, \code{phyloScattergram} also returns an object of class \code{"phyloScattergram"} which can be replotted using different options if desired. Presently only \code{type="traitgram3d"} uses the list \code{control} which can be supplied the same set of control parameters as \code{\link{phylomorphospace3d}}, as well as the control parameter \code{maxit} which will be passed to \code{\link{anc.ML}}. Finally, the optional argument \code{hold} will be passed to multiple methods if supplied. It is a logical value that indicates whether or not the output to the graphical device should be held using \code{\link{dev.hold}} before plotting (defaults to \code{hold=TRUE}). } \value{ This function plots different types of phylogenetic trees. For \code{type="droptip"} the function also returns the pruned tree. } \references{ Evans, M. E. K., Smith, S. A., Flynn, R. S., Donoghue, M. J. (2009) Climate, niche evolution, and diversification of the "bird-cage" evening primroses (Oenothera, sections Anogra and Kleinia). \emph{American Naturalist}, \bold{173}, 225-240. Revell, L. J. (2013) Two new graphical methods for mapping trait evolution on phylogenies. \emph{Methods in Ecology and Evolution}, \bold{4}, 754-759. Revell, L. J. (2014) Graphical methods for visualizing comparative data on phylogenies. Chapter 4 in \emph{Modern phylogenetic comparative methods and their application in evolutionary biology: Concepts and practice} (L. Z. Garamszegi ed.), pp. 77-103. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{contMap}}, \code{\link{densityMap}}, \code{\link{drop.tip}}, \code{\link{phenogram}}, \code{\link{phylomorphospace3d}}, \code{\link{plot.phylo}}, \code{\link{plotSimmap}} } \examples{ ## plot tree with extinction set.seed(10) tree<-pbtree(b=1,d=0.4,t=4) fancyTree(tree,type="extinction") \dontrun{ ## plot 3D traitgram ## load data from Revell & Collar (2009) data(sunfish.tree) data(sunfish.data) fancyTree(sunfish.tree,type="traitgram3d", X=sunfish.data[,2:3], control=list(spin=FALSE))} ## plot with dropped tips tree<-pbtree(n=30) tips<-sample(tree$tip.label)[1:10] pruned<-fancyTree(tree,type="droptip",tip=tips) par(mfrow=c(1,1)) ## reset mfrow to default \dontrun{ ## plot 95-percent CI phenogram data(mammal.tree) data(mammal.data) bodyMass<-setNames(mammal.data$bodyMass, rownames(mammal.data)) fancyTree(mammal.tree,type="phenogram95",x=bodyMass, fsize=0.7,ftype="i")} par(mar=c(5.1,4.1,4.1,2.1)) ## reset mar to defaults } \keyword{phylogenetics} \keyword{plotting} \keyword{comparative method} phytools/man/phyl.vcv.Rd0000644000176200001440000000367414546656424015000 0ustar liggesusers\name{phyl.vcv} \alias{phyl.vcv} \title{Compute evolutionary VCV matrix for a tree & dataset} \usage{ phyl.vcv(X, C, lambda) } \arguments{ \item{lambda}{value for \eqn{\lambda} transformation.} \item{X}{data matrix.} \item{C}{matrix containing the height above the root of each pair of species in the tree. Typically this will have been produced by calling \code{\link{vcv.phylo}}.} } \description{ Internal function for \code{\link{phyl.pca}}. } \details{ Primarily designed as an internal function for \code{\link{phyl.pca}}; \code{phyl.vcv} can be used to compute the phylogenetic trait variance-covariance matrix given a phylogenetic VCV, \eqn{\lambda}, and a data matrix. This function should not be confused with \code{\link{vcv.phylo}} in the \pkg{ape} package (although one of the objects returned is the output of \code{vcv.phylo}). Note that prior to \pkg{phytools} 2.1-0 the matrix \code{X} was not sorted to match the rows of \code{C} since that was assumed to have been done in the function calling \code{phyl.vcv} internally; however, I recently discovered that this had caused the function to be used incorrectly resulting in a paper correction. This is now fixed such that \code{X} is checked for row names and (if present) \code{C} is sorted to match the rows of \code{X}. Hopefully this does not cause any problems for other functions using \code{phyl.vcv}! } \value{ A list containing three elements, as follows: \code{C}, the matrix \code{vcv.phylo} transformed by \code{lambda}; \code{R}, the among trait variance-covariance matrix for the data in \code{X}; and \code{alpha}, a vector of ancestral states at the root node of the tree. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{statistics} \keyword{utilities} phytools/man/multi.mantel.Rd0000644000176200001440000000422014546014025015605 0ustar liggesusers\name{multi.mantel} \alias{multi.mantel} \title{Multiple matrix regression (partial Mantel test)} \usage{ multi.mantel(Y, X, nperm=1000) } \arguments{ \item{Y}{single "dependent" square matrix. Can be either a symmetric matrix of class \code{"matrix"} or a distance matrix of class \code{"dist"}.} \item{X}{a single independent matrix or multiple independent matrices in a list. As with \code{Y} can be a object of class \code{"matrix"} or class \code{"dist"}, or a list of such objects.} \item{nperm}{number of Mantel permutations to be used to compute a P-value of the test.} } \description{ This function conducting a multiple matrix regression (partial Mantel test) and uses Mantel (1967) permutations to test the significance of the model and individual coefficients. It also returns the residual and predicted matrices. } \value{ An object of class \code{"multi.mantel"} consisting of the following elements: \item{r.squared}{multiple R-squared.} \item{coefficients}{model coefficients, including intercept.} \item{tstatistic}{t-statistics for model coefficients.} \item{fstatistic}{F-statistic for the overall model.} \item{probt}{vector of probabilities, based on permutations, for \code{tstatistic}.} \item{probF}{probability of F, based on Mantel permutations.} \item{residuals}{matrix of residuals.} \item{predicted}{matrix of predicted values.} \item{nperm}{the number of permutations used.} } \details{ Printing the object to screen will result in a summary of the analysis similar to \code{summary.lm}, but with p-values derived from Mantel permutations. Methods \code{residuals} and \code{fitted} can be used to return residual and fitted matrices, respectively. } \references{ Mantel, N. (1967) The detection of disease clustering and a generalized regression approach. \emph{Cancer Research}, \bold{27}, 209-220. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{comparative method} \keyword{statistics} \keyword{least squares} \keyword{distance matrix} phytools/man/fitDiversityModel.Rd0000644000176200001440000000533114546013142016645 0ustar liggesusers\name{fitDiversityModel} \alias{fitDiversityModel} \alias{logLik.fitDiversityModel} \alias{print.fitDiversityModel} \title{Fit diversity-dependent phenotypic evolution model} \usage{ fitDiversityModel(tree, x, d=NULL, showTree=TRUE, tol=1e-6) \method{logLik}{fitDiversityModel}(object, ...) \method{print}{fitDiversityModel}(x, ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{x}{a vector with tip values for a continuously distributed trait. For \code{print} method, an object of class \code{"fitDiversityModel"}.} \item{d}{a vector containing the inferred historical diversity at each node in the tree - if \code{d=NULL} (the default) function will treat the diversification as if it occurred in a single geographic area.} \item{showTree}{optional logical value indicating whether to plot the tree transformation implied by the model.} \item{tol}{some small value by which \code{d} is incremented during rescaling of \code{psi} for optimization. If R thinks your matrices are singular during optimization, try increasing \code{tol} slightly.} \item{object}{for \code{logLik} method, an object of class \code{"fitDiversityModel"}.} \item{...}{optional arguments for \code{logLik} and \code{print} methods. Note that for the \code{logLik} method the number of fitted parameters (\code{"df"}) is assumed to be 3 for the diversity dependent model (that is, if \code{psi} is estimated) and 2 for the diversity independent model, unless otherwise specified (using the argument \code{df}).} } \description{ Fits a diversity-dependent phenotypic evolution model (similar to Mahler et al. 2010). } \value{ An object of class \code{"fitDiversityModel"} consisting of the following elements: \item{logL}{log-likelihood of the fitted model.} \item{sig0}{estimated starting value for the rate at the root of the tree, \eqn{\sigma_0^2}.} \item{psi}{the estimated rate of change in the rate associated with the addition of a lineage.} \item{vcv}{a matrix with the variances and covariance of the estimated parameters (from the Hessian).} } \references{ Mahler, D. L, L. J. Revell, R. E. Glor, and J. B. Losos (2010) Ecological opportunity and the rate of morphological evolution in the diversification of Greater Antillean anoles. \emph{Evolution}, \bold{64}, 2731-2745. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{brownie.lite}}, \code{\link{estDiversity}}, \code{\link{evol.rate.mcmc}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{maximum likelihood} \keyword{continuous character} \keyword{diversification} phytools/man/resolveNode.Rd0000644000176200001440000000316614546017456015504 0ustar liggesusers\name{resolveNode} \alias{resolveNode} \alias{resolveAllNodes} \title{Compute all possible resolutions of a node or all nodes in a multifurcating tree} \usage{ resolveNode(tree,node) resolveAllNodes(tree) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{node}{for \code{resolveNode}, the node with a polytomy to resolve.} } \description{ Resolves a single multifurcation or all multifurcations in all possible ways. } \details{ This functions resolves a single multifurcation or all multifurcations in a tree in all possible ways. If the input tree has edge lengths, then the resolutions will use internal edges of zero length. For \code{resolveNode} applied to a multifurcation with \emph{n} descendants, the number of resolved trees will be equal to the number of possible rooted trees of \emph{n} taxa. (For instance, three for a trifurcation, 15 for a quadrifurcation, and so on.) For \code{resolveAllNodes} the number of fully resolved trees will be equal to the product of numbers for \code{resolveNode} applied to each multifurcation separately. (For instance, 45 for a tree containing one trifurcation and one quadrifurcation.) } \value{ An object of class \code{"multiPhylo"} - or, if the input tree is already fully resolved, an object of class \code{"phylo"} identical to \code{tree}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{multi2di}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/phylomorphospace3d.Rd0000644000176200001440000000666014546016307017036 0ustar liggesusers\name{phylomorphospace3d} \alias{phylomorphospace3d} \title{Creates three-dimensional phylomorphospace plot} \usage{ phylomorphospace3d(tree, X, A=NULL, label=TRUE, control=list(), method=c("dynamic","static"), ...) } \arguments{ \item{tree}{a phylogenetic tree in \code{"phylo"} format.} \item{X}{an \code{n} x 3 matrix of tip values for two characters in \code{n} species.} \item{A}{an optional \code{m} x 3 matrix (for \code{m} nodes) of values for two traits at internal nodes in the tree - if not supplied, these values will be estimated using \code{\link{anc.ML}}.} \item{label}{logical value indicating whether to print tip labels next to terminal nodes in the plot (presently doesn't do anything, but labels can be dropped using \code{control}).} \item{control}{a list containing the following optional control parameters: \code{spin}: a logical value indicating whether to animate the plot when created; \code{axes}: a logical indicating whether to plot the axes; \code{box}: a logical value indicating whether to plot in box; \code{simple.axes}: logical value indicating whether to replace \code{box} and \code{axes} with simpler axes; \code{lwd}: line widths; \code{ftype}: font type ("off" turns off labels altogether); \code{col.edge} a vector of colors of length \code{nrow(tree$edge)}.} \item{method}{a string either \code{"dynamic"} for a dynamic (animated) plot created using \pkg{rgl}; or \code{"static"} for a flat 3D plot created using \code{scatterplot3d} and base graphics. The latter has the advantage of being very easy to export in standard format.} \item{...}{optional arguments to be passed to \code{scatterplot3d}. Most options not available. \code{angle} is an important option that does work here.} } \description{ Creates a phylomorphospace plot in three dimensions. } \details{ This function creates a phylomorphospace plot for three characters using the 3D visualization package, \pkg{rgl} (if available) or statically, by simulating 3D on a flat graphical device. } \value{ This function creates a three dimensional phylomorphospace plot. The function returns a function from \code{spin3d} (for \code{method="dynamic"}); or a series of functions from \code{\link{scatterplot3d}} (for \code{method="static"}). } \references{ Revell, L. J. (2014) Graphical methods for visualizing comparative data on phylogenies. Chapter 4 in \emph{Modern phylogenetic comparative methods and their application in evolutionary biology: Concepts and practice} (L. Z. Garamszegi ed.), pp. 77-103. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. Sidlauskas, B. (2008) Continuous and arrested morphological diversification in sister clades of characiform fishes: A phylomorphospace approach. \emph{Evolution}, \bold{62}, 3135-3156. } \author{Liam Revell \email{liam.revell@umb.edu}} \examples{ data(anoletree) data(anole.data) anole.pca<-phyl.pca(anoletree,anole.data) \dontrun{ phylomorphospace3d(anoletree,scores(anole.pca)[,1:3], control=list(spin=FALSE))} par(cex=0.5) phylomorphospace3d(anoletree,scores(anole.pca)[,1:3], method="static",angle=-30) par(cex=1) } \seealso{ \code{\link{fancyTree}}, \code{\link{phenogram}}, \code{\link{phylomorphospace}} } \keyword{ancestral states} \keyword{animation} \keyword{phylogenetics} \keyword{comparative method} \keyword{plotting} \keyword{continuous character} phytools/man/locate.yeti.Rd0000644000176200001440000000356214546013504015425 0ustar liggesusers\name{locate.yeti} \alias{locate.yeti} \title{Locate a cryptic, recently extinct, or missing taxon on a tree} \usage{ locate.yeti(tree, X, ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{X}{a matrix with continuous character data.} \item{...}{optional arguments including: \code{method} (\code{"ML"} or \code{"REML"}, defaults to \code{"ML"}); \code{search} (\code{"heuristic"} or \code{"exhaustive"}, defaults to \code{"heuristic"}); \code{constraint}, a vector containing the daughter node numbers from \code{tree$edge} for each edge to try; \code{plot} a logical argument specifying whether or not to plot the likelihood profile on edges (defaults to \code{FALSE}); \code{rotate} a logical indicating whether or not to rotate the data based on the input tree; and \code{quiet}, which is logical and has an obvious interpretation.} } \description{ Uses ML (or REML) to place a recently extinct, cryptic, or missing taxon on an ultrametric (i.e., time-calibrated) phylogeny following Revell et al. (2015). } \value{ Optimized tree as an object of class \code{"phylo"}. } \references{ Felsenstein, J. (1981) Maximum likelihood estimation of evolutionary trees from continuous characters. \emph{American Journal of Human Genetics}, 25, 471-492. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. Revell, L. J., D. L. Mahler, R. G. Reynolds, and G. J. Slater. (2015) Placing cryptic, recently extinct, or hypothesized taxa into an ultrametric phylogeny using continuous, character data: A case study with the lizard \emph{Anolis roosevelti}. \emph{Evolution}, \bold{69}, 1027-1035. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{phylogeny inference} \keyword{maximum likelihood} \keyword{continuous character} phytools/man/averageTree.Rd0000644000176200001440000000434614546011567015447 0ustar liggesusers\name{averageTree} \alias{averageTree} \alias{ls.consensus} \alias{minTreeDist} \title{Compute an average tree from a set of trees and related operations} \usage{ averageTree(trees, start=NULL, method="quadratic.path.difference", tol=1e-12, quiet=FALSE, ...) ls.consensus(trees, start=NULL, tol=1e-12, quiet=FALSE, ...) minTreeDist(tree, trees, method="quadratic.path.difference", ...) } \arguments{ \item{trees}{object of class \code{"multiPhylo"}.} \item{tree}{object of class \code{"phylo"}. For \code{minTreeDist} the tree on which to find the edge lengths that minimize the distance to the phylogenies in \code{trees}.} \item{start}{starting tree for optimization.} \item{method}{distance criterion for minimization. Options are \code{"symmetric.difference"}, \code{"branch.score.difference"}, \code{"path.difference"}, and \code{"quadratic.path.difference"}.} \item{tol}{tolerance value for optimization.} \item{quiet}{logical value indicating whether to run "quietly" or not.} \item{...}{other arguments to be passed internally.} } \description{ Compute average trees or consensus trees by various criteria. } \details{ The function \code{averageTree} tries to find the (hypothetical) tree topology and branch lengths that has a minimum distance to all the trees in an input set, according to some user-specified tree distance measure. The function \code{ls.consensus} computes the least-squares consensus tree (Lapointe & Cucumel, 1997) from a set of input trees. Finally, the function \code{minTreeDist} finds the tree in the input set that is a minimum distance to all the other trees in the set. (This contrasts with \code{averageTree} which can return a tree not in the input set.) } \value{ An object of class \code{"phylo"} with edge lengths. } \references{ Lapointe, F.-J., G. Cucumel (1997) The average consensus procedure: Combination of weighted trees containing identical or overlapping sets of taxa. \emph{Systematic Biology}, \bold{46}, 306-312. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{consensus tree} phytools/man/make.era.map.Rd0000644000176200001440000000233414546013543015443 0ustar liggesusers\name{make.era.map} \alias{make.era.map} \title{Create "era" map on a phylogenetic tree} \usage{ make.era.map(tree, limits, ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{limits}{a vector containing the temporal limits, in time since the root node of the tree, for the mappings. The first number should be \code{0}, and each subsequent number should be the start of each subsequent regime or era to be mapped on the tree.} \item{...}{optional arguments.} } \description{ Creates a temporal map on the tree based on \code{limits} provided by the user. } \value{ An object of class \code{"simmap"} with the specified eras mapped as different regimes. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{plotSimmap}} } \examples{ tree<-pbtree(n=1000,scale=100) tree<-make.era.map(tree,c(0,25,50,75)) plot(tree,ftype="off",lwd=1) par(mar=c(5.1,4.1,4.1,2.1)) ## reset margins to default } \keyword{phylogenetics} \keyword{comparative method} phytools/man/branching.diffusion.Rd0000644000176200001440000000315214546011704017120 0ustar liggesusers\name{branching.diffusion} \alias{branching.diffusion} \title{Animation of branching random diffusion} \usage{ branching.diffusion(sig2=1, b=0.0023, time.stop=1000, ylim=NULL, smooth=TRUE, pause=0.02, record=NULL, path=NULL, ...) } \arguments{ \item{sig2}{variance of BM process, \eqn{\sigma^2}.} \item{b}{birthrate for branching process.} \item{time.stop}{number of generations to run.} \item{ylim}{\emph{y} limits (for plotting).} \item{smooth}{no longer used.} \item{pause}{pause (in s) between generations.} \item{record}{filename for video file output (no video if \code{NULL}).} \item{path}{full path to file for video rendering. (By default \code{branching.diffusion} will look for the executable \code{ffmpeg.exe} in the directory \code{C:/Program Files/ffmpeg/bin}, even though this will not make sense on non-Windows machines.)} \item{...}{optional arguments.} } \description{ This function creates an animation of branching random diffusion (i.e., Brownian motion evolution with speciation). } \details{ For animation to be recorded to file, the function requires the package \emph{animation} as well as a video renderer. } \value{ An animated plot and (optionally) a recorded video file. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{bmPlot}}, \code{\link{fastBM}} } \keyword{phylogenetics} \keyword{animation} \keyword{plotting} \keyword{simulation} \keyword{continuous character} phytools/man/plotBranchbyTrait.Rd0000644000176200001440000000622414546016465016647 0ustar liggesusers\name{plotBranchbyTrait} \alias{plotBranchbyTrait} \title{Plot branch colors by a quantitative trait or value} \usage{ plotBranchbyTrait(tree, x, mode=c("edges","tips","nodes"), palette="rainbow", legend=TRUE, xlims=NULL, ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{x}{either a vector of states for the edges, tips, or nodes of the tree (for \code{mode="edges"}, \code{"tips"}, and \code{"nodes"}, respectively).} \item{mode}{string indicating plotting mode. \code{mode="edges"}, the default, requires that the mapping state of each edge in the tree should be provided. \code{mode="tips"} takes the tip values and estimates the state at each internal node. The mapped character value along each branch is the average of the nodes subtending that branch. \code{mode="nodes"} similar to \code{"tips"}, except that the node values are provided instead of estimated.} \item{palette}{color palette to translate character values to color. Options are presently \code{"rainbow"} (the default), \code{"heat.colors"}, and \code{"gray"}. \code{palette} can also be a function produced by \code{\link{colorRampPalette}}.} \item{legend}{can be a logical value (\code{TRUE} or \code{FALSE}) or a numeric value greater than 0. In the latter case the numeric value gives the length of the plotted legend, which also acts as a scale bar for the branch lengths of the tree.} \item{xlims}{range for the translation map between trait values and the color map. Should be inclusive of all the values in \code{x}.} \item{...}{other optional arguments to be passed to \code{\link{plot.phylo}} - pretty much all arguments are available. In addition, there \code{plotBranchbyTrait} has the following additional optional arguments: \code{tol} a small tolerance value to be added to the range of \code{x}; \code{prompt} for \code{legend=TRUE}, a logical value indicating whether to prompt for the position of the legend (or not) - the default is to put the legend in the lower left hand size of the plot; \code{title} for \code{legend=TRUE}, the title of the legend; and \code{digits} for \code{legend=TRUE}, the number of digits in the quantitative scale of the legend. Finally, \code{cex} can be supplied as either a single numeric value, or as a vector of two different values. If the latter is true than the second element of \code{cex} will be passed internally to the function \code{\link{add.color.bar}}.} } \description{ Function plots a tree with branches colored by the value for a quantitative trait or probability, by various methods. } \details{ Unlike most other tree plotting functions in \pkg{phytools}, this function calls \code{\link{plot.phylo}} (not \code{plotSimmap}) internally. Note that if \code{prompt=TRUE}, the function will prompt for the position of the legend. } \value{ Plots a phylogeny. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{ancestral states} \keyword{phylogenetics} \keyword{plotting} \keyword{comparative method} \keyword{continuous character} phytools/man/to.matrix.Rd0000644000176200001440000000151214546020357015127 0ustar liggesusers\name{to.matrix} \alias{to.matrix} \title{Convert a character vector to a binary matrix} \usage{ to.matrix(x, seq) } \arguments{ \item{x}{a vector of characters.} \item{seq}{the sequence for the columns in the output matrix.} } \description{ Creates a binary matrix, normally from a factor. } \details{ This function takes a vector of characters or a factor and computes a binary matrix. Primarily designed to be used internally by \code{\link{make.simmap}} and \code{\link{rerootingMethod}}. } \value{ A binary matrix of dimensions \code{length(x)} by \code{length(seq)}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{utilities} phytools/man/edgeProbs.Rd0000644000176200001440000000255614546012516015123 0ustar liggesusers\name{edgeProbs} \alias{edgeProbs} \title{Compute the relative frequencies of state changes along edges} \usage{ edgeProbs(trees) } \arguments{ \item{trees}{an object of class \code{"multiSimmap"} containing a sample of trees that are identical in topology & branch lengths with different stochastically mapped character histories.} } \description{ Computes the relative frequencies of character state changes along edges from a sample of stochastically mapped character histories. } \details{ The function assumes that all trees in the sample differ only in their mapped histories & not at all in topology or branch lengths. Note that \code{edgeProbs} only asks whether the starting and ending states of the edge \emph{differ} in a particular way, and thus ignores multiple-hits along a single edge. } \value{ The object that is returned is a matrix with the state changes & the relative frequency of each state change. Rows are in the order of the matrix \code{edge} for any of the mapped trees. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{plotSimmap}} } \keyword{ancestral states} \keyword{phylogenetics} \keyword{plotting} \keyword{discrete character} phytools/man/getSisters.Rd0000644000176200001440000000250014546013322015326 0ustar liggesusers\name{getSisters} \alias{getSisters} \title{Get the sister node number, label, or set of nodes for a node or tip} \usage{ getSisters(tree, node, mode=c("number","label")) } \arguments{ \item{tree}{object of class \code{"phylo"}.} \item{node}{a node number, tip number, node label, or tip label.} \item{mode}{an optional string indicating whether to return the node or tip number(s) or the node or tip label(s), if applicable.} } \description{ Computes the sister taxon or node. } \details{ This function takes a tree and node or tip number of label and returns the number or label of the sister or sisters to that node or tip. } \value{ If \code{mode="number"} this function returns an integer or vector containing the node number of numbers of the sister node or tip. If \code{mode="label"} then this function returns a list containing up to two vectors: one for the node numbers of labels of sister nodes (if applicable); and the other containing the tip labels of the sister tips. } \seealso{ \code{\link{getDescendants}}, \code{\link{Siblings}} } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/gammatest.Rd0000644000176200001440000000211214546013237015160 0ustar liggesusers\name{gammatest} \alias{gammatest} \title{Gamma test of Pybus & Harvey (2000)} \usage{ gammatest(x) } \arguments{ \item{x}{an object of class \code{"ltt"} resulting from a call of the function \code{\link{ltt}}.} } \description{ Conducts \eqn{\gamma}-test of Pybus & Harvey (2000). } \value{ A an object of class \code{"gammatest"} consisting of a list that contains: \item{gamma}{a value for the \eqn{\gamma}-statistic.} \item{p}{two-tailed P-value for the \eqn{\gamma}-test.} } \references{ Pybus, O. G., and P. H. Harvey (2000) Testing macro-evolutionary models using incomplete molecular phylogenies. \emph{Proc. R. Soc. Lond. B}, \bold{267}, 2267-2272. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ltt}}, \code{\link{mccr}} } \examples{ data(darter.tree) gammatest(ltt(darter.tree,plot=FALSE)) } \keyword{phylogenetics} \keyword{comparative method} \keyword{diversification} phytools/man/ancThresh.Rd0000644000176200001440000001056414546011330015117 0ustar liggesusers\name{ancThresh} \alias{ancThresh} \title{Ancestral character estimation under the threshold model using Bayesian MCMC} \usage{ ancThresh(tree, x, ngen=100000, sequence=NULL, method="mcmc", model=c("BM","OU","lambda"), control=list(), ...) } \arguments{ \item{tree}{phylogenetic tree.} \item{x}{a named vector containing discrete character states; or a matrix containing the tip species, in rows, and probabilities of being in each state, in columns.} \item{ngen}{number of generations to run the MCMC.} \item{sequence}{assumed ordering of the discrete character state. If not supplied and \code{x} is a vector then numerical/alphabetical order is assumed; if not supplied and \code{x} is a matrix, then the column order of \code{x} is used.} \item{method}{only method currently available is \code{"mcmc"}.} \item{model}{model for the evolution of the liability. Options are \code{"BM"} (Brownian motion, the default), \code{"OU"} (Ornstein-Uhlenbeck), or \code{"lambda"} (the \eqn{\lambda} model).} \item{control}{list containing the following elements: \code{sample}, the sampling interval; \code{propliab} variance of the proposal distribution for liabilities; \code{propthresh} variance on the proposal distribution for the thresholds; \code{propalpha} variance on the proposal distribution for \code{alpha} (for \code{model="OU"}); \code{pr.anc} prior probability distribution on the ancestral states for each node, in a matrix - not all nodes need to be supplied; \code{pr.th} prior density on the thresholds; \code{burnin} number of generations to exclude for burn-in when plotting posterior probabilities on the tree; \code{plot} logical value indicating whether or not to plot the posterior probabilities; \code{print} logical value indicating whether or not to print the state of the MCMC; \code{piecol} colors for the posterior probabilities plotted as pie charts at internal nodes; and \code{tipcol} which indicates whether the tip colors should be based on the input data (\code{"input"}) or sampled tip liabilities (\code{"estimated"}). These will only differ if there is uncertainty in the tip states.} \item{...}{additional arguments to be passed to \code{\link{plotThresh}} (called internally).} } \description{ This function uses Bayesian MCMC to estimate ancestral states and thresholds for a discrete character under the threshold model from quantitative genetics (Felsenstein 2012). } \details{ According to the threshold model from evolutionary quantitative genetics, values for our observed discrete character are determined by an unseen continuous trait, normally referred to as liability. Every time the value for liability crosses a threshold, the observed discrete character changes in state. Felsenstein (2012) first had the insight that this model could be used to study the evolution of discrete character traits on a reconstructed phylogenetic tree. This function uses Bayesian MCMC to sample ancestral liabilities and thresholds for a discrete character evolution under the threshold model. \code{print} and \code{plot} S3 methods are now available for the object class \code{"ancThresh"}. } \value{ This function returns an object of class \code{"ancThresh"} containing the posterior sample from our analysis, along with other components. } \references{ Felsenstein, J. (2012) A comparative method for both discrete and continuous characters using the threshold model. \emph{American Naturalist}, \bold{179}, 145-156. Revell, L. J. (2014) Ancestral character estimation under the threshold model from quantitative genetics. \emph{Evolution}, \bold{68}, 743-759. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{anc.Bayes}}, \code{\link{threshBayes}} } \examples{ \dontrun{ ## load data from Revell & Collar (2009) data(sunfish.tree) data(sunfish.data) ## extract character of interest fmode<-setNames(sunfish.data$feeding.mode, rownames(sunfish.data)) ## run MCMC mcmc<-ancThresh(sunfish.tree,fmode,ngen=1000000) ## plot results plot(mcmc,mar=c(0.1,0.1,4.1,0.1)) title(main="Posterior probabilities for node states", font.main=3)} } \keyword{ancestral states} \keyword{phylogenetics} \keyword{comparative method} \keyword{bayesian} \keyword{discrete character} phytools/man/consensus.edges.Rd0000644000176200001440000000322614546012056016311 0ustar liggesusers\name{consensus.edges} \alias{consensus.edges} \title{Compute consensus edges for a tree under some criterion} \usage{ consensus.edges(trees, method=c("mean.edge","least.squares"), ...) } \arguments{ \item{trees}{object of class \code{"multiPhylo"} in which the trees must have edge lengths. This could be, for instance, a sample from the posterior distribution of trees in a Bayesian analysis.} \item{method}{method for computing the edge lengths. Could be the mean of all trees in which the edge is present, or it could be the least-squares edge lengths computed on the mean patristic distance matrices from the input phylogenies in \code{trees}. Note that in the latter case the \pkg{phangorn} function \code{nnls.tree} is used and the option \code{rooted} will be set to \code{is.rooted(tree)} for the consensus tree.} \item{...}{optional arguments, the most popular of which is \code{consensus.tree} - a user supplied consensus tree. Another optional argument for \code{method="mean.edge"} is \code{if.absent} which tells the function how to include absent edges in the computation of average edge lengths. Possible values are \code{"zero"} (the default) or \code{"ignore"}.} } \description{ Computes consensus edge lengths from a set of input trees using multiple methods. } \value{ An object of class \code{"phylo"} with edge lengths. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{consensus tree} \keyword{phylogeny inference} \keyword{utilities} phytools/man/rotateNodes.Rd0000644000176200001440000000403114546017464015475 0ustar liggesusers\name{rotateNodes} \alias{rotateNodes} \alias{rotate.multi} \alias{allRotations} \title{Rotates a node or set of nodes in a phylogenetic tree} \usage{ rotateNodes(tree, nodes, polytom=c(1,2), ...) rotate.multi(tree, node) allRotations(tree) } \arguments{ \item{tree}{object of class \code{"phylo"}.} \item{nodes}{either a single node number to rotate, a vector of node numbers, or the string \code{"all"}.} \item{polytom}{a vector of mode numeric and length two specifying the two clades that should be exchanged in a polytomy (see \code{\link{rotate}}).} \item{node}{a single node to rotate (in the case of \code{rotate.multi}).} \item{...}{optional arguments.} } \description{ The function \code{rotateNodes} is a simple wrapper for \code{\link{rotate}} which rotates a set of nodes or all nodes. The function \code{rotate.multi} finds all possible rotations around a multifurcating node, given by \code{node}. This will be an object of class \code{"multiPhylo"}, assuming that the node specified is indeed a multifurcation. The function \code{allRotations} computes all possible rotated trees for a given input phylogeny. For a binary tree, this is generally two raised to the power of the number of internal nodes (so a very large number, if \emph{N} is even modest in size). } \details{ All three functions also address the problem that the product of multiple rotations from \code{\link{rotate}} can be non-compliant with the implicit \code{"phylo"} standard because the tip numbers in \code{tree$edge} are not in numerical order \code{1:n} for \code{n} tips. } \value{ An object of class \code{"phylo"} (i.e., a phylogenetic tree), in the case of \code{rotateNodes}, or an object of class \code{"multiPhylo"} for \code{rotate.multi} or \code{allRotations}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/evol.rate.mcmc.Rd0000644000176200001440000000626414546012661016027 0ustar liggesusers\name{evol.rate.mcmc} \alias{evol.rate.mcmc} \alias{print.evol.rate.mcmc} \alias{summary.evol.rate.mcmc} \alias{print.summary.evol.rate.mcmc} \alias{plot.summary.evol.rate.mcmc} \title{Bayesian MCMC method for identifying exceptional phenotypic diversification in a phylogeny} \usage{ evol.rate.mcmc(tree, x, ngen=10000, control=list(), ...) \method{print}{evol.rate.mcmc}(x, ...) \method{summary}{evol.rate.mcmc}(object, ...) \method{print}{summary.evol.rate.mcmc}(x, ...) \method{plot}{summary.evol.rate.mcmc}(x, ...) } \arguments{ \item{tree}{an object of class \code{"phylo"} (a phylogenetic tree).} \item{x}{a vector of tip values for species in which \code{names(x)} contains the species names of \code{tree}, an object of class \code{"evol.rate.mcmc"}, or (in the case of the S3 \code{summary} method) an object of class \code{"summary.evol.rate.mcmc"}.} \item{ngen}{an integer value indicating the number of generations for the MCMC.} \item{control}{a list of control parameters containing the following elements: \code{sig1}: starting value for \eqn{\sigma_1^2}; \code{sig2}: starting value for \eqn{\sigma_2^2}; \code{a}: starting value for a; \code{sd1}: standard deviation for the normal proposal distribution for \eqn{\sigma_1^2}; \code{sd2}: standard deviation for the normal proposal distribution for \eqn{\sigma_2^2}; \code{kloc}: scaling parameter for tree move proposals - \eqn{1/\lambda} for the reflected exponential distribution; \code{sdlnr}: standard deviation on the log-normal prior on \eqn{\sigma_1^2/\sigma_2^2}; \code{rand.shift}: probability of proposing a random shift in the tree (improves mixing); \code{print}: print frequency for the MCMC; \code{sample}: sample frequency.} \item{object}{for the S3 \code{summary} method, an object of class \code{"evol.rate.mcmc"}.} \item{...}{other optional arguments.} } \description{ Estimates the phylogenetic location of a \emph{single} rate shift on the tree using Bayesian MCMC (as described in Revell et al., 2012b). } \details{ This function takes a phylogenetic tree and data for a single continuously valued character and uses a Bayesian MCMC approach to identify the phylogenetic location of a shift in the evolutionary rate through time. Default values of \code{control} are given in Revell et al. (2012b). } \value{ An object of class \code{"evol.rate.mcmc"} consisting of at least the following elements: \item{mcmc}{results from the MCMC run.} \item{tips}{list of tips in rate \eqn{\sigma_1^2} for each sampled generation of MCMC (to polarize the rate shift).} } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. Revell, L. J., D. L. Mahler, P. Peres-Neto, and B. D. Redelings (2012) A new method for identifying exceptional phenotypic diversification. \emph{Evolution}, \bold{66}, 135-146. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{anc.Bayes}}, \code{\link{brownie.lite}}, \code{\link{evol.vcv}}, \code{\link{minSplit}}, \code{\link{posterior.evolrate}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{bayesian} \keyword{continuous character} phytools/man/densityTree.Rd0000644000176200001440000000473614546012333015507 0ustar liggesusers\name{densityTree} \alias{densityTree} \alias{make.transparent} \title{Plots a posterior sample of trees} \usage{ densityTree(trees, colors="blue", alpha=NULL, method="plotTree", fix.depth=FALSE, use.edge.length=TRUE, compute.consensus=TRUE, use.gradient=FALSE, show.axis=TRUE, ...) make.transparent(color, alpha) } \arguments{ \item{trees}{an object of class \code{"multiPhylo"} or \code{"multiSimmap"}.} \item{colors}{a color or a named vector of colors in which names correspond to mapped states in an object of class \code{"multiSimmap"}.} \item{alpha}{transparency level for plotted trees which is passed to internally used function, \code{make.transparent}. (\code{0} is fully transparent, which \code{1} is fully opaque.) By default will be one divided by the number of trees.} \item{method}{plotting method to be used internally. Can be \code{"plotTree"} or \code{"plotSimmap"}.} \item{fix.depth}{logical value indicating whether or not to plot trees with a fixed depth or to permit plotted trees to have different depths.} \item{use.edge.length}{logical value indicating whether to use the edge lengths of the input tree. Defaults to \code{use.edge.length=TRUE} unless any input tree edge lengths are \code{NULL}.} \item{compute.consensus}{logical value indicating whether or not to use the tip order from a consensus tree. (Defaults to \code{compute.consensus=TRUE} Defaulted to \code{FALSE} in earlier version of this function.)} \item{use.gradient}{logical value indicating whether to plot all trees slightly offset using a rainbow color gradient. (Defaults to \code{use.gradient=FALSE}.)} \item{show.axis}{logical value indicating whether or not to include a horizontal axis in the plot.} \item{...}{arguments to be passed to \code{plotTree} or \code{plotSimmap}. Some may be ignored if they are incompatible with the method.} \item{color}{in \code{make.transparent}, the color (or colors in a vector) to render transparent.} } \description{ Functions plots a posterior sample of trees, including with mapped discrete characters. \code{make.transparent} is used internally and converts a color to transparent with a certain user-specified \code{alpha} level. } \value{ Function creates a plot. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{plotting} phytools/man/contMap.Rd0000644000176200001440000001363114546015174014611 0ustar liggesusers\name{contMap} \alias{contMap} \alias{plot.contMap} \alias{errorbar.contMap} \title{Map continuous trait evolution on the tree} \usage{ contMap(tree, x, res=100, fsize=NULL, ftype=NULL, lwd=4, legend=NULL, lims=NULL, outline=TRUE, sig=3, type="phylogram", direction="rightwards", plot=TRUE, ...) \method{plot}{contMap}(x, ...) errorbar.contMap(obj, ...) } \arguments{ \item{tree}{object of class \code{"phylo"}.} \item{x}{a numerical vector of phenotypic trait values for species. \code{names(x)} should contain the species names and match \code{tree$tip.label}. Or, for \code{plot.contMap}, an object of class \code{"contMap"}.} \item{res}{resolution for gradient plotting. Larger numbers (to a point) indicate a finer (smoother) gradient.} \item{fsize}{relative font size - can be a vector of length 2 in which the first element gives the font size for the tip labels & the second element giving the font size for the legend.} \item{ftype}{font type - see options in \code{\link{plotSimmap}}. As with \code{fsize}, this can be a vector with the second element giving font type for the legend.} \item{lwd}{line width for branches. Can be a single integer number or a vector. In the latter case, the second number will be taken to be the desired legend width.} \item{legend}{if \code{FALSE} no legend is plotted; if a numeric value, it gives the length of the legend in units of branch length. Default is 0.5 times the total tree length.} \item{lims}{range for the color map. By default, this will be \code{c(min(x),max(x))}, and should always include this range.} \item{outline}{logical value indicating whether or not to outline the branches of the tree in black.} \item{sig}{the number of decimal places to show on the legend limits.} \item{type}{type of plot desired. Options are \code{"phylogram"} for a rightward square phylogram; and \code{"fan"} for a circular phylogram.} \item{direction}{plotting direction for \code{type="phylogram"}.} \item{plot}{logical value indicating whether or not to plot the tree. If \code{plot=FALSE} then an object of class \code{"contMap"} will be returned without plotting.} \item{obj}{object of class \code{"contMap"}.} \item{...}{optional arguments for \code{plot.contMap} which include all the arguments of \code{contMap} except for \code{tree}, \code{x}, \code{res}, and \code{lims}. Also \code{method}, \code{"fastAnc"}, \code{"anc.ML"}, or \code{"user"} (for user-supplied states) specifying which function to use for ancestral state estimation; \code{hold} specifies whether or not to hold output to graphical device before plotting (defaults to \code{hold=TRUE}); and \code{anc.states} a vector containing some or multiple ancestral user-supplied ancestral states at nodes. Some other plotting arguments, such as \code{xlim} and \code{ylim}, may also work. Optional arguments for \code{errorbar.contMap} include \code{x}, a vector containing the original trait values mapped onto the tree (otherwise these will be obtained from \code{obj}), \code{scale.by.ci}, a logical argument (defaulting to \code{TRUE}) that determines whether or not the length of the error bars will be scaled by the CI width, and \code{lwd}, which determines the line width of the plotted error bars.} } \description{ Projects the observed and reconstructed values of a continuous trait onto the edges of a tree using a color gradient. } \details{ Function plots a tree with a mapped continuous character. The mapping is accomplished by estimating states at internal nodes using ML with \code{\link{fastAnc}}, and then interpolating the states along each edge using equation [2] of Felsenstein (1985). This makes these interpolated values equal to the maximum likelihood estimates under a Brownian evolutionary process. The default color palette is \emph{not} recommended as it is not colorblind friendly and does not render well into gray scale; however, this can be updated using the helper function \code{\link{setMap}}. \code{errorbar.contMap} adds error bars to an existing plot. } \value{ Plots a tree. An object of class \code{"contMap"} is returned invisibly. \code{errorbar.contMap} adds colorful error bars to a plotted tree. } \references{ Felsenstein, J. (1985) Phylogenies and the comparative method. \emph{American Naturalist}, \bold{125}, 1-15. Revell, L. J. (2013) Two new graphical methods for mapping trait evolution on phylogenies. \emph{Methods in Ecology and Evolution}, \bold{4}, 754-759. Revell, L. J. (2014) Graphical methods for visualizing comparative data on phylogenies. Chapter 4 in \emph{Modern phylogenetic comparative methods and their application in evolutionary biology: Concepts and practice} (L. Z. Garamszegi ed.), pp. 77-103. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. Revell, L. J., K. Schliep, E. Valderrama, and J. E. Richardson (2018) Graphs in phylogenetic comparative analysis: Anscombe's quartet revisited. \emph{Methods in Ecology and Evolution}, \bold{9}, 2145-2154. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{anc.ML}}, \code{\link{densityMap}}, \code{\link{fastAnc}}, \code{\link{plotSimmap}} } \examples{ ## load data from Garland et al. (1992) data(mammal.tree) data(mammal.data) ## extract character of interest ln.bodyMass<-log(setNames(mammal.data$bodyMass, rownames(mammal.data))) ## create "contMap" object mammal.contMap<-contMap(mammal.tree, ln.bodyMass,plot=FALSE,res=200) ## change color scheme mammal.contMap<-setMap(mammal.contMap, c("white","#FFFFB2","#FECC5C","#FD8D3C", "#E31A1C")) plot(mammal.contMap,fsize=c(0.7,0.8), leg.txt="log(body mass)") par(mar=c(5.1,4.1,4.1,2.1)) ## reset margins to default } \keyword{ancestral states} \keyword{phylogenetics} \keyword{plotting} \keyword{comparative method} \keyword{continuous character} \keyword{maximum likelihood} phytools/man/fastMRCA.Rd0000644000176200001440000000307414546013031014576 0ustar liggesusers\name{fastMRCA} \alias{fastMRCA} \alias{fastHeight} \alias{fastDist} \title{Get the MRCA (or height above the root of the MRCA) of a pair of tip taxa} \usage{ fastMRCA(tree, sp1, sp2) fastHeight(tree, sp1, sp2) fastDist(tree, sp1, sp2) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{sp1}{species one name.} \item{sp2}{species two name.} } \description{ Finds the most recent common ancestor (MRCA) for a pair of tip taxa. } \details{ Function (\code{fastMRCA}) returns the most recent common ancestor (node number) for a pair of taxa; or, in the case of \code{fastHeight}, the height above the root of the MRCA of a pair of taxa; or, in the case of \code{fastDist}, the patristic distance between a pair of taxa. This function is mostly redundant with \code{\link{findMRCA}} (or \code{findMRCA(...,type="height")} in the case of \code{fastHeight}), but for very large trees will be considerably faster. (Also see \code{\link{getMRCA}} in the \pkg{ape} package.) } \value{ The node number of the MRCA, the height above the root (for \code{fastHeight}), or the patristic distance between two taxa (for \code{fastDist}). } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{getMRCA}}, \code{\link{findMRCA}}, \code{\link{mrca}} } \examples{ tree<-pbtree(n=2000) anc<-fastMRCA(tree,"t1","t15") } \keyword{phylogenetics} \keyword{utilities} phytools/man/getStates.Rd0000644000176200001440000000176114546013417015152 0ustar liggesusers\name{getStates} \alias{getStates} \title{Get the states at nodes or tips from a mapped tree} \usage{ getStates(tree, type=c("nodes","tips","both")) } \arguments{ \item{tree}{is a modified object of class \code{"phylo"} or \code{"multiPhylo"}.} \item{type}{mode indicating whether to get states at the nodes (\code{type="nodes"}) or the tips (\code{type="tips"}) of the tree.} } \description{ Gets the states from the nodes or tips of a mapped tree (e.g., \code{\link{make.simmap}}). } \value{ A named vector (for \code{"phylo"}) or matrix (for \code{"multiPhylo"}). } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{describe.simmap}}, \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{sim.history}} } \keyword{phylogenetics} \keyword{utilities} \keyword{discrete character} phytools/man/dotTree.Rd0000644000176200001440000000567314546012376014626 0ustar liggesusers\name{dotTree} \alias{dotTree} \alias{dot.legend} \title{Creates a phylogenetic dot plot} \usage{ dotTree(tree, x, legend=TRUE, method="plotTree", standardize=FALSE, ...) dot.legend(x, y, min, max, Ntip, length=5, prompt=FALSE, method="plotTree", ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{x}{vector of trait values; or a matrix. If \code{x} is a vector it must have names that correspond to the tip labels of \code{tree}. If \code{x} is a matrix (and it probably should be a \emph{matrix}, not a data frame) then the row names of the matrix should correspond to the tip labels of the phylogeny. In the case of \code{dot.legend}, the \emph{x} coordinate of the legend.} \item{legend}{logical value indicating whether or not a legend should be plotted.} \item{method}{tree plotting method to be used internally. Will switch to \code{method="phylogram"} if the number of traits is greater than one. For \code{dot.legend}, it should be the method that was used for the plot.} \item{standardize}{a logical value indicating whether or not to standardize \code{x}, or each column of \code{x}, to have a mean of zero & variance of one prior to analysis.} \item{y}{\emph{y} coordinate of the legend.} \item{min}{minimum value for \code{dot.legend}.} \item{max}{maximum value for \code{dot.legend}.} \item{Ntip}{number of tips in the plotted tree for \code{dot.legend}.} \item{length}{length of legend.} \item{prompt}{logical value indicating whether or not to prompt for legend position.} \item{...}{optional arguments. In the case of \code{dotTree}, these will be passed to \code{\link{plotTree}} or a different internally used plotting function for \code{method="phylogram"}. See \code{\link{phylo.heatmap}} for more detail on these arguments. Other option for \code{dotTree} also include \code{data.type} (\code{"continuous"} or \code{"discrete"}), \code{colors}, \code{length}, for data type \code{"continuous"} the length of the legend in terms of plotted circles, \code{x.space}, the spacing of the columns in the plotted data matrix, and \code{leg.space}, the spacing of the legend dots (again, for \code{data.type="continuous"} only).} } \description{ Creates a plot in which different sized dots/circles represent different tip values for a quantitative trait. } \value{ Function creates a plot. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \examples{ ## load data from Garland et al. (1992) data(mammal.tree) data(mammal.data) ## log-transform trait data log.mammal<-log(mammal.data) ## plot dotTree dotTree(mammal.tree,log.mammal,fsize=0.7, standardize=TRUE,length=10) par(mar=c(5.1,4.1,4.1,2.1)) ## reset margins to default } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{plotting} \keyword{continuous character} \keyword{discrete character} phytools/man/phyl.pca.Rd0000644000176200001440000000651014546016030014714 0ustar liggesusers\name{phyl.pca} \alias{phyl.pca} \alias{biplot.phyl.pca} \alias{scores} \alias{scores.phyl.pca} \alias{as.princomp} \alias{as.prcomp} \title{Phylogenetic principal components analysis} \usage{ phyl.pca(tree, Y, method="BM", mode="cov", ...) \method{biplot}{phyl.pca}(x, ...) scores(object, ...) \method{scores}{phyl.pca}(object, ...) as.princomp(x, ...) as.prcomp(x, ...) } \arguments{ \item{tree}{phylogeny as an object of class \code{"phylo"}.} \item{Y}{data matrix with traits in columns.} \item{method}{method to obtain the correlation structure: can be \code{"BM"} or \code{"lambda"}.} \item{mode}{is the mode for the PCA: can be \code{"cov"} or \code{"corr"}.} \item{x}{object of class \code{"phyl.pca"} for \code{biplot}, \code{as.princomp}, and \code{as.prcomp} methods.} \item{object}{object of class \code{"phyl.pca"} for \code{scores} method.} \item{...}{for S3 plotting method \code{biplot.phyl.pca}, other arguments to be passed to \code{\link{biplot}}.} } \description{ This function performs phylogenetic PCA following Revell (2009). } \details{ If \code{method="lambda"} then \eqn{\lambda} will be optimized on the interval (0,1) using \code{\link{optimize}}. Optimization method can be set using the option \code{opt} which can take values \code{"ML"}, \code{"REML"}, or \code{"fixed"}. If the last of these is selected than the user should also specify a value of \eqn{\lambda} to use via the argument \code{lambda}. S3 methods (\code{print}, \code{summary}, and \code{biplot}) are modified from code provided by Joan Maspons and are based on the same methods for objects of class \code{"prcomp"}. Function \code{biplot} now permits the argument \code{choices} to be supplied, which should be a vector of length two indicated the two PC axes to be plotted. S3 method \code{scores} extracts or computes (for a matrix of \code{newdata}) PC scores given an object of class \code{"phyl.pca"}. S3 methods \code{as.prcomp} and \code{as.princomp} convert the object of class \code{"phyl.pca"} to objects of class \code{"prcomp"} and \code{"princomp"}, respectively. } \value{ An object of class \code{"phyl.pca"} consisting of a list with some or all of the following elements: \item{Eval}{diagonal matrix of eigenvalues.} \item{Evec}{matrix with eigenvectors in columns.} \item{S}{matrix with scores.} \item{L}{matrix with loadings.} \item{lambda}{fitted value of \eqn{\lambda} (\code{method="lambda"} only).} \item{logL}{log-likelihood for \eqn{\lambda} model (\code{method="logL"} only).} } \references{ Revell, L. J. (2009) Size-correction and principal components for interspecific comparative studies. \emph{Evolution}, \bold{63}, 3258-3268. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}, Joan Maspons} \seealso{ \code{\link{phyl.cca}}, \code{\link{phyl.resid}}, \code{\link{prcomp}}, \code{\link{princomp}} } \examples{ ## load data from Mahler et al. (2010) data(anoletree) data(anole.data) ## run phylogenetic PCA anole.pca<-phyl.pca(anoletree,anole.data) print(anole.pca) ## plot results plot(anole.pca) biplot(anole.pca) } \keyword{phylogenetics} \keyword{maximum likelihood} \keyword{comparative method} \keyword{statistics} phytools/man/starTree.Rd0000644000176200001440000000136014546020002014757 0ustar liggesusers\name{starTree} \alias{starTree} \title{Create star phylogeny} \usage{ starTree(species, branch.lengths=NULL) } \arguments{ \item{species}{a list of species.} \item{branch.lengths}{an optional list of branch lengths in the same order as \code{species}.} } \description{ Creates a star phylogeny. } \details{ Creates a star phylogeny with (optionally) user specified branch lengths. } \value{ An object of class \code{"phylo"}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{stree}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/untangle.Rd0000644000176200001440000000237114546020407015017 0ustar liggesusers\name{untangle} \alias{untangle} \title{Attempts to untangle crossing branches for plotting} \usage{ untangle(tree, method=c("reorder","read.tree")) } \arguments{ \item{tree}{tree as an object of class \code{"phylo"} or \code{"simmap"}.} \item{method}{method to use to attempt to untangle branches. \code{method="reorder"} uses two calls of \code{\link{reorder.phylo}} or \code{\link{reorderSimmap}}; \code{method="read.tree"} writes the tree to a text string and then reads it back into memory using \code{\link{read.tree}}.} } \description{ Attempts to "untangle" the branches of a tree that are tangled when plotting with \code{\link{plot.phylo}}, \code{\link{plotTree}}, or \code{\link{plotSimmap}}. } \details{ Generally speaking, this function is wraps several different internal functions that might be use to fix a badly conformed \code{"phylo"} or \code{"simmap"} object. } \value{ An object of class \code{"phylo"} or \code{"simmap"}, depending on the class of \code{tree}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/as.multiPhylo.Rd0000644000176200001440000000170214546011400015740 0ustar liggesusers\name{as.multiPhylo} \alias{as.multiPhylo} \alias{as.multiPhylo.multiSimmap} \alias{as.multiPhylo.phylo} \title{Conversion to object of class \code{"multiPhylo"}} \usage{ as.multiPhylo(x, ...) \method{as.multiPhylo}{multiSimmap}(x, ...) \method{as.multiPhylo}{phylo}(x, ...) } \arguments{ \item{x}{object to be converted to \code{"multiPhylo"}. Presently an object of class \code{"multiSimmap"}, or an object of class \code{"phylo"}. In the latter case an object of class \code{"multiPhylo"} with length \code{1} is generated.} \item{...}{optional arguments.} } \description{ This function converts between object classes. } \value{ An object of class \code{"multiPhylo"}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/ls.tree.Rd0000644000176200001440000000140014546013512014545 0ustar liggesusers\name{ls.tree} \alias{ls.tree} \title{Least squares branch lengths for a given tree} \usage{ ls.tree(tree, D) } \arguments{ \item{tree}{phylogeny.} \item{D}{distance matrix.} } \description{ Computes the least squares branch lengths conditioned on a topology and distance matrix. } \details{ Generally intended as a function to be used internally by \code{\link{optim.phylo.ls}}. } \value{ A tree with branch lengths. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{phylogeny inference} \keyword{least squares} \keyword{consensus tree} phytools/man/aic.w.Rd0000644000176200001440000000223214546011042014172 0ustar liggesusers\name{aic.w} \alias{aic.w} \title{Computes Akaike weights} \usage{ aic.w(aic) } \arguments{ \item{aic}{vector of Akaike Information Criterion (AIC; Akaike, 1974) values for different fitted models. If the vector has names, these names will be inherited by the vector returned by the function.} } \description{ Computes Akaike weights based on a set of AIC values. } \details{ This function computes Akaike weights from a set of AIC values obtained from fitted models. It returns an object of class \code{"aic.w"} which is just a vector which allows it to be automatically printed with a numerical precision of 8 significant digits. } \value{ A vector of Akaike weights. } \references{ Akaike, H. (1974) A new look at the statistical model identification. \emph{IEEE Transactions on Automatic Control}, \bold{19}, 716-723. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{statistics} \keyword{utilities} \keyword{math} \keyword{maximum likelihood} \keyword{information criteria} phytools/man/bind.tree.simmap.Rd0000644000176200001440000000202514546011621016333 0ustar liggesusers\name{bind.tree.simmap} \alias{bind.tree.simmap} \title{Binds two trees of class \code{"simmap"}} \usage{ bind.tree.simmap(x, y, where="root") } \arguments{ \item{x}{an object of class \code{"simmap"}. (The receptor tree.)} \item{y}{an object of class \code{"simmap"}. (The tree being grafted.)} \item{where}{node number to attach new tip, or the root node if \code{where="root"}.} } \description{ This function grafts tree \code{y} onto tree \code{x} at node \code{where}. } \details{ This function wraps around \code{\link{bind.tree}} for objects of class \code{"simmap"}; however it presently only allows \code{y} to be grafted at a node of \code{x} and it does not allow \code{y} to possess a root edge. } \value{ An object of class \code{"simmap"}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/cospeciation.Rd0000644000176200001440000000473014546012172015663 0ustar liggesusers\name{cospeciation} \alias{cospeciation} \alias{plot.cospeciation} \alias{print.cospeciation} \title{Conducts a statistical test of cospeciation between two trees} \usage{ cospeciation(t1, t2, distance=c("RF","SPR"), method=c("simulation","permutation"), assoc=NULL, nsim=100, ...) \method{plot}{cospeciation}(x, ...) \method{print}{cospeciation}(x, ...) } \arguments{ \item{t1}{object of class \code{"phylo"}.} \item{t2}{object of class \code{"phylo"}.} \item{distance}{distance method to compare trees.} \item{method}{method to use (simulation of pure-birth trees, or permutation of tip labels on a fixed tree) to obtain a null distribution of tree distances via \code{distance}.} \item{assoc}{matrix containing the tip labels in \code{t1} to match to the tip labels in \code{t2}. Note that not all labels in either tree need to be included; however, unlike \code{cophylo}, one label in \code{t1} cannot be matched with more than one label in \code{t2}, nor vice versa. If \code{NULL} then an exact match of tip labels will be sought.} \item{nsim}{number of simulations or permutations.} \item{x}{for \code{plot} and \code{print} methods, an object of class \code{"cospeciation"}.} \item{...}{optional arguments.} } \description{ Test for cospeciation based on tree distance. } \details{ This function conducts a test for cospeciation based on tree distance, applying a distance metric selected by the user. Note that this method should be prone to be quite liberal as the null hypothesis is \emph{no similarity whatsoever} between the two trees! } \value{ An object of class \code{"cospeciation"}, which includes the test-statistic, the null distribution, and a p-value for the test of the null hypothesis of no topological similarity between the two trees. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{cophylo}} } \examples{ ## load data from Lopez-Vaamonde et al. (2001) data(wasp.trees) data(wasp.data) ## test for cospeciation wasp.cosp<-cospeciation(wasp.trees[[1]],wasp.trees[[2]], assoc=wasp.data) print(wasp.cosp) plot(wasp.cosp) title(main=paste("Simulated distribution of RF distances\n", "between unassociated trees"),font.main=3) } \keyword{phylogenetics} \keyword{plotting} \keyword{diversification} \keyword{co-phylogenetics} phytools/man/collapseTree.Rd0000644000176200001440000000274214546012031015620 0ustar liggesusers\name{collapseTree} \alias{collapseTree} \title{Interactive tree visualizer} \usage{ collapseTree(tree, ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{...}{optional arguments. These \emph{mostly} match the arguments of \code{\link{plotSimmap}}, but also include the argument \code{drop.extinct=TRUE} which will (if the input tree is ultrametric) drop any 'extinct' lineages from the tree that is returned by the function.} } \description{ Function creates an interactive visualization of collapsing & expanding clades on the tree. } \details{ Function first plots a fan style tree, and then the user collapses node on the tree by clicking on them. Collapsed nodes are collapsed to the common ancestor of the clade. Nodes that have been collapsed can also be expanded by clicking. Right-click (or select Finish button in \pkg{RStudio}) to end. Note, for the animation to work probably when run in the \pkg{RStudio} IDE the "zoom" level should be set to 100\%. } \value{ Returns the final plotted tree. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{plotTree}}, \code{\link{plotSimmap}} } \examples{ \dontrun{ data(liolaemid.tree) pruned<-collapseTree(liolaemid.tree,fsize=0.5)} } \keyword{phylogenetics} \keyword{plotting} \keyword{utilities} phytools/man/genSeq.Rd0000644000176200001440000000271614546013250014425 0ustar liggesusers\name{genSeq} \alias{genSeq} \title{Simulate a DNA alignment on the tree under a model} \usage{ genSeq(tree, l=1000, Q=NULL, rate=1, format="DNAbin", ...) } \arguments{ \item{tree}{object of class \code{"phylo"}.} \item{l}{length of desired sequences.} \item{Q}{transition matrix for the simulation. Row and column names (\code{c("a","c","g","t")}, although not necessarily in that order) should be provided. If \code{NULL}, a single rate is assumed.} \item{rate}{multiplier for \code{Q}, or a vector for \eqn{\Gamma} rate heterogeneity.} \item{format}{format of the output object. Can be \code{"DNAbin"}, \code{"phyDat"}, or \code{"matrix"}.} \item{...}{optional arguments.} } \description{ Simulates DNA sequence on \code{tree} under the specified model. } \details{ Uses \code{\link{sim.Mk}} internally. } \value{ An object of class \code{"DNAbin"} or \code{"phyDat"}, or a matrix of nucleotides. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \examples{ data(mammal.tree) mammal.tree$edge.length<-mammal.tree$edge.length/ max(nodeHeights(mammal.tree))*0.2 ## rescale tree ## simulate gamma rate heterogeneity gg<-rgamma(n=100,shape=0.25,rate=0.25) dna<-genSeq(mammal.tree,l=100,rate=gg) } \keyword{phylogenetics} \keyword{simulation} \keyword{discrete character} phytools/man/optim.phylo.ls.Rd0000644000176200001440000000434414546014116016103 0ustar liggesusers\name{optim.phylo.ls} \alias{optim.phylo.ls} \title{Phylogeny inference using the least squares method} \usage{ optim.phylo.ls(D, stree=NULL, set.neg.to.zero=TRUE, fixed=FALSE, tol=1e-10, collapse=TRUE) } \arguments{ \item{D}{a distance matrix.} \item{stree}{an optional starting tree for the optimization.} \item{set.neg.to.zero}{a logical value indicating whether to set negative branch lengths to zero (default \code{TRUE}).} \item{fixed}{a logical value indicating whether to estimate the topology - if \code{TRUE} only the branch lengths will be computed.} \item{tol}{a tolerance value used to assess whether the optimization has converged.} \item{collapse}{ a logical indicating whether to collapse branches with zero length.} } \description{ Phylogenetic inference using the method of least-squares (Cavalli-Sforza & Edwards, 1967). } \details{ Function uses \code{\link{nni}} from the \pkg{phangorn} package (Schliep 2011) to conduct NNIs for topology estimation. Since topology optimization is performed using NNIs, convergence to the true least-squares topology is not guaranteed. It is consequently probably wise to start with a very good tree - such as a NJ tree. } \value{ An object of class \code{"phylo"} that (may be) the least-squares tree with branch lengths; also returns the sum of squares in \code{attr(tree,"Q-score")}. } \references{ Cavalli-Sforza, L. L., and A. W. F. Edwards. (1967) Phylogenetic analysis: Models and estimation procedures. \emph{American Journal of Human Genetics}, \bold{19}, 233-257. Felsenstein, J. (2004) \emph{Inferring Phylogenies}. Sinauer. Paradis, E., J. Claude, and K. Strimmer. (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. Schliep, K. P. (2011) phangorn: phylogenetic analysis in R. \emph{Bioinformatics}, \bold{27}, 592-593. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{exhaustiveMP}}, \code{\link{nni}} } \keyword{phylogenetics} \keyword{phylogeny inference} \keyword{distance matrix} \keyword{least squares} phytools/man/rateshift.Rd0000644000176200001440000000517614546017173015207 0ustar liggesusers\name{rateshift} \alias{rateshift} \alias{plot.rateshift} \alias{likSurface.rateshift} \title{Find the temporal position of one or more rate shifts} \usage{ rateshift(tree, x, nrates=1, niter=10, method="ML", ...) \method{plot}{rateshift}(x, ...) likSurface.rateshift(tree, x, nrates=2, shift.range=NULL, density=20, plot=TRUE, ...) } \arguments{ \item{tree}{object of class \code{"phylo"}.} \item{x}{vector of phenotypic trait values for species. \code{names(x)} should contain the species names and match \code{tree$tip.label}. For \code{plot} method, \code{x} is an object of class \code{"rateshift"}.} \item{nrates}{number of rates.} \item{niter}{number of iterations of optimization routine to ensure convergence.} \item{method}{optimization method. Can be \code{"ML"} (maximum likelihood) or \code{"REML"} (restricted maximum likelihood).} \item{...}{optional arguments. In the case of the \code{plot} method, these will be passed to \code{\link{plotSimmap}}. For \code{rateshift}, optional arguments include: \code{tol}, tolerance; \code{plot} & \code{print}, logical values indicating whether to plot or print the progress of the optimization (default to \code{FALSE}); \code{quiet}, logical argument indicating whether to suppress all notifications (defaults to \code{FALSE}); \code{minL}, numeric value; and \code{fixed.shift}, either a vector of fixed shift points, or a logical value.} \item{shift.range}{for \code{likSurface.rateshift}.} \item{density}{for \code{likSurface.rateshift}.} \item{plot}{logical argument for \code{likSurface.rateshift}. If \code{plot=FALSE} then the surface is returned.} } \description{ Fits a model with one or more temporal rate shifts for a continuous trait on the tree. } \details{ \code{rateshift} attempts to find the location of one or more rate shifts. This model is quite easy to compute the likelihood for, but quite difficult to optimize as the likelihood surface is often rugged. \code{likSurface.rateshift} plots the likelihood surface. } \value{ A fitted object of class \code{"rateshift"}, or, in the case of \code{likSurface.rateshift}, a likelihood surface for the shift points. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. Revell, L. J. and L. J. Harmon (2022) \emph{Phylogenetic Comparative Methods in R}. Princeton University Press. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{brownie.lite}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{continuous character} \keyword{maximum likelihood} phytools/man/cophylo.Rd0000644000176200001440000001036614546012154014662 0ustar liggesusers\name{cophylo} \alias{cophylo} \alias{plot.cophylo} \alias{cotangleplot} \title{Creates a co-phylogenetic plot} \usage{ cophylo(tr1, tr2, assoc=NULL, rotate=TRUE, ...) \method{plot}{cophylo}(x, ...) cotangleplot(tr1, tr2, type=c("cladogram","phylogram"), use.edge.length=TRUE, tangle=c("both","tree1","tree2"), ...) } \arguments{ \item{tr1}{object of class \code{"phylo"}.} \item{tr2}{object of class \code{"phylo"}.} \item{assoc}{matrix containing the tip labels in \code{tr1} to match to the tip labels in \code{tr2}. Note that not all labels in either tree need to be included; and, furthermore, one label in \code{tr1} can be matched with more than one label in \code{tr2}, or vice versa.} \item{rotate}{logical argument indicating whether nodes on both trees should be rotated to attempt to match in vertical position.} \item{x}{in the case of \code{plot.cophylo}, an object of class \code{"cophylo"} to be plotted.} \item{type}{for \code{cotangleplot}, the tree plotting style.} \item{use.edge.length}{for \code{cotangleplot}, a logical value indicating whether or not to plot trees with edge lengths.} \item{tangle}{for \code{cotangleplot}, whether to tangle the left tree, the right tree, or both.} \item{...}{optional arguments to be passed to \code{\link{tipRotate}}, or, in the case of \code{plot.cophylo}, to the internally used tree plotting function, \code{phylogram}. \code{phylogram} takes similar arguments to \code{\link{plotSimmap}}, such as \code{fsize}, \code{ftype}, \code{lwd}, and \code{pts}, though not all options from \code{plotSimmap} and \code{plotTree} are available. If \code{fsize} is supplied as a vector, different size fonts for the left & right facing trees may be used. In addition, the optional argument \code{scale.bar}, which should be a vector containing the lengths of the scale bars desired for the right & left trees, will add scale bars to the plot when supplied to \code{plot.cophylo}. If either tree contains polytomies, the \code{cophylo} argument \code{rotate.multi} should be set to \code{TRUE}. If curved linking lines are desired, the \code{plot.cophylo} argument \code{link.type} should be set to \code{"curved"}. Other arguments for the \code{plot} method include \code{link.col}, \code{link.lty}, and \code{link.lwd}, which can be supplied as a scalar or a vector in which the order of the elements corresponds to the order of the associations in \code{assoc}. Finally, \code{edge.col}, a list consisting of two vectors (\code{left} and \code{right}) can be used to specify the edge colors of the two left & right plotted trees. Note that the edge order is the same as in the \emph{rotated} trees, assuming that a rotation has been performed on \code{x}.} } \description{ Visualize co-phylogenetic trees by multiple methods. } \details{ \code{cophylo} an object of class \code{"cophylo"} or, in the case of \code{plot.cophylo}, plots that object. The function can (optionally) first attempt to rotate the nodes of both trees to optimize vertical matching of tips. If no matrix of associations, \code{assoc}, is provided, then \code{cophylo} will look for exact matches of tip labels between trees. \code{cotangleplot} creates a co-phylogenetic plot in which the edges of the matched trees are crossing and is designed to be used \emph{only} on phylogenies with matching tip labels. } \value{ An object of class \code{"cophylo"} which includes the following components or a pair of plotted facing phylogenies with links between tips as specified in \code{assoc}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{cophyloplot}}, \code{\link{plotSimmap}} } \examples{ ## load data from Lopez-Vaamonde et al. (2001) data(wasp.trees) data(wasp.data) ## create co-phylogenetic object wasp.cophylo<-cophylo(wasp.trees[[1]],wasp.trees[[2]], assoc=wasp.data) ## plot co-phylogenies plot(wasp.cophylo,link.type="curved",link.lwd=4, link.lty="solid",link.col=make.transparent("red", 0.25)) par(mar=c(5.1,4.1,4.1,2.1)) } \keyword{phylogenetics} \keyword{plotting} \keyword{diversification} \keyword{co-phylogenetics} phytools/man/ansi_phylo.Rd0000644000176200001440000000143614546011361015347 0ustar liggesusers\name{ansi_phylo} \alias{ansi_phylo} \title{Compute the parsimony score} \usage{ ansi_phylo(tree, vertical=c("|","-"), ...) } \arguments{ \item{tree}{object of class \code{"phylo"}.} \item{vertical}{character for vertical lines} \item{...}{optional arguments.} } \description{ Plots a phylogeny in a silly, ANSI graphics style. } \value{ A plotted tree. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{plotTree}}, \code{\link{splinePhylogram}} } \examples{ data(salamanders) ansi_phylo(salamanders) par(mar=c(5.1,4.1,4.1,2.1)) } \keyword{phylogenetics} \keyword{plotting} phytools/man/anc.Bayes.Rd0000644000176200001440000001043414546020564015010 0ustar liggesusers\name{anc.Bayes} \alias{anc.Bayes} \alias{plot.anc.Bayes} \alias{density.anc.Bayes} \title{Bayesian ancestral character estimation} \usage{ anc.Bayes(tree, x, ngen=10000, control=list(), ...) \method{plot}{anc.Bayes}(x, ...) \method{density}{anc.Bayes}(x, ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{x}{a vector of tip values for species; \code{names(x)} should be the species names. In the case of the \code{plot} and \code{density} methods, an object of class \code{"anc.Bayes"}.} \item{ngen}{a integer indicating the number of generations for the MCMC.} \item{control}{a list of control parameters containing the following elements: \code{sig2}: starting value for \eqn{\sigma^2} (BM rate); \code{a}: starting for the state at the root node; \code{y}: starting values for the states at all internal nodes excluding the root (should be labeled with node numbers); \code{pr.mean}: means for the prior distributions in the following order - \code{sig2}, \code{a}, \code{y}, note that the prior probability distribution is exponential for \code{sig2} and normal for \code{a} and \code{y}; \code{pr.var}: variances on the prior distributions, same order as \code{pr.mean} (but the variance is not used for \code{sig2}); \code{prop}: variances on the normal proposal distributions in the same order as \code{pr.mean}; \code{sample}: sample frequency from the MCMC.} \item{...}{optional arguments, including to be passed to \code{plot} and \code{density} methods.} } \description{ This function uses Bayesian MCMC to sample from the posterior distribution for the states at internal nodes in the tree. } \value{ \code{anc.Bayes} returns an object of class \code{"anc.Bayes"} including at least two components: \item{mcmc}{a data frame with rows \code{ngen/sample+1} containing the posterior sample and likelihoods. Matrix columns are labeled either \code{sig2} or by the node number of the internal node.} \item{tree}{our input phylogeny.} } \details{ \code{plot.anc.Bayes} generates a likelihood profile plot of the MCMC by default, but can also create a profile plot for any of the sampled variables by using the optional argument \code{what}. For instance, \code{what=40} (or, equivalently, \code{what="40"}) will create a profile plot of the MCMC for node \code{40}. Additional arguments are passed to \code{\link{plot}}. \code{density.anc.Bayes} computes a posterior density from the MCMC sample. Like \code{plot.anc.Bayes} takes the optional argument \code{what}, but unlike \code{plot.anc.Bayes} computes the posterior density for the root node by default. The object computed by this function is of class \code{"density"} and can be visualized using \code{\link{plot.density}}. Burn-in (in generations) can be set using the optional argument \code{burnin}, otherwise it will be assumed to be 20% of the sample. The \code{print} and \code{summary} methods for this object class also return (invisibly) a vector of estimated ancestral states based on a user-supplied burn-in (or 20\% of the number of generations of MCMC, if no burn-in is provided). Burn-in can be specified with the optional argument \code{burnin}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ace}}, \code{\link{anc.ML}}, \code{\link{anc.trend}}, \code{\link{evol.rate.mcmc}}, \code{\link{fastAnc}} } \examples{ ## set seed set.seed(77) ## load data from Garland et al. (1992) data(mammal.tree) data(mammal.data) ## extract character of interest ln.bodyMass<-log(setNames(mammal.data$bodyMass, rownames(mammal.data))) ## run MCMC (should be run at least 1e6 generations) mcmc<-anc.Bayes(mammal.tree,ln.bodyMass, ngen=50000) print(mcmc,printlen=20) ## estimates par(mfrow=c(2,1)) plot(mcmc,bty="l",main="Likelihood-profile from MCMC", font.main=3) ## likelihood-profile plot(density(mcmc,what=Ntip(mammal.tree)+1, burnin=20000),bty="l", main="Posterior density for root state of log(body mass)", font.main=3) par(mfrow=c(1,1)) ## reset par to default } \keyword{ancestral states} \keyword{phylogenetics} \keyword{comparative method} \keyword{bayesian} \keyword{continuous character}phytools/man/rep.phylo.Rd0000644000176200001440000000214514546017406015126 0ustar liggesusers\name{rep.phylo} \alias{rep.phylo} \alias{rep.multiPhylo} \alias{repPhylo} \title{Replicate a tree or set of trees} \usage{ \method{rep}{phylo}(x, ...) \method{rep}{multiPhylo}(x, ...) repPhylo(tree, times) } \arguments{ \item{tree}{object of class \code{"phylo"}.} \item{times}{number of times to replicate tree.} \item{x}{for S3 method an object of class \code{"phylo"} or \code{"multiPhylo"}.} \item{...}{other arguments for \code{rep} (specifically, \code{times}).} } \description{ \code{\link{rep}} method for object of class \code{"phylo"} or \code{"multiPhylo"}. } \details{ \code{repPhylo} is just an alias for \code{rep.phylo} and \code{rep.multiPhylo}. } \value{ An object of class \code{"multiPhylo"}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \examples{ tree<-pbtree(n=100) trees<-rep(tree,100) } \seealso{ \code{\link{c.phylo}}, \code{\link{rep}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/splitplotTree.Rd0000644000176200001440000000321114546017770016057 0ustar liggesusers\name{splitplotTree} \alias{splitplotTree} \alias{plotTree.splits} \title{Plots a phylogeny in two columns} \usage{ splitplotTree(tree, fsize=1.0, ftype="reg", lwd=2, split=NULL, new.window=FALSE) plotTree.splits(tree, splits=NULL, file=NULL, fn=NULL, ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{fsize}{relative font size for tip labels.} \item{ftype}{font type - options are \code{"reg"}, \code{"i"} (italics), \code{"b"} (bold), or \code{"bi"} (bold-italics).} \item{lwd}{line width for plotting.} \item{split}{relative vertical position for splitting the tree (between 0 & 1).} \item{new.window}{whether or not to plot the split tree in a new window. If \code{FALSE} then the tree will be plotted in two columns within the same plotting window.} \item{splits}{for \code{plotTree.splits} relative positions (from 0 to 1) to split the tree across pages or devices.} \item{file}{filename if saving to a PDF file is desired. Otherwise will plot to the default plotting device.} \item{fn}{function to be executed on each plotted page. For instance, might be: \code{function()} \code{cladelabels()} if clade labels are desired.} \item{...}{other arguments to be passed to \code{\link{plotTree}}.} } \description{ Plots a tree in two columns or windows. } \value{ Plots a tree. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{plotTree}}, \code{\link{plotSimmap}} } \keyword{phylogenetics} \keyword{plotting} phytools/man/read.simmap.Rd0000644000176200001440000000573114546017362015413 0ustar liggesusers\name{read.simmap} \alias{read.simmap} \title{Read SIMMAP style trees from file} \usage{ read.simmap(file="", text, format="nexus", rev.order=TRUE, version=1) } \arguments{ \item{file}{name of text file with one or multiple SIMMAP v1.0 or v1.5 style trees containing the mapped history of a discrete character.} \item{text}{character string containing the tree. If \code{version=1.5} this argument is ignored. (This format tree can only be read from file in the present version.)} \item{format}{format of the trees: either \code{"phylip"} or \code{"nexus"} - the latter is the default output from SIMMAP. If \code{version=1.5} this argument is ignored.} \item{rev.order}{a logical value indicating whether the states and times along each branch is given (from root to tip) in right-to-left order (if TRUE) or in left-to-right order. If \code{version=1.5} this argument is ignored.} \item{version}{version of SIMMAP for input tree. If the tree(s) was/were simulated in SIMMAP v1.0 or written to file by \code{link{make.simmap}} then \code{version=1.0}; if the tree(s) was/were simulated using SIMMAP v1.5 then \code{version=1.5}.} } \description{ This reads one or multiple SIMMAP style trees from file. } \details{ This function now accepts trees in both SIMMAP v1.0 and SIMMAP v1.5 format. In addition, it can read a more flexible format than is produced by SIMMAP (for instance, multi-character mapped states and more than 7 mapped states). The function uses some modified code from \code{\link{read.nexus}} from the \pkg{ape} package to read the NEXUS block created by SIMMAP. Also creates the attribute \code{"map.order"} which indicates whether the stochastic map was read in from left to right or right to left. This attribute is used by default by \code{\link{write.simmap}} to write the tree in the same order. } \value{ An object of class \code{"simmap"} (or list of such objects with class \code{"multiSimmap"}), consisting of a modified object of class \code{"phylo"} with at least the following additional elements: \item{maps}{a list of named vectors containing the times spent in each state on each branch, in the order in which they occur.} \item{mapped.edge}{a matrix containing the total time spent in each state along each edge of the tree.} } \references{ Bollback, J. P. (2006) Stochastic character mapping of discrete traits on phylogenies. \emph{BMC Bioinformatics}, \bold{7}, 88. Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{brownie.lite}}, \code{\link{evol.vcv}}, \code{\link{read.tree}}, \code{\link{read.nexus}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{input/output} \keyword{discrete character} phytools/man/orderMappedEdge.Rd0000644000176200001440000000260514546014127016233 0ustar liggesusers\name{orderMappedEdge} \alias{orderMappedEdge} \title{Order the columns of mapped.edge to match across trees} \usage{ orderMappedEdge(trees, ordering=NULL) } \arguments{ \item{trees}{object of class \code{"phylo"} or \code{"multiPhylo"}.} \item{ordering}{ordering for the columns of \code{$mapped.edge}. If \code{NULL}, then an alphabetical order is assumed. Options are \code{"alphabetical"}, \code{"numerical"}, or any specific ordering of the mapped traits (e.g., \code{c("A","B","C")}.} } \description{ Orders the levels of a mapped character to match across trees in a \code{"multiSimmap"} object. } \details{ This function takes a an object of class \code{"multiSimmap"} with a mapped discrete character (e.g., see \code{\link{make.simmap}} and sorts the columns of each \code{tree$mapped.edge} element to have the same state ordering. This is handy if we want to, for instance, run \code{brownie.lite} on a set of mapped trees, and then average the fitted parameter values across trees. The function also works for a single tree. } \value{ An object of class \code{"simmap"} or (normally) \code{"multiSimmap"}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/phylosig.Rd0000644000176200001440000001172314546016354015047 0ustar liggesusers\name{phylosig} \alias{phylosig} \alias{plot.phylosig} \title{Compute phylogenetic signal with two methods} \usage{ phylosig(tree, x, method="K", test=FALSE, nsim=1000, se=NULL, start=NULL, control=list(), niter=10) \method{plot}{phylosig}(x, ...) } \arguments{ \item{tree}{a phylogenetic tree in \code{"phylo"} format.} \item{x}{vector containing values for a single continuously distributed trait. In the case of the \code{plot} method, \code{x} is an object of class \code{"phylosig"}.} \item{method}{method to compute signal: can be \code{"K"} or \code{"lambda"}.} \item{test}{logical indicating whether or not to conduct a hypothesis test of \code{"K"} or \code{"lambda"}.} \item{nsim}{for \code{method="K"}, number of simulations in randomization test.} \item{se}{named vector containing the standard errors for each species.} \item{start}{vector of starting values for optimization of (respectively) \eqn{\sigma^2} and \eqn{\lambda}. Only used in \code{method="lambda"} and \code{se!=NULL}.} \item{control}{list of control parameters for multidimensional optimization, implemented in \code{\link{optim}}. Only used in \code{method="lambda"} and \code{se!=NULL}.} \item{niter}{number of iterations for likelihood optimization of \eqn{\lambda} (if \code{se!=NULL}), or the number of \emph{intervals} between 0 and the maximum possible value of \eqn{\lambda} for univariate optimization of \eqn{\lambda} (if \code{se==NULL}).} \item{...}{optional arguments for \code{plot} method.} } \description{ Calculate phylogenetic signal using two different methods (Pagel, 1999; Blomberg et al., 2003). } \details{ This function computes phylogenetic signal using two different methods. It can also conduct the hypothesis tests for significant phylogenetic signal, and estimate phylogenetic signal incorporating sampling error following Ives et al. (2007). \eqn{\lambda} optimization is performed using \code{\link{optimize}} with the range of \eqn{\lambda} set between 0 and the theoretical upper limit of \eqn{\lambda} (determined by the relative height of the most recent internal node on the tree). \code{plot.phylosig} creates either a plot of the null distribution of \emph{K} or a likelihood surface, depending on the value of \code{method}. } \value{ The function returns an object of class \code{"phylosig"}. With default arguments (\code{method="K"}, \code{test=FALSE}, and \code{se=NULL}), this will be a single numeric value. Otherwise, if \code{(method="K")}, it will consist of a list with up to the following elements: \item{K}{value of the K-statistic.} \item{sig2}{rate of evolution, \eqn{\sigma^2}, for estimation with sampling error.} \item{logL}{log-likelihood, for estimation with sampling error.} \item{P}{optionally, the P-value from the randomization test.} If \code{(method="lambda")}, it will be a list with up to the following elements: \item{lambda}{fitted value of \eqn{\lambda}.} \item{sig2}{rate of evolution, \eqn{\sigma^2}, for estimation with sampling error.} \item{logL}{log-likelihood.} \item{logL0}{log-likelihood for \eqn{\lambda=0}.} \item{P}{P-value of the likelihood ratio test.} \item{convergence}{value for convergence, for estimation with sampling error only. (See \code{\link{optim}}).} \item{message}{message from \code{\link{optim}}, for estimation with sampling error only.} } \references{ Blomberg, S. P., T. Garland Jr., and A. R. Ives (2003) Testing for phylogenetic signal in comparative data: Behavioral traits are more labile. \emph{Evolution}, \bold{57}, 717-745. Ives, A. R., P. E. Midford, and T. Garland Jr. (2007) Within-species variation and measurement error in phylogenetic comparative biology. \emph{Systematic Biology}, \bold{56}, 252-270. Pagel, M. (1999) Inferring the historical patterns of biological evolution. \emph{Nature}, \bold{401}, 877-884. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \examples{ ## load data from Garland et al. (1992) data(mammal.tree) data(mammal.data) ## extract characters of interest ln.bodyMass<-log(setNames(mammal.data$bodyMass, rownames(mammal.data))) ln.homeRange<-log(setNames(mammal.data$homeRange, rownames(mammal.data))) ## compute phylogenetic signal K K.bodyMass<-phylosig(mammal.tree,ln.bodyMass, test=TRUE) print(K.bodyMass) plot(K.bodyMass) K.homeRange<-phylosig(mammal.tree,ln.homeRange, test=TRUE) print(K.homeRange) plot(K.homeRange) ## compute phylogenetic signal lambda lambda.bodyMass<-phylosig(mammal.tree,ln.bodyMass, method="lambda",test=TRUE) print(lambda.bodyMass) plot(lambda.bodyMass) lambda.homeRange<-phylosig(mammal.tree,ln.homeRange, method="lambda",test=TRUE) print(lambda.homeRange) plot(lambda.homeRange) } \keyword{phylogenetics} \keyword{comparative method} \keyword{maximum likelihood} \keyword{simulation} \keyword{continuous character} phytools/man/drop.tip.contMap.Rd0000644000176200001440000000313614546012450016340 0ustar liggesusers\name{drop.tip.contMap} \alias{drop.tip.contMap} \alias{drop.tip.densityMap} \alias{keep.tip.contMap} \alias{keep.tip.densityMap} \title{Drop tip or tips from an object of class \code{"contMap"} or \code{"densityMap"}} \usage{ \method{drop.tip}{contMap}(phy, tip, ...) \method{drop.tip}{densityMap}(phy, tip, ...) \method{keep.tip}{contMap}(phy, tip, ...) \method{keep.tip}{densityMap}(phy, tip, ...) } \arguments{ \item{phy}{an object of class \code{"contMap"} or \code{"densityMap"}.} \item{tip}{name or names of species to be dropped or kept.} \item{...}{optional arguments to be passed to \code{\link{drop.tip.simmap}}.} } \description{ Drops one or multiple tips from an object of class \code{"contMap"} or \code{"densityMap"}. } \details{ These functions are equivalent to \code{\link{drop.tip}} and \code{\link{keep.tip}} in the \pkg{ape} package, but for objects of class \code{"contMap"} and \code{"densityMap"}. For more information about objects of class \code{"contMap"} or \code{"densityMap"}, please refer to the documentation pages for \code{\link{contMap}} or \code{\link{densityMap}}, respectively. } \value{ An object of class \code{"contMap"} or \code{"densityMap"}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{contMap}}, \code{\link{densityMap}}, \code{\link{drop.tip}}, \code{\link{drop.tip.simmap}}, \code{\link{keep.tip}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/tree.grow.Rd0000644000176200001440000000315514546020366015123 0ustar liggesusers\name{tree.grow} \alias{tree.grow} \title{Creates an animation of a tree growing from left-to-right or upwards} \usage{ tree.grow(..., res=200, direction="rightwards", ladderize=TRUE) } \arguments{ \item{...}{arguments to pass to \code{\link{pbtree}}.} \item{res}{number of steps (the resolution of the animation). This also corresponds to the number of frames that will be created if the animation is to be converted to a .gif file.} \item{direction}{the direction to plot the tree. Only \code{direction="rightwards"} (the default) and \code{direction="upwards"} are supported.} \item{ladderize}{logical value indicating whether or not to 'ladderize' the plotted tree. (Defaults to \code{TRUE}.)} } \description{ Animates a birth-death tree simulation. } \details{ This function simulates a birth-death tree under user-defined conditions and then creates an animation of that tree growing from left-to-right in the plotting device, or upwards. } \value{ An object of class \code{"phylo"}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{pbtree}} } \examples{ \dontrun{ ## to create a .gif with ImageMagick installed png(file="pbtree-%03d.png",width=1000,height=600,res=144) tree.grow(b=0.06,d=0.02,t=100) dev.off() system("ImageMagick convert -delay 5 -loop 0 *.png pbtree-anim.gif")} } \keyword{phylogenetics} \keyword{plotting} \keyword{comparative method} \keyword{simulation} \keyword{diversification} phytools/man/mergeMappedStates.Rd0000644000176200001440000000236614546013650016622 0ustar liggesusers\name{mergeMappedStates} \alias{mergeMappedStates} \title{Merge two or more mapped states into one state} \usage{ mergeMappedStates(tree, old.states, new.state) } \arguments{ \item{tree}{an object of class \code{"simmap"} or \code{"multiSimmap"} containing one or more phylogenetic trees with a mapped discrete character.} \item{old.states}{states to merge.} \item{new.state}{name for new state.} } \description{ Merges two or mapped states on the tree to get one new state. } \details{ \code{mergeMappedStates} can be used to merge two or more mapped states into a single, new state. For instance, one could merge the states \code{"C"}, \code{"G"}, and \code{"T"} and define the new the state \code{"not-A"}. } \value{ An object of class \code{"simmap"} or \code{"multiSimmap"}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{make.simmap}}, \code{\link{read.simmap}} } \keyword{ancestral states} \keyword{phylogenetics} \keyword{comparative method} \keyword{simulation} \keyword{bayesian} \keyword{utilities} \keyword{discrete character} phytools/man/phylANOVA.Rd0000644000176200001440000000423714546016076014755 0ustar liggesusers\name{phylANOVA} \alias{phylANOVA} \title{Phylogenetic ANOVA and post-hoc tests} \usage{ phylANOVA(tree, x, y, nsim=1000, posthoc=TRUE, p.adj="holm") } \arguments{ \item{tree}{a phylogenetic tree in \code{"phylo"} format.} \item{x}{a vector containing the groups.} \item{y}{a vector containing the response variable (continuously valued).} \item{nsim}{an integer specifying the number of simulations (including the observed data).} \item{posthoc}{a logical value indicating whether or not to conduct posthoc tests to compare the mean among groups.} \item{p.adj}{method to adjust P-values for the posthoc tests to account for multiple testing. Options same as \code{\link{p.adjust}}.} } \description{ Simulation based phylogenetic ANOVA following Garland et al. (1993), with post-hoc tests. } \details{ This function performs the simulation-based phylogenetic ANOVA of Garland et al. (1993) and (optionally) conducts all posthoc comparisons of means among groups (also obtaining the P-values by phylogenetic simulation). This function uses a little bit of code from both \code{phy.anova} in the \pkg{geiger} package and \code{\link{pairwise.t.test}}. } \value{ An object of class \code{"phylANOVA"} containing the following elements: \item{F}{F from observed data.} \item{Pf}{P-value for F from simulation.} \item{T}{matrix of t-values.} \item{Pt}{matrix of multiple test corrected P-values from posthoc t-tests.} } \references{ Garland, T., Jr., A. W. Dickerman, C. M. Janis, & J. A. Jones (1993) Phylogenetic analysis of covariance by computer simulation. \emph{Systematic Biology}, \bold{42}, 265-292. Harmon, L. J., J. T. Weir, C. D. Brock, R. E. Glor, W. Challenger (2008) GEIGER: investigating evolutionary radiations. \emph{Bioinformatics}, 24, 129-131. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{anova}}, \code{\link{pairwise.t.test}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{statistics} \keyword{least squares} \keyword{simulation} phytools/man/phyl.pairedttest.Rd0000644000176200001440000000540514546016020016502 0ustar liggesusers\name{phyl.pairedttest} \alias{phyl.pairedttest} \title{Phylogenetic paired \emph{t}-test} \usage{ phyl.pairedttest(tree, x1, x2=NULL, se1=NULL, se2=NULL, lambda=1.0, h0=0.0, fixed=FALSE, ...) } \arguments{ \item{tree}{a phylogeny as an object of class \code{"phylo"}.} \item{x1}{data vector for first trait, or matrix with two traits in columns.} \item{x2}{data vector for second trait (or null if \code{x1} is a matrix).} \item{se1}{standard errors for \code{x1}.} \item{se2}{standard errors for \code{x2}.} \item{lambda}{starting value for Pagel's \ifelse{html}{\out{λ}}{\eqn{\lambda}{lambda}} (or fixed value, if \code{fixed=TRUE}).} \item{h0}{null hypothesis (to be tested) for the mean difference between \code{x1} and \code{x2}.} \item{fixed}{logical value specifying whether or not to optimize \ifelse{html}{\out{λ}}{\eqn{\lambda}{lambda}}.} \item{...}{optional arguments.} } \description{ Phylogenetic paired \emph{t}-test following Lindenfors et al. (2010). } \details{ This function conducts a phylogenetic paired \emph{t}-test, roughly following Lindenfors et al. (2010). This is \emph{not} a phylogenetic ANOVA, in which we want to compare the means of different sets of species on the tree. Instead, we are interested in the difference between two characters, or two measures of a character within a species, and we want to know if this difference is significantly different from zero controlling for the phylogenetic non-independence of species. Likelihood optimization is performed using \code{\link{optim}} with \code{method="L-BFGS-B"} with box constraints on \ifelse{html}{\out{λ}}{\eqn{\lambda}{lambda}} (0,1). } \value{ An object of class \code{"phyl.pairedttest"} with the following elements: \item{dbar}{phylogenetic mean difference.} \item{se}{standard error of \code{dbar}.} \item{sig2}{estimated evolutionary variance (of the difference).} \item{lambda}{fitted (or fixed) value of \ifelse{html}{\out{λ}}{\eqn{\lambda}{lambda}}.} \item{logL}{log-likelihood of the fitted model.} \item{t.dbar}{t-value (\code{(dbar-h0)/se} where \code{se} is computed from the Hessian).} \item{P.dbar}{P-value.} \item{df}{the degrees of freedom.} \item{h0}{the null hypothesis that was tested.} } \references{ Lindenfors, P., L. J. Revell, and C. L. Nunn (2010) Sexual dimorphism in primate aerobic capacity: A phylogenetic test. \emph{J. Evol. Biol.}, \bold{23}, 1183-1194. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{comparative method} \keyword{maximum likelihood} \keyword{statistics} \keyword{least squares} phytools/man/reorderSimmap.Rd0000644000176200001440000000216314546017400016011 0ustar liggesusers\name{reorderSimmap} \alias{reorderSimmap} \title{Reorder edges of a \code{"simmap"} tree} \usage{ reorderSimmap(tree, order="cladewise", index.only=FALSE, ...) } \arguments{ \item{tree}{a modified object of class \code{"phylo"}.} \item{order}{\code{"cladewise"}, \code{"pruningwise"}, or any other allowable order permitted by \code{\link{reorder.phylo}}.} \item{index.only}{logical value indicating whether only an index should be returned.} \item{...}{other arguments.} } \description{ Function returns a reordered modified \code{"phylo"} object by using \code{reorder.phylo} but then sorting the additional elements \code{$mapped.edge} and \code{$maps} to have the same order as \code{$edge}. } \value{ A modified object of class \code{"phylo"}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{reorder.phylo}}, \code{\link{plotSimmap}} } \keyword{phylogenetics} \keyword{utilities} \keyword{comparative method} phytools/man/nodelabels.cophylo.Rd0000644000176200001440000000264614546014107016773 0ustar liggesusers\name{nodelabels.cophylo} \alias{nodelabels.cophylo} \alias{tiplabels.cophylo} \alias{edgelabels.cophylo} \title{Add labels to a plotted "cophylo" object} \usage{ nodelabels.cophylo(..., which=c("left","right")) edgelabels.cophylo(..., which=c("left","right")) tiplabels.cophylo(..., which=c("left","right")) } \arguments{ \item{...}{arguments to be passed to \code{\link{nodelabels}}, \code{\link{edgelabels}}, or \code{\link{tiplabels}}.} \item{which}{argument indicated which of the two plotted trees (the \code{"left"} or \code{"right"} tree) to be used.} } \description{ This function adds node, edge, or tip labels to the plotted trees of a \code{"cophylo"} object. } \details{ Note that the order of tips, edges, and nodes may be different in the object of class \code{"cophylo"} than they are in the original input trees, particularly if \code{cophylo(...,rotate=TRUE)} was used. } \references{ Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{cophylo}}, \code{\link{edgelabels}}, \code{\link{nodelabels}}, \code{\link{tiplabels}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/sim.rates.Rd0000644000176200001440000000377314546017724015126 0ustar liggesusers\name{sim.rates} \alias{sim.rates} \alias{multiOU} \title{Brownian or OU simulation with multiple evolutionary regimes} \usage{ sim.rates(tree, sig2, anc=0, nsim=1, internal=FALSE, plot=FALSE) multiOU(tree, alpha, sig2, theta=NULL, a0=NULL, nsim=1, internal=FALSE, ...) } \arguments{ \item{tree}{is a stochastic map format phylogenetic tree in modified \code{"phylo"} format (e.g., see \code{\link{make.simmap}}).} \item{sig2}{a named vector containing the rates for each state; names should be states in \code{mtree}.} \item{anc}{optional value for the root state.} \item{nsim}{number of simulations.} \item{internal}{logical value indicating whether to return states at internal nodes.} \item{plot}{logical value indicating whether or not to visual the rate heterogeneity (default value is \code{FALSE}.} \item{alpha}{single value or vector of values of the OU \eqn{\alpha} parameter.} \item{theta}{single value or vector of values of the OU \eqn{\theta} parameter.} \item{a0}{optional value of the root state. Defaults to zero.} \item{...}{optional arguments.} } \description{ Simulates multi-rate or multi-regime continuous trait evolution on a phylogeny. } \details{ The function \code{sim.rates} conducts BM simulation on a tree with multiple rates. The function \code{multiOU} conducts multi-regime OU simulations on the tree under a range of conditions. \code{multiOU} uses a difference equation approximation of the OU process. } \value{ A vector (for \code{nsim=1}) or matrix containing the tip states for the \code{n} species in the tree. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{fastBM}}, \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{sim.history}} } \keyword{phylogenetics} \keyword{simulation} \keyword{comparative method} \keyword{continuous character} phytools/man/multiRF.Rd0000644000176200001440000000252214546014071014562 0ustar liggesusers\name{multiRF} \alias{multiRF} \title{Computes Robinson-Foulds distance between a set of trees} \usage{ multiRF(trees,quiet=FALSE,multi2di=FALSE) } \arguments{ \item{trees}{object of class \code{"multiPhylo"} consisting of two or more fully bifurcating, unrooted trees. If trees are rooted, they will be unrooted.} \item{quiet}{logical argument indicating whether or not to run quietly. (Defaults to \code{FALSE}.)} \item{multi2di}{logical argument indicating whether or not to resolve multifurcating trees. (Defaults to \code{FALSE}.)} } \description{ Computes the Robinson-Foulds (Robinson & Foulds 1981) distance between a set of trees in an object of class \code{"multiPhylo"}. } \details{ Computes the Robinson-Foulds distance between all phylogenies in an object of class \code{"multiPhylo"}. Uses \code{\link{prop.part}} internally for most of the heavy lifting. } \value{ A matrix containing distances. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. Robinson, D. R., Foulds, L. R. (1981) Comparison of phylogenetic trees. \emph{Mathematical Biosciences}, \bold{53}, 131-147. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} \keyword{phylogeny inference} phytools/man/ctt.Rd0000644000176200001440000000313414546012245013773 0ustar liggesusers\name{ctt} \alias{ctt} \alias{sim.ctt} \alias{sim.multiCtt} \title{Generates (or simulates) a 'changes through time' plot from a set of stochastic map character histories} \usage{ ctt(trees, segments=20, ...) sim.ctt(tree, Q, anc=NULL, nmaps=100, ...) sim.multiCtt(tree, Q, anc=NULL, nmaps=100, nsim=100, ...) } \arguments{ \item{trees}{an object of class \code{"multiSimmap"}.} \item{segments}{number of segments to break up the history of the tree.} \item{tree}{for \code{sim.ctt}, an object of class \code{"phylo"}.} \item{Q}{for \code{sim.ctt}, a transition matrix to use for simulation.} \item{anc}{ancestral state at the root node for simulation.} \item{nmaps}{number of stochastic maps per simulation.} \item{nsim}{for \code{sim.multiCtt} only, the number of simulations to run.} \item{...}{optional arguments.} } \description{ Create a 'changes through time' plot from a \code{"multiSimmap"} object. } \details{ This function generates a 'changes through time' plot in the style of a lineage-through-time (LTT) plot. It shows the mean rate or the mean number of changes per unit time from a set of stochastic character map trees. } \value{ An object of class \code{"ctt"} or \code{"multiCtt"}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ltt}} } \keyword{ancestral states} \keyword{comparative method} \keyword{discrete character} \keyword{phylogenetics} \keyword{plotting} phytools/man/read.newick.Rd0000644000176200001440000000477614546017352015414 0ustar liggesusers\name{read.newick} \alias{read.newick} \alias{readNexus} \title{Newick or Nexus style tree reader} \usage{ read.newick(file="", text, ...) readNexus(file="", format=c("standard","raxml")) } \arguments{ \item{file}{name of text file with single Newick style tree or multiple trees, one per line. For \code{readNexus} this should be a Nexus format tree.} \item{text}{character string containing tree.} \item{format}{file format (source) for \code{readNexus}. In the case of \code{format="standard"}, \code{\link{read.nexus}} from \pkg{ape} will be used internally. For \code{format="raxml"}, the parser assumes that bootstrap values have been stored as node labels in the format \code{[&label=bootstrap]}.} \item{...}{optional arguments to be passed to \code{\link{scan}}. Note that if the arguments \code{sep} or \code{what} are supplied this could generate an error. Useful optional arguments might include \code{skip} (number of lines to skip) and \code{nlines} (number of lines to read).} } \description{ Reads a phylogenetic tree from file. } \details{ The function \code{read.newick} reads a simple Newick style tree from file. This function is now almost completely redundant with \code{\link{read.tree}}. At the time of development, however, it was more 'robust' than \code{read.tree} in that it didn't fail if the tree contained so-called 'singles' (nodes with only one descendant); however, \code{read.tree} can now handle singleton nodes without difficulty. The function \code{readNexus} reads a Nexus formatted tree, optionally with bootstrap values as node labels. This function can read a simple Nexus formatted tree from file (like \code{\link{read.nexus}}); however, it can also parse the node labels as bootstrap values. This is the output format from the software \emph{RAxML}. For Nexus tree files with complex node labels (e.g., from the software \emph{MrBayes}) it will probably fail to parse node labels correctly, if at all. } \value{ An object of class \code{"phylo"}, possibly containing singletons (see \code{\link{collapse.singles}}); or an object of class \code{"multiPhylo"}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{read.tree}}, \code{\link{read.nexus}} } \examples{ tree<-"((Human,Chimp),Gorilla),Monkey);" phy<-read.newick(text=tree) } \keyword{phylogenetics} \keyword{input/output} phytools/man/export.as.xml.Rd0000644000176200001440000000207214546012751015725 0ustar liggesusers\name{export.as.xml} \alias{export.as.xml} \title{Export trees & data in XML format} \usage{ export.as.xml(file, trees, X) } \arguments{ \item{file}{filename for export.} \item{trees}{a phylogenetic tree or trees in \code{"phylo"} or \code{"multiPhylo"} format.} \item{X}{a matrix of class \code{"DNAbin"} or a matrix with discretely valued non-DNA character data.} } \description{ Exports trees & character data in XML format. } \details{ Can be used to create input file for the program SIMMAP v1.5 (Bollback 2006). } \value{ A file. } \references{ Bollback, J. P. (2006) Stochastic character mapping of discrete traits on phylogenies. \emph{BMC Bioinformatics}, \bold{7}, 88. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{make.simmap}}, \code{\link{read.nexus}}, \code{\link{read.simmap}}, \code{\link{write.simmap}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/ltt.Rd0000644000176200001440000001055714546013524014014 0ustar liggesusers\name{ltt} \alias{ltt} \alias{ltt.phylo} \alias{ltt.multiPhylo} \alias{ltt.simmap} \alias{ltt.multiSimmap} \alias{gtt} \alias{mccr} \title{Creates lineage-through-time plot (including extinct lineages)} \usage{ ltt(tree, ...) \method{ltt}{phylo}(tree, plot=TRUE, drop.extinct=FALSE, log.lineages=TRUE, gamma=TRUE, ...) \method{ltt}{multiPhylo}(tree, drop.extinct=FALSE, gamma=TRUE, ...) \method{ltt}{simmap}(tree, plot=TRUE, log.lineages=FALSE, gamma=TRUE, ...) \method{ltt}{multiSimmap}(tree, gamma=TRUE, ...) gtt(tree, n=100, ...) mccr(obj, rho=1, nsim=100, ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}, \code{"multiPhylo"}, \code{"simmap"}, or \code{"multiSimmap"}.} \item{plot}{a logical value indicating whether or not to create LTT plot.} \item{drop.extinct}{logical value indicating whether or not to drop extinct tips from the tree.} \item{log.lineages}{logical value indicating whether LTT plot should be on log-linear (default for \code{"phylo"} and \code{"multiPhylo"} objects) or linear-linear scale.} \item{gamma}{logical value indicating whether or not to compute \eqn{\gamma} from Pybus & Harvey (2000; \emph{Proc. Roy. Soc. B}).} \item{n}{for \code{gtt} the number of time intervals to use to track \eqn{\gamma} through time.} \item{obj}{for \code{mccr} an object of class \code{"ltt"}.} \item{rho}{for \code{mccr} sampling fraction.} \item{nsim}{for \code{mccr} number of simulations to use for the MCCR test.} \item{...}{other arguments to be passed to plotting methods. See \code{\link{plot.default}}.} } \description{ Computes and visualizes a lineage through time (LTT) plot, and related measures. } \details{ The function \code{ltt} computes LTT plot with extant and extinct lineages, and optionally conducts \eqn{\gamma}-test of Pybus & Harvey (2000). The object returned by \code{ltt} can be plotted or re-plotted using \code{\link{plot}}. For the case in which \code{tree} is an object of class \code{"simmap"} or \code{"multiSimmap"} then the object will contain the number of lineages through time (for each tree, in the case of \code{"multiSimmap"} objects) separated by mapped regimes. The function \code{gtt} computes the value of Pybus & Harvey's \eqn{\gamma} statistic through time by slicing the tree at various points - by default in even intervals from the time above the root at which \emph{N} = 3 to the present day. The function \code{mccr} performs the MCCR test of Pybus & Harvey (2000) which takes into account incomplete taxon sampling in computing a P-value of the \eqn{\gamma} statistic. Although it is calculated here, it's unclear how to interpret the \eqn{\gamma}-statistic if not all the tips in the tree are contemporaneous. } \value{ \code{ltt} returns an object of class \code{"ltt"} which normally includes the following elements: \item{times}{a vector of branching times.} \item{ltt}{a vector of lineages, or a matrix of lineages in each state over time for objects of class \code{"simmap"} and \code{"multiSimmap"}.} \item{gamma}{optionally, a value for the \eqn{\gamma}-statistic.} \item{p}{two-tailed P-value for the \eqn{\gamma}-test.} If \code{tree} is an object of class \code{"multiPhylo"}, then an object of class \code{"multiLtt"} is returned consisting of a list of object of class \code{"ltt"}. \code{gtt} returns an object of class \code{"gtt"}. \code{mccr} returns of object of class \code{"mccr"}. } \references{ Pybus, O. G., and P. H. Harvey (2000) Testing macro-evolutionary models using incomplete molecular phylogenies. \emph{Proc. R. Soc. Lond. B}, \bold{267}, 2267-2272. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{gammatest}}, \code{\link{ltt95}} } \examples{ ## LTT plots set.seed(99) trees<-pbtree(n=100,scale=100,nsim=10) obj<-ltt(trees,plot=FALSE) plot(obj,log="y",log.lineages=FALSE, bty="l") title(main="LTT plots for 10 pure-birth trees", font.main=3) tree<-pbtree(b=1,d=0.25,t=4) obj<-ltt(tree,gamma=FALSE,show.tree=TRUE, bty="l") title(main="LTT plot with superimposed tree", font.main=3) obj ## GTT plot data(anoletree) anole.gtt<-gtt(anoletree,n=40) plot(anole.gtt) } \keyword{phylogenetics} \keyword{plotting} \keyword{diversification} phytools/man/drop.tip.simmap.Rd0000644000176200001440000000352314546012470016227 0ustar liggesusers\name{drop.tip.simmap} \alias{drop.tip.simmap} \alias{keep.tip.simmap} \alias{extract.clade.simmap} \title{Drop tips or extract clade from tree with mapped discrete character} \usage{ \method{drop.tip}{simmap}(phy, tip, ...) \method{keep.tip}{simmap}(phy, tip, ...) extract.clade.simmap(tree, node) } \arguments{ \item{phy}{an object of class \code{"simmap"}.} \item{tip}{name or names of species to be dropped (or kept).} \item{node}{node number for the root node of the clade to be extracted.} \item{...}{optional arguments. Currently the logical argument \code{untangle} which if set to \code{TRUE} will call \code{\link{untangle}} before returning the \code{"simmap"} object to the user.} \item{tree}{for \code{extract.clade.simmap}, an object of class \code{"simmap"}.} } \description{ This function drops one or multiple tips from an object of class \code{"simmap"}. } \details{ Equivalent to \code{\link{drop.tip}} and \code{\link{keep.tip}} but for a tree with a mapped discrete character. \code{extract.clade.simmap} is functionally equivalent to \code{\link{extract.clade}} but preserves discrete character mappings on the tree. Following \code{\link{drop.tip}} in \pkg{ape}, the returned tree is always in \code{"cladewise"} order. } \value{ A modified object of class \code{"phylo"} containing the elements \code{maps} and \code{$mapped.edge} with the time spent in each state along each edge of the tree. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{drop.tip}}, \code{\link{extract.clade}}, \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{sim.history}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/findMRCA.Rd0000644000176200001440000000411314546013040014554 0ustar liggesusers\name{findMRCA} \alias{findMRCA} \title{Get the MRCA of a set of taxa} \usage{ findMRCA(tree, tips=NULL, type=c("node","height")) } \arguments{ \item{tree}{a phylogenetic tree as an object of class \code{"phylo"}.} \item{tips}{a vector containing a set of tip labels.} \item{type}{either \code{"node"} to return the node of the MRCA; or \code{"height"} to return the height above the root of the MRCA of \code{tips}.} } \description{ Finds the most recent common ancestor (MRCA) of a set of tips. } \details{ This function returns node number of the most recent common ancestor of a set of taxa. If \code{tips==NULL} and \code{type="node"} (the default) it will return the result of a normal function call to \code{\link{mrca}}. If \code{tips=NULL} and \code{type="height"} it will return a matrix equal to that produced by \code{\link{vcv.phylo}}. From \pkg{phytools} 0.5-66 forward, \code{findMRCA} uses \code{\link{getMRCA}} in the \pkg{ape} package internally, which results in a big speed-up. Even though the two functions are thus totally redundant I have left \code{findMRCA} in the package namespace to ensure backward compatibility. } \value{ The node number of the MRCA, or a matrix of node numbers (if \code{tips==NULL}) - for \code{type="node"}; or the height of the MRCA, or a matrix of heights (if \code{tips==NULL}) - for \code{type="height"}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{findMRCA}}, \code{\link{mrca}} } \examples{ data(anoletree) anc<-findMRCA(anoletree,c("cristatellus","cooki", "gundlachi")) plotTree(anoletree,type="fan",fsize=0.7,lwd=1) nodelabels(node=anc,frame="circle",pch=21,cex=1.5, bg="blue") legend("topleft","most recent common ancestor\nof Puerto Rican TG anoles", pch=21,pt.cex=1.5,pt.bg="blue",cex=0.7,bty="n") par(mar=c(5.1,4.1,4.1,2.1)) ## reset margin to default } \keyword{phylogenetics} \keyword{utilities} phytools/man/fitBayes.Rd0000644000176200001440000000512214546013115014743 0ustar liggesusers\name{fitBayes} \alias{fitBayes} \title{Evolutionary model fitting with intraspecific variability using Bayesian MCMC} \usage{ fitBayes(tree, x, ngen=10000, model="BM", method="reduced", control=list()) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{x}{a vector of phenotypic values for individuals; \code{names(x)} should contain the species names (not individual IDs).} \item{ngen}{a integer indicating the number of generations for the MCMC.} \item{model}{an evolutionary model: either \code{"BM"} or \code{"lambda"}.} \item{method}{a method: either \code{"reduced"} or \code{"full"}.} \item{control}{a list of control parameters containing the following elements: \code{sig2}: starting value for \eqn{\sigma^2} (BM rate); \code{lambda}: starting value for the \eqn{\lambda} parameter; \code{a}: starting for the state at the root node; \code{xbar}: starting values for the states at the tips; \code{intV}: starting value for the intraspecific variance (reduced method); or \code{v}: starting value for the vector of intraspecific variances for all species (full method); \code{pr.mean}: means for the prior distributions in the following order - \code{sig2}, \code{lambda} (if applicable), \code{a}, \code{xbar}, \code{intV} or \code{v} (if applicable), note that the prior probability distribution is exponential for \code{sig2} and normal for \code{a} and \code{y}; \code{pr.var}: variances on the prior distributions, same order as \code{pr.mean}.} } \description{ \code{fitBayes} uses Bayesian MCMC to sample terminal states (species means) as well as the parameters of an evolutionary model from their joint posterior distribution, following Revell & Reynolds (2012). } \value{ An object of class \code{"fitBayes"} that includes a matrix (\code{mcmc}) with a number of rows \code{ngen/control$sample+1} containing the posterior sample and likelihoods. Matrix columns are labeled by species (for species means and variances), or by the corresponding evolutionary parameter. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. Revell, L. J. and R. G. Reynolds. (2012) A new Bayesian method for fitting evolutionary models to comparative data with intraspecific variation. \emph{Evolution}, 66, 2697-2707. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{anc.Bayes}}, \code{\link{brownie.lite}}, \code{\link{evol.rate.mcmc}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{bayesian} \keyword{continuous character} phytools/man/expand.clade.Rd0000644000176200001440000000314614546012742015534 0ustar liggesusers\name{expand.clade} \alias{expand.clade} \alias{plot.expand.clade} \title{Expands (or contracts) the tip-spacing of a given clade or clades} \usage{ expand.clade(tree, node, factor=5) \method{plot}{expand.clade}(x, ...) } \arguments{ \item{tree}{tree an object of class \code{"phylo"} or \code{"simmap"}.} \item{node}{node index or vector of node indices.} \item{factor}{expansion factor for the tip-spacing of the taxa descended from node or nodes in \code{node}.} \item{x}{for \code{plot} method, an object of class \code{"expand.clade"}.} \item{...}{optional arguments to be passed to \code{plotTree} or \code{plotSimmap}, depending on the class of \code{x$tree}.} } \description{ Modify the tip-spacing of a plotted tree. } \details{ The purpose of this function is to compute a custom tip-spacing for users who want to expand or contract the tip-spacing of the descendant taxa from a given node or nodes. } \value{ The function returns an object of class \code{"expand.clade"} which consists of the (possibly re-ordered) tree and a numerical vector with the calculated tip spacing based on the expansion factor specified by the user. This object can be plotted using the S3 \code{plot} method for the object class; or it can be plotted simply by calling a standard plotting function on the tree & tip spacings. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{plotting} \keyword{utilities} phytools/man/getExtant.Rd0000644000176200001440000000242014546013314015137 0ustar liggesusers\name{getExtant} \alias{getExtant} \alias{getExtinct} \title{Returns a list of the extant or extinct lineages in a tree containing non-contemporaneous tips} \usage{ getExtant(tree, tol=1e-8) getExtinct(tree, tol=1e-8) } \arguments{ \item{tree}{a phylogeny stored as an object of class \code{"phylo"} with some tips that are non-contemporaneous (i.e., end before the present).} \item{tol}{a tolerance value to account for numerical imprecision.} } \description{ Computes the set of extant or extinct tips from a phylogenetic tree. } \details{ The function \code{getExtant} takes a tree as input and returns a vector containing the names of all the tips that have a height above the root that is equal (to a degree of numerical precision determined by \code{tol}) to the height of the highest tip. These tips are presumed to be "extant." \code{getExtinct} returns the complement. } \value{ A vector with the tip names of extant or extinct species in the tree. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{nodeHeights}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/matchNodes.Rd0000644000176200001440000000411714546013642015272 0ustar liggesusers\name{matchNodes} \alias{matchNodes} \alias{matchLabels} \title{Matches nodes between two trees} \usage{ matchNodes(tr1, tr2, method=c("descendants","distances"), ...) matchLabels(tr1, tr2) } \arguments{ \item{tr1}{first tree.} \item{tr2}{second tree.} \item{method}{method to use to match nodes between trees. \code{"descendants"} uses the tip species descended from each node; \code{"distances"} uses the distances from the nodes to the tips. Any unambiguous shortening of \code{"descendants"} or \code{"distances"} is also permitted.} \item{...}{optional arguments which may or may not be used depending on the value of \code{method}. \code{tol} is a tolerance value for the difference from exact matching that is allowed for \code{method="distances"}. \code{corr}, which is \code{FALSE} by default, indicates whether to match nodes under \code{method="distances"} using the correlation (\code{corr=TRUE}) or the absolute similarity of distances.} } \description{ This function returns a matrix in which the first column contains \emph{all} of the internal nodes of \code{tr1} and the second column contains the matching nodes from \code{tr2}, inasmuch as they can be identified. } \details{ For \code{method="descendants"}, pairs of matching nodes are defined by sharing all descendant leaves in common. For \code{method="distances"}, nodes are considered to matched if the share the same set of distances (or proportional distances, for optional argument \code{corr=TRUE}) to all tips. \code{matchLabels} is functionally equivalent but matches node (tip) indices based on identifying matching in the labels only. } \value{ A matrix in which the first column contains the nodes of \code{tr1} with the second column containing matching nodes in \code{tr2}, with the criterion for matching defined by \code{method}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/labelnodes.Rd0000644000176200001440000000227514546013427015321 0ustar liggesusers\name{labelnodes} \alias{labelnodes} \title{Function to interactively label nodes of a plotted tree} \usage{ labelnodes(text, node=NULL, interactive=TRUE, shape=c("circle","ellipse", "rect"), ...) } \arguments{ \item{text}{text string or vector to be used as labels.} \item{node}{node numbers (indices) for the labels.} \item{interactive}{logical value indicating whether or not nodes should be supplied interactively. (I.e., by clicking on the nodes.)} \item{shape}{shape to plot around the plotted node label(s).} \item{...}{optional arguments.} } \description{ Adds node labels to a plotted object of class \code{"phylo"}. } \details{ The nodes to be labels can be selected interactively by the user (i.e., by clicking on the corresponding nodes of the plotted tree). } \value{ Invisibly returns a vector of the node indices for the labeled nodes. } \seealso{ \code{\link{cladelabels}}, \code{\link{nodelabels}} } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{plotting} \keyword{utilities} phytools/man/posterior.evolrate.Rd0000644000176200001440000000341014546016573017054 0ustar liggesusers\name{posterior.evolrate} \alias{posterior.evolrate} \title{Analysis of the posterior sample from evol.rate.mcmc} \usage{ posterior.evolrate(tree, ave.shift, mcmc, tips, showTree=FALSE) } \arguments{ \item{tree}{a phylogenetic tree in \code{"phylo"} format.} \item{ave.shift}{mean or median shift-point from the posterior sample (see \code{\link{minSplit}}.} \item{mcmc}{matrix \code{$mcmc} from \code{evol.rate.mcmc} (probably with burn-in excluded).} \item{tips}{list of tips in state \eqn{\sigma_1^2} for each sampled generation of MCMC.} \item{showTree}{optional logical value indicating whether or not to plot the stretched and shrunken tree generated by the pre-processing algorithm implemented in this function (default is \code{FALSE}).} } \description{ Analyzes posterior sample from \code{\link{evol.rate.mcmc}}. } \details{ This function takes a phylogenetic tree, an average split position, and a raw MCMC output from \code{evol.rate.mcmc} and returns a posterior sample of evolutionary rates rootward (\eqn{\sigma_1^2}) and tipward (\eqn{\sigma_2^2}) from the average split. } \value{ A matrix containing the posterior sample of evolutionary rates and shift-points between rates. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. Revell, L. J., D. L. Mahler, P. Peres-Neto, and B. D. Redelings (2012) A new method for identifying exceptional phenotypic diversification. \emph{Evolution}, \bold{66}, 135-146. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{evol.rate.mcmc}}, \code{\link{minSplit}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{bayesian} \keyword{continuous character} phytools/man/geo.legend.Rd0000644000176200001440000000321614546013260015207 0ustar liggesusers\name{geo.legend} \alias{geo.legend} \alias{geo.palette} \title{Adds a geological (or other temporal) legend to a plotted tree} \usage{ geo.legend(leg=NULL, colors=NULL, alpha=0.2, ...) geo.palette() } \arguments{ \item{leg}{a matrix with the starting & ending point of each plotted era in rows, & names of the time periods as rownames.} \item{colors}{a vector of colors for the time periods of the rows in \code{leg}.} \item{alpha}{transparency level to apply to \code{colors}.} \item{...}{optional arguments.} } \description{ Adds a geological legend to a plotted tree. } \details{ The function \code{geo.legend} adds a geological (or other temporal) legend to a plotted tree. The function \code{geo.palette} returns a geological time color palette to the user. } \value{ \code{geo.legend} adds a visual element to a plotted tree and invisible returns an object of class \code{geo.legend} containing the time periods and colors of the painted legend. \code{geo.palette} simply returns a geological timescale color palette as an object of class \code{"geo.palette"}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \examples{ data(anoletree) ## rescale tree to 50 ma total depth anoletree<-rescale(anoletree,model="depth",depth=50) ## plot phylogeny plotTree(anoletree,ylim=c(-0.16,1)*Ntip(anoletree), ftype="i",lwd=1,fsize=0.5) ## add geological color legend obj<-geo.legend() par(mar=c(5.1,4.1,4.1,2.1)) } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{plotting} phytools/man/reroot.Rd0000644000176200001440000000344514546017415014524 0ustar liggesusers\name{reroot} \alias{reroot} \title{Re-root a tree along an edge} \usage{ reroot(tree, node.number, position=NULL, interactive=FALSE, ...) } \arguments{ \item{tree}{a phylogenetic tree in \code{"phylo"} format.} \item{node.number}{ number of the node descending from the target branch in \code{tree$edge} - this can also be a tip in which case the node number is the index number of the tip in \code{tree$tip.label}.} \item{position}{position along the target edge at which to re-root the tree. If not supplied, then the tree will be re-rooted \emph{at} the node or tip.} \item{interactive}{logical value indicating whether to use interactive mode (defaults to \code{interactive=} \code{FALSE}).} \item{...}{arguments to be passed to \code{plotTree} for \code{interactive=TRUE} only.} } \description{ Re-roots a phylogenetic tree at an arbitrary position along an edge. } \details{ This function had an error for rootings along edges descended from the root node for \pkg{phytools}<=0.2-47. This should be fixed in the present version. Now uses \code{\link{paste.tree}}, \code{\link{root}}, and \code{\link{splitTree}} internally. Earlier versions also had an error related to node labels. This should be fixed in \pkg{phytools}>=0.4-47. } \value{ A phylogenetic tree in \code{"phylo"} format. } \references{ Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{splitTree}}, \code{\link{paste.tree}}, \code{\link{root}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/bd.Rd0000644000176200001440000000204014546011600013553 0ustar liggesusers\name{bd} \alias{bd} \title{Convert object of class \code{"birthdeath"} to raw birth & death rates} \usage{ bd(x) } \arguments{ \item{x}{object of class \code{"birthdeath"}.} } \description{ Converts an object of class \code{"birthdeath"} (from \code{\link{birthdeath}}) to a vector with the ML birth & death rates. } \details{ This is now somewhat obsolete as \pkg{phytools} now contains functions to fit birth-death and pure-birth diversification models from trees (\code{\link{fit.bd}} and \code{\link{fit.yule}}) that also take into account incomplete sampling fraction. } \value{ A vector. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{birthdeath}}, \code{\link{fit.bd}}, \code{\link{fit.yule}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{utilities} \keyword{diversification} \keyword{maximum likelihood} phytools/man/edge.widthMap.Rd0000644000176200001440000000400414546012511015652 0ustar liggesusers\name{edge.widthMap} \alias{edge.widthMap} \alias{plot.edge.widthMap} \title{Map continuous trait evolution on the tree} \usage{ edge.widthMap(tree, x, ...) \method{plot}{edge.widthMap}(x, max.width=0.9, legend="trait value", ...) } \arguments{ \item{tree}{object of class \code{"phylo"}.} \item{x}{a numerical vector of phenotypic trait values for species. \code{names(x)} should contain the species names and match \code{tree$tip.label}. Or, for \code{plot.edge.widthMap}, an object of class \code{"edge.widthMap"}.} \item{max.width}{maximum edge width in plot units.} \item{legend}{label for the plot legend.} \item{...}{optional arguments - especially for the \code{plot} method. Perhaps the most important of these is \code{min.width}, which defaults to \code{0} but could probably be increased for many datasets and graphical devices. Other arguments are passed internally to \code{\link{plotTree}}.} } \description{ Maps a discrete character onto the edges of the tree using variable edge widths. } \value{ \code{edge.widthMap} returns an object of class \code{"edge.widthMap"}. \code{plot.edge.widthMap} can be used to plot this object. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{contMap}}, \code{\link{fastAnc}} } \examples{ ## load data from Garland et al. (1992) data(mammal.tree) data(mammal.data) ## extract character of interest ln.bodyMass<-log(setNames(mammal.data$bodyMass, rownames(mammal.data))) ## create "edge.widthMap" object mammal.ewMap<-edge.widthMap(mammal.tree,ln.bodyMass, min.width=0.05) ## plot it plot(mammal.ewMap,legend="log(body mass)") par(mar=c(5.1,4.1,4.1,2.1)) ## reset margins to default } \keyword{ancestral states} \keyword{phylogenetics} \keyword{plotting} \keyword{comparative method} \keyword{continuous character} \keyword{maximum likelihood} phytools/man/applyBranchLengths.Rd0000644000176200001440000000161714546011370016773 0ustar liggesusers\name{applyBranchLengths} \alias{applyBranchLengths} \title{Applies the branch lengths of a reference tree to a target} \usage{ applyBranchLengths(tree, edge.length) } \arguments{ \item{tree}{target tree.} \item{edge.length}{number of digits for rounding. Passed to \code{\link{round}}.} } \description{ Applies the branch lengths of a reference tree to a target. } \details{ This function applies the set of branch lengths from a reference tree to a target tree while reconciling any mappings (as in \code{\link{read.simmap}}) with the new branch lengths. } \value{ An object of class \code{"phylo"} or \code{"simmap"}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/mapped.states.Rd0000644000176200001440000000152514546013624015755 0ustar liggesusers\name{mapped.states} \alias{mapped.states} \title{Returns a vector, matrix, or list of the mapped states on a tree or set of trees} \usage{ mapped.states(tree, ...) } \arguments{ \item{tree}{a single tree or a set of trees as an object of class \code{"simmap"} or \code{"multiSimmap"}, respectively.} \item{...}{optional arguments.} } \description{ Computes and orders a vector, matrix, or list of the unique mapped states on a tree or state of trees of class \code{"simmap"} or \code{"multiSimmap"}. } \value{ A vector, matrix, or list. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{comparative method} \keyword{phylogenetics} \keyword{utilities} phytools/man/map.to.singleton.Rd0000644000176200001440000000471114546013614016403 0ustar liggesusers\name{map.to.singleton} \alias{map.to.singleton} \alias{plotTree.singletons} \alias{drop.tip.singleton} \alias{rootedge.to.singleton} \title{Converts a tree without singletons to a tree with singleton nodes} \usage{ map.to.singleton(tree) plotTree.singletons(tree) \method{drop.tip}{singleton}(phy, tip, ...) rootedge.to.singleton(tree) } \arguments{ \item{tree}{an object of class \code{"simmap"} (for \code{map.to.singleton}, or a tree with one or more singleton nodes (for \code{plotTree.singletons}, \code{drop.tip.singleton}, and \code{rootedge.to.singleton}).} \item{phy}{for \code{drop.tip.singleton}, an object of class \code{"singleton"} or \code{"phylo"}.} \item{tip}{for \code{drop.tip.singleton}, a tip label or vector of tip labels.} \item{...}{optional arguments for \code{drop.tip.singleton}.} } \description{ \code{map.to.singleton} takes an object of class \code{"simmap"} with a mapped discrete character and converts it to a tree with singleton nodes, in which edge has only one state. } \details{ The states for each edge are stored in \code{names(tree$edge.length)}. In a sense this is just an alternative way to use the general structure of the \code{"phylo"} object to encode a tree with a mapped character. \code{plotTree.singletons} plots a tree with singleton nodes. Note that \code{\link{plotTree}} and \code{\link{plot.phylo}} now have no trouble graphing trees with singleton nodes - but they do this by just ignoring the singletons. \code{plotTree.singletons} marks the singletons as nodes on the plotted phylogeny. \code{drop.tip.singleton} drops tips from the tree leaving ancestral nodes for all remaining tips as singletons. Finally, \code{rootedge.to.singleton} converts a tree with a root edge to a tree with a singleton node instead. } \value{ An object of class \code{"phylo"} with singleton nodes. \code{plotTree.singletons} graphs a tree in which the singleton nodes are shown. If \code{names(tree$edge.length)!=NULL} \code{plotTree.singletons} will use a different color from \code{\link{palette}} for each mapped state. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{collapse.singles}}, \code{\link{drop.tip}}, \code{\link{make.simmap}} } \keyword{phylogenetics} \keyword{utilities} \keyword{plotting} phytools/man/treeSlice.Rd0000644000176200001440000000337014546020377015127 0ustar liggesusers\name{treeSlice} \alias{treeSlice} \title{Slices the tree at a particular point and returns all subtrees, or the tree rootward of the point} \usage{ treeSlice(tree, slice, trivial=FALSE, prompt=FALSE, ...) } \arguments{ \item{tree}{is a phylogenetic tree in \code{"phylo"} format.} \item{slice}{a real number indicating the height above the root at which to slice the tree.} \item{trivial}{a logical value indicating whether or not to return subtrees with a number of tips less than two (default is \code{FALSE}).} \item{prompt}{logical value indicating whether or not the height of the slice should be given interactively.} \item{...}{for \code{prompt=TRUE}, other arguments to be passed to \code{\link{plotTree}}. In addition, the argument \code{orientation} can be used to specify whether the \code{"tipwards"} subtrees or the \code{"rootwards"} phylogeny are/is to be returned by the function call (using those two argument values, respectively).} } \description{ Cut (or slice) a phylogenetic tree at a particular time point. } \details{ This function slices a tree at a particular height above the root and returns all subtrees or all non-trivial subtrees (i.e., subtrees with more than 1 taxon). Uses \code{\link{extract.clade}} in the \pkg{ape} package. \code{treeSlice} can also be used to crop the terminal fraction of a tree for \code{orientation="rootwards"}. } \value{ An object of class \code{"phylo"} or \code{"multiPhylo"}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{extract.clade}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/strahlerNumber.Rd0000644000176200001440000000256614546020011016174 0ustar liggesusers\name{strahlerNumber} \alias{strahlerNumber} \alias{extract.strahlerNumber} \title{Computes Strahler number for trees and nodes} \usage{ strahlerNumber(tree, plot=TRUE) extract.strahlerNumber(tree, i, plot=TRUE) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{i}{order of Strahler number to extract for \code{extract.strahlerNumber}.} \item{plot}{logical value indicating whether to plot the tree with Strahler numbers for node labels.} } \description{ Computes the Strahler number of all nodes and tips in a phylogenetic tree. } \details{ The function \code{strahlerNumber} computes the Strahler number of all nodes and tips in the tree. For more information about Strahler numbers see \url{https://en.wikipedia.org/wiki/Strahler_number}. The function \code{extract.strahlerNumber} extracts all of the most inclusive clades of Strahler number \code{i}. } \value{ Either a vector with the Strahler number for each tip and internal node; or (for \code{extract.strahlerNumber} the set of (most inclusive) subtrees with Strahler number \code{i} as an object of class \code{"multiPhylo"}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/rescaleSimmap.Rd0000644000176200001440000000350314546017446015776 0ustar liggesusers\name{rescale.simmap} \alias{rescale.simmap} \alias{rescale.multiSimmap} \alias{rescaleSimmap} \title{Rescale object of class \code{"simmap"}} \usage{ \method{rescale}{simmap}(x, model="depth", ...) \method{rescale}{multiSimmap}(x, model="depth", ...) rescaleSimmap(tree, ...) } \arguments{ \item{x}{object of class \code{"simmap"} or \code{"multiSimmap"} to be rescaled.} \item{model}{model to use to rescale the tree. Currently the only option is \code{"depth"}.} \item{...}{parameter of the model to use in rescaling. Currently the only parameter is \code{depth} for \code{model="depth"}.} \item{tree}{for \code{rescaleSimmap}, object of class \code{"simmap"} to be rescaled.} } \description{ Scales a tree with a mapped discrete character (\code{"simmap"} object), or a set of such trees, to an arbitrary total height, preserving the relative time spent in each state along each edge. } \details{ Replaces \code{rescaleTree} (now \code{rescale.phylo}) in the \pkg{geiger} package for the \code{"simmap"} object class. \code{rescaleSimmap} is now a redundant alias for the method \code{rescale.simmap}. } \value{ An object of class \code{"simmap"} or \code{"multiSimmap"}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{make.simmap}}, \code{\link{read.simmap}} } \examples{ ## load anoletree data(anoletree) ## rescale to have total depth of 50 rescaled_anoletree<-rescale(anoletree,depth=50) ## plot rescaled tree plot(rescaled_anoletree,ftype="i",fsize=0.6, mar=c(5.1,1.1,1.1,1.1)) axis(1,at=seq(0,50,by=10)) par(mar=c(5.1,4.1,4.1,2.1)) ## reset margin to default } \keyword{phylogenetics} \keyword{utilities} phytools/man/locate.fossil.Rd0000644000176200001440000000361614546013472015756 0ustar liggesusers\name{locate.fossil} \alias{locate.fossil} \title{Locate a fossil lineage in a tree using continuous characters} \usage{ locate.fossil(tree, X, ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{X}{a matrix with continuous character data.} \item{...}{optional arguments including \code{time.constraint} which can be a scalar (positive height above the root of the fossil or negative time before present) or a vector (age range of fossil, either positive or negative); \code{edge.constraint}, which is equivalent to \code{constraint} in \code{\link{locate.yeti}}; \code{plot}, \code{rotate}, and \code{quiet}, which have the same interpretation (and defaults) as the equivalent arguments in \code{\link{locate.yeti}}.} } \description{ Uses ML to place a fossil lineage into a tree using continuous traits following Revell et al. (2015). } \value{ Optimized tree as an object of class \code{"phylo"}. } \references{ Felsenstein, J. (1981) Maximum likelihood estimation of evolutionary trees from continuous characters. \emph{American Journal of Human Genetics}, 25, 471-492. Felsenstein, J. (2002) Quantitative characters, phylogenies, and morphometrics. In: MacLeod, N. and P. Forey (Eds.) \emph{Morphology, Shape and Phylogeny} (pp. 27-44). Taylor and Francis, London. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. Revell, L. J., D. L. Mahler, R. G. Reynolds, and G. J. Slater. (2015) Placing cryptic, recently extinct, or hypothesized taxa into an ultrametric phylogeny using continuous, character data: A case study with the lizard \emph{Anolis roosevelti}. \emph{Evolution}, \bold{69}, 1027-1035. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{phylogeny inference} \keyword{maximum likelihood} \keyword{continuous character} phytools/man/phylo.heatmap.Rd0000644000176200001440000000452514546016161015760 0ustar liggesusers\name{phylo.heatmap} \alias{phylo.heatmap} \title{Creates a phylogenetic heat map} \usage{ phylo.heatmap(tree, X, fsize=1, colors=NULL, standardize=FALSE, ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{X}{a matrix containing data for multiple continuous characters in which \code{rownames} correspond to the tip labels of the tree.} \item{fsize}{an integer or vector of length 3 containing the font size for the tip labels, the trait labels, and the legend text. (If a single integer is supplied, then the value will be recycled.)} \item{colors}{a vector of colors to be passed to \code{\link{image}}. Can be a function call (e.g., \code{heat.colors(n=} \code{200)[200:1]}).} \item{standardize}{a logical value indicating whether or not to standardize each column of \code{X} to have the same variance & mean prior to analysis.} \item{...}{optional arguments. So far these include: \code{legend}, a logical value indicating whether or not to plot a figure legend (defaults to \code{legend=TRUE}); \code{labels}, a logical value indicating whether or not to plot trait labels (defaults to \code{labels=TRUE}); \code{split}, a numeric vector indicating the fraction of the horizontal dimension to use for the tree & heatmap, respectively (defaults to \code{split=c(0.5,0.5)}); \code{xlim}, \code{ylim}, & \code{mar}, defined as in \code{\link{par}}; and \code{ftype}, \code{lwd}, and \code{pts} as defined in \code{\link{plotSimmap}}.} } \description{ Multivariate phylogenetic \code{\link{heatmap}} plot. } \value{ Function creates a plot. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \examples{ ## load data data(anoletree) data(anole.data) ## compute phylogenetic residuals anole.data<-as.matrix(anole.data) anole.resids<-cbind(anole.data[,1], phyl.resid(anoletree,anole.data[,1,drop=FALSE], anole.data[,2:ncol(anole.data)])$resid) colnames(anole.resids)[1]<-"SVL" ## plot phylogenetic heatmap phylo.heatmap(anoletree,anole.resids, split=c(0.7,0.3),fsize=c(0.4,0.8,0.8), standardize=TRUE,pts=FALSE) par(mar=c(5.1,4.1,4.1,2.1)) ## reset margins to default } \keyword{phylogenetics} \keyword{plotting} \keyword{continuous character} phytools/man/mrp.supertree.Rd0000644000176200001440000000624214546013776016031 0ustar liggesusers\name{mrp.supertree} \alias{mrp.supertree} \alias{compute.mr} \title{Matrix representation parsimony supertree estimation} \usage{ mrp.supertree(trees, method=c("pratchet","optim.parsimony"), ...) compute.mr(trees, type=c("phyDat","matrix")) } \arguments{ \item{trees}{an object of class \code{"multiPhylo"} that consists of a list of phylogenetic trees.} \item{method}{an argument specifying whether to optimize the tree using the \pkg{phangorn} parsimony optimizer \code{\link{pratchet}} or \code{\link{optim.parsimony}}.} \item{type}{for \code{compute.mr}, the type of object to return (e.g., \code{"phyDat"} or \code{"matrix"}).} \item{...}{optional arguments - mostly to be passed to \code{\link{pratchet}} or \code{\link{optim.parsimony}}.} } \description{ This function estimates the MRP (matrix representation parsimony) supertree from a set of input trees (Baum 1992; Ragan 1992). } \details{ \code{mrp.supertree} uses \code{\link{pratchet}} or \code{\link{optim.parsimony}} from the \pkg{phangorn} package (Schliep, 2011) for optimization, and \code{\link{prop.part}} from \pkg{ape} package (Paradis et al. 2004). See \code{\link{pratchet}} or \code{\link{optim.parsimony}} for optional arguments, which vary slightly depending on the method. All optional arguments of these methods are available to the user with one exception. The argument \code{tree} in \code{\link{optim.parsimony}} is supplied instead as \code{start}. In addition to being an object of class \code{"phylo"}, \code{start} can also be assigned the string values of \code{"NJ"} or \code{"random"}, in which case either a neighbor-joining or random tree will be used as the starting tree for optimization. The function \code{compute.mr} computes the matrix-representation matrix of the input trees. It is used internally by \code{mrp.supertree}, but can also be used to export an object that can be written to file if desired. } \value{ An object of class \code{"phylo"} or \code{"multiPhylo"} that is the MP or set of MP MRP trees. In the case of \code{compute.mr}, an object of class \code{"phyDat"} or a matrix. } \references{ Baum, B. R., (1992) Combining trees as a way of combining data sets for phylogenetic inference, and the desirability of combining gene trees. \emph{Taxon}, \bold{41}, 3-10. Felsenstein, J. (2004) \emph{Inferring Phylogenies}. Sinauer. Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290. Ragan, M. A. (1992) Phylogenetic inference based on matrix representation of trees. \emph{Molecular Phylogenetics and Evolution}, \emph{1}, 53-58. Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. Schliep, K. P. (2011) phangorn: phylogenetic analysis in R. \emph{Bioinformatics}, \bold{27}, 592-593. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{exhaustiveMP}}, \code{\link{optim.parsimony}}, \code{\link{pratchet}} } \keyword{phylogenetics} \keyword{phylogeny inference} \keyword{parsimony} \keyword{supertree} \keyword{consensus tree} phytools/man/ltt95.Rd0000644000176200001440000000405014546013534014162 0ustar liggesusers\name{ltt95} \alias{ltt95} \alias{plot.ltt95} \title{Creates a (1-\eqn{\alpha})\% CI for a set of LTTs} \usage{ ltt95(trees, alpha=0.05, log=FALSE, method=c("lineages","times"), mode=c("median","mean"), ...) \method{plot}{ltt95}(x, ...) } \arguments{ \item{trees}{is an object of class \code{"multiPhylo"} containing a list of phylogenetic trees.} \item{alpha}{confidence level. Defaults to \code{alpha=0.05}. \code{alpha=0} will mean that the interval around \emph{all} trees in the set will be plotted.} \item{log}{logical value indicating whether or not to plot on the semi-log scale.} \item{method}{plot the CI on the number of lineages given time (\code{"lineages"}); or on times given a number of lineages (\code{"times"}).} \item{mode}{plot the median or mean LTT.} \item{x}{object of class \code{"ltt95"} for plotting method.} \item{...}{optional arguments to be used by \code{ltt95} or the plotting method. So far: \code{res} gives the number of time-steps (defaults to \code{res=100}); \code{xaxis} (\code{"standard"}, \code{"negative"}, or \code{"flipped"}) determines the scale (time from the root, time back from the present, or time from the present) of the x-axis of the plot; \code{lend} determines the line end type (as in \code{\link{par}}); \code{shaded} determines whether to plot the (1-\eqn{\alpha})\% CI using dotted lines (if \code{FALSE}) or shading (if \code{TRUE}); and \code{bg} is the background color for shading if \code{shaded=TRUE}.} } \description{ This function computes LTT plots for a set of trees & plots a (1-\eqn{\alpha})\% CI by various methods. (See \code{\link{ltt}} for more details.) } \details{ This function creates a plot and invisibly returns an object of class \code{"ltt95"}. } \references{ Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). \emph{PeerJ}, \bold{12}, e16505. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ltt}} } \keyword{phylogenetics} \keyword{plotting} \keyword{diversification} phytools/DESCRIPTION0000644000176200001440000000360614547214442013655 0ustar liggesusersPackage: phytools Version: 2.1-1 Date: 2024-01-08 Title: Phylogenetic Tools for Comparative Biology (and Other Things) Author: Liam J. Revell Maintainer: Liam J. Revell Depends: R (>= 3.5.0), ape (>= 5.7), maps Imports: clusterGeneration, coda, combinat, doParallel, expm, foreach, graphics, grDevices, MASS, methods, mnormt, nlme, numDeriv, optimParallel, parallel, phangorn (>= 2.3.1), scatterplot3d, stats, utils Suggests: animation, geiger, plotrix, RColorBrewer, rgl ZipData: no Description: A wide range of methods for phylogenetic analysis - concentrated in phylogenetic comparative biology, but also including numerous techniques for visualizing, analyzing, manipulating, reading or writing, and even inferring phylogenetic trees. Included among the functions in phylogenetic comparative biology are various for ancestral state reconstruction, model-fitting, and simulation of phylogenies and trait data. A broad range of plotting methods for phylogenies and comparative data include (but are not restricted to) methods for mapping trait evolution on trees, for projecting trees into phenotype space or a onto a geographic map, and for visualizing correlated speciation between trees. Lastly, numerous functions are designed for reading, writing, analyzing, inferring, simulating, and manipulating phylogenetic trees and comparative data. For instance, there are functions for computing consensus phylogenies from a set, for simulating phylogenetic trees and data under a range of models, for randomly or non-randomly attaching species or clades to a tree, as well as for a wide range of other manipulations and analyses that phylogenetic biologists might find useful in their research. License: GPL (>= 2) URL: https://github.com/liamrevell/phytools Packaged: 2024-01-08 16:48:29 UTC; liamj Repository: CRAN Date/Publication: 2024-01-09 10:00:02 UTC NeedsCompilation: no phytools/R/0000755000176200001440000000000014533454303012340 5ustar liggesusersphytools/R/phyl.RMA.R0000644000176200001440000000624014453257654014072 0ustar liggesusers## this function computes a phylogenetic reduced major axis (RMA) regression ## written by Liam Revell 2010, 2011, 2012, 2015, 2016, 2017, 2023 phyl.RMA<-function(x,y,tree,method="BM",lambda=NULL,fixed=FALSE,h0=1.0){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") x<-x[tree$tip.label]; y<-y[tree$tip.label] # bind the x & y into columns X<-cbind(x,y) if(method=="lambda") if(fixed==FALSE) result<-optimize(f=likMlambda,interval=c(0,1),X=X,C=vcv(tree), maximum=TRUE) else result<-list(objective=likMlambda(lambda,X,vcv(tree)),maximum=lambda) else if(method=="BM") result<-list(objective=likMlambda(1.0,X,vcv(tree)),maximum=1.0) else stop("do not recognize method") est.lambda<-result$maximum # estimated lambda C<-vcv(tree) C<-lambda.transform(est.lambda,C) temp<-phyl.vcv(X,vcv(tree),lambda=est.lambda) beta1<-sign(temp$R[1,2])*sqrt(temp$R[2,2]/temp$R[1,1]) beta0<-temp$a[2]-beta1*temp$a[1] r<-y-(beta0+beta1*x) r2<-temp$R[1,2]^2/(temp$R[1,1]*temp$R[2,2]) if(sign(beta1)!=sign(h0)){ warning("b & h0 have different signs; hypothesis test invalid") T<-0 } else T<-abs(log(abs(beta1))-log(abs(h0)))/sqrt((1-r2)/(Ntip(tree)-2)) df<-2+(Ntip(tree)-2)/(1+0.5*r2) P<-2*pt(T,df=df,lower.tail=FALSE) test<-c(r2,T,df,P); names(test)<-c("r2","T","df","P") object<-list(RMA.beta=c(beta0,beta1),V=temp$R,lambda=est.lambda, logL=as.numeric(result$objective),test=test,h0=h0,model=method, resid=as.matrix(r),data=cbind(x,y),tree=tree) class(object)<-"phyl.RMA" object } ## S3 methods for "phyl.RMA" object class print.phyl.RMA<-function(x,...){ cat("\nCoefficients:\n") print(coef(x)) cat("\nVCV matrix:\n") print(x$V) cat("\n") if(x$model=="BM") cat("Model for the covariance structure of the error is \"BM\"\n") else cat("Model for the covariance structure of the error is \"lambda\"\n") cat("\nEstimates (or set values):\n") print(setNames(c(x$lambda,x$logL),c("lambda","log(L)"))) cat("\n") cat("Hypothesis test based on Clarke (1980; Biometrika):\n") print(round(x$test,6)) cat(paste("\nNote that the null hypothesis test is h0 =",x$h0, "\n\n")) } coef.phyl.RMA<-function(object,...){ val<-setNames(object$RMA.beta,c("(Intercept)","x")) val } residuals.phyl.RMA<-function(object,...) object$resid[,1] plot.phyl.RMA<-function(x,...){ args<-list(tree=x$tree, X=x$data, node.size=c(0,0), ftype="off",...) do.call(phylomorphospace,args) #phylomorphospace(x$tree,x$data,node.size=c(0,0),ftype="off", # ...) points(x$data,cex=1.2,pch=21,bg="grey") x0<-ace(x$data[,1],x$tree,method="pic")$ace[1] y0<-ace(x$data[,2],x$tree,method="pic")$ace[1] a0<-y0-x$h0*x0 grid() abline(a=a0,b=x$h0,lwd=2,col="grey",lty="dashed") abline(a=coef(x)[1],b=coef(x)[2],lwd=2,col="red") tmp<-legend(x=0,y=0,legend=c(expression(beta[RMA]),expression(h[0])), lty=c("solid","dashed"),lwd=c(2,2),plot=FALSE) legend(x=if(x$h0>0) par()$usr[1] else par()$usr[2]-tmp$rect$w, y=par()$usr[4],col=c("red","grey"), legend=c(expression(beta[RMA]),expression(h[0])), lty=c("solid","dashed"),lwd=c(2,2), bg=make.transparent("white",0.75),bty="n") } phytools/R/plotTree.errorbars.R0000644000176200001440000000351314375517350016271 0ustar liggesusers## plot tree with error bars around divergence times at nodes ## written by Liam J. Revell 2017 plotTree.errorbars<-function(tree,CI,...){ args<-list(...) if(!is.null(args$gridlines)){ gridlines<-args$gridlines args$gridlines<-NULL } else gridlines<-TRUE if(is.null(args$mar)) args$mar<-c(4.1,1.1,1.1,1.1) if(is.null(args$ftype)) args$ftype<-"i" fsize<-if(!is.null(args$fsize)) args$fsize else 1 if(is.null(args$direction)) args$direction<-"leftwards" if(!is.null(args$bar.width)){ bar.width<-args$bar.width args$bar.width<-NULL } else bar.width<-11 if(!is.null(args$cex)){ cex<-args$cex args$cex<-NULL } else cex<-1.2 if(!is.null(args$bar.col)){ bar.col<-args$bar.col args$bar.col<-NULL } else bar.col<-"blue" par(mar=args$mar) plot.new() th<-max(nodeHeights(tree)) h<-max(th,max(CI)) if(is.null(args$xlim)){ m<-min(min(nodeHeights(tree)),min(CI)) d<-diff(c(m,h)) pp<-par("pin")[1] sw<-fsize*(max(strwidth(tree$tip.label,units="inches")))+ 1.37*fsize*strwidth("W",units="inches") alp<-optimize(function(a,d,sw,pp) (a*1.04*d+sw-pp)^2, d=d,sw=sw,pp=pp, interval=c(0,1e6))$minimum args$xlim<-if(args$direction=="leftwards") c(h,m-sw/alp) else c(m,h+sw/alp) } if(is.null(args$at)) at<-seq(0,h,by=h/5) else { at<-args$at args$at<-NULL } args$tree<-tree args$add<-TRUE do.call(plotTree,args=args) if(gridlines) abline(v=at,lty="dashed", col=make.transparent("grey",0.5)) axis(1,at=at,labels=signif(at,3)) obj<-get("last_plot.phylo",envir=.PlotPhyloEnv) for(i in 1:tree$Nnode+Ntip(tree)) lines(x=c(CI[i-Ntip(tree),1],CI[i-Ntip(tree),2]), y=rep(obj$yy[i],2),lwd=bar.width,lend=0, col=make.transparent(bar.col,0.4)) points(obj$xx[1:tree$Nnode+Ntip(tree)], obj$yy[1:tree$Nnode+Ntip(tree)],pch=19,col=bar.col, cex=cex) } phytools/R/ratebytree.R0000644000176200001440000007045614375517350014653 0ustar liggesusers## method to compare the rate of evolution for a character between trees ## continuous character method closely related to 'censored' approach of O'Meara et al. (2006; Evolution) ## discrete character method fits Mk model of Lewis 2001 ## diversification method fits Yule or birth-death model of Nee et al. (1994) & Stadler (2012) ## written by Liam J. Revell 2017 ratebytree<-function(trees,x,...){ if(hasArg(type)) type<-list(...)$type else if(!missing(x)&&!is.null(x)) { if(is.factor(unlist(x))||is.character(unlist(x))) type<-"discrete" else type<-"continuous" } else type<-"diversification" if(type=="continuous") obj<-rbt.cont(trees,x,...) else if(type=="discrete") obj<-rbt.disc(trees,x,...) else if(type=="diversification") obj<-rbt.div(trees,...) else { cat(paste("type =",type,"not recognized.\n")) obj<-NULL } obj } rbt.div<-function(trees,...){ if(hasArg(trace)) trace<-list(...)$trace else trace<-FALSE if(hasArg(digits)) digits<-list(...)$digits else digits<-4 if(hasArg(test)) test<-list(...)$test else test<-"chisq" if(hasArg(quiet)) quiet<-list(...)$quiet else quiet<-FALSE if(hasArg(model)) model<-list(...)$model else model<-"birth-death" if(hasArg(rho)) rho<-list(...)$rho else rho<-rep(1,length(trees)) if(hasArg(tol)) tol<-list(...)$tol else tol<-1e-12 if(hasArg(iter)) iter<-list(...)$iter else iter<-10 if(!inherits(trees,"multiPhylo")) stop("trees should be object of class \"multiPhylo\".") if(any(!sapply(trees,is.ultrametric))){ cat("One or more trees fails check is.ultrametric.\n") cat("If you believe your tree to be ultrametric ") cat("use force.ultrametric.\n") stop() } t<-lapply(trees,function(phy) sort(branching.times(phy), decreasing=TRUE)) if(model=="birth-death"){ fit.multi<-mapply(fit.bd,tree=trees,rho=rho,iter=iter,SIMPLIFY=FALSE) logL.multi<-sum(sapply(fit.multi,logLik)) } else if(model=="equal-extinction"){ lik.eqmu<-function(theta,t,rho,trace=FALSE){ lam<-theta[1:length(t)] mu<-theta[length(t)+1] logL<-0 for(i in 1:length(t)) logL<-logL-lik.bd(c(lam[i],mu),t[[i]],rho[i]) if(trace) cat(paste(paste(c(lam,mu,logL),collapse="\t"),"\n",sep="")) -logL } init.b<-sapply(trees,qb) obj<-nlminb(c(init.b,0),lik.eqmu,t=t,rho=rho,trace=trace, lower=rep(0,length(trees)+1),upper=rep(Inf,length(trees)+1)) count<-0 while(!is.finite(obj$objective)&&countinterval[2]) 52 else 0 fit.onerate<-list(par=c(obj$minimum,0),objective=obj$objective,convergence=convergence, message=if(convergence!=0) "Estimate at may be at limits of interval." else "Probably converged.") rates.multi<-cbind(sapply(fit.multi,function(x) x$b), rep(0,length(trees))) } if(!is.null(names(trees))) rownames(rates.multi)<-names(trees) else rownames(rates.multi)<-paste("tree",1:length(trees),sep="") colnames(rates.multi)<-c("b","d") LR<-2*(logL.multi+fit.onerate$objective) km<-if(model=="birth-death") 2*length(trees) else if(model=="equal-extinction") length(trees)+1 else if(model=="equal-speciation") length(trees)+1 else if(model=="Yule") length(trees) k1<-if(model=="Yule") 1 else 2 P.chisq<-pchisq(LR,df=km-k1,lower.tail=FALSE) obj<-list( multi.rate.model=list( logL=logL.multi, rates=rates.multi, k=km, method=if(model=="Yule") "optimize" else "nlminb"), common.rate.model=list( logL=-fit.onerate$objective, rates=setNames(fit.onerate$par,c("b","d")), k=k1, method=if(model=="Yule") "optimize" else "nlminb"), model=model,N=length(trees), n=sapply(trees,Ntip), likelihood.ratio=LR,P.chisq=P.chisq, type="diversification") class(obj)<-"ratebytree" obj } ## discrete character ratebytree rbt.disc<-function(trees,x,...){ if(hasArg(trace)) trace<-list(...)$trace else trace<-FALSE if(hasArg(digits)) digits<-list(...)$digits else digits<-4 if(hasArg(test)) test<-list(...)$test else test<-"chisq" if(hasArg(quiet)) quiet<-list(...)$quiet else quiet<-FALSE if(hasArg(model)) model<-list(...)$model else model<-"ER" if(!inherits(trees,"multiPhylo")) stop("trees should be object of class \"multiPhylo\".") if(!is.list(x)) stop("x should be a list of vectors.") N<-length(trees) fit.multi<-mapply(fitMk,tree=trees,x=x,MoreArgs=list(model=model), SIMPLIFY=FALSE) logL.multi<-sum(sapply(fit.multi,logLik)) lik.onerate<-function(theta,trees,x,model,trace=FALSE){ ss<-sort(unique(unlist(x))) m<-length(ss) if(is.character(model)){ rate<-matrix(NA,m,m) if(model=="ER"){ k<-rate[]<-1 diag(rate)<-NA } else if(model=="ARD") { k<-m*(m-1) rate[col(rate)!=row(rate)]<-1:k } else if(model=="SYM") { k<-m*(m-1)/2 ii<-col(rate)1){ fit.onerate<-optim(pp,lik.onerate,trees=trees,x=x,model=model) } else { fit.onerate<-optimize(lik.onerate,c(0,1000*pp),trees=trees,x=x, model=model) names(fit.onerate)<-c("par","value") } rates.multi<-t(sapply(fit.multi,function(x) x$rates)) if(is.character(model)){ m<-length(fit.multi[[1]]$states) if(model=="ER"){ rates.multi<-t(rates.multi) colnames(rates.multi)<-"q" } else if(model=="SYM"){ if(length(fit.multi[[1]]$states)==2) rates.multi<-t(rates.multi) colnames(rates.multi)<- sapply(fit.multi[[1]]$states,function(x,y) sapply(y,function(y,x) paste(x,"<->",y,sep=""),x=x), y=fit.multi[[1]]$states)[lower.tri(matrix(0,m,m))] } else if(model=="ARD"){ ii<-(upper.tri(matrix(0,m,m))+lower.tri(matrix(0,m,m))==TRUE) colnames(rates.multi)<- sapply(fit.multi[[1]]$states,function(x,y) sapply(y,function(y,x) paste(y,"->",x,sep=""),x=x), y=fit.multi[[1]]$states)[ii] } } else { k<-max(fit.multi[[1]]$index.matrix,na.rm=TRUE) if(k==1) rates.multi<-t(rates.multi) foo<-function(i,index.matrix,states){ rc<-which(index.matrix==i,arr.ind=TRUE) lab<-apply(rc,1,function(ind,ss) paste(ss[ind],collapse="->"), ss=states) if(length(lab)>1) paste(lab,collapse=",") else lab } colnames(rates.multi)<-sapply(1:k, foo,fit.multi[[1]]$index.matrix,fit.multi[[1]]$states) } if(!is.null(names(trees))) rownames(rates.multi)<-names(trees) else rownames(rates.multi)<-paste("tree",1:length(trees),sep="") LR<-2*(logL.multi+fit.onerate$value) km<-sum(sapply(fit.multi,function(x) max(x$index.matrix,na.rm=TRUE))) k1<-length(pp) P.chisq<-pchisq(LR,df=km-k1,lower.tail=FALSE) obj<-list( multi.rate.model=list( logL=logL.multi, rates=rates.multi, method=fit.multi[[1]]$method), common.rate.model=list( logL=-fit.onerate$value, rates=setNames(fit.onerate$par,colnames(rates.multi)), method=if(length(pp)>1) "optim" else "optimize"), index.matrix=fit.multi[[1]]$index.matrix, states=fit.multi[[1]]$states, pi=fit.multi[[1]]$pi, model=model,N=N,n=sapply(trees,Ntip), likelihood.ratio=LR,P.chisq=P.chisq, type="discrete") class(obj)<-"ratebytree" obj } ## continuous character ratebytree rbt.cont<-function(trees,x,...){ if(hasArg(tol)) tol<-list(...)$tol else tol<-1e-8 if(hasArg(trace)) trace<-list(...)$trace else trace<-FALSE if(hasArg(digits)) digits<-list(...)$digits else digits<-4 if(hasArg(test)) test<-list(...)$test else test<-"chisq" if(hasArg(quiet)) quiet<-list(...)$quiet else quiet<-FALSE if(hasArg(maxit)) maxit<-list(...)$maxit else maxit<-500 if(hasArg(regimes)){ regimes<-list(...)$regimes if(!is.factor(regimes)) regimes<-as.factor(regimes) } else regimes<-as.factor(1:length(trees)) if(hasArg(model)) model<-list(...)$model else model<-"BM" if(!(model%in%c("BM","OU","EB"))){ cat(paste("model =",model,"not recognized. using model = \"BM\"\n")) model<-"BM" } ## check trees & x if(!inherits(trees,"multiPhylo")) stop("trees should be object of class \"multiPhylo\".") if(!is.list(x)) stop("x should be a list of vectors.") if(hasArg(se)) se<-list(...)$se else { se<-x for(i in 1:length(x)) se[[i]][1:length(se[[i]])]<-0 } N<-length(trees) m<-length(levels(regimes)) ## reorder the trait vectors in x & SEs in se x<-mapply(function(x,t) x<-x[t$tip.label],x=x,t=trees,SIMPLIFY=FALSE) se<-mapply(function(x,t) x<-x[t$tip.label],x=se,t=trees,SIMPLIFY=FALSE) ## likelihood functions lik.multi<-function(theta,trees,y,se,model,regimes,trace=FALSE){ m<-length(unique(regimes)) ind<-setNames(lapply(levels(regimes),function(x,y) which(y==x),y=regimes), levels(regimes)) THETA<-list() for(i in 1:m){ THETA[[i]]<-c(theta[i],theta[ind[[i]]+m]) if(model%in%c("OU","EB")) THETA[[i]]<-c(THETA[[i]],theta[i+m+N]) } logL<-0 for(i in 1:m) logL<-logL-lik.onerate(THETA[[i]],trees[ind[[i]]],y[ind[[i]]],se[ind[[i]]], model=model,trace=FALSE) if(trace){ cat(paste(paste(round(theta[1:m],digits),collapse="\t"), if(model=="OU") paste(round(theta[1:m+m+N],digits),collapse="\t"), if(model=="EB") paste(round(theta[1:m+m+N],digits),collapse="\t"), round(logL,digits),"\n",sep="\t")) flush.console() } -logL } lik.onerate<-function(theta,trees,y,se,model,trace=FALSE){ n<-sapply(trees,Ntip) N<-length(trees) sig<-theta[1] a<-theta[1:N+1] if(model=="OU") alpha<-theta[N+2] if(model=="EB") r<-theta[N+2] if(model=="BM") C<-lapply(trees,vcv) else if(model=="OU") C<-lapply(trees,vcvPhylo,model="OU",alpha=alpha, anc.nodes=FALSE) else if(model=="EB") C<-lapply(trees,vcvPhylo,model="EB",r=r, anc.nodes=FALSE) E<-lapply(se,diag) V<-mapply("+",lapply(C,"*",sig),E,SIMPLIFY=FALSE) logL<-0 for(i in 1:N) logL<-logL-t(y[[i]]-a[i])%*%solve(V[[i]])%*%(y[[i]]- a[i])/2-n[i]*log(2*pi)/2-determinant(V[[i]])$modulus[1]/2 if(trace){ cat(paste(round(sig,digits), if(model=="OU") round(alpha,digits), if(model=="EB") round(r,digits), round(logL,digits),"\n",sep="\t")) flush.console() } -logL } ## first, fit multi-rate model f1<-function(tree,x){ pvcv<-phyl.vcv(as.matrix(x),vcv(tree),1) c(pvcv$R[1,1],pvcv$a[1,1]) } P<-mapply(f1,trees,x,SIMPLIFY=FALSE) PP<-list() PP[[1]]<-vector() for(i in 1:m) PP[[1]][i]<-mean(sapply(P,function(x) x[1])[which(regimes==levels(regimes)[i])]) PP[[2]]<-sapply(P,function(x) x[2]) if(model%in%c("OU","EB")) PP[[3]]<-rep(0,m) if(hasArg(init)){ init<-list(...)$init if(!is.null(init$sigm)) PP[[1]]<-init$sigm if(!is.null(init$am)) PP[[2]]<-init$am if(model=="OU") if(!is.null(init$alpham)) PP[[3]]<-init$alpham if(model=="EB") if(!is.null(init$rm)) PP[[3]]<-init$rm } p<-unlist(PP) if(trace){ if(model=="BM"){ cat("\nOptimizing multi-rate model....\n") cat(paste(paste("sig[",1:m,"]",sep="",collapse="\t"),"logL\n",sep="\t")) } else if(model=="OU"){ cat("\nOptimizing multi-regime model....\n") cat(paste(paste("sig[",1:m,"]",sep="",collapse="\t"), paste("alpha[",1:m,"]",sep="",collapse="\t"),"logL\n",sep="\t")) } else if(model=="EB"){ cat("\nOptimizing multi-regime model....\n") cat(paste(paste("sig[",1:m,"]",sep="",collapse="\t"), paste("r[",1:m,"]",sep="",collapse="\t"),"logL\n",sep="\t")) } } fit.multi<-optim(p,lik.multi,trees=trees,y=x,se=se,model=model, regimes=regimes,trace=trace, method="L-BFGS-B",lower=c(rep(tol,m),rep(-Inf,N), if(model%in%c("OU","EB")) rep(-Inf,m)),upper=c(rep(Inf,m),rep(Inf,N), if(model%in%c("OU","EB")) rep(Inf,m)),control=list(maxit=maxit)) ## compute covariance matrix H.multi<-hessian(lik.multi,fit.multi$par,trees=trees,y=x, se=se,model=model,regimes=regimes,trace=FALSE) Cov.multi<-if(qr(H.multi)$rank!=ncol(H.multi)) ginv(H.multi) else solve(H.multi) ## now fit single-rate model p<-c(mean(fit.multi$par[1:m]),fit.multi$par[1:N+m]) if(model%in%c("OU","EB")) p<-c(p,mean(fit.multi$par[1:m+m+N])) if(hasArg(init)){ if(!is.null(init$sigc)) p[1]<-init$sigc if(!is.null(init$ac)) p[1:N+1]<-init$ac if(model=="OU") if(!is.null(init$alphac)) p[N+2]<-init$alphac if(model=="EB") if(!is.null(init$rc)) p[N+2]<-init$rc } if(trace){ if(model=="BM"){ cat("\nOptimizing common-rate model....\n") cat(paste("sig ","logL\n",sep="\t")) } else if(model=="OU"){ cat("\nOptimizing common-regime model....\n") cat(paste("sig ","alpha ","logL\n",sep="\t")) } else if(model=="EB"){ cat("\nOptimizing common-regime mode.....\n") cat(paste("sig ","r ","logL\n",sep="\t")) } } fit.onerate<-optim(p,lik.onerate,trees=trees,y=x,se=se,model=model, trace=trace,method="L-BFGS-B", lower=c(tol,rep(-Inf,N),if(model=="OU") tol else if(model=="EB") -Inf), upper=c(Inf,rep(Inf,N),if(model%in%c("OU","EB")) Inf), control=list(maxit=maxit)) ## compute covariance matrix H.onerate<-hessian(lik.onerate,fit.onerate$par,trees=trees,y=x, se=se,model=model,trace=FALSE) Cov.onerate<-if(qr(H.onerate)$rank!=ncol(H.onerate)) ginv(H.onerate) else solve(H.onerate) ## compare models: LR<-2*(-fit.multi$value+fit.onerate$value) km<-N+m+if(model=="BM") 0 else if(model%in%c("OU","EB")) m k1<-N+if(model=="BM") 1 else if(model%in%c("OU","EB")) 2 if(test=="simulation"&&model%in%c("OU","EB")){ cat("Simulation test not yet available for chosen model. Using chi-square test.\n") test<-"chisq" } if(test=="chisq") P.chisq<-pchisq(LR,df=km-k1,lower.tail=FALSE) else if(test=="simulation"){ if(!quiet) cat("Generating null distribution via simulation -> |") flush.console() if(hasArg(nsim)) nsim<-list(...)$nsim else nsim<-100 X<-mapply(fastBM,tree=trees,a=as.list(fit.onerate$par[1:N+1]), MoreArgs=list(sig2=fit.onerate$par[1],nsim=nsim), SIMPLIFY=FALSE) P.sim<-1/(nsim+1) pct<-0.1 for(i in 1:nsim){ x.sim<-lapply(X,function(x,ind) x[,ind],ind=i) f2<-function(x,se) sampleFrom(xbar=x,xvar=se^2,n=rep(1,length(x))) x.sim<-mapply(f2,x=x.sim,se=se,SIMPLIFY=FALSE) fit.sim<-ratebytree(trees,x.sim,se=se) P.sim<-P.sim+(fit.sim$likelihood.ratio>=LR)/(nsim+1) if(i/nsim>=pct){ if(!quiet) cat(".") flush.console() pct<-pct+0.1 } } if(!quiet) cat(".|\nDone!\n") flush.console() } obj<-list( multi.rate.model=list(sig2=fit.multi$par[1:m], SE.sig2=sqrt(diag(Cov.multi)[1:m]), a=fit.multi$par[1:N+m], SE.a=sqrt(diag(Cov.multi)[1:N+m]), alpha=if(model=="OU") fit.multi$par[1:m+m+N] else NULL, SE.alpha=if(model=="OU") sqrt(diag(Cov.multi)[1:m+m+N]) else NULL, r=if(model=="EB") fit.multi$par[1:N+m+N] else NULL, SE.r=if(model=="EB") sqrt(diag(Cov.multi)[1:N+m+N]) else NULL, k=km, logL=-fit.multi$value, counts=fit.multi$counts,convergence=fit.multi$convergence, message=fit.multi$message), common.rate.model=list(sig2=fit.onerate$par[1], SE.sig2=sqrt(diag(Cov.onerate)[1]), a=fit.onerate$par[1:N+1], SE.a=sqrt(diag(Cov.onerate)[1:N+1]), alpha=if(model=="OU") fit.onerate$par[N+2] else NULL, SE.alpha=if(model=="OU") sqrt(diag(Cov.onerate)[N+2]) else NULL, r=if(model=="EB") fit.onerate$par[N+2] else NULL, SE.r=if(model=="EB") sqrt(diag(Cov.onerate)[N+2]) else NULL, k=k1, logL=-fit.onerate$value, counts=fit.onerate$counts,convergence=fit.onerate$convergence, message=fit.onerate$message), model=model, N=N,n=sapply(trees,Ntip),likelihood.ratio=LR, regimes=regimes,m=m, P.chisq=if(test=="chisq") P.chisq else NULL, P.sim=if(test=="simulation") P.sim else NULL, type="continuous") class(obj)<-"ratebytree" obj } ## S3 print method for ratebytree print.ratebytree<-function(x,...){ if(hasArg(digits)) digits<-list(...)$digits else digits<-4 if(x$type=="continuous") prbt.cont(x,digits=digits) else if(x$type=="discrete") prbt.disc(x,digits=digits) else if(x$type=="diversification") prbt.div(x,digits=digits) else print(x) } prbt.div<-function(x,digits=digits){ cat("ML common diversification-rate model:") cat("\n\tb\td\tk\tlog(L)") cat(paste("\nvalue",round(x$common.rate.model$rates[1],digits), round(x$common.rate.model$rates[2],digits), x$common.rate.model$k,round(x$common.rate.model$logL,digits), sep="\t")) cat("\n\nML multi diversification-rate model:") cat(paste("\n",paste(paste("b[",1:x$N,"]",sep=""),collapse="\t"), paste(paste("d[",1:x$N,"]",sep=""),collapse="\t"),"k\tlog(L)", sep="\t")) cat(paste("\nvalue",paste(round(x$multi.rate.model$rates[,"b"],digits), collapse="\t"),paste(round(x$multi.rate.model$rates[,"d"],digits), collapse="\t"),x$multi.rate.model$k,round(x$multi.rate.model$logL, digits),sep="\t")) cat(paste("\n\nDiversification model was \"",x$model,"\".\n",sep="")) cat(paste("Model fitting method was \"",x$multi.rate.model$method, "\".\n",sep="")) cat(paste("\nLikelihood ratio:",round(x$likelihood.ratio,digits),"\n")) cat(paste("P-value (based on X^2):",round(x$P.chisq,digits),"\n\n")) } prbt.cont<-function(x,digits=digits){ N<-x$N m<-x$m if(x$model=="BM"){ cat("ML common-rate model:\n") cat(paste("\ts^2\t",paste(paste("a[",1:N,"]",sep=""),collapse="\t")), "\tk\tlogL\n") cat(paste("value",round(x$common.rate.model$sig2,digits), paste(round(x$common.rate.model$a,digits),collapse="\t"), x$common.rate.model$k,round(x$common.rate.model$logL,digits), "\n",sep="\t")) cat(paste("SE ",round(x$common.rate.model$SE.sig2,digits), paste(round(x$common.rate.model$SE.a,digits),collapse="\t"), "\n\n",sep="\t")) cat("ML multi-rate model:\n") cat(paste("\t",paste(paste("s^2[",levels(x$regimes),"]",sep=""),collapse="\t"),"\t", paste(paste("a[",1:N,"]",sep=""),collapse="\t")), "\tk\tlogL\n") cat(paste("value",paste(round(x$multi.rate.model$sig2,digits),collapse="\t"), paste(round(x$multi.rate.model$a,digits),collapse="\t"), x$multi.rate.model$k,round(x$multi.rate.model$logL,digits), "\n",sep="\t")) cat(paste("SE ",paste(round(x$multi.rate.model$SE.sig2,digits),collapse="\t"), paste(round(x$multi.rate.model$SE.a,digits),collapse="\t"), "\n\n",sep="\t")) } else if(x$model=="OU"){ cat("ML common-regime OU model:\n") cat(paste("\ts^2\t",paste(paste("a[",1:N,"]",sep=""),collapse="\t")), "\talpha\tk\tlogL\n") cat(paste("value",round(x$common.rate.model$sig2,digits), paste(round(x$common.rate.model$a,digits),collapse="\t"), round(x$common.rate.model$alpha,digits), x$common.rate.model$k,round(x$common.rate.model$logL,digits), "\n",sep="\t")) cat(paste("SE ",round(x$common.rate.model$SE.sig2,digits), paste(round(x$common.rate.model$SE.a,digits),collapse="\t"), round(x$common.rate.model$SE.alpha,digits), "\n\n",sep="\t")) cat("ML multi-regime OU model:\n") cat(paste("\t",paste(paste("s^2[",levels(x$regimes),"]",sep=""),collapse="\t"),"\t", paste(paste("a[",1:N,"]",sep=""),collapse="\t"),"\t", paste(paste("alp[",levels(x$regimes),"]",sep=""),collapse="\t")), "\tk\tlogL\n") cat(paste("value",paste(round(x$multi.rate.model$sig2,digits),collapse="\t"), paste(round(x$multi.rate.model$a,digits),collapse="\t"), paste(round(x$multi.rate.model$alpha,digits),collapse="\t"), x$multi.rate.model$k,round(x$multi.rate.model$logL,digits), "\n",sep="\t")) cat(paste("SE ",paste(round(x$multi.rate.model$SE.sig2,digits),collapse="\t"), paste(round(x$multi.rate.model$SE.a,digits),collapse="\t"), paste(round(x$multi.rate.model$SE.alpha,digits),collapse="\t"), "\n\n",sep="\t")) } else if(x$model=="EB"){ cat("ML common-regime EB model:\n") cat(paste("\ts^2\t",paste(paste("a[",1:N,"]",sep=""),collapse="\t")), "\tr\tk\tlogL\n") cat(paste("value",round(x$common.rate.model$sig2,digits), paste(round(x$common.rate.model$a,digits),collapse="\t"), round(x$common.rate.model$r,digits), x$common.rate.model$k,round(x$common.rate.model$logL,digits), "\n",sep="\t")) cat(paste("SE ",round(x$common.rate.model$SE.sig2,digits), paste(round(x$common.rate.model$SE.a,digits),collapse="\t"), round(x$common.rate.model$SE.r,digits), "\n\n",sep="\t")) cat("ML multi-regime EB model:\n") cat(paste("\t",paste(paste("s^2[",levels(x$regimes),"]",sep=""),collapse="\t"),"\t", paste(paste("a[",1:N,"]",sep=""),collapse="\t"),"\t", paste(paste("r[",levels(x$regimes),"]",sep=""),collapse="\t")), "\tk\tlogL\n") cat(paste("value",paste(round(x$multi.rate.model$sig2,digits),collapse="\t"), paste(round(x$multi.rate.model$a,digits),collapse="\t"), paste(round(x$multi.rate.model$r,digits),collapse="\t"), x$multi.rate.model$k,round(x$multi.rate.model$logL,digits), "\n",sep="\t")) cat(paste("SE ",paste(round(x$multi.rate.model$SE.sig2,digits),collapse="\t"), paste(round(x$multi.rate.model$SE.a,digits),collapse="\t"), paste(round(x$multi.rate.model$SE.r,digits),collapse="\t"), "\n\n",sep="\t")) } cat(paste("Likelihood ratio:",round(x$likelihood.ratio,digits),"\n")) if(!is.null(x$P.chisq)) cat(paste("P-value (based on X^2):",round(x$P.chisq,digits),"\n\n")) else if(!is.null(x$P.sim)) cat(paste("P-value (based on simulation):",round(x$P.sim,digits),"\n\n")) if(x$multi.rate.model$convergence==0&&x$common.rate.model$convergence==0) cat("R thinks it has found the ML solution.\n\n") else cat("One or the other optimization may not have converged.\n\n") } prbt.disc<-function(x,digits=digits){ cat("ML common-rate model:\n") cat(paste("\t",paste(names(x$common.rate.model$rates),collapse="\t"), "\tk\tlogL\n",sep="")) cat(paste("value\t",paste(round(x$common.rate.model$rates,digits), collapse="\t"),"\t",max(x$index.matrix,na.rm=T),"\t", round(x$common.rate.model$logL,digits),"\n",sep="")) cat(paste("\nModel fitting method was \"",x$common.rate.model$method, "\".\n",sep="")) cat("\nML multi-rate model:\n") cat(paste("\t",paste(colnames(x$multi.rate.model$rates),collapse="\t"), "\tk\tlogL\n",sep="")) for(i in 1:nrow(x$multi.rate.model$rates)){ if(i>1) cat(paste(rownames(x$multi.rate.model$rates)[i],"\t", paste(round(x$multi.rate.model$rates[i,], digits),collapse="\t"),"\n",sep="")) else if(i==1) cat(paste(rownames(x$multi.rate.model$rates)[i],"\t", paste(round(x$multi.rate.model$rates[i,], digits),collapse="\t"),"\t",x$N*max(x$index.matrix,na.rm=T),"\t", round(x$multi.rate.model$logL,digits),"\n",sep="")) } cat(paste("\nModel fitting method was \"",x$multi.rate.model$method, "\".\n",sep="")) cat(paste("\nLikelihood ratio:",round(x$likelihood.ratio,digits),"\n")) cat(paste("P-value (based on X^2):",round(x$P.chisq,digits),"\n\n")) } ## posthoc comparison S3 method posthoc<-function(x, ...) UseMethod("posthoc") posthoc.ratebytree<-function(x,...){ if(hasArg(p.adjust.method)) p.adjust.method<-list(...)$p.adjust.method else p.adjust.method<-"none" if(x$type!="continuous"){ cat("Sorry. No posthoc method yet implemented for this data type.\n\n") } else { if(x$model=="BM") k<-2 else if(x$model%in%c("EB","OU")) k<-3 t<-df<-P<-matrix(0,x$m,x$m) for(i in 1:x$m){ for(j in 1:x$m){ x1<-if(x$model=="BM") x$multi.rate.model$sig2[i] else if(x$model=="OU") x$multi.rate.model$alpha[i] else if(x$model=="EB") x$multi.rate.model$r[i] x2<-if(x$model=="BM") x$multi.rate.model$sig2[j] else if(x$model=="OU") x$multi.rate.model$alpha[j] else if(x$model=="EB") x$multi.rate.model$r[j] s1<-x$multi.rate.model$SE.sig2[i]^2 s2<-x$multi.rate.model$SE.sig2[j]^2 n1<-x$n[i] n2<-x$n[j] se<-sqrt(s1+s2) df[i,j]<-(s1/n1+s2/n2)^2/ ((s1/n1)^2/(n1-k)+(s2/n2)^2/(n2-k)) t[i,j]<-(x1-x2)/se P[i,j]<-2*pt(abs(t[i,j]),df[i,j],lower.tail=FALSE) } } p<-P[upper.tri(P)] p<-p.adjust(p,method=p.adjust.method) P[upper.tri(P)]<-p P[lower.tri(P)]<-p } obj<-list(t=t,df=df,P=P,model=x$model,type=x$type, p.adjust.method=p.adjust.method) class(obj)<-"posthoc.ratebytree" obj } print.posthoc.ratebytree<-function(x,...){ if(hasArg(digits)) digits<-list(...)$digits else digits<-4 t<-x$t[upper.tri(x$t)] df<-x$df[upper.tri(x$df)] P<-x$P[upper.tri(x$P)] N<-nrow(x$P) paste("reg.",1:(N-1),"vs.",2:N) nn<-vector(mode="character",length=N*(N-1)/2) k<-1 for(i in 1:N) for(j in i:N){ if(i!=j){ nn[k]<-paste("reg.",i," vs. ",j,sep="") k<-k+1 } } X<-data.frame(t=t,df=df,P=P) rownames(X)<-nn cat(paste("\nPost-hoc test for \"",x$model,"\" model.\n",sep="")) cat(paste("(Comparison is of estimated values of", if(x$model=="BM") "sigma^2.)\n\n" else if(x$model=="OU") "alpha.)\n\n" else if(x$model=="EB") "r.)\n\n")) print(round(X,digits)) cat(paste("\nP-values adjusted using method=\"",x$p.adjust.method, "\".\n\n",sep="")) } AIC.ratebytree<-function(object,...,k=2){ aic<-data.frame(AIC=c(k*object$common.rate.model$k-2*object$common.rate.model$logL, k*object$multi.rate.model$k-2*object$multi.rate.model$logL), df=c(object$common.rate.model$k,object$multi.rate.model$k)) model.names<-if(is.null(object$model)) 1 else object$model addtl.obj<-list(...) if(length(addtl.obj)>0){ for(i in 1:length(addtl.obj)){ aic<-rbind(aic,c(k*addtl.obj[[i]]$multi.rate.model$k- 2*addtl.obj[[i]]$multi.rate.model$logL, addtl.obj[[i]]$multi.rate.model$k)) model.names<-c(model.names, if(is.null(addtl.obj[[i]]$model)) 1+i else addtl.obj[[i]]$model) } rownames(aic)<-c("common-rate",paste("multi-rate:",model.names,sep="")) } else rownames(aic)<-c("common-rate","multi-rate") aic } phytools/R/skewers.R0000644000176200001440000000240514375517350014155 0ustar liggesusers## this function does random skewers following Cheverud & Marroig (2007) ## for is.null(method)==FALSE uses clusterGeneration::genPositiveDefMat ## written by Liam J. Revell 2013 skewers<-function(X,Y,nsim=100,method=NULL){ m<-nrow(X) if(!all(sapply(c(dim(X),dim(Y)),"==",m))) stop("X & Y should be square matrices of equal dimension") S<-matrix(runif(nsim*m,min=-1,max=1),nsim,m) S<-S/matrix(sqrt(rowSums(S^2)),nsim,m) Sx<-apply(S,1,"%*%",X) Sy<-apply(S,1,"%*%",Y) R<-colMeans(Sx*Sy)/sqrt(colMeans(Sx^2)*colMeans(Sy^2)) r<-mean(R) ## get null distribution foo<-function(m,method,rangeVar){ if(is.null(method)){ x<-runif(m,min=-1,max=1) x<-x/sqrt(sum(x^2)) y<-runif(m) y<-y/sqrt(sum(y^2)) r<-mean(x*y)/sqrt(mean(x^2)*mean(y^2)) } else { X<-genPositiveDefMat(m,covMethod=method,rangeVar=rangeVar)$Sigma Y<-genPositiveDefMat(m,covMethod=method,rangeVar=rangeVar)$Sigma S<-matrix(runif(nsim*m,min=-1,max=1),nsim,m) S<-S/matrix(sqrt(rowSums(S^2)),nsim,m) Sx<-apply(S,1,"%*%",X) Sy<-apply(S,1,"%*%",Y) R<-colMeans(Sx*Sy)/sqrt(colMeans(Sx^2)*colMeans(Sy^2)) r<-mean(R) } r } Rnull<-replicate(nsim,foo(m,method=method,rangeVar=range(c(diag(X),diag(Y))))) return(list(r=r,p=mean(Rnull>=r))) }phytools/R/resolveNodes.R0000644000176200001440000000405614375517350015146 0ustar liggesusers## function to resolve nodes in a multifurcating tree ## written by Liam J. Revell 2016 resolveNode<-function(tree,node){ dd<-Children(tree,node) if(length(dd)>2){ EL<-!is.null(tree$edge.length) if(!EL) tree<-compute.brlen(tree) n<-length(dd) tt<-lapply(allTrees(n,TRUE,dd),untangle,"read.tree") ROOT<-node==(Ntip(tree)+1) SPL<-if(!ROOT) splitTree(tree,split=list(node=node, bp=tree$edge.length[which(tree$edge[,2]==node)])) else list(NULL,tree) KIDS<-Children(SPL[[2]],SPL[[2]]$edge[1,1]) KIDS<-setNames(KIDS,dd)[KIDS>Ntip(SPL[[2]])] SUBS<-list() if(length(KIDS)>0) for(i in 1:length(KIDS)) SUBS[[i]]<-extract.clade(SPL[[2]],KIDS[i]) obj<-list() for(i in 1:length(tt)){ tt[[i]]$edge.length<-rep(0,nrow(tt[[i]]$edge)) for(j in 1:Ntip(tt[[i]])) tt[[i]]$edge.length[which(tt[[i]]$edge[,2]==j)]<- tree$edge.length[which(tree$edge[,2]== as.numeric(tt[[i]]$tip.label[j]))] ind<-as.numeric(tt[[i]]$tip.label)<=Ntip(tree) tt[[i]]$tip.label[ind]<- tree$tip.label[as.numeric(tt[[i]]$tip.label[ind])] if(length(KIDS)>0) for(j in 1:length(KIDS)) tt[[i]]<-bind.tree(tt[[i]],SUBS[[j]], where=which(tt[[i]]$tip.label== names(KIDS)[j])) obj[[i]]<-if(!ROOT) bind.tree(SPL[[1]],tt[[i]], where=which(SPL[[1]]$tip.label=="NA")) else tt[[i]] if(!EL) obj[[i]]$edge.length<-NULL } class(obj)<-"multiPhylo" } else obj<-tree obj } ## function to resolve all nodes in a tree with multifurcations ## written by Liam J. Revell 2016 resolveAllNodes<-function(tree){ foo<-function(node,tree) length(Children(tree,node)) nodes<-1:tree$Nnode+Ntip(tree) ## all nodes nodes<-nodes[sapply(1:tree$Nnode+Ntip(tree),foo, tree=tree)>2] for(i in 1:length(nodes)){ if(i==1) obj<-resolveNode(tree,nodes[i]) else { for(j in 1:length(obj)){ MM<-matchNodes(tree,obj[[j]]) NODE<-MM[which(MM[,1]==nodes[i]),2] if(j==1) tmp<-resolveNode(obj[[j]],NODE) else tmp<-c(tmp,resolveNode(obj[[j]],NODE)) } obj<-tmp } } obj } phytools/R/plotrix_fn.R0000644000176200001440000002342114523233057014651 0ustar liggesusers## functions from plotrix version 3.8-3 (since package was orphaned on CRAN) ## citation: J L (2006). "Plotrix: a package in the red light district of R." R-News, 6(4), 8-12. ## authors: Jim Lemon, Ben Bolker, Sander Oom, Eduardo Klein, Barry Rowlingson, Hadley Wickham, ## Anupam Tyagi, Olivier Eterradossi, Gabor Grothendieck, Michael Toews, John Kane, Rolf Turner, ## Carl Witthoft, Julian Stander, Thomas Petzoldt, Remko Duursma, Elisa Biancotto, Ofir Levy, ## Christophe Dutang, Peter Solymos, Robby Engelmann, Michael Hecker, Felix Steinbeck, ## Hans Borchers, Henrik Singmann, Ted Toal, Derek Ogle, Darshan Baral, Ulrike Groemping, ## Bill Venables, The CRAN Team ## The following code is modified code from the plotrix R package version 3.8-3, which is licensed ## GPLv3. This code therefore is also licensed under the terms of the GNU Public License, version 3. ## First attempt to load functions from plotrix package (if installed). If not installed, functions ## are loaded from this source file. GetYmult<-function() { if(dev.cur() == 1) { warning("No graphics device open.") ymult<-1 } else { # get the plot aspect ratio xyasp<-par("pin") # get the plot coordinate ratio xycr<-diff(par("usr"))[c(1,3)] ymult<-xyasp[1]/xyasp[2]*xycr[2]/xycr[1] } return(ymult) } Arctext<-function(x,center=c(0,0),radius=1,start=NULL,middle=pi/2,end=NULL, stretch=1,clockwise=TRUE,cex=NULL, ...) { oldcex <- par("cex") # have to do this to get strwidth to work if(is.null(cex)) cex <- oldcex par(cex = cex) xvec <- strsplit(x, "")[[1]] lenx <- length(xvec) xwidths <- stretch * strwidth(xvec) charangles <- xwidths/radius # make really narrow characters wider changrang <- range(charangles) charangles[charangles < changrang[2]/2] <- changrang[2]/2 if(!is.null(end)) { if(clockwise) start <- end + sum(charangles) else start <- end - sum(charangles) } if(is.null(start)) { if (clockwise) start <- middle + sum(charangles)/2 else start <- middle - sum(charangles)/2 } if(clockwise) { charstart <- c(start, start - cumsum(charangles)[-lenx]) charpos <- charstart - charangles/2 } else { charstart <- c(start, start + cumsum(charangles)[-lenx]) charpos <- charstart + charangles/2 } xylim <- par("usr") plotdim <- par("pin") ymult <- (xylim[4] - xylim[3])/(xylim[2] - xylim[1]) * plotdim[1]/plotdim[2] for(xchar in 1:lenx) { srt <- 180 * charpos[xchar]/pi - 90 text(center[1] + radius * cos(charpos[xchar]), center[2] + radius * sin(charpos[xchar]) * ymult, xvec[xchar], adj = c(0.5, 0.5), srt = srt + 180 * (!clockwise),...) } par(cex = oldcex) } Draw.arc <- function(x=1, y=NULL, radius=1, angle1=deg1*pi/180, angle2=deg2*pi/180, deg1=0, deg2=45, n=0.05, col=NA, lwd=NA, ...) { if (all(is.na(col))) col <- par("col") if (all(is.na(lwd))) lwd <- par("lwd") xylim<-par("usr") ymult <- getYmult() devunits <- dev.size("px") draw.arc.0 <- function(x, y, radius, angle1, angle2, n, col, lwd, ...) { delta.angle <- (angle2 - angle1) if (n != as.integer(n)) n <- as.integer(1+delta.angle/n) # Divide total angle by desired segment angle to get number of segments delta.angle <- delta.angle/n angleS <- angle1 + seq(0, length=n) * delta.angle angleE <- c(angleS[-1], angle2) # Move segment starts/ends so that segments overlap enough to make wide segments # not have an open slice in them. The slice is open by delta.angle*half.lwd.user. # That subtends an angle of that/(radius+half.lwd.user) radians, from center. # Move segment endpoints by half of that, so together they equal that. if (n > 1) { half.lwd.user <- (lwd/2)*(xylim[2]-xylim[1])/devunits[1] adj.angle = delta.angle*half.lwd.user/(2*(radius+half.lwd.user)) angleS[2:n] = angleS[2:n] - adj.angle angleE[1:(n-1)] = angleE[1:(n-1)] + adj.angle } p1x <- x + radius * cos(angleS) p1y <- y + radius * sin(angleS) * ymult p2x <- x + radius * cos(angleE) p2y <- y + radius * sin(angleE) * ymult segments(p1x, p1y, p2x, p2y, col=col, lwd=lwd, ...) } xy <- xy.coords(x, y) x <- xy$x y <- xy$y a1 <- pmin(angle1, angle2) a2 <- pmax(angle1, angle2) angle1 <- a1 angle2 <- a2 args <- data.frame(x, y, radius, angle1, angle2, n, col, lwd, stringsAsFactors=FALSE) for (i in 1:nrow(args)) do.call("draw.arc.0", c(args[i, ], ...)) invisible(args) } Draw.circle<-function(x,y,radius,nv=100,border=NULL,col=NA, lty=1,density=NULL,angle=45,lwd = 1) { xylim<-par("usr") plotdim<-par("pin") ymult<-getYmult() angle.inc<-2*pi/nv angles<-seq(0,2*pi-angle.inc,by=angle.inc) if(length(col) 0) x[1]<-x[1] + margin[2] if(margin[3] > 0) y<-y-margin[3] if(margin[4] > 0) x[2]<-x[2]-margin[4] if(x[1] >= x[2]) x[2]<-x[1]+diff(par("usr")[1:2])*0.1 x.len<-diff(x) y.pos<-y x.pos<-x[1] adj2<-c(0,1) if(justify[1] == "c") { x.pos<-x.pos + x.len/2 adj2[1]<-0.5 } else { if(justify[1] == "r") { x.pos<-x.pos + x.len adj2[1]<-1 } } curword<-1 curline<-1 txtline<-"" while(curword <= length(words)) { txtline[curline]<- "" txtline[curline]<-paste(txtline[curline],words[curword]) curword<-curword + 1 while(strwidth(paste(txtline[curline],words[curword]),cex=cex, font=font,vfont=vfont) < x.len && !is.na(words[curword])) { txtline[curline]<-paste(txtline[curline],words[curword]) curword<-curword+1 } curline<-curline+1 y.pos[curline]<-y.pos[curline-1]-line.height } if(box) { xbox<-x ybox<-c(y.pos[curline],y) ybox[1]<-ybox[1]-abs(margin[1]) xbox[1]<-xbox[1]-abs(margin[2]) ybox[2]<-ybox[2]+abs(margin[3]) xbox[2]<-xbox[2]+abs(margin[4]) rect(xbox[1],ybox[1],xbox[2],ybox[2],border=border, col=fill,density=density,angle=angle,lty=lty,lwd=lwd) } text(x.pos,y.pos[1:curline-1],txtline,adj=adj+adj2,cex=cex, col=col,font=font,vfont=vfont) par(saveAdj) return(y.pos) } arctext<-if(.check.pkg("plotrix")) plotrix::arctext else Arctext draw.arc<-if(.check.pkg("plotrix")) plotrix::draw.arc else Draw.arc draw.circle<-if(.check.pkg("plotrix")) plotrix::draw.circle else Draw.circle draw.ellipse<-if(.check.pkg("plotrix")) plotrix::draw.ellipse else Draw.ellipse getYmult<-if(.check.pkg("plotrix")) plotrix::getYmult else GetYmult textbox<-if(.check.pkg("plotrix")) plotrix::textbox else Textbox phytools/R/mcmcBM.full.R0000644000176200001440000001022514375517350014570 0ustar liggesusers# function # written by Liam J. Revell 2011 mcmcBM.full<-function(tree,x,ngen=10000,control=list()){ # starting values (for now) n<-length(tree$tip) temp<-aggregate(x,list(species=as.factor(names(x))),mean) xbar<-temp[,2]; names(xbar)<-temp[,1]; xbar<-xbar[tree$tip.label] sig2<-mean(pic(xbar,tree)^2) a<-mean(xbar) v<-rep(mean(aggregate(x,list(species=as.factor(names(x))),var)[,2],na.rm=T),n) names(v)<-names(xbar) prop<-c(0.01*sig2,0.01*sig2,rep(0.01*sig2*max(vcv(tree)),n),0.01*v) pr.mean<-c(1000,rep(0,n+1),rep(1000,n)) pr.var<-c(pr.mean[1]^2,rep(1000,n+1),pr.mean[n+2+1:n]^2) # populate control list con=list(sig2=sig2,a=a,xbar=xbar,v=v,pr.mean=pr.mean,pr.var=pr.var,prop=prop,sample=100) names(con$v)<-gsub("\\)","",gsub("var\\(","",names(con$v))) con[(namc<-names(control))]<-control con<-con[!sapply(con,is.null)] # print control parameters to screen message("Control parameters (set by user or default):"); str(con) # function returns the log-likelihood likelihood<-function(C,invC,detC,x,sig2,a,xbar,v){ z<-xbar-a logLik<--z%*%invC%*%z/(2*sig2)-nrow(C)*log(2*pi)/2-nrow(C)*log(sig2)/2-detC/2+sum(dnorm(x,xbar[names(x)],sd=sqrt(v[names(x)]),log=T)) return(logLik) } # function returns the log prior probability log.prior<-function(sig2,a,xbar,v){ pp<-dexp(sig2,rate=1/con$pr.mean[1],log=T)+sum(dnorm(c(a,xbar),mean=con$pr.mean[1+1:(n+1)],sd=sqrt(con$pr.var[1+1:(n+1)]),log=T))+sum(dexp(v,rate=1/con$pr.mean[n+2+1:n],log=T)) return(pp) } # compute C C<-vcv.phylo(tree) invC<-solve(C) detC<-determinant(C,logarithm=TRUE)$modulus[1] # now set starting values for MCMC sig2<-con$sig2; a<-con$a; xbar<-con$xbar; v<-con$v L<-likelihood(C,invC,detC,x,sig2,a,xbar,v) Pr<-log.prior(sig2,a,xbar,v) # store X<-matrix(NA,ngen/con$sample+1,2*n+4,dimnames=list(NULL,c("gen","sig2","a",tree$tip.label,paste("var(",tree$tip.label,")",sep=""),"logLik"))) X[1,]<-c(0,sig2,a,xbar,v,L) message("Starting MCMC...") # start MCMC for(i in 1:ngen){ j<-(i-1)%%(2*n+2) if(j==0){ # update sig2 sig2.prime<-sig2+rnorm(n=1,sd=sqrt(con$prop[j+1])) if(sig2.prime<0) sig2.prime<--sig2.prime L.prime<-likelihood(C,invC,detC,x,sig2.prime,a,xbar,v) Pr.prime<-log.prior(sig2.prime,a,xbar,v) post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T) if(post.odds>runif(n=1)){ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2.prime,a,xbar,v,L.prime) sig2<-sig2.prime L<-L.prime Pr<-Pr.prime } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,v,L) } else if(j==1){ # update a a.prime<-a+rnorm(n=1,sd=sqrt(con$prop[j+1])) L.prime<-likelihood(C,invC,detC,x,sig2,a.prime,xbar,v) Pr.prime<-log.prior(sig2,a.prime,xbar,v) post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T) if(post.odds>runif(n=1)){ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a.prime,xbar,v,L.prime) a<-a.prime L<-L.prime Pr<-Pr.prime } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,v,L) } else if(j>1&&j<=(n+1)) { k<-j-1 # update tip mean k xbar.prime<-xbar xbar.prime[k]<-xbar[k]+rnorm(n=1,sd=sqrt(con$prop[j+1])) L.prime<-likelihood(C,invC,detC,x,sig2,a,xbar.prime,v) Pr.prime<-log.prior(sig2,a,xbar.prime,v) post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T) if(post.odds>runif(n=1)){ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar.prime,v,L.prime) xbar<-xbar.prime L<-L.prime Pr<-Pr.prime } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,v,L) } else if(j>(n+1)){ k<-j-n-1 # update var v.prime<-v v.prime[k]<-v[k]+rnorm(n=1,sd=sqrt(con$prop[j+1])) if(v.prime[k]<0) v.prime[k]<--v.prime[k] L.prime<-likelihood(C,invC,detC,x,sig2,a,xbar,v.prime) Pr.prime<-log.prior(sig2,a,xbar,v.prime) post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T) if(post.odds>runif(n=1)){ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,v.prime,L.prime) v<-v.prime L<-L.prime Pr<-Pr.prime } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,v,L) } } # done MCMC message("Done MCMC.") return(X) } phytools/R/starTree.R0000644000176200001440000000072714375517350014270 0ustar liggesusers# Function creates a polytomous tree # written by Liam Revell 2011 starTree<-function(species,branch.lengths=NULL){ n<-length(species) edge<-matrix(NA,n,2) if(!is.null(branch.lengths)) edge.length=branch.lengths edge[,1]<-n+1; edge[,2]<-1:n if(!is.null(branch.lengths)) phy<-list(edge=edge,edge.length=edge.length,Nnode=1,tip.label=as.vector(species)) else phy<-list(edge=edge,Nnode=1,tip.label=as.vector(species)) class(phy)<-"phylo" return(phy) } phytools/R/phyl.pca.R0000644000176200001440000002354214467163403014213 0ustar liggesusers## function to perform phylogenetic principal components analysis ## multiple morphological traits in Y ## also can use lambda transformation in which lambda is optimized by ML or REML ## written by Liam Revell 2010, 2011, 2013, 2015, 2016, 2017, 2019, 2020, 2022, 2023 ## ref. Revell (2009; Evolution) phyl.pca<-function(tree,Y,method="BM",mode="cov",...){ ## get optional argument if(hasArg(opt)) opt<-list(...)$opt else opt<-"ML" # check tree if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") # check mode if(length(strsplit(mode,split="")[[1]])<=2){ message(paste("mode = \"",mode, "\" not a valid option; setting mode = \"cov\"",sep="")) mode<-"cov" } if(all(strsplit(mode,split="")[[1]]==strsplit("correlation", split="")[[1]][1:length(strsplit(mode,split="")[[1]])])) mode<-"corr" else if(all(strsplit(mode,split="")[[1]]==strsplit("covariance", split="")[[1]][1:length(strsplit(mode,split="")[[1]])])) mode<-"cov" else { message(paste("mode = \"",mode, "\" not a valid option; setting mode = \"cov\"",sep="")) mode="cov" } if(opt=="REML") object<-reml_phyl.pca(tree,Y,method,mode,...) else object<-ml_phyl.pca(tree,Y,method,mode,...) object } reml_phyl.pca<-function(tree,X,method="BM",mode="cov",...){ if(!is.binary(tree)) tree<-multi2di(tree) lik<-function(lambda,tree,X){ tt<-lambdaTree(tree,lambda) pics<-lapply(X,pic,tt,scaled=FALSE,var.contrasts=TRUE) pX<-sapply(pics,function(x) x[,1]/sqrt(x[,2])) vcv<-t(pX)%*%pX/(Ntip(tt)-1) vars<-pics[[1]][,2] logL<-0 for(i in 1:nrow(pX)){ x<-sapply(pics,function(x,i) x[i,1],i=i) logL<-logL+dmnorm(x,varcov=vars[i]*vcv, log=TRUE) } logL } X<-X[tree$tip.label,] if(method=="lambda"){ reml_fit<-optimize(lik,c(0,maxLambda(tree)),tree=tree, X=as.data.frame(X),maximum=TRUE) logL.lambda<-reml_fit$objective lambda<-reml_fit$maximum tree<-lambdaTree(tree,lambda) } else { logL.lambda<-lik(1,tree,as.data.frame(X)) lambda<-1 } pX<-apply(X,2,pic,phy=tree) vcv<-t(pX)%*%pX/(Ntip(tree)-1) n<-nrow(X) m<-ncol(X) if(mode=="corr"){ X=X/matrix(rep(sqrt(diag(vcv)),n),n,m,byrow=TRUE) vcv=vcv/(sqrt(diag(vcv))%*%t(sqrt(diag(vcv)))) } a<-apply(X,2,function(x,tree) rep(ace(x,tree, method="pic")$ace[1],Ntip(tree)),tree=tree) eig<-eigen(vcv) Eval<-diag(eig$values) colnames(Eval)<-rownames(Eval)<-paste("PC",1:nrow(Eval),sep="") Evec<-eig$vectors rownames(Evec)<-colnames(X) colnames(Evec)<-colnames(Eval) S<-as.matrix(X-a)%*%Evec pic_corr<-function(x,y,tree){ px<-pic(x,tree) py<-pic(y,tree) mean(px*py)/sqrt(mean(px^2)*mean(py^2)) } L<-apply(S,2,function(x,y,tree) apply(y,2,pic_corr, x=x,tree=tree),y=X,tree=tree) dimnames(L)<-dimnames(Evec) object<-list(Eval=Eval,Evec=Evec, S=S,L=L,lambda=lambda, logL.lambda=logL.lambda, V=vcv,a=a[1,,drop=FALSE], mode=mode,call=match.call()) class(object)<-"phyl.pca" object } ml_phyl.pca<-function(tree,Y,method="BM",mode="cov",...){ ## get optional argument if(hasArg(opt)) opt<-list(...)$opt else opt<-"ML" # preliminaries n<-nrow(Y) m<-ncol(Y) # check and sort data if(n>Ntip(tree)) stop("number of rows in Y cannot be greater than number of taxa in your tree") Y<-as.matrix(Y) if(is.null(rownames(Y))){ if(nrow(Y)==n){ print("Y has no names. function will assume that the row order of Y matches tree$tip.label") rownames(Y)<-tree$tip.label } else stop("Y has no names and does not have the same number of rows as tips in tree") } else if(length(setdiff(rownames(Y),tree$tip.label))!=0) stop("Y has rownames, but some rownames of Y not found in tree") # analyze C<-vcv.phylo(tree)[rownames(Y),rownames(Y)] if(method=="BM"){ temp<-phyl.vcv(Y,C,1.0) V<-temp$R a<-t(temp$alpha) C<-temp$C } else if(method=="lambda"){ if(opt=="ML") temp<-optimize(f=likMlambda,interval=c(0,maxLambda(tree)),X=Y, C=C,maximum=TRUE) else if(opt=="REML") temp<-optimize(f=remlMlambda,interval=c(0,maxLambda(tree)), tree=tree,X=Y,maximum=TRUE) else if(opt=="fixed"){ if(hasArg(lambda)) lambda<-list(...)$lambda else { cat(" opt=\"fixed\" requires the user to specify lambda.\n") cat(" setting lambda to 1.0.\n") lambda<-1.0 } temp<-list(maximum=lambda,objective=likMlambda(lambda,X=Y,C=C)) } lambda<-temp$maximum logL<-as.numeric(temp$objective) temp<-phyl.vcv(Y,C,lambda) V<-temp$R a<-t(temp$alpha) C<-temp$C } invC<-solve(C) ## get inverse of C # if correlation matrix if(mode=="corr"){ Y=Y/matrix(rep(sqrt(diag(V)),n),n,m,byrow=T) # standardize Y V=V/(sqrt(diag(V))%*%t(sqrt(diag(V)))) # change V to correlation matrix a<-matrix(colSums(invC%*%Y)/sum(invC),m,1) # recalculate a } es=eigen(V) # eigenanalyze obj<-list() obj$Eval<-diag(es$values[1:min(n-1,m)]) obj$Evec<-es$vectors[,1:min(n-1,m)] dimnames(obj$Eval)<-list(paste("PC",1:min(n-1,m),sep=""), paste("PC",1:min(n-1,m),sep="")) dimnames(obj$Evec)<-list(colnames(Y),paste("PC",1:min(n-1,m),sep="")) A<-matrix(rep(a,n),n,m,byrow=T) obj$S<-(Y-A)%*%obj$Evec # compute scores in the species space Ccv<-t(Y-A)%*%invC%*%obj$S/(n-1) # compute cross covariance matrix and loadings obj$L<-matrix(,m,min(n-1,m),dimnames=list(colnames(Y),paste("PC",1:min(n-1,m),sep=""))) for(i in 1:m) for(j in 1:min(n-1,m)) obj$L[i,j]<-Ccv[i,j]/sqrt(V[i,i]*obj$Eval[j,j]) if(method=="lambda"){ obj$lambda<-lambda obj$logL.lambda<-logL } obj$V<-temp$R obj$a<-a obj$mode<-mode obj$call<-match.call() ## assign class attribute (for S3 methods) class(obj)<-"phyl.pca" # return obj obj } ## S3 method for object of class "phyl.pca ## modified from code provided by Joan Maspons ## S3 print method for "phyl.pca" ## modified from code provided by Joan Maspons print.phyl.pca<-function(x, ...){ cat("Phylogenetic pca\n") cat("Standard deviations:\n") print(sqrt(diag(x$Eval))) cat("Loads:\n") print(x$L) if("lambda" %in% names(x)){ cat("lambda:\n") print(x$lambda) } } ## S3 summary method for "phyl.pca" ## modified from code provided by Joan Maspons summary.phyl.pca<-function(object, ...){ cat("Importance of components:\n") sd<-sqrt(diag(object$Eval)) varProp<- diag(object$Eval)/sum(object$Eval) impp<-rbind("Standard deviation"=sd,"Proportion of Variance"=varProp, "Cumulative Proportion"=cumsum(varProp)) print(impp) xx<-list(sdev=sd,importance=impp) class(xx)<-"summary.phyl.pca" invisible(xx) } ## S3 biplot method for "phyl.pca" ## modified from code provided by Joan Maspons ## written by Liam J. Revell 2015, 2017 biplot.phyl.pca<-function(x,...){ to.do<-list(...) if(hasArg(choices)){ choices<-list(...)$choices to.do$choices<-NULL } else choices<-c(1,2) to.do$x<-x$S[,choices] to.do$y<-x$Evec[,choices] do.call(biplot,to.do) } ## lambdaTree for lambda="REML" ## written by Liam J. Revell 2013 lambdaTree<-function(tree,lambda){ n<-length(tree$tip.label) h1<-nodeHeights(tree) ii<-which(tree$edge[,2]>n) tree$edge.length[ii]<-lambda*tree$edge.length[ii] h2<-nodeHeights(tree) tree$edge.length[-ii]<-tree$edge.length[-ii]+h1[-ii,2]-h2[-ii,2] tree } ## REML function ## written by Liam J. Revell 2013 remlMlambda<-function(lambda,tree,X){ tt<-lambdaTree(tree,lambda) Y<-apply(X,2,pic,phy=tt) V<-t(Y)%*%Y/nrow(Y) logL<-sum(dmnorm(Y,mean=rep(0,ncol(Y)),varcov=V,log=TRUE)) ## kronRC<-kronecker(V,diag(rep(1,nrow(Y)))) ## y<-as.vector(Y) ## logL<--y%*%solve(kronRC,y)/2-length(y)*log(2*pi)/2-determinant(kronRC,logarithm=TRUE)$modulus/2 ## print(V) print(c(lambda,logL)) logL } ## S3 plot method (does screeplot) plot.phyl.pca<- function(x,...){ if(hasArg(main)) main<-list(...)$main else main="screeplot" x$sdev<-sqrt(diag(x$Eval)) screeplot(x,main=main) } ## S3 scores method to extract or compute scores scores<-function(object,...) UseMethod("scores") scores.default<-function(object,...){ warning(paste( "scores does not know how to handle objects of class ", class(object),".")) } scores.phyl.pca<-function(object,...){ if(hasArg(newdata))newdata<-list(...)$newdata else newdata<-NULL if(hasArg(dim)) dim<-list(...)$dim else dim<-NULL if(!is.null(newdata)){ if(!is.matrix(newdata)) newdata<-as.matrix(newdata) if(ncol(newdata)!=nrow(object$Evec)) stop("Dimensions of newdata incorrect.") n<-nrow(newdata) m<-ncol(newdata) A<-matrix(rep(object$a,n),n,m,byrow=TRUE) V<-object$V if(object$mode=="corr"){ Y<-newdata/matrix(rep(sqrt(diag(V)),n),n,m,byrow=TRUE)-A } else Y<-newdata-A Scores<-Y%*%object$Evec if(!is.null(dim)) Scores<-Scores[,dim,drop=FALSE] } else { Scores<-if(!is.null(dim)) object$S[,dim,drop=FALSE] else object$S } Scores } ## S3 as.princomp method to convert to "princomp" object class as.princomp<-function(x,...) UseMethod("as.princomp") as.princomp.default<-function(x,...){ warning(paste( "as.princomp does not know how to handle objects of class ", class(x),".")) } as.princomp.phyl.pca<-function(x,...){ nn<-paste("Comp.",1:ncol(x$Evec),sep="") obj<-list() obj$sdev<-setNames(sqrt(diag(x$Eval)),nn) obj$loadings<-x$L colnames(obj$loadings)<-nn obj$center<-setNames(as.vector(x$a),rownames(x$Evec)) obj$scale<-setNames(rep(1,length(obj$center)),names(obj$center)) obj$scores<-x$S colnames(obj$scores)<-nn obj$call<-x$call class(obj)<-"princomp" obj } ## S3 as.prcomp method to convert to "prcomp" object class as.prcomp<-function(x,...) UseMethod("as.prcomp") as.prcomp.default<-function(x,...){ warning(paste( "as.prcomp does not know how to handle objects of class ", class(x),".")) } as.prcomp.phyl.pca<-function(x,...){ object<-list( sdev=sqrt(diag(x$Eval)), rotation=x$Evec, center=x$a, scale=if(x$mode=="corr") TRUE else FALSE, x=x$S) class(object)<-"prcomp" object }phytools/R/rateshift.R0000644000176200001440000002547714430765705014502 0ustar liggesusers## find the temporal position of a rate shift using ML ## written by Liam J. Revell 2013, 2014, 2015, 2020, 2023 rateshift<-function(tree,x,nrates=1,niter=10,method="ML",...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(hasArg(tol)) tol<-list(...)$tol else tol<-1e-8 if(hasArg(plot)) plot<-list(...)$plot else plot<-FALSE if(hasArg(print)) print<-list(...)$print else print<-FALSE if(hasArg(quiet)) quiet<-list(...)$quiet else quiet<-FALSE if(hasArg(minL)) minL<-list(...)$minL else minL<--1e12 if(hasArg(fixed.shift)) fixed.shift<-list(...)$fixed.shift else fixed.shift<-FALSE if(hasArg(compute.se)) compute.se<-list(...)$compute.se else compute.se<-TRUE if(hasArg(parallel)) parallel<-list(...)$parallel else parallel<-FALSE if(niter==1) parallel<-FALSE fn<-if(method=="ML") brownie.lite else brownieREML if(!fixed.shift[1]){ if(print){ if(!parallel) cat("Optimization progress:\n\n") if(nrates>1&&!parallel) cat(paste(c("iter",paste("shift",1:(nrates-1),sep=":"),"logL\n"),collapse="\t")) else if(!parallel) cat("iter\ts^2(1)\tlogL\n") } else if(niter==1) { if(!quiet) cat("Optimizing. Please wait.\n\n") flush.console() } else { if(!quiet&&!parallel) cat("Optimization progress:\n|") flush.console() } } else { if(!quiet) cat("Estimating rates conditioned on input shift points...\n\n") nrates<-if(fixed.shift[1]!=TRUE) length(fixed.shift)+1 else 1 if(nrates>2) fixed.shift<-sort(fixed.shift) names(fixed.shift)<-NULL } lik<-function(par,tree,y,nrates,plot,print,iter,Tol,maxh,minL){ shift<-sort(c(setNames(0,1),setNames(par,2:nrates))) if((any(shift[2:length(shift)]<=0)||any(shift>=maxh))) logL<-minL else { tree<-make.era.map(tree,shift,tol=Tol/10) if(plot){ plotSimmap(tree,setNames(rainbow(nrates),1:nrates),lwd=3,ftype="off",mar=c(0.1,0.1,4.1,0.1)) title(main=paste("Optimizing rate shift(s), round",iter,"....",sep=" ")) for(i in 2:(length(shift))) lines(rep(shift[i],2),c(0,length(tree$tip.label)+1),lty="dashed") } logL<-fn(tree,y)$logL.multiple } if(print){ if(nrates>1) cat(paste(c(iter,round(shift[2:length(shift)],4),round(logL,4),"\n"),collapse="\t")) else cat(paste(c(iter,round(par,4),round(logL,4),"\n"),collapse="\t")) } -logL } h<-max(nodeHeights(tree)) N<-length(tree$tip.label) x<-x[tree$tip.label] if(!fixed.shift[1]){ fit<-list() if(!parallel){ for(i in 1:niter){ if(nrates==1){ fit[[i]]<-fn(make.era.map(tree,setNames(0,1)),x) fit[[i]]$convergence<-if(fit[[i]]$convergence== "Optimization has converged.") 0 else 1 } else { fit[[i]]<-list() class(fit[[i]])<-"try-error" while(inherits(fit[[i]],"try-error")){ par<-sort(runif(n=nrates-1)*h) suppressWarnings(fit[[i]]<-try(optim(par,lik,tree=tree, y=x,nrates=nrates,print=print,plot=plot,iter=i, Tol=tol,maxh=h,minL=minL))) } } if(!print&&niter>1){ if(!quiet) cat(".") flush.console() } } } else { if(hasArg(ncores)) ncores<-list(...)$ncores else ncores<-min(c(detectCores()-1,niter)) mc<-makeCluster(ncores,type="PSOCK") registerDoParallel(cl=mc) if(!quiet){ cat(paste("Opened cluster with",ncores,"cores.\n")) cat("Running optimization iterations in parallel.\n") cat("Please wait....\n") flush.console() } fit<-foreach(i=1:niter)%dopar%{ if(nrates>1) par<-sort(runif(n=nrates-1)*h) if(nrates==1){ obj<-fn(make.era.map(tree,setNames(0,1)),x) obj$convergence<-if(obj$convergence=="Optimization has converged.") 0 else 1 } else { obj<-list() class(obj)<-"try-error" while(inherits(obj,"try-error")){ par<-sort(runif(n=nrates-1)*h) suppressWarnings(obj<-try(optim(par,lik,tree=tree,y=x,nrates=nrates, print=FALSE,plot=FALSE,iter=i,Tol=tol,maxh=h,minL=minL))) } } obj } stopCluster(cl=mc) } if(!print&&niter>1) if(!quiet) if(!parallel) cat("|\nDone.\n\n") else cat("Done.\n\n") ll<-sapply(fit,function(x) if(nrates>1) x$value else -x$logL1) fit<-fit[[which(ll==min(ll))[1]]] frequency.best<-mean(ll<=(min(ll)+1e-4)) likHess<-if(method=="ML") function(par,tree,y,nrates,tol,maxh){ sig2<-par[1:nrates] shift<-if(nrates>1) setNames(c(0,par[1:(nrates-1)+nrates]),1:nrates) else shift<-setNames(0,1) tree<-make.era.map(tree,shift,tol=tol/10) mC<-multiC(tree) mC<-mapply("*",mC,sig2,SIMPLIFY=FALSE) V<-Reduce("+",mC) invV<-solve(V) a<-as.numeric(colSums(invV)%*%x/sum(invV)) logL<-sum(dmnorm(y,rep(a,length(x)),V,log=TRUE)) -logL } else if(method=="REML") function(par,tree,y,nrates,tol,maxh){ sig2<-par[1:nrates] shift<-if(nrates>1) setNames(c(0,par[1:(nrates-1)+nrates]),1:nrates) else shift<-setNames(0,1) tree<-make.era.map(tree,shift,tol=tol/10) tree<-scaleByMap(tree,setNames(sig2,1:nrates)) picX<-pic(y,tree,scaled=FALSE,var.contrasts=TRUE) logL<-sum(dnorm(picX[,1],sd=sqrt(picX[,2]),log=TRUE)) -logL } mtree<-if(nrates>1) make.era.map(tree,c(0,fit$par)) else make.era.map(tree,0) obj<-fn(mtree,x) if(compute.se){ H<-optimHess(c(obj$sig2.multiple,fit$par),likHess,tree=tree,y=x,nrates=nrates,tol=tol,maxh=h) vcv<-if(nrates>1) solve(H) else 1/H } else vcv<-matrix(-1,2*nrates-1,2*nrates-1) if(nrates>1) rownames(vcv)<-colnames(vcv)<-c(paste("sig2(",1:nrates,")",sep=""),paste(1:(nrates-1),"<->",2:nrates,sep="")) else rownames(vcv)<-colnames(vcv)<-"sig2(1)" obj<-list(sig2=setNames(obj$sig2.multiple,1:nrates), shift=if(nrates>1) setNames(fit$par,paste(1:(nrates-1),"<->",2:nrates,sep="")) else NULL, vcv=vcv,tree=mtree,logL=obj$logL.multiple,convergence=fit$convergence,message=fit$message, method=method,frequency.best=frequency.best) } else { mtree<-if(nrates>1) make.era.map(tree,c(0,fixed.shift)) else make.era.map(tree,0) fit<-fn(mtree,x) if(fit$convergence=="Optimization has converged.") fit$convergence<-0 obj<-list(sig2=setNames(fit$sig2.multiple,1:nrates), shift=if(nrates>1) setNames(fixed.shift,paste(1:(nrates-1),"<->",2:nrates,sep="")) else NULL, vcv=matrix(-1,2*nrates-1,2*nrates-1),tree=mtree,logL=fit$logL.multiple,convergence=fit$convergence, method=method,message="Fitted rates from a fixed shifts",frequency.best=NA) } class(obj)<-"rateshift" if(plot) plot(obj,ftype="off") obj } ## S3 print method for object of class "rateshift" ## written by Liam J. Revell 2013, 2020 print.rateshift<-function(x,...){ sqroot<-function(x){ if(length(x)==1) if(x>=0) sqrt(x) else NaN else sapply(x,sqroot) } if(hasArg(digits)) digits<-list(...)$digits else digits<-4 x<-lapply(x,function(a,b) if(is.numeric(a)) round(a,b) else a,b=digits) cat(paste("ML ",length(x$sig2),"-rate model:\n",sep="")) tmp<-list() nn<-vector() for(i in 1:length(x$sig2)){ tmp[2*i-1]<-x$sig2[i] tmp[2*i]<-sqroot(diag(x$vcv)[i]) nn[2*i-1]<-paste("s^2(",names(x$sig2)[i],")",sep="") nn[2*i]<-paste("se(",names(x$sig2)[i],")",sep="") } tmp[2*i+1]<-2*length(x$sig2) tmp[2*i+2]<-x$logL nn[2*i+1]<-"k" nn[2*i+2]<-"logL" tmp<-as.data.frame(tmp) colnames(tmp)<-nn rownames(tmp)<-"value" print(tmp,digits=digits) if(!is.null(x$shift)){ cat("\nShift point(s) between regimes (height above root):\n") tmp<-list() nn<-vector() for(i in 1:length(x$shift)){ tmp[2*i-1]<-x$shift[i] tmp[2*i]<-sqroot(diag(x$vcv)[i+length(x$sig2)]) nn[2*i-1]<-paste(strsplit(names(x$shift[i]),"<->")[[1]],collapse="|") nn[2*i]<-paste("se(",paste(strsplit(names(x$shift[i]),"<->")[[1]], collapse="|"),")",sep="") } tmp<-as.data.frame(tmp) colnames(tmp)<-nn rownames(tmp)<-"value" print(tmp,digits=digits) } else cat("\nThis is a one-rate model.\n") if(x$method=="ML") cat("\nModel fit using ML.\n\n") else if(x$method=="REML") cat("\nModel fit using REML.\n\n") cat(paste("Frequency of best fit:",x$frequency.best,"\n\n")) if (x$convergence==0) cat(paste("R thinks it has found the",x$method,"solution.\n\n")) else cat("Optimization may not have converged.\n\n") } ## S3 logLik method for object of class "rateshift" ## written by Liam J. Revell 2013, 2020 logLik.rateshift<-function(object,...){ logLik<-object$logL class(logLik)<-"logLik" attr(logLik,"df")<-2*length(object$sig2) logLik } ## S3 plot method for object of class "rateshift" ## written by Liam J. Revell 2015, 2020, 2021 plot.rateshift<-function(x,...){ if(length(x$sig2)>1){ if(hasArg(col)) col<-list(...)$col else col<-c("blue","purple","red") cols<-colorRampPalette(col)(101) rr<-range(x$sig2) names(cols)<-seq(rr[1],rr[2],by=diff(rr)/100) ii<-sapply(x$sig2,function(x,y) order(abs(y-x))[1], y=as.numeric(names(cols))) colors<-setNames(cols[ii],names(ii)) args<-list(x=x$tree,ylim=c(-0.1*Ntip(x$tree),Ntip(x$tree)), colors=colors,...) args$col<-NULL do.call(plot,args) nulo<-lapply(x$shift,function(x,y) lines(rep(x,2),c(1,Ntip(y)), lty="dotted",col="grey"),y=x$tree) add.color.bar(leg=0.5*max(nodeHeights(x$tree)),cols=cols, prompt=FALSE,x=0,y=-0.05*Ntip(x$tree),lims=round(rr,3), title=expression(sigma^2)) } else { if(hasArg(col)) col<-list(...)$col else col<-"blue" colors<-setNames(col[1],1) args<-list(x=x$tree,ylim=c(-0.1*Ntip(x$tree),Ntip(x$tree)), colors=colors,...) args$col<-NULL do.call(plot,args) legend(x=0,y=0, legend=bquote(sigma^2 == .(round(x$sig2,3))), pch=15,col=colors,pt.cex=2,bty="n") } } ## function to visualize the likelihood surface for 2 & 3 rate models (1 & 2 rate-shifts) ## written by Liam J. Revell 2016 likSurface.rateshift<-function(tree,x,nrates=2,shift.range=NULL, density=20,plot=TRUE,...){ h<-max(nodeHeights(tree)) if(is.null(shift.range)) shift.range<-c(0.01*h,0.99*h) shift<-seq(shift.range[1],shift.range[2],length.out=density) if(nrates==2){ cat("Computing likelihood surface for 2-rate (1 rate-shift) model....\n") flush.console() logL1<-sapply(shift,function(s,tree,x) logLik(rateshift(tree,x,fixed.shift=s, quiet=TRUE)),tree=tree,x=x) if(plot) plot(shift,logL1,type="l",lwd=2,xlab="shift point",ylab="log(L)",...) cat("Done.\n") obj<-list(shift=shift,logL=logL1) } else if(nrates==3){ cat("Computing likelihood surface for 3-rate (2 rate-shift) model....\n") flush.console() logL2<-sapply(shift,function(s1,s2,tree,x) sapply(s2,function(s2,s1,tree,x) logLik(rateshift(tree,x,fixed.shift=if(s1!=s2) c(s1,s2) else s1, quiet=TRUE)),s1=s1,tree=tree,x=x),s2=shift,tree=tree,x=x) if(plot) contour(shift,shift,logL2,nlevels=20,xlab="shift 1 (or 2)", ylab="shift 2 (or 1)",...) cat("Done.\n") obj<-list(shift=shift,logL=logL2) } else if((nrates%in%c(2,3))==FALSE){ cat("Method only available for nrates==2 and nrates==3\n") obj<-NULL } invisible(obj) } phytools/R/mcmcMk.R0000644000176200001440000003173114375517350013705 0ustar liggesusers## written by Liam J. Revell mtom<-function(model){ model<-t(model) im<-matrix(NA,nrow(model),ncol(model)) indices<-setNames(1:length(unique(as.vector(model)))-1, unique(as.vector(model))) for(i in 1:length(as.vector(model))) im[i]<-indices[as.character(model[i])] t(im) } minChanges<-function(tree,x){ if(is.matrix(x)) x<-as.factor(apply(x,1,function(x) names(which(x==max(x)))[1])) parsimony(tree,as.phyDat(x)) } makeq<-function(Q,index.matrix){ q<-vector(length=max(index.matrix,na.rm=TRUE),mode="numeric") for(i in 1:length(q)) q[i]<-Q[match(i,index.matrix)] q } mcmcMk<-function(tree,x,model="ER",ngen=10000,...){ if(hasArg(plot)) plot<-list(...)$plot else plot<-TRUE log.prior<-function(x,prior) sum(dgamma(x,shape=prior$alpha,rate=prior$beta,log=TRUE)) proposal<-function(q,pv) abs(q+rnorm(n=length(q),sd=sqrt(pv))) if(hasArg(q)) q<-list(...)$q else q<-minChanges(tree,x)/sum(tree$edge.length) if(hasArg(prop.var)) prop.var<-list(...)$prop.var else prop.var<-1/max(nodeHeights(tree)) if(hasArg(auto.tune)) auto.tune<-list(...)$auto.tune else auto.tune<-TRUE if(is.numeric(auto.tune)){ target.accept<-auto.tune auto.tune<-TRUE } else target.accept<-0.5 if(hasArg(prior)) prior<-list(...)$prior else prior<-NULL if(hasArg(print)) print<-list(...)$print else print<-100 if(hasArg(likelihood)) likelihood<-list(...)$likelihood else { if(.check.pkg("geiger")) likelihood<-"fitDiscrete" else likelihood<-"fitMk" } if(likelihood=="fitDiscrete"){ if(.check.pkg("geiger")==FALSE){ cat("geiger is not installed. Setting likelihood method to \"fitMk\".\n\n") likelihood<-"fitMk" fitDiscrete<-function(...) NULL } else if(is.matrix(x)){ cat("likelihood=\"fitDiscrete\" doesn't work for data input as matrix.\n") cat("Setting likelihood method to \"fitMk\".\n\n") fitDiscrete<-function(...) NULL } } if(is.matrix(x)){ x<-x[tree$tip.label,] m<-ncol(x) states<-colnames(x) } else { y<-x x<-to.matrix(x,sort(unique(x))) x<-x[tree$tip.label,] m<-ncol(x) states<-colnames(x) } if(hasArg(pi)) pi<-list(...)$pi else pi<-"equal" if(pi[1]=="equal") pi<-setNames(rep(1/m,m),states) else pi<-pi/sum(pi) if(is.character(model)){ rate<-matrix(NA,m,m) if(model=="ER"){ k<-rate[]<-1 diag(rate)<-NA } else if(model=="ARD"){ k<-m*(m-1) rate[col(rate)!=row(rate)]<-1:k } else if(model=="SYM"){ k<-m*(m-1)/2 ii<-col(rate)runif(n=1)){ q<-qp likQ<-likQp accept<-accept+1/100 } PS[i,]<-c(i,q,likQ) if(print) if(i%%print==1){ cat(paste(round(PS[i,1]),paste(round(PS[i,1:k+1],4),collapse="\t"), round(PS[i,ncol(PS)],4),round(accept,3),sep="\t")) cat("\n") flush.console() } if(i%%100==1){ if(auto.tune) prop.var<-if(accept>target.accept) 1.1*prop.var else prop.var/1.1 accept<-0 } if(plot){ dev.hold() par(mfrow=c(2,1),mar=c(5.1,4.1,2.1,1.1)) plot(1:i,PS[1:i,"logLik"],col="darkgrey",xlab="", ylab="log(L)",xlim=c(0,ngen),type="l",bty="l") mtext("a) log-likelihood profile plot",side=3,line=1,cex=1, at=0,outer=FALSE,adj=0) plot(1:i,PS[1:i,2],col=Palette(1), xlab="generation",xlim=c(0,ngen), ylim=c(0,max(PS[1:i,2:(ncol(PS)-1)])), ylab="q",type="l",bty="l") abline(h=mean(PS[1:i,2]),lty="dotted",col=Palette(1)) text(x=ngen,y=mean(PS[1:i,2]),colnames(PS)[2],cex=0.5, col=Palette(1),pos=3) if(length(q)>1){ for(j in 2:length(q)){ lines(1:i,PS[1:i,j+1],col=Palette(j)) abline(h=mean(PS[1:i,j+1]),lty="dotted",col=Palette(j)) text(x=ngen,y=mean(PS[1:i,j+1]),colnames(PS)[j+1], cex=0.5,col=Palette(j),pos=3) } } mtext("b) rates",side=3,line=1,cex=1,at=0,outer=FALSE,adj=0) dev.flush() } } cat("Done.\n") class(PS)<-"mcmcMk" attr(PS,"model")<-model attr(PS,"index.matrix")<-index.matrix attr(PS,"states")<-states PS } Palette<-function(i){ if(!.check.pkg("RColorBrewer")){ brewer.pal<-function(...) NULL COLOR<-rep(palette(),ceiling(i/8))[i] COLOR<-if(COLOR=="black") "darkgrey" } else COLOR<-rep(brewer.pal(8,"Accent"),ceiling(i/8))[i] COLOR } print.mcmcMk<-function(x,...){ cat("\nPosterior sample from mcmcMk consisting of a posterior sample obtained using\n") cat("Bayesian MCMC in the form of a matrix.\n\n") cat("1. plot(\'object_name\') will create a likelihood profile plot.\n") cat("2. summary(\'object_name\') will compute a summary of the MCMC.\n") cat("3. density(\'object_name\') will calculate a posterior density from the sample.\n") cat("4. Finally, plot(density(\'object_name\')) will plot the posterior density and\n") cat(" and high probability density intervals.\n\n") cat("To work best, we recommend users install the package \'coda\'.\n\n") } plot.mcmcMk<-function(x,...){ par(mfrow=c(2,1),mar=c(5.1,4.1,2.1,1.1)) plot(x[,"gen"],x[,"logLik"],col="darkgrey",xlab="", ylab="log(L)",type="l",bty="l") mtext("a) log-likelihood profile plot",side=3,line=1,cex=1, at=0,outer=FALSE,adj=0) plot(x[,"gen"],x[,2],col=Palette(1),xlab="generation", ylim=c(0,max(x[,2:(ncol(x)-1)])),ylab="q",type="l", bty="l") abline(h=mean(x[,2]),lty="dotted",col=Palette(1)) text(x=max(x[,"gen"]),y=mean(x[,2]),colnames(x)[2],cex=0.5, col=Palette(1),pos=3) if(ncol(x)>3){ for(j in 2:(ncol(x)-2)){ lines(x[,"gen"],x[,j+1],col=Palette(j)) abline(h=mean(x[,j+1]),lty="dotted",col=Palette(j)) text(x=max(x[,"gen"]),y=mean(x[,j+1]),colnames(x)[j+1], cex=0.5,col=Palette(j),pos=3) } } mtext("b) rates",side=3,line=1,cex=1,at=0,outer=FALSE,adj=0) } summary.mcmcMk<-function(object,...){ if(hasArg(burnin)) burnin<-list(...)$burnin else { burnin<-floor(0.2*nrow(object)) cat("Assuming 20% burn-in as no burn-in was specified....\n\n") } ii<-which((object[,"gen"]-burnin)^2==min((object[,"gen"]-burnin)^2)) PD<-object[(ii+1):nrow(object),] ## compute the average value of Q Q<-makeQ(length(attr(object,"states")), colMeans(PD[,2:(ncol(object)-1),drop=FALSE]), attr(object,"index.matrix")) colnames(Q)<-rownames(Q)<-attr(object,"states") ## print Q cat("Mean value of Q from the post burn-in posterior sample:\n") print(Q) ## compute the median value of Q median.Q<-makeQ(length(attr(object,"states")), apply(PD[,2:(ncol(object)-1),drop=FALSE],2,median), attr(object,"index.matrix")) colnames(median.Q)<-rownames(median.Q)<-attr(object,"states") ## print Q cat("\nMedian value of Q from the post burn-in posterior sample:\n") print(median.Q) if(.check.pkg("coda")){ hpd95<-function(x) HPDinterval(as.mcmc(x)) } else { cat(" HPDinterval requires package coda.\n") cat(" Computing 95% interval from samples only.\n\n") hpd95<-function(x){ obj<-setNames(c(sort(x)[round(0.025*length(x))], sort(x)[round(0.975*length(x))]), c("lower","upper")) attr(obj,"Probability")<-0.95 obj } } HPD<-t(apply(PD[,2:(ncol(object)-1),drop=FALSE],2,hpd95)) colnames(HPD)<-c("lower","upper") cat("\n95% HPD interval computed either from the post burn-in\nsamples or using \'coda\':\n") print(HPD) cat("\n") object<-list(mean.Q=Q,median.Q=median.Q,HPD95=HPD) class(object)<-"summary.mcmcMk" invisible(object) } density.mcmcMk<-function(x,...){ if(hasArg(burnin)) burnin<-list(...)$burnin else { burnin<-floor(0.2*nrow(x)) cat("Assuming 20% burn-in as no burn-in was specified....\n") } ii<-which((x[,"gen"]-burnin)^2==min((x[,"gen"]-burnin)^2)) PD<-x[(ii+1):nrow(x),] if(hasArg(bw)) bw<-list(...)$bw else bw<-rep("nrd0",ncol(x)-2) if(length(bw)==1) bw<-rep(bw,ncol(x)-2) d<-list() for(i in 2:(ncol(PD)-1)) d[[i-1]]<-density(PD[,i],bw=bw[i-1]) class(d)<-"density.mcmcMk" names(d)<-paste("Density",colnames(x)[2:(ncol(x)-1)]) attr(d,"model")<-attr(x,"model") attr(d,"index.matrix")<-attr(x,"index.matrix") attr(d,"states")<-attr(x,"states") nulo<-capture.output(attr(d,"summary")<-summary(x,...)) d } print.density.mcmcMk<-function(x, digits=NULL, ...){ for(i in 1:length(x)){ cat(paste("\n",names(x)[1],"\n\n")) print(summary(as.data.frame(x[[1]][c("x", "y")])), digits = digits, ...) } cat("\n") cat("To plot enter plot(\'object_name\') at the command line interface.\n\n") invisible(x) } plot.density.mcmcMk<-function(x,...){ if(hasArg(show.matrix)) show.matrix<-list(...)$show.matrix else show.matrix<-FALSE if(hasArg(xlim)) xlim<-list(...)$xlim else xlim<-range(sapply(x,function(x) x$x)) if(hasArg(ylim)) ylim<-list(...)$ylim else ylim<-c(0,1.1*max(sapply(x,function(x) x$y))) if(length(x)==1){ if(hasArg(main)) main<-list(...)$main else main<-"estimated posterior density for q" plot(x[[1]],main=main, bty="l",font.main=1,xlim=xlim,ylim=ylim, xlab="q",bty="l") polygon(x[[1]],col=make.transparent("blue",0.5)) lines(x=attr(x,"summary")$HPD95[1,],y=rep(1.01*max(x[[1]]$y),2)) text(x=mean(attr(x,"summary")$HPD95[1,]), y=1.01*max(x[[1]]$y),"95% HPD",pos=3) } else if(length(x)==2&&show.matrix==FALSE){ if(hasArg(main)) main<-list(...)$main else main<-expression(paste("estimated posterior density for ", Q[ij])) plot(x[[1]],xlim=xlim,ylim=ylim, main=main,xlab="q",bty="l") polygon(x[[1]],col=make.transparent("blue",0.25)) lines(x=attr(x,"summary")$HPD95[1,], y=rep(max(x[[1]]$y),2)+0.01*diff(ylim)) text(x=mean(attr(x,"summary")$HPD95[1,]), y=max(x[[1]]$y)+0.01*diff(ylim),paste("95% HPD", rownames(attr(x,"summary")$HPD95)[1]),pos=3) lines(x[[2]]) polygon(x[[2]],col=make.transparent("red",0.25)) lines(x=attr(x,"summary")$HPD95[2,], y=rep(max(x[[2]]$y),2)+0.01*diff(ylim)) text(x=mean(attr(x,"summary")$HPD95[2,]), y=max(x[[2]]$y)+0.01*diff(ylim),paste("95% HPD", rownames(attr(x,"summary")$HPD95)[2]),pos=3) nam.legend<-sapply(strsplit(names(x),"Density "),function(x) x[2]) legend(x="topright",legend=nam.legend,bty="n",pt.cex=2,pch=22, pt.bg=c(make.transparent("blue",0.25),make.transparent("red", 0.25))) } else { k<-length(attr(x,"states")) par(mfrow=c(k,k)) NAMES<-sapply(strsplit(names(x),"Density "),function(x) x[2]) NAMES<-sapply(strsplit(NAMES,""),function(x) paste(x[2:(length(x)-1)], collapse="")) s.i<-sapply(strsplit(NAMES,","),function(x) x[1]) s.j<-sapply(strsplit(NAMES,","),function(x) x[2]) for(i in 1:k){ for(j in 1:k){ ii<-intersect(which(s.i==attr(x,"states")[i]), which(s.j==attr(x,"states")[j])) if(length(ii)==0) { plot(c(0,1),c(1,0),type="l",lty="dotted",xaxt="n",yaxt="n", xlab="",ylab="") } else { plot(x[[ii]],xlim=xlim,ylim=ylim, main=paste("estimated posterior density for Q[", s.i[ii],",",s.j[ii],"]",sep=""),xlab="q",bty="l", font.main=1,cex.main=1,mar=c(4.1,4.1,3.1,1.1)) polygon(x[[ii]],col=make.transparent("blue",0.25)) lines(x=attr(x,"summary")$HPD95[ii,], y=rep(max(x[[ii]]$y),2)+0.01*diff(ylim)) text(x=mean(attr(x,"summary")$HPD95[ii,]), y=max(x[[ii]]$y)+0.01*diff(ylim),"95% HPD",pos=3) } } } } }phytools/R/phylo.to.map.R0000644000176200001440000003210114500202364015000 0ustar liggesusers## function depends on phytools (& dependencies) and maps (& dependencies) ## written by Liam J. Revell 2013, 2017, 2019, 2022, 2023 phylo.to.map<-function(tree,coords,rotate=TRUE,...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") # optional arguments if(hasArg(database)) database<-list(...)$database else database<-"world" if(hasArg(regions)) regions<-list(...)$regions else regions<-"." if(hasArg(plot)) plot<-list(...)$plot else plot<-TRUE if(hasArg(xlim)) xlim<-list(...)$xlim else xlim<-c(-180,180) if(hasArg(ylim)) ylim<-list(...)$ylim else ylim<-c(-90,90) if(hasArg(quiet)) quiet<-list(...)$quiet else quiet<-FALSE # create a map map<-map(database,regions,xlim=xlim,ylim=ylim,plot=FALSE,fill=TRUE,resolution=0) # if rotate if(hasArg(type)) type<-list(...)$type else type<-"phylogram" if(hasArg(direction)) direction<-list(...)$direction else direction<-"downwards" if(is.data.frame(coords)) coords<-as.matrix(coords) if(rotate&&type=="phylogram"){ cc<-aggregate(coords,by=list(rownames(coords)),mean) cc<-matrix(as.matrix(cc[,2:3]),nrow(cc),2,dimnames=list(cc[,1],colnames(cc)[2:3])) tree<-minRotate(tree,cc[,if(direction=="rightwards") 1 else 2],print=!quiet) } else direction<-"unoptimized" x<-list(tree=tree,map=map,coords=coords,direction=direction) class(x)<-"phylo.to.map" if(plot) plot.phylo.to.map(x,...) invisible(x) } ## S3 method to plot object of class "phylo.to.map" ## written by Liam J. Revell 2013, 2014, 2016, 2019, 2020, 2022, 2023 expand_range<-function(x){ d<-diff(x) x+0.05*c(-1,1)*d } update_map<-function(map,xlim,ylim){ tmp<-list() j<-k<-1 for(i in 1:length(map$names)){ xx<-yy<-c() ii<-1 while(!is.na(map$x[j])&&j<=length(map$x)){ xx[ii]<-map$x[j] yy[ii]<-map$y[j] ii<-ii+1 j<-j+1 } j<-j+1 if(any(xx>xlim[1])&&any(xxylim[1])&&any(yy1) c(tmp$x,NA,xx) else xx tmp$y<-if(k>1) c(tmp$y,NA,yy) else yy tmp$names<-if(k>1) c(tmp$names,map$names[i]) else map$names[i] k<-k+1 } } tmp$range<-c(range(tmp$x,na.rm=TRUE),range(tmp$y,na.rm=TRUE)) class(tmp)<-"map" tmp } plot.phylo.to.map<-function(x,type=c("phylogram","direct"),...){ type<-type[1] if(hasArg(lim_to_coords)) lim_to_coords<-list(...)$lim_to_coords else lim_to_coords<-TRUE if(hasArg(slice_landmasses)) slice_landmasses<-list(...)$slice_landmasses else slice_landmasses<-TRUE if(hasArg(delimit_map)) delimit_map<-list(...)$delimit_map else delimit_map<-FALSE if(inherits(x,"phylo.to.map")){ tree<-x$tree map<-x$map coords<-x$coords } else stop("x should be an object of class \"phylo.to.map\"") # get optional arguments if(hasArg(xlim)) xlim<-list(...)$xlim else { if(lim_to_coords) xlim<-expand_range(range(x$coords[,2])) else xlim<-map$range[1:2] } if(hasArg(ylim)) ylim<-list(...)$ylim else { if(lim_to_coords) ylim<-expand_range(range(x$coords[,1])) else ylim<-map$range[3:4] } ## update map map<-update_map(map,xlim=xlim,ylim=ylim) if(hasArg(fsize)) fsize<-list(...)$fsize else fsize<-1.0 if(hasArg(split)) split<-list(...)$split else split<-c(0.4,0.6) if(hasArg(psize)) psize<-list(...)$psize else psize<-1.0 if(hasArg(cex.points)){ cex.points<-list(...)$cex.points if(length(cex.points)==1) cex.points<-c(0.6*cex.points,cex.points) } else cex.points<-c(0.6*psize,psize) if(hasArg(mar)) mar<-list(...)$mar else mar<-rep(0,4) if(hasArg(asp)) asp<-list(...)$asp else asp<-1.0 if(hasArg(ftype)) ftype<-list(...)$ftype else ftype<-"reg" ftype<-which(c("off","reg","b","i","bi")==ftype)-1 if(!ftype) fsize=0 if(hasArg(from.tip)) from.tip<-list(...)$from.tip else from.tip<-FALSE if(hasArg(colors)) colors<-list(...)$colors else colors<-"red" if(length(colors)==1) rep(colors[1],2)->colors if(length(colors)==2&&type=="phylogram"){ colors<-matrix(rep(colors,nrow(coords)),nrow(coords),2,byrow=TRUE) rownames(colors)<-rownames(coords) } else if(is.vector(colors)&&(length(colors)==Ntip(tree))) { COLS<-matrix("red",nrow(coords),2,dimnames=list(rownames(coords))) for(i in 1:length(colors)) COLS[which(rownames(COLS)==names(colors)[i]),1:2]<-colors[i] colors<-COLS } if(hasArg(direction)) direction<-list(...)$direction else direction<-"downwards" if(hasArg(pch)) pch<-list(...)$pch else pch<-21 if(length(pch)==1) pch<-rep(pch,2) if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-c(2,1) if(length(lwd)==1) lwd<-rep(lwd,2) if(hasArg(lty)) lty<-list(...)$lty else lty<-"dashed" if(hasArg(pts)) pts<-list(...)$pts else pts<-TRUE if(hasArg(col.edge)) col.edge<-list(...)$col.edge else col.edge<-rep(par()$fg,nrow(x$tree$edge)) if(hasArg(map.bg)) map.bg<-list(...)$map.bg else map.bg<-"gray95" if(type=="phylogram"){ if(x$direction=="downwards"&&direction=="rightwards"){ cat("\"phylo.to.map\" direction is \"downwards\" but plot direction has been given as \"rightwards\".\n") cat("Re-optimizing object....\n") cc<-aggregate(coords,by=list(rownames(coords)),mean) cc<-matrix(as.matrix(cc[,2:3]),nrow(cc),2,dimnames=list(cc[,1],colnames(cc)[2:3])) tree<-minRotate(tree,cc[,1]) } else if(x$direction=="rightwards"&&direction=="downwards"){ cat("\"phylo.to.map\" direction is \"rightwards\" but plot direction has been given as \"downwards\".\n") cat("Re-optimizing object....\n") cc<-aggregate(coords,by=list(rownames(coords)),mean) cc<-matrix(as.matrix(cc[,2:3]),nrow(cc),2,dimnames=list(cc[,1],colnames(cc)[2:3])) tree<-minRotate(tree,cc[,2]) } } # recompute ylim or xlim to leave space for the tree XLIM<-xlim YLIM<-ylim if(type=="phylogram"){ if(direction=="downwards"){ if(!ftype) ylim<-c(ylim[1],ylim[2]+0.03*diff(ylim)) ylim<-c(ylim[1],ylim[2]+ split[1]/split[2]*(ylim[2]-ylim[1])) } else if(direction=="rightwards"){ if(!ftype) xlim<-c(xlim[1]-0.03*diff(xlim),xlim[2]) xlim<-c(xlim[1]-split[1]/split[2]*(xlim[2]-xlim[1]),xlim[2]) } } # open & size a new plot if(all(mar==0)) mar<-mar+0.01 plot.new() par(mar=mar) plot.window(xlim=xlim,ylim=ylim,asp=asp) if(slice_landmasses) clip(XLIM[1],XLIM[2],YLIM[1],YLIM[2]) if(hasArg(map.fill)) map.fill<-list(...)$map.fill else map.fill<-par()$bg if(delimit_map){ polygon(XLIM[c(1,2,2,1,1)],YLIM[c(1,1,2,2,1)], border=make.transparent(map.bg,1),lty="dotted", col=map.fill) } map(map,add=TRUE,fill=TRUE,col=map.bg,mar=rep(0,4)) if(slice_landmasses) clip(par()$usr[1],par()$usr[2],par()$usr[3],par()$usr[4]) if(type=="phylogram"){ ## preliminaries cw<-reorder(tree,"cladewise") if(!is.binary(cw)) cw<-multi2di(cw) n<-Ntip(cw) if(direction=="downwards"){ # plot a white rectangle dx<-abs(diff(xlim)) # rect(xlim[1]-1.04*dx,ylim[2]-split[1]*(ylim[2]-ylim[1]), # xlim[2]+1.04*dx,ylim[2],col=par()$bg,border=par()$bg) # rescale tree so it fits in the upper half of the plot # with enough space for labels pdin<-par()$din[2] sh<-(fsize*strwidth(paste(" ",cw$tip.label,sep=""))+ 0.3*fsize*strwidth("W"))*(par()$din[1]/par()$din[2])* (diff(par()$usr[3:4])/diff(par()$usr[1:2])) cw$edge.length<-cw$edge.length/max(nodeHeights(cw))* (split[1]*(ylim[2]-ylim[1])-max(sh)) pw<-reorder(cw,"postorder") ## post-order x<-vector(length=n+cw$Nnode) x[cw$edge[cw$edge[,2]<=n,2]]<-0:(n-1)/(n-1)*(xlim[2]-xlim[1])+xlim[1] nn<-unique(pw$edge[,1]) # compute horizontal position of each edge for(i in 1:length(nn)){ xx<-x[pw$edge[which(pw$edge[,1]==nn[i]),2]] x[nn[i]]<-mean(range(xx)) } # compute start & end points of each edge Y<-ylim[2]-nodeHeights(cw) # plot coordinates & linking lines coords<-coords[,2:1] for(i in 1:nrow(coords)){ tip.i<-which(cw$tip.label==rownames(coords)[i]) lines(c(x[tip.i],coords[i,1]),c(Y[which(cw$edge[,2]==tip.i),2]- if(from.tip) 0 else sh[tip.i],coords[i,2]), col=colors[i,1],lty=lty,lwd=lwd[2]) } points(coords,pch=pch,cex=cex.points[2],bg=colors[,2]) # plot vertical edges for(i in 1:nrow(Y)) lines(rep(x[cw$edge[i,2]],2),Y[i,], lwd=lwd[1],lend=2) # plot horizontal relationships for(i in 1:cw$Nnode+n){ ii<-which(cw$edge[,1]==i) if(length(ii)>1) lines(range(x[cw$edge[ii,2]]),Y[ii,1],lwd=lwd[1],lend=2) } # plot tip labels for(i in 1:n){ if(ftype) text(x[i],Y[which(cw$edge[,2]==i),2], paste(" ",sub("_"," ",cw$tip.label[i]),sep=""), pos=4,offset=c(0,1), srt=-90,cex=fsize,font=ftype) if(pts) points(x[i],Y[which(cw$edge[,2]==i),2],pch=21, bg=colors[sapply(cw$tip.label,function(x,y) which(y==x)[1], y=rownames(colors)),][i,2],cex=cex.points[1]) } PP<-list(type="phylogram",use.edge.length=TRUE,node.pos=1, show.tip.label=if(ftype) TRUE else FALSE,show.node.label=FALSE, font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE, label.offset=fsize*strwidth(" ")/(par()$usr[2]- par()$usr[1])*(par()$usr[4]-par()$usr[3]), x.lim=xlim,y.lim=ylim, direction=direction,tip.color=par()$fg,Ntip=Ntip(cw), Nnode=cw$Nnode,edge=cw$edge,xx=x,yy=sapply(1:(Ntip(cw)+ cw$Nnode),function(x,y,z) y[match(x,z)],y=Y,z=cw$edge)) } else { dy<-abs(diff(ylim)) #rect(xlim[1],ylim[1],xlim[1]+split[1]*(xlim[2]- # xlim[1]),ylim[2],col=par()$bg,border=par()$bg) sh<-fsize*strwidth(paste(" ",cw$tip.label,sep=""))+ 0.2*fsize*strwidth("W") cw$edge.length<-cw$edge.length/max(nodeHeights(cw))* (split[1]*(xlim[2]-xlim[1])-max(sh)) pw<-reorder(cw,"postorder") y<-vector(length=n+cw$Nnode) y[cw$edge[cw$edge[,2]<=n,2]]<-0:(n-1)/(n-1)*(ylim[2]-ylim[1])+ylim[1] nn<-unique(pw$edge[,1]) for(i in 1:length(nn)){ yy<-y[pw$edge[which(pw$edge[,1]==nn[i]),2]] y[nn[i]]<-mean(range(yy)) } H<-nodeHeights(cw) X<-xlim[1]+H coords<-coords[,2:1] for(i in 1:nrow(coords)){ tip.i<-which(cw$tip.label==rownames(coords)[i]) lines(c(X[which(cw$edge[,2]==tip.i),2]+if(from.tip) 0 else sh[tip.i],coords[i,1]), c(y[tip.i],coords[i,2]),col=colors[i,1],lty=lty,lwd=lwd[2]) } points(coords,pch=pch,cex=cex.points[2],bg=colors[,2]) for(i in 1:nrow(X)) lines(X[i,],rep(y[cw$edge[i,2]],2),lwd=lwd[1],lend=2) for(i in 1:cw$Nnode+n){ ii<-which(cw$edge[,1]==i) if(length(ii)>1) lines(X[ii,1],range(y[cw$edge[ii,2]]),lwd=lwd[1],lend=2) } for(i in 1:n){ if(ftype) text(X[which(cw$edge[,2]==i),2],y[i], paste(" ",sub("_"," ",cw$tip.label[i]),sep=""), pos=4,offset=0.1,cex=fsize,font=ftype) if(pts) points(X[which(cw$edge[,2]==i),2],y[i], pch=21,bg=colors[cw$tip.label,][i,2],cex=cex.points[1]) } PP<-list(type="phylogram",use.edge.length=TRUE,node.pos=1, show.tip.label=if(ftype) TRUE else FALSE,show.node.label=FALSE, font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE,label.offset=0.1, x.lim=xlim,y.lim=ylim, direction=direction,tip.color=par()$fg,Ntip=Ntip(cw),Nnode=cw$Nnode, edge=cw$edge,xx=sapply(1:(Ntip(cw)+cw$Nnode), function(x,y,z) y[match(x,z)],y=X,z=cw$edge),yy=y) } assign("last_plot.phylo",PP,envir=.PlotPhyloEnv) } else if(type=="direct"){ phylomorphospace(tree,coords[,2:1],add=TRUE,label="horizontal", node.size=c(0,psize),lwd=lwd[2],control=list(col.node= setNames(rep(colors[2],max(tree$edge)),1:max(tree$edge)), col.edge=setNames(rep(colors[1],nrow(tree$edge)),tree$edge[,2])), ftype=c("off","reg","b","i","bi")[ftype+1],fsize=fsize) } } ## rotates all nodes to try and match tip an ordering ## written by Liam J. Revell 2013, 2015, 2020 minRotate<-function(tree,x,...){ if(hasArg(print)) print<-list(...)$print else print<-TRUE tree<-reorder(tree) nn<-1:tree$Nnode+Ntip(tree) x<-x[tree$tip.label] for(i in 1:tree$Nnode){ tt<-read.tree(text=write.tree(if(isSingleton(tree,nn[i])) tree else rotate(tree,nn[i]))) oo<-sum(abs(order(x[tree$tip.label])-1:length(tree$tip.label))) pp<-sum(abs(order(x[tt$tip.label])-1:length(tt$tip.label))) if(oo>pp) tree<-tt if(print) message(paste("objective:",min(oo,pp))) } attr(tree,"minRotate")<-min(oo,pp) return(tree) } isSingleton<-function(tree,node) if(sum(tree$edge[,1]==node)<=1) TRUE else FALSE print.phylo.to.map<-function(x,...){ cat("Object of class \"phylo.to.map\" containing:\n\n") cat(paste("(1) A phylogenetic tree with",Ntip(x$tree),"tips and",x$tree$Nnode,"internal nodes.\n\n",sep=" ")) cat("(2) A geographic map with range:\n") cat(paste(" ",paste(round(x$map$range[3:4],2),collapse="N, "),"N\n",sep="")) cat(paste(" ",paste(round(x$map$range[1:2],2),collapse="W, "),"W.\n\n",sep="")) cat(paste("(3) A table containing ",nrow(x$coords)," geographic coordinates (may include\n", " more than one set per species).\n\n",sep="")) if(x$direction%in%c("downwards","rightwards")) cat(paste("If optimized, tree nodes have been rotated to maximize alignment\n", "with the map when the tree is plotted in a ",x$direction," direction.\n\n",sep="")) else cat("The nodes of the tree may not have yet been rotated to maximize\nalignment between the phylogeny & the map.\n\n") } phytools/R/multiRF.R0000644000176200001440000000217214375517350014055 0ustar liggesusers## functions computes Robinson-Foulds distance between all trees in a list of class "multiPhylo" ## works only for unrooted trees (if trees are rooted, them will be unrooted) ## written by Liam J. Revell 2013, 2015, 2017, 2019 multiRF<-function(trees,quiet=FALSE,multi2di=FALSE){ if(!inherits(trees,"multiPhylo")) stop("trees should be an object of class \"multiPhylo\".") N<-length(trees) RF<-matrix(0,N,N) if(any(sapply(unclass(trees),is.rooted))){ if(!quiet) cat("Some trees are rooted. Unrooting all trees.\n") trees<-lapply(unclass(trees),unroot) } if(any(sapply(unclass(trees),function(x) !is.binary(x)))){ if(multi2di){ if(!quiet) cat("some trees are not binary. Using multi2di to render bifurcating.\n") trees<-lapply(trees,multi2di) class(trees)<-"multiPhylo" } else stop("Some trees are not binary. This implementation only works for binary trees.") } foo<-function(pp) lapply(pp,function(x,pp) sort(attr(pp,"labels")[x]),pp=pp) xx<-lapply(unclass(trees),function(x) foo(prop.part(x))[2:x$Nnode]) for(i in 1:(N-1)) for(j in (i+1):N) RF[i,j]<-RF[j,i]<-2*sum(!xx[[i]]%in%xx[[j]]) RF } phytools/R/fastAnc.R0000644000176200001440000000631214453026350014042 0ustar liggesusers## function does fast estimation of ML ancestral states using ace ## written by Liam J. Revell 2012, 2013, 2015, 2019, 2020, 2021, 2023 fastAnc<-function(tree,x,vars=FALSE,CI=FALSE,...){ if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".") if(is.null(names(x))){ warn<-paste("x should be a vector with names corresponding to the taxon labels of the tree.\n", " Assuming x is in the order of tree$tip.label (this is seldom true).") warning(warn) } if(length(class(tree)>1)) class(tree)<-"phylo" if(hasArg(anc.states)) anc.states<-list(...)$anc.states else anc.states<-NULL if(!is.null(anc.states)){ nodes<-as.numeric(names(anc.states)) tt<-tree for(i in 1:length(nodes)){ M<-matchNodes(tt,tree,method="distances",quiet=TRUE) ii<-M[which(M[,2]==nodes[i]),1] tt<-bind.tip(tt,nodes[i],edge.length=0,where=ii) } x<-c(x,anc.states) } else tt<-tree if(!is.binary(tt)) btree<-multi2di(tt,random=FALSE) else btree<-tt M<-btree$Nnode N<-length(btree$tip.label) anc<-v<-vector() for(i in 1:M+N){ a<-collapse.singles(multi2di(ape::root.phylo(btree,node=i),random=FALSE)) anc[i-N]<-ace(x,a,method="pic")$ace[1] names(anc)[i-N]<-i if(vars||CI){ picx<-pic(x,a,rescaled.tree=TRUE) b<-picx$rescaled.tree d<-which(b$edge[,1]==(length(b$tip.label)+1)) v[i-N]<-(1/b$edge.length[d[1]]+1/b$edge.length[d[2]])^(-1)*mean(picx$contr^2) names(v)[i-N]<-names(anc)[i-N] } } if(!is.binary(tree)||!is.null(anc.states)){ ancNames<-matchNodes(tree,btree,method="distances",quiet=TRUE) anc<-anc[as.character(ancNames[,2])] names(anc)<-ancNames[,1] if(vars||CI){ v<-v[as.character(ancNames[,2])] names(v)<-ancNames[,1] } } obj<-list(ace=anc) if(vars) obj$var<-v if(CI){ obj$CI95<-cbind(anc-1.96*sqrt(v),anc+1.96*sqrt(v)) rownames(obj$CI95)<-names(anc) } if(length(obj)==1) obj<-obj$ace class(obj)<-"fastAnc" obj } ## print method for "fastAnc" ## written by Liam J. Revell 2015 print.fastAnc<-function(x,digits=6,printlen=NULL,...){ cat("Ancestral character estimates using fastAnc:\n") if(!is.list(x)){ if(is.null(printlen)||printlen>=length(x)) print(round(unclass(x),digits)) else printDotDot(unclass(x),digits,printlen) } else { Nnode<-length(x$ace) if(is.null(printlen)||printlen>=Nnode) print(round(x$ace,digits)) else printDotDot(x$ace,digits,printlen) if(!is.null(x$var)){ cat("\nVariances on ancestral states:\n") if(is.null(printlen)||printlen>=Nnode) print(round(x$var,digits)) else printDotDot(x$var,digits,printlen) } if(!is.null(x$CI95)){ cat("\nLower & upper 95% CIs:\n") colnames(x$CI95)<-c("lower","upper") if(is.null(printlen)||printlen>=Nnode) print(round(x$CI95,digits)) else printDotDot(x$CI95,digits,printlen) } } cat("\n") } ## internal function ## written by Liam J. Revell 2015 printDotDot<-function(x,digits,printlen){ if(is.vector(x)){ x<-as.data.frame(t(as.matrix(unclass(round(x[1:printlen],digits))))) x<-cbind(x,"....") rownames(x)<-"" colnames(x)[printlen+1]<-"" print(x) } else if(is.matrix(x)){ x<-as.data.frame(rbind(round(x[1:printlen,],digits),c("....","...."))) print(x) } } phytools/R/optim.phylo.ls.R0000644000176200001440000000637514375517350015403 0ustar liggesusers## function performs least-squares phylogeny inference by nni ## written by Liam J. Revell 2011, 2013, 2015, 2019, 2022 optim.phylo.ls<-function(D,stree=NULL,set.neg.to.zero=TRUE,fixed=FALSE,tol=1e-10,collapse=TRUE){ # change D to a matrix (if actually an object of class "dist") if(inherits(D,"dist")) D<-as.matrix(D) # compute the number of species n<-nrow(D) if(is.null(stree)) stree<-rtree(n=n,tip.label=rownames(D),br=NULL,rooted=F) # random starting tree else if(!inherits(stree,"phylo")){ cat("starting tree must be an object of class \"phylo.\" using random starting tree.\n") stree<-rtree(n=n,tip.label=rownames(D),br=NULL,rooted=F) # random starting tree } if(!is.binary(stree)) stree<-multi2di(stree) if(is.rooted(stree)) stree<-unroot(stree) # get ls branch lengths for stree best.tree<-ls.tree(stree,D) Q<-attr(best.tree,"Q-score") bestQ<-0 # to start the loop # for search Nnni<-0 # loop while Q is not improved by nni while(bestQ-Q15) stop("branch and bound only allowed for n<=15") if(is.null(tree)){ if(attr(data,"type")=="DNA"){ print("no input tree; starting with NJ tree") tree<-NJ(dist.dna(as.DNAbin(data))) } else { print("no input tree; using random starting tree") tree<-rtree(n=length(data),tip.label=names(data),br=NULL,rooted=FALSE) } } trees<-branch.and.bound(data,tree) } else if(method=="exhaustive"){ if(length(data)>10) stop("exhaustive search only allowed for n<=10") if(!is.null(tree)) print("starting tree not necessary for exhaustive search") trees<-exhaustive.search(data) } if(length(trees)==1) trees<-trees[[1]] return(trees) } # function performs branch & bound search # written by Liam J. Revell 2011 branch.and.bound<-function(data,tree){ # first, compute the parsimony score on the input tree bound<-parsimony(tree,data) # now pick three species to start ################## this is new and I don't know if it helps if(is.null(tree$edge.length)){ print("starting with 3 species chosen at random") new<-list(stree(n=3,tip.label=sample(tree$tip.label,3))) } else { print("starting with 3 species chosen to maximize distance") mdSp<-names(sort(colSums(cophenetic(tree)),decreasing=TRUE))[1:3] mdSp<-c("Tarsier","Chimp","J.Macaque") print(mdSp) new<-list(stree(n=3,tip.label=mdSp)) } ################## ends here class(new)<-"multiPhylo" added<-new[[1]]$tip.label; remaining<-setdiff(tree$tip.label,added) # branch & bound while(length(remaining)>0){ old<-new; new<-list() new.tip<-sample(remaining,1) pscores<-vector() for(i in 1:length(old)){ temp<-add.everywhere(old[[i]],new.tip) score<-parsimony(temp,data) new<-c(new,temp[score<=bound]) pscores<-c(pscores,score[score<=bound]) } added<-c(added,new.tip) print(paste(length(added),"species added;",length(new),"trees retained",collapse="")) remaining<-setdiff(tree$tip.label,added) } # ok, done, now sort what needs to be returned trees<-new[pscores==min(pscores)] for(i in 1:length(trees)) attr(trees[[i]],"pscore")<-min(pscores) return(trees) # return all mp trees } # function does exhaustive tree search # written by Liam J. Revell 2011 exhaustive.search<-function(data){ all.trees<-allTrees(n=length(data),tip.label=names(data),rooted=FALSE) print(paste("searching",length(all.trees),"trees",collapse="")) all.trees = .uncompressTipLabel(all.trees) pscores<-parsimony(all.trees,data) minscore<-min(pscores); trees<-all.trees[pscores==minscore] for(i in 1:length(trees)) attr(trees[[i]],"pscore")<-min(pscores) return(trees) } phytools/R/cospeciation.R0000644000176200001440000000654214375517350015160 0ustar liggesusers## cospeciation method ## written by Liam J. Revell 2016 cospeciation<-function(t1,t2,distance=c("RF","SPR"), method=c("simulation","permutation"),assoc=NULL, nsim=100,...){ distance<-distance[1] if(!distance%in%c("RF","SPR")) distance<-"RF" method<-method[1] if(!method%in%c("simulation","permutation")) method<-"simulation" if(is.null(assoc)){ ## assume exact match tips<-intersect(t1$tip.label,t2$tip.label) assoc<-cbind(tips,tips) } if(any(!t1$tip.label%in%assoc[,1])) t1<-drop.tip(t1,setdiff(t1$tip.label,assoc[,1])) if(any(!assoc[,1]%in%t1$tip.label)) assoc<-assoc[assoc[,1]%in%t1$tip.label,] if(any(!t2$tip.label%in%assoc[,2])) t2<-drop.tip(t2,setdiff(t2$tip.label,assoc[,2])) if(any(!assoc[,2]%in%t2$tip.label)) assoc<-assoc[assoc[,2]%in%t2$tip.label,] if(method=="permutation"){ perm.labels<-function(tree){ tree$tip.label<-sample(tree$tip.label) tree } tt1<-replicate(nsim,perm.labels(t1),simplify=FALSE) swap.t2<-t2 swap.t2$tip.label<-sapply(t2$tip.label,function(x,y) y[which(y[,2]==x),1],y=assoc) tt2<-replicate(nsim,perm.labels(swap.t2),simplify=FALSE) } else { tt1<-pbtree(n=Ntip(t1),tip.label=t1$tip.label, nsim=nsim) swap.t2<-t2 swap.t2$tip.label<-sapply(t2$tip.label,function(x,y) y[which(y[,2]==x),1],y=assoc) tt2<-pbtree(n=Ntip(t2),tip.label=swap.t2$tip.label, nsim=nsim) } if(distance=="SPR"){ d.null<-mapply(SPR.dist,tt1,tt2) d<-SPR.dist(t1,swap.t2) P.val<-mean(c(d,d.null)<=d) } else { d.null<-mapply(RF.dist,tt1,tt2) d<-RF.dist(t1,swap.t2) P.val<-mean(c(d,d.null)<=d) } obj<-list(d=d,d.null=d.null,P.val=P.val, distance=if(distance=="SPR") "SPR" else "RF", method=if(method=="simulation") "simulation" else "permutation") class(obj)<-"cospeciation" obj } print.cospeciation<-function(x,...){ cat(paste("\nCo-speciation test based on",x$distance, "distance.\n")) cat(paste("P-value obtained via",x$method,".\n\n")) if(x$distance=="SPR") cat(paste(" SPR distance:",x$d,"\n")) else cat(paste(" RF distance:",x$d,"\n")) cat(paste(" Mean(SD) from null: ", round(mean(x$d.null),1),"(", round(sd(x$d.null),1),")\n",sep="")) cat(paste(" P-value:",round(x$P.val,6),"\n\n")) } plot.cospeciation<-function(x,...){ if(hasArg(bty)) bty<-list(...)$bty else bty<-"l" if(x$distance=="RF") p<-hist(x$d.null,breaks=seq(min(c(x$d,x$d.null))-3, max(c(x$d,x$d.null))+3,2),plot=FALSE) else if(x$distance=="SPR") p<-hist(x$d.null,breaks=seq(min(c(x$d,x$d.null))-1.5, max(c(x$d,x$d.null))+1.5,1),plot=FALSE) plot(p$mids,p$density,xlim=c(min(c(x$d,x$d.null))-2, max(c(x$d,x$d.null))+1),ylim=c(0,1.2*max(p$density)), type="n",bty=bty, xlab=paste(x$distance," distance (null by ", x$method,")",sep=""),ylab="relative frequency") y2<-rep(p$density,each=2) y2<-y2[-length(y2)] x2<-rep(p$breaks[2:length(p$breaks)-1],each=2)[-1] x3<-c(min(x2),x2,max(x2)) y3<-c(0,y2,0) polygon(x3,y3,col=make.transparent("blue",0.3), border=FALSE) lines(p$breaks[2:length(p$breaks)-1],p$density,type="s") arrows(x$d,max(c(0.2*max(p$density), 1.1*p$density[which(p$mids==x$d)])), x$d,0,lend="round", length=0.15,lwd=2,col="black") text(x$d-diff(par()$usr[1:2])/40, 1.1*max(c(0.2*max(p$density), 1.1*p$density[which(p$mids==x$d)])), "observed distance", srt=60,pos=4) } phytools/R/estDiversity.R0000644000176200001440000000503714375517350015174 0ustar liggesusers## function computes an estimate of the standing diversity in each category ## given by x at each node ## written by Liam J. Revell 2011-2013, 2019 estDiversity<-function(tree,x,method=c("asr","simulation"),model="ER",...){ if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".") method<-matchType(method[1],c("asr","simulation")) if(hasArg(nsim)) nsim<-list(...)$nsim else nsim=100 if(method=="asr"){ tree<-reorder(tree,"cladewise") # reorder tree H<-nodeHeights(tree) if(!(model=="ER"||model=="SYM"||if(is.matrix(model)) isSymmetric(model) else FALSE)){ cat("Warning:\n only symmetric models allowed for method=\"asr\"\n") cat(" changing to model=\"ER\".\n") model<-"ER" } bb<-rerootingMethod(tree,x,model=model) aa<-bb$marginal.anc Q<-bb$Q D<-matrix(0,nrow(aa),ncol(aa),dimnames=dimnames(aa)) # now loop through every node above the root message("Please wait. . . . Warning - this may take a while!") flush.console() for(i in 2:nrow(aa)){ tt<-H[match(as.numeric(rownames(aa)[i]),tree$edge[,2]),2] ii<-H[,1]tt ee<-tree$edge[ii,2] hh<-H[ii,1] for(j in 1:length(ee)){ tr<-reroot(tree,node.number=ee[j],position=tt-hh[j]) D[i,]<-D[i,]+apeAce(tr,x[tr$tip.label],model=model, fixedQ=Q)$lik.anc[1,] } D[i,]<-D[i,]*aa[i,] if(i%%10==0){ message(paste("Completed",i,"nodes")) flush.console() } } d<-rowSums(D) } else if(method=="simulation") { mtrees<-make.simmap(tree,x,nsim=nsim,model=model,message=FALSE) st<-sort(unique(x)); nn<-1:tree$Nnode+length(tree$tip) aa<-lapply(mtrees,function(x) describe.simmap(x, message=FALSE)$states) H<-nodeHeights(tree) D<-matrix(0,tree$Nnode,length(st),dimnames=list(nn,st)) CC<-lapply(mtrees,function(x) lapply(x$maps,cumsum)) # now loop through every node above the root message("Please wait. . . . Warning - this may take a while!") flush.console() for(i in 2:tree$Nnode){ tt<-H[match(nn[i],tree$edge[,2]),2] ii<-H[,1]tt ee<-tree$edge[ii,2] hh<-H[ii,1] for(j in 1:length(ee)){ dd<-setNames(rep(0,length(st)),st) for(k in 1:nsim){ jj<-1; while((tt-hh[j])>CC[[k]][[which(tree$edge[,2]== ee[j])]][jj]) jj<-jj+1 ss<-names(mtrees[[k]]$maps[[which(tree$edge[,2]== ee[j])]])[jj] dd[ss]<-dd[ss]+ if(ss==aa[[k]][i]) 1/nsim else 0 } D[i,]<-D[i,]+dd } D[i,]<-D[i,] if(i%%10==0) message(paste("Completed",i,"nodes")) } d<-rowSums(D) } return(d) } phytools/R/fitMk.parallel.R0000644000176200001440000000477314453075313015344 0ustar liggesusers## parallelized version of fitMk using optimParallel fitMk.parallel<-function(tree,x,model="SYM",ncores=1,...){ if(hasArg(rand_start)) rand_start<-list(...)$rand_start else rand_start<-FALSE ## compute states if(is.matrix(x)){ x<-x[tree$tip.label,] m<-ncol(x) ss<-colnames(x) } else { x<-to.matrix(x,sort(unique(x))) x<-x[tree$tip.label,] m<-ncol(x) ss<-colnames(x) } ## set pi if(hasArg(pi)) pi<-list(...)$pi else pi<-"equal" if(is.numeric(pi)) root.prior<-"given" if(pi[1]=="equal"){ pi<-setNames(rep(1/m,m),ss) root.prior<-"flat" } else if(pi[1]=="fitzjohn") root.prior<-"nuisance" if(is.numeric(pi)){ pi<-pi/sum(pi) if(is.null(names(pi))) pi<-setNames(pi,ss) pi<-pi[ss] } ## create object of class "fitMk" args<-list(...) args$tree<-tree args$x<-x args$model<-model args$pi<-pi args$opt.method="none" unfitted<-do.call(fitMk,args) ## unfitted<-fitMk(tree,x,model=model,pi=pi,opt.method="none") ## get initial values for optimization if(hasArg(q.init)) { q.init<-list(...)$q.init if(length(q.init)!=max(unfitted$index.matrix,na.rm=TRUE)) { q.init<-rep(q.init,max(unfitted$index.matrix, na.rm=TRUE))[1:max(unfitted$index.matrix, na.rm=TRUE)] } } else q.init<-rep(m/sum(tree$edge.length), max(unfitted$index.matrix,na.rm=TRUE)) if(rand_start) q.init<-q.init*rexp(length(q.init),1) ## create likelihood function loglik<-function(par,lik,index.matrix){ Q<-makeQ(nrow(index.matrix),exp(par),index.matrix) -lik(Q) } ## create cluster cl<-makeCluster(ncores) ## optimize model fit.parallel<-optimParallel( log(q.init), loglik,lik=unfitted$lik, index.matrix=unfitted$index.matrix, lower=log(1e-12), upper=log(max(nodeHeights(tree))*100), parallel=list(cl=cl,forward=FALSE, loginfo=TRUE) ) ## stop cluster ## setDefaultCluster(cl=NULL) stopCluster(cl) ## create object estQ<-makeQ(nrow(unfitted$index.matrix), exp(fit.parallel$par), unfitted$index.matrix) colnames(estQ)<-rownames(estQ)<-ss temp<-fitMk(tree,x,fixedQ=estQ,pi=pi) object<-list() object$logLik<-(-fit.parallel$value[1]) object$rates<-exp(fit.parallel$par) object$index.matrix<-unfitted$index.matrix object$states<-unfitted$states object$pi<-temp$pi object$method<-"optimParallel" object$root.prior<-temp$root.prior object$data<-x object$tree<-tree object$lik<-temp$lik object$opt_results<-fit.parallel[c("counts","convergence","message","loginfo")] class(object)<-"fitMk" object } phytools/R/ansi_phylo.R0000644000176200001440000000400014416535115014623 0ustar liggesusers## function for ANSI graphic style phylogenetic tree Asp<-function(){ w<-par("pin")[1]/diff(par("usr")[1:2]) h<-par("pin")[2]/diff(par("usr")[3:4]) w/h } ansi_phylo<-function(tree,vertical=c("|","-"),...){ vertical<-vertical[1] if(hasArg(horizontal)) horizontal<-list(...)$horizontal else horizontal<-"-" if(hasArg(x_spacer)) x_spacer<-list(...)$x_spacer else x_spacer<-1 if(hasArg(y_spacer)) y_spacer<-list(...)$y_spacer else y_spacer<-1.4 args<-list(...) args$direction<-"rightwards" args$type<-"phylogram" args$plot<-FALSE args$tree<-tree do.call(plotTree,args) pp<-get("last_plot.phylo",envir=.PlotPhyloEnv) if(hasArg(family)) family<-list(...)$family else family<-"mono" old_family<-par()$family par(family=family) w<-x_spacer*strwidth(horizontal) if(vertical!="-") h<-y_spacer*strheight(vertical) else h<-x_spacer*strwidth("-")*Asp() ee<-pp$edge for(i in 1:nrow(pp$edge)){ d<-diff(pp$xx[ee[i,]]) n<-floor(d/w) x<-mean(pp$xx[ee[i,]]) y<-pp$yy[ee[i,2]] text(x,y,paste(rep(horizontal,n),collapse="")) if(ee[i,2]>Ntip(tree)) { dd<-ee[which(ee[,1]==ee[i,2]),2] d<-diff(pp$yy[dd]) n<-floor(d/h) if(n>0){ if(vertical!="-"){ y<-seq(h/2,by=h,length.out=n) y<-(y-mean(y))+mean(pp$yy[dd]) x<-rep(pp$xx[ee[i,2]],length(y)) text(x,y,vertical) } else { y<-mean(pp$yy[dd]) x<-pp$xx[ee[i,2]] text(x,y,paste(rep("-",n),collapse=""), srt=90) } } } } root<-Ntip(tree)+1 dd<-ee[which(ee[,1]==root),2] d<-diff(pp$yy[dd]) n<-floor(d/h) if(n>0){ if(vertical!="-"){ y<-seq(h/2,by=h,length.out=n) y<-(y-mean(y))+mean(pp$yy[dd]) x<-rep(pp$xx[root],length(y)) text(x,y,vertical) } else { y<-mean(pp$yy[dd]) x<-mean(pp$xx[root]) text(x,y,paste(rep("-",n),collapse=""),srt=90) } } if(hasArg(fsize)) fsize<-list(...)$fsize else fsize<-1 for(i in 1:Ntip(tree)) text(pp$xx[i],pp$yy[i], tree$tip.label[i],pos=4,cex=fsize) par(family=old_family) } phytools/R/anc.Bayes.R0000644000176200001440000001351414546657126014306 0ustar liggesusers## function does Bayes ancestral character estimation ## written by Liam J. Revell 2011, 2013, 2015, 2017, 2020 anc.Bayes<-function(tree,x,ngen=10000,control=list(),...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") # give the function some defaults (in case none are provided) temp<-phyl.vcv(as.matrix(x[tree$tip.label]),vcv(tree),1) sig2<-temp$R[1,1] a<-temp$alpha y<-rep(a,tree$Nnode-1) pr.mean<-c(1000,rep(0,tree$Nnode)) pr.var<-c(pr.mean[1]^2,rep(1000,tree$Nnode)) prop<-rep(0.01*max(temp$C)*sig2,tree$Nnode+1) # populate control list con=list(sig2=sig2,a=a,y=y,pr.mean=pr.mean,pr.var=pr.var,prop=prop,sample=100) con[(namc<-names(control))]<-control con<-con[!sapply(con,is.null)] # print control parameters to screen message("Control parameters (set by user or default):"); str(con) # function returns the log-likelihood likelihood<-function(C,invC,detC,x,sig2,a,y){ z<-c(x,y)-rep(a,nrow(C)) logLik<--z%*%invC%*%z/(2*sig2)-nrow(C)*log(2*pi)/2-nrow(C)*log(sig2)/2-detC/2 return(logLik) } # function returns the prior log.prior<-function(pr.mean,pr.var,sig2,a,y) pp<-dexp(sig2,rate=1/pr.mean[1],log=TRUE)+sum(dnorm(c(a,y),mean=pr.mean[2:length(pr.mean)],sd=sqrt(pr.var[1+1:tree$Nnode]),log=TRUE)) # compute C C<-vcvPhylo(tree) # check to make sure that C will be non-singular if(any(tree$edge.length<=(10*.Machine$double.eps))) stop("some branch lengths are 0 or nearly zero") invC<-solve(C) detC<-determinant(C,logarithm=TRUE)$modulus[1] # now set starting values for MCMC sig2<-con$sig2; a<-con$a; y<-con$y x<-x[tree$tip.label] if(is.null(names(y))) names(y)<-length(tree$tip)+2:tree$Nnode else y[as.character(length(tree$tip)+2:tree$Nnode)] L<-likelihood(C,invC,detC,x,sig2,a,y) Pr<-log.prior(con$pr.mean,con$pr.var,sig2,a,y) # store X<-matrix(NA,ngen/con$sample+1,tree$Nnode+3,dimnames=list(NULL,c("gen","sig2",length(tree$tip)+1:tree$Nnode,"logLik"))) X[1,]<-c(0,sig2,a,y,L) message("Starting MCMC...") # start MCMC for(i in 1:ngen){ j<-(i-1)%%(tree$Nnode+1) if(j==0){ # update sig2 sig2.prime<-sig2+rnorm(n=1,sd=sqrt(con$prop[j+1])) if(sig2.prime<0) sig2.prime<--sig2.prime L.prime<-likelihood(C,invC,detC,x,sig2.prime,a,y) Pr.prime<-log.prior(con$pr.mean,con$pr.var,sig2.prime,a,y) post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L)) if(post.odds>runif(n=1)){ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2.prime,a,y,L.prime) sig2<-sig2.prime L<-L.prime Pr<-Pr.prime } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,y,L) } else if(j==1){ # update a a.prime<-a+rnorm(n=1,sd=sqrt(con$prop[j+1])) L.prime<-likelihood(C,invC,detC,x,sig2,a.prime,y) Pr.prime<-log.prior(con$pr.mean,con$pr.var,sig2,a.prime,y) post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L)) if(post.odds>runif(n=1)){ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a.prime,y,L.prime) a<-a.prime L<-L.prime Pr<-Pr.prime } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,y,L) } else { k<-j-1 # update node k y.prime<-y y.prime[k]<-y[k]+rnorm(n=1,sd=sqrt(con$prop[j+1])) L.prime<-likelihood(C,invC,detC,x,sig2,a,y.prime) Pr.prime<-log.prior(con$pr.mean,con$pr.var,sig2,a,y.prime) post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L)) if(post.odds>runif(n=1)){ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,y.prime,L.prime) y<-y.prime L<-L.prime Pr<-Pr.prime } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,y,L) } } # done MCMC message("Done MCMC.") obj<-list(mcmc=as.data.frame(X),tree=tree) class(obj)<-"anc.Bayes" obj } ## S3 methods print.anc.Bayes<-function(x,digits=6,printlen=NULL,...){ cat("\nObject of class \"anc.Bayes\" consisting of a posterior") cat("\n sample from a Bayesian ancestral state analysis:\n") if(hasArg(burnin)) burnin<-list(...)$burnin else burnin<-0.2*max(x$mcmc$gen) ii<-which(((x$mcmc$gen-burnin)^2)==min((x$mcmc$gen-burnin)^2)) Nnode<-x$tree$Nnode cat("\nMean ancestral states from posterior distribution:\n") ace<-colMeans(x$mcmc[ii:nrow(x$mcmc),as.character(1:Nnode+Ntip(x$tree))]) if(is.null(printlen)||printlen>=Nnode) print(round(ace,digits)) else printDotDot(ace,digits,printlen) cat(paste("\nBased on a burn-in of ",burnin," generations.\n\n",sep="")) invisible(ace) } summary.anc.Bayes<-function(object,...) print(object,...) plot.anc.Bayes<-function(x,...){ args<-list(...) if(is.null(args$what)) what<-"logLik" else { what<-args$what args$what<-NULL } if(is.null(args$burnin)) burnin<-0.2*max(x$mcmc$gen) else { burnin<-args$burnin args$burnin<-NULL } if(what=="logLik"){ args$x<-x$mcmc$gen args$y<-x$mcmc$logLik if(is.null(args$xlab)) args$xlab<-"generation" if(is.null(args$ylab)) args$ylab<-"log(L)" if(is.null(args$type)) args$type<-"l" if(is.null(args$col)) args$col<-make.transparent("blue",0.5) do.call(plot,args) } else { args$x<-x$mcmc$gen args$y<-x$mcmc[,as.character(what)] if(is.null(args$xlab)) args$xlab<-"generation" if(is.null(args$ylab)) args$ylab<-paste("state for node",what) if(is.null(args$type)) args$type<-"l" if(is.null(args$col)) args$col<-make.transparent("blue",0.5) if(is.null(args$ylim)) args$ylim<-range(x$mcmc[,2:(ncol(x$mcmc)-1)]) do.call(plot,args) } } density.anc.Bayes<-function(x,...){ if(hasArg(what)) what<-list(...)$what else what<-Ntip(x$tree)+1 if(hasArg(burnin)) burnin<-list(...)$burnin else burnin<-0.2*max(x$mcmc$gen) ii<-which(abs(x$mcmc$gen-burnin)==min(abs(x$mcmc$gen-burnin))) if(hasArg(bw)) bw<-list(...)$bw else bw<-"nrd0" args<-list(x=x$mcmc[ii:nrow(x$mcmc),as.character(what)], bw=bw) d<-do.call(density,args) d$call<-match.call() d$data.name<-if(what=="logLik") what else paste("node",what) d }phytools/R/simBMphylo.R0000644000176200001440000000403114375517350014552 0ustar liggesusers## functions & methods to simulate & plot discrete time Brownian motion ## on a simulated discrete-time tree simBMphylo<-function(n,t,sig2,plot=TRUE,...){ if(length(sig2)!=t) sig2<-rep(sig2[1],t) b<-exp((log(n)-log(2))/t)-1 tree<-pbtree(b=b,d=0,t=t,n=n,type="discrete", tip.label=if(n<=26) LETTERS[n:1] else NULL, quiet=TRUE) H<-nodeHeights(tree) root<-Ntip(tree)+1 xx<-list() for(i in 1:nrow(tree$edge)){ sd<-sqrt(sig2[H[i,1]+1:tree$edge.length[i]]) x<-rnorm(n=tree$edge.length[i],sd=sd) x<-c(0,cumsum(x)) if(tree$edge[i,1]!=root){ ii<-which(tree$edge[,2]==tree$edge[i,1]) x<-x+xx[[ii]][length(xx[[ii]])] } xx[[i]]<-x } object<-list(tree=tree,x=xx) class(object)<-"simBMphylo" if(plot) plot(object,...) invisible(object) } plot.simBMphylo<-function(x,...){ xx<-x$x tree<-x$tree H<-nodeHeights(tree) layout(mat=matrix(c(1,2),2,1), heights=c(1/3,2/3)) if(hasArg(fsize)) fsize<-list(...)$fsize else fsize<-0.9 if(hasArg(cex.axis)) cex.axis<-list(...)$cex.axis else cex.axis<-0.9 if(hasArg(cex.lab)) cex.lab=list(...)$cex.lab else cex.lab<-1 if(hasArg(las)) las<-list(...)$las else las<-par()$las plotTree(tree,mar=c(0.1,4.1,2.1,1.1), xlim=c(0,1.05*max(H)), ylim=c(1-2*(Ntip(tree)-1)*0.04, Ntip(tree)+(Ntip(tree)-1)*0.04),lwd=1, fsize=fsize) ## axis(1,cex.axis=cex.axis) mtext("a)",line=0,adj=0,cex=cex.lab) plot.new() par(mar=c(5.1,4.1,1.1,1.1)) plot.window(xlim=c(0,1.05*max(H)),ylim=range(xx)) axis(1,cex.axis=cex.axis,las=las) axis(2,cex.axis=cex.axis,las=las) for(i in 1:length(xx)) lines(H[i,1]:H[i,2],xx[[i]]) for(i in 1:Ntip(tree)){ ii<-which(tree$edge[,2]==i) text(max(H),xx[[ii]][length(xx[[ii]])], tree$tip.label[i],pos=4,offset=0.4/3, cex=fsize) } mtext("b)",line=0,adj=0,cex=cex.lab) title(xlab="time",ylab="phenotype", cex.lab=cex.lab) } print.simBMphylo<-function(x,...){ cat(paste("\nObject of class \"simBMphylo\" with",Ntip(x$tree),"taxa.\n"), sep="") cat("To print use plot method.\n\n") } phytools/R/densityTree.R0000644000176200001440000000752014375517350014774 0ustar liggesusers## function to make a color (e.g., "blue") transparent with alpha level alpha make.transparent<-function(color,alpha){ if(length(color)>1 && length(alpha)>1){ if(length(color) != length(alpha)){ cat("Lengths of color and alpha should match.\n") cat("Using only first alpha value....\n") cols<-make.transparent(color,alpha[1]) } else { cols<-mapply(make.transparent,color=color,alpha=alpha) } } else if(length(color)>1 && length(alpha)==1){ cols<-sapply(color,make.transparent,alpha=alpha) } else if(length(color)==1 && length(alpha)>1){ cols<-sapply(alpha,make.transparent,color=color) } else { RGB<-col2rgb(color)[,1]/255 cols<-rgb(RGB[1],RGB[2],RGB[3],alpha) } cols } ## function to be used internally rescaleTree<-function(tree,scale){ tree$edge.length<-tree$edge.length/max(nodeHeights(tree))*scale tree } ## function to plot a posterior density of trees (e.g., densiTree in phangorn) ## written by Liam J. Revell 2016, 2017 densityTree<-function(trees,colors="blue",alpha=NULL,method="plotTree", fix.depth=FALSE,use.edge.length=TRUE,compute.consensus=TRUE, use.gradient=FALSE,show.axis=TRUE,...){ N<-length(trees) if(any(sapply(trees,function(x) is.null(x$edge.length)))) use.edge.length<-FALSE if(!use.edge.length){ trees<-lapply(trees,compute.brlen) class(trees)<-"multiPhylo" } h<-sapply(trees,function(x) max(nodeHeights(x))) if(fix.depth){ if(method=="plotTree"){ trees<-lapply(trees,rescaleTree,mean(h)) class(trees)<-"multiPhylo" } else if(method=="plotSimmap"){ trees<-rescaleSimmap(trees,depth=mean(h)) } h<-sapply(trees,function(x) max(nodeHeights(x))) } tips<-setNames(1:Ntip(trees[[1]]), if(compute.consensus) untangle(consensus(trees), "read.tree")$tip.label else trees[[1]]$tip.label) if(is.null(alpha)) alpha<-max(c(1/N,0.01)) args<-list(...) args$direction<-"leftwards" args$tips<-tips args$add<-FALSE if(is.null(args$nodes)) args$nodes<-"inner" if(is.null(args$mar)) args$mar<-if(show.axis) c(4.1,1.1,1.1,1.1) else rep(1.1,4) if(is.null(args$ftype)) args$ftype<-"i" if(!use.gradient){ plotTree(trees[[which(h==max(h))[1]]],direction="leftwards",mar=args$mar, plot=FALSE) par(new=TRUE) args$xlim<-get("last_plot.phylo",envir=.PlotPhyloEnv)$x.lim[2:1] if(method=="plotTree"){ args$color<-make.transparent(colors[1],alpha) for(i in 1:length(trees)){ args$tree<-trees[[i]] do.call(plotTree,args) if(i==1){ if(show.axis) axis(1) args$ftype<-"off" args$add<-TRUE } } } else if(method=="plotSimmap"){ states<-sort(unique(as.vector(mapped.states(trees)))) if(length(colors)!=length(states)){ colors<-setNames(c("grey",palette()[2:length(states)]), states) } colors<-sapply(colors,make.transparent,alpha=alpha) args$colors<-colors for(i in 1:length(trees)){ args$tree<-trees[[i]] do.call(plotSimmap,args) if(i==1){ if(show.axis) axis(1) args$ftype<-"off" args$add<-TRUE } } } } else if(use.gradient){ rf<-multiRF(trees,quiet=TRUE) mds<-cmdscale(rf,k=1)[,1] trees<-trees[order(mds)] h<-h[order(mds)] args$ylim<-c(0,Ntip(trees[[1]])+1) plotTree(trees[[which(h==max(h))[1]]],direction="leftwards",mar=args$mar, ylim=args$ylim,plot=FALSE) par(new=TRUE) args$xlim<-get("last_plot.phylo",envir=.PlotPhyloEnv)$x.lim[2:1] colors<-sapply(rainbow(n=length(trees)),make.transparent,alpha=alpha) ftype<-args$ftype for(i in 1:length(trees)){ y.shift<-(i-median(1:length(trees)))/length(trees)/2 args$tree<-trees[[i]] args$tips<-tips+y.shift args$color<-colors[i] args$ftype<-if(i==floor(median(1:length(trees)))) ftype else "off" do.call(plotTree,args) if(i==1){ if(show.axis) axis(1) args$ftype<-"off" args$add<-TRUE } } } } phytools/R/utilities.R0000644000176200001440000023137214546657574014531 0ustar liggesusers## some utility functions ## written by Liam J. Revell 2011, 2012, 2013, 2014, 2015, 2016, 2017, ## 2018, 2019, 2020, 2021, 2022, 2023, 2024 ## function forces a tree to be ultrametric using two different methods ## written by Liam J. Revell 2017, 2021, 2022, 2023 force.ultrametric<-function(tree,method=c("nnls","extend"),...){ if(hasArg(message)) message<-list(...)$message else message<-TRUE if(message){ cat("***************************************************************\n") cat("* Note: *\n") cat("* force.ultrametric does not include a formal method to *\n") cat("* ultrametricize a tree & should only be used to coerce *\n") cat("* a phylogeny that fails is.ultrametric due to rounding -- *\n") cat("* not as a substitute for formal rate-smoothing methods. *\n") cat("***************************************************************\n") } method<-method[1] if(method=="nnls") tree<-nnls.tree(cophenetic(tree),tree, method="ultrametric",rooted=is.rooted(tree),trace=0) else if(method=="extend"){ h<-diag(vcv(tree)) d<-max(h)-h ii<-sapply(1:Ntip(tree),function(x,y) which(y==x), y=tree$edge[,2]) tree$edge.length[ii]<-tree$edge.length[ii]+d } else cat("method not recognized: returning input tree\n\n") tree } ## c "combine" method for "simmap" and "multiSimmap" object classes ## adapted from c.phylo in ape (Paradis & Schliep 2019) c.simmap<-function(...,recursive=TRUE){ obj<-list(...) classes<-lapply(obj,class) isphylo<-sapply(classes,function(x) "simmap" %in% x) if(all(isphylo)){ class(obj)<-c("multiSimmap","multiPhylo") return(obj) } if(!recursive) return(obj) ismulti<-sapply(classes, function(x) "multiSimmap" %in% x) if(all(isphylo|ismulti)){ result<-list() j<-1 for(i in 1:length(isphylo)){ if(isphylo[i]){ result[[j]]<-obj[[i]] j<-j+1 } else { n<-length(obj[[i]]) result[0:(n-1)+j]<-.uncompressTipLabel(obj[[i]]) j<-j+n } } class(result)<-c("multiSimmap","multiPhylo") obj<-result } else { msg<-paste("some objects not of class \"simmap\" or", "\"multiSimmap\": argument recursive=TRUE ignored") warning(msg) } return(obj) } ## adapted from c.multiPhylo in ape (Paradis & Schliep 2019) c.multiSimmap<-function(...,recursive=TRUE){ obj<-list(...) if(!recursive) return(obj) classes<-lapply(obj,class) isphylo<-sapply(classes,function(x) "simmap" %in% x) ismulti<-sapply(classes, function(x) "multiSimmap" %in% x) if(all(isphylo|ismulti)){ result<-list() j<-1 for(i in 1:length(isphylo)){ if(isphylo[i]){ result[[j]]<-obj[[i]] j<-j+1 } else { n<-length(obj[[i]]) result[0:(n-1)+j]<-.uncompressTipLabel(obj[[i]]) j<-j+n } } class(result)<-c("multiSimmap","multiPhylo") obj<-result } else { msg<-paste("some objects not of class \"simmap\" or", "\"multiSimmap\": argument recursive=TRUE ignored") warning(msg) } return(obj) } ## function to summarize the results of stochastic mapping ## written by Liam J. Revell 2013, 2014, 2015, 2021, 2022, 2023 describe.simmap<-function(tree,...){ if(hasArg(plot)) plot<-list(...)$plot else plot<-FALSE if(hasArg(check.equal)) check.equal<-list(...)$check.equal else check.equal<-FALSE if(hasArg(message)) message<-list(...)$message else message<-FALSE if(hasArg(ref.tree)) ref.tree<-list(...)$ref.tree else ref.tree<-NULL if(hasArg(states)) states<-list(...)$states else states<-NULL if(inherits(tree,"multiPhylo")){ if(check.equal){ TT<-sapply(tree,function(x,y) sapply(y,all.equal.phylo,x),y=tree) check<-all(TT) if(!check) cat("Note: Some trees are not equal.\nA \"reference\" tree will be computed if none was provided.\n\n") } else check<-TRUE if(is.null(ref.tree)&&check){ YY<-getStates(tree,"both") if(is.null(states)) states<-sort(unique(as.vector(YY))) ZZ<-t(apply(YY,1,function(x,levels,Nsim) summary(factor(x,levels))/Nsim, levels=states,Nsim=length(tree))) } else { YY<-getStates(tree) if(is.null(states)) states<-sort(unique(as.vector(YY))) if(is.null(ref.tree)){ cat("No reference tree provided & some trees are unequal.\nComputing majority-rule consensus tree.\n") ref.tree<-consensus(tree,p=0.5) } YYp<-matrix(NA,ref.tree$Nnode,length(tree),dimnames=list(1:ref.tree$Nnode+Ntip(ref.tree), NULL)) for(i in 1:length(tree)){ M<-matchNodes(ref.tree,tree[[i]]) jj<-sapply(M[,2],function(x,y) if(x%in%y) which(as.numeric(y)==x) else NA, y=as.numeric(rownames(YY))) YYp[,i]<-YY[jj,i] } ZZ<-t(apply(YYp,1,function(x,levels) summary(factor(x[!is.na(x)], levels))/sum(!is.na(x)),levels=states)) } XX<-countSimmap(tree,states,FALSE) XX<-XX[,-(which(as.vector(diag(-1,length(states)))==-1)+1)] AA<-lapply(unclass(tree),function(x) setNames( c(colSums(x$mapped.edge),sum(x$edge.length)), c(colnames(x$mapped.edge),"total"))) foo<-function(x,n){ y<-setNames(rep(0,length(n)),n) y[names(x)]<-x y } AA<-t(sapply(AA,foo,n=c(states,"total"))) BB<-getStates(tree,type="tips") CC<-t(apply(BB,1,function(x,levels,Nsim) summary(factor(x,levels))/Nsim,levels=states, Nsim=length(tree))) x<-list(count=XX,times=AA,ace=ZZ,tips=CC,tree=tree,ref.tree=if(!is.null(ref.tree)) ref.tree else NULL) class(x)<-"describe.simmap" } else if(inherits(tree,"phylo")){ XX<-countSimmap(tree,message=FALSE) YY<-getStates(tree) if(is.null(states)) states<-sort(unique(YY)) AA<-setNames(c(colSums(tree$mapped.edge),sum(tree$edge.length)), c(colnames(tree$mapped.edge),"total")) AA<-rbind(AA,AA/AA[length(AA)]); rownames(AA)<-c("raw","prop") x<-list(N=XX$N,Tr=XX$Tr,times=AA,states=YY,tree=tree) class(x)<-"describe.simmap" } if(message) print(x) if(plot) plot(x) x } # function works like extract.clade in ape but will preserve a discrete character mapping # written by Liam J. Revell 2013, 2023 extract.clade.simmap<-function(tree,node){ if(!inherits(tree,"simmap")) stop("tree should be an object of class \"simmap\".") x<-getDescendants(tree,node) x<-x[x<=Ntip(tree)] drop.tip.simmap(tree,tree$tip.label[-x]) } ## function to add an arrow pointing to a tip or node in the tree ## written by Liam J. Revell 2014, 2017, 2020, 2023 add.arrow<-function(tree=NULL,tip,...){ if(length(tip)>1){ object<-sapply(tip,add.arrow,tree=tree,...) invisible(object) } else { lastPP<-get("last_plot.phylo",envir=.PlotPhyloEnv) asp<-if(lastPP$type=="fan") 1 else (par()$usr[4]-par()$usr[3])/(par()$usr[2]- par()$usr[1]) if(!is.null(tree)){ if(inherits(tree,"contMap")) tree<-tree$tree else if(inherits(tree,"densityMap")) tree<-tree$tree } if(is.numeric(tip)){ ii<-tip if(!is.null(tree)&&ii<=Ntip(tree)) tip<-tree$tip.label[ii] else tip<-"" } else if(is.character(tip)&&!is.null(tree)) ii<-which(tree$tip.label==tip) if(hasArg(offset)) offset<-list(...)$offset else offset<-lastPP$label.offset strw<-lastPP$cex*(strwidth(tip)+offset*mean(strwidth(c(LETTERS,letters)))) if(lastPP$direction%in%c("upwards","downwards")) strw<-strw*asp*par()$pin[1]/par()$pin[2] if(hasArg(arrl)) arrl<-list(...)$arrl else { if(lastPP$type=="fan") arrl<-0.3*max(lastPP$xx) else if(lastPP$type=="phylogram") arrl<-0.15*max(lastPP$xx) } if(hasArg(hedl)) hedl<-list(...)$hedl else hedl<-arrl/3 if(hasArg(angle)) angle<-list(...)$angle else angle<-45 arra<-angle*pi/180 if(hasArg(col)) col<-list(...)$col else col<-"black" if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-2 if(lastPP$type=="fan") theta<-atan2(lastPP$yy[ii],lastPP$xx[ii]) else if(lastPP$type=="phylogram"){ if(lastPP$direction=="rightwards") theta<-0 else if(lastPP$direction=="upwards") theta<-pi/2 else if(lastPP$direction=="leftwards") theta<-pi else if(lastPP$direction=="downwards") theta<-3*pi/2 } segments(x0=lastPP$xx[ii]+cos(theta)*(strw+arrl), y0=lastPP$yy[ii]+sin(theta)*(strw+arrl), x1=lastPP$xx[ii]+cos(theta)*strw, y1=lastPP$yy[ii]+sin(theta)*strw, col=col,lwd=lwd,lend="round") segments(x0=lastPP$xx[ii]+cos(theta)*strw+cos(theta+arra/2)*hedl, y0=lastPP$yy[ii]+sin(theta)*strw+sin(theta+arra/2)*hedl*asp, x1=lastPP$xx[ii]+cos(theta)*strw, y1=lastPP$yy[ii]+sin(theta)*strw, col=col,lwd=lwd,lend="round") segments(x0=lastPP$xx[ii]+cos(theta)*strw+cos(theta-arra/2)*hedl, y0=lastPP$yy[ii]+sin(theta)*strw+sin(theta-arra/2)*hedl*asp, x1=lastPP$xx[ii]+cos(theta)*strw, y1=lastPP$yy[ii]+sin(theta)*strw, col=col,lwd=lwd,lend="round") invisible(list(x0=lastPP$xx[ii]+cos(theta)*(strw+arrl), y0=lastPP$yy[ii]+sin(theta)*(strw+arrl), x1=lastPP$xx[ii]+cos(theta)*strw, y1=lastPP$yy[ii]+sin(theta)*strw)) } } ## function to rescale simmap style trees ## written by Liam J. Revell 2012, 2013, 2014, 2015, 2017, 2023 ## S3 Ntip etc. methods for "contMap" object class Ntip.contMap<-function(phy) Ntip(phy$tree) Nnode.contMap<-function(phy,...) Nnode(phy$tree) Nedge.contMap<-function(phy) Nedge(phy$tree) ## S3 Ntip etc. methods for "densityMap" object class Ntip.densityMap<-function(phy) Ntip(phy$tree) Nnode.densityMap<-function(phy,...) Nnode(phy$tree) Nedge.densityMap<-function(phy) Nedge(phy$tree) rescale<-function(x,...) UseMethod("rescale") rescale.default<-function(x,...){ warning(paste( "rescale does not know how to handle objects of class ",class(x),".\n", "if",class(x),"= \"phylo\" load geiger package to rescale.\n")) } rescale.simmap<-function(x, model="depth", ...) rescaleSimmap(x,...) rescale.multiSimmap<-function(x, model="depth", ...) rescaleSimmap(x,...) rescaleSimmap<-function(tree,...){ if(inherits(tree,"multiSimmap")){ cls<-class(tree) trees<-unclass(tree) trees<-lapply(trees,rescaleSimmap,...) class(trees)<-cls return(trees) } else if(inherits(tree,"simmap")){ if(hasArg(lambda)) lambda<-list(...)$lambda else lambda<-1 if(hasArg(totalDepth)) depth<-totalDepth<-list(...)$totalDepth else if(hasArg(depth)) depth<-totalDepth<-list(...)$depth else depth<-totalDepth<-max(nodeHeights(tree)) if(lambda!=1){ e<-lambdaTree(tree,lambda)$edge.length/tree$edge.length tree$edge.length<-tree$edge.length*e tree$maps<-mapply(function(x,y) x*y,tree$maps,e) tree$mapped.edge<-tree$mapped.edge*matrix(rep(e,ncol(tree$mapped.edge)),length(e),ncol(tree$mapped.edge)) } if(depth!=max(nodeHeights(tree))){ h<-max(nodeHeights(tree)) s<-depth/h tree$edge.length<-tree$edge.length*s tree$maps<-lapply(tree$maps,"*",s) tree$mapped.edge<-tree$mapped.edge*s } return(tree) } else message("tree should be an object of class \"simmap\" or \"multiSimmap\"") } ## function to get states at internal nodes from simmap style trees ## written by Liam J. Revell 2013, 2014, 2015, 2021 getStates<-function(tree,type=c("nodes","tips","both")){ type<-type[1] if(inherits(tree,"multiPhylo")){ tree<-unclass(tree) obj<-lapply(tree,getStates,type=type) nn<-names(obj[[1]]) y<-sapply(obj,function(x,n) x[n],n=nn) } else if(inherits(tree,"phylo")){ if(type%in%c("nodes","both")){ a<-setNames(sapply(tree$maps,function(x) names(x)[1]),tree$edge[,1]) a<-a[as.character(Ntip(tree)+1:tree$Nnode)] } if(type%in%c("tips","both")){ b<-setNames(sapply(tree$maps,function(x) names(x)[length(x)]),tree$edge[,2]) b<-setNames(b[as.character(1:Ntip(tree))],tree$tip.label) } y<-if(type=="both") c(a,b) else if(type=="nodes") a else b } else stop("tree should be an object of class \"phylo\" or \"multiPhylo\".") return(y) } ## di2multi & multi2di for "contMap" & "densityMap" object classes di2multi.contMap<-function(phy,...){ phy$tree<-di2multi(phy$tree,...) phy } di2multi.densityMap<-function(phy,...){ phy$tree<-di2multi(phy$tree,...) phy } multi2di.contMap<-function(phy,...){ phy$tree<-multi2di(phy$tree,...) phy } multi2di.densityMap<-function(phy,...){ phy$tree<-multi2di(phy$tree,...) phy } ## multi2di for "simmap" object class multi2di.simmap<-function(phy,...){ obj<-multi2di(as.phylo(phy),...) M<-rbind(matchNodes(obj,phy), matchLabels(obj,phy)) obj$maps<-vector(mode="list",length=nrow(obj$edge)) for(i in 2:nrow(M)){ if(!is.na(M[i,2])){ obj$maps[[which(obj$edge[,2]==M[i,1])]]<- phy$maps[[which(phy$edge[,2]==M[i,2])]] } else { ii<-which(obj$edge[,2]==getParent(obj,M[i,1])) state<-names(obj$maps[[ii]])[length(obj$maps[[ii]])] obj$maps[[which(obj$edge[,2]==M[i,1])]]<- setNames(0,state) } } obj$node.states<-getStates(obj,"nodes") obj$states<-getStates(obj,"tips") obj$mapped.edge<-makeMappedEdge(obj$edge,obj$maps) class(obj)<-c("simmap",class(obj)) obj } ## di2multi & multi2di for "multiSimmap" object class di2multi.multiSimmap<-function(phy,...){ obj<-lapply(phy,di2multi,...) class(obj)<-c("multiSimmap","multiPhylo") obj } multi2di.multiSimmap<-function(phy,...){ obj<-lapply(phy,multi2di,...) class(obj)<-c("multiSimmap","multiPhylo") obj } ## function to rescale a tree according to an EB model ## written by Liam J. Revell 2017 ebTree<-function(tree,r){ if(r!=0){ H<-nodeHeights(tree) e<-(exp(r*H[,2])-exp(r*H[,1]))/r tree$edge.length<-e } tree } ## function to expand clades in a plot by a given factor ## written by Liam J. Revell 2017 expand.clade<-function(tree,node,factor=5){ cw<-reorder(tree) tips<-setNames(rep(1,Ntip(tree)),cw$tip.label) get.tips<-function(node,tree){ dd<-getDescendants(tree,node) tree$tip.label[dd[dd<=Ntip(tree)]] } desc<-unlist(lapply(node,get.tips,tree=cw)) for(i in 2:Ntip(cw)){ tips[i]<-tips[i-1]+ if(names(tips)[i]%in%desc){ 1 } else if(names(tips)[i-1]%in%desc){ 1 } else 1/factor } obj<-list(tree=tree,tips=tips) class(obj)<-"expand.clade" obj } ## S3 print method for the object class "expand.clade" print.expand.clade<-function(x,...){ cat("An object of class \"expand.clade\" consisting of:\n") cat(paste("(1) A phylogenetic tree (x$tree) with",Ntip(x$tree), "tips and\n ",x$tree$Nnode,"internal nodes.\n")) cat("(2) A vector (x$tips) containing the desired tip-spacing.\n\n") } ## S3 plot method for the object class "expand.clade" plot.expand.clade<-function(x,...){ args<-list(...) args$tree<-x$tree args$tips<-x$tips if(inherits(args$tree,"simmap")) do.call(plotSimmap,args) else do.call(plotTree,args) } ## function to add a geological or other temporal legend to a plotted tree ## written by Liam J. Revell 2017, 2019 geo.legend<-function(leg=NULL,colors=NULL,alpha=0.2,...){ if(hasArg(cex)) cex<-list(...)$cex else cex<-par()$cex if(hasArg(plot)) plot<-list(...)$plot else plot<-TRUE if(hasArg(show.lines)) show.lines<-list(...)$show.lines else show.lines<-TRUE obj<-get("last_plot.phylo",envir=.PlotPhyloEnv) if(is.null(colors)){ colors<-setNames(c( rgb(255,242,127,255,maxColorValue=255), rgb(255,230,25,255,maxColorValue=255), rgb(253,154,82,255,maxColorValue=255), rgb(127,198,78,255,maxColorValue=255), rgb(52,178,201,255,maxColorValue=255), rgb(129,43,146,255,maxColorValue=255), rgb(240,64,40,255,maxColorValue=255), rgb(103,165,153,255,maxColorValue=255), rgb(203,140,55,255,maxColorValue=255), rgb(179,225,182,255,maxColorValue=255), rgb(0,146,112,255,maxColorValue=255), rgb(127,160,86,255,maxColorValue=255), rgb(247,67,112,255,maxColorValue=255)), c("Quaternary","Neogene","Paleogene", "Cretaceous","Jurassic","Triassic", "Permian","Carboniferous","Devonian", "Silurian","Ordovician","Cambrian", "Precambrian")) } if(is.null(leg)){ leg<-rbind(c(2.588,0), c(23.03,2.588), c(66.0,23.03), c(145.0,66.0), c(201.3,145.0), c(252.17,201.3), c(298.9,252.17), c(358.9,298.9), c(419.2,358.9), c(443.8,419.2), c(485.4,443.8), c(541.0,485.4), c(4600,541.0)) rownames(leg)<-c("Quaternary","Neogene","Paleogene", "Cretaceous","Jurassic","Triassic", "Permian","Carboniferous","Devonian", "Silurian","Ordovician","Cambrian", "Precambrian") t.max<-max(obj$xx) ii<-which(leg[,2]<=t.max) leg<-leg[ii,] leg[max(ii),1]<-t.max } colors<-sapply(colors,make.transparent,alpha=alpha) if(plot){ y<-c(rep(0,2),rep(par()$usr[4],2)) ylabel<--1/25*obj$Ntip if(obj$direction=="rightwards"){ old.usr<-par()$usr h<-max(obj$xx) new.xlim<-c(h-par()$usr[1],h-par()$usr[2]) par(usr=c(new.xlim,old.usr[3:4])) } else old.usr<-par()$usr for(i in 1:nrow(leg)){ strh<-strheight(rownames(leg)[i]) polygon(c(leg[i,1:2],leg[i,2:1]),y, col=colors[rownames(leg)[i]],border=NA) if(show.lines){ lines(x=rep(leg[i,1],2),y=c(0,par()$usr[4]), lty="dotted",col="grey") lines(x=c(leg[i,1],mean(leg[i,])-0.8*cex* get.asp()*strheight(rownames(leg)[i])), y=c(0,ylabel),lty="dotted",col="grey") lines(x=c(leg[i,2],mean(leg[i,])+0.8*cex* get.asp()*strheight(rownames(leg)[i])), y=c(0,ylabel),lty="dotted",col="grey") lines(x=rep(mean(leg[i,])-0.8*cex* get.asp()*strheight(rownames(leg)[i]),2), y=c(ylabel,par()$usr[3]),lty="dotted",col="grey") lines(x=rep(mean(leg[i,])+0.8*cex* get.asp()*strheight(rownames(leg)[i]),2), y=c(ylabel,par()$usr[3]),lty="dotted",col="grey") } polygon(x=c(leg[i,1], mean(leg[i,])-0.8*cex*get.asp()*strh, mean(leg[i,])-0.8*cex*get.asp()*strh, mean(leg[i,])+0.8*cex*get.asp()*strh, mean(leg[i,])+0.8*cex*get.asp()*strh, leg[i,2]),y=c(0,ylabel,par()$usr[3], par()$usr[3],ylabel,0), col=colors[rownames(leg)[i]],border=NA) strh<-strh*get.asp() text(x=mean(leg[i,])+ if(obj$direction=="leftwards") 0.12*strh else -0.12*strh, y=ylabel,labels=rownames(leg)[i], srt=90,adj=c(1,0.5),cex=cex) } } par(usr=old.usr) object<-list(leg=leg,colors=colors[1:nrow(leg)]) class(object)<-"geo.legend" invisible(object) } print.geo.legend<-function(x,...){ cat("A geological period legend:\n") colnames(x$leg)<-c("start","end") print(data.frame(x$leg,color=x$colors)) cat("\n") } geo.palette<-function(){ colors<-setNames(c( rgb(255,242,127,255,maxColorValue=255), rgb(255,230,25,255,maxColorValue=255), rgb(253,154,82,255,maxColorValue=255), rgb(127,198,78,255,maxColorValue=255), rgb(52,178,201,255,maxColorValue=255), rgb(129,43,146,255,maxColorValue=255), rgb(240,64,40,255,maxColorValue=255), rgb(103,165,153,255,maxColorValue=255), rgb(203,140,55,255,maxColorValue=255), rgb(179,225,182,255,maxColorValue=255), rgb(0,146,112,255,maxColorValue=255), rgb(127,160,86,255,maxColorValue=255), rgb(247,67,112,255,maxColorValue=255)), c("Quaternary","Neogene","Paleogene", "Cretaceous","Jurassic","Triassic", "Permian","Carboniferous","Devonian", "Silurian","Ordovician","Cambrian", "Precambrian")) leg<-rbind(c(2.588,0), c(23.03,2.588), c(66.0,23.03), c(145.0,66.0), c(201.3,145.0), c(252.17,201.3), c(298.9,252.17), c(358.9,298.9), c(419.2,358.9), c(443.8,419.2), c(485.4,443.8), c(541.0,485.4), c(4600,541.0)) rownames(leg)<-c("Quaternary","Neogene","Paleogene", "Cretaceous","Jurassic","Triassic", "Permian","Carboniferous","Devonian", "Silurian","Ordovician","Cambrian", "Precambrian") colnames(leg)<-c("start","end") object<-list(period=leg,cols=colors) class(object)<-"geo.palette" object } print.geo.palette<-function(x,...){ cat("A geological period color palette:\n") print(data.frame(x$period,color=x$cols)) cat("\n") } ## borrowed from mapplots get.asp<-function(){ pin<-par("pin") usr<-par("usr") asp<-(pin[2]/(usr[4]-usr[3]))/(pin[1]/(usr[2]-usr[1])) asp } # round.polygon<-function(x,y,col="transparent"){ ## just space holding for now # } ## draw a box around a clade ## written by Liam J. Revell 2017 cladebox<-function(tree,node,color=NULL,...){ if(is.null(color)) color<-make.transparent("yellow",0.2) obj<-get("last_plot.phylo",envir=.PlotPhyloEnv) h<-max(nodeHeights(tree)) parent<-tree$edge[which(tree$edge[,2]==node),1] x0<-max(c(obj$xx[node]+obj$xx[parent])/2,obj$xx[node]-0.05*h) x1<-obj$x.lim[2] dd<-getDescendants(tree,node) y0<-min(range(obj$yy[dd]))-0.5 y1<-max(range(obj$yy[dd]))+0.5 polygon(c(x0,x1,x1,x0),c(y0,y0,y1,y1),col=color, border=0) } ## draw tip labels as linking lines to text ## written by Liam J. Revell 2017 linklabels<-function(text,tips,link.type=c("bent","curved","straight"), ...){ lastPP<-get("last_plot.phylo",envir=.PlotPhyloEnv) if(!(lastPP$direction%in%c("leftwards","rightwards"))) stop("direction should be \"rightwards\" or \"leftwards\".") if(hasArg(cex)) cex<-list(...)$cex else cex<-1 if(hasArg(col)) col<-list(...)$col else col<-"black" if(hasArg(lty)) lty<-list(...)$lty else lty<-"dashed" if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-1 if(hasArg(link.offset)) link.offset<-list(...)$link.offset else link.offset<-0.1*max(lastPP$xx) if(hasArg(font)) font<-list(...)$font else font<-3 link.type<-link.type[1] xpos<-lastPP$xx[tips]+strwidth("i") ypos<-lastPP$yy[tips] xmax<-rep(max(lastPP$xx),length(tips))+link.offset ylab<-seq(min(lastPP$yy),max(lastPP$yy), by=(max(lastPP$yy)-min(lastPP$yy))/(length(tips)-1)) ylab<-ylab[rank(ypos)] text(xmax,ylab,gsub("_"," ",text),pos=4,font=font,cex=cex, offset=0) if(link.type=="curved"){ for(i in 1:length(tips)) drawCurve(c(xpos[i],xmax[i]),c(ypos[i],ylab[i]), scale=0.01*diff(range(lastPP$xx)),lty=lty, col=col,lwd=lwd) } else if(link.type=="bent"){ tipmax<-max(lastPP$xx) for(i in 1:length(tips)){ ff<-strwidth("W") segments(xpos[i],ypos[i],tipmax+link.offset/2,ypos[i], lty=lty,col=col,lwd=lwd) segments(tipmax+link.offset/2,ypos[i],tipmax+ link.offset/2+ff,ylab[i],lty=lty,col=col,lwd=lwd) segments(tipmax+link.offset/2+ff,ylab[i],xmax[i],ylab[i], lty=lty,col=col,lwd=lwd) } } else if(link.type=="straight") segments(xpos,ypos,xmax,ylab,lty=lty,col=col) } ## function to create curved clade labels for a fan tree ## written by Liam J. Revell 2017, 2022 arc.cladelabels<-function(tree=NULL,text,node=NULL,ln.offset=1.02, lab.offset=1.06,cex=1,orientation="curved",stretch=1,...){ obj<-get("last_plot.phylo",envir=.PlotPhyloEnv) if(obj$type!="fan") stop("method works only for type=\"fan\"") h<-max(sqrt(obj$xx^2+obj$yy^2)) if(hasArg(mark.node)) mark.node<-list(...)$mark.node else mark.node<-TRUE if(hasArg(interactive)) interactive<-list(...)$interactive else { if(is.null(node)) interactive<-TRUE else interactive<-FALSE } if(interactive) node<-getnode() if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-par()$lwd if(hasArg(col)) col<-list(...)$col else col<-par()$col if(hasArg(lend)) lend<-list(...)$lend else lend<-par()$lend if(hasArg(clockwise)) clockwise<-list(...)$clockwise else clockwise<-TRUE if(hasArg(n)) n<-list(...)$n else n<-0.05 if(mark.node) points(obj$xx[node],obj$yy[node],pch=21, bg="red") if(is.null(tree)){ tree<-list(edge=obj$edge,tip.label=1:obj$Ntip, Nnode=obj$Nnode) class(tree)<-"phylo" } d<-getDescendants(tree,node) d<-sort(d[d<=Ntip(tree)]) deg<-atan(obj$yy[d]/obj$xx[d])*180/pi ii<-intersect(which(obj$yy[d]>=0),which(obj$xx[d]<0)) deg[ii]<-180+deg[ii] ii<-intersect(which(obj$yy[d]<0),which(obj$xx[d]<0)) deg[ii]<-180+deg[ii] ii<-intersect(which(obj$yy[d]<0),which(obj$xx[d]>=0)) deg[ii]<-360+deg[ii] draw.arc(x=0,y=0,radius=ln.offset*h,deg1=min(deg), deg2=max(deg),lwd=lwd,col=col,lend=lend,n=n) if(orientation=="curved") arctext(text,radius=lab.offset*h, middle=mean(range(deg*pi/180)),cex=cex, clockwise=clockwise,stretch=stretch) else if(orientation=="horizontal"){ x0<-lab.offset*cos(median(deg)*pi/180)*h y0<-lab.offset*sin(median(deg)*pi/180)*h text(x=x0,y=y0,label=text, adj=c(if(x0>=0) 0 else 1,if(y0>=0) 0 else 1), offset=0,cex=cex) } } ## function to return a node index interactively from a plotted tree ## written by Liam J. Revell 2017 getnode<-function(...){ if(hasArg(env)) env<-list(...)$env else env<-get("last_plot.phylo",envir=.PlotPhyloEnv) if(hasArg(show.pt)) show.pt<-list(...)$show.pt else show.pt<-FALSE xy<-unlist(locator(n=1)) if(show.pt) points(xy[1],xy[2]) d<-sqrt((xy[1]-env$xx)^2+(xy[2]-env$yy)^2) ii<-which(d==min(d))[1] ii } ## function mostly to interactively label nodes by clicking ## written by Liam J. Revell 2017, 2020 labelnodes<-function(text,node=NULL,interactive=TRUE, shape=c("circle","ellipse","rect"),...){ shape<-shape[1] if(hasArg(circle.exp)) circle.exp<-list(...)$circle.exp else circle.exp<-1.3 if(hasArg(rect.exp)) rect.exp<-list(...)$rect.exp else rect.exp<-1.6 if(hasArg(cex)) cex<-list(...)$cex else cex<-1 if(hasArg(bg)) bg<-list(...)$bg else bg<-"white" obj<-get("last_plot.phylo",envir=.PlotPhyloEnv) h<-cex*strheight("A") w<-cex*strwidth(text) rad<-circle.exp*h*diff(par()$usr[1:2])/diff(par()$usr[3:4]) if(is.null(node)){ if(!interactive){ cat("No nodes provided. Setting interactive mode to TRUE.\n") interactive<-TRUE } node<-vector(length=length(text)) } for(i in 1:length(text)){ if(interactive){ cat(paste("Click on the node you would like to label ", text[i],".\n",sep="")) flush.console() ii<-getnode(env=obj) node[i]<-ii } else ii<-node[i] if(shape=="circle") draw.circle(obj$xx[ii],obj$yy[ii],rad,col=bg) else if(shape=="ellipse") draw.ellipse(obj$xx[ii],obj$yy[ii],0.8*w[i],h, col=bg) else if(shape=="rect") rect(xleft=obj$xx[ii]-0.5*rect.exp*w[i], ybottom=obj$yy[ii]-0.5*rect.exp*h, xright=obj$xx[ii]+0.5*rect.exp*w[i], ytop=obj$yy[ii]+0.5*rect.exp*h,col=bg, ljoin=1) text(obj$xx[ii],obj$yy[ii],label=text[i],cex=cex) } invisible(node) } ## convert object of class "birthdeath" into birth & death rates bd<-function(x){ if(!inherits(x,"birthdeath")) stop("x should be an object of class 'birthdeath'") b<-x$para[2]/(1-x$para[1]) d<-b-x$para[2] setNames(c(b,d),c("b","d")) } ## compute AIC weights aic.w<-function(aic){ d.aic<-aic-min(aic) x<-exp(-1/2*d.aic)/sum(exp(-1/2*d.aic)) class(x)<-"aic.w" x } print.aic.w<-function(x,...){ if(hasArg(signif)) signif<-list(...)$signif else signif<-8 print(round(unclass(x),signif)) } ## function to compute all paths towards the tips from a node ## written by Liam J. Revell node.paths<-function(tree,node){ d<-Descendants(tree,node,"children") paths<-as.list(d) while(any(d>Ntip(tree))){ jj<-1 new.paths<-list() for(i in 1:length(paths)){ if(paths[[i]][length(paths[[i]])]<=Ntip(tree)){ new.paths[[jj]]<-paths[[i]] jj<-jj+1 } else { ch<-Descendants(tree,paths[[i]][length(paths[[i]])], "children") for(j in 1:length(ch)){ new.paths[[jj]]<-c(paths[[i]],ch[j]) jj<-jj+1 } } } paths<-new.paths d<-sapply(paths,function(x) x[length(x)]) } paths } ## function to compute a modification of Grafen's edge lengths ## written by Liam J. Revell 2016 modified.Grafen<-function(tree,power=2){ max.np<-function(tree,node){ np<-node.paths(tree,node) if(length(np)>0) max(sapply(np,length)) else 0 } nn<-1:(Ntip(tree)+tree$Nnode) h<-sapply(nn,max.np,tree=tree)+1 h<-(h/max(h))^power edge.length<-vector() for(i in 1:nrow(tree$edge)) edge.length[i]<-diff(h[tree$edge[i,2:1]]) tree$edge.length<-edge.length tree } ## function to compute all rotations ## written by Liam J. Revell 2016 allRotations<-function(tree){ if(!is.binary(tree)){ was.binary<-FALSE if(is.null(tree$edge.length)){ tree<-compute.brlen(tree) had.edge.lengths<-FALSE } else had.edge.lengths<-TRUE tree<-multi2di(tree) } else was.binary<-TRUE nodes<-1:tree$Nnode+Ntip(tree) trees<-vector(mode="list",length=2^length(nodes)) ii<-2 trees[[1]]<-tree for(i in 1:length(nodes)){ N<-ii-1 for(j in 1:N){ trees[[ii]]<-rotate(trees[[j]],nodes[i]) ii<-ii+1 } } trees<-lapply(trees,untangle,"read.tree") if(!was.binary){ trees<-lapply(trees,di2multi) if(!had.edge.lengths) trees<-lapply(trees, function(x){ x$edge.length<-NULL x }) } class(trees)<-"multiPhylo" trees } ## function to rotate a multifurcation in all possible ways ## written by Liam J. Revell 2016 rotate.multi<-function(tree,node){ kids<-Children(tree,node) if(length(kids)>2){ ii<-sapply(kids,function(x,y) which(y==x),y=tree$edge[,2]) jj<-permn(ii) foo<-function(j,i,t){ t$edge[i,]<-t$edge[j,] if(!is.null(t$edge.length)) t$edge.length[i]<-t$edge.length[j] untangle(t,"read.tree") } obj<-lapply(jj[2:length(jj)],foo,i=ii,t=tree) class(obj)<-"multiPhylo" } else obj<-untangle(rotate(tree,node),"read.tree") obj } ## wrapper for bind.tree that takes objects of class "simmap" ## written by Liam J. Revell 2016 bind.tree.simmap<-function(x,y,where="root"){ x<-reorder(x) y<-reorder(y) rootx<-x$edge[1,1] rooty<-y$edge[1,1] xy<-read.tree(text=write.tree(bind.tree(x,y,where))) Mx<-rbind(matchLabels(x,xy),matchNodes(x,xy,"distances")) My<-rbind(matchLabels(y,xy),matchNodes(y,xy,"distances")) if(where!="root"&&where<=Ntip(x)) Mx[which(is.na(Mx[,2])),2]<-findMRCA(xy,y$tip.label) xy$maps<-vector(mode="list",length=nrow(xy$edge)) ix<-sapply(Mx[-which(Mx[,1]==rootx),1], function(x,y) which(y==x),y=x$edge[,2]) ixy<-sapply(Mx[-which(Mx[,1]==rootx),2], function(x,y) which(y==x),y=xy$edge[,2]) xy$maps[ixy]<-x$maps[ix] iy<-sapply(My[-which(My[,1]==rooty),1], function(x,y) which(y==x),y=y$edge[,2]) ixy<-sapply(My[-which(My[,1]==rooty),2], function(x,y) which(y==x),y=xy$edge[,2]) xy$maps[ixy]<-y$maps[iy] xy$mapped.edge<-makeMappedEdge(xy$edge,xy$maps) ns<-c(setNames(getStates(xy,"tips"),1:Ntip(xy)), getStates(xy,"nodes")) xy$node.states<-cbind(ns[as.character(xy$edge[,1])], ns[as.character(xy$edge[,2])]) xy$states<-getStates(xy,"tips") attr(xy,"class")<-c("simmap",class(xy)) xy } ## generic function to convert an object of class "simmap" to "phylo" ## written by Liam J. Revell 2016 as.phylo.simmap<-function(x,...){ x$maps<-NULL x$mapped.edge<-NULL if(!is.null(x$node.states)) x$node.states<-NULL if(!is.null(x$states)) x$states<-NULL if(!is.null(x$Q)) x$Q<-NULL if(!is.null(x$logL)) x$logL<-NULL if(!is.null(attr(x,"map.order"))) attr(x,"map.order")<-NULL class(x)<-setdiff(class(x),"simmap") x } ## generic function to convert an object of class "multiSimmap" to "multiPhylo" ## written by Liam J. Revell 2016 as.multiPhylo.multiSimmap<-function(x,...){ obj<-lapply(x,as.phylo) class(obj)<-setdiff(class(x),"multiSimmap") obj } ## generic function to convert object of class "phylo" to "multiPhylo" ## written by Liam J. Revell 2016 as.multiPhylo.phylo<-function(x,...){ obj<-list(x) class(obj)<-"multiPhylo" obj } as.multiPhylo<-function(x,...){ if (identical(class(x),"multiPhylo")) return(x) UseMethod("as.multiPhylo") } ## get mapped states ## written by Liam J. Revell 2016 mapped.states<-function(tree,...){ if(!(inherits(tree,"simmap")||inherits(tree,"multiSimmap"))) stop("tree should be an object of class \"simmap\" or \"multiSimmap\".") else { if(inherits(tree,"simmap")){ if(!is.null(tree$mapped.edge)) obj<-sort(colnames(tree$mapped.edge)) else obj<-sort(unique(unlist(lapply(tree$maps,function(x) names(x))))) } else if(inherits(tree,"multiSimmap")) { obj<-sapply(tree,mapped.states,...) } } obj } ## match labels between trees (equivalent to matchNodes) ## written by Liam J. Revell 2016 matchLabels<-function(tr1,tr2){ foo<-function(x,y) if(length(obj<-which(y==x))>0) obj else NA M<-cbind(1:Ntip(tr1),sapply(tr1$tip.label,foo,y=tr2$tip.label)) colnames(M)<-c("tr1","tr2") M } ## compute the probability of states changes along edges of the tree ## written by Liam J. Revell 2015 edgeProbs<-function(trees){ if(!inherits(trees,"multiSimmap")) stop("trees should be an object of class \"multiSimmap\".") SS<-sapply(trees,getStates,"tips") states<-sort(unique(as.vector(SS))) m<-length(states) TT<-sapply(states,function(x,y) sapply(y,paste,x,sep="->"), y=states) nn<-c(TT[upper.tri(TT)],TT[lower.tri(TT)]) ## this function computes for a given edge fn<-function(edge,trees,states){ obj<-sapply(trees,function(x,e,s) if(names(x$maps[[e]])[1]== s[1]&&names(x$maps[[e]])[length(x$maps[[e]])]==s[2]) TRUE else FALSE,e=edge,s=states) sum(obj)/length(obj) } edge.probs<-matrix(0,nrow(trees[[1]]$edge),m, dimnames=list(apply(trees[[1]]$edge,1,paste,collapse=","),nn)) k<-1 for(i in 1:m) for(j in 1:m){ if(i!=j){ edge.probs[,k]<-sapply(1:nrow(trees[[1]]$edge),fn, trees=trees,states=states[c(i,j)]) k<-k+1 } } edge.probs<-cbind(edge.probs,1-rowSums(edge.probs)) colnames(edge.probs)[ncol(edge.probs)]<-"no change" edge.probs } ## get a position in the tree interactively ## written by Liam J. Revell 2015, 2016, 2020 get.treepos<-function(message=TRUE,...){ obj<-get("last_plot.phylo",envir=.PlotPhyloEnv) if(obj$type=="phylogram"&&obj$direction=="rightwards"){ if(message){ cat("Click on the tree position you want to capture...\n") flush.console() } if(hasArg(x)) x<-list(...)$x else x<-NULL if(hasArg(y)) y<-list(...)$y else y<-NULL if(is.null(x)||is.null(y)){ x<-unlist(locator(1)) y<-x[2] x<-x[1] } d<-pos<-c() for(i in 1:nrow(obj$edge)){ x0<-obj$xx[obj$edge[i,]] y0<-obj$yy[obj$edge[i,2]] if(xx0[2]){ d[i]<-min(dist(rbind(c(x,y),c(x0[1],y0))), dist(rbind(c(x,y),c(x0[2],y0)))) pos[i]<-if(x>x0[2]) 0 else diff(obj$xx[obj$edge[i,]]) } else { d[i]<-abs(y0-y) pos[i]<-obj$xx[obj$edge[i,2]]-x } } ii<-which(d==min(d)) ## check to make sure the root is not closer: root.d<-dist(rbind(c(x,y),c(obj$xx[obj$Ntip+1],obj$yy[obj$Ntip+1]))) if(root.d0) nc<-nc[ii] xx<-yy<-vector() for(i in 1:length(ii)){ for(j in 1:nc[i]){ ss<-names(tree$maps[[ii[i]]])[j+1] mm<-tree$edge[ii[i],1] dd<-tree$edge[ii[i],2] x<-rep(obj$xx[mm]+cumsum(tree$maps[[ii[i]]])[j],2) y<-c(obj$yy[dd]-0.5*mean(strheight(LETTERS)*cex), obj$yy[dd]+0.5*mean(strheight(LETTERS)*cex)) if(plot) lines(x,y,lwd=lwd,col=colors[ss],lend=2) xx<-c(xx,setNames(x[1], paste(names(tree$maps[[ii[i]]])[j:(j+1)], collapse="->"))) yy<-c(yy,mean(y)) } } XY<-cbind(xx,yy) colnames(XY)<-c("x","y") invisible(XY) } ## function to label clades ## written by Liam J. Revell 2014, 2015, 2022 cladelabels<-function(tree=NULL,text,node,offset=NULL,wing.length=NULL,cex=1, orientation="vertical"){ lastPP<-get("last_plot.phylo",envir=.PlotPhyloEnv) if(is.null(tree)){ if(is.null(wing.length)) wing.length<-1 if(is.null(offset)) offset<-8 tree<-list(edge=lastPP$edge, tip.label=1:lastPP$Ntip, Nnode=lastPP$Nnode) H<-matrix(lastPP$xx[tree$edge],nrow(tree$edge),2) tree$edge.length<-H[,2]-H[,1] class(tree)<-"phylo" } if(is.null(offset)) offset<-0.5 xx<-mapply(labelSubTree,node,text, MoreArgs=list(tree=tree,pp=lastPP,offset=offset,wl=wing.length,cex=cex, orientation=orientation),SIMPLIFY=FALSE) } ## internal function used by cladelabels ## written by Liam J. Revell 2014, 2015, 2022 labelSubTree<-function(tree,nn,label,pp,offset,wl,cex,orientation){ if(is.null(wl)) wl<-1 tree<-reorder(tree) tips<-getDescendants(tree,nn) tips<-tips[tips<=Ntip(tree)] ec<-0.7 ## expansion constant sw<-pp$cex*max(strwidth(tree$tip.label[tips])) sh<-pp$cex*max(strheight(tree$tip.label)) cw<-mean(strwidth(LETTERS)*cex) h<-max(sapply(tips,function(x,tree) nodeHeights(tree)[which(tree$edge[,2]==x),2], tree=tree))+sw+offset*cw y<-range(pp$yy[tips]) lines(c(h,h),y+ec*c(-sh,sh),col=par()$fg) lines(c(h-wl*cw,h), c(y[1]-ec*sh,y[1]-ec*sh),col=par()$fg) lines(c(h-wl*cw,h), c(y[2]+ec*sh,y[2]+ec*sh),col=par()$fg) text(h+cw,mean(y), label,srt=if(orientation=="horizontal") 0 else 90, adj=if(orientation=="horizontal") 0 else 0.5,cex=cex, col=par()$col.lab) list(xx=c(h,h),yy=y+ec*c(-sh,sh)) } ## get all the extant/extinct tip names ## written by Liam J. Revell 2012, 2015 getExtant<-function(tree,tol=1e-8){ if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".") H<-nodeHeights(tree) tl<-max(H) x<-which(H[,2]>=(tl-tol)) y<-tree$edge[x,2] y<-y[y<=Ntip(tree)] z<-tree$tip.label[y] return(z) } getExtinct<-function(tree,tol=1e-8) setdiff(tree$tip.label,getExtant(tree,tol)) # function splits tree at split # written by Liam Revell 2011, 2014, 2015, 2020 splitTree<-function(tree,split){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(split$node>Ntip(tree)){ # first extract the clade given by shift$node tr2<-extract.clade(tree,node=split$node) tr2$root.edge<-tree$edge.length[which(tree$edge[,2]==split$node)]-split$bp #now remove tips in tr2 from tree tr1<-drop.clade(tree,tr2$tip.label) nn<-if(!is.null(tree$node.label)) c(tree$node.label,"NA") else "NA" tr1$tip.label[which(tr1$tip.label%in%nn)]<-"NA" tr1$edge.length[match(which(tr1$tip.label=="NA"),tr1$edge[,2])]<-split$bp } else { # first extract the clade given by shift$node tr2<-list(edge=matrix(c(2L,1L),1,2),tip.label=tree$tip.label[split$node],edge.length=tree$edge.length[which(tree$edge[,2]==split$node)]-split$bp,Nnode=1L) class(tr2)<-"phylo" # now remove tip in tr2 from tree tr1<-tree tr1$edge.length[match(which(tr1$tip.label==tr2$tip.label[1]),tr1$edge[,2])]<-split$bp tr1$tip.label[which(tr1$tip.label==tr2$tip.label[1])]<-"NA" } trees<-list(tr1,tr2) class(trees)<-"multiPhylo" trees } # function drops entire clade # written by Liam Revell 2011, 2015, 2020 drop.clade<-function(tree,tip){ ## step 1, check to make sure tips form a monophyletic clade node<-getMRCA(tree,tip) desc<-getDescendants(tree,node) chk<-tree$tip.label[desc[desc<=Ntip(tree)]] if(!setequal(tip,chk)){ cat("Caution: Species in tip do not form a monophyletic clade.\n") cat(" Pruning all tips descended from ancestor.\n\n") tip<-chk } ## step 2, find all edges in the clade & set them to zero length ee<-sapply(desc,function(node,edge) which(edge==node), edge=tree$edge[,2]) tree$edge.length[ee]<-0 ## step 3, bind a tip labeled "NA" to the node tree<-bind.tip(tree,"NA",0,node) ## step 4, prune the other tips tree<-drop.tip(tree,tip) ## step 5, return tree tree } ## function to re-root a phylogeny along an edge ## written by Liam J. Revell 2011-2016, 2019, 2020 reroot<-function(tree,node.number,position=NULL,interactive=FALSE,...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(interactive){ plotTree(tree,...) cat("Click where you would like re-root the plotted tree\n") flush.console() obj<-get.treepos(message=FALSE) node.number<-obj$where position<-tree$edge.length[which(tree$edge[,2]==node.number)]-obj$pos } if(node.number==(Ntip(tree)+1)) cat("Note: you chose to re-root the tree at it's current root.\n") if(is.null(position)){ if(node.number==(Ntip(tree)+1)) position=0 else position<-tree$edge.length[which(tree$edge[,2]==node.number)] } else { if(node.number==(Ntip(tree)+1)) cat(" A value of position != 0 has been reset to zero.\n") } if(hasArg(edgelabel)) edgelabel<-list(...)$edgelabel else edgelabel<-FALSE if(node.number!=(Ntip(tree)+1)){ tt<-splitTree(tree,list(node=node.number,bp=position)) p<-tt[[1]] d<-tt[[2]] tip<-if(length(which(p$tip.label=="NA"))>0) "NA" else p$tip.label[which(p$tip.label%in%tree$node.label)] p<-ape::root.phylo(p,outgroup=tip,resolve.root=TRUE,edgelabel=edgelabel) bb<-which(p$tip.label==tip) p$tip.label[bb]<-"NA" ee<-p$edge.length[which(p$edge[,2]==bb)] p$edge.length[which(p$edge[,2]==bb)]<-0 cc<-p$edge[which(p$edge[,2]==bb),1] dd<-setdiff(p$edge[which(p$edge[,1]==cc),2],bb) p$edge.length[which(p$edge[,2]==dd)]<-p$edge.length[which(p$edge[,2]==dd)]+ee obj<-paste.tree(p,d) } else obj<-tree if(interactive) plotTree(obj,...) obj } ## function to ladderize phylogeny with mapped discrete character ## written by Liam J. Revell 2014, 2015, 2019, 2023 ladderize.simmap<-function(tree,right=TRUE){ if(!inherits(tree,"simmap")){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") else { cat("Do not detect a mapped character. Using ape::ladderize.\n") obj<-ladderize(tree,right=right) } } else { obj<-read.tree(text=write.tree(ladderize(tree,right=right))) rN<-Ntip(obj)+1 T<-cbind(1:Ntip(obj),sapply(obj$tip.label, function(x,y) which(y==x),y=tree$tip.label)) N<-matchNodes(obj,as.phylo(tree)) M<-rbind(T,N[N[,1]!=rN,]) ii<-sapply(M[,1],function(x,y) which(y==x),y=obj$edge[,2]) jj<-sapply(M[,2],function(x,y) which(y==x),y=tree$edge[,2]) obj$maps<-vector(length=nrow(tree$edge),mode="list") obj$mapped.edge<-matrix(NA,nrow(tree$edge),ncol(tree$mapped.edge), dimnames=list(apply(tree$edge,1,paste,collapse=","), colnames(tree$mapped.edge))) if(!is.null(tree$states)) obj$states<-tree$states[sapply(obj$tip.label, function(x,y) which(y==x),y=tree$tip.label)] if(!is.null(tree$node.states)) obj$node.states<-matrix(NA,nrow(tree$edge),2) for(i in 1:length(ii)){ obj$maps[[ii[i]]]<-tree$maps[[jj[i]]] obj$mapped.edge[ii[i],]<-tree$mapped.edge[jj[i],] if(!is.null(tree$node.states)) obj$node.states[ii[i],]<- tree$node.states[jj[i],] } class(obj)<-c("simmap","phylo") } obj } ## for backward compatibility repPhylo<-function(tree,times) rep(tree,times) ## S3 method rep for objects of class "phylo" and "multiPhylo" ## written by Liam J. Revell 2014, 2021 rep.phylo<-function(x,...){ if(hasArg(times)) times<-list(...)$times else times<-(...)[[1]] for(i in 1:times) obj<-if(i==1) x else if(i==2) c(obj,x) else c(unclass(obj),list(x)) class(obj)<-"multiPhylo" obj } rep.multiPhylo<-function(x,...){ if(hasArg(times)) times<-list(...)$times else times<-(...)[[1]] for(i in 1:times) obj<-if(i==1) x else if(i>=2) c(obj,x) class(obj)<-"multiPhylo" obj } ## function to drop one or more tips from a tree but retain all ancestral nodes as singletons ## written by Liam J. Revell 2014, 2015, 2023 drop.tip.singleton<-function(phy,tip,...){ if(!inherits(phy,"singleton")&&!inherits(phy,"phylo")) stop("phy should be an object of class \"singleton\".") N<-Ntip(phy) m<-length(tip) ii<-sapply(tip,function(x,y) which(y==x),y=phy$tip.label) phy$tip.label<-phy$tip.label[-ii] ii<-sapply(ii,function(x,y) which(y==x),y=phy$edge[,2]) phy$edge<-phy$edge[-ii,] phy$edge.length<-phy$edge.length[-ii] phy$edge[phy$edge<=N]<-as.integer(rank(phy$edge[phy$edge<=N])) phy$edge[phy$edge>N]<-phy$edge[phy$edge>N]-m N<-N-m if(any(sapply(phy$edge[phy$edge[,2]>N,2],"%in%",phy$edge[,1])==FALSE)) internal<-TRUE else internal<-FALSE while(internal){ ii<-which(sapply(phy$edge[,2],"%in%",c(1:N,phy$edge[,1]))==FALSE)[1] nn<-phy$edge[ii,2] phy$edge<-phy$edge[-ii,] phy$edge.length<-phy$edge.length[-ii] phy$edge[phy$edge>nn]<-phy$edge[phy$edge>nn]-1 phy$Nnode<-phy$Nnode-length(ii) if(any(sapply(phy$edge[phy$edge[,2]>N,2],"%in%",phy$edge[,1])==FALSE)) internal<-TRUE else internal<-FALSE } class(phy)<-union("singleton",class(phy)) phy } ## S3 print method for object of class 'describe.simmap' ## written by Liam J. Revell 2014, 2015 print.describe.simmap<-function(x,...){ if(inherits(x$tree,"multiPhylo")){ cat(paste(length(x$tree),"trees with a mapped discrete character with states:\n",paste(colnames(x$ace),collapse=", "),"\n\n")) cat(paste("trees have",colMeans(x$count)["N"],"changes between states on average\n\n")) cat(paste("changes are of the following types:\n")) aa<-t(as.matrix(colMeans(x$count)[2:ncol(x$count)])) rownames(aa)<-"x->y" print(aa) cat(paste("\nmean total time spent in each state is:\n")) print(matrix(c(colMeans(x$times),colMeans(x$times[,1:ncol(x$times)]/x$times[,ncol(x$times)])),2,ncol(x$times),byrow=TRUE, dimnames=list(c("raw","prop"),c(colnames(x$times))))) cat("\n") } else if(inherits(x$tree,"phylo")){ cat(paste("1 tree with a mapped discrete character with states:\n",paste(colnames(x$Tr),collapse=", "),"\n\n")) cat(paste("tree has",x$N,"changes between states\n\n")) cat(paste("changes are of the following types:\n")) print(x$Tr) cat(paste("\nmean total time spent in each state is:\n")) print(x$times) cat("\n") } } ## S3 plot method for object of class 'describe.simmap' ## written by Liam J. Revell 2014, 2015, 2020 plot.describe.simmap<-function(x,...){ if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-2 if(hasArg(cex)) cex<-list(...)$cex else cex<-c(0.6,0.4) if(length(cex)==1) cex<-rep(cex,2) if(hasArg(type)) type<-list(...)$type else type<-"phylogram" if(hasArg(offset)) offset<-list(...)$offset else offset<-0 if(hasArg(fsize)) fsize<-list(...)$fsize else fsize<-1 if(inherits(x$tree,"multiPhylo")){ states<-colnames(x$ace) if(hasArg(colors)) colors<-list(...)$colors else colors<-setNames(palette()[1:length(states)],states) plotTree(if(is.null(x$ref.tree)) x$tree[[1]] else x$ref.tree,lwd=lwd, offset=cex[2]+offset*fsize,...) nodelabels(pie=x$ace,piecol=colors[colnames(x$ace)],cex=cex[1]) if(!is.null(x$tips)) tips<-x$tips else tips<-to.matrix(getStates(x$tree[[1]],"tips"),seq=states) tiplabels(pie=tips[if(is.null(x$ref.tree)) x$tree[[1]]$tip.label else x$ref.tree$tip.label,],piecol=colors[colnames(tips)],cex=cex[2]) } else if(inherits(x$tree,"phylo")){ states<-colnames(x$Tr) if(hasArg(colors)) colors<-list(...)$colors else colors<-setNames(palette()[1:length(states)],states) plotSimmap(x$tree,lwd=lwd,colors=colors,type=type,offset=offset) } } ## function finds the height of a given node ## written by Liam Revell 2014, 2015, 2016 nodeheight<-function(tree,node,...){ if(hasArg(root.edge)) root.edge<-list(...)$root.edge else root.edge<-FALSE if(root.edge) ROOT<-if(!is.null(tree$root.edge)) tree$root.edge else 0 else ROOT<-0 if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(node==(Ntip(tree)+1)) h<-0 else { a<-setdiff(c(getAncestors(tree,node),node),Ntip(tree)+1) h<-sum(tree$edge.length[sapply(a,function(x,e) which(e==x),e=tree$edge[,2])]) } h+ROOT } # fast pairwise MRCA function # written by Liam Revell 2012, 2014, 2015 fastMRCA<-function(tree,sp1,sp2){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") x<-match(sp1,tree$tip.label) y<-match(sp2,tree$tip.label) a<-c(x,getAncestors(tree,x)) b<-c(y,getAncestors(tree,y)) z<-a%in%b return(a[min(which(z))]) } ## function to find the height of the MRCA of sp1 & sp2 ## written by Liam J. Revell 2014, 2015 fastHeight<-function(tree,sp1,sp2){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(is.null(tree$edge.length)) stop("tree should have edge lengths.") sp1<-which(tree$tip.label==sp1) sp2<-which(tree$tip.label==sp2) a1<-c(sp1,getAncestors(tree,sp1)) a2<-c(sp2,getAncestors(tree,sp2)) a12<-intersect(a1,a2) if(length(a12)>1){ a12<-a12[2:length(a12)-1] h<-sapply(a12,function(i,tree) tree$edge.length[which(tree$edge[,2]==i)],tree=tree) return(sum(h)) } else return(0) } ## function gets ancestor node numbers, to be used internally by ## written by Liam J. Revell 2014 getAncestors<-function(tree,node,type=c("all","parent")){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") type<-type[1] if(type=="all"){ aa<-vector() rt<-Ntip(tree)+1 currnode<-node while(currnode!=rt){ currnode<-getAncestors(tree,currnode,"parent") aa<-c(aa,currnode) } return(aa) } else if(type=="parent"){ aa<-tree$edge[which(tree$edge[,2]==node),1] return(aa) } else stop("do not recognize type") } ## function for midpoint rooting ## written by Liam J. Revell 2014 ## (being deprecated out in 2023) midpoint_root<-function(tree){ D<-cophenetic(tree) dd<-max(D) ii<-which(D==dd)[1] ii<-c(ceiling(ii/nrow(D)),ii%%nrow(D)) if(ii[2]==0) ii[2]<-nrow(D) spp<-rownames(D)[ii] nn<-which(tree$tip.label==spp[2]) tree<-reroot(tree,nn,tree$edge.length[which(tree$edge[,2]==nn)]) aa<-getAncestors(tree,which(tree$tip.label==spp[1])) D<-c(0,dist.nodes(tree)[which(tree$tip.label==spp[1]),aa]) names(D)[1]<-which(tree$tip.label==spp[1]) i<-0 while(D[i+1]<(dd/2)) i<-i+1 tree<-reroot(tree,as.numeric(names(D)[i]),D[i+1]-dd/2) tree } midpoint.root<-function(tree,node.labels="support",...) phangorn::midpoint(tree,node.labels="support",...) # function computes phylogenetic variance-covariance matrix, including for internal nodes # written by Liam J. Revell 2011, 2013, 2014, 2015 vcvPhylo<-function(tree,anc.nodes=TRUE,...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") # get & set optional arguments if(hasArg(internal)) internal<-list(...)$internal else internal<-anc.nodes if(internal!=anc.nodes){ message(paste("arguments \"internal\" and \"anc.nodes\" are synonyms; setting internal =",anc.nodes)) internal<-anc.nodes } if(hasArg(model)) model<-list(...)$model else model<-"BM" if(hasArg(tol)) tol<-list(...)$tol else tol<-1e-12 if(model=="OU"){ if(hasArg(alpha)) alpha<-list(...)$alpha else alpha<-0 } if(model=="OU"&&alphaNtip(tree)) H1<-nodeHeights(tree) tree$edge.length[ii]<-lambda*tree$edge.length[ii] H2<-nodeHeights(tree) tree$edge.length[-ii]<-tree$edge.length[-ii]+ H1[-ii,2]-H2[-ii,2] tree } ## di2multi method for tree with mapped state ## written by Liam J. Revell 2013, 2015, 2016 di2multi.simmap<-function(phy,...){ if(hasArg(tol)) tol<-list(...)$tol else tol<-1e-08 if(!inherits(phy,"phylo")) stop("tree should be an object of class \"phylo\".") if(is.null(phy$maps)){ cat("Warning: tree does not contain mapped state. Using di2multi.\n") return(di2multi(phy,tol)) } N<-length(phy$tip.label) n<-length(intersect(which(phy$edge.lengthN))) if(n==0) return(phy) edge<-phy$edge edge[edge>N]<--edge[edge>N]+N edge.length<-phy$edge.length maps<-phy$maps Nnode<-phy$Nnode for(i in 1:n){ ii<-intersect(which(edge.lengthn]<--edge[edge>n]+n ii<-which(edge[,2]>0) edge<-edge[-ii,] if(!is.null(tree$edge.length)){ edge.length<-tree$edge.length edge.length<-edge.length[-ii] } zz<-sapply(edge[,2],function(x,y) !(x%in%y),y=edge[,1]) if(is.null(tree$node.label)) tree$node.label<-1:tree$Nnode+n nn<-matrix(tree$node.label[-edge],nrow(edge),ncol(edge)) tip.label<-nn[zz,2] node.label<-c(nn[1,1],nn[!zz,2]) edge[zz,2]<-1:sum(zz) Nnode<-length(unique(edge[edge<0])) rr<-cbind(sort(unique(edge[edge<0]),decreasing=TRUE),1:Nnode+sum(zz)) for(i in 1:nrow(rr)) edge[edge==rr[i,1]]<-rr[i,2] tt<-list(edge=edge,Nnode=Nnode,tip.label=tip.label,edge.length=edge.length,node.label=node.label) class(tt)<-"phylo" tt<-collapse.singles(tt) if(keep.tip.labels){ for(i in 1:length(tt$tip.label)){ yy<-getDescendants(tree,node=which(tree$node.label==tt$tip.label[i])+n) tt$tip.label[i]<-paste(tree$tip.label[yy[yy<=n]],collapse=",") } } return(tt) } # function rounds the branch lengths of the tree & applies rounding to simmap tree # written by Liam J. Revell 2012, 2013, 2015 roundBranches<-function(tree,digits=0){ if(inherits(tree,"multiPhylo")){ trees<-lapply(tree,roundBranches,digits=digits) class(trees)<-"multiPhylo" return(trees) } else if(inherits(tree,"phylo")) { tree$edge.length<-round(tree$edge.length,digits) if(!is.null(tree$maps)){ for(i in 1:nrow(tree$edge)){ temp<-tree$maps[[i]]/sum(tree$maps[[i]]) tree$maps[[i]]<-temp*tree$edge.length[i] } } if(!is.null(tree$mapped.edge)){ a<-vector() for(i in 1:nrow(tree$edge)) a<-c(a,names(tree$maps[[i]])) a<-unique(a) tree$mapped.edge<-matrix(data=0,length(tree$edge.length),length(a),dimnames=list(apply(tree$edge,1,function(x) paste(x,collapse=",")),state=a)) for(i in 1:length(tree$maps)) for(j in 1:length(tree$maps[[i]])) tree$mapped.edge[i,names(tree$maps[[i]])[j]]<-tree$mapped.edge[i,names(tree$maps[[i]])[j]]+tree$maps[[i]][j] } return(tree) } else stop("tree should be an object of class \"phylo\" or \"multiPhylo\".") } # function to merge mapped states # written by Liam J. Revell 2013, 2015, 2019 mergeMappedStates<-function(tree,old.states,new.state){ if(inherits(tree,"multiSimmap")){ tree<-unclass(tree) tree<-lapply(tree,mergeMappedStates,old.states=old.states,new.state=new.state) class(tree)<-c("multiSimmap","multiPhylo") } else if(inherits(tree,"simmap")) { maps<-tree$maps rr<-function(map,oo,nn){ for(i in 1:length(map)) if(names(map)[i]%in%oo) names(map)[i]<-nn map } mm<-function(map){ if(length(map)>1){ new.map<-vector() j<-1 new.map[j]<-map[1] names(new.map)[j]<-names(map)[1] for(i in 2:length(map)){ if(names(map)[i]==names(map)[i-1]){ new.map[j]<-map[i]+new.map[j] names(new.map)[j]<-names(map)[i] } else { j<-j+1 new.map[j]<-map[i] names(new.map)[j]<-names(map)[i] } } map<-new.map } map } maps<-lapply(maps,rr,oo=old.states,nn=new.state) if(length(old.states)>1){ maps<-lapply(maps,mm) mapped.edge<-tree$mapped.edge mapped.edge<-cbind(rowSums(mapped.edge[,colnames(mapped.edge)%in%old.states]), mapped.edge[,setdiff(colnames(mapped.edge),old.states)]) colnames(mapped.edge)<-c(new.state,setdiff(colnames(tree$mapped.edge),old.states)) } else { mapped.edge<-tree$mapped.edge colnames(mapped.edge)[which(colnames(mapped.edge)==old.states)]<-new.state } tree$maps<-maps tree$mapped.edge<-mapped.edge } else stop("tree should be an object of class \"simmap\" or \"multiSimmap\".") return(tree) } # function rotates a node or multiple nodes # written by Liam J. Revell 2013, 2015 rotateNodes<-function(tree,nodes,polytom=c(1,2),...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") n<-Ntip(tree) if(nodes[1]=="all") nodes<-1:tree$Nnode+n for(i in 1:length(nodes)) tree<-rotate(tree,nodes[i],polytom) if(hasArg(reversible)) reversible<-list(...)$reversible else reversible<-TRUE if(reversible){ ii<-which(tree$edge[,2]<=n) jj<-tree$edge[ii,2] tree$edge[ii,2]<-1:n tree$tip.label<-tree$tip.label[jj] } return(tree) } # function simulates random sampling from xbar, xvar, with sample sizes n # written by Liam J. Revell 2012 sampleFrom<-function(xbar=0,xvar=1,n=1,randn=NULL,type="norm"){ if(length(xvar)==1&&length(xbar)!=length(xvar)) xvar<-rep(xvar,length(xbar)) if(!is.null(randn)) for(i in 1:length(xbar)) n[i]<-floor(runif(n=1,min=randn[1],max=(randn[2]+1))) x<-vector() for(i in 1:length(xbar)){ y<-rnorm(n=n[i],mean=xbar[i],sd=sqrt(xvar[i])) names(y)<-rep(names(xbar)[i],length(y)) x<-c(x,y) } return(x) } # function adds a new tip to the tree # written by Liam J. Revell 2012, 2013, 2014, 2015 bind.tip<-function(tree,tip.label,edge.length=NULL,where=NULL,position=0,interactive=FALSE,...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") use.edge.length<-if(is.null(tree$edge.length)) FALSE else TRUE if(use.edge.length==FALSE) tree<-compute.brlen(tree) if(interactive==TRUE){ plotTree(tree,...) cat(paste("Click where you would like to bind the tip \"",tip.label,"\"\n",sep="")) flush.console() obj<-get.treepos(message=FALSE) where<-obj$where position<-obj$pos } else if(is.null(where)) where<-Ntip(tree)+1 if(where<=Ntip(tree)&&position==0){ pp<-1e-12 if(tree$edge.length[which(tree$edge[,2]==where)]<=1e-12){ tree$edge.length[which(tree$edge[,2]==where)]<-2e-12 ff<-TRUE } else ff<-FALSE } else pp<-position if(is.null(edge.length)&&is.ultrametric(tree)){ H<-nodeHeights(tree) if(where==(Ntip(tree)+1)) edge.length<-max(H) else edge.length<-max(H)-H[tree$edge[,2]==where,2]+position } tip<-list(edge=matrix(c(2,1),1,2), tip.label=tip.label, edge.length=edge.length, Nnode=1) class(tip)<-"phylo" obj<-bind.tree(tree,tip,where=where,position=pp) if(where<=Ntip(tree)&&position==0){ nn<-obj$edge[which(obj$edge[,2]==which(obj$tip.label==tip$tip.label)),1] obj$edge.length[which(obj$edge[,2]==nn)]<-obj$edge.length[which(obj$edge[,2]==nn)]+1e-12 obj$edge.length[which(obj$edge[,2]==which(obj$tip.label==tip$tip.label))]<-0 obj$edge.length[which(obj$edge[,2]==which(obj$tip.label==tree$tip.label[where]))]<-0 } root.time<-if(!is.null(obj$root.time)) obj$root.time else NULL obj<-untangle(obj,"read.tree") if(!is.null(root.time)) obj$root.time<-root.time if(interactive) plotTree(obj,...) if(!use.edge.length) obj$edge.length<-NULL obj } ## function collapses the subtree descended from node to a star tree ## written by Liam J. Revell 2013, 2015, 2019 collapse.to.star<-function(tree,node){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(node==(Ntip(tree)+1)){ object<-list(edge=cbind(rep(Ntip(tree)+1,Ntip(tree)),1:Ntip(tree)), tip.label=tree$tip.label,Nnode=1) if(!is.null(tree$edge.length)) object$edge.length<-sapply(1:Ntip(tree),nodeheight,tree=tree) class(object)<-"phylo" tree<-object } else { nel<-if(is.null(tree$edge.length)) TRUE else FALSE if(nel) tree$edge.length<-rep(1,nrow(tree$edge)) tt<-splitTree(tree,split=list(node=node, bp=tree$edge.length[which(tree$edge[,2]==node)])) ss<-starTree(species=tt[[2]]$tip.label, branch.lengths=diag(vcv(tt[[2]]))) ss$root.edge<-0 tree<-paste.tree(tt[[1]],ss) if(nel) tree$edge.length<-NULL } tree } ## function returns the MRCA, or its height above the root, for a set of taxa (in tips) ## written by Liam Revell 2012, 2013, 2015, 2016 findMRCA<-function(tree,tips=NULL,type=c("node","height")){ type<-type[1] if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(is.null(tips)){ X<-mrca(tree) if(type=="height"){ H<-nodeHeights(tree) X<-apply(X,c(1,2),function(x,y,z) y[which(z==x)[1]],y=H,z=tree$edge) } return(X) } else { node<-getMRCA(tree,tips) if (type == "node") return(node) else if(type=="height") return(nodeheight(tree,node)) } } # function works like extract.clade in ape but will preserve a discrete character mapping # written by Liam J. Revell 2013 extract.clade.simmap<-function(tree,node){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") x<-getDescendants(tree,node) x<-x[x<=Ntip(tree)] drop.tip.simmap(tree,tree$tip.label[-x]) } # function gets all subtrees that cannot be further subdivided into two clades of >= clade.size # written by Liam J. Revell 2013, 2015 getCladesofSize<-function(tree,clade.size=2){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") n<-Ntip(tree) nn<-1:(tree$Nnode+n) ndesc<-function(tree,node){ x<-getDescendants(tree,node) sum(x<=Ntip(tree)) } dd<-setNames(sapply(nn,ndesc,tree=tree),nn) aa<-n+1 # root nodes<-vector() while(length(aa)){ bb<-lapply(aa,function(x,tree) tree$edge[which(tree$edge[,1]==x),2],tree=tree) cc<-lapply(bb,function(x) dd[as.character(x)]) gg<-sapply(cc,function(x,cs) any(xy"))) } else if(inherits(tree,"phylo")) { n<-sum(sapply(tree$maps,length))-nrow(tree$edge) if(is.null(states)) states<-colnames(tree$mapped.edge) m<-length(states) TT<-matrix(NA,m,m,dimnames=list(states,states)) gg<-function(map,a,b){ if(length(map)==1) zz<-0 else { zz<-0; i<-2 while(i<=length(map)){ if(names(map)[i]==b&&names(map)[i-1]==a) zz<-zz+1 i<-i+1 } } return(zz) } for(i in 1:m) for(j in 1:m) if(i==j) TT[i,j]<-0 else TT[i,j]<-sum(sapply(tree$maps,gg,a=states[i],b=states[j])) if(!message) return(list(N=n,Tr=TT)) else return(list(N=n,Tr=TT,message=c( "N is the total number of character changes on the tree", "Tr gives the number of transitions from row state->column state"))) } } # function to match nodes between trees # written by Liam J. Revell 2012, 2013, 2015 matchNodes<-function(tr1,tr2,method=c("descendants","distances"),...){ if(!inherits(tr1,"phylo")||!inherits(tr1,"phylo")) stop("tr1 & tr2 should both be objects of class \"phylo\".") if(hasArg(quiet)) quiet<-list(...)$quiet else quiet<-FALSE method<-method[1] method<-matchType(method,c("descendants","distances")) if(method=="descendants"){ desc.tr1<-lapply(1:tr1$Nnode+length(tr1$tip),function(x) extract.clade(tr1,x)$tip.label) names(desc.tr1)<-1:tr1$Nnode+length(tr1$tip) desc.tr2<-lapply(1:tr2$Nnode+length(tr2$tip),function(x) extract.clade(tr2,x)$tip.label) names(desc.tr2)<-1:tr2$Nnode+length(tr2$tip) Nodes<-matrix(NA,length(desc.tr1),2,dimnames=list(NULL,c("tr1","tr2"))) for(i in 1:length(desc.tr1)){ Nodes[i,1]<-as.numeric(names(desc.tr1)[i]) for(j in 1:length(desc.tr2)) if(all(desc.tr1[[i]]%in%desc.tr2[[j]])&&all(desc.tr2[[j]]%in%desc.tr1[[i]])) Nodes[i,2]<-as.numeric(names(desc.tr2)[j]) } } else if(method=="distances"){ if(hasArg(tol)) tol<-list(...)$tol else tol<-1e-6 if(hasArg(corr)) corr<-list(...)$corr else corr<-FALSE if(corr) tr1$edge.length<-tr1$edge.length/max(nodeHeights(tr1)) if(corr) tr2$edge.length<-tr2$edge.length/max(nodeHeights(tr2)) D1<-dist.nodes(tr1)[1:length(tr1$tip),1:tr1$Nnode+length(tr1$tip)] D2<-dist.nodes(tr2)[1:length(tr2$tip),1:tr2$Nnode+length(tr2$tip)] rownames(D1)<-tr1$tip.label rownames(D2)<-tr2$tip.label common.tips<-intersect(tr1$tip.label,tr2$tip.label) D1<-D1[common.tips,] D2<-D2[common.tips,] Nodes<-matrix(NA,tr1$Nnode,2,dimnames=list(NULL,c("tr1","tr2"))) for(i in 1:tr1$Nnode){ if(corr) z<-apply(D2,2,function(X,y) cor(X,y),y=D1[,i]) else z<-apply(D2,2,function(X,y) 1-sum(abs(X-y)),y=D1[,i]) Nodes[i,1]<-as.numeric(colnames(D1)[i]) if(any(z>=(1-tol))){ a<-as.numeric(names(which(z>=(1-tol)))) if(length(a)==1) Nodes[i,2]<-a else { Nodes[i,2]<-a[1] if(!quiet) warning("polytomy detected; some node matches may be arbitrary") } } } } return(Nodes) } # function applies the branch lengths of a reference tree to a second tree, including mappings # written by Liam J. Revell 2012, 2015 applyBranchLengths<-function(tree,edge.length){ if(inherits(tree,"multiPhylo")){ trees<-lapply(tree,applyBranchLengths,edge.length=edge.length) class(trees)<-"multiPhylo" return(trees) } else if(inherits(tree,"phylo")) { tree$edge.length<-edge.length if(!is.null(tree$maps)){ for(i in 1:nrow(tree$edge)){ temp<-tree$maps[[i]]/sum(tree$maps[[i]]) tree$maps[[i]]<-temp*tree$edge.length[i] } } if(!is.null(tree$mapped.edge)){ a<-vector() for(i in 1:nrow(tree$edge)) a<-c(a,names(tree$maps[[i]])) a<-unique(a) tree$mapped.edge<-matrix(data=0,length(tree$edge.length),length(a),dimnames=list(apply(tree$edge,1,function(x) paste(x,collapse=",")),state=a)) for(i in 1:length(tree$maps)) for(j in 1:length(tree$maps[[i]])) tree$mapped.edge[i,names(tree$maps[[i]])[j]]<-tree$mapped.edge[i,names(tree$maps[[i]])[j]]+tree$maps[[i]][j] } return(tree) } } # function to compute phylogenetic VCV using joint Pagel's lambda # written by Liam Revell 2011, 2024 phyl.vcv<-function(X,C,lambda){ if(!is.null(rownames(X))) C<-C[rownames(X),rownames(X)] ## sort by rownames of X (if present) C<-lambda.transform(lambda,C) invC<-solve(C) a<-matrix(colSums(invC%*%X)/sum(invC),ncol(X),1) A<-matrix(rep(a,nrow(X)),nrow(X),ncol(X),byrow=T) V<-t(X-A)%*%invC%*%(X-A)/(nrow(C)-1) return(list(C=C,R=V,alpha=a)) } # lambda transformation of C # written by Liam Revell 2011 lambda.transform<-function(lambda,C){ if(lambda==1) return(C) else { V<-diag(diag(C)) C<-C-V C.lambda<-(V+lambda*C) return(C.lambda) } } # likelihood function for joint estimation of lambda for multiple traits # written by Liam Revell 2011/2012 likMlambda<-function(lambda,X,C){ # compute R, conditioned on lambda temp<-phyl.vcv(X,C,lambda); C<-temp$C; R<-temp$R; a<-temp$alpha # prep n<-nrow(X); m<-ncol(X); D<-matrix(0,n*m,m) for(i in 1:(n*m)) for(j in 1:m) if((j-1)*n1) if(length(intersect(states,ordering))n)) result$nodes<-sisters[which(sisters>n)] else if(any(sisters>n)) result$nodes<-tree$node.label[sisters[which(sisters>n)]-n] if(any(sisters<=n)) result$tips<-tree$tip.label[sisters[which(sisters<=n)]] return(result) } } # gets descendant node numbers # written by Liam Revell 2012, 2013, 2014 getDescendants<-function(tree,node,curr=NULL){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(is.null(curr)) curr<-vector() daughters<-tree$edge[which(tree$edge[,1]==node),2] curr<-c(curr,daughters) if(length(curr)==0&&node<=Ntip(tree)) curr<-node w<-which(daughters>Ntip(tree)) if(length(w)>0) for(i in 1:length(w)) curr<-getDescendants(tree,daughters[w[i]],curr) return(curr) } # function computes vcv for each state, and stores in array # written by Liam J. Revell 2011, 2012, 2016 multiC<-function(tree,internal=FALSE){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(!inherits(tree,"simmap")) stop("tree should be an object of class \"simmap\".") m<-ncol(tree$mapped.edge) # compute separate C for each state mC<-list() for(i in 1:m){ mtree<-list(edge=tree$edge, Nnode=tree$Nnode, tip.label=tree$tip.label, edge.length=tree$mapped.edge[,i]) class(mtree)<-"phylo" mC[[i]]<-if(internal) vcvPhylo(mtree,internal=TRUE) else vcv.phylo(mtree) } names(mC)<-colnames(tree$mapped.edge) mC } # function pastes subtree onto tip # written by Liam Revell 2011, 2015 paste.tree<-function(tr1,tr2){ if(!inherits(tr1,"phylo")||!inherits(tr2,"phylo")) stop("tr1 & tr2 should be objects of class \"phylo\".") if(length(tr2$tip)>1){ temp<-tr2$root.edge; tr2$root.edge<-NULL tr1$edge.length[match(which(tr1$tip.label=="NA"),tr1$edge[,2])]<-tr1$edge.length[match(which(tr1$tip.label=="NA"),tr1$edge[,2])]+temp } tr.bound<-bind.tree(tr1,tr2,where=which(tr1$tip.label=="NA")) return(tr.bound) } # match type # written by Liam J. Revell 2012 matchType<-function(type,types){ for(i in 1:length(types)) if(all(strsplit(type,split="")[[1]]==strsplit(types[i],split="")[[1]][1:length(strsplit(type,split="")[[1]])])) type=types[i] return(type) } ## function 'untangles' (or attempts to untangle) a tree with crossing branches ## written by Liam J. Revell 2013, 2015, 2020, 2021 untangle<-function(tree,method=c("reorder","read.tree")){ if(inherits(tree,"multiPhylo")){ tree<-lapply(tree,untangle,method=method) class(tree)<-"multiPhylo" } else { if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") obj<-attributes(tree) method<-method[1] if(method=="reorder") tree<-reorder(reorder(tree,"pruningwise")) else if(method=="read.tree"){ tip.label<-tree$tip.label tree$tip.label<-1:Ntip(tree) if(inherits(tree,"simmap")) tree<-read.simmap(text=capture.output(write.simmap(tree,file=stdout()))) else tree<-if(Ntip(tree)>1) read.tree(text=write.tree(tree)) else read.newick(text=write.tree(tree)) tree$tip.label<-tip.label[as.numeric(tree$tip.label)] } ii<-!names(obj)%in%names(attributes(tree)) attributes(tree)<-c(attributes(tree),obj[ii]) } tree } phytools/R/paintSubTree.R0000644000176200001440000000636314375517350015106 0ustar liggesusers## paint branch(es) ## written by Liam J. Revell 2014, 2015 paintBranches<-function(tree,edge,state,anc.state="1"){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(is.null(tree$maps)) maps<-lapply(tree$edge.length,function(x) setNames(x,anc.state)) else maps<-tree$maps ii<-sapply(edge,function(x,y) which(y==x),y=tree$edge[,2]) for(i in 1:length(ii)) maps[[ii[i]]]<-setNames(tree$edge.length[[ii[i]]],state) ## build mapped.edge matrix s<-vector() for(i in 1:nrow(tree$edge)) s<-c(s,names(maps[[i]])) s<-unique(s) mapped.edge<-matrix(0,length(tree$edge.length),length(s),dimnames=list(edge=apply(tree$edge,1,function(x) paste(x,collapse=",")),state=s)) for(i in 1:length(maps)) for(j in 1:length(maps[[i]])) mapped.edge[i,names(maps[[i]])[j]]<-mapped.edge[i,names(maps[[i]])[j]]+maps[[i]][j] ## add attributes to the tree tree$mapped.edge<-mapped.edge tree$maps<-maps class(tree)<-c("simmap",setdiff(class(tree),"simmap")) tree } # function paints a subtree # written by Liam Revell 2012, 2013, 2015 paintSubTree<-function(tree,node,state,anc.state="1",stem=FALSE){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(stem==0&&node<=length(tree$tip)) stop("stem must be TRUE for node<=N") if(is.null(tree$edge.length)) tree<-compute.brlen(tree) if(is.null(tree$maps)){ maps<-as.list(tree$edge.length) for(i in 1:length(maps)) names(maps[[i]])<-anc.state } else maps<-tree$maps if(node>length(tree$tip)){ desc<-getDescendants(tree,node) z<-which(tree$edge[,2]%in%desc) for(i in 1:length(z)){ maps[[z[i]]]<-sum(maps[[z[i]]]) names(maps[[z[i]]])<-state } if(stem){ a<-which(tree$edge[,2]==node) b<-bySegments(maps[[a]])/max(bySegments(maps[[a]])) c<-match(1,((1-stem)>=b[,1])*((1-stem)<=b[,2])) d<-names(maps[[a]])[1:c] e<-maps[[a]] if(c>1){ maps[[a]]<-c(e[1:(c-1)],(1-stem)*sum(e)-sum(e[1:(c-1)]),stem*sum(e)) names(maps[[a]])<-c(d,state) } else { maps[[a]]<-c((1-stem)*sum(e),stem*sum(e)) names(maps[[a]])<-c(d,state) } } } else { a<-which(tree$edge[,2]==node) b<-bySegments(maps[[a]])/max(bySegments(maps[[a]])) c<-match(1,((1-stem)>=b[,1])*((1-stem)<=b[,2])) d<-names(maps[[a]])[1:c] e<-maps[[a]] if(c>1){ maps[[a]]<-c(e[1:(c-1)],(1-stem)*sum(e)-sum(e[1:(c-1)]),stem*sum(e)) names(maps[[a]])<-c(d,state) } else { maps[[a]]<-c((1-stem)*sum(e),stem*sum(e)) names(maps[[a]])<-c(d,state) } } s<-vector() for(i in 1:nrow(tree$edge)) s<-c(s,names(maps[[i]])) s<-unique(s) mapped.edge<-matrix(0,length(tree$edge.length),length(s),dimnames=list(edge=apply(tree$edge,1,function(x) paste(x,collapse=",")),state=s)) for(i in 1:length(maps)) for(j in 1:length(maps[[i]])) mapped.edge[i,names(maps[[i]])[j]]<-mapped.edge[i,names(maps[[i]])[j]]+maps[[i]][j] tree$mapped.edge<-mapped.edge tree$maps<-maps class(tree)<-c("simmap",setdiff(class(tree),"simmap")) return(tree) } # function # written by Liam Revell 2012 bySegments<-function(z){ XX<-matrix(0,length(z),2,dimnames=list(names(z),c("start","end"))) XX[1,2]<-z[1] if(length(z)>1){ for(j in 2:length(z)){ XX[j,1]<-XX[j-1,2] XX[j,2]<-XX[j,1]+z[j] } } return(XX) } phytools/R/phylo.heatmap.R0000644000176200001440000000573714375517350015256 0ustar liggesusers## function for phylogenetic heat map ## written by Liam J. Revell 2016, 2017, 2020 phylo.heatmap<-function(tree,X,fsize=1,colors=NULL,standardize=FALSE,...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(length(fsize)!=3) fsize<-rep(fsize,3) if(hasArg(legend)) legend<-list(...)$legend else legend<-TRUE if(hasArg(labels)) labels<-list(...)$labels else labels<-TRUE if(hasArg(split)) split<-list(...)$split else split<-c(0.5,0.5) split<-split/sum(split) if(is.null(colnames(X))) colnames(X)<-paste("var",1:ncol(X),sep="") if(standardize){ sd<-apply(X,2,function(x) sqrt(var(x,na.rm=TRUE))) X<-(X-matrix(rep(1,Ntip(tree)),Ntip(tree),1)%*%colMeans(X,na.rm=TRUE))/ (matrix(rep(1,Ntip(tree)),Ntip(tree),1)%*%sd) } if(hasArg(xlim)) xlim<-list(...)$xlim else xlim<-c(-0.5,(2-0.5)*split[2]/split[1]+0.5) if(hasArg(ylim)) ylim<-list(...)$ylim else ylim<-if(legend) c(if(standardize) -0.15 else -0.1, if(labels) 1.1 else 1) else c(0,if(labels) 1.1 else 1) if(hasArg(mar)) mar<-list(...)$mar else mar<-rep(1.1,4) if(is.null(colors)) colors<-heat.colors(n=20)[20:1] if(hasArg(grid)) add.grid <- list(...)$grid else add.grid <- FALSE cw<-untangle(as.phylo(tree),"read.tree") plot.new() par(mar=mar) plot.window(xlim=xlim,ylim=ylim) h<-phylogram(cw,fsize=fsize[1],...) START<-h+1/2*((2-0.5)*split[2]/split[1]+0.5-h)/(ncol(X)-1)+ 0.5*strwidth("W")*fsize[1] END<-(2-0.5)*split[2]/split[1]+0.5-1/2*((2-0.5)*split[2]/split[1]+ 0.5-START)/(ncol(X)-1) X<-X[cw$tip.label,] image(x=seq(START,END,by=(END-START)/(ncol(X)-1)), z=t(X[cw$tip.label,]),add=TRUE, col=colors,...) if(add.grid){ dx <- (END - START)/(ncol(X) - 1) x <- seq(START - dx/2, END + dx/2, by = dx) nTips <- length(tree$tip.label) y <- c(-1/(2*(nTips-1)), seq(0, 1, length = nTips) + 1/(2*(nTips-1)) ) segments(x, y[1], x, y[length(y)]) segments(x[1], y, x[length(x)], y) } if(legend){ if(hasArg(leg.title)) leg.title<-list(...)$leg.title else leg.title<-if(standardize) "standardized value" else "value" if(hasArg(leg.subtitle)) leg.subtitle<-list(...)$leg.subtitle else leg.subtitle<-if(standardize) "SD units" else "" add.color.bar(leg=END-START,cols=colors,lims=range(X,na.rm=TRUE), title=leg.title,subtitle=leg.subtitle,prompt=FALSE,x=START, y=-1/(2*(Ntip(cw)-1))-3*fsize[3]*strheight("W"), digits=if(max(abs(X),na.rm=TRUE)<1) round(log10(1/max(abs(X),na.rm=TRUE)))+1 else 2,fsize=fsize[3]) } if(labels) text(x=seq(START,END,by=(END-START)/(ncol(X)-1)), y=rep(1+1/(2*(Ntip(cw)-1))+0.4*fsize[2]*strwidth("I"),ncol(X)), colnames(X),srt=70,adj=c(0,0.5),cex=fsize[2]) if(any(is.na(X))){ ii<-which(is.na(X),arr.ind=TRUE) x.na<-seq(START,END,by=(END-START)/(ncol(X)-1))[ii[,2]] y.na<-seq(0,1,by=1/(nrow(X)-1))[ii[,1]] for(i in 1:length(x.na)){ xx<-x.na[i]+c(1/2,-1/2)*(END-START)/(ncol(X)-1) yy<-y.na[i]+c(-1/2,1/2)*1/(nrow(X)-1) lines(xx,yy) } } } phytools/R/locate.fossil.R0000644000176200001440000001052714375517350015243 0ustar liggesusers## code to place a fossil taxon into a tree using ML and continuous data ## written by Liam J. Revell 2014, 2015, 2017, 2022, 2023 locate.fossil<-function(tree,X,...){ if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".") if(hasArg(plot)) plot<-list(...)$plot else plot<-TRUE if(hasArg(quiet)) quiet<-list(...)$quiet else quiet<-FALSE if(hasArg(rotate)) rotate<-list(...)$rotate else rotate<-TRUE if(hasArg(edge.constraint))edge.constraint<-list(...)$edge.constraint else edge.constraint<-tree$edge[,2] if(hasArg(time.constraint)) time.constraint<-list(...)$time.constraint else time.constraint<-c(0,max(nodeHeights(tree))) if(hasArg(tol)) tol<-list(...)$tol else tol<-1e-6 if(any(time.constraint<0)) time.constraint<-max(nodeHeights(tree))+time.constraint if(length(time.constraint)==1) time.constraint<-rep(time.constraint,2) if(!is.matrix(X)) X<-as.matrix(X) tip<-setdiff(rownames(X),tree$tip.label) fossilML(tree,X,quiet,tip,edge.constraint,time.constraint,plot,search,rotate,tol) } fossilML<-function(tree,X,quiet,tip,edge.constraint,time.constraint,plot,search,rotate,tol){ if(!quiet) cat(paste("Optimizing the phylogenetic position of ",tip, " using ML. Please wait....\n",sep="")) if(ncol(X)>1&&rotate){ pca<-phyl.pca(tree,X[tree$tip.label,]) obj<-phyl.vcv(X[tree$tip.label,],vcv(tree),1) X<-(X-matrix(rep(obj$a[,1],nrow(X)),nrow(X),ncol(X),byrow=TRUE))%*%pca$Evec } lik.tree<-function(par,tip,tree,edge,height,XX,rotate,time.constraint){ tip.depth<-par[1] tip.height<-par[2] if(tip.height>(tip.depth+1e-6)){ ii<-which(tree$edge[,2]==edge) tree<-bind.tip(tree,tip,where=edge,position=min(height[2]-tip.depth, tree$edge.length[ii]), edge.length=tip.height-tip.depth) if(!rotate) XX<-phyl.pca(tree,XX[tree$tip.label,])$S obj<-phyl.vcv(as.matrix(XX[tree$tip.label,]),vcv(tree),1) ll<-vector() for(i in 1:ncol(XX)) ll[i]<-sum(dmnorm(XX[tree$tip.label,i],mean=rep(obj$a[i,1],nrow(XX)), obj$C*obj$R[i,i],log=TRUE)) if(plot){ plotTree(tree,mar=c(2.1,0.1,3.1,0.1),ftype="i",fsize=0.8) obj<-lapply(time.constraint,function(x,tree) lines(rep(x,2), c(0,Ntip(tree)+1),col="red",lty="dashed"),tree=tree) title(paste("log(L) = ",signif(sum(ll),6),sep="")) axis(1) } logL<-sum(ll) } else logL<--.Machine$double.xmax/1e100 logL } ee<-intersect(tree$edge[,2],edge.constraint) H<-nodeHeights(tree) hh<-unique(c(tree$edge[H[,1]<=time.constraint[2],2], tree$edge[H[,2]<=time.constraint[2],2])) ee<-intersect(ee,hh) fit<-vector(mode="list",length=length(ee)) for(i in 1:length(ee)){ ii<-which(tree$edge[,2]==ee[i]) lower<-c(H[ii,1],time.constraint[1])+ tol*diff(c(H[ii,1],time.constraint[1])) upper<-c(H[ii,2],time.constraint[2])+ tol*diff(c(H[ii,2],time.constraint[2])) par<-c(mean(lower),mean(upper)) fit[[i]]<-optim(par,lik.tree,tip=tip,tree=tree,edge=ee[i], height=H[ii,],XX=X,rotate=rotate, time.constraint=time.constraint, method="L-BFGS-B",lower=lower,upper=upper, control=list(fnscale=-1)) } logL<-sapply(fit,function(x) x$value) ii<-which(logL==max(logL)) if(length(ii)==1){ fit<-fit[[ii]] edge<-ee[ii] mltree<-bind.tip(tree,tip,where=edge, position=H[which(tree$edge[,2]==edge),2]-fit$par[1], edge.length=fit$par[2]-fit$par[1]) mltree$logL<-fit$value } else { fit<-fit[ii] mltree<-vector(mode="list",length=length(ii)) for(i in 1:length(ii)){ edge<-ee[ii[i]] mltree[[i]]<-bind.tip(tree,tip,where=edge, position=H[which(tree$edge[,2]==edge),2]-fit[[i]]$par[1], edge.length=fit[[i]]$par[2]-fit[[i]]$par[1]) mltree[[i]]$logL<-fit[[i]]$value } class(mltree)<-"multiPhylo" } if(!quiet) cat("Done.\n") if(plot){ if(inherits(mltree,"phylo")){ plotTree(mltree,mar=c(2.1,0.1,3.1,0.1),ftype="i",fsize=0.8) obj<-lapply(time.constraint,function(x,tree) lines(rep(x,2), c(0,Ntip(tree)+1),col="red",lty="dashed"),tree=tree) title(paste("Optimized position of taxon \"",tip,"\"",sep="")) axis(1) } else { par(mfrow=c(1,length(mltree))) for(i in 1:length(mltree)){ plotTree(mltree[[i]],mar=c(2.1,0.1,0.1,0.1),ftype="i",fsize=0.8) obj<-lapply(time.constraint,function(x,tree) lines(rep(x,2), c(0,Ntip(tree)+1),col="red",lty="dashed"),tree=tree) axis(1) } } } mltree } phytools/R/sim.corrs.R0000644000176200001440000000257514375517350014421 0ustar liggesusers# sim.corrs # written by Liam J. Revell 2012, 2013, 2015 sim.corrs<-function(tree,vcv,anc=NULL,internal=FALSE){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(!is.list(vcv)){ p<-nrow(vcv) if(is.null(anc)) anc<-rep(0,p) cholvcv<-chol(vcv) X<-matrix(rnorm(p*nrow(tree$edge),sd=rep(sqrt(tree$edge.length),p)),nrow(tree$edge),p) X<-X%*%cholvcv } else { p<-nrow(vcv[[1]]) if(is.null(anc)) anc<-rep(0,p) if(is.null(names(vcv))){ names(vcv)<-colnames(tree$mapped.edge) message("names absent from vcv: assuming same order as $mapped.edge") } vcv<-vcv[colnames(tree$mapped.edge)] cholvcv<-lapply(vcv,chol) X<-matrix(0,nrow(tree$edge),p) for(i in 1:length(vcv)){ Y<-matrix(rnorm(p*nrow(tree$edge),sd=rep(sqrt(tree$mapped.edge[,i]),p)),nrow(tree$edge),p) X<-X+Y%*%cholvcv[[i]] } } Y<-array(0,dim=c(nrow(tree$edge),ncol(tree$edge),p)) n<-length(tree$tip) for(i in 1:nrow(X)){ if(tree$edge[i,1]==(n+1)) Y[i,1,]<-anc else Y[i,1,]<-Y[match(tree$edge[i,1],tree$edge[,2]),2,] Y[i,2,]<-Y[i,1,]+X[i,] } X<-matrix(data=rbind(Y[1,1,],as.matrix(Y[,2,])),length(tree$edge.length)+1,p) rownames(X)<-c(n+1,tree$edge[,2]) X<-as.matrix(X[as.character(1:(n+tree$Nnode)),]) rownames(X)[1:n]<-tree$tip.label if(internal==TRUE) return(X) else return(X[1:length(tree$tip.label),]) } phytools/R/strahlerNumber.R0000644000176200001440000000352614375517350015474 0ustar liggesusers# function computes the Strahler number at each node # written by Liam J. Revell 2013, 2015 strahlerNumber<-function(tree,plot=TRUE){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") pw<-reorder(tree,"pruningwise") oo<-sapply(tree$edge[,2],function(x,y) which(x==y),y=pw$edge[,2]) SS<-matrix(0,nrow(pw$edge),2) SS[pw$edge[,2]<=length(pw$tip.label),2]<-1 nn<-unique(pw$edge[,1]) for(i in 1:pw$Nnode){ jj<-which(pw$edge[,1]==nn[i]) s<-sort(SS[jj,2],decreasing=TRUE) SS[jj,1]<-if(all(sapply(s[2:length(s)],"<",s[1]))) s[1] else s[1]+1 SS[which(pw$edge[,2]==pw$edge[jj[1],1]),2]<-SS[jj[1],1] } ss<-setNames(c(SS[oo,][1,1],SS[oo,2]),c(tree$edge[1,1],tree$edge[,2])) ss<-ss[order(as.numeric(names(ss)))] names(ss)[1:length(tree$tip.label)]<-tree$tip.label if(plot){ plotTree(tree) nodelabels(ss[1:tree$Nnode+length(tree$tip.label)]) } return(ss) } # extracts all the most inclusive clades with Strahler number i from tree # written by Liam J. Revell 2013, 2015 extract.strahlerNumber<-function(tree,i,plot=TRUE){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") sn<-strahlerNumber(tree) sn<-sn[sn==i] # get descendant tip numbers for all clades ll<-lapply(as.numeric(names(sn)),getDescendants,tree=tree) # figure out which ones are most inclusive ff<-function(x,y) !all(sapply(x,"%in%",y)) GG<-sapply(ll,function(x,y) sapply(y,ff,x=x),y=ll) ii<-which(colSums(GG)==(ncol(GG)-1)) # extract these clades trees<-lapply(as.numeric(names(sn))[ii],extract.clade,phy=tree) if(plot){ nplots<-2*ceiling(length(trees)/2) layout(matrix(1:nplots,ceiling(nplots/2),min(c(length(trees),2)),byrow=TRUE)) sNN<-lapply(trees,strahlerNumber,plot=TRUE) } if(length(trees)>1) class(trees)<-"multiPhylo" else trees<-trees[[1]] return(trees) } phytools/R/phylomorphospace3d.R0000644000176200001440000000704114375517350016316 0ustar liggesusers## phylomorphospace3d: projection of a tree into three dimensional morphospace ## written by Liam J. Revell 2012, 2013, 2014, 2016, 2018 phylomorphospace3d<-function(tree,X,A=NULL,label=TRUE,control=list(),method=c("dynamic","static"),...){ method<-method[1] if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") # control list con=list(spin=TRUE,axes=TRUE,box=TRUE,simple.axes=FALSE,lwd=1,ftype="reg", col.edge=rep("black",nrow(tree$edge))) con[(namc<-names(control))]<-control if(con$simple.axes) con$box<-con$axes<-FALSE con$ftype<-which(c("off","reg","b","i","bi")==con$ftype)-1 if(is.null(A)) A<-apply(X,2,function(x,tree) fastAnc(tree,x),tree=tree) else A<-A[as.character(1:tree$Nnode+length(tree$tip)),] x<-y<-z<-matrix(NA,nrow(tree$edge),2) X<-X[tree$tip.label,] for(i in 1:length(tree$tip)){ x[tree$edge[,2]==i,2]<-X[i,1] y[tree$edge[,2]==i,2]<-X[i,2] z[tree$edge[,2]==i,2]<-X[i,3] } for(i in length(tree$tip)+1:tree$Nnode){ x[tree$edge[,1]==i,1]<-x[tree$edge[,2]==i,2]<-A[as.character(i),1] y[tree$edge[,1]==i,1]<-y[tree$edge[,2]==i,2]<-A[as.character(i),2] z[tree$edge[,1]==i,1]<-z[tree$edge[,2]==i,2]<-A[as.character(i),3] } if(is.null(colnames(X))) colnames(X)<-c("x","y","z") if(method=="dynamic"){ chk<-.check.pkg("rgl") if(!chk){ cat(" method = \"dynamic\" requires the package \"rgl\"\n Defaulting to method = \"static\"\n\n") method<-"static" lines3d<-play3d<-plot3d<-segments3d<-spheres3d<-spin3d<-text3d<-function(...) NULL } } if(method=="dynamic"){ params<-get("r3dDefaults") plot3d(rbind(X,A),xlab=colnames(X)[1],ylab=colnames(X)[2],zlab=colnames(X)[3], axes=con$axes,box=con$box,params=params) spheres3d(X,radius=0.02*mean(apply(X,2,max)-apply(X,2,min))) for(i in 1:nrow(tree$edge)) segments3d(x[i,],y[i,],z[i,],lwd=con$lwd, col=con$col.edge[i]) ms<-colMeans(X) rs<-apply(rbind(X,A),2,range) if(con$simple.axes){ lines3d(x=rs[,1],y=c(rs[1,2],rs[1,2]),z=c(rs[1,3],rs[1,3])) lines3d(x=c(rs[1,1],rs[1,1]),y=rs[,2],z=c(rs[1,3],rs[1,3])) lines3d(x=c(rs[1,1],rs[1,1]),y=c(rs[1,2],rs[1,2]),z=rs[,3]) } rs<-rs[2,]-rs[1,] for(i in 1:length(tree$tip)){ adj<-0.03*rs*(2*(X[i,]>ms)-1) if(con$ftype) text3d(X[i,]+adj,texts=tree$tip.label[i],font=con$ftype) } if(con$spin){ xx<-spin3d(axis=c(0,0,1),rpm=10) play3d(xx,duration=5) invisible(xx) } else invisible(NULL) } else if(method=="static"){ if(hasArg(angle)) angle<-list(...)$angle else angle<-30 if(hasArg(xlim)) xlim<-list(...)$xlim else xlim<-NULL if(hasArg(ylim)) ylim<-list(...)$ylim else ylim<-NULL if(hasArg(zlim)) zlim<-list(...)$zlim else zlim=NULL xx<-scatterplot3d(X,xlab=colnames(X)[1],zlab=colnames(X)[3],pch=19,angle=angle, ylab=colnames(X)[2],cex.symbols=1.3,xlim=xlim,ylim=ylim,zlim=zlim) aa<-xx$xyz.convert(A) points(aa$x,aa$y,pch=19,cex=0.8) for(i in 1:nrow(tree$edge)){ aa<-xx$xyz.convert(x[i,],y[i,],z[i,]) lines(aa$x,aa$y,lwd=2,col=con$col.edge[i]) } for(i in 1:length(tree$tip.label)){ aa<-xx$xyz.convert(x[which(tree$edge[,2]==i),2],y[which(tree$edge[,2]==i),2], z[which(tree$edge[,2]==i),2]) if(con$ftype) text(tree$tip.label[i],x=aa$x,y=aa$y,pos=2,font=con$ftype) } invisible(xx) } } ## check for a package (modified from 'geiger') ## primarily used for rgl ## written by Liam J. Revell 2014, 2022 .check.pkg<-function(pkg){ if(pkg%in%rownames(installed.packages())){ require(pkg,character.only=TRUE) return(TRUE) } else return(FALSE) } phytools/R/export.as.xml.R0000644000176200001440000000243614375517350015220 0ustar liggesusers## makes xml data and tree file for SIMMAP ## written by Liam J. Revell 2012, 2015, 2022 export.as.xml<-function(file,trees,X){ if(is.vector(X)) X<-data.frame(X) if(inherits(X,"DNAbin")) { X<-as.character(X) datatype="nucleotide" } else datatype="standard" if(inherits(trees,"phylo")){ trees<-list(trees) class(trees)<-"multiPhylo" } ntaxa<-length(trees[[1]]$tip) nchars<-ncol(X) write("",file) write("",file,append=TRUE) write(paste("\t",sep=""),file,append=TRUE) for(i in 1:ntaxa) write(paste("\t\t",paste(X[i,],collapse=""),"",sep=""),file,append=TRUE) write("\t",file,append=TRUE) write("\t",file,append=TRUE) trans<-trees[[1]]$tip.label for(i in 1:ntaxa) write(paste("\t\t",trans[i],"",sep=""),file,append=TRUE) for(i in 1:length(trees)){ trees[[i]]$tip.label<-match(trans,trees[[i]]$tip.label) temp<-unlist(strsplit(write.tree(trees[[i]]),NULL)) temp<-paste(temp[1:(length(temp)-1)],collapse="") write(paste("\t\t",temp,"",sep=""),file,append=TRUE) } write("\t",file,append=TRUE) write("",file,append=TRUE) } phytools/R/backbonePhylo.R0000644000176200001440000002462514421520134015244 0ustar liggesusers## function to manipulate & plot objects of class "backbonePhylo" ## written by Liam J. Revell 2013, 2016 backbone.toTrans<-function(obj){ tip.label<-obj$tip.label clade.label<-sapply(obj$tip.clade,function(x) x$label) N<-sapply(obj$tip.clade,function(x) x$N) depth<-sapply(obj$tip.clade,function(x) x$depth) data.frame(tip.label,clade.label,N,depth) } ## convert "phylo" to "backbonePhylo" phylo.toBackbone<-function(x,trans=NULL,...){ if(!inherits(x,"phylo")) stop("tree should be an object of class \"phylo\".") if(hasArg(interactive)) interactive<-list(...)$interactive else interactive<-is.null(trans) if(hasArg(height)) height<-list(...)$height else height<-"mean" if(interactive){ options(locatorBell=FALSE) if(is.null(x$node.label)) x$node.label<-as.character(1:x$Nnode+Ntip(x)) if(inherits(x,"backbonePhylo")) plot(x,...) else plotTree(x,...) cat(" Select clade to collapse.\n") flush.console() check<-textbox(x=c(par()$usr[1],par()$usr[1]+ 0.1*(par()$usr[2]-par()$usr[1])), y=par()$usr[4],c("click to stop"),justify="c") xy<-unlist(locator(1)) while(!(xy[1]>par()$usr[1]&&xy[1]check&&xy[2] ") flush.console() clab<-readLines(n=1) if(obj$where<=Ntip(x)){ if(clab=="") clab<-x$tip.label[obj$where] tlab<-x$tip.label[obj$where] depth<-obj$pos N<-if(inherits(x,"backbonePhylo")) x$tip.clade[[obj$where]]$N else 1 if(!inherits(x,"backbonePhylo")){ trans<-data.frame(tip.label=as.character(tlab), clade.label=as.character(clab),N=N,depth=depth) x<-phylo.toBackbone(x,trans) } else { x$tip.clade[[obj$where]]<-list(label=as.character(clab), N=N,depth=depth, id=paste(sample(c(letters,LETTERS,0:9),6,replace=TRUE), collapse="")) x$tip.label[obj$where]<-x$tip.clade[[obj$where]]$id } } else { if(clab=="") clab<-x$node.label[obj$where-Ntip(x)] tlab<-x$node.label[obj$where-Ntip(x)] split<-list(node=obj$where, bp=x$edge.length[which(x$edge[,2]==obj$where)]-obj$pos) tip.clade<-if(!is.null(x$tip.clade)) x$tip.clade else NULL aclass<-class(x) tmp<-splitTree(x,split) tip<-which(tmp[[1]]$tip.label=="NA") if(height=="mean") depth<-obj$pos+ mean(sapply(1:Ntip(tmp[[2]]),nodeheight,tree=tmp[[2]])) else if(height=="max") depth<-obj$pos+ max(sapply(1:Ntip(tmp[[2]]),nodeheight,tree=tmp[[2]])) else if(height=="min") depth<-obj$pos+ min(sapply(1:Ntip(tmp[[2]]),nodeheight,tree=tmp[[2]])) tmp[[1]]$edge.length[which(tmp[[1]]$edge[,2]==tip)]<- tmp[[1]]$edge.length[which(tmp[[1]]$edge[,2]==tip)]+depth if(inherits(x,"backbonePhylo")){ dd<-getDescendants(x,obj$where) N<-sum(sapply(x$tip.clade[dd[dd<=Ntip(x)]],function(x) x$N)) } else { dd<-getDescendants(x,obj$where) N<-sum(dd<=Ntip(x)) } x<-tmp[[1]] x$tip.label[tip]<-tlab trans<-data.frame(tip.label=as.character(tlab), clade.label=as.character(clab),N=N,depth=depth) x<-phylo.toBackbone(x,trans) } if(inherits(x,"backbonePhylo")) plot(x,...) else plotTree(x,...) cat("\n Select clade to collapse (or STOP).\n") flush.console() check<-textbox(x=c(par()$usr[1],par()$usr[1]+ 0.1*(par()$usr[2]-par()$usr[1])), y=par()$usr[4],c("click to stop"),justify="c") xy<-unlist(locator(1)) } } else { if(!inherits(x,"backbonePhylo")){ x$tip.clade<-list() for(i in 1:length(x$tip.label)){ if(x$tip.label[i]%in%trans$tip.label){ ii<-which(trans$tip.label==x$tip.label[i]) x$tip.clade[[i]]<-list() x$tip.clade[[i]]$label<-as.character(trans$clade.label[ii]) x$tip.clade[[i]]$N<-trans$N[ii] x$tip.clade[[i]]$depth<-trans$depth[ii] } else { x$tip.clade[[i]]<-list() x$tip.clade[[i]]$label<-as.character(x$tip.label[i]) x$tip.clade[[i]]$N<-1 x$tip.clade[[i]]$depth<-x$edge.length[which(x$edge[,2]==i)] } x$tip.clade[[i]]$id<-paste(sample(c(letters,LETTERS,0:9),6, replace=TRUE),collapse="") } x$tip.label<-sapply(x$tip.clade,function(y) y$id) class(x)<-c("backbonePhylo","phylo") } else { for(i in 1:nrow(trans)){ ii<-which(x$tip.label==trans$tip.label[i]) tmp<-as.character(trans$clade.label[i]) x$tip.clade[[length(x$tip.clade)+1]]<- list(label=tmp,N=trans$N[i],depth=trans$depth[i], id=paste(sample(c(letters,LETTERS,0:9),6,replace=TRUE), collapse="")) x$tip.label[ii]<-x$tip.clade[[length(x$tip.clade)]]$id clade.id<-sapply(x$tip.clade,function(y) y$id) ii<-sapply(clade.id,function(x,y) if(x%in%y) which(y==x) else -1, y=x$tip.label) x$tip.clade<-x$tip.clade[ii>0] x$tip.clade<-x$tip.clade[ii[ii>0]] } } } x } ## convert to object of class "phylo" backbone.toPhylo<-function(x){ if(!inherits(x,"backbonePhylo")) stop("x not an object of class \"backbonePhylo\"") x$tip.label<-sapply(x$tip.clade,function(x) x$label) x$tip.clade<-NULL class(x)<-"phylo" x } ## reorder backbone phylogeny reorder.backbonePhylo<-function(x,order="cladewise",...){ ii<-reorder(backbone.toPhylo(x),order,index.only=TRUE) x$edge<-x$edge[ii,] x$edge.length<-x$edge.length[ii] attr(x,"order")<-order x } ## print method print.backbonePhylo<-function(x,...){ cat(paste("\nBackbone phylogenetic tree with",length(x$tip.clade), "subtrees and",x$Nnode,"resolved internal nodes.\n")) n<-min(length(x$tip.clade),5) cat("\nLabels: ") cat(paste(sapply(x$tip.clade[1:n],function(y) y$label),collapse=", ")) cat(", ...\nDiversities: ") cat(paste(sapply(x$tip.clade[1:n],function(y) y$N),collapse=", ")) cat(", ...\n\n") } ## scale N scaleN<-function(x,k){ for(i in 1:length(x$tip.clade)) if(x$tip.clade[[i]]$N>1) x$tip.clade[[i]]$N<-x$tip.clade[[i]]$N*k x } ## plot backbone phylogeny with triangles plot.backbonePhylo<-function(x,...){ if(!inherits(x,"backbonePhylo")) stop("x not an object of class \"backbonePhylo\"") if(hasArg(vscale)) vscale<-list(...)$vscale else vscale<-1 if(hasArg(col)) col<-list(...)$col else col<-"grey" if(length(col)!=Ntip(x)){ if(!is.null(names(col))){ tmp<-setNames(rep("grey",Ntip(x)),sapply(x$tip.clade,function(x) x$label)) for(i in 1:length(col)) tmp[which(names(tmp)==names(col)[i])]<-col[i] col<-tmp } else col<-setNames(rep(col[1],Ntip(x)),sapply(x$tip.clade, function(x) x$label)) } if(is.null(names(col))) names(col)<-sapply(x$tip.clade, function(x) x$label) col<-col[sapply(x$tip.clade,function(x) x$label)] names(col)<-sapply(x$tip.clade,function(x) x$id) if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-2 if(hasArg(sep)) sep<-list(...)$sep else sep<-1 if(hasArg(fixed.height)) fixed.height<-list(...)$fixed.height else fixed.height<-FALSE if(hasArg(print.clade.size)) print.clade.size<-list(...)$print.clade.size else print.clade.size<-FALSE if(hasArg(fixed.n1)) fixed.n1<-list(...)$fixed.n1 else fixed.n1<-FALSE if(hasArg(xlim)) xlim<-list(...)$xlim else xlim<-NULL if(hasArg(ylim)) ylim<-list(...)$ylim else ylim<-NULL if(hasArg(cex)) cex<-list(...)$cex else cex<-par("cex") if(fixed.height||print.clade.size){ obj<-x for(i in 1:Ntip(obj)){ if(print.clade.size){ obj$tip.clade[[i]]$label<-if(x$tip.clade[[i]]$N>1||fixed.n1) paste(x$tip.clade[[i]]$label," (n=", x$tip.clade[[i]]$N,")",sep="") else x$tip.clade[[i]]$label ii<-which(names(col)==x$tip.clade[[i]]$label) names(col)[ii]<-obj$tip.clade[[i]]$label } if(fixed.height) obj$tip.clade[[i]]$N<-if(x$tip.clade[[i]]$N>1||fixed.n1) sum(sapply(x$tip.clade,function(y) y$N))/Ntip(x) else 1 } x<-obj } x<-scaleN(x,vscale) tt<-backbone.toPhylo(x) n<-sum(sapply(x$tip.clade,function(x) x$N)) cw<-reorder.backbonePhylo(x,"cladewise") y<-vector(length=length(cw$tip.clade)+cw$Nnode) ii<-order(cw$edge[,2][cw$edge[,2]<=Ntip(cw)]) z<-c(0,cumsum(sapply(cw$tip.clade[order(ii)],function(x) x$N))) nn<-sapply(2:length(z),function(i,x) (x[i]-x[i-1])/2+x[i-1],x=z) y[cw$edge[cw$edge[,2]<=length(cw$tip.clade),2]]<-nn[1:length(cw$tip.clade)] pw<-reorder.backbonePhylo(x,"pruningwise") nn<-unique(pw$edge[,1]) for(i in 1:length(nn)){ yy<-y[pw$edge[which(pw$edge[,1]==nn[i]),2]] y[nn[i]]<-mean(range(yy)) } # compute start & end points of each edge X<-nodeHeights(tt) # open & size a new plot plot.new() par(mar=rep(0.1,4)) pp<-par("pin")[1] sw<-cex*(max(strwidth(sapply(cw$tip.clade,function(x) x$label), units="inches")))+1.37*cex*strwidth("W",units="inches") alp<-optimize(function(a,H,sw,pp) (a*1.04*max(H)+sw-pp)^2,H=X,sw=sw,pp=pp, interval=c(0,1e6))$minimum if(is.null(xlim)) xlim<-c(min(X),max(X)+sw/alp) if(is.null(ylim)) ylim<-c(0,n) plot.window(xlim=xlim,ylim=ylim) # plot horizontal edges for(i in 1:nrow(X)){ if(cw$edge[i,2]>length(cw$tip.clade)) lines(X[i,],rep(y[cw$edge[i,2]],2), lwd=lwd,lend=2) else lines(c(X[i,1],X[i,2]-cw$tip.clade[[cw$edge[i,2]]]$depth), rep(y[cw$edge[i,2]],2),lwd=lwd,lend=2) } # plot vertical relationships for(i in 1:x$Nnode+length(x$tip.clade)) lines(X[which(cw$edge[,1]==i),1], range(y[cw$edge[which(cw$edge[,1]==i),2]]),lwd=lwd,lend=2) for(i in 1:length(x$tip.clade)){ if(x$tip.clade[[i]]$N==1){ tmp<-sep sep<-1 } else tmp<-sep xx<-c(X[which(cw$edge[,2]==i),2]-cw$tip.clade[[i]]$depth, X[which(cw$edge[,2]==i),2],X[which(cw$edge[,2]==i),2]) yy<-c(y[cw$edge[which(cw$edge[,2]==i),2]], y[cw$edge[which(cw$edge[,2]==i),2]]+cw$tip.clade[[i]]$N/2- sep/2,y[cw$edge[which(cw$edge[,2]==i),2]]- cw$tip.clade[[i]]$N/2+sep/2) if(yy[2]tol){ warning("first value in limits should be zero.") limits[1]<-0 } while(limits[length(limits)]>max(H)){ warning("last value in limits should be less than the total tree height.") limits<-limits[1:(length(limits)-1)] } if(is.null(names(limits))) names(limits)<-1:length(limits) limits[length(limits)+1]<-max(H) maps<-list() # ok, now go through the edges of the tree for(i in 1:nrow(tree$edge)){ s<-1 while((H[i,1]>=(limits[s]-tol)&&H[i,1]limits[e]&&H[i,2]<=(limits[e+1]+tol))==FALSE) e<-e+1 maps[[i]]<-vector() if(s==e){ maps[[i]][1]<-tree$edge.length[i] names(maps[[i]])[1]<-names(limits)[s] } else { maps[[i]][1]<-limits[s+1]-H[i,1] for(j in (s+1):e) maps[[i]][j-s+1]<-limits[j+1]-limits[j] maps[[i]][e-s+1]<-H[i,2]-limits[e] names(maps[[i]])<-names(limits)[s:e] } } tree$maps<-maps # now construct the matrix "mapped.edge" (for backward compatibility) allstates<-vector() for(i in 1:nrow(tree$edge)) allstates<-c(allstates,names(tree$maps[[i]])) allstates<-unique(allstates) tree$mapped.edge<-matrix(data=0,length(tree$edge.length),length(allstates), dimnames=list(apply(tree$edge,1,function(x) paste(x,collapse=",")), state=allstates)) for(i in 1:length(tree$maps)) for(j in 1:length(tree$maps[[i]])) tree$mapped.edge[i,names(tree$maps[[i]])[j]]<-tree$mapped.edge[i, names(tree$maps[[i]])[j]]+tree$maps[[i]][j] class(tree)<-c("simmap",setdiff(class(tree),"simmap")) tree } phytools/R/ltt95.R0000644000176200001440000001215614375517350013457 0ustar liggesusers# 95% CI on ltts # written by Liam J. Revell 2013, 2014, 2015, 2019 ltt95<-function(trees,alpha=0.05,log=FALSE,method=c("lineages","times"),mode=c("median","mean"),...){ if(!inherits(trees,"multiPhylo")) stop("trees should be an object of class \"multiPhylo\".") method<-method[1] mode<-mode[1] if(hasArg(res)) res<-list(...)$res else res<-100 if(hasArg(plot)) plot<-list(...)$plot else plot<-TRUE X<-ltt(trees,plot=FALSE,gamma=FALSE) if(method=="times"){ N<-length(X) tt<-sapply(X,function(x) max(x$times)) zz<-max(tt)-tt for(i in 1:N) X[[i]]$times<-X[[i]]$times+zz[i] n<-sapply(X,function(x) max(x$ltt)) if(all(n==max(n))) n<-max(n) else stop("for method=\"times\" all trees must contain the same number of lineages") LL<-sapply(X,function(x) x$times[1:length(x$times)]) ii<-max(floor(alpha/2*N)+1,1) jj<-min(ceiling((1-alpha/2)*N),N) low<-apply(LL,1,function(x) sort(x)[ii]) high<-apply(LL,1,function(x) sort(x)[jj]) ll<-if(mode=="median") apply(LL,1,function(x) median(x)[1]) else rowMeans(LL) obj<-cbind(c(1:n,n),low,ll,high) colnames(obj)<-c("lineages","low(time)","time","high(time)") rownames(obj)<-NULL } else if(method=="lineages"){ N<-length(X) tt<-sapply(X,function(x) max(x$times)) zz<-max(tt)-tt for(i in 1:N) X[[i]]$times<-X[[i]]$times+zz[i] tt<-0:res*max(tt)/res ll<-low<-high<-vector() for(i in 1:length(tt)){ ss<-vector() for(j in 1:N){ ii<-2 while(tt[i]>X[[j]]$times[ii]&&ii0&&k==v[length(v)]){ string[j]<-")" j<-j+1 w<-which(tree$edge[,2]==tree$edge[k,1]) if(length(w)>0){ string[j]<-":{" j<-j+1 if(map.order=="L"){ for(l in 1:length(tree$maps[[w]])){ string[j]<-paste(c(names(tree$maps[[w]])[l],",", round(tree$maps[[w]][l],8)),collapse="") string[j+1]<-":" j<-j+2 } } else { for(l in length(tree$maps[[w]]):1){ string[j]<-paste(c(names(tree$maps[[w]])[l],",", round(tree$maps[[w]][l],8)),collapse="") string[j+1]<-":" j<-j+2 } } string[j-1]<-"}" } v<-which(tree$edge[,1]==tree$edge[w,1]) k<-w } string[j]<-"," j<-j+1 } else if(tree$edge[i,2]>=n){ string[j]<-"(" j<-j+1 } } string<-c(string[1:(length(string)-1)],";") string<-paste(string,collapse="") string } write.v2<-function(tree,map.order,quiet){ if(is.null(map.order)){ if(!is.null(attr(tree,"map.order"))) map.order<-attr(tree,"map.order") else { if(!quiet) message("map order should be specified in function call or by tree attribute \"map.order\".\nAssuming right-to-left order.") map.order<-"R" } } map.order<-toupper(unlist(strsplit(map.order,NULL))[1]) if(map.order!="R"&&map.order!="L"){ if(!quiet) message("do not recognize map order. Assuming right-to-left order.") map.order<-"R" } tree<-reorderSimmap(tree,"cladewise") n<-Ntip(tree) string<-vector() string[1]<-"(" j<-2 for(i in 1:nrow(tree$edge)){ if(tree$edge[i,2]<=n){ string[j]<-tree$tip.label[tree$edge[i,2]] j<-j+1 string[j]<-":[&map={" j<-j+1 nn<-length(tree$maps[[i]]) if(nn==1){ string[j]<-names(tree$maps[[i]])[1] j<-j+1 } else { if(map.order=="L"){ for(l in 1:(nn-1)){ string[j]<-paste(c(names(tree$maps[[i]])[l],",", round(tree$maps[[i]][l],8)),collapse="") string[j+1]<-"," j<-j+2 } string[j]<-names(tree$maps[[i]])[nn] j<-j+1 } else { for(l in nn:2){ string[j]<-paste(c(names(tree$maps[[i]])[l],",", round(tree$maps[[i]][l],8)),collapse="") string[j+1]<-"," j<-j+2 } string[j]<-names(tree$maps[[i]])[1] j<-j+1 } } string[j]<-paste(c("}]",round(tree$edge.length[i],8)),collapse="") j<-j+1 v<-which(tree$edge[,1]==tree$edge[i,1]) k<-i while(length(v)>0&&k==v[length(v)]){ string[j]<-")" j<-j+1 w<-which(tree$edge[,2]==tree$edge[k,1]) if(length(w)>0){ nn<-length(tree$maps[[w]]) string[j]<-":[&map={" j<-j+1 if(nn==1){ string[j]<-names(tree$maps[[w]])[1] j<-j+1 } else { if(map.order=="L"){ for(l in 1:(nn-1)){ string[j]<-paste(c(names(tree$maps[[w]])[l],",", round(tree$maps[[w]][l],8)),collapse="") string[j+1]<-"," j<-j+2 } string[j]<-names(tree$maps[[w]])[nn] j<-j+1 } else { for(l in nn:2){ string[j]<-paste(c(names(tree$maps[[w]])[l],",", round(tree$maps[[w]][l],8)),collapse="") string[j+1]<-"," j<-j+2 } string[j]<-names(tree$maps[[w]])[1] j<-j+1 } } string[j]<-paste(c("}]",round(tree$edge.length[w],8)),collapse="") j<-j+1 } v<-which(tree$edge[,1]==tree$edge[w,1]) k<-w } string[j]<-"," j<-j+1 } else if(tree$edge[i,2]>=n){ string[j]<-"(" j<-j+1 } } string<-c(string[1:(length(string)-1)],";") string<-paste(string,collapse="") string } phytools/R/anc.ML.R0000644000176200001440000002354514375517350013552 0ustar liggesusers## lightweight version of ace(...,method="ML") for continuous traits ## also allows missing data in x, in which case missing data are also estimated ## written by Liam J. Revell 2011, 2013, 2014, 2015 anc.ML<-function(tree,x,maxit=2000,model=c("BM","OU","EB"),...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(model[1]=="BM") obj<-anc.BM(tree,x,maxit,...) else if(model[1]=="OU") obj<-anc.OU(tree,x,maxit,...) else if(model[1]=="EB") obj<-anc.EB(tree,x,maxit,...) else stop(paste("Do not recognize method",model)) obj } ## internal to estimate ancestral states under a BM model ## written by Liam J. Revell 2011, 2013, 2014, 2016, 2018 anc.BM<-function(tree,x,maxit,...){ if(hasArg(trace)) trace<-list(...)$trace else trace<-FALSE if(hasArg(vars)) vars<-list(...)$vars else vars<-FALSE if(hasArg(CI)) CI<-list(...)$CI else CI<-FALSE if(hasArg(se)) se<-list(...)$se else se<-setNames(rep(0,length(x)),names(x)) SE<-setNames(rep(0,Ntip(tree)),tree$tip.label) SE[names(se)]<-se E<-diag(SE) colnames(E)<-rownames(E)<-names(SE) if(hasArg(tol)) tol<-list(...)$tol else tol<-10*.Machine$double.eps ## check to see if any tips are missing data xx<-setdiff(tree$tip.label,names(x)) ## function returns the log-likelihood likelihood<-function(par,C,invC,detC,xvals,msp,trace,E=0){ sig2<-par[1] a<-par[2] y<-par[1:(tree$Nnode-1)+2] xvals<-c(xvals,setNames(par[1:length(msp)+tree$Nnode+1],msp)) xvals<-xvals[rownames(C)[1:length(tree$tip.label)]] z<-c(xvals,y)-a if(trace) cat(paste(round(sig2,6)," --- ",sep="")) if(sum(E)>0){ C<-sig2*C C[rownames(E),colnames(E)]<-C[rownames(E),colnames(E)]+E invC<-solve(C) detC<-determinant(C,logarithm=TRUE)$modulus[1] } logLik<-(-z%*%invC%*%z/(2*sig2)-nrow(C)*log(2*pi)/2-nrow(C)*log(sig2)/2- detC/2)[1,1] if(trace) cat(paste(round(logLik,6),"\n")) -logLik } ## compute C C<-vcvPhylo(tree) invC<-solve(C) detC<-determinant(C,logarithm=TRUE)$modulus[1] ## assign starting values zz<-fastAnc(tree,c(x,setNames(rep(mean(x),length(xx)),xx))) y<-zz[2:length(zz)] a<-zz[1] bb<-c(c(x,setNames(rep(mean(x),length(xx)),xx))[tree$tip.label],y) sig2<-((bb-a)%*%invC%*%(bb-a)/nrow(C))[1,1] fit<-optim(c(sig2,a,y,rep(mean(x),length(xx))),fn=likelihood,C=C,invC=invC, detC=detC,xvals=x,msp=xx,trace=trace,E=E,method="L-BFGS-B", lower=c(tol,rep(-Inf,tree$Nnode+length(xx))), control=list(maxit=maxit)) if(vars||CI){ H<-hessian(likelihood,fit$par,C=C,invC=invC,detC=detC, xvals=x,msp=xx,trace=trace,E=E) vcv<-solve(H) } states<-fit$par[1:tree$Nnode+1] names(states)<-c(length(tree$tip)+1,rownames(C)[(length(tree$tip)+1):nrow(C)]) obj<-list(sig2=fit$par[1],ace=states,logLik=-fit$value,counts=fit$counts, convergence=fit$convergence,message=fit$message,model="BM") if(vars) obj$var<-setNames(diag(vcv)[1:tree$Nnode+1], c(length(tree$tip)+1,rownames(C)[(length(tree$tip)+1):nrow(C)])) if(CI){ obj$CI95<-cbind(obj$ace-1.96*sqrt(diag(vcv)[1:tree$Nnode+1]), obj$ace+1.96*sqrt(diag(vcv)[1:tree$Nnode+1])) rownames(obj$CI95)<-c(length(tree$tip)+1, rownames(C)[(length(tree$tip)+1):nrow(C)]) } if(length(xx)>0){ obj$missing.x<-setNames(fit$par[1:length(xx)+tree$Nnode+1],xx) if(vars) obj$missing.var<-setNames(diag(vcv)[1:length(xx)+ tree$Nnode+1],xx) if(CI){ obj$missing.CI95<-cbind(obj$missing.x- 1.96*sqrt(diag(vcv)[1:length(xx)+tree$Nnode+1]), obj$missing.x+1.96*sqrt(diag(vcv)[1:length(xx)+tree$Nnode+1])) rownames(obj$missing.CI95)<-xx } } class(obj)<-"anc.ML" obj } ## internal to estimate ancestral states under an OU model (this may not work) ## written by Liam J. Revell 2014 anc.OU<-function(tree,x,maxit=2000,...){ ## check to see if any tips are missing data xx<-setdiff(tree$tip.label,names(x)) if(length(xx)>0) stop("Some tips of the tree do not have data. Try model=\"BM\".") if(hasArg(tol)) tol<-list(...)$tol else tol<-1e-8 if(hasArg(trace)) trace<-list(...)$trace else trace<-FALSE if(hasArg(a.init)) a.init<-list(...)$a.init else a.init<-2*log(2)/max(nodeHeights(tree)) likOU<-function(par,tree,x,trace){ sig2<-par[1] alpha<-par[2] a0<-par[3] a<-par[1:(tree$Nnode-1)+3] logLik<-logMNORM(c(x,a),rep(a0,Ntip(tree)+tree$Nnode-1),sig2*vcvPhylo(tree,model="OU",alpha=alpha)) if(trace) print(c(sig2,alpha,logLik)) -logLik } x<-x[tree$tip.label] pp<-rep(NA,tree$Nnode+2) pp[1:tree$Nnode+2]<-fastAnc(tree,x) pp[1]<-phyl.vcv(as.matrix(c(x,pp[2:tree$Nnode+2])),vcvPhylo(tree),lambda=1)$R[1,1] pp[2]<-a.init ## arbitrarily fit<-optim(pp,likOU,tree=tree,x=x,trace=trace,method="L-BFGS-B", lower=c(tol,tol,rep(-Inf,tree$Nnode)),upper=rep(Inf,length(pp)), control=list(maxit=maxit)) obj<-list(sig2=fit$par[1],alpha=fit$par[2], ace=setNames(fit$par[1:tree$Nnode+2],1:tree$Nnode+length(tree$tip.label)), logLik=-fit$value,counts=fit$counts,convergence=fit$convergence, message=fit$message,model="OU") class(obj)<-"anc.ML" obj } ## EB is the Early-burst model (Harmon et al. 2010) and also called the ACDC model ## (accelerating-decelerating; Blomberg et al. 2003). Set by the a rate parameter, EB fits a model where ## the rate of evolution increases or decreases exponentially through time, under the model ## r[t] = r[0] * exp(a * t), where r[0] is the initial rate, a is the rate change parameter, and t is ## time. The maximum bound is set to -0.000001, representing a decelerating rate of evolution. The minimum ## bound is set to log(10^-5)/depth of the tree. ## internal to estimate ancestral states under an EB model ## written by Liam J. Revell 2017 anc.EB<-function(tree,x,maxit=2000,...){ ## check to see if any tips are missing data xx<-setdiff(tree$tip.label,names(x)) if(length(xx)>0) stop("Some tips of the tree do not have data. Try model=\"BM\".") if(hasArg(tol)) tol<-list(...)$tol else tol<-1e-8 if(hasArg(trace)) trace<-list(...)$trace else trace<-FALSE if(hasArg(vars)) vars<-list(...)$vars else vars<-FALSE if(hasArg(CI)) CI<-list(...)$CI else CI<-FALSE if(hasArg(r.init)){ r.init<-list(...)$r.init obj<-phyl.vcv(as.matrix(x[tree$tip.label]), vcv(ebTree(tree,r.init)),1) s2.init<-obj$R[1,1] a0.init<-obj$alpha[1,1] } else { ## optimize r.init lik<-function(p,tree,x) logLik<--logMNORM(x,rep(p[3],Ntip(tree)), p[1]*vcvPhylo(tree,model="EB",r=p[2],anc.nodes=F)) obj<-phyl.vcv(as.matrix(x[tree$tip.label]),vcv(tree),1) fit.init<-optim(c(obj$R[1,1],0,obj$alpha[1,1]), lik,tree=tree,x=x,method="L-BFGS-B",lower=c(tol,-Inf,-Inf), upper=rep(Inf,3)) r.init<-fit.init$par[2] s2.init<-fit.init$par[1] a0.init<-fit.init$par[3] } likEB<-function(par,tree,x,trace){ sig2<-par[1] r<-par[2] obj<-fastAnc(ebTree(tree,r),x) a0<-obj[1] a<-obj[2:length(obj)] logLik<-logMNORM(c(x,a),rep(a0,Ntip(tree)+tree$Nnode-1), sig2*vcvPhylo(tree,model="EB",r=r)) if(trace) print(c(sig2,r,logLik)) -logLik } x<-x[tree$tip.label] pp<-rep(NA,2) pp[1]<-s2.init pp[2]<-r.init fit<-optim(pp,likEB,tree=tree,x=x,trace=trace,method="L-BFGS-B", lower=c(tol,-Inf),upper=rep(Inf,2),control=list(maxit=maxit)) obj<-list(sig2=fit$par[1],r=fit$par[2], ace=unclass(fastAnc(ebTree(tree,fit$par[2]),x)), logLik=-fit$value,counts=fit$counts,convergence=fit$convergence, message=fit$message,model="EB") if(vars||CI){ likEB.hessian<-function(par,tree,y){ sig2<-par[1] r<-par[2] a<-par[3:length(par)] logLik<-logMNORM(c(y,a[2:length(a)]),rep(a[1],Ntip(tree)+tree$Nnode-1), sig2*vcvPhylo(tree,model="EB",r=r)) -logLik } H<-hessian(likEB.hessian,c(fit$par,obj$ace),tree=tree,y=x) vcv<-solve(H) if(vars) obj$var<-setNames(diag(vcv)[1:tree$Nnode+1],1:tree$Nnode+Ntip(tree)) if(CI){ obj$CI95<-cbind(obj$ace-1.96*sqrt(diag(vcv)[1:tree$Nnode+2]), obj$ace+1.96*sqrt(diag(vcv)[1:tree$Nnode+2])) rownames(obj$CI95)<-1:tree$Nnode+Ntip(tree) } } class(obj)<-"anc.ML" obj } logMNORM<-function(x,x0,vcv) -t(x-x0)%*%solve(vcv)%*%(x-x0)/2-length(x)*log(2*pi)/2-determinant(vcv,logarithm=TRUE)$modulus[1]/2 ## print method for "anc.ML" ## written by Liam J. Revell 2015, 2016 print.anc.ML<-function(x,digits=6,printlen=NULL,...){ cat(paste("Ancestral character estimates using anc.ML under a(n)", x$model,"model:\n")) Nnode<-length(x$ace) if(is.null(printlen)||printlen>=Nnode) print(round(x$ace,digits)) else printDotDot(x$ace,digits,printlen) if(!is.null(x$var)){ cat("\nVariances on ancestral states:\n") if(is.null(printlen)||printlen>=Nnode) print(round(x$var,digits)) else printDotDot(x$var,digits,printlen) } if(!is.null(x$CI95)){ cat("\nLower & upper 95% CIs:\n") colnames(x$CI95)<-c("lower","upper") if(is.null(printlen)||printlen>=Nnode) print(round(x$CI95,digits)) else printDotDot(x$CI95,digits,printlen) } cat("\nFitted model parameters & likelihood:\n") if(x$model=="BM"){ obj<-data.frame(round(x$sig2,digits),round(x$logLik,digits)) colnames(obj)<-c("sig2","log-likelihood") rownames(obj)<-"" print(obj) } else if(x$model=="OU"){ obj<-data.frame(round(x$sig2,digits),round(x$alpha,digits), round(x$logLik,digits)) colnames(obj)<-c("sigma^2","alpha","logLik") rownames(obj)<-"" print(obj) } else if(x$model=="EB"){ obj<-data.frame(round(x$sig2,digits),round(x$r,digits), round(x$logLik,digits)) colnames(obj)<-c("sigma^2","r","logLik") rownames(obj)<-"" print(obj) } if(x$convergence==0) cat("\nR thinks it has found the ML solution.\n\n") else cat("\nOptimization may not have converged.\n\n") } ## S3 logLik method for "anc.ML" object class logLik.anc.ML<-function(object,...){ lik<-object$logLik if(object$model=="BM") attr(lik,"df")<-length(object$ace)+1 else if(object$model=="EB") attr(lik,"df")<-length(object$ace)+2 else if(object$model=="OU") attr(lik,"df")<-length(object$ace)+2 lik } phytools/R/phyl.cca.R0000644000176200001440000001054414375517350014176 0ustar liggesusers# function does phylogenetic canonical correlation analysis (Revell & Harrison 2008) # written by Liam Revell 2011, 2012, 2013, 2015 phyl.cca<-function(tree,X,Y,lambda=1.0,fixed=TRUE){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") # misc n<-length(tree$tip) mX<-ncol(X) mY<-ncol(Y) # compute C C<-vcv.phylo(tree) # if X & Y are data frames, convert to matrix if(is.data.frame(X)) X<-as.matrix(X) if(is.data.frame(Y)) Y<-as.matrix(Y) # check to see if X & Y have rownames if(is.null(rownames(X))){ message("X is missing rownames; assuming same order as tree$tip.label") if(nrow(X)!=length(tree$tip)) warning("X does not have the correct number of rows") else rownames(X)<-tree$tip.label } if(is.null(rownames(Y))){ message("Y is missing rownames; assuming same order as tree$tip.label") if(nrow(Y)!=length(tree$tip)) warning("Y does not have the correct number of rows") else rownames(Y)<-tree$tip.label } # reorder Y & C by tree$tip.label C<-C[tree$tip.label,tree$tip.label] # I think this is superfluous X<-as.matrix(X[tree$tip.label,]) Y<-as.matrix(Y[tree$tip.label,]) # set or optimize lambda if(fixed) logL<-likMlambda(lambda,cbind(X,Y),C) else { temp<-optimize(f=likMlambda,interval=c(0,maxLambda(tree)),X=cbind(X,Y),C=C,maximum=TRUE) logL<-temp$objective lambda<-temp$maximum } C<-lambda.transform(lambda,C) # invert C invC<-solve(C) # compute means aX<-colSums(invC%*%X)/sum(invC) aY<-colSums(invC%*%Y)/sum(invC) # compute cov & cross-cov matrices one<-as.matrix(rep(1,n)) SigXX<-t(X-one%*%aX)%*%invC%*%(X-one%*%aX)/(n-1) SigXY<-t(X-one%*%aX)%*%invC%*%(Y-one%*%aY)/(n-1) SigYX<-t(SigXY) SigYY<-t(Y-one%*%aY)%*%invC%*%(Y-one%*%aY)/(n-1) # compute canonical coefficients A<-eigen(solve(SigXX)%*%SigXY%*%solve(SigYY)%*%SigYX) B<-eigen(solve(SigYY)%*%SigYX%*%solve(SigXX)%*%SigXY) # compute canonical variables, rescale U<-X%*%A$vectors[,1:min(mX,mY)] aU<-colSums(invC%*%U)/sum(invC) vcvU<-t(U-one%*%aU)%*%invC%*%(U-one%*%aU)/(n-1) U<-(U-one%*%aU)%*%Diag(sqrt(Diag(1/vcvU))) V<-Y%*%B$vectors[,1:min(mX,mY)] aV<-colSums(invC%*%V)/sum(invC) vcvV<-t(V-one%*%aV)%*%invC%*%(V-one%*%aV)/(n-1) V<-(V-one%*%aV)%*%Diag(sqrt(Diag(1/vcvV))) # compute canonical correlations aU<-colSums(invC%*%U)/sum(invC) aV<-colSums(invC%*%V)/sum(invC) Ccv<-round(t(cbind(U,V))%*%invC%*%cbind(U,V)/(n-1),10) ccs<-Diag(Ccv[1:min(mX,mY),(1+min(mX,mY)):(2*min(mX,mY))]) if(all(Im(ccs)==0)) ccs<-Re(ccs) pos<-2*(as.numeric(ccs>0)-0.5) ccs<-ccs*pos # reorient variables, reorient & rescale coefficents U<-U*one%*%pos xcoef<-A$vectors[,1:min(mX,mY)]*matrix(1,mX,1)%*%pos%*%Diag(sqrt(Diag(1/vcvU))) ycoef<-B$vectors[,1:min(mX,mY)]%*%Diag(sqrt(Diag(1/vcvV))) # conduct hypothesis tests W_lh<-rep(1,min(mX,mY)) chiSq<-vector() df<-vector() for(i in 1:min(mX,mY)){ for(j in i:min(mX,mY)) W_lh[i]<-W_lh[i]*(1-ccs[j]^2) chiSq[i]<--((n-1)-(mX+mY+1)/2)*log(W_lh[i]) df[i]<-(mX+1-i)*(mY+1-i) } pvalues<-pchisq(chiSq,df=df,lower.tail=F) # add row & column names if(!is.null(colnames(X))) rownames(xcoef)<-colnames(X) if(!is.null(colnames(Y))) rownames(ycoef)<-colnames(Y) temp<-vector() for(i in 1:min(mX,mY)) temp[i]<-paste("CA",i,sep="") colnames(xcoef)<-temp colnames(ycoef)<-temp colnames(U)<-temp colnames(V)<-temp # return as list lambda<-c(lambda,logL); names(lambda)<-c("lambda","logL") obj<-list(cor=ccs,xcoef=xcoef,ycoef=ycoef,xscores=U,yscores=V,lambda=lambda,chisq=chiSq,p=pvalues) class(obj)<-"phyl.cca" obj } ## internal function replace Diag ## modified from a suggestion by Travis Ingram 2013 Diag<-function(X){ if(length(X)==1) X else diag(X) } ## S3 print method print.phyl.cca<-function(x,digits=6,...){ cat("\nObject of class \"phyl.cca\" from a phylogenetic canonical") cat("\n correlation analysis.\n\n") object<-data.frame(round(x$cor,digits),round(x$chisq,digits),round(x$p,digits)) colnames(object)<-c("correlation","X^2","P-value") rownames(object)<-paste("CC",1:length(x$cor),sep=":") cat("Summary of results:\n") print(object) cat("\nAssumed or estimated value of lambda:\n") print(round(x$lambda,digits)) cat("\nCanonical x coefficients:\n") print(as.data.frame(round(x$xcoef,digits))) cat("\nCanonical y coefficients:\n") print(as.data.frame(round(x$ycoef,digits))) cat("\n") } phytools/R/writeAncestors.R0000644000176200001440000000757114375517350015517 0ustar liggesusers## function writes a "phylo" object to a Newick string with ancestor state estimates ## written by Liam J. Revell 2013, 2015, 2022 writeAncestors<-function(tree,Anc=NULL,file="",digits=6,format=c("phylip","nexus"),...){ format=format[1] if(hasArg(CI)) CI<-list(...)$CI else CI<-TRUE if(is.null(Anc)){ if(hasArg(x)){ x<-list(...)$x if(inherits(tree,"multiPhylo")){ if(is.list(x)) Anc<-mapply(fastAnc,tree,x,MoreArgs=list(CI=CI),SIMPLIFY=FALSE) else Anc<-lapply(tree,fastAnc,x=x,CI=CI) } else if(inherits(tree,"phylo")){ if(is.list(x)){ Anc<-lapply(x,fastAnc,tree=tree,CI=CI) tree<-repPhylo(tree,length(x)) class(tree)<-"multiPhylo" } else Anc<-fastAnc(tree,x,CI=CI) } } else stop("must have argument 'Anc' or 'x'") } if(format=="phylip"){ if(inherits(tree,"multiPhylo")) XX<-mapply(writeAnc,tree,Anc,MoreArgs=list(digits=digits)) else if(inherits(tree,"phylo")) XX<-writeAnc(tree,Anc,digits) else stop("tree should be an object of class 'phylo' or 'multiPhylo'") write(XX,file) invisible(XX) } else if(format=="nexus"){ writeNex(tree,Anc,file,digits) } } # internal function to create a Nexus style output file # written by Liam J. Revell 2013 writeNex<-function(tree,Anc,file="",digits){ if(inherits(tree,"multiPhylo")) N<-length(tree) else { N<-1 tree<-list(tree) Anc<-list(Anc) } n<-length(tree[[1]]$tip.label) write("#NEXUS",file) write(paste("[R-package PHYTOOLS, ",date(),"]\n",sep=""),file,append=TRUE) write("BEGIN TAXA;",file,append=TRUE) write(paste("\tDIMENSIONS NTAX = ",n,";",sep=""),file,append=TRUE) write("\tTAXLABELS",file,append=TRUE) trans<-tree[[1]]$tip.label; trans<-sort(trans) for(i in 1:n) write(paste("\t\t",trans[i],sep=""),file,append=TRUE) write("\t;",file,append=TRUE) write("END;",file,append=TRUE) write("BEGIN TREES;\n\tTRANSLATE",file,append=TRUE) for(i in 1:(n-1)) write(paste("\t\t",i,"\t",trans[i],",",sep=""),file,append=TRUE) write(paste("\t\t",i+1,"\t",trans[i+1],sep=""),file,append=TRUE) write("\t;",file,append=TRUE) for(i in 1:N){ tree[[i]]$tip.label<-sapply(tree[[i]]$tip.label,function(x) which(x==trans)) write(paste("\tTREE * UNTITLED = [&R] ",writeAnc(tree[[i]],Anc[[i]],digits),sep=""),file,append=TRUE) } write("END;",file,append=TRUE) } # internal function to write the Newick string with ancestor states # written by Liam J. Revell writeAnc<-function(tree,Anc,digits){ tree<-reorder.phylo(tree,"cladewise") n<-length(tree$tip.label) if(!is.list(Anc)) Anc<-list(ace=Anc) Anc$ace<-Anc$ace[order(names(Anc$ace))] Anc$ace<-round(Anc$ace,digits) if(!is.null(Anc$CI95)){ Anc$CI95<-round(Anc$CI95,digits) tree$node.label<-paste("[&CI={",Anc$CI95[,1],",",Anc$CI95[,2],"},ancstate={",Anc$ace,"}]",sep="") } else { Anc$CI95<-Anc$CI95[names(Anc$ace),] tree$node.label<-paste("[&ancstate={",Anc$ace,"}]",sep="") } tree$edge.length<-round(tree$edge.length,digits) string<-vector(); string[1]<-"("; j<-2 for(i in 1:nrow(tree$edge)){ if(tree$edge[i,2]<=n){ string[j]<-tree$tip.label[tree$edge[i,2]]; j<-j+1 if(!is.null(tree$edge.length)){ string[j]<-paste(c(":",tree$edge.length[i]),collapse="") j<-j+1 } v<-which(tree$edge[,1]==tree$edge[i,1]); k<-i while(length(v)>0&&k==v[length(v)]){ string[j]<-")"; j<-j+1 string[j]<-tree$node.label[tree$edge[k,1]-n]; j<-j+1 w<-which(tree$edge[,2]==tree$edge[k,1]) if(!is.null(tree$edge.length)){ string[j]<-paste(c(":",tree$edge.length[w]),collapse="") j<-j+1 } v<-which(tree$edge[,1]==tree$edge[w,1]); k<-w } string[j]<-","; j<-j+1 } else if(tree$edge[i,2]>=n){ string[j]<-"("; j<-j+1 } } if(is.null(tree$edge.length)) string<-c(string[1:(length(string)-1)],";") else string<-c(string[1:(length(string)-2)],";") string<-paste(string,collapse="") return(string) } phytools/R/fitpolyMk.R0000644000176200001440000004154014527734241014452 0ustar liggesusers## fitpolyMk ## fits several polymorphic discrete character evolution models ## written by Liam J. Revell 2019, 2020, 2022, 2023 anova.fitpolyMk<-function(object,...) anova.fitMk(object,...) as.Qmatrix.fitpolyMk<-function(x,...){ class(x)<-"fitMk" as.Qmatrix(x,...) } Combinations<-function(n,r,v=1:n){ if(n!=length(v)) stop("n and v should have the same length") else return(t(combn(v,r))) } fitpolyMk<-function(tree,x,model="SYM",ordered=FALSE,...){ if(hasArg(return_matrix)) return_matrix<-list(...)$return_matrix else return_matrix<-FALSE if(return_matrix) quiet<-TRUE else { if(hasArg(quiet)) quiet<-list(...)$quiet else quiet<-FALSE } if(is.factor(x)) x<-setNames(as.character(x),names(x)) if(is.matrix(x)) X<-strsplit(colnames(x),"+",fixed=TRUE) else X<-strsplit(x,"+",fixed=TRUE) ns<-sapply(X,length) ## get the states states<-sort(unique(unlist(X))) ## check if ordered if(ordered){ if(hasArg(max.poly)) max.poly<-list(...)$max.poly else if(hasArg(max.states)){ max.states<-list(...)$max.states max.poly<-max.states } else max.poly<-max(ns) ## get any user-supplied ordering if(hasArg(order)) order<-list(...)$order else order<-NULL if(!is.null(order)){ if(setequal(order,states)) states<-order else cat("order & states do not match. using alphabetical order.\n") } } if(all(ns==1)&&return_matrix==FALSE){ cat("No polymorphic species found. Use fitMk.\n\n") object<-NULL } else { ## fix the order of the input data if(is.matrix(x)){ Levs<-sapply(X,function(x) paste(sort(x),collapse="+")) colnames(x)<-Levs } else x<-sapply(X,function(x) paste(sort(x),collapse="+")) if(ordered){ ss<-vector() for(i in 1:(length(states)-1)){ ss<-c(ss,states[i]) for(j in (i+1):length(states)) if((j-i)0 &&(0%in%c(length(SDij),length(SDji))) &&(1%in%c(length(SDij),length(SDji)))){ if(model=="ER"){ tmodel[i,j]<-tmodel[j,i]<-1 } else if(model%in%c("ARD","SYM")){ index<-index+1 tmodel[i,j]<-index if(model=="SYM") tmodel[j,i]<-index else { tmodel[j,i]<-index+1 index<-index+1 } } else if(model=="transient") { if(length(poly[[i]])>length(poly[[j]])){ tmodel[i,j]<-1 tmodel[j,i]<-2 } else { tmodel[i,j]<-2 tmodel[j,i]<-1 } } } } } if(!quiet){ cat("\nThis is the design matrix of the fitted model.\nDoes it make sense?\n\n") print(tmodel) cat("\n") flush.console() } if(is.matrix(x)){ X<-matrix(0,nrow(x),length(ss),dimnames=list(rownames(x),ss)) X[rownames(x),colnames(x)]<-x } else X<-to.matrix(x,ss) if(return_matrix) return(X) object<-fitMk(tree,X,model=tmodel,...) } object$model<-model object$ordered<-ordered if(ordered) attr(object$ordered,"max.poly")<-max.poly class(object)<-"fitpolyMk" object } ## print method for objects of class "fitpolyMk" print.fitpolyMk<-function(x,digits=6,...){ cat("Object of class \"fitpolyMk\".\n\n") if(x$ordered){ cat("Evolution was modeled as \'ordered\' (i.e., transitions are assumed\n") cat(paste("to occur ",x$states[1]," <-> ",x$states[2]," <-> ",x$states[3], " and so on) ",sep="")) cat(paste("using the \"",x$model,"\" model.\n\n",sep="")) } else { cat("Evolution was modeled as \'unordered\' ") cat(paste("using the \"",x$model,"\" model.\n\n",sep="")) } cat("Fitted (or set) value of Q:\n") Q<-matrix(NA,length(x$states),length(x$states)) Q[]<-c(0,x$rates)[x$index.matrix+1] diag(Q)<-0 diag(Q)<--rowSums(Q) colnames(Q)<-rownames(Q)<-x$states print(round(Q,digits)) cat("\nFitted (or set) value of pi:\n") print(round(x$pi,digits)) cat(paste("\nLog-likelihood:",round(x$logLik,digits),"\n")) cat(paste("\nOptimization method used was \"",x$method,"\"\n\n",sep="")) if(x$opt_results$convergence==0) cat("R thinks it has found the ML solution.\n\n") else cat("R thinks optimization may not have converged.\n\n") } ## logLik method for objects of class "fitpolyMk" logLik.fitpolyMk<-function(object,...){ lik<-object$logLik attr(lik,"df")<-length(object$rates) lik } ## S3 plot method for objects of class "fitpolyMk" plot.fitpolyMk<-function(x,...){ if(hasArg(signif)) signif<-list(...)$signif else signif<-3 if(hasArg(main)) main<-list(...)$main else main<-NULL if(hasArg(cex.main)) cex.main<-list(...)$cex.main else cex.main<-1.2 if(hasArg(cex.traits)) cex.traits<-list(...)$cex.traits else cex.traits<-1 if(hasArg(cex.rates)) cex.rates<-list(...)$cex.rates else cex.rates<-0.6 if(hasArg(mar)) mar<-list(...)$mar else mar<-c(1.1,1.1,3.1,1.1) if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-1 if(hasArg(asp)) asp<-list(...)$asp else asp<-1 if(hasArg(add)) add<-list(...)$add else add<-FALSE if(hasArg(xlim)) xlim<-list(...)$xlim else xlim<-c(-1.2,1.2) if(hasArg(ylim)) ylim<-list(...)$ylim else ylim<-c(-1.2,1.2) if(hasArg(offset)) offset<-list(...)$offset else offset<-1.5 if(hasArg(spacer)) spacer<-list(...)$spacer else spacer<-0.1 Q<-matrix(NA,length(x$states),length(x$states)) Q[]<-c(0,x$rates)[x$index.matrix+1] diag(Q)<-0 if(!add) plot.new() par(mar=mar) plot.window(xlim=xlim,ylim=ylim,asp=asp) if(!is.null(main)) title(main=main,cex.main=cex.main) nstates<-length(x$states) if(x$ordered){ if(attr(x$ordered,"max.poly")==2){ step<-360/nstates angles<-seq(-floor(nstates/2)*step,360-ceiling(nstates/2)*step,by=step)/180*pi if(nstates==2) angles<-angles+pi/2 v.x<-sin(angles) v.y<-cos(angles) for(i in 1:nstates) for(j in 1:nstates){ if(if(!isSymmetric(Q)) i!=j else i>j){ dx<-v.x[j]-v.x[i] dy<-v.y[j]-v.y[i] slope<-abs(dy/dx) shift.x<-0.02*sin(atan(dy/dx))*sign(j-i)*if(dy/dx>0) 1 else -1 shift.y<-0.02*cos(atan(dy/dx))*sign(j-i)*if(dy/dx>0) -1 else 1 s<-c(v.x[i]+spacer*cos(atan(slope))*sign(dx)+ if(isSymmetric(Q)) 0 else shift.x, v.y[i]+spacer*sin(atan(slope))*sign(dy)+ if(isSymmetric(Q)) 0 else shift.y) e<-c(v.x[j]+spacer*cos(atan(slope))*sign(-dx)+ if(isSymmetric(Q)) 0 else shift.x, v.y[j]+spacer*sin(atan(slope))*sign(-dy)+ if(isSymmetric(Q)) 0 else shift.y) if(x$index.matrix[i,j]!=0){ if(abs(diff(c(i,j)))==1||abs(diff(c(i,j)))==(nstates-1)) text(mean(c(s[1],e[1]))+offset*shift.x, mean(c(s[2],e[2]))+offset*shift.y, round(Q[i,j],signif),cex=cex.rates, srt=atan(asp*dy/dx)*180/pi) else text(mean(c(s[1],e[1]))+0.3*diff(c(s[1],e[1]))+ offset*shift.x, mean(c(s[2],e[2]))+0.3*diff(c(s[2],e[2]))+ offset*shift.y, round(Q[i,j],signif),cex=cex.rates, srt=atan(asp*dy/dx)*180/pi) arrows(s[1],s[2],e[1],e[2],length=0.05, code=if(isSymmetric(Q)) 3 else 2,lwd=lwd) } } } text(v.x,v.y,x$states,cex=cex.traits, col=make.transparent(par()$fg,0.7)) } else { nlevs<-attr(x$ordered,"max.poly") Ns<-inv.ncombn2(nstates,nlevs) v.x<-v.y<-vector() xx<-seq(-1,1,length.out=Ns) for(i in 1:Ns){ for(j in 1:min(nlevs,Ns-i+1)){ v.x<-c(v.x,mean(xx[i:(i+j-1)])) v.y<-c(v.y,1-2*(j-1)/(nlevs-1)) } } for(i in 1:nstates) for(j in 1:nstates){ if(if(!isSymmetric(Q)) i!=j else i>j){ dx<-v.x[j]-v.x[i] dy<-v.y[j]-v.y[i] slope<-abs(dy/dx) shift.x<-0.02*sin(atan(dy/dx))*sign(j-i)*if(dy/dx>0) 1 else -1 shift.y<-0.02*cos(atan(dy/dx))*sign(j-i)*if(dy/dx>0) -1 else 1 s<-c(v.x[i]+spacer*cos(atan(slope))*sign(dx)+ if(isSymmetric(Q)) 0 else shift.x, v.y[i]+spacer*sin(atan(slope))*sign(dy)+ if(isSymmetric(Q)) 0 else shift.y) e<-c(v.x[j]+spacer*cos(atan(slope))*sign(-dx)+ if(isSymmetric(Q)) 0 else shift.x, v.y[j]+spacer*sin(atan(slope))*sign(-dy)+ if(isSymmetric(Q)) 0 else shift.y) if(x$index.matrix[i,j]!=0){ text(mean(c(s[1],e[1]))+offset*shift.x, mean(c(s[2],e[2]))+offset*shift.y, round(Q[i,j],signif),cex=cex.rates, srt=atan(asp*dy/dx)*180/pi) arrows(s[1],s[2],e[1],e[2],length=0.05, code=if(isSymmetric(Q)) 3 else 2,lwd=lwd) } } } text(v.x,v.y,x$states,cex=cex.traits, col=make.transparent(par()$fg,0.7)) } } else { Ns<-inv.ncombn(nstates) step.y<-2/(Ns-1) v.x<-v.y<-vector() for(i in 1:Ns){ nc<-ncombn(Ns,i) v.x<-c(v.x,if(nc>1) seq(-1,1,by=2/(nc-1)) else 0) v.y<-c(v.y,rep(1-rep((i-1)*step.y,nc))) } for(i in 1:nstates) for(j in 1:nstates) if(if(!isSymmetric(Q)) i!=j else i>j){ dx<-v.x[j]-v.x[i] dy<-v.y[j]-v.y[i] slope<-abs(dy/dx) shift.x<-0.02*sin(atan(dy/dx))*sign(j-i)*if(dy/dx>0) 1 else -1 shift.y<-0.02*cos(atan(dy/dx))*sign(j-i)*if(dy/dx>0) -1 else 1 s<-c(v.x[i]+spacer*cos(atan(slope))*sign(dx)+ if(isSymmetric(Q)) 0 else shift.x, v.y[i]+spacer*sin(atan(slope))*sign(dy)+ if(isSymmetric(Q)) 0 else shift.y) e<-c(v.x[j]+spacer*cos(atan(slope))*sign(-dx)+ if(isSymmetric(Q)) 0 else shift.x, v.y[j]+spacer*sin(atan(slope))*sign(-dy)+ if(isSymmetric(Q)) 0 else shift.y) if(x$index.matrix[i,j]!=0){ if(abs(diff(c(i,j)))==1||abs(diff(c(i,j)))==(nstates-1)) text(mean(c(s[1],e[1]))+offset*shift.x, mean(c(s[2],e[2]))+offset*shift.y, round(Q[i,j],signif),cex=cex.rates, srt=atan(asp*dy/dx)*180/pi) else text(mean(c(s[1],e[1]))+0.3*diff(c(s[1],e[1]))+ offset*shift.x, mean(c(s[2],e[2]))+0.3*diff(c(s[2],e[2]))+ offset*shift.y, round(Q[i,j],signif),cex=cex.rates, srt=atan(asp*dy/dx)*180/pi) arrows(s[1],s[2],e[1],e[2],length=0.05, code=if(isSymmetric(Q)) 3 else 2,lwd=lwd) } } text(v.x,v.y,x$states,cex=cex.traits, col=make.transparent(par()$fg,0.7)) } } ## internally used functions to either calculate the number of combinations ## of r elements of n or calculate the number of elements n from the sum of ## all combinations from 1:r of n elements ncombn<-function(n,r) factorial(n)/(factorial(n-r)*factorial(r)) inv.ncombn<-function(N){ n<-Nc<-1 while(Nc!=N){ Nc<-0 for(r in 1:n) Nc<-Nc+factorial(n)/(factorial(n-r)*factorial(r)) n<-n+1 } return(n-1) } inv.ncombn2<-function(N,m){ n<-2 Nc<-0 while(Nc!=N){ Nc<-sum((n:1)[1:min(m,n)]) n<-n+1 } return(n-1) } ## maybe this should be plot.mkModel or something? ## then you create a model class & plot it? graph.polyMk<-function(k=2,model="SYM",ordered=FALSE,...){ if(hasArg(states)) states<-list(...)$states else states<-0:(k-1) if(hasArg(max.poly)) max.poly<-list(...)$max.poly else max.poly<-k if(hasArg(main)) main<-list(...)$main else main<-NULL if(hasArg(cex.main)) cex.main<-list(...)$cex.main else cex.main<-1.2 if(hasArg(cex.traits)) cex.traits<-list(...)$cex.traits else cex.traits<-1 if(hasArg(mar)) mar<-list(...)$mar else mar<-c(1.1,1.1,3.1,1.1) if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-1 if(hasArg(quiet)) quiet<-list(...)$quiet else quiet<-FALSE if(hasArg(xlim)) xlim<-list(...)$xlim else xlim<-c(-1.2,1.2) if(hasArg(ylim)) ylim<-list(...)$ylim else ylim<-c(-1.2,1.2) if(hasArg(plot)) plot<-list(...)$plot else plot<-TRUE if(hasArg(asp)) asp<-list(...)$asp else asp<-1 if(ordered){ ss<-vector() for(i in 1:(length(states)-1)){ ss<-c(ss,states[i]) for(j in (i+1):length(states)) if((j-i)0 &&(0%in%c(length(SDij),length(SDji))) &&(1%in%c(length(SDij),length(SDji)))){ if(model=="ER"){ tmodel[i,j]<-tmodel[j,i]<-1 } else if(model%in%c("ARD","SYM")){ index<-index+1 tmodel[i,j]<-index if(model=="SYM") tmodel[j,i]<-index else { tmodel[j,i]<-index+1 index<-index+1 } } else if(model=="transient"){ if(length(poly[[i]])>length(poly[[j]])){ tmodel[i,j]<-1 tmodel[j,i]<-2 } else { tmodel[i,j]<-2 tmodel[j,i]<-1 } } } } } if(plot){ spacer<-if(hasArg(spacer)) list(...)$spacer else 0.1 plot.new() par(mar=mar) plot.window(xlim=xlim,ylim=ylim,asp=asp) if(!is.null(main)) title(main=main,cex.main=cex.main) if(ordered){ if(max.poly==2){ step<-360/nstates angles<-seq(-floor(nstates/2)*step,360-ceiling(nstates/2)*step,by=step)/180*pi if(k==2) angles<-angles+pi/2 v.x<-sin(angles) v.y<-cos(angles) for(i in 1:nstates) for(j in 1:nstates){ if(if(!isSymmetric(tmodel)) i!=j else i>j){ dx<-v.x[j]-v.x[i] dy<-v.y[j]-v.y[i] slope<-abs(dy/dx) shift.x<-0.02*sin(atan(dy/dx))*sign(j-i)*if(dy/dx>0) 1 else -1 shift.y<-0.02*cos(atan(dy/dx))*sign(j-i)*if(dy/dx>0) -1 else 1 s<-c(v.x[i]+spacer*cos(atan(slope))*sign(dx)+ if(isSymmetric(tmodel)) 0 else shift.x, v.y[i]+spacer*sin(atan(slope))*sign(dy)+ if(isSymmetric(tmodel)) 0 else shift.y) e<-c(v.x[j]+spacer*cos(atan(slope))*sign(-dx)+ if(isSymmetric(tmodel)) 0 else shift.x, v.y[j]+spacer*sin(atan(slope))*sign(-dy)+ if(isSymmetric(tmodel)) 0 else shift.y) if(tmodel[i,j]!=0){ arrows(s[1],s[2],e[1],e[2],length=0.05, code=if(isSymmetric(tmodel)) 3 else 2,lwd=lwd) } } } text(v.x,v.y,colnames(tmodel),cex=cex.traits, col=make.transparent(par()$fg,0.7)) } else { nlevs<-max.poly Ns<-inv.ncombn2(nstates,nlevs) v.x<-v.y<-vector() xx<-seq(-1,1,length.out=Ns) for(i in 1:k){ for(j in 1:min(nlevs,Ns-i+1)){ v.x<-c(v.x,mean(xx[i:(i+j-1)])) v.y<-c(v.y,1-2*(j-1)/(nlevs-1)) } } for(i in 1:nstates) for(j in 1:nstates){ if(if(!isSymmetric(tmodel)) i!=j else i>j){ dx<-v.x[j]-v.x[i] dy<-v.y[j]-v.y[i] slope<-abs(dy/dx) shift.x<-0.02*sin(atan(dy/dx))*sign(j-i)*if(dy/dx>0) 1 else -1 shift.y<-0.02*cos(atan(dy/dx))*sign(j-i)*if(dy/dx>0) -1 else 1 s<-c(v.x[i]+spacer*cos(atan(slope))*sign(dx)+ if(isSymmetric(tmodel)) 0 else shift.x, v.y[i]+spacer*sin(atan(slope))*sign(dy)+ if(isSymmetric(tmodel)) 0 else shift.y) e<-c(v.x[j]+spacer*cos(atan(slope))*sign(-dx)+ if(isSymmetric(tmodel)) 0 else shift.x, v.y[j]+spacer*sin(atan(slope))*sign(-dy)+ if(isSymmetric(tmodel)) 0 else shift.y) if(tmodel[i,j]!=0){ arrows(s[1],s[2],e[1],e[2],length=0.05, code=if(isSymmetric(tmodel)) 3 else 2,lwd=lwd) } } } text(v.x,v.y,rownames(tmodel),cex=cex.traits, col=make.transparent(par()$fg,0.7)) } } else { step.y<-2/(k-1) v.x<-v.y<-vector() for(i in 1:k){ nc<-ncombn(k,i) v.x<-c(v.x,if(nc>1) seq(-1,1,by=2/(nc-1)) else 0) v.y<-c(v.y,rep(1-rep((i-1)*step.y,nc))) } for(i in 1:ncol(tmodel)) for(j in 1:ncol(tmodel)){ if(if(!isSymmetric(tmodel)) i!=j else i>j){ dx<-v.x[j]-v.x[i] dy<-v.y[j]-v.y[i] slope<-abs(dy/dx) shift.x<-0.02*sin(atan(dy/dx))*sign(j-i)*if(dy/dx>0) 1 else -1 shift.y<-0.02*cos(atan(dy/dx))*sign(j-i)*if(dy/dx>0) -1 else 1 s<-c(v.x[i]+spacer*cos(atan(slope))*sign(dx)+ if(isSymmetric(tmodel)) 0 else shift.x, v.y[i]+spacer*sin(atan(slope))*sign(dy)+ if(isSymmetric(tmodel)) 0 else shift.y) e<-c(v.x[j]+spacer*cos(atan(slope))*sign(-dx)+ if(isSymmetric(tmodel)) 0 else shift.x, v.y[j]+spacer*sin(atan(slope))*sign(-dy)+ if(isSymmetric(tmodel)) 0 else shift.y) if(tmodel[i,j]!=0){ arrows(s[1],s[2],e[1],e[2],length=0.05, code=if(isSymmetric(tmodel)) 3 else 2,lwd=lwd) } } } text(v.x,v.y,rownames(tmodel),cex=cex.traits, col=make.transparent(par()$fg,0.7)) } } invisible(tmodel) } phytools/R/writeNexus.R0000644000176200001440000000213314375517350014645 0ustar liggesusers# function # written by Liam J. Revell 2012, 2015 writeNexus<-function(tree,file=""){ if(inherits(tree,"multiPhylo")) N<-length(tree) else { N<-1 tree<-list(tree) } n<-length(tree[[1]]$tip.label) write("#NEXUS",file) write(paste("[R-package PHYTOOLS, ",date(),"]\n",sep=""),file,append=TRUE) write("BEGIN TAXA;",file,append=TRUE) write(paste("\tDIMENSIONS NTAX = ",n,";",sep=""),file,append=TRUE) write("\tTAXLABELS",file,append=TRUE) trans<-tree[[1]]$tip.label; trans<-sort(trans) for(i in 1:n) write(paste("\t\t",trans[i],sep=""),file,append=TRUE) write("\t;",file,append=TRUE) write("END;",file,append=TRUE) write("BEGIN TREES;\n\tTRANSLATE",file,append=TRUE) for(i in 1:(n-1)) write(paste("\t\t",i,"\t",trans[i],",",sep=""),file,append=TRUE) write(paste("\t\t",i+1,"\t",trans[i+1],sep=""),file,append=TRUE) write("\t;",file,append=TRUE) for(i in 1:N){ tree[[i]]$tip.label<-sapply(tree[[i]]$tip.label,function(x) which(x==trans)) write(paste("\tTREE * UNTITLED = [&R] ",write.tree(tree[[i]]),sep=""),file,append=TRUE) } write("END;",file,append=TRUE) } phytools/R/phyl.resid.R0000644000176200001440000000375314375517350014562 0ustar liggesusers# function to fit phylogenetic regression and compute residuals # multiple morphological traits in Y, size in x # written by Liam Revell 2011, 2015 ref. Revell (2009; Evolution) phyl.resid<-function(tree,x,Y,method="BM"){ # check tree if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") # check and sort data # X X<-cbind(1,x) if(is.null(rownames(X))){ print("x has no names. function will assume that the order of x matches tree$tip.label") rownames(X)<-tree$tip.label } else X<-X[tree$tip.label,] # sort # Y Y<-as.matrix(Y) if(is.null(rownames(Y))){ print("y has no names. function will assume that the order of y matches tree$tip.label") rownames(Y)<-tree$tip.label } else Y<-as.matrix(Y[tree$tip.label,]) # sort # analyze if(method=="BM"){ C<-vcv.phylo(tree) beta<-solve(t(X)%*%solve(C)%*%X)%*%t(X)%*%solve(C)%*%Y resid<-Y-X%*%beta return(list(beta=beta,resid=resid)) } else if(method=="lambda"){ C<-vcv.phylo(tree) maxLambda<-max(C)/max(C[upper.tri(C)]) lambda<-vector() logL<-vector() beta<-matrix(NA,ncol(X),ncol(Y),dimnames=list(colnames(X),colnames(Y))) for(i in 1:ncol(Y)){ res<-optimize(f=likelihood.lambda,interval=c(0,maxLambda),y=Y[,i],X=X,C=C,maximum=TRUE) lambda[i]<-res$maximum logL[i]<-as.numeric(res$objective) C.l<-lambda.transform(lambda[i],C) beta[,i]<-solve(t(X)%*%solve(C.l)%*%X)%*%t(X)%*%solve(C.l)%*%Y[,i] } resid<-Y-X%*%beta return(list(beta=beta,lambda=lambda,logL=logL,resid=resid)) } } # likelihood function for the regression model with lambda likelihood.lambda<-function(lambda,y,X,C){ n<-nrow(C) C.lambda<-lambda.transform(lambda,C) beta<-solve(t(X)%*%solve(C.lambda)%*%X)%*%(t(X)%*%solve(C.lambda)%*%y) sig2e<-as.double((1/n)*(t(y-X%*%beta)%*%solve(C.lambda)%*%(y-X%*%beta))) logL<--(1/2)*t(y-X%*%beta)%*%solve(sig2e*C.lambda)%*%(y-X%*%beta)-(1/2)*determinant(sig2e*C.lambda,logarithm=TRUE)$modulus-(n/2)*log(2*pi) return(logL) } phytools/R/map.to.singleton.R0000644000176200001440000001265114421332645015667 0ustar liggesusers## convert stochastic map style tree to a tree with singleton nodes ## written by Liam J. Revell 2013, 2015 map.to.singleton<-function(tree){ if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".") tree<-reorderSimmap(tree) Nedge<-nrow(tree$edge)+sum(sapply(tree$maps,length)-1) Ntips<-length(tree$tip.label) edge<-tree$edge edge[edge>Ntips]<--edge[edge>Ntips]+Ntips xx<-vector(); edge.length<-vector(); ii<-1 for(i in 1:nrow(tree$edge)){ if(length(tree$maps[[i]])==1){ xx[ii]<-names(tree$maps[[i]]) edge.length[ii]<-tree$maps[[i]] ii<-ii+1 } else { nn<-length(tree$maps[[i]]) new<-matrix(NA,nn,2) new[1,1]<-edge[ii,1] nextnode<--1+if(i>1) min(c(edge[1:(ii-1),],edge[ii,1])) else edge[ii,1] new[,2]<-nextnode-0:(nn-1) for(j in 2:nn) new[j,1]<-new[j-1,2] if(edge[ii,2]>0) new[nrow(new),2]<-edge[ii,2] if(i==nrow(tree$edge)) edge<-rbind(edge[1:(ii-1),],new) else { ee<-edge[(ii+1):nrow(edge),] ee[ee1) lines(xx,yy,lwd=2,lend=2,col=colors[which(cw$edge[,1]==i)]) } # plot points for(i in 1:nrow(X)) points(X[i,],rep(y[cw$edge[i,2]],2),pch=21,bg="gray") # plot tip labels for(i in 1:n) text(X[which(cw$edge[,2]==i),2],y[i],tree$tip.label[i],pos=4,offset=0.3) PP<-list(type="phylogram",use.edge.length=TRUE,node.pos=1, show.tip.label=TRUE,show.node.label=FALSE, font=par()$font,cex=par()$cex,adj=0,srt=0,no.margin=FALSE,label.offset=0.3, x.lim=xlim,y.lim=c(1,max(y)), direction="rightwards",tip.color="black",Ntip=Ntip(cw),Nnode=cw$Nnode, edge=tree$edge,xx=sapply(1:(Ntip(cw)+cw$Nnode), function(x,y,z) y[match(x,z)],y=X,z=cw$edge),yy=y) assign("last_plot.phylo",PP,envir=.PlotPhyloEnv) } ## function to reorder the edges of the tree for postorder traversal should *only* be used ## internally to plotTree.singletons (i.e., is not designed for general use). ## written by Liam J. Revell 2013 reorderPhylo<-function(x,order="pruningwise",index.only=FALSE,...){ if(index.only) stop("index.only=TRUE not permitted") if(order!="pruningwise") stop("function only returns trees in modified pruningwise format for plotTree.singletons") if(attr(x,"order")!="cladewise") stop("input tree should be in cladewise order.") aa<-lapply(x$edge[,1],getDescendants,tree=x) ll<-sapply(aa,length) ii<-order(ll) x$edge<-x$edge[ii,] x$edge.length<-x$edge.length[ii] attr(x,"order")<-"pruningwise" return(x) } ## function converts a tree with a root edge to a tree with a singleton node instead ## written by Liam J. Revell 2016, re-written 2019 rootedge.to.singleton<-function(tree){ if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".") if(!is.null(tree$root.edge)){ tree$edge[tree$edge>Ntip(tree)]<- tree$edge[tree$edge>Ntip(tree)]+1 if(attr(tree,"order")%in%c("postorder","pruningwise")){ tree$edge<-rbind(tree$edge,c(1,2)+Ntip(tree)) tree$edge.length<-c(tree$edge.length,tree$root.edge) } else { tree$edge<-rbind(c(1,2)+Ntip(tree),tree$edge) tree$edge.length<-c(tree$root.edge,tree$edge.length) } tree$root.edge<-NULL tree$Nnode<-tree$Nnode+1 if(!is.null(tree$node.label)) tree$node.label<-c("",tree$node.label) } tree } phytools/R/fitDiversityModel.R0000644000176200001440000001200314375517350016133 0ustar liggesusers## this function fits a "diversity-dependent-evolutionary-diversification" ## model (similar to Mahler et al. 2010) ## written by Liam Revell, 2010/2011/2012, 2019 fitDiversityModel<-function(tree,x,d=NULL,showTree=TRUE,tol=1e-6){ # some minor error checking if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".") if(is.data.frame(x)) x<-as.matrix(x) if(is.matrix(x)) x<-x[,1] if(is.null(names(x))){ if(length(x)==length(tree$tip)){ message("x has no names; assuming x is in the same order as tree$tip.label") names(x)<-tree$tip.label } else stop("x has no names and is a different length than tree$tip.label") } if(any(is.na(match(tree$tip.label,names(x))))){ message("some species in tree are missing from data, dropping missing taxa from the tree") tree<-drop.tip(tree,tree$tip.label[-match(names(x),tree$tip.label)]) } if(any(is.na(match(names(x),tree$tip.label)))){ message("some species in data are missing from tree, dropping missing taxa from the data") x<-x[tree$tip.label] } if(any(is.na(x))){ message("some data given as 'NA', dropping corresponding species from tree") tree<-drop.tip(tree,names(which(is.na(x)))) } if(!is.null(d)){ if(is.data.frame(d)) d<-as.matrix(d) if(is.matrix(d)) d<-d[,1] if(is.null(names(d))){ if(length(d)==tree$Nnode){ message("d has no names; assuming d is in node number order of the resolved tree") names(d)<-c(length(tree$tip)+tol:tree$Nnode) } else stop("d has no names and is a different length than tree$Nnode for the resolved tree") } } else { message("no values for lineage density provided; computing assuming single biogeographic region") # compute lineage diversity at each node ages<-branching.times(tree) d<-vector() for(i in 1:length(ages)) d[i]<-sum(ages>ages[i]) names(d)<-names(ages) } maxd<-max(d) d<-d/(maxd+tol) # likelihood function lik<-function(theta,y,phy,diversity){ scaled.psi<-theta for(i in 1:nrow(phy$edge)){ vi<-phy$edge.length[i] phy$edge.length[i]<-vi+vi*scaled.psi* diversity[as.character(phy$edge[i,1])] } D<-vcv(phy) D<-D[names(y),names(y)] Dinv<-solve(D) a<-as.numeric(colSums(Dinv)%*%y/sum(Dinv)) sig0<-as.numeric(t(y-a)%*%Dinv%*%(y-a)/nrow(D)) Dinv<-Dinv/sig0; D<-D*sig0 logL<-as.numeric(-t(y-a)%*%Dinv%*%(y-a)/2- determinant(D)$modulus[1]/2-length(y)*log(2*pi)/2) if(showTree) plot(phy) return(logL) } # optimize res<-optimize(lik,c(-1,1),y=x,phy=tree,diversity=d, maximum=TRUE) # compute condition sig0 compute_sig0<-function(scaled.psi,y,phy,diversity){ for(i in 1:nrow(phy$edge)){ vi<-phy$edge.length[i] phy$edge.length[i]<-vi+vi*scaled.psi* diversity[as.character(phy$edge[i,1])] } D<-vcv(phy) D<-D[names(y),names(y)] Dinv<-solve(D) a<-as.numeric(colSums(Dinv)%*%y/sum(Dinv)) sig0<-as.numeric(t(y-a)%*%Dinv%*%(y-a)/nrow(D)) return(sig0) } sig0=compute_sig0(res$maximum,x,tree,d) # compute the Hessian compute_Hessian<-function(scaled.psi,sig0,y,phy,d,maxd){ psi<-scaled.psi*sig0/(maxd+tol) likHessian<-function(theta,y,phy,d,maxd){ sig0<-theta[1] psi<-theta[2] for(i in 1:nrow(phy$edge)){ vi<-phy$edge.length[i] phy$edge.length[i]<-vi*(sig0+psi*d[as.character(phy$edge[i, 1])]*(maxd+tol)) } D<-vcv(phy) D<-D[names(y),names(y)] Dinv<-solve(D) a<-as.numeric(colSums(Dinv)%*%y/sum(Dinv)) logL<-as.numeric(-t(y-a)%*%Dinv%*%(y-a)/2-determinant(D)$modulus[1]/2- length(y)*log(2*pi)/2) return(logL) } H<-hessian(likHessian,c(sig0,psi),y=y,phy=phy,d=d,maxd=maxd) return(H) } H<-compute_Hessian(res$maximum,sig0,x,tree,d,maxd) # return results to user if(var(d)>0){ object<-list(logL=res$objective,sig0=sig0,psi=sig0*res$maximum/(maxd+tol), vcv=matrix(solve(-H),2,2,dimnames=list(c("sig0","psi"),c("sig0","psi")))) class(object)<-"fitDiversityModel" return(object) } else { message("psi not estimable because diversity is constant through time.") object<-list(logL=res$objective,sig0=sig0,vcv=matrix(-1/H[1,1],1,1, dimnames=list(c("sig0"),c("sig0")))) class(object)<-"fitDiversityModel" return(object) } } print.fitDiversityModel<-function(x,...){ if(hasArg(digits)) digits<-list(...)$digits else digits<-5 if(is.null(x$psi)){ cat("Fitted diversity-independent evolution model:\n") cat("\tsig2(0)\tSE\tlog(L)\n") cat(paste("value\t",round(x$sig0,digits),"\t", round(sqrt(x$vcv[1,1]),digits),"\t", round(logLik(x),digits),"\n\n",sep="")) } else { cat("Fitted diversity-dependent evolution model:\n") cat("\tsig2(0)\tSE\tpsi\tSE\tlog(L)\n") cat(paste("value\t",round(x$sig0,digits),"\t", round(sqrt(x$vcv[1,1]),digits),"\t", round(x$psi,digits),"\t", round(sqrt(x$vcv[2,2]),digits),"\t", round(logLik(x),digits),"\n\n",sep="")) } } logLik.fitDiversityModel<-function(object,...){ if(hasArg(df)) df<-list(...)$df else df<-if(is.null(object$psi)) 2 else 3 lik<-object$logL attr(lik,"df")<-df lik } phytools/R/fancyTree.R0000644000176200001440000002535014375517350014416 0ustar liggesusers# function to plot special types of phylogeny visualizations # so far the implemented types are: # "extinction" in which all branches leading to extinct taxa (or prior to the MRCA of extant species) are plotted with red dashed lines; # "traitgram3d" which creates a 3D graph projecting the tree into two-dimensional morphospace (with time as the third axis) # "droptip" creates a two panel plot with the tips to be pruned marked (panel 1) and then removed, and returns the pruned tree # "xkcd" creates an xkcd-comic style phylogeny [no longer an option] # "densitymap" maps the posterior density of a binary stochastic character mapping # "contmap" maps reconstructed trait evolution for a continuous character on the tree # "phenogram95" plots a 95% CI phenogram # "scattergram" plots a phylogenetic scatterplot matrix # written by Liam J. Revell 2012, 2013, 2014, 2015, 2016, 2017 fancyTree<-function(tree,type=c("extinction","traitgram3d","droptip", "densitymap","contmap","phenogram95","scattergram"),...,control=list()){ type<-matchType(type,c("extinction","traitgram3d","droptip","densitymap", "contmap","phenogram95","scattergram")) if(!inherits(tree,"phylo")&&type%in%c("extinction","traitgram3d", "droptip")) stop("tree should be an object of class \"phylo\".") else if(!inherits(tree,"multiSimmap")&&type=="densitymap") stop("for type='densitymap' tree should be an object of class \"multiSimmap\".") if(type=="extinction") extinctionTree(tree,...) else if(type=="traitgram3d") invisible(traitgram3d(tree,...,control=control)) else if(type=="droptip") return(droptipTree(tree,...)) else if(type=="densitymap") plotDensityMap(tree,...) else if(type=="contmap") plotContMap(tree,...) else if(type=="phenogram95") phenogram95(tree,...) else if(type=="scattergram") invisible(phyloScattergram(tree,...)) else stop(paste("do not recognize type = \"",type,"\"",sep="")) } ## phyloScattergram internal function ## written by Liam J. Revell 2013, 2014, 2017, 2019, 2021 phyloScattergram<-function(tree,X=NULL,...){ if(is.null(X)) stop("phenotypic data should be provided in the matrix X") if(is.data.frame(X)) X<-as.matrix(X) if(hasArg(plot)) plot<-list(...)$plot else plot<-TRUE if(hasArg(fixed.lims)) fixed.lims<-list(...)$fixed.lims else fixed.lims<-FALSE if(hasArg(quiet)) quiet<-list(...)$quiet else quiet<-FALSE if(!quiet){ cat("Computing multidimensional phylogenetic scatterplot matrix...\n") flush.console() } m<-ncol(X) A<-apply(X,2,fastAnc,tree=tree) cmaps<-list() lims<-if(fixed.lims) range(X) else NULL for(i in 1:m) cmaps[[i]]<-contMap(tree,X[,i], legend=FALSE,lwd=2,outline=FALSE,plot=FALSE, lims=lims) if(is.null(colnames(X))) colnames(X)<-paste("V",1:m,sep="") obj<-list(tree=tree,contMaps=cmaps,X=X,A=A) class(obj)<-"phyloScattergram" if(plot) plot(obj,...) invisible(obj) } plot.phyloScattergram<-function(x,...){ if(hasArg(fsize)) fsize<-list(...)$fsize else fsize<-0.7 if(hasArg(ftype)) ftype<-list(...)$ftype else ftype<-"i" if(hasArg(colors)) colors<-list(...)$colors else if(!is.null(x$tree$maps)) colors<-setNames(palette()[1:ncol(x$tree$mapped.edge)], sort(colnames(x$tree$mapped.edge))) if(hasArg(label)) label<-list(...)$label else label<-"radial" m<-ncol(x$X) dev.hold() par(mfrow=c(m,m)) par(mar=c(0,0,0,0)) par(oma=c(5,5,3,3)) for(i in 1:m) for(j in 1:m){ if(i==j) plot(x$contMaps[[i]],legend=FALSE, lwd=2,outline=FALSE,fsize=fsize,ftype=ftype) else { phylomorphospace(x$tree,x$X[,c(j,i)],A=x$A[,c(j,i)],lwd=1, node.by.map=TRUE,axes=FALSE,node.size=c(0,1), colors=colors,label=label,xlab="",ylab="", fsize=fsize/0.7,ftype=ftype) if(i==1) axis(side=3) # top row if(i==m) axis(side=1) # first column if(j==1) axis(side=2) # bottom row if(j==m) axis(side=4) # last column } } old.cex<-par()$cex par(cex=0.9) if(is.null(colnames(x$X))) colnames(x$X)<-paste("V",1:m,sep="") invisible(mapply(title,xlab=colnames(x$X), adj=seq(0,(m-1)/m,1/m)+1/(2*m),MoreArgs=list(outer=TRUE,cex=0.9))) invisible(mapply(title,ylab=colnames(x$X)[m:1], adj=seq(0,(m-1)/m,1/m)+1/(2*m),MoreArgs=list(outer=TRUE,cex=0.9))) dev.flush() par(cex=old.cex) } print.phyloScattergram<-function(x,...){ cat(paste("\nObject of class \"phyloScattergram\" for",ncol(x$X), "continuous traits.\n")) cat("To replot enter \"plot(object_name)\" at the prompt.\n\n") } ## phenogram95 internal function ## written by Liam J. Revell 2013, 2014, 2019 phenogram95<-function(tree,x=NULL,...){ if(is.null(x)) stop("no phenotypic data provided") if(hasArg(spread.labels)) spread.labels<-list(...)$spread.labels else spread.labels<-TRUE if(hasArg(link)) link<-list(...)$link else link<-0.05*max(nodeHeights(tree)) if(hasArg(offset)) offset<-list(...)$offset else offset<-0 if(hasArg(hold)) hold<-list(...)$hold else hold<-TRUE if(hasArg(quiet)) quiet<-list(...)$quiet else quiet<-FALSE # get ancestral states A<-fastAnc(tree,x,CI=TRUE) # compute transparencies if(hasArg(tlim)) tlim<-list(...)$tlim else tlim<-c(0,25) trans<-as.character(floor(seq(tlim[1],tlim[2],length.out=51))) trans[as.numeric(trans)<10]<-paste("0", trans[as.numeric(trans)<10],sep="") # now get the arguments for phenogram args<-list(...) args$tree<-tree args$lwd<-1 args$link<-0.05*max(nodeHeights(tree)) args$offset<-0 if(hold) null<-dev.hold() if(!quiet&&hold){ cat("Computing density traitgram...\n") flush.console() } for(i in 0:50){ p<-i/length(trans) args$add<-i>0 args$spread.labels<-if(i==0) spread.labels else FALSE args$link<-if(i==0) link else 0 args$offset<-if(i==0) offset else offset+link args$x<-c(x,(1-p)*A$CI95[,1]+p*A$ace) args$colors<-paste("#0000ff",trans[i+1],sep="") do.call(phenogram,args) args$x<-c(x,(1-p)*A$CI95[,2]+p*A$ace) args$add<-TRUE args$spread.labels<-FALSE args$link<-0 args$offset<-offset+link do.call(phenogram,args) } args$x<-c(x,A$ace) args$add<-TRUE args$colors<-"white" args$lwd<-2 args$offset<-offset+link do.call(phenogram,args) null<-dev.flush() } ## extinctionTree internal function ## written by Liam J. Revell 2012, 2019 extinctionTree<-function(tree,...){ if(hasArg(fsize)) fsize<-list(...)$fsize else fsize<-1 if(hasArg(ftype)) ftype<-list(...)$ftype else ftype<-"i" if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-2 if(hasArg(colors)) colors<-list(...)$colors else colors<-palette()[1:2] ftype<-which(c("off","reg","b","i","bi")==ftype)-1 if(!ftype) fsize=0.1 edges<-rep(0,nrow(tree$edge)) names(edges)<-tree$edge[,2] extant<-getExtant(tree) ca<-findMRCA(tree,extant) root.node<-length(tree$tip)+1 if(ca!=root.node){ z<-setdiff(getDescendants(tree,root.node), getDescendants(tree,ca)) edges[as.character(z)]<-1 } z<-getDescendants(tree,ca) y<-lapply(z,getDescendants,tree=tree) for(i in 1:length(z)) if(!any(tree$tip.label[y[[i]]]%in%extant)) edges[as.character(z[i])]<-1 ape::plot.phylo(tree,edge.color=colors[edges+1],edge.lty=edges+1, edge.width=lwd,no.margin=TRUE,cex=fsize, show.tip.label=if(ftype==0) FALSE else TRUE, font=ftype) } # traitgram3d internal function # written by Liam J. Revell 2012, 2013 traitgram3d<-function(tree,...,control){ if(hasArg(X)) X<-list(...)$X else stop("no phenotypic data provided") if(!hasArg(A)){ if(is.null(control$maxit)) maxit<-2000 else maxit<-control$maxit Y<-apply(X,2,function(x,tree) anc.ML(tree,x,maxit),tree=tree) convergence<-sapply(Y,function(x) x$convergence) if(any(convergence!=0)) warning("anc.ML may not have converged; consider increasing maxit.") A<-sapply(Y,function(x) x$ace) } else { A<-list(...)$A A<-A[as.character(1:tree$Nnode+length(tree$tip)),] } if(is.null(colnames(X))) colnames(X)<-c("x","y") X<-cbind(X,diag(vcv(tree))[rownames(X)]) A<-cbind(A,nodeHeights(tree)[match(rownames(A)[1:nrow(A)],tree$edge)]) colnames(X)[3]<-colnames(A)[3]<-"time" # other optional arguments if(hasArg(method)) method<-list(...)$method else method<-"dynamic" if(hasArg(angle)) angle<-list(...)$angle else angle<-30 # done other optional arguments xx<-phylomorphospace3d(tree,X,A,control=control,method=method, angle=angle,zlim=range(nodeHeights(tree))) return(xx) } # droptipTree internal function # written by Liam J. Revell 2012, 2020 (just to fix a couple of dumb bugs) droptipTree<-function(tree,...){ if(hasArg(tip)) tip<-list(...)$tip else stop("need to provide tip or tips to drop") if(hasArg(cex)) cex<-list(...)$cex else cex<-0.7 edges<-rep(0,nrow(tree$edge)) names(edges)<-tree$edge[,2] keep<-setdiff(tree$tip.label,tip) ca<-findMRCA(tree,keep) root.node<-length(tree$tip)+1 if(ca!=root.node){ z<-setdiff(getDescendants(tree,root.node), getDescendants(tree,ca)) edges[as.character(z)]<-1 } z<-getDescendants(tree,ca) foo<-function(x,tree){ n<-length(tree$tip.label) y<-getDescendants(tree,x) y<-y[y<=n] return(y) } y<-lapply(z,foo,tree=tree) for(i in 1:length(z)) if(!any(tree$tip.label[y[[i]]]%in%keep)) edges[as.character(z[i])]<-1 par(mfrow=c(2,1)) plot.phylo(tree,edge.color=edges+1,edge.lty=edges+1, edge.width=2,no.margin=TRUE,cex=cex) xlim<-get("last_plot.phylo",envir=.PlotPhyloEnv)$x.lim dtree<-drop.tip(tree,tip) dtree$root.edge<-max(nodeHeights(tree))-max(nodeHeights(dtree)) plot.phylo(rootedge.to.singleton(dtree),edge.width=2, no.margin=TRUE,cex=cex,x.lim=xlim) return(dtree) } # plotDensityMap internal function # written by Liam J. Revell 2012 plotDensityMap<-function(trees,...){ if(hasArg(res)) res<-list(...)$res else res<-100 if(hasArg(fsize)) fsize<-list(...)$fsize else fsize<-NULL if(hasArg(ftype)) ftype<-list(...)$ftype else ftype<-NULL if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-3 if(hasArg(check)) check<-list(...)$check else check<-FALSE if(hasArg(legend)) legend<-list(...)$legend else legend<-NULL if(hasArg(outline)) outline<-list(...)$outline else outline<-FALSE densityMap(trees,res,fsize,check,legend,outline) } # plotContMap internal function # written by Liam J. Revell 2012 plotContMap<-function(tree,...){ if(hasArg(x)) x<-list(...)$x else stop("need to provide vector 'x' of phenotypic trait values") if(hasArg(res)) res<-list(...)$res else res<-100 if(hasArg(fsize)) fsize<-list(...)$fsize else fsize<-NULL if(hasArg(ftype)) ftype<-list(...)$ftype else ftype<-NULL if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-4 if(hasArg(legend)) legend<-list(...)$legend else legend<-NULL if(hasArg(lims)) lims<-list(...)$lims else lims<-NULL if(hasArg(outline)) outline<-list(...)$outline else outline<-TRUE if(hasArg(sig)) sig<-list(...)$sig else sig<-3 contMap(tree,x,res,fsize,ftype,lwd,legend,lims,outline,sig) } phytools/R/bmPlot.R0000644000176200001440000001057014375517350013731 0ustar liggesusers## visualize discrete time Brownian simulation on a tree ## written by Liam J. Revell 2012, 2013, 2015, 2020, 2022 bmPlot<-function(tree,type="BM",anc=0,sig2=1/1000,ngen=1000,...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(hasArg(return.tree)) return.tree<-list(...)$return.tree else return.tree<-TRUE tr<-reorder(tree) H<-nodeHeights(tr) tr$edge.length<-round(tr$edge.length/max(H)*ngen) tr<-di2multi(tr) h<-nodeHeights(tr)[,1] bmSim<-function(start,n) cumsum(c(start,rnorm(n,sd=sqrt(sig2)))) X<-T<-list() N<-length(tr$tip) for(i in 1:nrow(tr$edge)){ if(tr$edge[i,1]==(N+1)) X[[i]]<-bmSim(anc,tr$edge.length[i]) else { parent<-match(tr$edge[i,1],tr$edge[,2]) X[[i]]<-bmSim(X[[parent]][length(X[[parent]])],tr$edge.length[i]) } T[[i]]<-h[i]+0:tr$edge.length[i] } if(type=="BM") cols<-bm(X,T,...) else if(type=="threshold") cols<-th(X,T,...) if(return.tree){ if(type=="BM") tr$X<-X else if(type=="threshold"){ if(hasArg(thresholds)) thresholds<-list(...)$thresholds else stop("no thresholds provided for type=\"threshold\"") thresholds<-setNames(c(thresholds,Inf),letters[1:(length(thresholds)+1)]) xx<-lapply(X,function(x,y) sapply(x[2:length(x)],threshState,thresholds=y),y=thresholds) maps<-lapply(tr$edge.length,function(x) rep(1,x)) maps<-mapply(function(x,y) setNames(x,y),x=maps,y=xx) maps<-lapply(maps,mergeAdjacent) tr$maps<-maps class(tr)<-c("simmap",setdiff(class(tr),"simmap")) } } Y<-matrix(NA,nrow(tr$edge),2) Y[,1]<-sapply(X,function(x) x[1]) Y[,2]<-sapply(X,function(x) x[length(x)]) x<-Y[tr$edge[,2]%in%1:N,2] names(x)<-tr$tip.label[tr$edge[tr$edge[,2]%in%1:N,2]] a<-c(anc,Y[tr$edge[,2]%in%(N+2:tr$Nnode),2]) names(a)<-c(N+1,tr$edge[tr$edge[,2]%in%(N+2:tr$Nnode),2]) xx<-c(x[tr$tip],a[as.character(N+1:tr$Nnode)]) if(!return.tree) return(xx) else return(list(x=xx,tree=tr,colors=cols)) } # plots type="BM" bm<-function(X,T,...){ if(hasArg(bty)) bty<-list(...)$bty else bty<-"o" if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-1 minX<-min(sapply(X,min)) maxX<-max(sapply(X,max)) plot(X[[1]][1],T[[1]][1],ylim=c(0,max(sapply(T,max))), xlim=c(minX,maxX),ylab="time",xlab="phenotype", bty=bty) for(i in 1:length(X)) lines(X[[i]],T[[i]],lwd=lwd) if(hasArg(colors)) cols<-list(...)$colors else cols<-"black" return(cols) } # plots type="threshold" th<-function(X,T,...){ if(hasArg(bty)) bty<-list(...)$bty else bty<-"o" if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-1 minX<-min(sapply(X,min)) maxX<-max(sapply(X,max)) if(hasArg(thresholds)) thresholds<-list(...)$thresholds else stop("no thresholds provided for type='threshold'") if(hasArg(colors)) cols<-list(...)$colors else { cols<-c("black","red","blue","green") while(length(thresholds)>(length(cols)-1)) cols<-c(cols,c("black","red","blue","green")) } thresholds<-thresholds+1e-16 plot(X[[1]][1],T[[1]][1],ylim=c(0,max(sapply(T,max))),xlim=c(minX,maxX),ylab="time",xlab="liability", bty=bty) for(i in 1:length(X)) if(length(X[[i]])>1) for(j in 1:(length(X[[i]])-1)) if(threshCol(X[[i]][j],thresholds,cols)==threshCol(X[[i]][j+1],thresholds,cols)) lines(X[[i]][c(j,j+1)],T[[i]][c(j,j+1)], col=threshCol(X[[i]][j+1],thresholds,cols),lwd=lwd) else { t<-thresholds[which(sort(c(thresholds,min(X[[i]][c(j,j+1)])))==min(X[[i]][c(j,j+1)]))] lines(c(X[[i]][j],t),c(T[[i]][j], T[[i]][j]+abs(diff(c(X[[i]][j],t))/diff(X[[i]][c(j,j+1)]))), col=threshCol(X[[i]][j],thresholds,cols),lwd=lwd) lines(c(X[[i]][j+1],t),c(T[[i]][j+1], T[[i]][j+1]-abs(diff(c(X[[i]][j+1],t))/diff(X[[i]][c(j,j+1)]))), col=threshCol(X[[i]][j+1],thresholds,cols),lwd=lwd) } for(i in 1:length(thresholds)) lines(rep(thresholds[i],2),c(0,max(sapply(T,max))),lty="dashed") return(setNames(cols[1:(length(thresholds)+1)],letters[1:(length(thresholds)+1)])) } # returns a color based on position relative to thresholds threshCol<-function(x,thresholds,cols){ t<-c(-Inf,thresholds,Inf); i<-1 while(x>t[i]) i<-i+1 return(cols[i-1]) } # merge adjacent map in the same state mergeAdjacent<-function(x){ ii<-1 y<-x[1] if(length(x)>1){ for(i in 2:length(x)){ if(names(x)[i]==names(y)[ii]) y[ii]<-y[ii]+x[i] else{ y<-c(y,x[i]) ii<-ii+1 } } } return(y) } phytools/R/readNexus.R0000644000176200001440000000714514375517350014436 0ustar liggesusers## function ## written by Liam J. Revell 2013, 2021 readNexus<-function(file="",format=c("standard","raxml")){ format<-format[1] if(tolower(format)=="standard") tree<-read.nexus(file) else if(tolower(format)=="raxml"){ XX<-readNexusData(file,version=3.5) text<-XX$text trans<-XX$trans Ntree<-XX$Ntree tree<-lapply(text,modified.text_to_tree,trans=trans) if(length(tree)==1) tree<-tree[[1]] else class(tree)<-"multiPhylo" } else { cat("Do not recognize format\n") tree<-NULL } tree } # function gets edge length # written by Liam J. Revell 2013, 2021 getEdgeLength<-function(text,start){ i<-start+1 l<-1 temp<-vector() while(is.na(match(text[i],c(",",")")))){ temp[l]<-text[i]; l<-l+1; i<-i+1 } list(edge.length=as.numeric(paste(temp,collapse="")), end=i) } ## function gets bootstrap stored as [&label="bootstrap%"] ## written by Liam J. Revell 2021 getBS<-function(text,start){ i<-start if(text[i]=="["){ j<-1 xx<-vector() while(text[i]!="]"){ i<-i+1 xx[j]<-text[i] j<-j+1 } label<-paste(xx[1:(length(xx)-1)],collapse="") label<-sub("&label=","",label) } list(label=label,end=i+1) } ## function translates text-string to tree ## written by Liam J. Revell 2011-2013, 2021 modified.text_to_tree<-function(text,trans){ text<-unlist(strsplit(text,NULL)) tip.label<-vector(mode="character") edge<-matrix(c(1,NA),1,2) edge.length<-vector() node.label<-vector(mode="character") currnode<-1 Nnode<-currnode i<-j<-k<-1 while(text[i]!="(") i<-i+1 while(text[i]!=";"){ if(text[i]=="("){ if(j>nrow(edge)) edge<-rbind(edge,c(NA,NA)) edge[j,1]<-currnode i<-i+1 # is the next element a label? if(is.na(match(text[i],c("(",")",",",":",";")))){ temp<-getLabel(text,i) tip.label[k]<-temp$label i<-temp$end edge[j,2]<--k k<-k+1 # is there a branch length? if(text[i]==":"){ temp<-getEdgeLength(text,i) edge.length[j]<-temp$edge.length i<-temp$end } } else if(text[i]=="("){ Nnode<-Nnode+1 # creating a new internal node currnode<-Nnode edge[j,2]<-currnode # move to new internal node } j<-j+1 } else if(text[i]==")"){ i<-i+1 # is there a node label? if(text[i]=="["){ temp<-getBS(text,i) node.label[currnode]<-as.character(temp$label) i<-temp$end } # is there a branch length? if(text[i]==":"){ temp<-getEdgeLength(text,i) ii<-match(currnode,edge[,2]) edge.length[ii]<-temp$edge.length i<-temp$end } currnode<-edge[match(currnode,edge[,2]),1] # move down the tree } else if(text[i]==","){ if(j>nrow(edge)) edge<-rbind(edge,c(NA,NA)) edge[j,1]<-currnode i<-i+1 # is the next element a label? if(is.na(match(text[i],c("(",")",",",":",";")))){ temp<-getLabel(text,i) tip.label[k]<-temp$label i<-temp$end edge[j,2]<--k k<-k+1 # is there a branch length? if(text[i]==":"){ temp<-getEdgeLength(text,i) edge.length[j]<-temp$edge.length i<-temp$end } } else if(text[i]=="("){ Nnode<-Nnode+1 # creating a new internal node currnode<-Nnode edge[j,2]<-currnode # move to internal node } j<-j+1 } } Ntip<-k-1 if(!is.null(trans)) tip.label<-trans[tip.label] # assemble into modified "phylo" object ntip<-abs(min(edge)) edge[which(edge>0)]<-ntip+edge[which(edge>0)] edge[which(edge<0)]<-abs(edge[which(edge<0)]) tree<-list(edge=edge,Nnode=as.integer(Nnode),tip.label=tip.label, edge.length=edge.length,node.label=node.label) class(tree)<-"phylo" tree } phytools/R/read.simmap.R0000644000176200001440000002242214375517350014673 0ustar liggesusers# function reads SIMMAP v1.0 & v1.5 style trees into file # written by Liam J. Revell 2011-2015 read.simmap<-function(file="",text,format="nexus",rev.order=TRUE,version=1.0){ if(file!=""){ trans<-NULL if(format=="nexus"){ XX<-readNexusData(file,version) text<-XX$text trans<-XX$trans Ntree<-XX$Ntree } else if(format=="phylip"){ text<-scan(file,sep="\n",what="character") Ntree<-length(text) } } else { trans<-NULL Ntree<-length(text) } tree<-lapply(text,text_to_tree,version,rev.order,trans) class(tree)<-c("multiSimmap","multiPhylo") if(length(tree)==1) tree<-tree[[1]] return(tree) } # function gets branch length # written by Liam J. Revell 2011-2013 getBranch<-function(text,start,version){ if(version<=1.0){ i<-start+1 l<-1 if(text[i]=="{"){ maps<-vector() i<-i+1 while(text[i]!="}"){ temp<-vector() m<-1 while(text[i]!=","){ temp[m]<-text[i] i<-i+1 m<-m+1 } state<-paste(temp,collapse="") i<-i+1 temp<-vector() m<-1 while(text[i]!=":"&&text[i]!="}"){ temp[m]<-text[i] i<-i+1 m<-m+1 } length<-as.numeric(paste(temp,collapse="")) maps[l]<-length names(maps)[l]<-as.character(state) l<-l+1 if(text[i]==":") i<-i+1 } } edge.length<-sum(maps) # create branch length i<-i+1 } else if(version>1.0){ i<-start+1 l<-1 if(text[i]=="["){ maps<-vector() i<-i+7 while(text[i]!="}"){ temp<-vector() m<-1 while(text[i]!=","&&text[i]!="}"){ temp[m]<-text[i] i<-i+1 m<-m+1 } state<-paste(temp,collapse="") if(text[i]!="}"){ i<-i+1 temp<-vector() m<-1 while(text[i]!=","&&text[i]!="}"){ temp[m]<-text[i] i<-i+1 m<-m+1 } ll<-as.numeric(paste(temp,collapse="")) maps[l]<-ll names(maps)[l]<-as.character(state) l<-l+1 if(text[i]==",") i<-i+1 } } temp<-vector() m<-1 i<-i+2 while(is.na(match(text[i],c(",",")")))){ temp[m]<-text[i] i<-i+1 m<-m+1 } maps[l]<-as.numeric(paste(temp,collapse=""))-sum(maps) names(maps)[l]<-as.character(state) } edge.length<-sum(maps) } return(list(maps=maps,edge.length=edge.length,end=i)) } # make a mapped edge matrix # written by Liam J. Revell 2013 makeMappedEdge<-function(edge,maps){ st<-sort(unique(unlist(sapply(maps,function(x) names(x))))) mapped.edge<-matrix(0,nrow(edge),length(st)) rownames(mapped.edge)<-apply(edge,1,function(x) paste(x,collapse=",")) colnames(mapped.edge)<-st for(i in 1:length(maps)) for(j in 1:length(maps[[i]])) mapped.edge[i,names(maps[[i]])[j]]<-mapped.edge[i,names(maps[[i]])[j]]+maps[[i]][j] return(mapped.edge) } # function translates text-string to tree # written by Liam J. Revell 2011-2015, 2019 text_to_tree<-function(text,version,rev.order,trans){ text<-unlist(strsplit(text, NULL)) while(text[1]!="(") text<-text[2:length(text)] tip.label<-vector(mode="character") edge<-matrix(c(1,NA),1,2) edge.length<-vector() maps<-list() currnode<-1 Nnode<-currnode i<-j<-k<-1 while(text[i]!=";"){ if(text[i]=="("){ if(j>nrow(edge)) edge<-rbind(edge,c(NA,NA)) edge[j,1]<-currnode i<-i+1 # is the next element a label? if(is.na(match(text[i],c("(",")",",",":",";")))){ temp<-getLabel(text,i) tip.label[k]<-temp$label i<-temp$end edge[j,2]<--k k<-k+1 # is there a branch length? if(text[i]==":"){ temp<-getBranch(text,i,version) maps[[j]]<-temp$maps edge.length[j]<-temp$edge.length i<-temp$end } } else if(text[i]=="("){ Nnode<-Nnode+1 # creating a new internal node currnode<-Nnode edge[j,2]<-currnode # move to new internal node } j<-j+1 } else if(text[i]==")"){ i<-i+1 # is there a branch length? if(text[i]==":"){ temp<-getBranch(text,i,version) ii<-match(currnode,edge[,2]) maps[[ii]]<-temp$maps edge.length[ii]<-temp$edge.length i<-temp$end } currnode<-edge[match(currnode,edge[,2]),1] # move down the tree } else if(text[i]==","){ if(j>nrow(edge)) edge<-rbind(edge,c(NA,NA)) edge[j,1]<-currnode i<-i+1 # is the next element a label? if(is.na(match(text[i],c("(",")",",",":",";")))){ temp<-getLabel(text,i) tip.label[k]<-temp$label i<-temp$end edge[j,2]<--k k<-k+1 # is there a branch length? if(text[i]==":"){ temp<-getBranch(text,i,version) maps[[j]]<-temp$maps edge.length[j]<-temp$edge.length i<-temp$end } } else if(text[i]=="("){ Nnode<-Nnode+1 # creating a new internal node currnode<-Nnode edge[j,2]<-currnode # move to internal node } j<-j+1 } } Ntip<-k-1 edge[edge>0]<-edge[edge>0]+Ntip edge[edge<0]<--edge[edge<0] mapped.edge<-makeMappedEdge(edge,maps) maps<-if(rev.order) lapply(maps,function(x) x<-x[length(x):1]) else maps if(!is.null(trans))tip.label<-trans[tip.label] # assemble into modified "phylo" object tree<-list(edge=edge,Nnode=as.integer(Nnode),tip.label=tip.label,edge.length=edge.length,maps=maps,mapped.edge=mapped.edge) class(tree)<-c("simmap","phylo") attr(tree,"map.order")<-if(rev.order) "right-to-left" else "left-to-right" return(tree) } # function reads Nexus taxa block in SIMMAP format trees # modified from ape:read.nexus # written by Liam J. Revell 2011-2013 readNexusData<-function(file,version){ # read modified nexus block # this function is adapted from ape:read.nexus (Paradis et al. 2004) if(version<=1.0){ X<-scan(file=file,what="",sep="\n",quiet=TRUE) left<-grep("\\[",X) right<-grep("\\]",X) if(length(left)){ w<-left==right if(any(w)){ s<-left[w] X[s]<-gsub("\\[[^]]*\\]","",X[s]) } w<-!w if(any(w)){ s<-left[w] X[s]<-gsub("\\[.*","",X[s]) sb<-right[w] X[sb]<-gsub(".*\\]","",X[sb]) if(any(si1) TRUE else FALSE if(translation){ end<-semico[semico>i2][1] x<-X[(i2+1):end] x<-unlist(strsplit(x,"[,;\t]")) x<-unlist(strsplit(x," ")) # this is an addition x<-x[nzchar(x)] trans<-matrix(x,ncol=2,byrow=TRUE) trans[,2]<-gsub("['\"]","",trans[,2]) n<-dim(trans)[1] } start<-if(translation) semico[semico>i2][1]+1 else semico[semico>i1][1] end<-endblock[endblock>i1][1]-1 tree<-X[start:end] tree<-gsub("^.*= *","",tree) tree<-tree[tree!=""] semico<-grep(";",tree) Ntree<-length(semico) if(Ntree==1&&length(tree)>1){ STRING<-paste(tree,collapse="") } else { if(any(diff(semico)!=1)){ STRING<-character(Ntree) s<-c(1,semico[-Ntree]+1) j<-mapply(":",s,semico) if(is.list(j)){ for(i in 1:Ntree) STRING[i]<-paste(tree[j[[i]]],collapse="") } else { for(i in 1:Ntree) STRING[i]<-paste(tree[j[,i]],collapse="") } } else STRING<-tree } text<-STRING if(translation==TRUE){ rownames(trans)<-trans[,1] trans<-trans[,2] return(list(text=text,trans=trans,Ntree=Ntree)) } else return(list(text=text,Ntree=Ntree)) } else if(version>1.0){ X<-scan(file=file,what="",sep="\n",quiet=TRUE) left<-grep("\\[",X) right<-grep("\\]",X) skip<-if(version<=2.0) grep("\\&map",X) else if(version>2.0&&version<=3.0) grep("\\&prob",X) else if(version>3.0) grep("\\&label",X) left<-setdiff(left,skip) right<-setdiff(right,skip) if(length(left)){ w<-left==right if(any(w)){ s<-left[w] X[s]<-gsub("\\[[^]]*\\]","",X[s]) } w<-!w if(any(w)){ s<-left[w] X[s]<-gsub("\\[.*","",X[s]) sb<-right[w] X[sb]<-gsub(".*\\]","",X[sb]) if(any(si1) TRUE else FALSE if(translation){ end<-semico[semico>i2][1] x<-X[(i2+1):end] x<-unlist(strsplit(x,"[,;\t]")) x<-unlist(strsplit(x," ")) # this is an addition x<-x[nzchar(x)] trans<-matrix(x,ncol=2,byrow=TRUE) trans[,2]<-gsub("['\"]","",trans[,2]) n<-dim(trans)[1] } start<-if(translation) semico[semico>i2][1]+1 else semico[semico>i1][1] end<-endblock[endblock>i1][1]-1 tree<-X[start:end] tree<-sub(".* = *","",tree) tree<-tree[tree!=""] semico<-grep(";",tree) Ntree<-length(semico) if(Ntree==1&&length(tree)>1){ STRING<-paste(tree,collapse="") } else { if(any(diff(semico)!=1)){ STRING<-character(Ntree) s<-c(1,semico[-Ntree]+1) j<-mapply(":",s,semico) if(is.list(j)){ for(i in 1:Ntree) STRING[i]<-paste(tree[j[[i]]],collapse="") } else { for(i in 1:Ntree) STRING[i]<-paste(tree[j[,i]],collapse="") } } else STRING<-tree } text<-STRING if(translation==TRUE){ rownames(trans)<-trans[,1] trans<-trans[,2] return(list(text=text,trans=trans,Ntree=Ntree)) } else return(list(text=text,Ntree=Ntree)) } } phytools/R/plotSimmap.R0000644000176200001440000007247314524712103014620 0ustar liggesusers## functions plot stochastic character mapped trees ## written by Liam Revell 2011-2023 plotSimmap<-function(tree,colors=NULL,fsize=1.0,ftype="reg",lwd=2, pts=FALSE,node.numbers=FALSE,mar=NULL,add=FALSE,offset=NULL,direction="rightwards", type="phylogram",setEnv=TRUE,part=if(type=="arc") 0.5 else 1.0,xlim=NULL,ylim=NULL, nodes="intermediate",tips=NULL,maxY=NULL,hold=TRUE,split.vertical=FALSE,lend=2,asp=NA, outline=FALSE,plot=TRUE,underscore=FALSE,arc_height=2){ if(inherits(tree,"multiPhylo")){ par(ask=TRUE) for(i in 1:length(tree)) plotSimmap(tree[[i]],colors=colors,fsize=fsize, ftype=ftype,lwd=lwd,pts=pts,node.numbers=node.numbers,mar,add,offset, direction,type,setEnv,part,xlim,ylim,nodes,tips,maxY,hold,split.vertical, lend,asp,outline,plot,underscore) } else { # check tree if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\"") if(is.null(tree$maps)) stop("tree should contain mapped states on edges.") # check font ftype<-which(c("off","reg","b","i","bi")==ftype)-1 if(!ftype) fsize=0 # check colors if(is.null(colors)){ st<-sort(unique(unlist(sapply(tree$maps,names)))) colors<-palette()[1:length(st)] names(colors)<-st if(length(st)>1){ cat("no colors provided. using the following legend:\n") print(colors) } } # swap out "_" character for spaces (assumes _ is a place holder) if(!underscore) tree$tip.label<-gsub("_"," ",tree$tip.label) # get margin if(is.null(mar)) mar=rep(0.1,4) if(hold) null<-dev.hold() if(type=="phylogram"){ if(direction%in%c("upwards","downwards")){ if(outline){ fg<-par()$fg par(fg="transparent") black<-colors black[]<-fg updownPhylogram(tree,colors=black,fsize,ftype,lwd=lwd+2,pts, node.numbers,mar,add,offset,direction,setEnv,xlim,ylim,nodes, tips,split.vertical,lend,asp,plot,underscore) par(fg=fg) } updownPhylogram(tree,colors,fsize,ftype,lwd,pts,node.numbers,mar, add=if(outline) TRUE else add,offset,direction,setEnv,xlim,ylim,nodes, tips,split.vertical,lend,asp,plot,underscore) } else { if(outline){ fg<-par()$fg par(fg="transparent") black<-colors black[]<-fg plotPhylogram(tree,colors=black,fsize,ftype,lwd=lwd+2,pts, node.numbers,mar,add,offset,direction,setEnv,xlim,ylim,nodes, tips,split.vertical,lend,asp,plot,underscore) par(fg=fg) } plotPhylogram(tree,colors,fsize,ftype,lwd,pts,node.numbers,mar, add=if(outline) TRUE else add,offset,direction,setEnv,xlim,ylim,nodes, tips,split.vertical,lend,asp,plot,underscore) } } else if(type=="fan"){ if(outline){ fg<-par()$fg par(fg="transparent") black<-colors black[]<-fg plotFan(tree,colors=black,fsize,ftype,lwd=lwd+2,mar,add,part,setEnv, xlim,ylim,tips,maxY,lend,plot,offset) par(fg=fg) } plotFan(tree,colors,fsize,ftype,lwd,mar,add=if(outline) TRUE else add,part, setEnv,xlim,ylim,tips,maxY,lend,plot,offset) } else if(type=="arc"){ if(outline){ fg<-par()$fg par(fg="transparent") black<-colors black[]<-fg arcPhylogram(tree,colors=black,fsize,ftype,lwd=lwd+2,mar,add,part,setEnv, xlim,ylim,tips,maxY,lend,plot,offset,arc_height) par(fg=fg) } arcPhylogram(tree,colors,fsize,ftype,lwd,mar,add=if(outline) TRUE else add,part, setEnv,xlim,ylim,tips,maxY,lend,plot,offset,arc_height) } else if(type=="cladogram"){ if(outline){ fg<-par()$fg par(fg="transparent") black<-colors black[]<-fg plotCladogram(tree,colors=black,fsize,ftype,lwd=lwd+2,mar,add,offset, direction,xlim,ylim,nodes,tips,lend,asp,plot) par(fg=fg) } plotCladogram(tree,colors,fsize,ftype,lwd,mar,add=if(outline) TRUE else add, offset,direction,xlim,ylim,nodes,tips,lend,asp,plot) } if(hold) null<-dev.flush() } } ## this is a wrapper of plotFan ## written by Liam J. Revell 2023 arcPhylogram<-function(tree,colors,fsize,ftype,lwd,mar,add,part,setEnv, xlim,ylim,tips,maxY,lend,plot,offset,arc_height){ tree<-reorder(tree,"cladewise") edge<-tree$edge edge[edge>Ntip(tree)]<-edge[edge>Ntip(tree)]+1 edge<-rbind(Ntip(tree)+c(1,2),edge) Nnode<-Nnode(tree)+1 edge.length<-c(arc_height*max(nodeHeights(tree)),tree$edge.length) maps<-c(vector(length=1,mode="numeric"),tree$maps) maps[[1]]<-setNames(edge.length[1],"NULO") colors<-c(setNames("transparent","NULO"),colors) object<-list(edge=edge,Nnode=Nnode,tip.label=tree$tip.label, edge.length=edge.length,maps=maps) class(object)<-class(tree) attr(object,"map.order")<-attr(object,"map.order") plotFan(object,colors,fsize,ftype,lwd,mar,add,part,setEnv,xlim, ylim,tips,maxY,lend,plot,offset) if(setEnv){ PP<-get("last_plot.phylo",envir=.PlotPhyloEnv) ROOT<-PP$Ntip+1 PP$Nnode<-PP$Nnode-1 PP$edge<-PP$edge[2:nrow(PP$edge),] PP$edge[PP$edge>PP$Ntip]<-PP$edge[PP$edge>PP$Ntip]-1 PP$xx<-PP$xx[-ROOT] PP$yy<-PP$yy[-ROOT] assign("last_plot.phylo",PP,envir=.PlotPhyloEnv) } } ## function to plot simmap tree in type "phylogram" ## written by Liam J. Revell 2011-2023 updownPhylogram<-function(tree,colors,fsize,ftype,lwd,pts,node.numbers,mar, add,offset,direction,setEnv,xlim,ylim,placement,tips,split.vertical,lend, asp,plot,underscore){ if(split.vertical&&!setEnv){ cat("split.vertical requires setEnv=TRUE. Setting split.vertical to FALSE.\n") spit.vertical<-FALSE } # set offset fudge (empirically determined) offsetFudge<-1.37 # reorder cw<-reorderSimmap(tree) pw<-reorderSimmap(tree,"postorder") # count nodes and tips n<-Ntip(cw) m<-cw$Nnode # Y coordinates for nodes Y<-matrix(NA,m+n,1) # first, assign y coordinates to all the tip nodes if(is.null(tips)) Y[cw$edge[cw$edge[,2]<=n,2]]<-1:n else Y[cw$edge[cw$edge[,2]<=n,2]]<-if(is.null(names(tips))) tips[sapply(1:Ntip(cw),function(x,y) which(y==x),y=cw$edge[cw$edge[,2]<=n,2])] else if(!underscore) tips[gsub(" ","_",cw$tip.label)] # get Y coordinates of the nodes nodes<-unique(pw$edge[,1]) for(i in 1:m){ if(placement=="intermediate"){ desc<-pw$edge[which(pw$edge[,1]==nodes[i]),2] Y[nodes[i]]<-(min(Y[desc])+max(Y[desc]))/2 } else if(placement=="centered"){ desc<-getDescendants(pw,nodes[i]) desc<-desc[desc<=Ntip(pw)] Y[nodes[i]]<-(min(Y[desc])+max(Y[desc]))/2 } else if(placement=="weighted"){ desc<-pw$edge[which(pw$edge[,1]==nodes[i]),2] n1<-desc[which(Y[desc]==min(Y[desc]))] n2<-desc[which(Y[desc]==max(Y[desc]))] v1<-pw$edge.length[which(pw$edge[,2]==n1)] v2<-pw$edge.length[which(pw$edge[,2]==n2)] Y[nodes[i]]<-((1/v1)*Y[n1]+(1/v2)*Y[n2])/(1/v1+1/v2) } else if(placement=="inner"){ desc<-getDescendants(pw,nodes[i]) desc<-desc[desc<=Ntip(pw)] mm<-which(abs(Y[desc]-median(Y[1:Ntip(pw)]))==min(abs(Y[desc]- median(Y[1:Ntip(pw)])))) if(length(mm>1)) mm<-mm[which(Y[desc][mm]==min(Y[desc][mm]))] Y[nodes[i]]<-Y[desc][mm] } else if(placement=="right"){ desc<-getDescendants(pw,nodes[i]) desc<-desc[desc<=Ntip(pw)] mm<-which(Y[desc]==max(Y[desc])) Y[nodes[i]]<-Y[desc][mm] } else if(placement=="left"){ desc<-getDescendants(pw,nodes[i]) desc<-desc[desc<=Ntip(pw)] mm<-which(Y[desc]==min(Y[desc])) Y[nodes[i]]<-Y[desc][mm] } } # compute node heights H<-nodeHeights(cw) # open plot par(mar=mar) if(is.null(offset)) offset<-0.2*lwd/3+0.2/3 if(!add) plot.new() ### if(is.null(ylim)){ pp<-par("pin")[2] sw<-fsize*(max(strwidth(cw$tip.label,units="inches")))+ offsetFudge*fsize*strwidth("W",units="inches") alp<-optimize(function(a,H,sw,pp) (a*1.04*max(H)+sw-pp)^2,H=H,sw=sw,pp=pp, interval=c(0,1e6))$minimum ylim<-if(direction=="downwards") c(min(H)-sw/alp,max(H)) else c(min(H),max(H)+sw/alp) } if(is.null(xlim)) xlim=range(Y) if(direction=="downwards") H<-max(H)-H plot.window(xlim=xlim,ylim=ylim,asp=asp) #### if(plot){ if(!split.vertical){ for(i in 1:m) lines(Y[cw$edge[which(cw$edge[,1]==nodes[i]),2]], H[which(cw$edge[,1]==nodes[i]),1], col=colors[names(cw$maps[[match(nodes[i], cw$edge[,1])]])[1]],lwd=lwd,lend=lend) } for(i in 1:nrow(cw$edge)){ x<-H[i,1] for(j in 1:length(cw$maps[[i]])){ if(direction=="downwards") lines(c(Y[cw$edge[i,2]],Y[cw$edge[i,2]]),c(x,x-cw$maps[[i]][j]), col=colors[names(cw$maps[[i]])[j]],lwd=lwd,lend=lend) else lines(c(Y[cw$edge[i,2]],Y[cw$edge[i,2]]),c(x,x+cw$maps[[i]][j]), col=colors[names(cw$maps[[i]])[j]],lwd=lwd,lend=lend) if(pts) points(c(Y[cw$edge[i,2]],Y[cw$edge[i,2]]),c(x,x+cw$maps[[i]][j]), pch=20,lwd=(lwd-1)) x<-x+if(direction=="downwards") -cw$maps[[i]][j] else cw$maps[[i]][j] j<-j+1 } } if(node.numbers){ symbols(mean(Y[cw$edge[cw$edge[,1]==(Ntip(cw)+1),2]]), if(direction=="downwards") max(H) else 0, rectangles=matrix(c(1.2*fsize*strwidth(as.character(Ntip(cw)+1)), 1.4*fsize*strheight(as.character(Ntip(cw)+1))),1,2),inches=FALSE, bg="white",add=TRUE) text(mean(Y[cw$edge[cw$edge[,1]==(Ntip(cw)+1),2]]), if(direction=="downwards") max(H) else 0,Ntip(cw)+1, cex=fsize) for(i in 1:nrow(cw$edge)){ x<-H[i,2] if(cw$edge[i,2]>Ntip(cw)){ symbols(Y[cw$edge[i,2]],x, rectangles=matrix(c(1.2*fsize*strwidth(as.character(cw$edge[i,2])), 1.4*fsize*strheight(as.character(cw$edge[i,2]))),1,2),inches=FALSE, bg="white",add=TRUE) text(Y[cw$edge[i,2]],x,cw$edge[i,2],cex=fsize) } } } if(direction=="downwards") pos<-if(par()$usr[3]>par()$usr[4]) 2 else 4 if(direction=="upwards") pos<-if(par()$usr[3]>par()$usr[4]) 2 else 4 for(i in 1:n){ shift<-offset*fsize*strwidth("W")*(diff(par()$usr[3:4])/diff(par()$usr[1:2])) if((direction=="downwards"&&diff(par()$usr[3:4])>0) || (direction=="upwards"&&diff(par()$usr[3:4])<0)) shift<--shift if(ftype){ text(labels=cw$tip.label[i],Y[i], H[which(cw$edge[,2]==i),2]+shift, pos=pos,offset=0,cex=fsize,font=ftype, srt=if(direction=="downwards") 270 else 90) } } } if(setEnv){ PP<-list(type="phylogram",use.edge.length=TRUE,node.pos=1, show.tip.label=if(ftype) TRUE else FALSE,show.node.label=FALSE, font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE,label.offset=offset, x.lim=xlim,y.lim=ylim, direction=direction,tip.color="black",Ntip=Ntip(cw),Nnode=cw$Nnode, edge=tree$edge,xx=Y[,1],yy=sapply(1:(Ntip(cw)+cw$Nnode), function(x,y,z) y[match(x,z)],y=H,z=cw$edge)) assign("last_plot.phylo",PP,envir=.PlotPhyloEnv) } if(plot) if(split.vertical) splitEdgeColor(cw,colors,lwd) } # function to plot simmap tree in type "phylogram" # written by Liam J. Revell 2011-2023 plotPhylogram<-function(tree,colors,fsize,ftype,lwd,pts,node.numbers,mar, add,offset,direction,setEnv,xlim,ylim,placement,tips,split.vertical,lend, asp,plot,underscore){ if(split.vertical&&!setEnv){ cat("split.vertical requires setEnv=TRUE. Setting split.vertical to FALSE.\n") spit.vertical<-FALSE } # set offset fudge (empirically determined) offsetFudge<-1.37 # reorder cw<-reorderSimmap(tree) pw<-reorderSimmap(tree,"postorder") # count nodes and tips n<-Ntip(cw) m<-cw$Nnode # Y coordinates for nodes Y<-matrix(NA,m+n,1) # first, assign y coordinates to all the tip nodes if(is.null(tips)) Y[cw$edge[cw$edge[,2]<=n,2]]<-1:n else Y[cw$edge[cw$edge[,2]<=n,2]]<-if(is.null(names(tips))) tips[sapply(1:Ntip(cw),function(x,y) which(y==x),y=cw$edge[cw$edge[,2]<=n,2])] else if(!underscore) tips[gsub(" ","_",cw$tip.label)] # get Y coordinates of the nodes nodes<-unique(pw$edge[,1]) for(i in 1:m){ if(placement=="intermediate"){ desc<-pw$edge[which(pw$edge[,1]==nodes[i]),2] Y[nodes[i]]<-(min(Y[desc])+max(Y[desc]))/2 } else if(placement=="centered"){ desc<-getDescendants(pw,nodes[i]) desc<-desc[desc<=Ntip(pw)] Y[nodes[i]]<-(min(Y[desc])+max(Y[desc]))/2 } else if(placement=="weighted"){ desc<-pw$edge[which(pw$edge[,1]==nodes[i]),2] n1<-desc[which(Y[desc]==min(Y[desc]))] n2<-desc[which(Y[desc]==max(Y[desc]))] v1<-pw$edge.length[which(pw$edge[,2]==n1)] v2<-pw$edge.length[which(pw$edge[,2]==n2)] Y[nodes[i]]<-((1/v1)*Y[n1]+(1/v2)*Y[n2])/(1/v1+1/v2) } else if(placement=="inner"){ desc<-getDescendants(pw,nodes[i]) desc<-desc[desc<=Ntip(pw)] mm<-which(abs(Y[desc]-median(Y[1:Ntip(pw)]))==min(abs(Y[desc]- median(Y[1:Ntip(pw)])))) if(length(mm>1)) mm<-mm[which(Y[desc][mm]==min(Y[desc][mm]))] Y[nodes[i]]<-Y[desc][mm] } else if(placement=="right"){ desc<-getDescendants(pw,nodes[i]) desc<-desc[desc<=Ntip(pw)] mm<-which(Y[desc]==max(Y[desc])) Y[nodes[i]]<-Y[desc][mm] } else if(placement=="left"){ desc<-getDescendants(pw,nodes[i]) desc<-desc[desc<=Ntip(pw)] mm<-which(Y[desc]==min(Y[desc])) Y[nodes[i]]<-Y[desc][mm] } } # compute node heights H<-nodeHeights(cw) # open plot par(mar=mar) if(is.null(offset)) offset<-0.2*lwd/3+0.2/3 if(!add) plot.new() ### if(is.null(xlim)){ pp<-par("pin")[1] sw<-fsize*(max(strwidth(cw$tip.label,units="inches")))+ offsetFudge*fsize*strwidth("W",units="inches") alp<-optimize(function(a,H,sw,pp) (a*1.04*max(H)+sw-pp)^2,H=H,sw=sw,pp=pp, interval=c(0,1e6))$minimum xlim<-if(direction=="leftwards") c(min(H)-sw/alp,max(H)) else c(min(H),max(H)+sw/alp) } if(is.null(ylim)) ylim=range(Y) if(direction=="leftwards") H<-max(H)-H plot.window(xlim=xlim,ylim=ylim,asp=asp) if(plot){ #### if(!split.vertical){ for(i in 1:m) lines(H[which(cw$edge[,1]==nodes[i]),1], Y[cw$edge[which(cw$edge[,1]==nodes[i]),2]],col=colors[names(cw$maps[[match(nodes[i], cw$edge[,1])]])[1]],lwd=lwd,lend=lend) } for(i in 1:nrow(cw$edge)){ x<-H[i,1] for(j in 1:length(cw$maps[[i]])){ if(direction=="leftwards") lines(c(x,x-cw$maps[[i]][j]),c(Y[cw$edge[i,2]],Y[cw$edge[i,2]]), col=colors[names(cw$maps[[i]])[j]],lwd=lwd,lend=lend) else lines(c(x,x+cw$maps[[i]][j]),c(Y[cw$edge[i,2]],Y[cw$edge[i,2]]), col=colors[names(cw$maps[[i]])[j]],lwd=lwd,lend=lend) if(pts) points(c(x,x+cw$maps[[i]][j]),c(Y[cw$edge[i,2]],Y[cw$edge[i,2]]), pch=20,lwd=(lwd-1)) x<-x+if(direction=="leftwards") -cw$maps[[i]][j] else cw$maps[[i]][j] j<-j+1 } } if(node.numbers){ symbols(if(direction=="leftwards") max(H) else 0, mean(Y[cw$edge[cw$edge[,1]==(Ntip(cw)+1),2]]), rectangles=matrix(c(1.2*fsize*strwidth(as.character(Ntip(cw)+1)), 1.4*fsize*strheight(as.character(Ntip(cw)+1))),1,2),inches=FALSE, bg="white",add=TRUE) text(if(direction=="leftwards") max(H) else 0, mean(Y[cw$edge[cw$edge[,1]==(Ntip(cw)+1),2]]),Ntip(cw)+1, cex=fsize) for(i in 1:nrow(cw$edge)){ x<-H[i,2] if(cw$edge[i,2]>Ntip(cw)){ symbols(x,Y[cw$edge[i,2]], rectangles=matrix(c(1.2*fsize*strwidth(as.character(cw$edge[i,2])), 1.4*fsize*strheight(as.character(cw$edge[i,2]))),1,2),inches=FALSE, bg="white",add=TRUE) text(x,Y[cw$edge[i,2]],cw$edge[i,2],cex=fsize) } } } if(direction=="leftwards") pos<-if(par()$usr[1]>par()$usr[2]) 4 else 2 if(direction=="rightwards") pos<-if(par()$usr[1]>par()$usr[2]) 2 else 4 for(i in 1:n) if(ftype) text(H[which(cw$edge[,2]==i),2],Y[i],cw$tip.label[i],pos=pos, offset=offset,cex=fsize,font=ftype) } if(setEnv){ PP<-list(type="phylogram",use.edge.length=TRUE,node.pos=1, show.tip.label=if(ftype) TRUE else FALSE,show.node.label=FALSE, font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE,label.offset=offset, x.lim=xlim,y.lim=ylim, direction=direction,tip.color="black",Ntip=Ntip(cw),Nnode=cw$Nnode, edge=tree$edge,xx=sapply(1:(Ntip(cw)+cw$Nnode), function(x,y,z) y[match(x,z)],y=H,z=cw$edge),yy=Y[,1]) assign("last_plot.phylo",PP,envir=.PlotPhyloEnv) } if(plot) if(split.vertical) splitEdgeColor(cw,colors,lwd) } # function to plot simmap tree in type "fan" # written by Liam J. Revell 2013-2017 plotFan<-function(tree,colors,fsize,ftype,lwd,mar,add,part,setEnv,xlim,ylim,tips,maxY,lend,plot,offset){ if(!plot) cat("plot=FALSE option is not permitted for type=\"fan\". Tree will be plotted.\n") if(is.null(offset)) offset<-1 # reorder cw<-reorder(tree) pw<-reorder(tree,"pruningwise") # count nodes and tips n<-Ntip(cw) m<-cw$Nnode # get Y coordinates on uncurved space Y<-vector(length=m+n) if(is.null(tips)) tips<-1:n if(part<1.0) Y[cw$edge[cw$edge[,2]<=n,2]]<-0:(n-1) else Y[cw$edge[cw$edge[,2]<=n,2]]<-tips nodes<-unique(pw$edge[,1]) for(i in 1:m){ desc<-pw$edge[which(pw$edge[,1]==nodes[i]),2] Y[nodes[i]]<-(min(Y[desc])+max(Y[desc]))/2 } if(is.null(maxY)) maxY<-max(Y) Y<-setNames(Y/maxY*2*pi,1:(n+m)) Y<-part*cbind(Y[as.character(cw$edge[,2])],Y[as.character(cw$edge[,2])]) R<-nodeHeights(cw) # now put into a circular coordinate system x<-R*cos(Y) y<-R*sin(Y) # optimize x & y limits par(mar=mar) offsetFudge<-1.37 # empirically determined OFFSET<-0 pp<-par("pin")[1] sw<-fsize*(max(strwidth(cw$tip.label,units="inches")))+ offsetFudge*OFFSET*fsize*strwidth("W",units="inches") alp<-optimize(function(a,H,sw,pp) (2*a*1.04*max(H)+2*sw-pp)^2,H=R,sw=sw,pp=pp, interval=c(0,1e6))$minimum if(part<=0.25) x.lim<-y.lim<-c(0,max(R)+sw/alp) else if(part>0.25&&part<=0.5){ x.lim<-c(-max(R)-sw/alp,max(R)+sw/alp) y.lim<-c(0,max(R)+sw/alp) } else x.lim<-y.lim<-c(-max(R)-sw/alp,max(R)+sw/alp) if(is.null(xlim)) xlim<-x.lim if(is.null(ylim)) ylim<-y.lim # plot tree if(!add) plot.new() plot.window(xlim=xlim,ylim=ylim,asp=1) # plot radial lines (edges) ## first, the lines emerging from the root (if there are only two): jj<-which(cw$edge[,1]==(Ntip(cw)+1)) if(length(jj)==2){ m.left<-cumsum(cw$maps[[jj[1]]])/sum(cw$maps[[jj[1]]]) xx.left<-c(x[jj[1],1],x[jj[1],1]+(x[jj[1],2]-x[jj[1],1])*m.left) yy.left<-c(y[jj[1],1],y[jj[1],1]+(y[jj[1],2]-y[jj[1],1])*m.left) m.right<-cumsum(cw$maps[[jj[2]]])/sum(cw$maps[[jj[2]]]) xx.right<-c(x[jj[2],1],x[jj[2],1]+(x[jj[2],2]-x[jj[2],1])*m.right) yy.right<-c(y[jj[2],1],y[jj[2],1]+(y[jj[2],2]-y[jj[2],1])*m.right) xx<-c(xx.left[length(xx.left):1],xx.right[2:length(xx.right)]) yy<-c(yy.left[length(yy.left):1],yy.right[2:length(yy.right)]) col<-colors[c(names(m.left)[length(m.left):1],names(m.right))] segments(xx[2:length(xx)-1],yy[2:length(yy)-1],xx[2:length(xx)],yy[2:length(yy)], col=col,lwd=lwd,lend=lend) } else jj<-NULL for(i in 1:nrow(cw$edge)){ if(i%in%jj==FALSE){ maps<-cumsum(cw$maps[[i]])/sum(cw$maps[[i]]) xx<-c(x[i,1],x[i,1]+(x[i,2]-x[i,1])*maps) yy<-c(y[i,1],y[i,1]+(y[i,2]-y[i,1])*maps) for(i in 1:(length(xx)-1)) lines(xx[i+0:1],yy[i+0:1],col=colors[names(maps)[i]], lwd=lwd,lend=lend) } } # plot circular lines for(i in 1:m+n){ r<-R[match(i,cw$edge)] a1<-min(Y[which(cw$edge==i)]) a2<-max(Y[which(cw$edge==i)]) draw.arc(0,0,r,a1,a2,lwd=lwd,col=colors[names(cw$maps[[match(i,cw$edge[,1])]])[1]]) } # plot labels for(i in 1:n){ ii<-which(cw$edge[,2]==i) aa<-Y[ii,2]/(2*pi)*360 adj<-if(aa>90&&aa<270) c(1,0.25) else c(0,0.25) tt<-if(aa>90&&aa<270) paste(cw$tip.label[i],paste(rep(" ",offset), collapse=""),sep="") else paste(paste(rep(" ",offset),collapse=""), cw$tip.label[i],sep="") aa<-if(aa>90&&aa<270) 180+aa else aa if(ftype) text(x[ii,2],y[ii,2],tt,srt=aa,adj=adj,cex=fsize,font=ftype) } if(setEnv){ PP<-list(type="fan",use.edge.length=TRUE,node.pos=1, show.tip.label=if(ftype) TRUE else FALSE,show.node.label=FALSE, font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE,label.offset=offset, x.lim=xlim,y.lim=ylim,direction="rightwards",tip.color="black", Ntip=Ntip(cw),Nnode=cw$Nnode,edge=tree$edge, xx=c(x[sapply(1:n,function(x,y) which(x==y)[1],y=cw$edge[,2]),2],x[1,1], if(m>1) x[sapply(2:m+n,function(x,y) which(x==y)[1],y=cw$edge[,2]),2] else c()), yy=c(y[sapply(1:n,function(x,y) which(x==y)[1],y=cw$edge[,2]),2],y[1,1], if(m>1) y[sapply(2:m+n,function(x,y) which(x==y)[1],y=cw$edge[,2]),2] else c())) assign("last_plot.phylo",PP,envir=.PlotPhyloEnv) } } ## internal function for slanted cladogram ## written by Liam J. Revell 2017-2023 plotCladogram<-function(tree,colors=NULL,fsize=1.0,ftype="reg",lwd=2,mar=NULL, add=FALSE,offset=NULL,direction="rightwards",xlim=NULL,ylim=NULL, nodes="intermediate",tips=NULL,lend=2,asp=NA,plot=TRUE,underscore=FALSE){ placement<-nodes # set offset fudge (empirically determined) offsetFudge<-1.37 # reorder cw<-reorderSimmap(tree) pw<-reorderSimmap(tree,"postorder") # count nodes and tips n<-Ntip(cw) m<-cw$Nnode # Y coordinates for nodes Y<-matrix(NA,m+n,1) # first, assign y coordinates to all the tip nodes if(is.null(tips)) Y[cw$edge[cw$edge[,2]<=n,2]]<-1:n else Y[cw$edge[cw$edge[,2]<=n,2]]<-if(is.null(names(tips))) tips[sapply(1:Ntip(cw),function(x,y) which(y==x),y=cw$edge[cw$edge[,2]<=n,2])] else if(!underscore) tips[gsub(" ","_",cw$tip.label)] # get Y coordinates of the nodes nodes<-unique(pw$edge[,1]) for(i in 1:m){ if(placement=="intermediate"){ desc<-pw$edge[which(pw$edge[,1]==nodes[i]),2] Y[nodes[i]]<-(min(Y[desc])+max(Y[desc]))/2 } else if(placement=="centered"){ desc<-getDescendants(pw,nodes[i]) desc<-desc[desc<=Ntip(pw)] Y[nodes[i]]<-(min(Y[desc])+max(Y[desc]))/2 } else if(placement=="weighted"){ desc<-pw$edge[which(pw$edge[,1]==nodes[i]),2] n1<-desc[which(Y[desc]==min(Y[desc]))] n2<-desc[which(Y[desc]==max(Y[desc]))] v1<-pw$edge.length[which(pw$edge[,2]==n1)] v2<-pw$edge.length[which(pw$edge[,2]==n2)] Y[nodes[i]]<-((1/v1)*Y[n1]+(1/v2)*Y[n2])/(1/v1+1/v2) } else if(placement=="inner"){ desc<-getDescendants(pw,nodes[i]) desc<-desc[desc<=Ntip(pw)] mm<-which(abs(Y[desc]-median(Y[1:Ntip(pw)]))==min(abs(Y[desc]- median(Y[1:Ntip(pw)])))) if(length(mm>1)) mm<-mm[which(Y[desc][mm]==min(Y[desc][mm]))] Y[nodes[i]]<-Y[desc][mm] } else if(placement=="right"){ desc<-getDescendants(pw,nodes[i]) desc<-desc[desc<=Ntip(pw)] mm<-which(Y[desc]==max(Y[desc])) Y[nodes[i]]<-Y[desc][mm] } else if(placement=="left"){ desc<-getDescendants(pw,nodes[i]) desc<-desc[desc<=Ntip(pw)] mm<-which(Y[desc]==min(Y[desc])) Y[nodes[i]]<-Y[desc][mm] } } # compute node heights H<-nodeHeights(cw) # open plot par(mar=mar) if(is.null(offset)) offset<-0.2*lwd/3+0.2/3 if(!add) plot.new() ### if(is.null(xlim)){ pp<-par("pin")[1] sw<-fsize*(max(strwidth(cw$tip.label,units="inches")))+ offsetFudge*fsize*strwidth("W",units="inches") alp<-optimize(function(a,H,sw,pp) (a*1.04*max(H)+sw-pp)^2,H=H,sw=sw,pp=pp, interval=c(0,1e6))$minimum xlim<-if(direction=="leftwards") c(min(H)-sw/alp,max(H)) else c(min(H),max(H)+sw/alp) } if(is.null(ylim)) ylim=range(Y) if(direction=="leftwards") H<-max(H)-H plot.window(xlim=xlim,ylim=ylim,asp=asp) if(plot){ #### for(i in 1:nrow(cw$edge)){ x<-H[i,1] y<-Y[cw$edge[i,1]] m<-(Y[cw$edge[i,2]]-Y[cw$edge[i,1]])/(H[i,2]-H[i,1]) if(is.finite(m)){ for(j in 1:length(cw$maps[[i]])){ if(direction=="leftwards") lines(c(x,x-cw$maps[[i]][j]),c(y,y-cw$maps[[i]][j]*m), col=colors[names(cw$maps[[i]])[j]],lwd=lwd,lend=lend) else lines(c(x,x+cw$maps[[i]][j]),c(y,y+cw$maps[[i]][j]*m), col=colors[names(cw$maps[[i]])[j]],lwd=lwd,lend=lend) x<-x+if(direction=="leftwards") -cw$maps[[i]][j] else cw$maps[[i]][j] y<-y+if(direction=="leftwards") -m*cw$maps[[i]][j] else m*cw$maps[[i]][j] j<-j+1 } } else { lines(rep(x,2),Y[cw$edge[i,]],col=colors[names(cw$maps[[i]])[1]],lwd=lwd, lend=lend) } } if(direction=="leftwards") pos<-if(par()$usr[1]>par()$usr[2]) 4 else 2 if(direction=="rightwards") pos<-if(par()$usr[1]>par()$usr[2]) 2 else 4 for(i in 1:n) if(ftype) text(H[which(cw$edge[,2]==i),2],Y[i],cw$tip.label[i],pos=pos, offset=offset,cex=fsize,font=ftype) } PP<-list(type="phylogram",use.edge.length=TRUE,node.pos=1, show.tip.label=if(ftype) TRUE else FALSE,show.node.label=FALSE, font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE,label.offset=offset, x.lim=xlim,y.lim=ylim, direction=direction,tip.color="black",Ntip=Ntip(cw),Nnode=cw$Nnode, edge=tree$edge,xx=sapply(1:(Ntip(cw)+cw$Nnode), function(x,y,z) y[match(x,z)],y=H,z=cw$edge),yy=Y[,1]) assign("last_plot.phylo",PP,envir=.PlotPhyloEnv) } ## adds legend to an open stochastic map style plot ## written by Liam J. Revell 2013, 2016, 2017, 2023 add.simmap.legend<-function(leg=NULL,colors,prompt=TRUE,vertical=TRUE,...){ if(hasArg(border)) border<-list(...)$border else border<-par()$fg if(hasArg(shape)) shape<-list(...)$shape else shape<-"square" if(prompt){ cat("Click where you want to draw the legend\n") x<-unlist(locator(1)) y<-x[2] x<-x[1] } else { if(hasArg(x)) x<-list(...)$x else x<-0 if(hasArg(y)) y<-list(...)$y else y<-0 } if(hasArg(fsize)) fsize<-list(...)$fsize else fsize<-1.0 if(is.null(leg)) leg<-names(colors) h<-fsize*strheight(LETTERS[1]) w<-par()$mfcol[2]*h*abs(diff(par()$usr[1:2])/diff(par()$usr[3:4])) flipped<-par()$usr[1]>par()$usr[2] if(vertical){ y<-y-0:(length(leg)-1)*1.5*h x<-rep(x+w/2,length(y)) text(x + if(flipped) -w else w,y,leg,pos=4,cex=fsize/par()$cex) } else { sp<-abs(fsize*max(strwidth(leg))) x<-x + if(flipped) w/2-0:(length(leg)-1)*1.5*(sp+w) else -w/2+0:(length(leg)-1)*1.5*(sp+w) y<-rep(y+w/2,length(x)) text(x,y,leg,pos=4,cex=fsize/par()$cex) } if(shape=="square") symbols(x,y,squares=rep(w,length(x)),bg=colors,add=TRUE,inches=FALSE, fg=border) else if(shape=="circle") nulo<-mapply(draw.circle,x=x,y=y,col=colors, MoreArgs=list(nv=200,radius=w/2,border=border)) else stop(paste("shape=\"",shape,"\" is not a recognized option.",sep="")) } # function plots a tree; in the new version this is just a wrapper for plotSimmap # written by Liam Revell 2012-2017, 2023 plotTree<-function(tree,...){ if(hasArg(color)) color<-list(...)$color else color<-NULL if(hasArg(fsize)) fsize<-list(...)$fsize else fsize<-1.0 if(hasArg(ftype)) ftype<-list(...)$ftype else ftype<-"reg" if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-2 if(hasArg(pts)) pts<-list(...)$pts else pts<-FALSE if(hasArg(node.numbers)) node.numbers<-list(...)$node.numbers else node.numbers<-FALSE if(hasArg(mar)) mar<-list(...)$mar else mar<-NULL if(hasArg(add)) add<-list(...)$add else add<-FALSE if(hasArg(offset)) offset<-list(...)$offset else offset<-NULL if(hasArg(type)) type<-list(...)$type else type<-"phylogram" if(hasArg(direction)) direction<-list(...)$direction else direction<-"rightwards" if(hasArg(setEnv)) setEnv<-list(...)$setEnv else setEnv<-TRUE if(hasArg(part)) part<-list(...)$part else part<-if(type=="arc") 0.5 else 1 if(hasArg(xlim)) xlim<-list(...)$xlim else xlim<-NULL if(hasArg(ylim)) ylim<-list(...)$ylim else ylim<-NULL if(hasArg(nodes)) nodes<-list(...)$nodes else nodes<-"intermediate" if(hasArg(tips)) tips<-list(...)$tips else tips<-NULL if(hasArg(maxY)) maxY<-list(...)$maxY else maxY<-NULL if(hasArg(hold)) hold<-list(...)$hold else hold<-TRUE if(hasArg(lend)) lend<-list(...)$lend else lend<-2 if(hasArg(asp)) asp<-list(...)$asp else asp<-NA if(hasArg(plot)) plot<-list(...)$plot else plot<-TRUE if(hasArg(underscore)) underscore<-list(...)$underscore else underscore<-FALSE if(hasArg(arc_height)) arc_height<-list(...)$arc_height else arc_height<-2 if(inherits(tree,"multiPhylo")){ par(ask=TRUE) if(!is.null(color)) names(color)<-"1" for(i in 1:length(tree)) plotTree(tree[[i]],color=color,fsize=fsize,ftype=ftype, lwd=lwd,pts=pts,node.numbers=node.numbers,mar=mar,add=add,offset=offset, direction=direction,type=type,setEnv=setEnv,part=part,xlim=xlim,ylim=ylim, nodes=nodes,tips=tips,maxY=maxY,hold=hold,lend=lend,asp=asp,plot=plot, underscore=underscore,arc_height=arc_height) } else { if(is.null(tree$edge.length)) tree<-compute.brlen(tree) tree$maps<-as.list(tree$edge.length) for(i in 1:length(tree$maps)) names(tree$maps[[i]])<-c("1") if(!is.null(color)) names(color)<-"1" plotSimmap(tree,colors=color,fsize=fsize,ftype=ftype,lwd=lwd,pts=pts, node.numbers=node.numbers,mar=mar,add=add,offset=offset,direction=direction, type=type,setEnv=setEnv,part=part,xlim=xlim,ylim=ylim,nodes=nodes,tips=tips,maxY=maxY, hold=hold,lend=lend,asp=asp,plot=plot,underscore=underscore,arc_height=arc_height) } } ## S3 method for objects of class "simmap" & "multiSimmap" ## added by Liam J. Revell 2015 plot.simmap<-function(x,...) plotSimmap(x,...) plot.multiSimmap<-function(x,...) plotSimmap(x,...) ## function to split vertical plotted lines by the states of daughter edges ## written by Liam J. Revell 2015 splitEdgeColor<-function(tree,colors,lwd=2){ obj<-get("last_plot.phylo",envir=.PlotPhyloEnv) for(i in 1:tree$Nnode+Ntip(tree)){ daughters<-tree$edge[which(tree$edge[,1]==i),2] cols<-vector() for(j in 1:length(daughters)){ jj<-which(tree$edge[,2]==daughters[j]) cols[j]<-if(tree$maps[[jj]][1]==0&&length(tree$maps[[jj]])>1) colors[names(tree$maps[[jj]])[2]] else colors[names(tree$maps[[jj]])[1]] } ii<-order(obj$yy[c(i,daughters)]) jj<-order(obj$yy[daughters]) x0<-x1<-rep(obj$xx[i],length(daughters)) y0<-obj$yy[c(i,daughters)][ii][1:length(daughters)] y1<-obj$yy[c(i,daughters)][ii][2:(length(daughters)+1)] cols<-cols[jj] for(j in 1:length(x0)) segments(x0[j],y0[j],x1[j],y1[j],col=cols[j],lwd=lwd,lend=2) } } phytools/R/sim.history.R0000644000176200001440000001215514375517350014765 0ustar liggesusers## function simulates stochastic character history under some model ## written by Liam J. Revell 2011, 2013, 2014, 2016, 2020 sim.history<-function(tree,Q,anc=NULL,nsim=1,direction=c("column_to_row","row_to_column"), ...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(hasArg(message)) message<-list(...)$message else message<-TRUE direction<-direction[1] direction<-strsplit(direction,"_")[[1]][1] # reorder to cladewise tree<-reorder.phylo(tree,"cladewise") # check Q if(!isSymmetric(Q)) if(message){ if(direction=="column") cat("Note - the rate of substitution from i->j should be given by Q[j,i].\n") else if(direction=="row") cat("Note - the rate of substitution from i->j should be given by Q[i,j].\n") } if(direction=="column"){ if(!all(round(colSums(Q),10)==0)){ if(all(round(rowSums(Q),10)==0)&&!isSymmetric(Q)){ if(message){ cat("Detecting that rows, not columns, of Q sum to zero :\n") cat("Transposing Q for internal calculations.\n") } Q<-t(Q) } else { if(message) cat("Some columns (or rows) of Q don't sum to 0.0. Fixing.\n") diag(Q)<-0 diag(Q)<--colSums(Q,na.rm=TRUE) } } } else if(direction=="row"){ Q<-t(Q) if(!all(round(colSums(Q),10)==0)){ if(all(round(rowSums(Q),10)==0)&&!isSymmetric(Q)){ if(message){ cat("Detecting that columns, not rows, of Q sum to zero :\n") cat("Transposing Q for internal calculations.\n") } Q<-t(Q) } else { if(message) cat("Some columns (or rows) of Q don't sum to 0.0. Fixing.\n") diag(Q)<-0 diag(Q)<--colSums(Q,na.rm=TRUE) } } } # does Q have names? if(is.null(dimnames(Q))) dimnames(Q)<-list(1:nrow(Q),1:ncol(Q)) # create "multiPhylo" object mtrees<-vector(mode="list",length=nsim) class(mtrees)<-c("multiSimmap","multiPhylo") ## deal with ancestral state if(is.null(anc)) anc<-setNames(rep(1/ncol(Q),ncol(Q)),colnames(Q)) if(is.character(anc)){ anc<-colSums(to.matrix(anc,colnames(Q))) anc<-anc/sum(anc) } # now loop for(i in 1:nsim){ # set root state a<-rstate(anc) # create the map tree object mtree<-tree mtree$maps<-vector(mode="list",length=nrow(tree$edge)) # now we want to simulate the node states on the tree node.states<-matrix(NA,nrow(tree$edge),ncol(tree$edge)) node.states[which(tree$edge[,1]==(length(tree$tip)+1)),1]<-a for(j in 1:nrow(tree$edge)){ if(tree$edge.length[j]==0){ map<-vector() map[1]<-tree$edge.length[j] names(map)[1]<- node.states[which(tree$edge[,1]==tree$edge[j,2]),1]<- node.states[j,2]<-node.states[j,1] } else { time=0 state<-node.states[j,1] new.state<-state dt<-vector() map<-vector() k<-1 while(timenode.states[j,2]-> node.states[which(tree$edge[,1]==tree$edge[j,2]),1] } mtree$maps[[j]]<-map } # add a couple of elements mtree$node.states<-node.states tip.states<-node.states[tree$edge[,2]<=length(tree$tip),2] tip.states<-tip.states[order(tree$edge[tree$edge[,2]<=length(tree$tip),2])] names(tip.states)<-tree$tip.label mtree$states<-tip.states # now construct the matrix "mapped.edge" (for backward compatibility allstates<-vector() for(j in 1:nrow(mtree$edge)) allstates<-c(allstates,names(mtree$maps[[j]])) allstates<-unique(allstates) mtree$mapped.edge<-matrix(data=0,length(mtree$edge.length), length(allstates),dimnames=list(apply(mtree$edge,1, function(x) paste(x,collapse=",")),state=allstates)) for(j in 1:length(mtree$maps)) for(k in 1:length(mtree$maps[[j]])) mtree$mapped.edge[j,names(mtree$maps[[j]])[k]]<- mtree$mapped.edge[j,names(mtree$maps[[j]])[k]]+ mtree$maps[[j]][k] class(mtree)<-c("simmap",setdiff(class(mtree),"simmap")) mtrees[[i]]<-mtree } if(nsim==1) mtrees<-mtrees[[1]] if(message) cat("Done simulation(s).\n") mtrees } ## simulate DNA sequence from a tree & model parameters ## written by Liam J. Revell 2013, 2019 genSeq<-function(tree,l=1000,Q=NULL,rate=1,format="DNAbin",...){ if(is.null(Q)){ Q<-matrix(1,4,4) rownames(Q)<-colnames(Q)<-c("a","c","g","t") diag(Q)<-0 diag(Q)<--colSums(Q) } if(length(rate)!=l){ if(length(rate)==1) rate<-rep(rate,l) else { cat("warning: length(rate) & l should match for length(rate)>1\n") cat(" rate will be recycled.\n") rate<-rep(rate,ceiling(l/length(rate)))[1:l] } } cat("simulating sequences....\n") flush.console() X<-sapply(rate,function(a,b,c) sim.Mk(b,a*c),b=tree,c=Q) if(format=="DNAbin") return(as.DNAbin(X)) else if(format=="phyDat") return(as.phyDat(X)) else if(format=="matrix") return(X) } phytools/R/make.simmap.R0000644000176200001440000005140614522524013014665 0ustar liggesusers## function creates a stochastic character mapped tree as a modified "phylo" object ## written by Liam Revell 2013, 2014, 2015, 2016, 2017, 2018, 2019, 2020, 2021, 2022, 2023 ## S3 method for Mk models & objects of various classes simmap<-function(object,...) UseMethod("simmap") simmap.default<-function(object,...){ warning(paste( "simmap does not know how to handle objects of class ", class(object),".\n")) } simmap.simmap<-function(object,...){ args<-list(...) args$tree<-as.phylo(object) args$x<-getStates(object,"tips") if(hasArg(Q)) Q<-list(...)$Q else { args$Q<-if(!is.null(object$Q)) object$Q } args$pi<-if(hasArg(pi)) list(...)$pi else "fitzjohn" if(hasArg(nsim)){ nsim<-list(...)$nsim args$nsim<-nsim } else args$nsim<-100 if(hasArg(trace)) trace<-list(...)$trace else trace<-0 if(trace>0) args$message<-TRUE else args$message<-FALSE do.call(make.simmap,args) } simmap.fitpolyMk<-function(object,...) simmap.fitMk(object,...) simmap.fitMk<-function(object,...){ args<-list(...) args$tree<-object$tree args$x<-object$data args$Q<-as.Qmatrix(object) args$pi<-if(object$root.prior=="fitzjohn") "fitzjohn" else object$pi if(is.null(args$nsim)) args$nsim<-100 if(hasArg(trace)) trace<-list(...)$trace else trace<-0 if(trace>0) args$message<-TRUE else args$message<-FALSE do.call(make.simmap,args) } simmap.anova.fitMk<-function(object,...){ if(hasArg(weighted)) weighted<-list(...)$weighted else weighted<-TRUE if(hasArg(nsim)) nsim<-list(...)$nsim else nsim<-100 if(weighted){ w<-object$weight mods<-sample(1:length(w),size=nsim,replace=TRUE,prob=w) } else { best<-which(object$AIC==min(object$AIC)) mods<-sample(best,size=nsim,replace=TRUE) } fits<-attr(object,"models")[mods] foo<-function(obj,args){ args$object<-obj do.call(simmap,args) } args<-list(...) args$nsim<-1 tt<-lapply(fits,foo,args=args) class(tt)<-c("multiSimmap","multiPhylo") return(tt) } make.simmap<-function(tree,x,model="SYM",nsim=1,...){ if(inherits(tree,"multiPhylo")){ ff<-function(yy,x,model,nsim,...){ zz<-make.simmap(yy,x,model,nsim,...) if(nsim>1) class(zz)<-NULL return(zz) } if(nsim>1){ mtrees<-unlist(sapply(tree,ff,x,model,nsim,...,simplify=FALSE), recursive=FALSE) } else mtrees<-sapply(tree,ff,x,model,nsim,...,simplify=FALSE) class(mtrees)<-c("multiSimmap","multiPhylo") } else { ## get optional arguments if(hasArg(pi)) pi<-list(...)$pi else pi<-"equal" if(hasArg(message)) pm<-list(...)$message else pm<-TRUE if(hasArg(tol)) tol<-list(...)$tol else tol<-0 if(hasArg(Q)) Q<-list(...)$Q else Q<-"empirical" if(hasArg(burnin)) burnin<-list(...)$burnin else burnin<-1000 if(hasArg(samplefreq)) samplefreq<-list(...)$samplefreq else samplefreq<-100 if(hasArg(vQ)) vQ<-list(...)$vQ else vQ<-0.1 prior<-list(alpha=1,beta=1,use.empirical=FALSE) if(hasArg(prior)){ pr<-list(...)$prior prior[names(pr)]<-pr } ## done optional arguments # check if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".") # if vector convert to binary matrix if(!is.matrix(x)) xx<-to.matrix(x,sort(unique(x))) else xx<-x xx<-xx[tree$tip.label,] xx<-xx/rowSums(xx) # reorder to cladewise tree<-bt<-reorder.phylo(tree,"cladewise") ## this seems to be outdated & no longer needed ## if(!is.binary(bt)) bt<-multi2di(bt,random=FALSE) # some preliminaries N<-Ntip(tree) m<-ncol(xx) root<-N+1 # get conditional likelihoods & model if(is.character(Q)&&Q=="empirical"){ XX<-getPars(bt,xx,model,Q=NULL,tree,tol,m,pi=pi,args=list(...)) L<-XX$L Q<-XX$Q logL<-XX$loglik pi<-XX$pi if(pi[1]=="equal") pi<-setNames(rep(1/m,m),colnames(L)) # set equal else if(pi[1]=="estimated") pi<-statdist(Q) # set from stationary distribution else if(pi[1]=="fitzjohn") pi<-"fitzjohn" else pi<-pi/sum(pi) # obtain from input if(pm) printmessage(Q,pi,method="empirical") mtrees<-replicate(nsim,smap(tree,x,N,m,root,L,Q,pi,logL),simplify=FALSE) } else if(is.character(Q)&&Q=="mcmc"){ if(prior$use.empirical){ qq<-fitMk(bt,xx,model)$rates prior$alpha<-qq*prior$beta } get.stationary<-if(pi[1]=="estimated") TRUE else FALSE if(pi[1]%in%c("equal","estimated")) pi<-setNames(rep(1/m,m),colnames(xx)) # set equal else if(pi[1]=="fitzjohn") pi<-"fitzjohn" else pi<-pi/sum(pi) # obtain from input XX<-mcmcQ(bt,xx,model,tree,tol,m,burnin,samplefreq,nsim,vQ,prior,pi=pi) L<-lapply(XX,function(x) x$L) Q<-lapply(XX,function(x) x$Q) logL<-lapply(XX,function(x) x$loglik) pi<-if(get.stationary) lapply(Q,statdist) else if(pi[1]=="fitzjohn") lapply(XX,function(x) x$pi) else lapply(1:nsim,function(x,y) y,y=pi) if(pm) printmessage(Reduce('+',Q)/length(Q),Reduce('+',pi)/length(pi), method="mcmc") mtrees<-if(nsim>1) mapply(smap,L=L,Q=Q,pi=pi,logL=logL,MoreArgs= list(tree=tree,x=x,N=N,m=m,root=root),SIMPLIFY=FALSE) else list(smap(tree=tree,x=x,N=N,m=m,root=root,L=L[[1]],Q=Q[[1]],pi=pi[[1]], logL=logL[[1]])) } else if(is(Q,"Qmatrix")||is.matrix(Q)){ if(is(Q,"Qmatrix")) Q<-unclass(Q) XX<-getPars(bt,xx,model,Q=Q,tree,tol,m,pi=pi,args=list(...)) L<-XX$L logL<-XX$loglik pi<-XX$pi if(pi[1]=="equal") pi<-setNames(rep(1/m,m),colnames(L)) # set equal else if(pi[1]=="estimated") pi<-statdist(Q) # set from stationary distribution else if(pi[1]=="fitzjohn") pi<-"fitzjohn" else pi<-pi/sum(pi) # obtain from input if(pm) printmessage(Q,pi,method="fixed") mtrees<-replicate(nsim,smap(tree,x,N,m,root,L,Q,pi,logL),simplify=FALSE) } if(length(mtrees)==1) mtrees<-mtrees[[1]] else class(mtrees)<-c("multiSimmap","multiPhylo") } (if(hasArg(message)) list(...)$message else TRUE) if((if(hasArg(message)) list(...)$message else TRUE)&&inherits(tree,"phylo")) message("Done.") return(mtrees) } # print message # written by Liam J. Revell 2013 printmessage<-function(Q,pi,method){ if(method=="empirical"||method=="fixed") cat("make.simmap is sampling character histories conditioned on\nthe transition matrix\n\nQ =\n") else if(method=="mcmc"){ cat("make.simmap is simulating with a sample of Q from\nthe posterior distribution\n") cat("\nMean Q from the posterior is\nQ =\n") } print(Q) if(method=="empirical") cat("(estimated using likelihood);\n") else if(method=="fixed") cat("(specified by the user);\n") cat("and (mean) root node prior probabilities\npi =\n") if(is.list(pi)) pi<-Reduce("+",pi)/length(pi) print(pi) flush.console() } # mcmc for Q used in Q="mcmc" # written by Liam J. Revell 2013 mcmcQ<-function(bt,xx,model,tree,tol,m,burnin,samplefreq,nsim,vQ,prior,pi,args=list()){ update<-function(x){ x<-abs(x+rnorm(n=np,mean=0,sd=sqrt(vQ))) return(x) } # get model matrix if(is.character(model)){ rate<-matrix(NA,m,m) if(model=="ER"){ np<-rate[]<-1 diag(rate)<-NA } if(model=="ARD"){ np<-m*(m-1) rate[col(rate)!=row(rate)]<-1:np } if(model=="SYM") { np<-m*(m-1)/2 sel<-col(rate)=runif(n=1)){ yy<-zz p<-pp } } # now run MCMC generation, sampling at samplefreq cat(paste("Running",samplefreq*nsim,"generations of MCMC, sampling every",samplefreq,"generations.\nPlease wait....\n\n")) flush.console() XX<-vector("list",nsim) for(i in 1:(samplefreq*nsim)){ pp<-update(p) Qp<-matrix(c(0,pp)[rate+1],m,m) diag(Qp)<--rowSums(Qp,na.rm=TRUE) zz<-getPars(bt,xx,model,Qp,tree,tol,m,FALSE,pi=pi,args) p.odds<-exp(zz$loglik+sum(dgamma(pp,prior$alpha,prior$beta,log=TRUE))- yy$loglik-sum(dgamma(p,prior$alpha,prior$beta,log=TRUE))) if(p.odds>=runif(n=1)){ yy<-zz p<-pp } if(i%%samplefreq==0){ Qi<-matrix(c(0,p)[rate+1],m,m) diag(Qi)<--rowSums(Qi,na.rm=TRUE) XX[[i/samplefreq]]<-getPars(bt,xx,model,Qi,tree,tol,m,TRUE,pi=pi,args) } } return(XX) } # get pars # written by Liam J. Revell 2013, 2017, 2021, 2023 getPars<-function(bt,xx,model,Q,tree,tol,m,liks=TRUE,pi,args=list()){ if(!is.null(args$pi)) args$pi<-NULL args<-c(list(tree=bt,x=xx,model=model,fixedQ=Q,output.liks=liks,pi=pi),args) obj<-do.call(fitMk,args) N<-length(bt$tip.label) pi<-obj$pi II<-obj$index.matrix+1 lvls<-obj$states if(liks){ L<-obj$lik.anc rownames(L)<-N+1:nrow(L) ## this seems to be outdated & no longer needed #if(!is.binary(tree)){ # ancNames<-matchNodes(tree,bt) # L<-L[as.character(ancNames[,2]),] # rownames(L)<-ancNames[,1] #} L<-rbind(xx,L) rownames(L)[1:N]<-1:N } else L<-NULL Q<-matrix(c(0,obj$rates)[II],m,m,dimnames=list(lvls,lvls)) if(any(rowSums(Q,na.rm=TRUE)0) rexp(n=1,rate=-Q[s,s]) else t-sum(dt) if(sum(dt)<(t-tol)){ dt<-c(dt,0) if(sum(Q[s,][-match(s,colnames(Q))])>0) names(dt)[length(dt)]<-rstate(Q[s,][-match(s,colnames(Q))]/sum(Q[s,][-match(s,colnames(Q))])) else names(dt)[length(dt)]<-s } else dt[length(dt)]<-dt[length(dt)]-sum(dt)+t } return(dt) } # function uses numerical optimization to solve for the stationary distribution # written by Liam J. Revell 2013 statdist<-function(Q){ foo<-function(theta,Q){ Pi<-c(theta[1:(nrow(Q)-1)],1-sum(theta[1:(nrow(Q)-1)])) sum((Pi%*%Q)^2) } k<-nrow(Q) if(nrow(Q)>2){ fit<-optim(rep(1/k,k-1),foo,Q=Q,control=list(reltol=1e-16)) return(setNames(c(fit$par[1:(k-1)],1-sum(fit$par[1:(k-1)])),rownames(Q))) } else { fit<-optimize(foo,interval=c(0,1),Q=Q) return(setNames(c(fit$minimum,1-fit$minimum),rownames(Q))) } } ## S3 print method for objects of class "simmap" & multiSimmap ## based on print.phylo in ape print.simmap<-function(x,printlen=6,...){ N<-Ntip(x) M<-x$Nnode cat(paste("\nPhylogenetic tree with",N,"tips and",M,"internal nodes.\n\n")) cat("Tip labels:\n") if(N>printlen) cat(paste("\t",paste(x$tip.label[1:printlen],collapse=", "),", ...\n",sep="")) else print(x$tip.label) ss<-sort(unique(c(getStates(x,"tips"),getStates(x,"nodes")))) cat(paste("\nThe tree includes a mapped, ",length(ss),"-state discrete character\nwith states:\n", sep="")) if(length(ss)>printlen) cat(paste("\t",paste(ss[1:printlen],collapse=", "),", ...\n",sep="")) else cat(paste("\t",paste(ss,collapse=", "),"\n",sep="")) rlab<-if(is.rooted(x)) "Rooted" else "Unrooted" cat("\n",rlab,"; includes branch lengths.\n",sep="") } print.multiSimmap<-function(x,details=FALSE,...){ N<-length(x) cat(N,"phylogenetic trees with mapped discrete characters\n") if(details){ n<-sapply(x,Ntip) s<-sapply(x,function(x) length(unique(c(getStates(x,"tips"),getStates(x,"nodes"))))) for(i in 1:N) cat("tree",i,":",n[i],"tips,",s[i],"mapped states\n") } } ## S3 summary method for objects of class "simmap" & "multiSimmap" summary.simmap<-function(object,...) describe.simmap(object,...) summary.multiSimmap<-function(object,...) describe.simmap(object,...) ## for backward compatibility with any function using apeAce internally apeAce<-function(tree,x,model,fixedQ=NULL,...){ if(hasArg(output.liks)){ output.liks<-list(...)$output.liks return(fitMk(tree,x,model,fixedQ,...)) } else { output.liks<-TRUE return(fitMk(tree,x,model,fixedQ,output.liks=TRUE,...)) } } ## S3 logLik methods for "simmap" & "multiSimmap" logLik.simmap<-function(object,...) object$logL logLik.multiSimmap<-function(object,...) sapply(object,function(x) x$logL) ## S3 density method for "multiSimmap" density.multiSimmap<-function(x,...){ if(hasArg(method)) method<-list(...)$method else method<-"changes" if(!method%in%c("densityMap","changes")){ cat("method not recognized. Setting to default method.\n\n") method<-"changes" } if(method=="densityMap") obj<-densityMap(x,plot=FALSE,...) else if(method=="changes"){ if(hasArg(bw)) bw<-list(...)$bw else bw<-1 tmp<-summary(x) ab<-lapply(2:ncol(tmp$count),function(i,x) x[,i],x=tmp$count) names(ab)<-sapply(strsplit(colnames(tmp$count)[2:ncol(tmp$count)], ","),function(x) paste(x,collapse="->")) ab<-lapply(ab,function(x){ class(x)<-"mcmc" x }) hpd.ab<-lapply(ab,HPDinterval) minmax<-range(unlist(ab)) pcalc<-function(x,mm) hist(x,breaks=seq(mm[1]-1.5,mm[2]+1.5,bw),plot=FALSE) p.ab<-lapply(ab,pcalc,mm=minmax) states<-colnames(tmp$ace) trans<-names(ab) obj<-list(hpd=hpd.ab, p=p.ab, states=states,trans=trans, bw=bw, mins=sapply(ab,min), meds=sapply(ab,median), means=sapply(ab,mean), maxs=sapply(ab,max)) class(obj)<-"changesMap" } else if(method=="timings"){ cat("This method doesn't work yet.\n") obj<-NULL } obj } ## S3 plot method for "changesMap" object from density.multiSimmap plot.changesMap<-function(x,...){ if(hasArg(bty)) bty<-list(...)$bty else bty<-"l" if(hasArg(alpha)) alpha<-list(...)$alpha else alpha<-0.3 if(hasArg(xlim)) xlim<-list(...)$xlim else xlim<-NULL if(hasArg(ylim)) ylim<-list(...)$ylim else ylim<-NULL if(hasArg(main)) main<-list(...)$main else main<-NULL if(hasArg(colors)){ colors<-list(...)$colors nn<-names(colors) colors<-setNames(make.transparent(colors,alpha),nn) } else { colors<-if(length(x$trans)==2) setNames(make.transparent(c("blue","red"),alpha),x$trans) else setNames(rep(make.transparent("blue",alpha),length(x$trans)), x$trans) } if(length(colors)1){ cat("transition should be of length 1; truncating to first element.\n") transition<-transition[1] } } else transition<-NULL p<-x$p hpd<-x$hpd bw<-x$bw if(length(x$trans)==2&&is.null(transition)){ plot(p[[1]]$mids,p[[1]]$density,xlim=if(is.null(xlim)) c(min(x$mins)-1,max(x$maxs)+1) else xlim, ylim=if(is.null(ylim)) c(0,1.2*max(c(p[[1]]$density, p[[2]]$density))) else ylim, type="n",xlab="number of changes", ylab="relative frequency across stochastic maps", bty=bty) y2<-rep(p[[1]]$density,each=2) y2<-y2[-length(y2)] x2<-rep(p[[1]]$mids-bw/2,each=2)[-1] x3<-c(min(x2),x2,max(x2)) y3<-c(0,y2,0) polygon(x3,y3,col=colors[x$trans[1]],border=FALSE) lines(p[[1]]$mids-bw/2,p[[1]]$density,type="s") y2<-rep(p[[2]]$density,each=2) y2<-y2[-length(y2)] x2<-rep(p[[2]]$mids-bw/2,each=2)[-1] x3<-c(min(x2),x2,max(x2)) y3<-c(0,y2,0) polygon(x3,y3,col=colors[x$trans[2]],border=FALSE) lines(p[[2]]$mids-bw/2,p[[2]]$density,type="s") dd<-0.01*diff(par()$usr[3:4]) lines(hpd[[1]],rep(max(p[[1]]$density)+dd,2)) lines(rep(hpd[[1]][1],2),c(max(p[[1]]$density)+dd, max(p[[1]]$density)+dd-0.005)) lines(rep(hpd[[1]][2],2),c(max(p[[1]]$density)+dd, max(p[[1]]$density)+dd-0.005)) CHARS<-strsplit(x$trans[1],"->")[[1]] CHARS[1]<-paste("HPD(",CHARS[1],collapse="") CHARS[2]<-paste(CHARS[2],")",collapse="") T1<-bquote(.(CHARS[1])%->%.(CHARS[2])) text(mean(hpd[[1]]),max(p[[1]]$density)+dd, T1,pos=3) lines(hpd[[2]],rep(max(p[[2]]$density)+dd,2)) lines(rep(hpd[[2]][1],2),c(max(p[[2]]$density)+dd, max(p[[2]]$density)+dd-0.005)) lines(rep(hpd[[2]][2],2),c(max(p[[2]]$density)+dd, max(p[[2]]$density)+dd-0.005)) CHARS<-strsplit(x$trans[2],"->")[[1]] CHARS[1]<-paste("HPD(",CHARS[1],collapse="") CHARS[2]<-paste(CHARS[2],")",collapse="") T2<-bquote(.(CHARS[1])%->%.(CHARS[2])) text(mean(hpd[[2]]),max(p[[2]]$density)+dd, T2,pos=3) CHARS<-strsplit(x$trans[1],"->")[[1]] T1<-bquote(.(CHARS[1])%->%.(CHARS[2])) CHARS<-strsplit(x$trans[2],"->")[[1]] T2<-bquote(.(CHARS[1])%->%.(CHARS[2])) legend("topleft",legend=c(T1,T2),pch=22,pt.cex=2.2,bty="n", pt.bg=colors[x$trans]) } else { k<-if(is.null(transition)) length(x$states) else 1 if(k>1) par(mfrow=c(k,k)) ii<-if(is.null(transition)) 1 else which(x$trans==transition) max.d<-max(unlist(lapply(p,function(x) x$density))) for(i in 1:k){ for(j in 1:k){ if(i==j&&is.null(transition)) plot.new() else { CHARS<-strsplit(x$trans[ii],"->")[[1]] MAIN<-if(is.null(main)) bquote(.(CHARS[1])%->%.(CHARS[2])) else main plot(p[[ii]]$mids,p[[ii]]$density,xlim=if(is.null(xlim)) c(min(x$mins)-1,max(x$maxs)+1) else xlim, ylim=if(is.null(ylim)) c(0,1.2*max.d) else ylim, type="n",xlab="number of changes", ylab="relative frequency",main=MAIN,font.main=1, bty=bty) y2<-rep(p[[ii]]$density,each=2) y2<-y2[-length(y2)] x2<-rep(p[[ii]]$mids-bw/2,each=2)[-1] x3<-c(min(x2),x2,max(x2)) y3<-c(0,y2,0) polygon(x3,y3,col=colors[x$trans[ii]],border=FALSE) lines(p[[ii]]$mids-bw/2,p[[ii]]$density,type="s") dd<-0.03*diff(par()$usr[3:4]) lines(hpd[[ii]],rep(max(p[[ii]]$density)+dd,2)) text(mean(hpd[[ii]]),max(p[[ii]]$density)+dd,"HPD",pos=3) ii<-ii+1 } } } } } print.changesMap<-function(x, ...){ if(hasArg(signif)) signif<-list(...)$signif else signif<-2 cat("\nDistribution of changes from stochastic mapping:\n") NROW<-ceiling(length(x$trans)/2) if(NROW>1) cat("\n") for(i in 1:NROW){ ii<-2*i-1 jj<-ii+1 cat(paste("\t",x$trans[ii],"\t\t",x$trans[jj],"\n",sep="")) cat(paste("\tMin. :",round(x$mins[ii],signif), "\tMin. :",round(x$mins[jj],signif),"\n",sep="")) cat(paste("\tMedian :",round(x$meds[ii],signif), "\tMedian :",round(x$meds[jj],signif),"\n",sep="")) cat(paste("\tMean :",round(x$means[ii],signif), "\tMean :",round(x$means[jj],signif),"\n",sep="")) cat(paste("\tMax. :",round(x$maxs[ii],signif), "\tMax. :",round(x$maxs[jj],signif),"\n\n",sep="")) } for(i in 1:length(x$trans)) cat("95% HPD interval(",x$trans[i],"): [",x$hpd[[i]][1],", ", x$hpd[[i]][2],"]\n",sep="") cat("\n") } phytools/R/multi.mantel.R0000644000176200001440000000622114375517350015103 0ustar liggesusers## function for multiple matrix regression with P-values computed by Mantel permutation of the dependent matrix ## written by Liam J. Revell 2012, 2017, 2022 multi.mantel<-function(Y,X,nperm=1000){ y<-unfoldLower(Y) if(!is.list(X)) X<-list(X) Xv<-sapply(X,unfoldLower) colnames(Xv)<-paste("X",1:ncol(Xv),sep="") fit<-lm(y~Xv) coefficients<-fit$coefficients smmry<-summary(fit) r.squared<-smmry$r.squared fstatistic<-smmry$fstatistic[1] pF<-0 tstatistic<-smmry$coefficients[,"t value"] pT<-rep(0,length(tstatistic)) # begin Mantel permutations Y<-Yp<-as.matrix(Y) for(i in 1:nperm){ y<-unfoldLower(Yp) fitp<-lm(y~Xv) smmryp<-summary(fitp) pF<-pF+as.numeric(smmryp$fstatistic[1]>=fstatistic)/nperm pT<-pT+as.numeric(abs(smmryp$coefficients[,"t value"])>=abs(tstatistic))/nperm rndm<-sample(1:nrow(Yp)) Yp<-Y[rndm,rndm] } names(coefficients)<-names(tstatistic)<-names(pT)<-c("(intercept)",paste("X",1:ncol(Xv),sep="")) names(fstatistic)<-NULL residuals<-foldtoLower(fit$residuals); attr(residuals,"Labels")<-rownames(Y) fitted.values<-foldtoLower(fit$fitted.values); attr(fitted.values,"Labels")<-rownames(Y) object<-list(r.squared=r.squared, coefficients=coefficients, tstatistic=tstatistic, fstatistic=fstatistic, probt=pT, probF=pF, residuals=residuals, fitted.values=fitted.values, nperm=nperm) class(object)<-"multi.mantel" object } ## function unfolds the sub-diagonal of a "dist" object or symmetric matrix into a vector ## written by Liam J. Revell 2012, 2022 unfoldLower<-function(X){ if(inherits(X,"dist")) X<-as.matrix(X) x<-vector() for(i in 2:ncol(X)-1) x<-c(x,X[(i+1):nrow(X),i]) names(x)<-NULL return(x) } # function folds vector into lower matrix "dist" object foldtoLower<-function(x){ n<-(1+sqrt(1+8*length(x)))/2 X<-matrix(0,n,n) j<-0 for(i in 2:n-1){ X[(i+1):n,i]<-x[i:(n-1)+j] j<-j+(n-i-1) } return(as.dist(X)) } ## S3 methods (added 2017) print.multi.mantel<-function(x,...){ if(hasArg(digits)) digits<-list(...)$digits else digits<-6 star<-function(p){ obj<-if(p>0.1) "" else if(p<=0.1&&p>0.05) "." else if(p<=0.05&&p>0.01) "*" else if(p<=0.01&&p>0.001) "**" else if(p<=0.001) "***" obj } cat("\nResults from a (multiple) Mantel regression using \"multi.mantel\":\n\n") cat("Coefficients:\n") object<-data.frame(x$coefficients, x$tstatistic,x$probt, sapply(x$probt,star)) rownames(object)<-names(x$coefficients) colnames(object)<-c("Estimate","t value","Pr(>|t|)","") print(object) cat("---\n") cat(paste("Signif. codes: 0 \u2018***\u2019 0.001 \u2018**\u2019 0.01", "\u2018*\u2019 0.05 \u2018.\u2019 0.1 \u2018 \u2019 1\n")) cat(paste("Pr(>|t|) based on",x$nperm, "(Mantel) permutations of rows & columns together in Y.\n\n")) cat(paste("Multiple R-squared:",round(x$r.squared,digits),"\n")) cat(paste("F-statistic: ",round(x$fstatistic,digits), ", p-value (based on ",x$nperm," permutations): ", round(x$probF,ceiling(log10(x$nperm))),"\n\n",sep="")) } residuals.multi.mantel<-function(object,...) object$residuals fitted.multi.mantel<-function(object,...) object$fitted.values phytools/R/allFurcTrees.R0000644000176200001440000000326114375517350015066 0ustar liggesusers# function returns all unrooted multi & bifurcating tree topologies # written by Liam Revell 2011, 2013 allFurcTrees<-function(n,tip.label=NULL,to.plot=TRUE){ # check to see if tip labels have been provided if(is.null(tip.label)) tip.label=as.character(1:n) # now pick three species at random to start new<-list(stree(n=3,tip.label=sample(tip.label,3))) class(new)<-"multiPhylo" added<-new[[1]]$tip.label; remaining<-setdiff(tip.label,added) # loop while(length(remaining)>0){ old<-new; new<-list() new.tip<-sample(remaining,1) for(i in 1:length(old)){ temp<-add.to.branches.and.nodes(old[[i]],new.tip) new<-unlist(list(new,temp),recursive=FALSE); class(new)<-"multiPhylo" } added<-c(added,new.tip) remaining<-setdiff(tip.label,added) } if(to.plot) new<-read.tree(text=write.tree(new)) return(new) # return all trees } # function adds a tip to all branches and nodes # written by Liam Revell 2011 add.to.branches.and.nodes<-function(tree,tip.name){ n.edge<-nrow(tree$edge) tree$edge.length<-rep(1,n.edge) # set all edge lengths to 1.0 # create new tip new.tip<-list(edge=matrix(c(2L,1L),1,2),tip.label=tip.name,edge.length=1,Nnode=1L); class(new.tip)<-"phylo" # first add the tip to all edges trees<-list(); class(trees)<-"multiPhylo" for(i in 1:n.edge){ trees[[i]]<-bind.tree(tree,new.tip,where=tree$edge[i,2],position=0.5) # add tip to edge trees[[i]]$edge.length<-NULL } # ok, now add the tip to all internal nodes intnodes<-unique(tree$edge[,1]) for(i in 1:tree$Nnode){ trees[[i+n.edge]]<-bind.tree(tree,new.tip,where=intnodes[i]) # add tip to node trees[[i+n.edge]]$edge.length<-NULL } return(trees) } phytools/R/phenogram.R0000644000176200001440000001747314375517350014465 0ustar liggesusers## function creates a phenogram (i.e., 'traitgram') ## written by Liam J. Revell 2011, 2012, 2013, 2014, 2015, 2016, 2020, 2021 phenogram<-function(tree,x,fsize=1.0,ftype="reg",colors=NULL,axes=list(),add=FALSE,...){ ## get optional arguments if(hasArg(xlim)) xlim<-list(...)$xlim else xlim<-NULL if(hasArg(ylim)) ylim<-list(...)$ylim else ylim<-NULL if(hasArg(log)) log<-list(...)$log else log<-"" if(hasArg(main)) main<-list(...)$main else main<-NULL if(hasArg(sub)) sub<-list(...)$sub else sub<-NULL if(hasArg(xlab)) xlab<-list(...)$xlab else xlab<-"time" if(hasArg(ylab)) ylab<-list(...)$ylab else ylab<-"phenotype" if(hasArg(asp)) asp<-list(...)$asp else asp<-NA if(hasArg(type)) type<-list(...)$type else type<-"l" if(hasArg(lty)) lty<-list(...)$lty else lty<-1 if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-2 if(hasArg(offset)) offset<-list(...)$offset else offset<-0.2 if(hasArg(offsetFudge)) offsetFudge<-list(...)$offsetFudge else offsetFudge<-1.37 if(hasArg(digits)) digits<-list(...)$digits else digits<-2 if(hasArg(nticks)) nticks<-list(...)$nticks else nticks<-5 if(hasArg(spread.labels)) spread.labels<-list(...)$spread.labels else spread.labels<-TRUE if(ftype=="off") spread.labels<-FALSE if(hasArg(spread.cost)) spread.cost<-list(...)$spread.cost else spread.cost<-c(1,0.4) if(hasArg(spread.range)) spread.range<-list(...)$spread.range else spread.range<-range(x) if(hasArg(link)) link<-list(...)$link else link<-if(spread.labels) 0.1*max(nodeHeights(tree)) else 0 if(hasArg(hold)) hold<-list(...)$hold else hold<-TRUE if(hasArg(quiet)) quiet<-list(...)$quiet else quiet<-FALSE if(hasArg(label.pos)) label.pos<-list(...)$label.pos else label.pos<-NULL if(hasArg(cex.axis)) cex.axis<-list(...)$cex.axis else cex.axis<-par()$cex.axis if(hasArg(cex.lab)) cex.lab<-list(...)$cex.lab else cex.lab<-par()$cex.lab if(hasArg(las)) las<-list(...)$las else las<-par()$las ## end optional arguments # check tree if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") # check font ftype<-which(c("off","reg","b","i","bi")==ftype)-1 if(!ftype&&!add) fsize=0 H<-nodeHeights(tree) if(length(x)<(length(tree$tip)+tree$Nnode)) x<-c(x,fastAnc(tree,x)) else x<-c(x[tree$tip.label],x[as.character(length(tree$tip)+1:tree$Nnode)]) x[1:length(tree$tip)]<-x[tree$tip.label] names(x)[1:length(tree$tip)]<-1:length(tree$tip) X<-matrix(x[as.character(tree$edge)],nrow(tree$edge),ncol(tree$edge)) # legacy 'axes' argument trumps ylim & xlim from optional (...) if(is.null(axes$trait)&&is.null(ylim)) ylim<-c(min(x),max(x)) else if(!is.null(axes$trait)) ylim<-axes$trait if(!is.null(axes$time)) xlim<-axes$time if(!add&&is.null(xlim)){ pp<-par("pin")[1] sw<-fsize*(max(strwidth(tree$tip.label,units="inches")))+ offsetFudge*offset*fsize*strwidth("W",units="inches") alp<-optimize(function(a,H,link,sw,pp) (a*1.04*(max(H)+link)+sw-pp)^2,H=H, link=link,sw=sw,pp=pp,interval=c(0,1e6))$minimum xlim<-c(min(H),max(H)+link+sw/alp) } if(!quiet&&Ntip(tree)>=40&&spread.labels){ cat("Optimizing the positions of the tip labels...\n") flush.console() } ## matrix for tip coordinates tip.coords<-matrix(NA,Ntip(tree),2,dimnames=list(tree$tip.label,c("x","y"))) if(hold) null<-dev.hold() if(is.null(tree$maps)){ if(is.null(colors)) colors<-"black" if(!add){ plot(H[1,],X[1,],type=type,lwd=lwd,lty=lty,col=colors,xlim=xlim,ylim=ylim, log=log,asp=asp,xlab="",ylab="",frame=FALSE,axes=FALSE) if(spread.labels) tt<-spreadlabels(tree,x,fsize=fsize,cost=spread.cost, range=spread.range,label.pos=label.pos,log=log) else tt<-x[1:length(tree$tip)] if(tree$edge[1,2]<=length(tree$tip)){ if(fsize&&!add){ text(gsub("_"," ",tree$tip.label[tree$edge[1,2]]),x=H[1,2]+link, y=tt[tree$edge[1,2]],cex=fsize,font=ftype,pos=4,offset=offset) tip.coords[tree$tip.label[tree$edge[1,2]],]<-c(H[1,2]+link, tt[tree$edge[1,2]]) if(link>0) lines(x=c(H[1,2],H[1,2]+link),y=c(X[1,2], tt[tree$edge[1,2]]),lty=3) } } s<-2 } else s<-1 for(i in s:nrow(H)){ lines(H[i,],X[i,],type=type,lwd=lwd,lty=lty,col=colors) if(tree$edge[i,2]<=length(tree$tip)){ if(fsize&&!add){ text(gsub("_"," ",tree$tip.label[tree$edge[i,2]]),x=H[i,2]+link, y=tt[tree$edge[i,2]],cex=fsize,font=ftype,pos=4,offset=offset) tip.coords[tree$tip.label[tree$edge[i,2]],]<-c(H[i,2]+link, tt[tree$edge[i,2]]) if(link>0) lines(x=c(H[i,2],H[i,2]+link),y=c(X[i,2],tt[tree$edge[i,2]]), lty=3) } } } } else { if(is.null(colors)){ nn<-sort(unique(c(getStates(tree,"tips"),getStates(tree,"nodes")))) colors<-setNames(palette()[1:length(nn)],nn) } for(i in 1:nrow(H)){ y<-H[i,1] m<-diff(X[i,])/diff(H[i,]) for(j in 1:length(tree$maps[[i]])){ a<-c(y,y+tree$maps[[i]][j]) b<-m*(a-H[i,1])+X[i,1] if(i==1&&j==1&&!add) { plot(a,b,col=colors[names(tree$maps[[i]])[j]],type=type,lwd=lwd, lty=lty,xlim=xlim,ylim=ylim,log=log,asp=asp,axes=FALSE,xlab="", ylab="") if(spread.labels) tt<-spreadlabels(tree,x[1:length(tree$tip)], fsize=fsize,cost=spread.cost,range=spread.range,log=log) else tt<-x[1:length(tree$tip)] } else lines(a,b,col=colors[names(tree$maps[[i]])[j]],lwd=lwd,lty=lty, type=type) y<-a[2] } if(tree$edge[i,2]<=length(tree$tip)){ if(fsize&&!add){ text(gsub("_"," ",tree$tip.label[tree$edge[i,2]]),x=H[i,2]+link, y=tt[tree$edge[i,2]],cex=fsize,font=ftype,pos=4,offset=offset) tip.coords[tree$tip.label[tree$edge[i,2]],]<-c(H[i,2]+link, tt[tree$edge[i,2]]) if(link>0) lines(x=c(H[i,2],H[i,2]+link),y=c(X[i,2], tt[tree$edge[i,2]]),lty=3) } } } } if(!add){ at<-round(0:(nticks-1)*max(H)/(nticks-1),digits) axis(1,at=at,cex.axis=cex.axis,cex.lab=cex.lab,las=las) axis(2,cex.axis=cex.axis,cex.lab=cex.lab,las=las) title(xlab=xlab,ylab=ylab,main=main,sub=sub) } if(hold) null<-dev.flush() xx<-setNames(c(H[1,1],H[,2]),c(tree$edge[1,1],tree$edge[,2])) xx<-xx[order(as.numeric(names(xx)))] yy<-setNames(c(X[1,1],X[,2]),c(tree$edge[1,1],tree$edge[,2])) yy<-yy[order(as.numeric(names(yy)))] PP<-list(type="phenogram",use.edge.length=TRUE,node.pos=1, show.tip.label=if(ftype!="off") TRUE else FALSE,show.node.label=FALSE, font=ftype,cex=fsize,adj=0,srt=NULL,no.margin=FALSE,label.offset=offset, x.lim=par()$usr[1:2],y.lim=par()$usr[3:4], direction=NULL,tip.color="black",Ntip=Ntip(tree),Nnode=tree$Nnode, edge=tree$edge,xx=xx,yy=yy) assign("last_plot.phylo",PP,envir=.PlotPhyloEnv) invisible(tip.coords) } ## function to spread labels ## written by Liam J. Revell 2013, 2014, 2016, 2021 spreadlabels<-function(tree,x,fsize=1,cost=c(1,1),range=NULL,label.pos=NULL,log=""){ if(!is.null(label.pos)) return(label.pos[tree$tip.label]) else { if(log=="y") x<-log(x) if(is.null(range)) range<-range(x) else { if(log=="y") range<-log(range) } yy<-x[1:Ntip(tree)] zz<-setNames((rank(yy,ties.method="random")-1)/(length(yy)-1)*diff(range(yy))+ range(yy)[1],names(yy)) mm<-max(fsize*strheight(tree$tip.label)) ff<-function(zz,yy,cost,mo=1,ms=1){ ZZ<-cbind(zz-mm/2,zz+mm/2) ZZ<-ZZ[order(zz),] oo<-0 for(i in 2:nrow(ZZ)) oo<-if(ZZ[i-1,2]>ZZ[i,1]) oo<-oo+ZZ[i-1,2]-ZZ[i,1] else oo<-oo pp<-sum((zz-yy)^2) oo<-if(oo<(1e-6*diff(par()$usr[3:4]))) 0 else oo pp<-if(pp<(1e-6*diff(par()$usr[3:4]))) 0 else pp oo/mo*cost[1]+pp/ms*cost[2] } mo<-ff(yy,zz,cost=c(1,0)) ms<-ff(yy,zz,cost=c(0,1)) if(mo==0&&ms==0) return(yy) else { rr<-optim(zz,ff,yy=yy,mo=mo,ms=ms,cost=cost,method="L-BFGS-B", lower=rep(range[1],length(yy)),upper=rep(range[2],length(yy))) if(log=="y") return(exp(rr$par)) else return(rr$par) } } } phytools/R/consensus.edges.R0000644000176200001440000000301114376151063015566 0ustar liggesusers## compute consensus edge lengths from a set of trees given (or not) a consensus topology ## written by Liam J. Revell 2016, 2023 consensus.edges<-function(trees,method=c("mean.edge","least.squares"),...){ if(hasArg(rooted)) rooted<-list(...)$rooted else rooted<-if(all(sapply(trees,is.rooted))) TRUE else FALSE if(hasArg(consensus.tree)) consensus.tree<-list(...)$consensus.tree else consensus.tree<-consensus(trees,p=0.5,rooted=rooted) tree<-consensus.tree ## get rid of this cumbersome name if(hasArg(if.absent)) if.absent<-list(...)$if.absent else if.absent<-"zero" N<-length(trees) if(method[1]=="mean.edge"){ M<-lapply(trees,function(x,y) rbind(matchLabels(y,x), matchNodes(y,x)),y=tree) nodes<-M[[1]][,1] edge.length<-vector(mode="numeric",length=length(nodes)) for(i in 1:length(nodes)){ ii<-which(tree$edge[,2]==nodes[i]) n.absent<-0 for(j in 1:N){ edge.length[ii]<-edge.length[ii] + if(!is.na(M[[j]][i,2])) trees[[j]]$edge.length[which(trees[[j]]$edge[,2]==M[[j]][i,2])]/N else 0 if(is.na(M[[j]][i,2])) n.absent<-n.absent+1 } if(if.absent=="ignore") edge.length[ii]<-edge.length[ii]*N/(N-n.absent) } tree$edge.length<-edge.length } else if(method[1]=="least.squares"){ D<-Reduce('+',lapply(trees,function(x,t) cophenetic(x)[t,t],t=tree$tip.label))/N if(rooted){ method<-if(all(sapply(trees,is.ultrametric))) "ultrametric" else "unrooted" } else method<-"unrooted" tree<-nnls.tree(D,tree=tree,method=method) } tree }phytools/R/phylosig.R0000644000176200001440000002456614453276155014346 0ustar liggesusers## function for computing phylogenetic signal by the lambda (Pagel 1999) ## or K (Blomberg et al. 2003) methods ## written by Liam J. Revell 2011/2012, 2019, 2020, 2021, 2023 phylosig<-function(tree,x,method="K",test=FALSE,nsim=1000, se=NULL,start=NULL,control=list(),niter=10){ # some minor error checking if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") x<-matchDatatoTree(tree,x,"x") tree<-matchTreetoData(tree,x,"x") if(!is.null(se)){ se<-matchDatatoTree(tree,se,"se") tree<-matchTreetoData(tree,se,"se") me=TRUE M<-diag(se^2) rownames(M)<-colnames(M)<-names(se) } else me=FALSE if(!is.null(start)&&!is.null(se)){ if(start[1]<=0||start[2]<0||start[2]>maxLambda(tree)){ message("some of the elements of 'start' are invalid, resetting to random") start<-NULL } } # done error handling if(method=="K"){ C<-vcv.phylo(tree) x<-x[rownames(C)] n<-nrow(C) if(!me){ invC<-solve(C) a<-sum(invC%*%x)/sum(invC) K<-(t(x-a)%*%(x-a)/(t(x-a)%*%invC%*%(x-a)))/((sum(diag(C))- n/sum(invC))/(n-1)) # calculate K if(!test){ object<-as.numeric(K) } else { P=0.0 simX<-x simK<-vector() for(i in 1:nsim){ a<-sum(invC%*%simX)/sum(invC) simK[i]<-(t(simX-a)%*%(simX-a)/(t(simX-a)%*%invC%*% (simX-a)))/((sum(diag(C))-n/sum(invC))/(n-1)) ## calculate P-value for randomization test if(simK[i]>=K) P<-P+1/nsim simX<-sample(simX) # randomize x } object<-list(K=as.numeric(K),P=P,sim.K=simK) } } else { likelihoodK<-function(theta,C,M,y){ Ce<-theta*C+M invCe<-solve(Ce) a<-as.numeric(sum(invCe%*%y)/sum(invCe)) logL<--t(y-a)%*%invCe%*%(y-a)/2-n*log(2*pi)/2- determinant(Ce,logarithm=TRUE)$modulus/2 logL[1,1] } M<-M[rownames(C),colnames(C)] invC<-solve(C) maxSig2<-as.numeric(t(x-as.numeric(sum(invC%*%x)/ sum(invC)))%*%invC%*%(x-as.numeric(sum(invC%*%x)/ sum(invC)))/n) res<-optimize(f=likelihoodK,interval=c(0,maxSig2),y=x, C=C,M=M,maximum=TRUE) # optimize sig2 sig2<-res$maximum*n/(n-1) Ce<-sig2*C+M invCe<-solve(Ce) a<-as.numeric(sum(invCe%*%x)/sum(invCe)) K<-(t(x-a)%*%(x-a)/(t(x-a)%*%invCe%*%(x-a)))/((sum(diag(Ce))- n/sum(invCe))/(n-1)) # calculate K if(!test){ object<-list(K=as.numeric(K),sig2=as.numeric(sig2), logL=res$objective, lik=function(sig2) likelihoodK(sig2,C=C,M=M,y=x)) } else { P=0.0 simX<-x simK<-vector() for(i in 1:nsim){ maxSig2<-as.numeric(t(simX-as.numeric(sum(invC%*% simX)/sum(invC)))%*%invC%*%(simX-as.numeric(sum(invC%*% simX)/sum(invC)))/n) simRes<-optimize(f=likelihoodK,interval=c(0,maxSig2),y=simX, C=C,M=M,maximum=TRUE) # optimize sig2 simSig2<-simRes$maximum*n/(n-1) Ce<-simSig2*C+M invCe<-solve(Ce) a<-as.numeric(sum(invCe%*%simX)/sum(invCe)) # calculate K simK[i]<-(t(simX-a)%*%(simX-a)/(t(simX-a)%*%invCe%*% (simX-a)))/((sum(diag(Ce))-n/sum(invCe))/(n-1)) # calculate P-value for randomization test if(simK[i]>=K) P<-P+1/nsim o<-sample(1:n) simX<-x[o] M<-diag(se[o]^2) # randomize x & errors } object<-list(K=as.numeric(K),P=P,sim.K=simK, sig2=as.numeric(sig2),logL=res$objective, lik=function(sig2) likelihoodK(sig2,C=C,M=M,y=x)) } } } else if(method=="lambda"){ # function to compute C with lambda lambda.transform<-function(C,lambda){ dC<-diag(diag(C)) C<-lambda*(C-dC)+dC C } # likelihood function likelihoodLambda<-function(theta,C,y){ Cl<-lambda.transform(C,theta) invCl<-solve(Cl) n<-nrow(Cl) y<-y[rownames(Cl)] a<-as.numeric(sum(invCl%*%y)/sum(invCl)) sig2<-as.numeric(t(y-a)%*%invCl%*%(y-a)/n) logL<--t(y-a)%*%(1/sig2*invCl)%*%(y-a)/2-n*log(2*pi)/2- determinant(sig2*Cl,logarithm=TRUE)$modulus/2 logL[1,1] } # likelihood function with error likelihoodLambda.me<-function(theta,C,y,M){ Cl<-theta[1]*lambda.transform(C,theta[2]) V<-Cl+M invV<-solve(V) n<-nrow(Cl) y<-y[rownames(Cl)] a<-as.numeric(sum(invV%*%y)/sum(invV)) logL<--t(y-a)%*%invV%*%(y-a)/2-n*log(2*pi)/2- determinant(V,logarithm=TRUE)$modulus/2 logL[1,1] } C<-vcv.phylo(tree) x<-x[rownames(C)] maxlam<-maxLambda(tree) if(!me){ INTERVAL<-cbind( seq(0,maxlam-maxlam/niter,length.out=niter), seq(maxlam/niter,maxlam,length.out=niter)) FITS<-apply(INTERVAL,1,optimize,f=likelihoodLambda, y=x,C=C,maximum=TRUE) LIKS<-sapply(FITS,function(x) x$objective) res<-FITS[[which(LIKS==max(LIKS))[1]]] if(!test){ object<-list(lambda=res$maximum,logL=res$objective, lik=function(lambda) likelihoodLambda(lambda, C=C,y=x)) } else { # compute likelihood of lambda=0 logL0<-likelihoodLambda(theta=0,C=C,y=x) P<-as.numeric(pchisq(2*(res$objective-logL0),df=1, lower.tail=FALSE)) # P-value object<-list(lambda=res$maximum,logL=res$objective, logL0=logL0,P=P,lik=function(lambda) likelihoodLambda(lambda,C=C,y=x)) } } else { FITS<-list() control$fnscale=-1 M<-M[rownames(C),colnames(C)] for(i in 1:niter){ if(is.null(start)) s<-c(0.5*runif(n=1)*mean(pic(x, multi2di(tree,random=FALSE))^2),runif(n=1)) else s<-start FITS[[i]]<-optim(s,likelihoodLambda.me,C=C,y=x,M=M, method="L-BFGS-B",lower=c(0,0),upper=c(Inf,maxlam), control=control) } LIKS<-sapply(FITS,function(x) x$value) res<-FITS[[which(LIKS==max(LIKS))[1]]] if(!test){ object<-list(lambda=res$par[2],sig2=res$par[1], logL=res$value,convergence=res$convergence, message=res$message,lik=function(lambda, sig2=res$par[1]) likelihoodLambda.me(c(sig2,lambda), C=C,M=M,y=x)) } else { for(i in 1:niter){ s<-0.5*runif(n=1)*mean(pic(x,multi2di(tree, random=FALSE))^2) FITS[[i]]<-optim(c(s,0),likelihoodLambda.me,C=C, y=x,M=M,method="L-BFGS-B",lower=c(0,0), upper=c(Inf,1e-10),control=control) } LIKS<-sapply(FITS,function(x) x$value) res0<-FITS[[which(LIKS==max(LIKS))[1]]] P<-as.numeric(pchisq(2*(res$value-res0$value),df=1, lower.tail=FALSE)) object<-list(lambda=res$par[2],sig2=res$par[1], logL=res$value,convergence=res$convergence, message=res$message,logL0=res0$value,P=P, lik=function(lambda,sig2=res$par[1]) likelihoodLambda.me(c(sig2, lambda),C=C,M=M,y=x)) } } } else stop(paste("do not recognize method = \"",method, "\"; methods are \"K\" and \"lambda\"",sep="")) attr(object,"class")<-"phylosig" attr(object,"method")<-method attr(object,"test")<-test attr(object,"se")<-!is.null(se) object } print.phylosig<-function(x,...){ if(hasArg(digits)) digits<-list(...)$digits else digits<-6 cat("\n") if(attr(x,"method")=="K"){ if(attr(x,"test")||attr(x,"se")){ cat(paste("Phylogenetic signal K :",signif(x$K, digits),"\n")) if(attr(x,"se")){ cat(paste("MLE(sig2) :",signif(x$sig2,digits), "\n")) cat(paste("logL(sig2) :",signif(x$logL,digits), "\n")) } if(attr(x,"test")) cat(paste("P-value (based on",length(x$sim.K), "randomizations) :",signif(x$P,digits),"\n")) } else cat(paste("Phylogenetic signal K :",signif(x[1], digits),"\n")) } else if(attr(x,"method")=="lambda"){ cat(paste("Phylogenetic signal lambda :",signif(x$lambda, digits),"\n")) cat(paste("logL(lambda) :",signif(x$logL,digits),"\n")) if(attr(x,"se")) cat(paste("MLE(sig2) :",signif(x$sig2, digits),"\n")) if(attr(x,"test")){ cat(paste("LR(lambda=0) :",signif(2*(x$logL-x$logL0), digits),"\n")) cat(paste("P-value (based on LR test) :",signif(x$P, digits),"\n")) } } cat("\n") } plot.phylosig<-function(x,...){ if(hasArg(what)) what<-list(...)$what else what<-if(attr(x,"method")=="lambda") "lambda" else if(attr(x,"method")=="K"&&attr(x,"test")) "K" else "sig2" if(hasArg(res)) res<-list(...)$res else res<-100 if(hasArg(las)) las<-list(...)$las else las<-par()$las if(hasArg(cex.lab)) cex.lab<-list(...)$cex.lab*par()$cex else cex.lab<-par()$cex.lab if(hasArg(cex.axis)) cex.axis<-list(...)$cex.axis*par()$cex else cex.axis<-par()$cex.axis if(hasArg(bty)) bty<-list(...)$bty else bty<-par()$bty if(hasArg(xlim)) xlim<-list(...)$xlim else xlim<-NULL if(attr(x,"method")=="lambda"){ lambda<-seq(0,max(c(1,x$lambda)),length.out=res) logL<-sapply(lambda,x$lik) plot(lambda,logL,xlab=expression(lambda),ylab="log(L)", type="l",bty=bty,las=las,cex.lab=cex.lab,cex.axis=cex.axis, xlim=xlim) lines(rep(x$lambda,2),c(par()$usr[3],x$logL),lty="dotted") text(x=x$lambda+0.01*diff(par()$usr[1:2]), par()$usr[3]+0.5*diff(par()$usr[3:4]), expression(paste("MLE(",lambda,")")),srt=90,adj=c(0.5,1)) if(attr(x,"test")){ lines(c(0,x$lambda),rep(x$logL0,2),lty="dotted") text(x=0.5*x$lambda, y=x$logL0+ if(x$logL0>(par()$usr[3]+0.5*(diff(par()$usr[3:4])))) -0.01*diff(par()$usr[3:4]) else 0.01*diff(par()$usr[3:4]), expression(paste("logL(",lambda,"=0)")), adj=if(x$logL0>(par()$usr[3]+0.5*(diff(par()$usr[3:4])))) c(0.5,1) else c(0.5,0)) } } else if(attr(x,"method")=="K"){ if(what=="K"){ if(attr(x,"test")==FALSE) cat("Sorry. This is not a valid plotting option for your object.\n\n") else { hist(x$sim.K,breaks=min(c(max(12,round(length(x$sim.K)/10)), 20)),bty=bty,col="lightgrey",border="lightgrey", main="",xlab="K",ylab="null distribution of K", las=las,cex.lab=cex.lab,cex.axis=cex.axis) arrows(x0=x$K,y0=par()$usr[4],y1=0,length=0.12, col=make.transparent("blue",0.5),lwd=2) text(x$K,0.95*par()$usr[4],"observed value of K", pos=if(x$K>mean(range(x$sim.K))) 2 else 4) } } else if(what=="sig2"){ if(attr(x,"se")==FALSE) cat("Sorry. This is not a valid plotting option for your object.\n\n") else { sig2<-seq(0.25*x$sig2,1.75*x$sig2,length.out=res) logL<-sapply(sig2,x$lik) plot(sig2,logL,xlab=expression(sigma^2),ylab="log(L)", type="l",bty=bty,las=las,cex.lab=cex.lab, cex.axis=cex.axis,xlim=xlim) lines(rep(x$sig2,2),c(par()$usr[3],x$logL),lty="dotted") text(x=x$sig2+0.01*diff(par()$usr[1:2]), par()$usr[3]+0.5*diff(par()$usr[3:4]), expression(paste("MLE(",sigma^2,")")),srt=90, adj=c(0.5,1)) } } } }phytools/R/phyl.pairedttest.R0000644000176200001440000001027714375517350016003 0ustar liggesusers## function for phylogenetic paired t-test (Lindenfors et al. 2010) ## written by Liam Revell 2011, 2013, 2015, 2021 phyl.pairedttest<-function(tree,x1,x2=NULL,se1=NULL,se2=NULL,lambda=1.0, h0=0.0,fixed=FALSE,...){ if(hasArg(tol)) tol<-list(...)$tol else tol<-1e-12 ## check tree if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") ## convert x1 to a matrix if necessary if(is.data.frame(x1)) x1<-as.matrix(x1) ## if x2 is NULL if(is.null(x2)){ ## check to see that x1 has two columns if(dim(x1)[2]!=2) stop("user must provide two data vectors or matrix with two variables") else { x2<-x1[,2] x1<-x1[,1] } } if(is.data.frame(x2)) x2<-as.matrix(x2) # to be safe if(is.matrix(x1)) x1<-x1[,1] if(is.matrix(x2)) x2<-x2[,1] if(is.null(se1)){ v1<-rep(0,length(tree$tip)) names(v1)<-tree$tip.label } else v1<-se1^2 if(is.null(se2)){ v2<-rep(0,length(tree$tip)) names(v2)<-tree$tip.label } else v2<-se2^2 ## compute C and sort vectors C<-vcv.phylo(tree) x1<-x1[rownames(C)] x2<-x2[rownames(C)] v1<-v1[rownames(C)] v2<-v2[rownames(C)] V.diff<-diag(v1+v2) dimnames(V.diff)<-list(names(v1),names(v1)) ## compute difference d<-x1-x2 ## lambda transformation lambda.transform<-function(C,lambda) lambda*(C-diag(diag(C)))+diag(diag(C)) ## likelihood function likelihood<-if(fixed) function(theta,d,C,V.diff,fixed.lambda){ theta[1]->sig2 theta[2]->dbar V<-sig2*lambda.transform(C,fixed.lambda)+V.diff logL<--t(d-dbar)%*%solve(V,d-dbar)/2-determinant(V)$modulus[1]/2- length(d)*log(2*pi)/2 -logL[1,1] } else function(theta,d,C,V.diff){ theta[1]->sig2 theta[2]->lambda theta[3]->dbar V<-sig2*lambda.transform(C,lambda)+V.diff logL<--t(d-dbar)%*%solve(V,d-dbar)/2-determinant(V)$modulus[1]/2- length(d)*log(2*pi)/2 -logL[1,1] } ## rescale for optimization: dscale<-1/sqrt(mean(pic(d,multi2di(tree,random=FALSE))^2)) d<-d*dscale V.diff<-V.diff*dscale^2 ## maximize the likelihood if(!fixed) fit<-optim(c(mean(pic(d,multi2di(tree,random=FALSE))^2),lambda,mean(d)),likelihood, d=d,C=C,V.diff=V.diff,method="L-BFGS-B",lower=c(tol,0,-Inf),upper=c(Inf,1,Inf), hessian=TRUE) else fit<-optim(c(mean(pic(d,multi2di(tree,random=FALSE))^2),mean(d)),likelihood, d=d,C=C,V.diff=V.diff,fixed.lambda=lambda,method="L-BFGS-B",lower=c(tol,-Inf), upper=c(Inf,Inf),hessian=TRUE) ## run t-test se.dbar<-if(fixed) sqrt(1/fit$hessian[2,2]) else sqrt(1/fit$hessian[3,3]) t<-if(fixed) (fit$par[2]-h0)/se.dbar else (fit$par[3]-h0)/se.dbar P<-2*pt(abs(t),df=Ntip(tree)-if(fixed) 2 else 3,lower.tail=FALSE) obj<-list(dbar=if(fixed) fit$par[2]/dscale else fit$par[3]/dscale, se=se.dbar/dscale,sig2=fit$par[1]/(dscale^2), lambda=if(fixed) lambda else fit$par[2], logL=if(fixed) -likelihood(c(fit$par[1]/(dscale^2),fit$par[2]/dscale), d/dscale,C,V.diff/(dscale^2),lambda) else -likelihood(c(fit$par[1]/(dscale^2), fit$par[2],fit$par[3]/dscale),d/dscale,C,V.diff/(dscale^2)),t.dbar=t, P.dbar=P,df=Ntip(tree)-if(fixed) 2 else 3,h0=h0) class(obj)<-"phyl.pairedttest" obj } print.phyl.pairedttest<-function(x,...){ if(hasArg(digits)) digits<-list(...)$digits else digits<-6 rnd<-function(x,digits){ x<-if(abs(x)>1e5) format(x,scientific=TRUE,digits=digits) else if(abs(x)<=1e5&&abs(x)>1e-5) format(x,digits=digits) else if(x<=1e-5&&x!=0) format(x,scientific=TRUE,digits=digits) else format(x,digits=digits) x } cat("\nPhylogenetic paired t-test:\n\n") cat(paste(" t = ",rnd(x$t.dbar,digits),", df = ",x$df, ", p-value = ",rnd(x$P.dbar,digits),sep="")) cat(paste( "\n\nalternative hypothesis:\n true difference in means is not equal to", rnd(x$h0,digits))) cat("\n\n95 percent confidence interval on the phylogenetic\ndifference in mean:\n") cat(paste(" [",paste(sapply(x$dbar+c(-1.96,1.96)*x$se,rnd,digits=digits), collapse=", "),"]\n",sep="")) cat("\nestimates:\n") cat(" phylogenetic mean difference =",rnd(x$dbar,digits),"\n") cat(" sig^2 of BM model =",rnd(x$sig2,digits),"\n") cat(" lambda (fixed or estimated) =",rnd(x$lambda,digits),"\n\n") cat("log-likelihood:\n") cat(paste(" ",rnd(x$logL,digits),"\n\n")) } phytools/R/map.overlap.R0000644000176200001440000000616014375517350014720 0ustar liggesusers## function computes the fractional (i.e., 0->1) overlap between the ## stochastic maps of two trees ## written by Liam Revell 2011, 2015, 2016 Map.Overlap<-function(tree1,tree2,tol=1e-06,standardize=TRUE,...){ if(hasArg(check.equal)) check.equal<-list(...)$check.equal else check.equal<-TRUE if(!inherits(tree1,"phylo")||!inherits(tree2,"phylo")) stop("Both input trees should be objects of class \"phylo\".") if(check.equal&&!all.equal.phylo(tree1,tree2,tolerance=tol)) stop("Mapped trees must have the same underlying structure.") if(!inherits(tree1,"simmap")||!inherits(tree2,"simmap")) stop("Both input trees should be objects of class \"simmap\".") s1<-mapped.states(tree1) s2<-mapped.states(tree2) R<-matrix(0,length(s1),length(s2),dimnames=list(s1,s2)) for(i in 1:nrow(tree1$edge)){ XX<-matrix(0,length(tree1$maps[[i]]),2, dimnames=list(names(tree1$maps[[i]]),c("start","end"))) XX[1,2]<-tree1$maps[[i]][1] if(length(tree1$maps[[i]])>1){ for(j in 2:length(tree1$maps[[i]])){ XX[j,1]<-XX[j-1,2] XX[j,2]<-XX[j,1]+tree1$maps[[i]][j] } } YY<-matrix(0,length(tree2$maps[[i]]),2, dimnames=list(names(tree2$maps[[i]]),c("start","end"))) YY[1,2]<-tree2$maps[[i]][1] if(length(tree2$maps[[i]])>1){ for(j in 2:length(tree2$maps[[i]])){ YY[j,1]<-YY[j-1,2] YY[j,2]<-YY[j,1]+tree2$maps[[i]][j] } } for(j in 1:nrow(XX)){ lower<-max(which(YY[,1]<=XX[j,1])) upper<-which(YY[,2]>=(XX[j,2]-tol))[1] for(k in lower:upper){ R[rownames(XX)[j],rownames(YY)[k]]<- R[rownames(XX)[j],rownames(YY)[k]]+ min(YY[k,2],XX[j,2])-max(YY[k,1],XX[j,1]) } } } if(standardize) R/sum(R) else R } map.overlap<-function(tree1,tree2,tol=1e-6,...){ if(hasArg(check.equal)) check.equal<-list(...)$check.equal else check.equal<-TRUE if(!inherits(tree1,"phylo")||!inherits(tree2,"phylo")) stop("Both input trees should be objects of class \"phylo\".") if(check.equal&&!all.equal.phylo(tree1,tree2,tolerance=tol)) stop("Mapped trees must have the same underlying structure.") if(!inherits(tree1,"simmap")||!inherits(tree2,"simmap")) stop("Both input trees should be objects of class \"simmap\".") overlap<-0 for(i in 1:nrow(tree1$edge)){ XX<-matrix(0,length(tree1$maps[[i]]),2, dimnames=list(names(tree1$maps[[i]]),c("start","end"))) XX[1,2]<-tree1$maps[[i]][1] if(length(tree1$maps[[i]])>1){ for(j in 2:length(tree1$maps[[i]])){ XX[j,1]<-XX[j-1,2] XX[j,2]<-XX[j,1]+tree1$maps[[i]][j] } } YY<-matrix(0,length(tree2$maps[[i]]),2, dimnames=list(names(tree2$maps[[i]]),c("start","end"))) YY[1,2]<-tree2$maps[[i]][1] if(length(tree2$maps[[i]])>1){ for(j in 2:length(tree2$maps[[i]])){ YY[j,1]<-YY[j-1,2] YY[j,2]<-YY[j,1]+tree2$maps[[i]][j] } } for(j in 1:nrow(XX)){ lower<-which(YY[,1]<=XX[j,1]) lower<-lower[length(lower)] upper<-which(YY[,2]>=(XX[j,2]-tol))[1] for(k in lower:upper){ if(rownames(XX)[j]==rownames(YY)[k]) overlap<-overlap+min(YY[k,2],XX[j,2])- max(YY[k,1],XX[j,1]) } } } overlap/sum(tree1$edge.length) } phytools/R/evolvcv.lite.R0000644000176200001440000005547414375517350015130 0ustar liggesusers## function is simplified version of evol.vcv ## written by Liam J. Revell 2011, 2012, 2013, 2017, 2019, 2020, 2021, 2022 anova.evolvcv.lite<-function(object,...){ models<-paste("model",sapply(strsplit(names(object),"model"), function(x) x[2])) logL<-sapply(object,function(x) x$logLik) df<-sapply(object,function(x) x$k) AIC<-sapply(object,function(x) x$AIC) value<-data.frame(logL=logL,df=df,AIC=AIC,weight=unclass(aic.w(AIC))) rownames(value)<-models colnames(value)<-c("log(L)","d.f.","AIC","weight") print(value) invisible(value) } evolvcv.lite<-function(tree,X,maxit=2000,tol=1e-10,...){ ## check 'phylo' object if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".") ## get some optional arguments if(hasArg(models)) models<-list(...)$models else models<-as.character(1:4) if(models[1]=="all models") models<-c("1","2","2b","2c","3","3b","3c","4") models<-as.character(models) if(hasArg(try.iter)) try.iter<-list(...)$try.iter else try.iter<-10 if(hasArg(lower)){ lower<-list(...)$lower if(length(lower)==1) lower<-c(rep(lower,2),-1) if(length(lower)>3) lower<-lower[1:3] } else lower<-NULL if(hasArg(upper)){ upper<-list(...)$upper if(length(upper)==1) upper<-c(rep(upper,2),1) if(length(upper)>3) upper<-upper[1:3] } else upper<-NULL if(!inherits(tree,"simmap")) models<-intersect("1",models) if(length(models)==0) stop("for models!=\"1\" tree must be an object of class \"simmap\".") # model 1: common variances & correlation lik1<-function(theta,C,D,y,E){ v<-exp(theta[1:2]) r<-theta[3] R<-matrix(c(v[1],r*sqrt(v[1]*v[2]),r*sqrt(v[1]*v[2]), v[2]),2,2) V<-kronecker(R,C)+E a<-solve(t(D)%*%solve(V)%*%D)%*%(t(D)%*%solve(V)%*%y) logL<--t(y-D%*%a)%*%solve(V)%*%(y-D%*%a)/2- n*m*log(2*pi)/2-determinant(V)$modulus[1]/2 return(-logL) } # model 2: different variances, same correlation lik2<-function(theta,C,D,y,E){ p<-(length(theta)-1)/2 v<-matrix(exp(theta[1:(2*p)]),p,2,byrow=T) r<-theta[length(theta)] R<-list() for(i in 1:p) R[[i]]<-matrix(c(v[i,1],r*sqrt(v[i,1]*v[i,2]), r*sqrt(v[i,1]*v[i,2]),v[i,2]),2,2) V<-matrix(0,length(y),length(y)) for(i in 1:p) V<-V+kronecker(R[[i]],C[[i]]) V<-V+E a<-solve(t(D)%*%solve(V)%*%D)%*%(t(D)%*%solve(V)%*%y) logL<--t(y-D%*%a)%*%solve(V)%*%(y-D%*%a)/2-n*m*log(2*pi)/2- determinant(V)$modulus[1]/2 return(-logL) } ## model 2b: different variances for only trait 1, same correlation lik2b<-function(theta,C,D,y,E){ p<-length(theta)-2 v<-matrix(exp(c(theta[1:p],rep(theta[p+1],p))),p,2,byrow=FALSE) r<-theta[length(theta)] R<-list() for(i in 1:p) R[[i]]<-matrix(c(v[i,1],r*sqrt(v[i,1]*v[i,2]), r*sqrt(v[i,1]*v[i,2]),v[i,2]),2,2) V<-matrix(0,length(y),length(y)) for(i in 1:p) V<-V+kronecker(R[[i]],C[[i]]) V<-V+E a<-solve(t(D)%*%solve(V)%*%D)%*%(t(D)%*%solve(V)%*%y) logL<--t(y-D%*%a)%*%solve(V)%*%(y-D%*%a)/2-n*m*log(2*pi)/2- determinant(V)$modulus[1]/2 return(-logL) } ## model 2c: different variances for only trait 2, same correlation lik2c<-function(theta,C,D,y,E){ p<-length(theta)-2 v<-matrix(exp(c(rep(theta[1],p),theta[1:p+1])),p,2,byrow=FALSE) r<-theta[length(theta)] R<-list() for(i in 1:p) R[[i]]<-matrix(c(v[i,1],r*sqrt(v[i,1]*v[i,2]), r*sqrt(v[i,1]*v[i,2]),v[i,2]),2,2) V<-matrix(0,length(y),length(y)) for(i in 1:p) V<-V+kronecker(R[[i]],C[[i]]) V<-V+E a<-solve(t(D)%*%solve(V)%*%D)%*%(t(D)%*%solve(V)%*%y) logL<--t(y-D%*%a)%*%solve(V)%*%(y-D%*%a)/2-n*m*log(2*pi)/2- determinant(V)$modulus[1]/2 return(-logL) } # model 3: same variances, different correlations lik3<-function(theta,C,D,y,E){ p<-length(theta)-2 v<-exp(theta[1:2]) r<-theta[3:length(theta)] R<-list() for(i in 1:p) R[[i]]<-matrix(c(v[1],r[i]*sqrt(v[1]*v[2]), r[i]*sqrt(v[1]*v[2]),v[2]),2,2) V<-matrix(0,length(y),length(y)) for(i in 1:p) V<-V+kronecker(R[[i]],C[[i]]) V<-V+E a<-solve(t(D)%*%solve(V)%*%D)%*%(t(D)%*%solve(V)%*%y) logL<--t(y-D%*%a)%*%solve(V)%*%(y-D%*%a)/2-n*m*log(2*pi)/2- determinant(V)$modulus[1]/2 return(-logL) } # model 3b: different variances for only trait 1, different correlation lik3b<-function(theta,C,D,y,E){ p<-(length(theta)-1)/2 v<-matrix(exp(c(theta[1:p],rep(theta[p+1],p))),p,2,byrow=FALSE) r<-theta[1:p+(p+1)] R<-list() for(i in 1:p) R[[i]]<-matrix(c(v[i,1],r[i]*sqrt(v[i,1]*v[i,2]), r[i]*sqrt(v[i,1]*v[i,2]),v[i,2]),2,2) V<-matrix(0,length(y),length(y)) for(i in 1:p) V<-V+kronecker(R[[i]],C[[i]]) V<-V+E a<-solve(t(D)%*%solve(V)%*%D)%*%(t(D)%*%solve(V)%*%y) logL<--t(y-D%*%a)%*%solve(V)%*%(y-D%*%a)/2-n*m*log(2*pi)/2- determinant(V)$modulus[1]/2 return(-logL) } # model 3c: different variances for only trait 2, different correlations lik3c<-function(theta,C,D,y,E){ p<-(length(theta)-1)/2 v<-matrix(exp(c(rep(theta[1],p),theta[1:p+1])),p,2,byrow=FALSE) r<-theta[1:p+(p+1)] R<-list() for(i in 1:p) R[[i]]<-matrix(c(v[i,1],r[i]*sqrt(v[i,1]*v[i,2]), r[i]*sqrt(v[i,1]*v[i,2]),v[i,2]),2,2) V<-matrix(0,length(y),length(y)) for(i in 1:p) V<-V+kronecker(R[[i]],C[[i]]) V<-V+E a<-solve(t(D)%*%solve(V)%*%D)%*%(t(D)%*%solve(V)%*%y) logL<--t(y-D%*%a)%*%solve(V)%*%(y-D%*%a)/2-n*m*log(2*pi)/2- determinant(V)$modulus[1]/2 return(-logL) } # model 4: everything different lik4<-function(theta,C,D,y,E){ p<-length(theta)/3 v<-matrix(exp(theta[1:(2*p)]),p,2,byrow=TRUE) r<-theta[(2*p+1):length(theta)] R<-list() for(i in 1:p) R[[i]]<-matrix(c(v[i,1],r[i]*sqrt(v[i,1]*v[i,2]), r[i]*sqrt(v[i,1]*v[i,2]),v[i,2]),2,2) V<-matrix(0,length(y),length(y)) for(i in 1:p) V<-V+kronecker(R[[i]],C[[i]]) V<-V+E a<-solve(t(D)%*%solve(V)%*%D)%*%(t(D)%*%solve(V)%*%y) logL<--t(y-D%*%a)%*%solve(V)%*%(y-D%*%a)/2-n*m*log(2*pi)/2- determinant(V)$modulus[1]/2 return(-logL) } # done internal functions # bookkeeping X<-as.matrix(X) X<-X[tree$tip.label,] n<-nrow(X) # number of species m<-ncol(X) # number of traits if(m!=2) stop("number of traits must equal 2") ## get error covariance matrices if(hasArg(err_vcv)){ err_vcv<-list(...)$err_vcv err_vcv<-err_vcv[tree$tip.label] } else { err_vcv<-replicate(n,matrix(0,m,m),simplify=FALSE) names(err_vcv)<-tree$tip.label } E<-matrix(0,n*m,n*m) for(i in 1:n){ ii<-0:(m-1)*n+i E[ii,ii]<-err_vcv[[i]] } ## end get error covariances ## more bookkeeping p<-if(inherits(tree,"simmap")) ncol(tree$mapped.edge) else 1 # number of states D<-matrix(0,n*m,m) for(i in 1:(n*m)) for(j in 1:m) if((j-1)*nbest){ if(res1$convergence==0) res1$convergence<-99 } else best<-res1$value iter<-iter+1 } if(inherits(res1,"try-error")){ m1<-list(description="common rates, common correlation", R=matrix(NA,p,p),logLik=NA,k=5,AIC=NA) } else { if(any(res1$par<(LOWER+2*tol))||any(res1$par>(UPPER-2*tol))) res1$convergence<-77 res1$par[1:2]<-exp(res1$par[1:2]) m1<-list(description="common rates, common correlation", R=matrix(c(res1$par[1],res1$par[3]*sqrt(res1$par[1]*res1$par[2]), res1$par[3]*sqrt(res1$par[1]*res1$par[2]),res1$par[2]),2,2), logLik=-res1$value, convergence=res1$convergence, k=length(res1$par)+2, AIC=2*(length(res1$par)+2)+2*res1$value) } object$model1=m1 msg(paste("Best log(L) from model 1: ",round(m1$logLik,4),".\n",sep="")) } else m1<-NULL makeError<-function(description,names,p,k){ list(description=description, R=setNames(replicate(p,matrix(NA,2,2),simplify=FALSE),names), logLik=NA, convergence=99, k=k, AIC=NA) } if("2"%in%models){ msg("Fitting model 2: different rates, common correlation...\n") res2<-list() res2$convergence<-99 class(res2)<-"try-error" iter<-0 best<-if(is.null(m1)) -loglik_model1+tol else -m1$logLik LOWER<-c(rep(lower[1:2],p),lower[3]) UPPER<-c(rep(upper[1:2],p),upper[3]) while((inherits(res2,"try-error")||res2$convergence!=0)&&iterbest){ if(res2$convergence==0) res2$convergence<-99 } else best<-res2$value iter<-iter+1 } if(inherits(res2,"try-error")){ m2<-makeError("different rates, common correlation", colnames(tree$mapped.edge), ncol(tree$mapped.edge), 2*ncol(tree$mapped.edge)+1) } else { if(any(res2$par<(LOWER+2*tol))||any(res2$par>(UPPER-2*tol))) res2$convergence<-77 R<-list() res2$par[1:(2*p)]<-exp(res2$par[1:(2*p)]) for(i in 1:p) R[[i]]<-matrix(c(res2$par[2*(i-1)+1], rep(res2$par[2*p+1]*sqrt(res2$par[2*(i-1)+1]*res2$par[2*(i-1)+2]),2), res2$par[2*(i-1)+2]),2,2) names(R)<-colnames(tree$mapped.edge) m2<-list(description="different rates, common correlation", R=R, logLik=-res2$value, convergence=res2$convergence, k=length(res2$par)+2, AIC=2*(length(res2$par)+2)+2*res2$value) } object$model2<-m2 msg(paste("Best log(L) from model 2: ",round(m2$logLik,4),".\n",sep="")) } if("2b"%in%models){ msg("Fitting model 2b: different rates (trait 1), common correlation...\n") res2b<-list() res2b$convergence<-99 class(res2b)<-"try-error" iter<-0 best<-if(is.null(m1)) -loglik_model1+tol else (-m1$logLik) LOWER<-c(rep(lower[1],p),lower[2],lower[3]) UPPER<-c(rep(upper[1],p),upper[2],upper[3]) while((inherits(res2b,"try-error")||res2b$convergence!=0)&&iterbest){ if(res2b$convergence==0) res2b$convergence<-99 } else best<-res2b$value iter<-iter+1 } if(inherits(res2b,"try-error")){ m2b<-makeError("different rates (trait 1), common correlation", colnames(tree$mapped.edge), ncol(tree$mapped.edge), 2*ncol(tree$mapped.edge)+2) } else { if(any(res2b$par<(LOWER+2*tol))||any(res2b$par>(UPPER-2*tol))) res2b$convergence<-77 R<-list() res2b$par[1:(p+1)]<-exp(res2b$par[1:(p+1)]) for(i in 1:p) R[[i]]<-matrix(c(res2b$par[i], rep(res2b$par[p+2]*sqrt(res2b$par[i]*res2b$par[p+1]),2), res2b$par[p+1]),2,2) names(R)<-colnames(tree$mapped.edge) m2b<-list(description="different rates (trait 1), common correlation", R=R, logLik=-res2b$value, convergence=res2b$convergence, k=length(res2b$par)+2, AIC=2*(length(res2b$par)+2)+2*res2b$value) } object$model2b<-m2b msg(paste("Best log(L) from model 2b: ",round(m2b$logLik,4),".\n",sep="")) } if("2c"%in%models){ msg("Fitting model 2c: different rates (trait 2), common correlation...\n") res2c<-list() res2c$convergence<-99 class(res2c)<-"try-error" iter<-0 best<-if(is.null(m1)) -loglik_model1+tol else (-m1$logLik) LOWER<-c(lower[1],rep(lower[2],p),lower[3]) UPPER<-c(upper[1],rep(upper[2],p),upper[3]) while((inherits(res2c,"try-error")||res2c$convergence!=0)&&iterbest){ if(res2c$convergence==0) res2c$convergence<-99 } else best<-res2c$value iter<-iter+1 } if(inherits(res2c,"try-error")){ m2c<-makeError("different rates (trait 2), common correlation", colnames(tree$mapped.edge), ncol(tree$mapped.edge), 2*ncol(tree$mapped.edge)+2) } else { if(any(res2c$par<(LOWER+2*tol))||any(res2c$par>(UPPER-2*tol))) res2c$convergence<-77 R<-list() res2c$par[1:(p+1)]<-exp(res2c$par[1:(p+1)]) for(i in 1:p) R[[i]]<-matrix(c(res2c$par[1], rep(res2c$par[p+2]*sqrt(res2c$par[1]*res2c$par[i+1]),2), res2c$par[i+1]),2,2) names(R)<-colnames(tree$mapped.edge) m2c<-list(description="different rates (trait 2), common correlation", R=R, logLik=-res2c$value, convergence=res2c$convergence, k=length(res2c$par)+2, AIC=2*(length(res2c$par)+2)+2*res2c$value) } object$model2c<-m2c msg(paste("Best log(L) from model 2c: ",round(m2c$logLik,4),".\n",sep="")) } if("3"%in%models){ msg("Fitting model 3: common rates, different correlation...\n") res3<-list() res3$convergence<-99 class(res3)<-"try-error" iter<-0 best<-if(is.null(m1)) -loglik_model1+tol else (-m1$logLik) LOWER<-c(lower[1],lower[2],rep(lower[3],p)) UPPER<-c(upper[1],upper[2],rep(upper[3],p)) while((inherits(res3,"try-error")||res3$convergence!=0)&&iterbest){ if(res3$convergence==0) res3$convergence<-99 } else best<-res3$value iter<-iter+1 } if(inherits(res3,"try-error")){ m3<-makeError("common rates, different correlation", colnames(tree$mapped.edge), ncol(tree$mapped.edge), ncol(tree$mapped.edge)+2) } else { if(any(res3$par<(LOWER+2*tol))||any(res3$par>(UPPER-2*tol))) res3$convergence<-77 R<-list() res3$par[1:2]<-exp(res3$par[1:2]) for(i in 1:p) R[[i]]<-matrix(c(res3$par[1], rep(res3$par[2+i]*sqrt(res3$par[1]*res3$par[2]),2),res3$par[2]),2,2) names(R)<-colnames(tree$mapped.edge) m3<-list(description="common rates, different correlation", R=R, logLik=-res3$value, convergence=res3$convergence, k=length(res3$par)+2, AIC=2*(length(res3$par)+2)+2*res3$value) } object$model3<-m3 msg(paste("Best log(L) from model 3: ",round(m3$logLik,4),".\n",sep="")) } if("3b"%in%models){ msg("Fitting model 3b: different rates (trait 1), different correlation...\n") res3b<-list() res3b$convergence<-99 class(res3b)<-"try-error" iter<-0 best<-if(is.null(m1)) -loglik_model1+tol else (-m1$logLik) LOWER<-c(rep(lower[1],p),lower[2],rep(lower[3],p)) UPPER<-c(rep(upper[1],p),upper[2],rep(upper[3],p)) while((inherits(res3b,"try-error")||res3b$convergence!=0)&&iterbest){ if(res3b$convergence==0) res3b$convergence<-99 } else best<-res3b$value iter<-iter+1 } if(inherits(res3b,"try-error")){ m3b<-makeError("different rates (trait 1), different correlation", colnames(tree$mapped.edge), ncol(tree$mapped.edge), 2*ncol(tree$mapped.edge)+1) } else { if(any(res3b$par<(LOWER+2*tol))||any(res3b$par>(UPPER-2*tol))) res3b$convergence<-77 R<-list() res3b$par[1:(p+1)]<-exp(res3b$par[1:(p+1)]) for(i in 1:p) R[[i]]<-matrix(c(res3b$par[i], rep(res3b$par[p+1+i]*sqrt(res3b$par[i]*res3b$par[p+1]),2), res3b$par[p+1]),2,2) names(R)<-colnames(tree$mapped.edge) m3b<-list(description="different rates (trait 1), different correlation", R=R, logLik=-res3b$value, convergence=res3b$convergence, k=length(res3b$par)+2, AIC=2*(length(res3b$par)+2)+2*res3b$value) } object$model3b<-m3b msg(paste("Best log(L) from model 3b: ",round(m3b$logLik,4),".\n",sep="")) } if("3c"%in%models){ msg("Fitting model 3c: different rates (trait 2), different correlation...\n") res3c<-list() res3c$convergence<-99 class(res3c)<-"try-error" iter<-0 best<-if(is.null(m1)) -loglik_model1+tol else (-m1$logLik) LOWER<-c(lower[1],rep(lower[2],p),rep(lower[3],p)) UPPER<-c(upper[1],rep(upper[2],p),rep(upper[3],p)) while((inherits(res3c,"try-error")||res3c$convergence!=0)&&iterbest){ if(res3c$convergence==0) res3c$convergence<-99 } else best<-res3c$value iter<-iter+1 } if(inherits(res3c,"try-error")){ m3c<-makeError("different rates (trait 2), different correlation", colnames(tree$mapped.edge), ncol(tree$mapped.edge), 2*ncol(tree$mapped.edge)+1) } else { if(any(res3c$par<(LOWER+2*tol))||any(res3c$par>(UPPER-2*tol))) res3c$convergence<-77 R<-list() res3c$par[1:(p+1)]<-exp(res3c$par[1:(p+1)]) for(i in 1:p) R[[i]]<-matrix(c(res3c$par[1], rep(res3c$par[p+1+i]*sqrt(res3c$par[1]*res3c$par[1+i]),2), res3c$par[1+i]),2,2) names(R)<-colnames(tree$mapped.edge) m3c<-list(description="different rates (trait 2), different correlation", R=R, logLik=-res3c$value, convergence=res3c$convergence, k=length(res3c$par)+2, AIC=2*(length(res3c$par)+2)+2*res3c$value) } object$model3c<-m3c msg(paste("Best log(L) from model 3c: ",round(m3c$logLik,4),".\n",sep="")) } if("4"%in%models){ msg("Fitting model 4: no common structure...\n") res4<-list() res4$convergence<-99 class(res4)<-"try-error" iter<-0 best<-if(is.null(m1)) -loglik_model1+tol else (-m1$logLik) LOWER<-c(rep(lower[1:2],p),rep(lower[3],p)) UPPER<-c(rep(upper[1:2],p),rep(upper[3],p)) while((inherits(res4,"try-error")||res4$convergence!=0)&&iterbest){ if(res4$convergence==0) res4$convergence<-99 } else best<-res4$value iter<-iter+1 } if(inherits(res4,"try-error")){ m4<-makeError("no common structure", colnames(tree$mapped.edge), ncol(tree$mapped.edge), 3*ncol(tree$mapped.edge)+2) } else { if(any(res4$par<(LOWER+2*tol))||any(res4$par>(UPPER-2*tol))) res4$convergence<-77 R<-list() res4$par[1:(2*p)]<-exp(res4$par[1:(2*p)]) for(i in 1:p) R[[i]]<-matrix(c(res4$par[2*(i-1)+1], rep(res4$par[2*p+i]*sqrt(res4$par[2*(i-1)+1]*res4$par[2*(i-1)+2]), 2),res4$par[2*(i-1)+2]),2,2) names(R)<-colnames(tree$mapped.edge) m4<-list(description="no common structure", R=R, logLik=-res4$value, convergence=res4$convergence, k=length(res4$par)+2, AIC=2*(length(res4$par)+2)+2*res4$value) } object$model4<-m4 msg(paste("Best log(L) from model 4: ",round(m4$logLik,4),".\n",sep="")) } object } ## S3 print method for object of class "evolvcv.lite" ## written by Liam J. Revell 2017, 2019, 2021 print.evolvcv.lite<-function(x,...){ if(hasArg(digits)) digits<-list(...)$digits else digits<-4 if(!is.null(x$model1)){ nn<-paste("R[",t(sapply(1:ncol(x$model1$R),paste, 1:ncol(x$model1$R),sep=","))[upper.tri(x$model1$R, diag=TRUE)],"]",sep="") ## MODEL 1 m1<-lapply(x$model1,function(a,b) if(is.numeric(a)) round(a,b) else a,b=digits) cat(paste("Model 1:",x$model1$description,"\n")) cat(paste("\t",paste(nn,collapse="\t"),"\tk\tlog(L)\tAIC","\n",sep="")) cat(paste("fitted",paste(m1$R[upper.tri(m1$R,diag=TRUE)],collapse="\t"),m1$k, m1$logLik,m1$AIC,"\n",sep="\t")) if(m1$convergence==0) cat("\n(R thinks it has found the ML solution for model 1.)\n\n") else if(m1$convergence==77) cat("\n(Model 1 optimization may be at bounds.)\n\n") else cat("\n(Model 1 optimization may not have converged.)\n\n") ii<-which(names(x)=="model1") x<-x[-ii] } if(length(x)>0){ nn<-paste("R[",t(sapply(1:ncol(x[[1]]$R[[1]]),paste, 1:ncol(x[[1]]$R[[1]]),sep=","))[upper.tri(x[[1]]$R[[1]], diag=TRUE)],"]",sep="") for(i in 1:length(x)){ m<-lapply(x[[i]],function(a,b) if(is.numeric(a)) round(a,b) else a,b=digits) m$R<-lapply(m$R,function(a,b) if(is.numeric(a)) round(a,b) else a,b=digits) model<-strsplit(names(x)[i],"model")[[1]][2] cat(paste("Model ",model,": ",m$description,"\n",sep="")) cat(paste("\t",paste(nn,collapse="\t"),"\tk\tlog(L)\tAIC","\n",sep="")) for(j in 1:length(m$R)){ if(j==1) cat(paste(names(m$R)[j],paste(m$R[[j]][upper.tri(m$R[[j]],diag=TRUE)], collapse="\t"),m$k,m$logLik,m$AIC,"\n",sep="\t")) else cat(paste(names(m$R)[j],paste(m$R[[j]][upper.tri(m$R[[j]],diag=TRUE)], collapse="\t"),"\n",sep="\t")) } if(m$convergence==0) cat(paste("\n(R thinks it has found the ML solution for model ",model,".)\n\n",sep="")) else if(m$convergence==77) cat(paste("\n(Model ",model," optimization may be at bounds.)\n\n",sep="")) else cat(paste("\n(Model ",model," optimization may not have converged.)\n\n",sep="")) } } } phytools/R/phylANOVA.R0000644000176200001440000000634014375517350014235 0ustar liggesusers# function conducts phylogenetic ANOVA & posthoc tests # some code from phy.anova() in "geiger" # written by Liam Revell 2011, 2015, 2017, 2021 phylANOVA<-function(tree,x,y,nsim=1000,posthoc=TRUE,p.adj="holm"){ if(is.null(names(x))){ cat("Warning: no labels for x. Assuming order of tree$tip.label.\n\n") names(x)<-tree$tip.label } x<-x[tree$tip.label] if(is.null(names(y))){ cat("Warning: no labels for y. Assuming order of tree$tip.label.\n\n") names(y)<-tree$tip.label } y<-y[tree$tip.label] if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") sig2<-mean(pic(y,multi2di(tree,random=FALSE))^2) # compute BM rate for y x<-as.factor(x) # change x to factor m<-length(levels(x)) aov<-anova(lm(y~x)) F.obs<-aov[1,4] # F on empirical data if(posthoc) T.obs<-tTests(x,y) # empirical ts sims<-fastBM(tree,sig2=sig2,nsim=(nsim-1)) # simulate F.null<-vector() if(posthoc) T.null<-array(NA,dim=c(m,m,nsim),dimnames=list(levels(x),levels(x),NULL)) F.null[1]<-F.obs if(posthoc) T.null[,,1]<-T.obs for(i in 2:nsim){ F.null[i]<-anova(lm(sims[,i-1]~x))[1,4] if(posthoc) T.null[,,i]<-tTests(x,sims[,i-1]) } P.F<-sum(F.null>=F.obs)/nsim # p-value for F-test if(posthoc){ P.T<-matrix(NA,m,m,dimnames=list(levels(x),levels(x))) # uncorrected p-values from simulation for(i in 1:m) for(j in i:m){ P.T[i,j]<-sum(abs(T.null[i,j,])>=abs(T.obs[i,j]))/nsim P.T[j,i]<-P.T[i,j] } # control for multiple tests (if p.adj!="none") P.T[lower.tri(P.T)]<-p.adjust(P.T[lower.tri(P.T)],method=p.adj) for(i in 1:m) for(j in i:m) P.T[i,j]<-P.T[j,i] obj<-list(F=F.obs,Pf=P.F,T=T.obs,method=p.adj,Pt=P.T, "Sum Sq"=aov$"Sum Sq","Mean Sq"=aov$"Mean Sq") } else obj<-list(F=F.obs,Pf=P.F,"Sum Sq"=aov$"Sum Sq", "Mean Sq"=aov$"Mean Sq") class(obj)<-"phylANOVA" obj } # computes pairwise t-statistics with a pooled SD # some code from pairwise.t.test() in "stats" # written by Liam Revell 2011 tTests<-function(x,y){ if(!is.factor(x)) x<-as.factor(x) ybar<-tapply(y,x,mean,na.rm=TRUE) s<-tapply(y,x,sd,na.rm=TRUE) n<-tapply(!is.na(y),x,sum) m<-length(levels(x)) degf<-n-1 total.degf<-sum(degf) pooled.sd<-sqrt(sum(s^2*degf)/total.degf) compare.levels<-function(i,j){ dif<-ybar[i]-ybar[j] se.dif<-pooled.sd*sqrt(1/n[i]+1/n[j]) t.val<-dif/se.dif return(t.val) } T<-matrix(NA,m,m,dimnames=list(levels(x),levels(x))) for(i in 1:m) for(j in 1:m) T[i,j]<-compare.levels(levels(x)[i],levels(x)[j]) return(T) } ## S3 print method print.phylANOVA<-function(x,digits=6,...){ cat("ANOVA table: Phylogenetic ANOVA\n\n") cat("Response: y\n") object<-data.frame(round(x$"Sum Sq",digits), round(x$"Mean Sq",digits), c(round(x$F,digits),""), c(round(x$Pf,digits),"")) colnames(object)<-c("Sum Sq","Mean Sq","F value", "Pr(>F)") rownames(object)<-c("x","Residual") print(object) cat("\nP-value based on simulation.\n") cat("---------\n") cat("\n") if(!is.null(x$T)){ cat(paste("Pairwise posthoc test using method = \"", x$method,"\"\n\n",sep="")) cat("Pairwise t-values:\n") print(round(x$T,digits)) cat("\nPairwise corrected P-values:\n") print(round(x$Pt,digits)) cat("---------\n") cat("\n") } } phytools/R/tree.grow.R0000644000176200001440000000271414375517350014411 0ustar liggesusers## function to 'grow' a birth-death tree from left-to-right or from upwards ## written by Liam J. Revell 2019 tree.grow<-function(...,res=200,direction="rightwards",ladderize=TRUE){ tree<-if(ladderize) ladderize(pbtree(...),FALSE) else pbtree(...) h<-max(nodeHeights(tree)) for(i in 1:res){ dev.hold() if(direction=="upwards"){ if(ilength(tree$tip.label),2]) points(c(XX[1,1],XX[tree$edge[,2]>length(tree$tip.label),2]),c(YY[1,1], YY[tree$edge[,2]>length(tree$tip.label),2]),pch=pch,cex=node.size[1], col=if(pch%in%c(1:20)) con$col.node[as.character(zz)] else "black", bg=if(pch%in%c(21:25)) con$col.node[as.character(zz)] else NULL) zz<-tree$edge[tree$edge[,2]<=length(tree$tip.label),2] points(XX[tree$edge[,2]<=length(tree$tip.label),2],YY[tree$edge[,2]<=length(tree$tip.label),2], pch=pch,cex=node.size[2],col=if(pch%in%c(1:20)) con$col.node[as.character(zz)] else "black", bg=if(pch%in%c(21:25)) con$col.node[as.character(zz)] else NULL) zz<-sapply(1:length(tree$tip.label),function(x,y) which(x==y),y=tree$edge[,2]) if(label!="off"){ asp<-(par()$usr[2]-par()$usr[1])/(par()$usr[4]-par()$usr[3]) for(i in 1:length(tree$tip.label)){ ii<-which(tree$edge[,2]==i) aa<-atan(asp*(YY[ii,2]-YY[ii,1])/(XX[ii,2]-XX[ii,1]))/(2*pi)*360 adj<-if(XX[ii,2]=Nnode) print(round(x$ace,digits)) else printDotDot(x$ace,digits,printlen) cat("\nParameter estimates:\n") cat(paste("\tmu",paste(rep(" ",digits),collapse=""),"\tsig^2", paste(rep(" ",max(digits-3,1)),collapse=""),"\tlog(L)\n",sep="")) cat(paste("\t",round(x$mu,digits),"\t",round(x$sig2,digits),"\t", round(x$logL,digits),"\n"),sep="") if(x$convergence==0) cat("\nR thinks it has converged.\n\n") else cat("\nR thinks function may not have converged.\n\n") } ## logLik method for "anc.trend" logLik.anc.trend<-function(object,...){ lik<-object$logL attr(lik,"df")<-length(object$ace)+2 lik } phytools/R/fitmultiMk.R0000644000176200001440000001156214531510304014605 0ustar liggesusers## new function to fit multi-regime Mk model ## written by Liam J. Revell 2017, 2020, 2023 ## pruning adapted from ape::ace by E. Paradis et al. 2013 fitmultiMk<-function(tree,x,model="ER",...){ if(!inherits(tree,"simmap")){ stop("tree should be an object of class \"simmap\". Use fitMk.\n") } else { regimes<-mapped.states(tree) nregimes<-length(regimes) } if(hasArg(q.init)) q.init<-list(...)$q.init else q.init<-length(unique(x))/sum(tree$edge.length) if(hasArg(rand_start)) rand_start<-list(...)$rand_start else rand_start<-FALSE if(hasArg(opt.method)) opt.method<-list(...)$opt.method else opt.method<-"nlminb" if(hasArg(min.q)) min.q<-list(...)$min.q else min.q<-1e-12 if(is.matrix(x)){ x<-x[tree$tip.label,] m<-ncol(x) states<-colnames(x) } else { x<-to.matrix(x,sort(unique(x))) x<-x[tree$tip.label,] m<-ncol(x) states<-colnames(x) } if(hasArg(pi)) pi<-list(...)$pi else pi<-"equal" if(pi[1]=="equal") pi<-setNames(rep(1/m,m),states) else pi<-pi/sum(pi) if(is.character(model)){ rate<-matrix(NA,m,m) if(model=="ER"){ k<-rate[]<-1 diag(rate)<-NA } else if(model=="ARD"){ k<-m*(m-1) rate[col(rate)!=row(rate)]<-1:k } else if(model=="SYM"){ k<-m*(m-1)/2 ii<-col(rate)=1.0||auto.tune<=0.0){ cat("value for auto.tune outside allowable range. Resetting....\n") auto.tune<-0.234 } if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") # likelihood function for the liabilities lik<-function(a,V,invV,detV,D,Y){ y<-as.vector(Y) logL<--t(y-D%*%a)%*%invV%*%(y-D%*%a)/2-n*m*log(2*pi)/2-detV/2 return(logL[1,1]) } # function for the log-prior (presently returns 0, i.e. a flat prior) logPrior<-function(sig2,a,r,Yp){ pp<-dexp(sig2[1],rate=1/con$pr.mean[1],log=T)+ dexp(sig2[2],rate=1/con$pr.mean[2],log=T)+ dnorm(a[1],mean=con$pr.mean[3],sd=sqrt(con$pr.var[3]),log=T)+ dnorm(a[2],mean=con$pr.mean[4],sd=sqrt(con$pr.var[4]),log=T)+ dunif(r,min=con$pr.mean[5]-0.5*sqrt(12*con$pr.var[5]), max=con$pr.mean[5]+0.5*sqrt(12*con$pr.var[5]),log=T) return(pp) } # function to crop the first 4 characters from a vector of strings crop<-function(x){ for(i in 1:length(x)) x[i]<-paste(strsplit(x[i],"")[[1]][1:4],collapse="") return(x) } ## bookkeeping C<-vcv.phylo(tree) n<-nrow(X) m<-ncol(X) if(is.null(types)){ types<-rep("cont",m) if(is.data.frame(X)){ ii<-which(sapply(X,is.factor)) if(length(ii)>0) types[ii]<-"disc" } else if(is.matrix(X)){ ii<-which(apply(X,2,function(x) all(x%in%c(0,1)))) if(length(ii)>0) types[ii]<-"disc" } } X<-X[tree$tip.label,] levels<-as.list(rep(NA,m)) if(is.data.frame(X)){ ii<-sapply(X,is.character) if(any(ii)) X[,ii]<-sapply(X[,ii],as.factor) ii<-sapply(X,is.factor) if(any(ii)){ d<-which(ii) for(i in 1:length(d)) levels[[d[i]]]<-levels(X[,d[i]]) X[,ii]<-sapply(X[,ii],as.numeric)-1 } X<-as.matrix(X) } else { d<-which(crop(types)=="disc") if(length(d)>0) for(i in 1:length(d)) levels[[d[i]]]<-as.character(0:1) } if(m!=2) stop("number of traits must equal 2") npar<-n*m+5 # or npar<-n*m+1 # design matrix D<-matrix(0,n*m,m) for(i in 1:(n*m)) for(j in 1:m) if((j-1)*n0]<-1 Vp<-V invVp<-invV detVp<-detV # for storing the posterior sample Z<-matrix(NA,ngen/con$sample+1,8,dimnames=list(NULL,c("gen","sig1","sig2", "a1","a2","r","logL","accept_rate"))) Z[1,]<-c(0,sig2,a,r,lik1<-lik(a,V,invV,detV,D,Y),0) L<-matrix(NA,ngen/con$sample+1,m*Ntip(tree)+1,dimnames=list(NULL,c("gen", as.vector(apply(matrix(colnames(Y)),1,paste,".",tree$tip.label,sep=""))))) L[1,]<-c(0,as.vector(Y)) logL.trace<-r.trace<-rep(0,ngen) running.accept<-0 ## maybe help with memory Yp<-Y # start MCMC cat("Starting MCMC....\n") flush.console() for(i in 1:ngen){ if(i%%10000==1){ ## reset acceptance rates accept.rate<-accept<-hit<-rep(0,npar) } d<-i%%npar if(ngen>=con$print.interval) if(i%%con$print.interval==0) if(!con$quiet){ cat(paste("generation: ",i,"; mean acceptance rate: ",round(mean(accept.rate),2),"\n",sep="")) flush.console() } Yp[]<-Y sig2p<-sig2 ap<-a rp<-r if(d<=length(Y[,disc])&&d>0){ # update liabilities Yp[,disc][d]<-Y[,disc][d]+rnorm(n=1,sd=sqrt(con$propliab[d])) } else { key<-c("sig1","sig2","a1","a2","r")[c(cont,3,4,5)] key<-key[if(d>0) d-length(Y[,disc]) else length(key)] if(key=="sig1"){ sig2p[1]<-sig2[1]+rnorm(n=1,sd=sqrt(con$propvar[1])) if(sig2p[1]<0) sig2p[1]=-sig2p[1] R<-matrix(c(sig2p[1],rp*sqrt(sig2p[1]*sig2p[2]), rp*sqrt(sig2p[1]*sig2p[2]),sig2p[2]),2,2) Vp<-kronecker(R,C) invVp<-solve(Vp) detVp<-determinant(Vp)$modulus[1] } else if(key=="sig2"){ sig2p[2]<-sig2[2]+rnorm(n=1,sd=sqrt(con$propvar[2])) if(sig2p[2]<0) sig2p[2]=-sig2p[2] R<-matrix(c(sig2p[1],rp*sqrt(sig2p[1]*sig2p[2]), rp*sqrt(sig2p[1]*sig2p[2]),sig2p[2]),2,2) Vp<-kronecker(R,C) invVp<-solve(Vp) detVp<-determinant(Vp)$modulus[1] } else if(key=="a1") { ap[1]<-a[1]+rnorm(n=1,sd=sqrt(con$propvar[3])) } else if(key=="a2") { ap[2]<-a[2]+rnorm(n=1,sd=sqrt(con$propvar[4])) } else if(key=="r"){ rp<-r+rnorm(n=1,sd=sqrt(con$propvar[5])) while(rp>1||rp< -1){ if(rp>1) rp<-2-rp if(rp< -1) rp<--2-rp } R<-matrix(c(sig2p[1],rp*sqrt(sig2p[1]*sig2p[2]), rp*sqrt(sig2p[1]*sig2p[2]),sig2p[2]),2,2) Vp<-kronecker(R,C) invVp<-solve(Vp) detVp<-determinant(Vp)$modulus[1] } } Pp[Yp<0]<-0 Pp[Yp>0]<-1 lik2<-lik(ap,Vp,invVp,detVp,D,Yp)+log(all(Pp[,disc]==X[,disc])) p.odds<-min(c(1,exp(lik2+logPrior(sig2p,ap,rp,Yp)-lik1- logPrior(sig2,a,r,Yp)))) hit[if(d>0) d else npar]<-hit[if(d>0) d else npar]+1 if(p.odds>runif(n=1)){ accept[if(d>0) d else npar]<-accept[if(d>0) d else npar]+1 running.accept<-running.accept+1/con$sample Y[]<-Yp sig2<-sig2p a<-ap r<-rp V<-Vp invV<-invVp detV<-detVp logL<-lik2 lik1<-lik2 } else logL<-lik1 accept.rate[if(d>0) d else npar]<-accept[if(d>0) d else npar]/hit[if(d>0) d else npar] if(is.numeric(auto.tune)){ if(accept.rate[if(d>0) d else npar]>auto.tune){ if(d>=1&&d<=(length(Y[,disc]))) con$propliab[d]<-1.1*con$propliab[d] else { ii<-which(c("sig1","sig2","a1","a2","r")==key) con$propvar[ii]<-1.1*con$propvar[ii] if(key=="r"&&con$propvar[ii]>1) con$propvar[ii]<-1 } } else if(accept.rate[if(d>0) d else npar]=1&&d<=(length(Y[,disc]))) con$propliab[d]<-con$propliab[d]/1.1 else { ii<-which(c("sig1","sig2","a1","a2","r")==key) con$propvar[ii]<-con$propvar[ii]/1.1 } } } logL.trace[i]<-logL r.trace[i]<-r if(plot&&(i%%100==1)){ dev.hold() par(mfrow=c(3,1)) par(mar=c(5.1,4.1,2.1,1.1)) plot(1:i,logL.trace[1:i],type="l",bty="l",col=make.transparent("grey",0.5), xlab="generation",ylab="log(L)",xlim=c(0,ngen)) mtext("a) log-likelihood trace",side=3,line=0,cex=1,at=0,outer=FALSE, adj=0) par(mar=c(5.1,4.1,2.1,1.1)) h<-barplot(accept.rate,ylim=c(0,1),col=make.transparent("blue",0.25), border=NA) if(is.numeric(auto.tune)) lines(range(h),rep(auto.tune,2),lty="dotted") mtext("b) acceptance rates (resets every 10,000 generations)",side=3,line=0, cex=1,at=0,outer=FALSE,adj=0) plot(1:i,r.trace[1:i],type="l",bty="l",col=make.transparent("blue",0.5), xlab="generation",ylab="r",xlim=c(0,ngen)) mtext("c) trace of the correlation coefficient, r",side=3,line=0,cex=1,at=0, outer=FALSE,adj=0) lines(c(par()$usr[1],ngen),rep(mean(r.trace[1:i]),2),lty="dotted") dev.flush() } if(i%%con$sample==0){ Z[i/con$sample+1,]<-c(i,sig2,a,r,logL,running.accept) L[i/con$sample+1,]<-c(i,Y[,1],Y[,2]) running.accept<-0 ## reset running acceptance rate } } cat("Done MCMC.\n") obj<-list(par=as.data.frame(Z),liab=as.data.frame(L), burnin=burnin,levels=levels,types=types) attr(obj,"auto.tune")<-auto.tune class(obj)<-"threshBayes" obj } ## S3 methods for the object class print.threshBayes<-function(x,...){ cat("\nObject of class \"threshBayes\" consisting of a matrix (L) of\n") cat("sampled liabilities for the tips of the tree & a second matrix\n") cat("(par) with the sample model parameters & correlation.\n") cat(paste("\nMean correlation (r) from the posterior sample is: ", round(mean(x$par[,"r"]),5),".\n",sep="")) if(any(x$types=="disc")){ cat("\nOrdination of discrete traits:\n\n") for(i in 1:length(x$types)){ if(x$types[i]=="disc") cat(paste("\tTrait ",i,": ",x$levels[[i]][1]," <-> ", x$levels[[i]][2],"\n",sep="")) } } cat("\n") } plot.density.threshBayes<-function(x,...){ d<-x$density r<-x$mean.r if(hasArg(xlim)) xlim<-list(...)$xlim else xlim<-c(-1,1) if(hasArg(ylim)) ylim<-list(...)$ylim else ylim<-c(0,1.2*max(d$y)) if(hasArg(bty)) bty<-list(...)$bty else bty<-"n" if(hasArg(cex.lab)) cex.lab<-list(...)$cex.lab else cex.lab<-1 if(hasArg(cex.axis)) cex.axis<-list(...)$cex.axis else cex.axis<-1 plot(d,xlim=xlim,ylim=ylim,col="blue",xlab="Posterior sample of r", ylab="Density",main="",bty=bty,cex.lab=cex.lab,cex.axis=cex.axis) polygon(x=c(min(d$x),d$x,max(d$x)),y=c(0,d$y,0), col=make.transparent("blue",0.2)) lines(rep(r,2),c(0,max(d$y)),col="blue",lty="dashed", lwd=2) text(r,max(d$y),"mean post-burnin\nvalue of r",cex=0.7, pos=if(r>0) 2 else 4,font=3) } density.threshBayes<-function(x,...){ if(hasArg(burnin)) burnin<-list(...)$burnin else burnin<-x$burnin if(hasArg(bw)) bw<-list(...)$bw else bw<-0.05 ii<-which(((x$par$gen-burnin)^2)==min((x$par$gen-burnin)^2))[1]+1 d<-density(x$par$r[ii:nrow(x$par)],bw=bw) r<-mean(x$par$r[ii:nrow(x$par)]) d$data.name<-deparse(substitute(x)) d$call<-paste("density.threshBayes(x =",d$data.name," bw = bw)") d$bw<-bw object<-list(density=d,mean.r=r) class(object)<-"density.threshBayes" object } print.density.threshBayes<-function(x,...){ print(x$density) cat("\n") cat("To plot enter plot(\'object_name\') at the command line interface.\n\n") } plot.threshBayes<-function(x,...){ if(hasArg(bw)) bw<-list(...)$bw else bw<-floor(length(x$par$gen)/100) if(hasArg(bty)) bty<-list(...)$bty else bty<-"n" if(hasArg(las)) las<-list(...)$las else las<-1 if(hasArg(cex.main)) cex.main<-list(...)$cex.main else cex.main<-1 par(mfrow=c(3,1)) par(mar=c(5.1,4.1,2.1,1.1)) plot(x$par$gen,x$par$logL,type="l",bty=bty,col=make.transparent("grey",0.5), xlab="generation",ylab="log(L)",las=las) mtext("a) log-likelihood trace",side=3,line=0.5,cex=cex.main,at=0, outer=FALSE,adj=0) par(mar=c(5.1,4.1,2.1,1.1)) accept<-vector() for(i in 1:length(x$par$gen)) accept[i]<-mean(x$par$accept_rate[max(c(1,i-bw)):i]) plot(x$par$gen,accept,type="l",bty=bty,col=make.transparent("red",0.5), xlab="generation",ylab="mean acceptance rate",las=las) if(is.numeric(attr(x,"auto.tune"))) lines(c(par()$usr[1],max(x$par$gen)), rep(attr(x,"auto.tune"),2),lty="dotted") mtext(paste("b) mean acceptance rate (sliding window: bw=",bw,")",sep=""), side=3,line=0.5,cex=cex.main,at=0,outer=FALSE,adj=0) plot(x$par$gen,x$par$r,type="l",bty=bty,col=make.transparent("blue",0.5), xlab="generation",ylab="r",las=las) mtext("c) trace of the correlation coefficient, r",side=3,line=0.5, cex=cex.main,at=0,outer=FALSE,adj=0) } phytools/R/ancThresh.R0000644000176200001440000003642214375517350014417 0ustar liggesusers## function performs ancestral character estimation under the threshold model ## written by Liam J. Revell 2012, 2013, 2014, 2017, 2019, 2020 ancThresh<-function(tree,x,ngen=100000,sequence=NULL,method="mcmc", model=c("BM","OU","lambda"),control=list(),...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(hasArg(auto.tune)) auto.tune<-list(...)$auto.tune else auto.tune<-TRUE if(is.logical(auto.tune)) if(auto.tune==TRUE) auto.tune<-0.234 else if(is.numeric(auto.tune)) if(auto.tune>=1.0||auto.tune<=0.0){ cat("value for auto.tune outside allowable range. Resetting....\n") auto.tune<-0.234 } # check method if(method!="mcmc") stop(paste(c("do not recognize method =",method, ",quitting"))) # get model for the evolution of liability model<-model[1] # check x if(is.factor(x)) x<-setNames(as.character(x),names(x)) if(is.data.frame(x)) x<-as.matrix(x) if(is.matrix(x)){ X<-x[tree$tip.label,] if(is.null(sequence)){ message("**** NOTE: no sequence provided, column order in x") seq<-colnames(X) } else seq<-sequence } else if(is.vector(x)){ x<-x[tree$tip.label] if(is.null(sequence)){ message("**** NOTE: no sequence provided, using alphabetical or numerical order") seq<-sort(levels(as.factor(x))) } else seq<-sequence X<-to.matrix(x,seq) } # row scale X X<-X/apply(X,1,sum) X<-X[,seq] # order columns by seq # ok, now set starting thresholds th<-c(1:length(seq))-1 names(th)<-seq x<-to.vector(X) ## set plausible starting liabilities MU<-mean(th) SD<-2*sd(th) # now change the upper limit of th to Inf th[length(th)]<-Inf l<-setNames(vector(mode="numeric",length=length(x)),names(x)) for(i in 1:length(l)){ l[i]<-rnorm(n=1,mean=MU,sd=SD) while(threshState(l[i],thresholds=th)!=x[i]) l[i]<-rnorm(n=1,mean=MU, sd=SD) } ## set plausible starting liability ## l<-sapply(x,function(x) runif(n=1,min=th[x]-1,max=th[x])) if(model=="OU") alpha<-0.1*max(nodeHeights(tree)) if(model=="lambda") lambda<-1.0 # for MCMC n<-length(tree$tip) m<-length(th) npar<-if(model=="BM") tree$Nnode+n+m-2 else tree$Nnode+n+m-1 # populate control list PrA<-matrix(1/m,tree$Nnode,m,dimnames=list(1:tree$Nnode+n,seq)) if(!is.null(control$pr.anc)){ if(!is.matrix(control$pr.anc)){ message("**** NOTE: prior on ancestral states must be in matrix form; using default prior") control$pr.anc<-NULL } else { control$pr.anc<-control$pr.anc[,seq,drop=FALSE] PrA[rownames(control$pr.anc),]<-control$pr.anc control$pr.anc<-PrA } } con=list(sample=1000, propliab=0.5*max(nodeHeights(tree)), propthresh=0.05*max(nodeHeights(tree)), propalpha=0.1*max(nodeHeights(tree)), proplambda=0.01, pr.anc=PrA, pr.th=0.01, burnin=round(0.2*ngen), plot=FALSE, print=TRUE, piecol=setNames(palette()[1:length(seq)],seq), tipcol="input", quiet=FALSE) con[(namc<-names(control))]<-control con<-con[!sapply(con,is.null)] # now set ancestral liabilities, by first picking ancestral states from their prior temp<-apply(con$pr.anc,1,rstate) # assign random liabilities consistent with the starting thresholds ## a<-sapply(temp,function(x) runif(n=1,min=th[x]-1,max=th[x])) a<-setNames(vector(mode="numeric",length=length(temp)),names(temp)) for(i in 1:length(a)){ a[i]<-rnorm(n=1,mean=MU,sd=SD) while(threshState(a[i],thresholds=th)!=temp[i]) a[i]<-rnorm(n=1,mean=MU, sd=SD) } # compute some matrices & values V<-if(model=="BM") vcvPhylo(tree) else if(model=="OU") vcvPhylo(tree,model="OU",alpha=alpha) else if(model=="lambda") vcvPhylo(tree,model="lambda",lambda=lambda) # check to make sure that V will be non-singular if(any(tree$edge.length<=(10*.Machine$double.eps))) stop("some branch lengths are 0 or nearly zero") invV<-solve(V) detV<-determinant(V,logarithm=TRUE)$modulus[1] lik1<-likLiab(l,a,V,invV,detV)+log(probMatch(X,l,th,seq)) # store A<-matrix(NA,ngen/con$sample+1,tree$Nnode,dimnames=list(NULL, n+1:tree$Nnode)) B<-if(model=="BM") matrix(NA,ngen/con$sample+1,m+2, dimnames=list(NULL,c("gen",names(th),"logLik"))) else if(model=="OU") matrix(NA,ngen/con$sample+1,m+3, dimnames=list(NULL,c("gen",names(th),"alpha","logLik"))) else if(model=="lambda") matrix(NA,ngen/con$sample+1,m+3, dimnames=list(NULL,c("gen",names(th),"lambda","logLik"))) C<-matrix(NA,ngen/con$sample+1,tree$Nnode+n,dimnames=list(NULL, c(tree$tip.label,1:tree$Nnode+n))) A[1,]<-threshState(a,thresholds=th) B[1,]<-if(model=="BM") c(0,th,lik1) else if(model=="OU") c(0,th,alpha,lik1) else if(model=="lambda") c(0,th,lambda,lik1) C[1,]<-c(l[tree$tip.label],a[as.character(1:tree$Nnode+n)]) # run MCMC message("MCMC starting....") logL<-lik1<-likLiab(l,a,V,invV,detV)+log(probMatch(X,l,th,seq)) for(i in 1:ngen){ lik1<-logL d<-i%%npar if(ngen>=1000) if(i%%1000==0) if(con$print) message(paste("gen",i)) ap<-a; lp<-l; thp<-th if(model=="OU") alphap<-alpha if(model=="lambda") lambdap<-lambda Vp<-V; invVp<-invV; detVp<-detV if(d<=tree$Nnode&&d!=0){ # update node liabilities ind<-d%%tree$Nnode; if(ind==0) ind<-tree$Nnode ap[ind]<-a[ind]+rnorm(n=1,sd=sqrt(con$propliab)) } else { if((d>tree$Nnode&&d<=(tree$Nnode+n))||(npar==(tree$Nnode+n)&&d==0)){ # update tip liabilities if(d==0) ind<-n else { ind<-(d-tree$Nnode)%%n; if(ind==0) ind<-n } lp[ind]<-l[ind]+rnorm(n=1,sd=sqrt(con$propliab)) } else if(d>(tree$Nnode+n)&&d<=(tree$Nnode+n+m-2)||(npar==(tree$Nnode+n+m-2)&&d==0)) { # update thresholds if(d) ind<-(d-tree$Nnode-n)%%m+1 else ind<-m-1 thp[ind]<-bounce(th[ind],rnorm(n=1,sd=sqrt(con$propthresh)),c(th[ind-1],th[ind+1])) } else { if(model=="OU"){ alphap<-bounce(alpha,rnorm(n=1,sd=sqrt(con$propalpha)),c(0,Inf)) Vp<-vcvPhylo(tree,model="OU",alpha=alphap) } else if(model=="lambda"){ lambdap<-bounce(lambda,rnorm(n=1,sd=sqrt(con$proplambda)),c(0,1)) Vp<-vcvPhylo(tree,model="lambda",lambda=lambdap) } invVp<-solve(Vp) detVp<-determinant(Vp,logarithm=TRUE)$modulus[1] } } lik2<-likLiab(lp,ap,Vp,invVp,detVp)+log(probMatch(X,lp,thp,seq)) p.odds<-min(c(1,exp(lik2+logPrior(threshState(ap,thresholds=thp),thp,con)- lik1-logPrior(threshState(a,thresholds=th),th,con)))) if(p.odds>runif(n=1)){ a<-ap; l<-lp; th<-thp V<-Vp; detV<-detVp; invV<-invVp if(model=="OU") alpha<-alphap if(model=="lambda") lambda<-lambdap logL<-lik2 } else logL<-lik1 if(i%%con$sample==0){ A[i/con$sample+1,]<-threshState(a,thresholds=th) B[i/con$sample+1,]<-if(model=="BM") c(i,th[colnames(B)[1+1:m]],logL) else if(model=="OU") c(i,th[colnames(B)[1+1:m]],alpha,logL) else if(model=="lambda") c(i,th[colnames(B)[1+1:m]],lambda,logL) C[i/con$sample+1,]<-c(l[tree$tip.label],a[as.character(1:tree$Nnode+n)]) } } mcmc<-as.data.frame(A) param<-as.data.frame(B) liab<-as.data.frame(C) ace<-matrix(0,tree$Nnode,m,dimnames=list(colnames(A),seq)) burnin<-which(param[,"gen"]==con$burnin) for(i in 1:tree$Nnode){ mcmc[[i]]<-as.factor(mcmc[[i]]) temp<-summary(mcmc[burnin:nrow(mcmc),i])/(nrow(mcmc)-burnin+1) ace[i,names(temp)]<-temp } obj<-list(ace=ace,mcmc=mcmc,par=param,liab=liab, tree=tree,x=x,model=model, seq=seq, ngen=ngen,sample=con$sample, burnin=con$burnin) class(obj)<-"ancThresh" if(con$plot) plot(obj) obj } ## some S3 methods (added in 2017) print.ancThresh<-function(x,...){ cat("\nObject containing the results from an MCMC analysis\n") cat("of the threshold model using ancThresh.\n\n") cat("List with the following components:\n") cat(paste("ace:\tmatrix with posterior probabilities assuming",x$burnin, "\n\tburn-in generations.\n")) cat("mcmc:\tposterior sample of liabilities at tips & internal\n") cat(paste("\tnodes (a matrix with",nrow(x$mcmc),"rows &",ncol(x$mcmc), "columns).\n")) cat("par:\tposterior sample of the relative positions of the\n") cat(paste("\tthresholds, the log-likelihoods, and any other\n", "\tmodel variables (a matrix with",nrow(x$par),"rows).\n\n")) cat("The MCMC was run under the following conditions:\n") cat(paste("\tseq =",paste(x$seq,collapse=" <-> "), "\n\tmodel =",x$model,"\n\tnumber of generations =",x$ngen, "\n\tsample interval=",x$sample, "\n\tburn-in =",x$burnin,"\n\n")) } plot.ancThresh<-function(x,...){ if(hasArg(burnin)) burnin<-list(...)$burnin else burnin<-x$burnin args<-list(...) if(is.null(args$lwd)) args$lwd<-1 if(is.null(args$type)) args$type<-"phylogram" if(is.null(args$ylim)) if(args$type=="phylogram") args$ylim<-c(-0.1*Ntip(x$tree),Ntip(x$tree)) if(is.null(args$offset)) args$offset<-0.5 if(is.null(args$ftype)) args$ftype="i" args$tree<-x$tree do.call(plotTree,args) ii<-which(x$par[,1]==burnin)+1 LIAB<-as.matrix(x$liab)[ii:nrow(x$liab),] THRESH<-as.matrix(x$par)[ii:nrow(x$par),1:length(x$seq)+1] STATES<-matrix(NA,nrow(LIAB),ncol(LIAB),dimnames=dimnames(LIAB)) for(i in 1:nrow(LIAB)) STATES[i,]<-threshState(LIAB[i,],THRESH[i,]) PP<-t(apply(STATES,2,function(x,levs) summary(factor(x,levels=levs))/length(x),levs=x$seq)) if(hasArg(piecol)) piecol<-list(...)$piecol else piecol<-setNames(colorRampPalette(c("blue", "yellow"))(length(x$seq)),x$seq) if(hasArg(node.cex)) node.cex<-list(...)$node.cex else node.cex<-0.6 nodelabels(pie=PP[1:x$tree$Nnode+Ntip(x$tree),], piecol=piecol,cex=node.cex) if(hasArg(tip.cex)) tip.cex<-list(...)$tip.cex else tip.cex<-0.4 tiplabels(pie=PP[x$tree$tip.label,],piecol=piecol, cex=tip.cex) legend(x="bottomleft",legend=x$seq,pch=21,pt.bg=piecol, pt.cex=2.2,bty="n") invisible(PP) } # plots ancestral states from the threshold model # written by Liam J. Revell 2012, 2014 plotThresh<-function(tree,x,mcmc,burnin=NULL,piecol,tipcol="input",legend=TRUE,...){ if(is.logical(legend)||is.vector(legend)){ if(is.logical(legend)&&legend==TRUE) leg<-setNames(names(piecol),names(piecol)) else if(is.vector(legend)){ leg<-legend[names(piecol)] legend<-TRUE } } # plot tree par(lend=2) plotTree(tree,ftype="i",lwd=1,ylim=if(legend) c(-0.1*length(tree$tip.label), length(tree$tip.label)) else NULL,...) if(legend){ zz<-par()$cex; par(cex=0.6) for(i in 1:length(piecol)) add.simmap.legend(leg=leg[i],colors=piecol[i],prompt=FALSE, x=0.02*max(nodeHeights(tree)),y=-0.1*length(tree$tip.label),vertical=FALSE, shape="square",fsize=1) par(cex=zz) } # pull matrices from mcmc ace<-mcmc$ace liab<-mcmc$liab param<-mcmc$par # get burnin if(is.null(burnin)) burnin<-round(0.2*max(param[,"gen"])) burnin<-which(param[,"gen"]==burnin) # check x if(is.data.frame(x)) x<-as.matrix(x) if(is.matrix(x)) X<-x[tree$tip.label,] else if(is.vector(x)){ x<-x[tree$tip.label] X<-to.matrix(x,names(piecol)) } # row scale X X/apply(X,1,sum)->X # plot node labels nodelabels(pie=ace,piecol=piecol[colnames(ace)],cex=0.6) # plot tip labels if(tipcol=="input") tiplabels(pie=X,piecol=piecol[colnames(X)],cex=0.6) else if(tipcol=="estimated") { XX<-matrix(NA,nrow(liab),length(tree$tip),dimnames=list(rownames(liab), colnames(liab)[1:length(tree$tip)])) for(i in 1:nrow(liab)) XX[i,]<-threshState(liab[i,1:length(tree$tip)], thresholds=param[i,1:ncol(X)+1]) X<-t(apply(XX,2,function(x) summary(factor(x,levels=colnames(X))))) tiplabels(pie=X/rowSums(X),piecol=piecol[colnames(X)],cex=0.6) } } # computes DIC for threshold model # written by Liam J. Revell 2012, 2014 threshDIC<-function(tree,x,mcmc,burnin=NULL,sequence=NULL,method="pD"){ ## identify model if(any(colnames(mcmc$par)=="alpha")) model<-"OU" else if(any(colnames(mcmc$par)=="lambda")) model<-"lambda" else model<-"BM" # check x if(is.data.frame(x)) x<-as.matrix(x) if(is.matrix(x)){ X<-x[tree$tip.label,] if(is.null(sequence)){ message("**** NOTE: no sequence provided, column order in x") seq<-colnames(X) } else seq<-sequence } else if(is.vector(x)){ x<-x[tree$tip.label] if(is.null(sequence)){ message("**** NOTE: no sequence provided, using alphabetical or numerical order") seq<-sort(levels(as.factor(x))) } else seq<-sequence X<-to.matrix(x,seq) } # row scale X X<-X/apply(X,1,sum) X<-X[,seq] # order columns by seq # convert burnin to starting row if(is.null(burnin)) burnin<-0.2*max(mcmc$par[,"gen"]) start<-which(mcmc$par[,"gen"]==burnin)+1 # compute k<-if(model=="BM") 1 else 2 thBar<-colMeans(mcmc$par[start:nrow(mcmc$par),2:(ncol(mcmc$par)-k)]) liabBar<-colMeans(mcmc$liab[start:nrow(mcmc$liab),]) if(model=="BM") V<-vcvPhylo(tree) else if(model=="OU") V<-vcvPhylo(tree,model="OU", alpha=mean(mcmc$par[start:nrow(mcmc$par),"alpha"])) else if(model=="lambda") V<-vcvPhylo(tree,model="lambda", lambda=mean(mcmc$par[start:nrow(mcmc$par),"lambda"])) Dtheta<--2*(likLiab(liabBar[tree$tip.label], liabBar[as.character(1:tree$Nnode+length(tree$tip))],V,solve(V), determinant(V,logarithm=TRUE)$modulus[1])+log(probMatch(X[tree$tip.label,], liabBar[tree$tip.label],thBar,seq))) D<--2*mcmc$par[start:nrow(mcmc$par),"logLik"] Dbar<-mean(D) if(method=="pD"){ pD<-Dbar-Dtheta DIC<-pD+Dbar result<-setNames(c(Dbar,Dtheta,pD,DIC),c("Dbar","Dhat","pD","DIC")) } else if(method=="pV"){ pV<-var(D)/2 DIC<-pV+Dbar result<-setNames(c(Dbar,Dtheta,pV,DIC),c("Dbar","Dhat","pV","DIC")) } return(result) } # internal functions for ancThresh, plotThresh, and threshDIC ## returns a state based on position relative to thresholds ## threshStateC is a function from phangorn>=2.3.1 threshState<-if(packageVersion("phangorn")>='2.3.1'){ function(x,thresholds){ res <- names(thresholds)[threshStateC(x, thresholds)] names(res) <- names(x) res } } else function(x,thresholds){ t<-c(-Inf,thresholds,Inf) names(t)[length(t)]<-names(t)[length(t)-1] i<-1 while(x>t[i]) i<-i+1 names(t)[i] } # likelihood function for the liabilities likLiab<-function(l,a,V,invV,detV){ y<-c(l,a[2:length(a)])-a[1] logL<--y%*%invV%*%y/2-nrow(V)*log(2*pi)/2-detV/2 return(logL) } # function for the log-prior logPrior<-function(a,t,control){ # pp<-sum(log(diag(control$pr.anc[names(a),a])))+ pp<-sum(log(control$pr.anc[cbind(names(a),a)])) + if(length(t)>2) sum(dexp(t[2:(length(t)-1)],rate=control$pr.th,log=TRUE)) else 0 return(pp) } # check if the liability predictions match observed data allMatch<-function(x,l,thresholds){ result<-all(threshState(l,thresholds=thresholds)==x) if(!is.na(result)) return(result) else return(FALSE) } # check if the liability predictions match observed data & return a probability # (this allows states to be uncertain) probMatch<-function(X,l,thresholds,sequence){ Y<-to.matrix(threshState(l,thresholds=thresholds),sequence) return(prod(rowSums(X*Y))) } # bounds parameter by bouncing bounce<-function(start,step,bounds){ x<-start+step while(x>bounds[2]||xbounds[2]) x<-2*bounds[2]-x if(x0) cbind(assoc,assoc) else NULL if(is.null(assoc)){ cat("No associations provided or found.\n") rotate<-FALSE } } ## check to verify that all taxa in assoc are in tree ii<-sapply(assoc[,1],"%in%",tr1$tip.label) if(any(!ii)){ assoc<-assoc[ii,] cat("Some species in assoc[,1] not in tr1. Removing species & links.\n") } ii<-sapply(assoc[,2],"%in%",tr2$tip.label) if(any(!ii)){ assoc<-assoc[ii,] cat("Some species in assoc[,2] not in tr2. Removing species & links.\n") } ## now check if rotation is to be performed if(rotate){ cat("Rotating nodes to optimize matching...\n") flush.console() if("exhaustive"%in%methods){ tt1<-allRotations(tr1) tt2<-allRotations(tr2) M1<-M2<-matrix(NA,length(tt1),length(tt2)) for(i in 1:length(tt1)){ for(j in 1:length(tt2)){ x<-setNames(sapply(assoc[,2],match,table=tt2[[j]]$tip.label),assoc[,1]) y<-setNames(sapply(assoc[,1],match,table=tt1[[i]]$tip.label),assoc[,2]) M1[i,j]<-attr(tipRotate(tt1[[i]],x*Ntip(tr1)/Ntip(tr2),methods="just.compute"),"minRotate") M2[i,j]<-attr(tipRotate(tt2[[j]],y*Ntip(tr2)/Ntip(tr1),methods="just.compute"),"minRotate") } } MM<-M1+M2 ij<-which(MM==min(MM),arr.ind=TRUE) obj<-list() for(i in 1:nrow(ij)){ tr1<-tt1[[ij[i,1]]] attr(tr1,"minRotate")<-M1[ij[i,1],ij[i,2]] tr2<-tt2[[ij[i,2]]] attr(tr2,"minRotate")<-M2[ij[i,1],ij[i,2]] tt<-list(tr1,tr2) class(tt)<-"multiPhylo" obj[[i]]<-list(trees=tt,assoc=assoc) class(obj[[i]])<-"cophylo" } if(length(obj)>1) class(obj)<-"multiCophylo" else obj<-obj[[1]] } else if ("all"%in%methods){ tt1<-allRotations(tr1) tt2<-allRotations(tr2) obj<-vector(mode="list",length=length(tt1)*length(tt2)) ij<-1 for(i in 1:length(tt1)){ for(j in 1:length(tt2)){ x<-setNames(sapply(assoc[,2],match,table=tt2[[j]]$tip.label),assoc[,1]) y<-setNames(sapply(assoc[,1],match,table=tt1[[i]]$tip.label),assoc[,2]) obj[[ij]]<-list(trees=c( tipRotate(tt1[[i]],x*Ntip(tr1)/Ntip(tr2),methods="just.compute"), tipRotate(tt2[[j]],y*Ntip(tr2)/Ntip(tr1),methods="just.compute")), assoc=assoc) class(obj[[ij]])<-"cophylo" ij<-ij+1 } } class(obj)<-"multiCophylo" } else { x<-setNames(sapply(assoc[,2],match,table=tr2$tip.label),assoc[,1]) tr1<-tipRotate(tr1,x*Ntip(tr1)/Ntip(tr2),right=tr2,assoc=assoc,...) best.tr1<-Inf x<-setNames(sapply(assoc[,1],match,table=tr1$tip.label),assoc[,2]) tr2<-tipRotate(tr2,x*Ntip(tr2)/Ntip(tr1),left=tr1,assoc=assoc,...) best.tr2<-Inf while((best.tr2-attr(tr2,"minRotate"))>0||(best.tr1-attr(tr1,"minRotate"))>0){ best.tr1<-attr(tr1,"minRotate") best.tr2<-attr(tr2,"minRotate") x<-setNames(sapply(assoc[,2],match,table=tr2$tip.label),assoc[,1]) tr1<-tipRotate(tr1,x*Ntip(tr1)/Ntip(tr2),right=tr2,assoc=assoc,...) x<-setNames(sapply(assoc[,1],match,table=tr1$tip.label),assoc[,2]) tr2<-tipRotate(tr2,x*Ntip(tr2)/Ntip(tr1),left=tr1,assoc=assoc,...) } tt<-list(tr1,tr2) class(tt)<-"multiPhylo" obj<-list(trees=tt,assoc=assoc) class(obj)<-"cophylo" } cat("Done.\n") } else { tt<-list(tr1,tr2) class(tt)<-"multiPhylo" obj<-list(trees=tt,assoc=assoc) class(obj)<-"cophylo" } obj } ## called internally by plot.cophylo to plot a phylogram ## written by Liam J. Revell phylogram<-function(tree,part=1,direction="rightwards",fsize=1,ftype="i",lwd=1,...){ if(hasArg(pts)) pts<-list(...)$pts else pts<-TRUE if(hasArg(edge.col)) edge.col<-list(...)$edge.col else edge.col<-rep("black",nrow(tree$edge)) if(hasArg(tip.lwd)) tip.lwd<-list(...)$tip.lwd else tip.lwd<-1 if(hasArg(tip.lty)) tip.lty<-list(...)$tip.lty else tip.lty<-"dotted" if(hasArg(tip.len)) tip.len<-list(...)$tip.len else tip.len<-0.1 if(pts==TRUE&&tip.len==0) tip.len<-0.1 d<-if(direction=="rightwards") 1 else -1 ## sub "_" for " " tree$tip.label<-gsub("_"," ",tree$tip.label) ## check if edge lenths if(is.null(tree$edge.length)) tree<-compute.brlen(tree) ## rescale tree so it fits in one half of the plot ## with enough space for labels if(ftype=="off") fsize<-0 n<-Ntip(tree) sh<-fsize*strwidth(tree$tip.label) H<-nodeHeights(tree) th<-sapply(1:n,function(i,x,e) x[which(e==i)],x=H[,2], e=tree$edge[,2])+tip.len*max(H) tree$edge.length<-tree$edge.length/max(th/(part-sh)) ## reorder cladewise to assign tip positions cw<-reorder(tree,"cladewise") y<-vector(length=n+cw$Nnode) y[cw$edge[cw$edge[,2]<=n,2]]<-0:(n-1)/(n-1) ## reorder pruningwise for post-order traversal pw<-reorder(tree,"pruningwise") nn<-unique(pw$edge[,1]) ## compute vertical position of each edge for(i in 1:length(nn)){ yy<-y[pw$edge[which(pw$edge[,1]==nn[i]),2]] y[nn[i]]<-mean(range(yy)) } ## compute start & end points of each edge X<-nodeHeights(cw)-0.5 ## plot horizontal edges for(i in 1:nrow(X)) lines(d*X[i,],rep(y[cw$edge[i,2]],2),lwd=lwd,lend=2, col=edge.col[i]) ## plot vertical relationships for(i in 1:tree$Nnode+n){ ee<-which(cw$edge[,1]==i) p<-if(i%in%cw$edge[,2]) which(cw$edge[,2]==i) else NULL if(!is.null(p)){ xx<-c(X[ee,1],X[p,2]) yy<-sort(c(y[cw$edge[ee,2]],y[cw$edge[p,2]])) } else { xx<-c(X[ee,1],X[ee[1],1]) yy<-sort(c(y[cw$edge[ee,2]],mean(y[cw$edge[ee,2]]))) } segments(x0=d*xx[1:(length(xx)-1)],y0=yy[1:(length(yy)-1)], x1=d*xx[2:length(xx)],y1=yy[2:length(yy)],lwd=lwd,lend=2,col=edge.col[ee]) } h<-part-0.5-tip.len*(max(X)-min(X))-fsize*strwidth(tree$tip.label) ## plot links to tips for(i in 1:n){ lines(d*c(X[which(cw$edge[,2]==i),2],h[i]+tip.len*(max(X)-min(X))),rep(y[i],2), lwd=tip.lwd,lty=tip.lty) if(pts) points(d*X[which(cw$edge[,2]==i),2],y[i],pch=16,cex=pts*0.7*sqrt(lwd)) } ## plot tip labels font<-which(c("off","reg","b","i","bi")==ftype)-1 if(font>0){ for(i in 1:n) TEXTBOX(d*(h[i]+fsize*strwidth(tree$tip.label[i])+ tip.len*(max(X)-min(X))),y[i], tree$tip.label[i], pos=if(d<0) 4 else 2,offset=0, cex=fsize,font=font) } PP<-list(type="phylogram",use.edge.length=TRUE,node.pos=1, show.tip.label=if(ftype!="off") TRUE else FALSE,show.node.label=FALSE, font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE,label.offset=0, x.lim=par()$usr[1:2],y.lim=par()$usr[3:4], direction=direction,tip.color="black",Ntip=Ntip(cw),Nnode=cw$Nnode, edge=tree$edge,xx=d*sapply(1:(Ntip(cw)+cw$Nnode), function(x,y,z) y[match(x,z)],y=X,z=cw$edge),yy=y) assign("last_plot.phylo",PP,envir=.PlotPhyloEnv) ## return rightmost or leftmost edge of tip labels invisible(d*max(h+fsize*strwidth(tree$tip.label)+tip.len*(max(X)-min(X)))) } cladogram<-function(tree,part=1,direction="rightwards",fsize=1,ftype="i",lwd=1,...){ if(hasArg(pts)) pts<-list(...)$pts else pts<-TRUE if(hasArg(edge.col)) edge.col<-list(...)$edge.col else edge.col<-rep("black",nrow(tree$edge)) if(hasArg(tip.lwd)) tip.lwd<-list(...)$tip.lwd else tip.lwd<-1 if(hasArg(tip.lty)) tip.lty<-list(...)$tip.lty else tip.lty<-"dotted" if(hasArg(tip.len)) tip.len<-list(...)$tip.len else tip.len<-0.1 if(pts==TRUE&&tip.len==0) tip.len<-0.1 d<-if(direction=="rightwards") 1 else -1 ## sub "_" for " " tree$tip.label<-gsub("_"," ",tree$tip.label) ## check if edge lenths if(is.null(tree$edge.length)) tree<-compute.brlen(tree) ## rescale tree so it fits in one half of the plot ## with enough space for labels if(ftype=="off") fsize<-0 n<-Ntip(tree) sh<-fsize*strwidth(tree$tip.label) H<-nodeHeights(tree) th<-sapply(1:n,function(i,x,e) x[which(e==i)],x=H[,2], e=tree$edge[,2])+tip.len*max(H) tree$edge.length<-tree$edge.length/max(th/(part-sh)) ## reorder cladewise to assign tip positions cw<-reorder(tree,"cladewise") y<-vector(length=n+cw$Nnode) y[cw$edge[cw$edge[,2]<=n,2]]<-0:(n-1)/(n-1) ## reorder pruningwise for post-order traversal pw<-reorder(tree,"pruningwise") nn<-unique(pw$edge[,1]) ## compute vertical position of each edge for(i in 1:length(nn)){ desc<-pw$edge[which(pw$edge[,1]==nn[i]),2] n1<-desc[which(y[desc]==min(y[desc]))] n2<-desc[which(y[desc]==max(y[desc]))] v1<-pw$edge.length[which(pw$edge[,2]==n1)] v2<-pw$edge.length[which(pw$edge[,2]==n2)] y[nn[i]]<-((1/v1)*y[n1]+(1/v2)*y[n2])/(1/v1+1/v2) } ## compute start & end points of each edge X<-nodeHeights(cw)-0.5 ## plot horizontal edges for(i in 1:nrow(X)) lines(d*X[i,],y[cw$edge[i,]],lwd=lwd,lend=2, col=edge.col[i]) h<-part-0.5-tip.len*(max(X)-min(X))-fsize*strwidth(tree$tip.label) ## plot links to tips for(i in 1:n){ lines(d*c(X[which(cw$edge[,2]==i),2],h[i]+tip.len*(max(X)-min(X))),rep(y[i],2), lwd=tip.lwd,lty=tip.lty) if(pts) points(d*X[which(cw$edge[,2]==i),2],y[i],pch=16,cex=pts*0.7*sqrt(lwd)) } ## plot tip labels font<-which(c("off","reg","b","i","bi")==ftype)-1 if(font>0){ for(i in 1:n) TEXTBOX(d*(h[i]+fsize*strwidth(tree$tip.label[i])+ tip.len*(max(X)-min(X))),y[i], tree$tip.label[i], pos=if(d<0) 4 else 2,offset=0, cex=fsize,font=font) } PP<-list(type="cladogram",use.edge.length=TRUE,node.pos=1, show.tip.label=if(ftype!="off") TRUE else FALSE,show.node.label=FALSE, font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE,label.offset=0, x.lim=par()$usr[1:2],y.lim=par()$usr[3:4], direction=direction,tip.color="black",Ntip=Ntip(cw),Nnode=cw$Nnode, edge=tree$edge,xx=d*sapply(1:(Ntip(cw)+cw$Nnode), function(x,y,z) y[match(x,z)],y=X,z=cw$edge),yy=y) assign("last_plot.phylo",PP,envir=.PlotPhyloEnv) ## return rightmost or leftmost edge of tip labels invisible(d*max(h+fsize*strwidth(tree$tip.label)+tip.len*(max(X)-min(X)))) } ## internally used function TEXTBOX<-function(x,y,label,pos,offset,cex,font){ rect(x,y-0.5*strheight(label,cex=cex,font=font),x+if(pos==4) strwidth(label, cex=cex,font=font) else -strwidth(label,cex=cex,font=font), y+0.5*strheight(label,cex=cex,font=font),border=FALSE, col=if(par()$bg%in%c("white","transparent")) "white" else par()$bg) text(x=x,y=y,label=label,pos=pos,offset=offset,cex=cex,font=font) } ## plot links between tip taxa according to assoc ## written by Liam J. Revell 2015, 2016, 2019 makelinks<-function(obj,x,link.type="curved",link.lwd=1,link.col="black", link.lty="dashed"){ if(length(link.lwd)==1) link.lwd<-rep(link.lwd,nrow(obj$assoc)) if(length(link.col)==1) link.col<-rep(link.col,nrow(obj$assoc)) if(length(link.lty)==1) link.lty<-rep(link.lty,nrow(obj$assoc)) for(i in 1:nrow(obj$assoc)){ ii<-which(obj$trees[[1]]$tip.label==obj$assoc[i,1]) jj<-which(obj$trees[[2]]$tip.label==obj$assoc[i,2]) for(j in 1:length(ii)) for(k in 1:length(jj)){ y<-c((ii[j]-1)/(Ntip(obj$trees[[1]])-1), (jj[k]-1)/(Ntip(obj$trees[[2]])-1)) if(link.type=="straight") lines(x,y,lty=link.lty[i], lwd=link.lwd[i],col=link.col[i]) else if(link.type=="curved") drawCurve(x,y,lty=link.lty[i], lwd=link.lwd[i],col=link.col[i]) } } } ## plot method for class "multiCophylo" plot.multiCophylo<-function(x,...){ par(ask=TRUE) for(i in 1:length(x)) plot.cophylo(x[[i]],...) } ## plot an object of class "cophylo" ## written by Liam J. Revell 2015, 2016, 2017, 2021, 2023 plot.cophylo<-function(x,...){ plot.new() if(hasArg(type)) type<-list(...)$type else type<-"phylogram" if(length(type)==1) type<-rep(type,2) if(hasArg(mar)) mar<-list(...)$mar else mar<-c(0.1,0.1,0.1,0.1) if(hasArg(xlim)) xlim<-list(...)$xlim else xlim<-c(-0.5,0.5) if(hasArg(scale.bar)) scale.bar<-list(...)$scale.bar else scale.bar<-rep(0,2) if(hasArg(ylim)) ylim<-list(...)$ylim else ylim<-if(any(scale.bar>0)) c(-0.1,1) else c(0,1) if(hasArg(link.type)) link.type<-list(...)$link.type else link.type<-"straight" if(hasArg(link.lwd)) link.lwd<-list(...)$link.lwd else link.lwd<-1 if(hasArg(link.col)) link.col<-list(...)$link.col else link.col<-"black" if(hasArg(link.lty)) link.lty<-list(...)$link.lty else link.lty<-"dashed" if(hasArg(edge.col)) edge.col<-list(...)$edge.col else edge.col<-list( left=rep("black",nrow(x$trees[[1]]$edge)), right=rep("black",nrow(x$trees[[2]]$edge))) obj<-list(...) if(is.null(obj$part)) obj$part<-0.4 par(mar=mar) plot.window(xlim=xlim,ylim=ylim) leftArgs<-rightArgs<-obj leftArgs$edge.col<-edge.col$left rightArgs$edge.col<-edge.col$right if(!is.null(obj$fsize)){ if(length(obj$fsize)>1){ leftArgs$fsize<-obj$fsize[1] rightArgs$fsize<-obj$fsize[2] sb.fsize<- if(length(obj$fsize)>2) obj$fsize[3] else 1 } else sb.fsize<-1 } else sb.fsize<-1 if(!is.null(obj$ftype)){ if(length(obj$ftype)>1){ leftArgs$ftype<-obj$ftype[1] rightArgs$ftype<-obj$ftype[2] } } plotter<-if(type[1]=="cladogram") "cladogram" else "phylogram" x1<-do.call(plotter,c(list(tree=x$trees[[1]]),leftArgs)) plotter<-if(type[2]=="cladogram") "cladogram" else "phylogram" left<-get("last_plot.phylo",envir=.PlotPhyloEnv) x2<-do.call(plotter,c(list(tree=x$trees[[2]],direction="leftwards"), rightArgs)) right<-get("last_plot.phylo",envir=.PlotPhyloEnv) if(!is.null(x$assoc)) makelinks(x,c(x1,x2),link.type,link.lwd,link.col, link.lty) else cat("No associations provided.\n") assign("last_plot.cophylo",list(left=left,right=right),envir=.PlotPhyloEnv) if(any(scale.bar>0)) add.scalebar(x,scale.bar,sb.fsize) } ## add scale bar ## written by Liam J. Revell 2015, 2023 add.scalebar<-function(obj,scale.bar,fsize){ if(scale.bar[1]>0){ pp<-get("last_plot.cophylo",envir=.PlotPhyloEnv)[[1]] s1<-diff(range(pp$xx))/max(nodeHeights(obj$trees[[1]])) lines(c(-0.5,-0.5+scale.bar[1]*s1),rep(-0.05,2)) lines(rep(-0.5,2),c(-0.05,-0.06)) lines(rep(-0.5+scale.bar[1]*s1,2),c(-0.05,-0.06)) text(mean(c(-0.5,-0.5+scale.bar[1]*s1)),rep(-0.05,2),scale.bar[1],pos=1) } if(scale.bar[2]>0){ pp<-get("last_plot.cophylo",envir=.PlotPhyloEnv)[[2]] s2<-diff(range(pp$xx))/max(nodeHeights(obj$trees[[2]])) lines(c(0.5-scale.bar[2]*s2,0.5),rep(-0.05,2)) lines(rep(0.5-scale.bar[2]*s2,2),c(-0.05,-0.06)) lines(rep(0.5,2),c(-0.05,-0.06)) text(mean(c(0.5-scale.bar[2]*s2,0.5)),rep(-0.05,2),scale.bar[2],pos=1) } } ## print an object of class "cophylo" ## written by Liam J. Revell 2015 print.cophylo<-function(x, ...){ cat("Object of class \"cophylo\" containing:\n\n") cat("(1) 2 (possibly rotated) phylogenetic trees in an object of class \"multiPhylo\".\n\n") cat("(2) A table of associations between the tips of both trees.\n\n") } ## print method for "multiCophylo" object print.multiCophylo<-function(x, ...) cat("Object of class \"multiCophylo\" containg",length(x),"objects of class \"cophylo\".\n\n") ## written by Liam J. Revell 2015, 2016 tipRotate<-function(tree,x,...){ if(hasArg(fn)) fn<-list(...)$fn else fn<-function(x) x^2 if(hasArg(methods)) methods<-list(...)$methods else methods<-"pre" if("exhaustive"%in%methods) methods<-"exhaustive" if(hasArg(print)) print<-list(...)$print else print<-FALSE if(hasArg(max.exhaustive)) max.exhaustive<-list(...)$max.exhaustive else max.exhaustive<-20 if(hasArg(rotate.multi)) rotate.multi<-list(...)$rotate.multi else rotate.multi<-FALSE if(rotate.multi) rotate.multi<-!is.binary(tree) if(hasArg(anim.cophylo)) anim.cophylo<-list(...)$anim.cophylo else anim.cophylo<-FALSE if(anim.cophylo){ if(hasArg(left)) left<-list(...)$left else left<-NULL if(hasArg(right)) right<-list(...)$right else right<-NULL if(hasArg(assoc)) assoc<-list(...)$assoc else assoc<-NULL if(is.null(left)&&is.null(right)) anim.cophylo<-FALSE if(hasArg(only.accepted)) only.accepted<-list(...)$only.accepted else only.accepted<-TRUE } tree<-reorder(tree) nn<-1:tree$Nnode+length(tree$tip.label) if("just.compute"%in%methods){ foo<-function(phy,x) sum(fn(x-setNames(1:length(phy$tip.label),phy$tip.label)[names(x)])) oo<-pp<-foo(tree,x) } if("exhaustive"%in%methods){ if(Ntip(tree)>max.exhaustive){ cat(paste("\nmethods=\"exhaustive\" not permitted for more than", max.exhaustive,"tips.\n", "If you are sure you want to run an exhaustive search for a tree of this size\n", "increasing argument max.exhaustive & re-run.\n", "Setting methods to \"pre\".\n\n")) methods<-"pre" } else { cat("Running exhaustive search. May be slow!\n") oo<-Inf tt<-allRotations(tree) foo<-function(phy,x) sum(fn(x-setNames(1:length(phy$tip.label),phy$tip.label)[names(x)])) pp<-sapply(tt,foo,x=x) ii<-which(pp==min(pp)) ii<-if(length(ii)>1) sample(ii,1) else ii tt<-tt[[ii]] pp<-pp[ii] } if(print) message(paste("objective:",pp)) tree<-tt } ANIM.COPHYLO<-function(tree){ dev.hold() if(is.null(left)) plot(cophylo(tree,right,assoc=assoc,rotate=FALSE),...) else if(is.null(right)) plot(cophylo(left,tree,assoc=assoc,rotate=FALSE),...) nodelabels.cophylo(node=i+Ntip(tree),pie=1,col="red",cex=0.4, which=if(is.null(left)) "left" else "right") dev.flush() } if("pre"%in%methods){ for(i in 1:tree$Nnode){ if(anim.cophylo) ANIM.COPHYLO(tree) tt<-if(rotate.multi) rotate.multi(tree,nn[i]) else untangle(rotate(tree,nn[i]),"read.tree") oo<-sum(fn(x-setNames(1:length(tree$tip.label),tree$tip.label)[names(x)])) if(inherits(tt,"phylo")) pp<-sum(fn(x-setNames(1:length(tt$tip.label),tt$tip.label)[names(x)])) if(anim.cophylo&&!only.accepted) ANIM.COPHYLO(tt) else if(inherits(tt,"multiPhylo")){ foo<-function(phy,x) sum(fn(x-setNames(1:length(phy$tip.label),phy$tip.label)[names(x)])) pp<-sapply(tt,foo,x=x) if(anim.cophylo&&!only.accepted) nulo<-lapply(tt,ANIM.COPHYLO) ii<-which(pp==min(pp)) ii<-if(length(ii)>1) sample(ii,1) else ii tt<-tt[[ii]] pp<-pp[ii] } if(oo>pp) tree<-tt if(print) message(paste("objective:",min(oo,pp))) } } if("post"%in%methods){ for(i in tree$Nnode:1){ if(anim.cophylo) ANIM.COPHYLO(tree) tt<-if(rotate.multi) rotate.multi(tree,nn[i]) else untangle(rotate(tree,nn[i]),"read.tree") oo<-sum(fn(x-setNames(1:length(tree$tip.label),tree$tip.label)[names(x)])) if(inherits(tt,"phylo")) pp<-sum(fn(x-setNames(1:length(tt$tip.label),tt$tip.label)[names(x)])) if(anim.cophylo&&!only.accepted) ANIM.COPHYLO(tt) else if(inherits(tt,"multiPhylo")){ foo<-function(phy,x) sum(fn(x-setNames(1:length(phy$tip.label),phy$tip.label)[names(x)])) pp<-sapply(tt,foo,x=x) if(anim.cophylo&&!only.accepted) nulo<-lapply(tt,ANIM.COPHYLO) ii<-which(pp==min(pp)) ii<-if(length(ii)>1) sample(ii,1) else ii tt<-tt[[ii]] pp<-pp[ii] } if(oo>pp) tree<-tt if(print) message(paste("objective:",min(oo,pp))) } } attr(tree,"minRotate")<-min(oo,pp) if(anim.cophylo) ANIM.COPHYLO(tree) tree } ## multi2di for "multiPhylo" object MULTI2DI<-function(x,...){ obj<-lapply(x,multi2di,...) class(obj)<-"multiPhylo" obj } ## labeling methods for plotted "cophylo" object ## written by Liam J. Revell 2015 nodelabels.cophylo<-function(...,which=c("left","right")){ obj<-get("last_plot.cophylo",envir=.PlotPhyloEnv) if(which[1]=="left") assign("last_plot.phylo",obj[[1]],envir=.PlotPhyloEnv) else if(which[1]=="right") assign("last_plot.phylo",obj[[2]],envir=.PlotPhyloEnv) nodelabels(...) } edgelabels.cophylo<-function(...,which=c("left","right")){ obj<-get("last_plot.cophylo",envir=.PlotPhyloEnv) if(which[1]=="left") assign("last_plot.phylo",obj[[1]],envir=.PlotPhyloEnv) else if(which[1]=="right") assign("last_plot.phylo",obj[[2]],envir=.PlotPhyloEnv) edgelabels(...) } tiplabels.cophylo<-function(...,which=c("left","right")){ obj<-get("last_plot.cophylo",envir=.PlotPhyloEnv) if(which[1]=="left") assign("last_plot.phylo",obj[[1]],envir=.PlotPhyloEnv) else if(which[1]=="right") assign("last_plot.phylo",obj[[2]],envir=.PlotPhyloEnv) tiplabels(...) } ## function to draw sigmoidal links ## modified from https://stackoverflow.com/questions/32046889/connecting-two-points-with-curved-lines-s-ish-curve-in-r drawCurve<-function(x,y,scale=0.01,...){ x1<-x[1] x2<-x[2] y1<-y[1] y2<-y[2] curve(plogis(x,scale=scale,location=(x1+x2)/2)*(y2-y1)+y1, x1,x2,add=TRUE,...) } ## S3 summary method ## written by Liam J. Revell 2016 summary.cophylo<-function(object,...){ cat("\nCo-phylogenetic (\"cophylo\") object:",deparse(substitute(object)), "\n\n") cat(paste("Tree 1 (left tree) is an object of class \"phylo\" containing", Ntip(object$trees[[1]]),"species.\n\n")) cat(paste("Tree 2 (right tree) is an object of class \"phylo\" containing", Ntip(object$trees[[2]]),"species.\n\n")) cat("Association (assoc) table as follows:\n\n") maxl<-max(sapply(strsplit(object$assoc[,1],""),length)) cat(paste("\tleft:",paste(rep(" ",max(0,maxl-5)),collapse=""), "\t----\tright:\n",sep="")) nulo<-apply(object$assoc,1,function(x,maxl) cat(paste("\t",x[1], paste(rep(" ",maxl-length(strsplit(x[1],split="")[[1]])), collapse=""),"\t----\t",x[2],"\n",sep="")),maxl=maxl) cat("\n") } phytools/R/parsimony.R0000644000176200001440000000341614533651002014503 0ustar liggesusers## functions to compute the parsimony score (mostly for diagnostic purposes) Fitch<-function(x,pw,nn,nm,return="score"){ xx<-vector("list",Ntip(pw)+Nnode(pw)) xx[1:Ntip(pw)]<-setNames(x,nm)[pw$tip.label] pp<-0 for(i in 1:length(nn)){ ee<-which(pw$edge[,1]==nn[i]) Intersection<-Reduce(intersect,xx[pw$edge[ee,2]]) if(length(Intersection)>0){ xx[[nn[i]]]<-Intersection } else { xx[[nn[i]]]<-Reduce(union,xx[pw$edge[ee,2]]) pp<-pp+1 } } if(return=="score") pp else if(return=="nodes") xx } pscore<-function(tree,x,...){ pw<-if(!is.null(attr(tree,"order"))&& attr(tree,"order")=="postorder") tree else reorder(tree,"postorder") nn<-unique(pw$edge[,1]) if(is.matrix(x)||is.data.frame(x)){ nm<-rownames(x) apply(x,2,Fitch,pw=pw,nn=nn,nm=nm,...) } else { nm<-names(x) Fitch(x,pw,nn,nm,...) } } acctran<-function(tree,x,...){ pw<-if(!is.null(attr(tree,"order"))&& attr(tree,"order")=="postorder") tree else reorder(tree,"postorder") cw<-if(!is.null(attr(tree,"order"))&& attr(tree,"order")=="cladewise") tree else reorder(tree,"cladewise") nn<-unique(pw$edge[,1]) if(is.matrix(x)||is.data.frame(x)){ nm<-rownames(x) Nodes<-apply(x,2,AccDelTran,pw=pw,cw=cw,nn=nn,nm=nm, method="acctran") } else { nm<-names(x) AccDelTran(x,pw,cw,nn,nm,method="acctran") } } AccDelTran<-function(x,pw,cw,nn,nm,method="acctran"){ Sets<-Fitch(x,pw,nn,nm,return="nodes") ## preorder traversal for(i in length(nn):1){ ee<-which(cw$edge[,1]==nn[i]) } # ee<-which(pw$edge[,1]==nn[i]) # Intersection<-Reduce(intersect,xx[pw$edge[ee,2]]) # if(length(Intersection)>0){ # xx[[nn[i]]]<-Intersection # } else { # xx[[nn[i]]]<-Reduce(union,xx[pw$edge[ee,2]]) # pp<-pp+1 # } }phytools/R/ctt.R0000644000176200001440000001233314375517350013265 0ustar liggesusers## computing the mean number of character changes through time from a set of stochastic map trees ## written by Liam J. Revell 2017, 2020 ctt<-function(trees,segments=20,...){ if(!(inherits(trees,"multiSimmap"))) stop("trees should be an object of class \"multiSimmap\".") tree<-as.phylo(trees[[1]]) changes<-sapply(trees,getChanges) h<-max(nodeHeights(tree)) b<-segments segs<-cbind(seq(0,h-h/b,h/b), seq(1/b*h,h,h/b)) nchanges<-rep(0,b) for(i in 1:length(changes)){ for(j in 1:length(changes[[i]])){ ind<-which((changes[[i]][j]>segs[,1])+ (changes[[i]][j]<=segs[,2])==2) nchanges[ind]<-nchanges[ind]+1/length(changes) } } LTT<-ltt(tree,plot=FALSE) LTT<-cbind(LTT$ltt[2:(length(LTT$ltt)-1)], LTT$times[2:(length(LTT$ltt)-1)], LTT$times[3:length(LTT$ltt)]) ii<-1 edge.length<-rep(0,b) for(i in 1:nrow(segs)){ done.seg<-FALSE while(LTT[ii,2]<=segs[i,2]&&done.seg==FALSE){ edge.length[i]<-edge.length[i]+ LTT[ii,1]*(min(segs[i,2],LTT[ii,3])- max(segs[i,1],LTT[ii,2])) if(LTT[ii,3]>=segs[i,2]) done.seg<-TRUE if(LTT[ii,3]<=segs[i,2]) ii<-if(ii0) nc<-nc[b] xx<-vector() H<-nodeHeights(tree) for(i in 1:length(b)){ for(j in 1:nc[i]){ ss<-names(tree$maps[[b[i]]])[j+1] x<-rep(H[b[i],1]+cumsum(tree$maps[[b[i]]])[j],2) xx<-c(xx,setNames(x[1], paste(names(tree$maps[[b[i]]])[j:(j+1)], collapse="->"))) } } xx } print.ctt<-function(x,...){ cat("Object of class \"ctt\" consisting of:\n") cat(" (1) a matrix (segments) with the beginning & ending time of each segment.\n") cat(" (2) a vector (nchanges) with the mean number of changes in each segment.\n") cat(" (3) a vector (edge.length) containing the total edge length of each segement.\n") cat(" (4) an object of class \"phylo\".\n\n") } print.multiCtt<-function(x,...){ cat(paste(length(x),"objects of class \"ctt\" in a list.\n\n")) } plot.multiCtt<-function(x,...){ if(hasArg(alpha)) alpha<-list(...)$alpha else alpha<-0.05 segments<-x[[1]]$segments nchanges<-sapply(x,function(x) x$nchanges) if(hasArg(type)) type<-list(...)$type else type<-"rate" edge.length<-sapply(x,function(x) x$edge.length) obj<-list(segments=segments,nchanges=rowMeans(nchanges), edge.length=rowMeans(edge.length),tree=x[[1]]$tree) class(obj)<-"ctt" lower<-max(floor(alpha/2*length(x)),1) upper<-min(ceiling((1-alpha/2)*length(x)),ncol(nchanges)) xx<-max(nodeHeights(x[[1]]$tree))-as.vector(t(segments)) xx<-c(xx,xx[length(xx):1]) y.lower<-if(type=="number") apply(nchanges,1,sort)[lower,] else if(type=="rate") apply(nchanges/edge.length,1,sort)[lower,] y.upper<-if(type=="number") apply(nchanges,1,sort)[upper,] else if(type=="rate") apply(nchanges/edge.length,1,sort)[upper,] y.lower<-as.vector(rbind(y.lower,y.lower)) y.upper<-as.vector(rbind(y.upper,y.upper)) yy<-c(y.lower,y.upper[length(y.upper):1]) args<-list(...) if(!is.null(args$alpha)) args$alpha<-NULL if(is.null(args$col)) args$col<-"blue" if(is.null(args$ylim)) args$ylim<-range(yy) args$x<-obj do.call(plot,args) polygon(xx,yy,col=make.transparent("grey",0.4),border=0) } phytools/R/mrp.supertree.R0000644000176200001440000001007614375517350015310 0ustar liggesusers## function for Matrix Representation Parsimony supertree estimation in R ## uses pratchet() or optim.parsimony() from the "phangorn" package ## written by Liam J. Revell 2011, 2013, 2015, 2022 compute.mr<-function(trees,type=c("phyDat","matrix")){ type<-type[1] if(inherits(trees,"phylo")){ trees<-list(trees) class(trees)<-"multiPhylo" } if(!inherits(trees,"multiPhylo")) stop("trees should be an object of class \"phylo\" or \"multiPhylo\".") # compute matrix representation phylogenies X<-list() # list of bipartitions characters<-0 # number of characters for(i in 1:length(trees)){ temp<-prop.part(trees[[i]]) # find all bipartitions # create matrix representation of trees[[i]] in X[[i]] X[[i]]<-matrix(0,nrow=length(trees[[i]]$tip),ncol=length(temp)-1) for(j in 1:ncol(X[[i]])) X[[i]][c(temp[[j+1]]),j]<-1 rownames(X[[i]])<-attr(temp,"labels") # label rows if(i==1) species<-trees[[i]]$tip.label else species<-union(species,trees[[i]]$tip.label) # accumulate labels characters<-characters+ncol(X[[i]]) # count characters } XX<-matrix(data="?",nrow=length(species),ncol=characters,dimnames=list(species)) j<-1 for(i in 1:length(X)){ # copy each of X into supermatrix XX XX[rownames(X[[i]]),c(j:((j-1)+ncol(X[[i]])))]<-X[[i]][1:nrow(X[[i]]),1:ncol(X[[i]])] j<-j+ncol(X[[i]]) } if(type=="phyDat"){ # compute contrast matrix for phangorn contrast<-matrix(data=c(1,0,0,1,1,1),3,2,dimnames=list(c("0","1","?"),c("0","1")),byrow=TRUE) # convert XX to phyDat object XX<-phyDat(XX,type="USER",contrast=contrast) } XX } mrp.supertree<-function(trees,method=c("pratchet","optim.parsimony"),...){ # set method method<-method[1] # some minor error checking if(!inherits(trees,"multiPhylo")) stop("trees should be an object of class \"multiPhylo\".") XX<-compute.mr(trees,type="phyDat") # estimate supertree if(method=="pratchet"){ if(hasArg(start)){ start<-list(...)$start if(inherits(start,"phylo")){ supertree<-pratchet(XX,all=TRUE,...) } else { if(start=="NJ") start<-NJ(dist.hamming(XX)) else if(start=="random") start<-rtree(n=length(XX),tip.label=names(XX)) else { warning("do not recognize that option for start; using random starting tree") tree<-rtree(n=length(XX),tip.label=names(XX)) } args<-list(...) args$start<-start args$data<-XX args$all<-TRUE supertree<-do.call(pratchet,args) } } else supertree<-pratchet(XX,all=TRUE,...) if(inherits(supertree,"phylo")) message(paste("The MRP supertree, optimized via pratchet(),\nhas a parsimony score of ", attr(supertree,"pscore")," (minimum ",attr(XX,"nr"),")",sep="")) else if(inherits(supertree,"multiPhylo")) message(paste("pratchet() found ",length(supertree)," supertrees\nwith a parsimony score of ", attr(supertree[[1]],"pscore")," (minimum ",attr(XX,"nr"),")",sep="")) } else if(method=="optim.parsimony"){ if(hasArg(start)){ start<-list(...)$start if(inherits(start,"phylo")){ supertree<-optim.parsimony(tree=start,data=XX,...) } else { if(start=="NJ") start<-NJ(dist.hamming(XX)) else if(start=="random") start<-rtree(n=length(XX),tip.label=names(XX)) else { warning("do not recognize that option for tree; using random starting tree") start<-rtree(n=length(XX),tip.label=names(XX)) } supertree<-optim.parsimony(tree=start,data=XX,...) } } else { message("no input starting tree or option for optim.parsimony; using random starting tree") start<-rtree(n=length(XX),tip.label=names(XX)) supertree<-optim.parsimony(tree=start,data=XX,...) } if(inherits(supertree,"phylo")) message(paste("The MRP supertree, optimized via optim.parsimony(),\nhas a parsimony score of ", attr(supertree,"pscore")," (minimum ",attr(XX,"nr"),")",sep="")) else if(inherits(supertree,"multiPhylo")) message(paste("optim.parsimony() found ",length(supertree)," supertrees\nwith a parsimony score of ", attr(supertree[[1]],"pscore")," (minimum ",attr(XX,"nr"),")",sep="")) } return(supertree) } phytools/R/multirateBM.R0000644000176200001440000002041314376316713014717 0ustar liggesusers## function ## by Liam J. Revell 2021, 2022, 2023 VCV<-function(tree){ H<-nodeHeights(tree) h<-c(H[1,1],H[,2])[order(c(tree$edge[1,1],tree$edge[,2]))] M<-mrca(tree,full=TRUE) M[lower.tri(M)]<-t(M)[lower.tri(M)] ROOT<-Ntip(tree)+1 M<-M[-ROOT,-ROOT] matrix(h[M],nrow(M),ncol(M), dimnames=list(c(tree$tip.label,2:tree$Nnode+Ntip(tree)), c(tree$tip.label,2:tree$Nnode+Ntip(tree)))) } p.func<-function(x,a,C) dmnorm(x,rep(a,nrow(C)),C,log=TRUE) ln.mean<-function(x){ if(x[1]==x[2]) return(x[1]) else { a<-x[2] b<-log(x[1])-log(x[2]) return(a/b*exp(b)-a/b) } } log_lik<-function(lnsig2,tree,x,lambda=1,trace=0){ sig2<-exp(lnsig2) tt<-tree tt$edge.length<-tree$edge.length*apply(tree$edge, 1,function(e,x) ln.mean(x[e]),x=sig2) Tips<-phyl.vcv(as.matrix(x),vcv(tt),1) root<-Ntip(tree)+1 n<-nrow(Tips$C) m<-tree$Nnode ln.p1<-p.func(x,Tips$alpha[1,1],Tips$C) ln.p2<--p.func(log(sig2)[-root],log(sig2)[root], VCV(tree)) logL<-ln.p1-lambda*ln.p2 if(trace>0){ cat(paste("log(L) =",round(logL,4),"\n")) flush.console() } -logL } log_relik<-function(lnsig2,tree,x,trace=0){ sig2<-exp(lnsig2[1:(length(lnsig2)-1)]) SCALE<-exp(lnsig2[length(lnsig2)]) tt<-tree tt$edge.length<-SCALE*tree$edge.length*apply(tree$edge, 1,function(e,x) mean(x[e]),x=sig2) px<-pic(x,tt) dLNSIG<-apply(tree$edge,1,function(edge,lnsig2) diff(lnsig2[edge]), lnsig2=lnsig2)/sqrt(tree$edge.length) logL<-sum(dnorm(px,log=TRUE))+sum(dnorm(dLNSIG,log=TRUE)) if(trace>0){ cat(paste("log(reL) =",round(logL,4),"\n")) flush.console() } -logL } multirateBM<-function(tree,x,method=c("ML","REML"), optim=c("L-BFGS-B","Nelder-Mead","BFGS","CG"), maxit=NULL,n.iter=1,lambda=1,...){ if(hasArg(quiet)) quiet<-list(...)$quiet else quiet<-FALSE if(hasArg(parallel)) parallel<-list(...)$parallel else parallel<-FALSE if(parallel){ if(hasArg(ncores)) ncores<-list(...)$ncores else ncores<-detectCores() if(is.na(ncores)) ncores<-1 } method<-method[1] optim.method<-if(!parallel) optim else "L-BFGS-B" if(!is.null(maxit)) control<-list(maxit=maxit) else control<-list() if(method=="REML"){ cat("Sorry! method=\"REML\" doesn't work. Switching to \"ML\".\n") method<-"ML" } if("L-BFGS-B"%in%optim.method){ vv<-log(var(x)/max(nodeHeights(tree))) if(hasArg(lower)){ lower<-list(...)$lower lower<-log(lower) } else lower<-rep(-10+vv,Ntip(tree)+tree$Nnode) if(length(lower)!=(Ntip(tree)+tree$Nnode)) lower<-rep(lower[1],Ntip(tree)+tree$Nnode) if(hasArg(upper)){ upper<-list(...)$upper lower<-log(lower) } else upper<-rep(10+vv,Ntip(tree)+tree$Nnode) if(length(upper)!=(Ntip(tree)+tree$Nnode)) upper<-rep(upper[1],Ntip(tree)+tree$Nnode) } lik<-if(method=="ML") log_lik else log_relik if(hasArg(trace)) trace<-list(...)$trace else trace<-0 x<-x[tree$tip.label] fit<-list() fit$convergence<-99 init<-log(mean(pic(x,multi2di(collapse.singles(tree), random=FALSE))^2)*(Ntip(tree)-1)/Ntip(tree)) fit$par<-rep(init,Ntip(tree)+tree$Nnode) class(fit)<-"try-error" ii<-1 if(!quiet) cat("Beginning optimization....\n") if(parallel){ ## create cluster cl<-makeCluster(ncores) tmp<-capture.output(print(cl)) if(!quiet) cat(paste("Using ",tmp,".\n",sep="")) } while(inherits(fit,"try-error")||fit$convergence!=0||ii<=n.iter){ if(length(optim.method)==1) OPTIM<-optim.method[1] else OPTIM<-optim.method[if(ii!=length(optim.method)) ii%%length(optim.method) else length(optim.method)] if(!quiet) cat(paste("Optimization iteration ",ii,". Using \"", OPTIM,"\"",if(parallel) " (parallel) " else " ", "optimization method.\n",sep="")) if(OPTIM=="L-BFGS-B"){ fit$par[which(fit$parupper)]<-upper } flush.console() cur.vals<-fit$par if(parallel){ fit<-try(optimParallel(fit$par, lik,tree=tree,x=x,lambda=lambda,trace=trace, control=control, lower=lower,upper=upper, parallel=list(cl=cl,forward=FALSE, loginfo=TRUE))) } else { fit<-try(optim(fit$par, lik,tree=tree,x=x,lambda=lambda,trace=trace, control=control, method=OPTIM, lower=if(OPTIM=="L-BFGS-B") lower else -Inf, upper=if(OPTIM=="L-BFGS-B") upper else Inf)) } if(inherits(fit,"try-error")){ fit<-list() fit$convergence<-99 fit$par<-cur.vals class(fit)<-"try-error" if(!quiet) cat("Caught error without failing. Trying again....\n") } else { if(!quiet) cat(paste("Best (penalized) log-likelihood so far:", signif(-fit$value,6),"\n")) } ii<-ii+1 } if(parallel){ ## stop cluster ## setDefaultCluster(cl=NULL) stopCluster(cl) } if(!quiet) cat("Done optimization.\n") LIK<-function(sig2) -lik(log(sig2),tree=tree,x=x, lambda=0) object<-list( sig2=setNames(exp(fit$par), c(tree$tip.label,1:tree$Nnode+Ntip(tree))), lambda=lambda, logLik=LIK(exp(fit$par)), k=length(fit$par)+1, tree=tree, x=x, convergence=fit$convergence, method=method, lik=LIK) class(object)<-"multirateBM" object } print.multirateBM<-function(x,digits=6,printlen=NULL,...){ if(is.null(printlen)) printlen<-8 cat("Multi-rate Brownian model using multirateBM.\n\n") cat("Fitted rates:\n") if(printlen>=length(x$sig2)) print(round(x$sig2,digits)) else printDotDot(x$sig2,digits,printlen) cat(paste("\nlambda penalty term:", round(x$lambda,digits))) cat(paste("\nlog-likelihood: ",round(x$logLik,digits),"\n")) cat(paste("AIC: ",round(AIC(x),digits),"\n\n")) if(x$convergence==0) cat("R thinks it has found a solution.\n\n") else cat("R may not have found a solution.\n\n") } logLik.multirateBM<-function(object,...){ lik<-object$logLik attr(lik,"df")<-object$k lik } plot.multirateBM<-function(x,digits=2,...){ if(hasArg(plot)) plot<-list(...)$plot else plot<-TRUE cols<-setNames(rainbow(1000,start=0.7,end=0), 1:1000) est.sig2<-apply(x$tree$edge,1,function(e,x) ln.mean(x[e]),x=x$sig2) ln.sig2<-log(est.sig2) min.sig2<-min(ln.sig2) max.sig2<-max(ln.sig2) edge.states<-vector() for(i in 1:length(est.sig2)){ edge.states[i]<-round((ln.sig2[i]-min.sig2)/ (max.sig2-min.sig2)*999)+1 } tree<-paintBranches(x$tree,edge=x$tree$edge[1,2], state=edge.states[1]) for(i in 2:length(edge.states)) tree<-paintBranches(tree,edge=tree$edge[i,2], state=edge.states[i]) nticks<-10 ticks<-exp(seq(min(log(x$sig2)),max(log(x$sig2)), length.out=nticks)) object<-list(tree=tree,cols=cols,ticks=ticks, sig2=est.sig2) class(object)<-"multirateBM_plot" if(plot) plot(object,digits=digits,...) invisible(object) } plot.multirateBM_plot<-function(x,digits=2,...){ args<-list(...) if(!is.null(args$type)) if(args$type=="fan") args$type<-"phylogram" if(is.null(args$lwd)) args$lwd<-3 args$split.vertical<-TRUE args$tree<-x$tree args$plot<-FALSE do.call(plotTree,args) lastPP<-get("last_plot.phylo",envir=.PlotPhyloEnv) args$plot<-TRUE args$colors<-x$cols args$xlim<-c(-0.3,1.05)*diff(lastPP$x.lim) args$add<-TRUE do.call(plotSimmap,args) lastPP<-get("last_plot.phylo",envir=.PlotPhyloEnv) h<-max(nodeHeights(x$tree)) LWD<-diff(par()$usr[1:2])/dev.size("px")[1] lines(x=rep(-0.25*h+LWD*15/2,2),y=c(2,Ntip(x$tree)-1)) nticks<-length(x$ticks) Y<-cbind(seq(2,Ntip(x$tree)-1,length.out=nticks), seq(2,Ntip(x$tree)-1,length.out=nticks)) X<-cbind(rep(-0.25*h+LWD*15/2,nticks), rep(-0.25*h+LWD*15/2+0.02*h,nticks)) for(i in 1:nrow(Y)) lines(X[i,],Y[i,]) add.color.bar(Ntip(x$tree)-3, x$cols, title=expression(paste("evolutionary rate ( ",sigma^2,")")), lims=NULL,digits=3, direction="upwards", subtitle="",lwd=15, x=-0.25*h, y=2,prompt=FALSE) text(x=X[,2],y=Y[,2],signif(x$ticks,digits),pos=4,cex=0.7) } print.multirateBM_plot<-function(x,...){ cat("Object of class \"multirateBM_plot\" containing:\n\n") cat(paste("(1) A phylogenetic tree with ", length(x$tree$tip.label)," tips and ",x$tree$Nnode, " internal nodes.\n\n",sep="")) cat("(2) A mapped set of Brownian evolution rates.\n\n") } setMap.multirateBM_plot<-function(x,...){ if(hasArg(invert)) invert<-list(...)$invert else invert<-FALSE n<-length(x$cols) if(invert) x$cols<-setNames(rev(x$cols),names(x$cols)) else x$cols[1:n]<-colorRampPalette(...)(n) x } phytools/R/mcmcBM.R0000644000176200001440000001012014375517350013621 0ustar liggesusers# function # written by Liam J. Revell 2011 mcmcBM<-function(tree,x,ngen=10000,control=list()){ # starting values (for now) n<-length(tree$tip) temp<-aggregate(x,list(species=as.factor(names(x))),mean) xbar<-temp[,2]; names(xbar)<-temp[,1]; xbar<-xbar[tree$tip.label] sig2<-mean(pic(xbar,tree)^2) a<-mean(xbar) intV<-mean(aggregate(x,list(species=as.factor(names(x))),var)[,2],na.rm=T) prop<-c(0.01*sig2,0.01*sig2,rep(0.01*sig2*max(vcv(tree)),n),0.01*intV) pr.mean<-c(1000,rep(0,n+1),1000) pr.var<-c(pr.mean[1]^2,rep(1000,n+1),pr.mean[length(pr.mean)]^2) # populate control list con=list(sig2=sig2,a=a,xbar=xbar,intV=intV,pr.mean=pr.mean,pr.var=pr.var,prop=prop,sample=100) con[(namc<-names(control))]<-control con<-con[!sapply(con,is.null)] # print control parameters to screen message("Control parameters (set by user or default):"); str(con) # function returns the log-likelihood likelihood<-function(C,invC,detC,x,sig2,a,xbar,intV){ z<-xbar-a logLik<--z%*%invC%*%z/(2*sig2)-nrow(C)*log(2*pi)/2-nrow(C)*log(sig2)/2-detC/2+sum(dnorm(x,xbar[names(x)],sd=sqrt(intV),log=T)) return(logLik) } # function returns the log prior probability log.prior<-function(sig2,a,xbar,intV){ pp<-dexp(sig2,rate=1/con$pr.mean[1],log=T)+sum(dnorm(c(a,xbar),mean=con$pr.mean[1+1:(n+1)],sd=sqrt(con$pr.var[1+1:(n+1)]),log=T))+dexp(intV,rate=1/con$pr.mean[length(con$pr.mean)],log=T) return(pp) } # compute C C<-vcv.phylo(tree) invC<-solve(C) detC<-determinant(C,logarithm=TRUE)$modulus[1] # now set starting values for MCMC sig2<-con$sig2; a<-con$a; xbar<-con$xbar; intV<-con$intV L<-likelihood(C,invC,detC,x,sig2,a,xbar,intV) Pr<-log.prior(sig2,a,xbar,intV) # store X<-matrix(NA,ngen/con$sample+1,n+5,dimnames=list(NULL,c("gen","sig2","a",tree$tip.label,"var","logLik"))) X[1,]<-c(0,sig2,a,xbar,intV,L) message("Starting MCMC...") # start MCMC for(i in 1:ngen){ j<-(i-1)%%(n+3) if(j==0){ # update sig2 sig2.prime<-sig2+rnorm(n=1,sd=sqrt(con$prop[j+1])) if(sig2.prime<0) sig2.prime<--sig2.prime L.prime<-likelihood(C,invC,detC,x,sig2.prime,a,xbar,intV) Pr.prime<-log.prior(sig2.prime,a,xbar,intV) post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T) if(post.odds>runif(n=1)){ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2.prime,a,xbar,intV,L.prime) sig2<-sig2.prime L<-L.prime Pr<-Pr.prime } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,intV,L) } else if(j==1){ # update a a.prime<-a+rnorm(n=1,sd=sqrt(con$prop[j+1])) L.prime<-likelihood(C,invC,detC,x,sig2,a.prime,xbar,intV) Pr.prime<-log.prior(sig2,a.prime,xbar,intV) post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T) if(post.odds>runif(n=1)){ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a.prime,xbar,intV,L.prime) a<-a.prime L<-L.prime Pr<-Pr.prime } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,intV,L) } else if(j>1&&j<=(n+1)) { k<-j-1 # update tip mean k xbar.prime<-xbar xbar.prime[k]<-xbar[k]+rnorm(n=1,sd=sqrt(con$prop[j+1])) L.prime<-likelihood(C,invC,detC,x,sig2,a,xbar.prime,intV) Pr.prime<-log.prior(sig2,a,xbar.prime,intV) post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T) if(post.odds>runif(n=1)){ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar.prime,intV,L.prime) xbar<-xbar.prime L<-L.prime Pr<-Pr.prime } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,intV,L) } else if(j>(n+1)){ # update var intV.prime<-intV+rnorm(n=1,sd=sqrt(con$prop[j+1])) if(intV.prime<0) intV.prime<--intV.prime L.prime<-likelihood(C,invC,detC,x,sig2,a,xbar,intV.prime) Pr.prime<-log.prior(sig2,a,xbar,intV.prime) post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T) if(post.odds>runif(n=1)){ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,intV.prime,L.prime) intV<-intV.prime L<-L.prime Pr<-Pr.prime } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,xbar,intV,L) } } # done MCMC message("Done MCMC.") return(X) } phytools/R/mcmcLambda.R0000644000176200001440000001265414375517350014521 0ustar liggesusers# function # written by Liam J. Revell 2011, 2012, 2013 mcmcLambda<-function(tree,x,ngen=10000,control=list()){ # starting values (for now) n<-length(tree$tip) temp<-aggregate(x,list(species=as.factor(names(x))),mean) xbar<-temp[,2]; names(xbar)<-temp[,1]; xbar<-xbar[tree$tip.label] sig2<-mean(pic(xbar,tree)^2) lambda<-1.0; max.lambda<-maxLambda(tree) a<-mean(xbar) intV<-mean(aggregate(x,list(species=as.factor(names(x))),var)[,2],na.rm=T) prop<-c(0.01*sig2,0.02,0.01*sig2,rep(0.01*sig2*max(vcv(tree)),n),0.01*intV) pr.mean<-c(1000,max.lambda/2,rep(0,n+1),1000) pr.var<-c(pr.mean[1]^2,max.lambda,rep(1000,n+1),pr.mean[length(pr.mean)]^2) # populate control list con=list(sig2=sig2,lambda=lambda,a=a,xbar=xbar,intV=intV,pr.mean=pr.mean,pr.var=pr.var,prop=prop,sample=100) con[(namc<-names(control))]<-control con<-con[!sapply(con,is.null)] # print control parameters to screen message("Control parameters (set by user or default):"); str(con) # function returns the log-likelihood likelihood<-function(C,invC,detC,x,sig2,a,xbar,intV){ z<-xbar-a logLik<--z%*%invC%*%z/(2*sig2)-nrow(C)*log(2*pi)/2-nrow(C)*log(sig2)/2-detC/2+sum(dnorm(x,xbar[names(x)],sd=sqrt(intV),log=T)) return(logLik) } # function returns the log prior probability log.prior<-function(sig2,lambda,a,xbar,intV){ pp<-dexp(sig2,rate=1/con$pr.mean[1],log=T)+dunif(lambda,min=con$pr.mean[2]-con$pr.var[2]/2,max=con$pr.mean[2]+con$pr.var[2]/2,log=T)+sum(dnorm(c(a,xbar),mean=con$pr.mean[1+1:(n+1)],sd=sqrt(con$pr.var[1+1:(n+1)]),log=T))+dexp(intV,rate=1/con$pr.mean[length(con$pr.mean)],log=T) return(pp) } # compute (starting values for) C C1<-vcv.phylo(tree) # used for updates of lambda C<-lambda.transform(con$lambda,C1) invC<-solve(C) detC<-determinant(C,logarithm=TRUE)$modulus[1] # now set starting values for MCMC sig2<-con$sig2; lambda<-con$lambda; a<-con$a; xbar<-con$xbar; intV<-con$intV L<-likelihood(C,invC,detC,x,sig2,a,xbar,intV) Pr<-log.prior(sig2,lambda,a,xbar,intV) # store X<-matrix(NA,ngen/con$sample+1,n+6,dimnames=list(NULL,c("gen","sig2","lambda","a",tree$tip.label,"var","logLik"))) X[1,]<-c(0,sig2,lambda,a,xbar,intV,L) message("Starting MCMC...") # start MCMC for(i in 1:ngen){ j<-(i-1)%%(n+4) if(j==0){ # update sig2 sig2.prime<-sig2+rnorm(n=1,sd=sqrt(con$prop[j+1])) if(sig2.prime<0) sig2.prime<--sig2.prime L.prime<-likelihood(C,invC,detC,x,sig2.prime,a,xbar,intV) Pr.prime<-log.prior(sig2.prime,lambda,a,xbar,intV) post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T) if(post.odds>runif(n=1)){ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2.prime,lambda,a,xbar,intV,L.prime) sig2<-sig2.prime L<-L.prime Pr<-Pr.prime } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,lambda,a,xbar,intV,L) } else if(j==1){ # update lambda lambda.prime<-lambda+rnorm(n=1,sd=sqrt(con$prop[j+1])) while(lambda.prime<0||lambda.prime>max.lambda){ if(lambda.prime<0) lambda.prime<--lambda.prime if(lambda.prime>max.lambda) lambda.prime<-2*max.lambda-lambda.prime } # update C with new lambda C.prime<-lambda.transform(lambda.prime,C1) invC.prime<-solve(C.prime) detC.prime<-determinant(C.prime,logarithm=TRUE)$modulus[1] L.prime<-likelihood(C.prime,invC.prime,detC.prime,x,sig2,a,xbar,intV) Pr.prime<-log.prior(sig2,lambda.prime,a,xbar,intV) post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T) if(post.odds>runif(n=1)){ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,lambda.prime,a,xbar,intV,L.prime) lambda<-lambda.prime C<-C.prime; invC<-invC.prime; detC<-detC.prime L<-L.prime Pr<-Pr.prime } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,lambda,a,xbar,intV,L) } else if(j==2){ # update a a.prime<-a+rnorm(n=1,sd=sqrt(con$prop[j+1])) L.prime<-likelihood(C,invC,detC,x,sig2,a.prime,xbar,intV) Pr.prime<-log.prior(sig2,lambda,a.prime,xbar,intV) post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T) if(post.odds>runif(n=1)){ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,lambda,a.prime,xbar,intV,L.prime) a<-a.prime L<-L.prime Pr<-Pr.prime } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,lambda,a,xbar,intV,L) } else if(j>2&&j<=(n+2)) { k<-j-2 # update tip mean k xbar.prime<-xbar xbar.prime[k]<-xbar[k]+rnorm(n=1,sd=sqrt(con$prop[j+1])) L.prime<-likelihood(C,invC,detC,x,sig2,a,xbar.prime,intV) Pr.prime<-log.prior(sig2,lambda,a,xbar.prime,intV) post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T) if(post.odds>runif(n=1)){ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,lambda,a,xbar.prime,intV,L.prime) xbar<-xbar.prime L<-L.prime Pr<-Pr.prime } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,lambda,a,xbar,intV,L) } else if(j>(n+2)){ # update var intV.prime<-intV+rnorm(n=1,sd=sqrt(con$prop[j+1])) if(intV.prime<0) intV.prime<--intV.prime L.prime<-likelihood(C,invC,detC,x,sig2,a,xbar,intV.prime) Pr.prime<-log.prior(sig2,lambda,a,xbar,intV.prime) post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L),na.rm=T) if(post.odds>runif(n=1)){ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,lambda,a,xbar,intV.prime,L.prime) intV<-intV.prime L<-L.prime Pr<-Pr.prime } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,lambda,a,xbar,intV,L) } } # done MCMC message("Done MCMC.") return(X) } phytools/R/rerootingMethod.R0000644000176200001440000000655714435734304015654 0ustar liggesusers## function to compute the marginal posterior probabilities for nodes ## using the rerooting method ## written by Liam J. Revell 2013, 2015, 2017, 2018, 2020, 2023 rerootingMethod<-function(tree,x,model=c("ER","SYM"),...){ if(hasArg(quiet)) quiet<-list(...)$quiet else quiet<-FALSE if(!quiet){ cat("\nNote:\n") cat(" This function is redundant with 'phytools::ancr' in situations in\n") cat(" which it should be used (symmetric Q matrices) & invalid for non-\n") cat(" symmetric Q matrices (e.g., model='ARD').\n\n") } if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(hasArg(tips)) tips<-list(...)$tips else tips<-NULL if(!is.matrix(model)) model<-model[1] n<-Ntip(tree) # if vector convert to binary matrix if(!is.matrix(x)){ yy<-to.matrix(x,sort(unique(x))) if(is.null(tips)) tips<-FALSE } else { if(is.null(tips)) tips<-TRUE yy<-x } yy<-yy[tree$tip.label,] yy<-yy/rowSums(yy) YY<-fitMk(tree,yy,model=model,output.liks=TRUE,...) Q<-matrix(c(0,YY$rates)[YY$index.matrix+1],length(YY$states), length(YY$states),dimnames=list(YY$states,YY$states)) diag(Q)<--colSums(Q,na.rm=TRUE) nn<-if(tips) c(1:n,if(tree$Nnode>1) 2:tree$Nnode+n) else { if(tree$Nnode>1) 2:tree$Nnode+n else vector() } ff<-function(nn){ tt<-if(nn>Ntip(tree)) ape::root.phylo(tree,node=nn) else reroot(tree,nn,tree$edge.length[which(tree$edge[,2]==nn)]) fitMk(tt,yy,model=model,fixedQ=Q,output.liks=TRUE)$lik.anc[1,] } XX<-t(sapply(nn,ff)) if(tips) XX<-rbind(XX[1:n,],YY$lik.anc[1,],if(tree$Nnode>1) XX[(n+1):nrow(XX),]) else XX<-rbind(yy,YY$lik.anc[1,],if(tree$Nnode>1) XX) rownames(XX)<-1:(tree$Nnode+n) if(tips) rownames(XX)[1:n]<-tree$tip.label XX<-if(tips) XX else XX[1:tree$Nnode+n,] obj<-list(loglik=YY$logLik,Q=Q,marginal.anc=XX,tree=tree,x=yy) class(obj)<-"rerootingMethod" obj } print.rerootingMethod<-function(x,digits=6,printlen=NULL,...){ cat("Ancestral character estimates using re-rooting method") cat("\nof Yang et al. (1995):\n") if(is.null(printlen)) print(round(x$marginal.anc,digits)) else { print(round(x$marginal.anc[1:printlen,],digits)) cat("...\n") } cat("\nEstimated transition matrix,\nQ =\n") print(round(x$Q,digits)) cat("\n**Note that if Q is not symmetric the marginal") cat("\nreconstructions may be invalid.\n") cat(paste("\nLog-likelihood =",round(x$loglik,digits),"\n\n")) } plot.rerootingMethod<-function(x, ...){ args<-list(...) if(is.null(args$lwd)) args$lwd<-1 if(is.null(args$ylim)) args$ylim<-c(-0.1*Ntip(x$tree), Ntip(x$tree)) if(is.null(args$offset)) args$offset<-0.5 if(is.null(args$ftype)) args$ftype="i" args$tree<-x$tree do.call(plotTree,args) if(hasArg(piecol)) piecol<-list(...)$piecol else piecol<-setNames(colorRampPalette(c("blue", "yellow"))(ncol(x$marginal.anc)), colnames(x$marginal.anc)) if(hasArg(node.cex)) node.cex<-list(...)$node.cex else node.cex<-0.6 nodelabels(pie=x$marginal.anc[ as.character(1:x$tree$Nnode+Ntip(x$tree)),], piecol=piecol,cex=node.cex) if(hasArg(tip.cex)) tip.cex<-list(...)$tip.cex else tip.cex<-0.4 tiplabels(pie=x$x[x$tree$tip.label,],piecol=piecol, cex=tip.cex) legend(x=par()$usr[1],y=par()$usr[1], legend=colnames(x$marginal.anc), pch=21,pt.bg=piecol,pt.cex=2.2,bty="n") } logLik.rerootingMethod<-function(object,...) object$loglik phytools/R/phylo.impute.R0000644000176200001440000000427214375517350015133 0ustar liggesusers## function to impute missing values in a multivariate data matrix ## written by Liam J. Revell 2019 phylo.impute<-function(tree,X,...){ if(hasArg(maxit)) maxit<-list(...)$maxit else maxit<-5000 if(hasArg(quiet)) quiet<-list(...)$quiet else quiet<-TRUE if(hasArg(fixed)) fixed<-list(...)$fixed else fixed<-FALSE if(hasArg(p)) p<-list(...)$p else p<-2.0 if(is.data.frame(X)) X<-as.matrix(X) ii<-which(is.na(X),arr.ind=TRUE) lik<-function(theta,tree,X,ii){ X[ii]<-theta object<-evol.vcv(tree,X) if(!quiet) print(object$logL1) -object$logL1 } lower<-apply(X,2,expand.range,na.rm=TRUE,p=p)[1,ii[,2]] upper<-apply(X,2,expand.range,na.rm=TRUE,p=p)[2,ii[,2]] if(hasArg(x.init)) x.init<-list(...)$x.init else x.init<-"ace" if(x.init[1]=="random") x.init<-runif(n=length(ii),lower,upper) else if(x.init[1]=="ace") { x.init<-vector() for (i in 1:nrow(ii)){ tip<-rownames(X)[ii[i]] tt<-drop.tip(ape::root.phylo(tree,outgroup=tip), names(ii[which(ii[,2]==ii[i,2]),1])) x.init[i]<-fastAnc(tt,X[!is.na(X[,ii[i,2]]), ii[i,2]])[1] } } if(fixed==FALSE){ fit<-optim(x.init,lik,tree=tree,X=X,ii=ii,method="L-BFGS-B", lower=lower,upper=upper,control=list(maxit=maxit)) } else { fit<-list(par=x.init,value=lik(x.init,tree,X,ii), counts=c(0,0),convergence=0, message="Fixed value of par.") } X[ii]<-fit$par attr(X,"optim")<-list(logLik=-fit$value,counts=fit$counts, convergence=fit$convergence,message=fit$message) class(X)<-c("matrix","phylo.impute") X } expand.range<-function(x,na.rm=FALSE,p=2.0){ rr<-range(x,na.rm=na.rm) mean(rr)+c(p*(rr[1]-mean(rr)),p*(rr[2]-mean(rr))) } print.phylo.impute<-function(x,...){ if(hasArg(digits)) digits<-list(...)$digits else digits<-c(7,3) if(hasArg(n)) n<-list(...)$n else n<-6L if(n>nrow(x)) n<-nrow(x) cat("Results from phylogenetic imputation:\n") print(head(unclass(x),n),digits=digits[1]) if(n0,arr.ind=TRUE) for(i in 1:max(ncat)){ ii<-grep(paste("R",i,sep=""),rownames(model)) for(j in 1:max(ncat)){ if(i!=j){ jj<-grep(paste("R",j,sep=""),rownames(model)) if(any(mm[ii,jj]>0)){ kk<-ind[which(ind[,1]%in%ii),,drop=FALSE] kk<-kk[which(kk[,2]%in%jj),,drop=FALSE] mm[kk]<-min(model[kk]) } } } } old<-sort(unique(as.vector(mm))) new<-0:length(old) for(i in 1:length(old)) mm[which(mm==old[i],arr.ind=TRUE)]<-new[i] model<-mm } colnames(model)<-rownames(model)<-colnames(X)<-cols if(!quiet){ cat("\nThis is the design matrix of the fitted model.\nDoes it make sense?\n\n") print(model) cat("\n") flush.console() } fits<-list() args<-list(...) args$model<-model args$tree<-tree args$x<-X if(hasArg(logscale)) logscale<-rep(list(...)$logscale,niter) else logscale<-sample(c(TRUE,FALSE),niter,replace=TRUE) if(hasArg(opt.method)) opt.method<-rep(list(...)$opt.method,niter) else opt.method<-sample(c("nlminb","optim"),niter,replace=TRUE) ## parallelize if(!parallel){ for(i in 1:niter){ args$logscale<-logscale[i] args$opt.method<-opt.method[i] args$rand_start<-TRUE fits[[i]]<-NA class(fits[[i]])<-"try-error" while(inherits(fits[[i]],"try-error")){ fits[[i]]<-try(do.call(fitMk,args)) } if(trace>0) print(fits[[i]]) logL<-sapply(fits,logLik) if(!quiet){ cat(paste("log-likelihood from current iteration:", round(logLik(fits[[i]]),4),"\n")) cat(paste(" --- Best log-likelihood so far:",round(max(logL),4), "---\n")) flush.console() } } } else if(parallel){ if(hasArg(ncores)) ncores<-list(...)$ncores else ncores<-min(c(detectCores()-1,niter)) mc<-makeCluster(ncores,type="PSOCK") registerDoParallel(cl=mc) if(!quiet){ cat(paste("Opened cluster with",ncores,"cores.\n")) cat("Running optimization iterations in parallel.\n") cat("Please wait....\n") flush.console() } fits<-foreach(i=1:niter)%dopar%{ args$logscale<-logscale[i] args$opt.method<-opt.method[i] args$rand_start<-TRUE result<-NA class(result)<-"try-error" while(inherits(result,"try-error")){ result<-try(do.call(phytools::fitMk,args)) } result } logL<-sapply(fits,logLik) stopCluster(cl=mc) } obj<-fits[[which(logL==max(logL))[1]]] obj$ncat<-ncat obj$model<-MODEL obj$umbral<-umbral obj$all.fits<-fits obj$data<-X class(obj)<-c("fitHRM","fitMk") obj } ## print method for objects of class "fitHRM" print.fitHRM<-function(x,digits=6,...){ cat("Object of class \"fitHRM\".\n\n") ss<-unique(sapply(x$states,function(x) strsplit(x,"*",fixed=TRUE)[[1]][1])) cat(paste("Observed states: [ ",paste(ss,collapse=", ")," ]\n", sep="")) cat(paste("Number of rate categories per state: [ ", paste(x$ncat,collapse=", ")," ]\n\n",sep="")) cat("Fitted (or set) value of Q:\n") Q<-matrix(NA,length(x$states),length(x$states)) Q[]<-c(0,x$rates)[x$index.matrix+1] diag(Q)<-0 diag(Q)<--rowSums(Q) colnames(Q)<-rownames(Q)<-x$states print(round(Q,digits)) cat("\nFitted (or set) value of pi:\n") print(round(x$pi,digits)) cat(paste("due to treating the root prior as (a) ",x$root.prior,".\n", sep="")) cat(paste("\nLog-likelihood:",round(x$logLik,digits),"\n")) cat(paste("\nOptimization method used was \"",x$method,"\"\n\n", sep="")) if(x$opt_results$convergence==0) cat("R thinks it has found the ML solution.\n\n") else cat("R thinks optimization may not have converged.\n\n") } isOdd<-function(x) (x%%2)==1 ## S3 plot method for objects of class "fitHRM" plot.fitHRM<-function(x,...){ if(hasArg(tol)) tol<-list(...)$tol else tol<-1e-6 umbral<-x$umbral ncat<-x$ncat Q<-as.Qmatrix(x) II<-x$index.matrix for(i in 1:nrow(II)) for(j in 1:ncol(II)) if(Q[i,j]1) sum(x$ncat[1:(i-1)]) else 0 mm[1:x$ncat[i]+cs]<-if(isOdd(i)) nn[1:x$ncat[i]+cs] else nn[x$ncat[i]:1+cs] } if(isOdd(length(x$ncat))) mm<-nn Q<-Q[mm,mm] class(Q)<-"Qmatrix" args.list<-list(...) args.list$show.zeros<-FALSE plot(Q,show.zeros=FALSE,umbral=umbral,ncat=ncat,...) } as.Qmatrix.corhmm<-function(x,...){ Q<-x$solution Q[is.na(Q)]<-0 diag(Q)<--rowSums(Q) class(Q)<-"Qmatrix" Q } phytools/R/roundPhylogram.R0000644000176200001440000002107214421530444015474 0ustar liggesusers## function plots a sigmoid or spline phylogram or cladogram ## written by Liam J. Revell 2022, 2023 splinePhylogram<-function(tree,...){ args<-list(...) args$tree<-tree args$plot<-FALSE args$direction<-"rightwards" do.call(plotTree,args) pp<-get("last_plot.phylo",envir=.PlotPhyloEnv) if(hasArg(df)) df<-list(...)$df else df<-50 if(hasArg(res)) res<-list(...)$res else res<-4*df if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-par()$lwd if(hasArg(color)) color<-list(...)$color else color<-par()$fg if(is.null(tree$edge.length)) tree<-compute.brlen(tree) h<-max(nodeHeights(tree))/res tree<-make.era.map(tree,seq(0,max(nodeHeights(tree)),by=h)) tree<-map.to.singleton(tree) args<-list(...) args$tree<-tree args$color<-"transparent" args$direction<-"rightwards" args$add<-TRUE dev.hold() do.call(plotTree,args) obj<-get("last_plot.phylo",envir=.PlotPhyloEnv) phy<-list(edge=obj$edge,Nnode=obj$Nnode, tip.label=1:obj$Ntip) attr(phy,"class")<-"phylo" for(i in 1:Ntip(phy)){ aa<-c(i,Ancestors(phy,i)) xx<-obj$xx[aa] yy<-obj$yy[aa] DF<-min(min(length(xx)-1,df),df) tmp<-predict(smooth.spline(xx,yy,df=DF)) tmp$x<-c(xx[length(xx)],tmp$x) tmp$y<-c(yy[length(yy)],tmp$y) lines(tmp,lwd=lwd,col=color) } nulo<-dev.flush() args$tree<-collapse.singles(tree) args$add<-TRUE ffg<-par()$fg par(fg="transparent") do.call(plotTree,args) par(fg=ffg) assign("last_plot.phylo",pp,envir=.PlotPhyloEnv) } compute.brlen.simmap<-function(phy,method="Grafen",power=1,...){ if(inherits(phy,"simmap")){ tt<-as.phylo(phy) tt<-compute.brlen(tt,method=method,power=power,...) ss<-tt$edge.length/phy$edge.length phy$maps<-mapply("*",ss,phy$maps,SIMPLIFY=FALSE) phy$mapped.edge<-phy$mapped.edge* matrix(rep(ss,ncol(phy$mapped.edge)), nrow(phy$mapped.edge),ncol(phy$mapped.edge)) phy$edge.length<-tt$edge.length } else if(inherits(phy,"phylo")) phy<-compute.brlen(phy,method=method,power=power,...) phy } sigmoidPhylogram<-function(tree,...){ if(hasArg(outline)) outline<-list(...)$outline else outline<-FALSE if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-2 if(outline){ args<-list(...) args$tree<-as.phylo(tree) args$lwd<-lwd+2 args$colors<-par()$fg args$outline<-FALSE do.call(sigmoidPhylogram,args) } ## b=5,m1=0.01,m2=0.5,v=1 b<-if(hasArg(b)) list(...)$b else 5 m1<-if(hasArg(m1)) list(...)$m1 else 0.01 m2<-if(hasArg(m2)) list(...)$m2 else 0.5 v<-if(hasArg(v)) list(...)$v else 1 direction<-if(hasArg(direction)) list(...)$direction else "rightwards" show.hidden<-if(hasArg(show.hidden)) list(...)$show.hidden else FALSE if(inherits(tree,"simmap")){ if(hasArg(colors)) colors<-list(...)$colors else { ss<-sort(unique(c(getStates(tree,"nodes"), getStates(tree,"tips")))) mm<-length(ss) colors<-setNames( colorRampPalette(palette()[1:min(8,mm)])(mm), ss) } } else if(inherits(tree,"phylo")) { if(hasArg(color)){ color<-setNames(list(...)$color,"1") colors<-color } else colors<-setNames(par()$fg,"1") tree<-paintSubTree(tree,Ntip(tree)+1,"1") } if(hasArg(res)) res<-list(...)$res else res<-199 if(hasArg(use.edge.length)) use.edge.length<-list(...)$use.edge.length else use.edge.length<-TRUE if(!use.edge.length){ if(hasArg(power)) power<-list(...)$power else power<-1 tree<-compute.brlen.simmap(tree,power=power) } h<-max(nodeHeights(tree)) args<-list(...) args$power<-NULL args$res<-NULL args$colors<-NULL args$b<-NULL args$m1<-NULL args$m2<-NULL args$v<-NULL args$tree<-tree args$color<-if(show.hidden) make.transparent("red",0.25) else "transparent" if(outline) args$add<-TRUE args$outline<-FALSE dev.hold() par_fg<-par()$fg par(fg="transparent") do.call(plotTree,args) par(fg=par_fg) pp<-get("last_plot.phylo",envir=.PlotPhyloEnv) par_usr<-par()$usr args$add<-TRUE if(direction=="downwards"){ args$xlim<-pp$x.lim args$ylim<-pp$y.lim[2:1]-pp$y.lim[1] args$direction<-"upwards" } else if(direction=="leftwards"){ args$xlim<-pp$x.lim[2:1]-pp$x.lim[1] args$ylim<-pp$y.lim args$direction<-"rightwards" } if(outline){ par_fg<-par()$fg par(fg="transparent") } do.call(plotTree,args) if(outline) par(fg=par_fg) pp<-get("last_plot.phylo",envir=.PlotPhyloEnv) xx<-if(direction%in%c("rightwards","leftwards")) pp$xx else pp$yy yy<-if(direction%in%c("rightwards","leftwards")) pp$yy else pp$xx ## Yt<-A+(K-A)/((C+exp(-B*(t-M)))^(1/v)) sigmoid<-function(x,.A=A,.K=K,.C=C,.B=B,.M=M,.v=v) return(.A+(.K-.A)/((.C+exp(-.B*(x-.M)))^(1/.v))) for(i in 1:nrow(tree$edge)){ A<-yy[tree$edge[i,1]] K<-yy[tree$edge[i,2]] if(i==1) dy<-abs(A-K) B<-b*Ntip(tree)/h t<-seq(xx[tree$edge[i,1]],xx[tree$edge[i,2]], length.out=res) t<-sort(c(t,t[1]+cumsum(tree$maps[[i]]))) dd<-diff(range(t)) M<-t[1] + if(m1*h>(m2*dd)) m2*dd else m1*h C<-1 Yt<-c(A,sigmoid(t),K) t<-c(t[1],t,t[length(t)]) COLS<-vector() bb<-setNames(t[1]+cumsum(tree$maps[[i]]),names(tree$maps[[i]])) for(j in 1:length(t)) COLS[j]<-colors[names(bb[which(t[j]<=bb)])[1]] nn<-length(t) if(direction%in%c("rightwards","leftwards")) segments(t[1:(nn-1)],Yt[1:(nn-1)],x1=t[2:nn],y1=Yt[2:nn], col=COLS,lwd=lwd) else if(direction%in%c("upwards","downwards")) segments(Yt[1:(nn-1)],t[1:(nn-1)],x1=Yt[2:nn],y1=t[2:nn], col=COLS,lwd=lwd) } nulo<-dev.flush() pp$edge<-tree$edge assign("last_plot.phylo",pp,envir=.PlotPhyloEnv) } ## function plots a round phylogram ## written by Liam J. Revell 2014, 2015, 2016, 2023 roundPhylogram<-function(tree,fsize=1.0,ftype="reg",lwd=2,mar=NULL,offset=NULL, direction="rightwards",type="phylogram",xlim=NULL,ylim=NULL,...){ if(inherits(tree,"multiPhylo")){ par(ask=TRUE) tt<-lapply(tree,roundPhylogram,fsize=fsize,ftype=ftype,lwd=lwd,mar=mar,offset=offset, direction=direction,type=type,xlim=xlim,ylim=ylim) } else { if(hasArg(lty)) lty<-list(...)$lty else lty<-"solid" if(length(lty)!=nrow(tree$edge)) lty<-rep(lty,ceiling(nrow(tree$edge)/length(lty))) if(length(lwd)!=nrow(tree$edge)) lwd<-rep(lwd,ceiling(nrow(tree$edge)/length(lwd))) if(type=="cladogram"||is.null(tree$edge.length)) tree<-compute.brlen(tree) ftype<-which(c("off","reg","b","i","bi")==ftype)-1 if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") # swap out "_" character for spaces (assumes _ is a place holder) tree$tip.label<-gsub("_"," ",tree$tip.label) if(is.null(mar)) mar=rep(0.1,4) n<-length(tree$tip.label) # set offset fudge (empirically determined) offsetFudge<-1.37 # reorder cladewise to assign tip positions cw<-reorder(tree,"cladewise") io<-reorder(tree,index.only=TRUE) lwd<-lwd[io] lty<-lty[io] y<-vector(length=n+cw$Nnode) y[cw$edge[cw$edge[,2]<=n,2]]<-1:n # reorder pruningwise for post-order traversal pw<-reorder(tree,"pruningwise") nn<-unique(pw$edge[,1]) # compute vertical position of each edge for(i in 1:length(nn)){ yy<-y[pw$edge[which(pw$edge[,1]==nn[i]),2]] y[nn[i]]<-mean(range(yy)) } # compute start & end points of each edge X<-nodeHeights(cw) if(is.null(xlim)){ pp<-par("pin")[1] sw<-fsize*(max(strwidth(cw$tip.label,units="inches")))+offsetFudge*fsize*strwidth("W",units="inches") alp<-optimize(function(a,H,sw,pp) (a*1.04*max(H)+sw-pp)^2,H=X,sw=sw,pp=pp,interval=c(0,1e6))$minimum xlim<-c(min(X),max(X)+sw/alp) } if(is.null(ylim)) ylim=c(1,max(y)) ## end preliminaries # open & size a new plot plot.new() par(mar=mar) if(is.null(offset)) offset<-0.2*lwd/3+0.2/3 plot.window(xlim=xlim,ylim=ylim) # plot edges for(i in 1:nrow(X)){ x<-NULL b<-y[cw$edge[i,1]] c<-X[i,1] d<-if(y[cw$edge[i,2]]>y[cw$edge[i,1]]) 1 else -1 xx<-X[i,2] yy<-y[cw$edge[i,2]] a<-(xx-c)/(yy-b)^2 curve(d*sqrt((x-c)/a)+b,from=X[i,1],to=X[i,2],add=TRUE,lwd=lwd[i],lty=lty[i]) } # plot tip labels for(i in 1:n) if(ftype) text(X[which(cw$edge[,2]==i),2],y[i],tree$tip.label[i],pos=4,offset=offset,font=ftype,cex=fsize) PP<-list(type=type,use.edge.length=if(type=="phylogram") TRUE else FALSE,node.pos=1, show.tip.label=if(ftype) TRUE else FALSE,show.node.label=FALSE,font=ftype,cex=fsize, adj=0,srt=0,no.margin=FALSE,label.offset=offset,x.lim=par()$usr[1:2],y.lim=par()$usr[3:4], direction=direction,tip.color="black",Ntip=length(cw$tip.label),Nnode=cw$Nnode,edge=tree$edge, xx=sapply(1:(length(cw$tip.label)+cw$Nnode),function(x,y,z) y[match(x,z)],y=X,z=cw$edge), yy=y) assign("last_plot.phylo",PP,envir=.PlotPhyloEnv) } } phytools/R/plotTree.wBars.R0000644000176200001440000002152414375517350015350 0ustar liggesusers## plotTree.boxplot ## written by Liam J. Revell 2016, 2021, 2022 plotTree.boxplot<-function(tree,x,args.plotTree=list(), args.boxplot=list(),...){ tree<-untangle(tree,"read.tree") cw<-reorder(tree) if(!is.list(x)&&inherits(x,"formula",FALSE)){ obj<-setNames( lapply(cw$tip.label,function(x,y) y[which(names(y)==x)], y=x),cw$tip.label) } else obj<-x if(inherits(x,"formula")) args.boxplot$formula<-obj else args.boxplot$x<-obj args.boxplot$horizontal<-TRUE args.boxplot$axes<-FALSE args.boxplot$names.arg<-"" args.boxplot$xlim<-c(1,Ntip(cw)) if(is.null(args.boxplot$space)) args.boxplot$space<-0.7 if(is.null(args.boxplot$mar)) args.boxplot$mar<-c(5.1,0,2.1,1.1) else args.boxplot$mar[2]<-0.1 args.plotTree$tree<-cw if(is.null(args.plotTree$mar)) args.plotTree$mar<-c(5.1,1.1,2.1,0) else { args.plotTree$mar[4]<-0 } if(args.plotTree$mar[1]!=args.boxplot$mar[1]) args.plotTree$mar[1]<-args.boxplot$mar[1] if(args.plotTree$mar[3]!=args.boxplot$mar[3]) args.plotTree$mar[3]<-args.boxplot$mar[3] if(is.null(args.plotTree$ftype)) args.plotTree$ftype<-"i" if(is.null(args.plotTree$lwd)) args.plotTree$lwd<-1 par(mfrow=c(1,2)) ii<-which(names(args.boxplot)%in%c("formula","x")) args.boxplot<-c(args.boxplot[ii],args.boxplot[-ii]) args.boxplot$plot<-FALSE obj<-do.call(boxplot,args.boxplot) N<-ncol(obj$stats) if(hasArg(ylim)) ylim<-list(...)$ylim else ylim<-c(0.5,N+0.5) args.boxplot$xlim<-ylim args.boxplot$plot<-TRUE args.plotTree$tips<-setNames(1:Ntip(cw),obj$names) args.plotTree$ylim<-ylim do.call(plotTree,args.plotTree) par(mar=args.boxplot$mar) ii<-which(names(args.boxplot)%in%c("formula","x")) args.boxplot<-c(args.boxplot[ii],args.boxplot[-ii]) obj<-do.call(boxplot,args.boxplot) axis(1) if(!is.null(args.boxplot$xlab)) title(xlab=args.boxplot$xlab) else title(xlab="x") invisible(obj) } ## plotTree.barplot ## written by Liam J. Revell 2016, 2017, 2018, 2021 plotTree.barplot<-function(tree,x,args.plotTree=list(), args.barplot=list(),...){ tree<-untangle(tree,"read.tree") if(hasArg(add)) add<-list(...)$add else add<-FALSE if(hasArg(args.axis)) args.axis<-list(...)$args.axis else args.axis<-list() args.axis$side<-1 cw<-reorder(tree) if(is.data.frame(x)) x<-as.matrix(x) if(is.matrix(x)){ x<-x[cw$tip.label,] x<-t(x) } args.barplot$height<-if(is.matrix(x)) x[,cw$tip.label] else x[cw$tip.label] args.barplot$plot<-FALSE args.barplot$horiz<-TRUE args.barplot$axes<-FALSE args.barplot$names.arg<-rep("",Ntip(cw)) if(is.null(args.barplot$beside)) args.barplot$beside<-FALSE if(is.null(args.barplot$space)) args.barplot$space<-if(args.barplot$beside) c(0,1) else 0.7 if(is.null(args.barplot$mar)) args.barplot$mar<-c(5.1,0,2.1,1.1) else args.barplot$mar[2]<-0.1 obj<-as.matrix(do.call(barplot,args.barplot)) if(hasArg(ylim)) ylim<-list(...)$ylim else ylim<-c(min(obj)-mean(args.barplot$space), max(obj)+mean(args.barplot$space)) if(dim(obj)[2]==1) obj<-t(obj) args.plotTree$tips<-setNames(colMeans(obj),cw$tip.label) args.barplot$plot<-TRUE args.barplot$ylim<-ylim args.plotTree$ylim<-ylim args.plotTree$tree<-cw if(is.null(args.plotTree$mar)) args.plotTree$mar<-c(5.1,1.1,2.1,0) else { args.plotTree$mar[4]<-0.1 } if(args.plotTree$mar[1]!=args.barplot$mar[1]) args.plotTree$mar[1]<-args.barplot$mar[1] if(args.plotTree$mar[3]!=args.barplot$mar[3]) args.plotTree$mar[3]<-args.barplot$mar[3] if(is.null(args.plotTree$ftype)) args.plotTree$ftype<-"i" if(is.null(args.plotTree$lwd)) args.plotTree$lwd<-1 if(!add) par(mfrow=c(1,2)) do.call(plotTree,args.plotTree) if(!is.null(args.plotTree$plot)&&args.plotTree$plot==FALSE) par(new=TRUE) par(mar=args.barplot$mar) obj<-do.call(barplot,args.barplot) if(!is.null(args.barplot$xlab)) args.axis$xlab<-args.barplot$xlab else args.axis$xlab<-"x" do.call(axis,args.axis) invisible(obj) } ## function to plot bars at the tips of a plotted tree ## written by Liam J. Revell 2014, 2015, 2018, 2019 plotTree.wBars<-function(tree,x,scale=NULL,width=NULL,type="phylogram", method="plotTree",tip.labels=FALSE,col="grey",border=NULL,...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(is.null(scale)){ scale<-0.3*max(nodeHeights(tree))/diff(range(x)) } if(is.matrix(x)){ x.neg<-apply(x,1,function(x) sum(x[x<0])) x.pos<-apply(x,1,function(x) sum(x[x>0])) } else { d<-scale*(max(x)-min(0,min(x))) H<-nodeHeights(tree) if(tip.labels==FALSE){ lims<-c(-max(H)-d,max(H)+d) sw<-0 } else { if(hasArg(fsize)) fsize<-list(...)$fsize else fsize<-1 if(type=="phylogram"){ pp<-par("pin")[1] sw<-fsize*(max(strwidth(tree$tip.label, units="inches")))+1.37*fsize*strwidth("W", units="inches") alp<-optimize(function(a,H,sw,pp,d) (a*1.04*(max(H)+d)+sw-pp)^2,H=H,sw=sw, pp=pp,d=d,interval=c(0,1e6))$minimum lims<-c(min(H),max(H)+d+sw/alp) } else if(type=="fan"){ pp<-par("pin")[1] sw<-fsize*(max(strwidth(tree$tip.label, units="inches")))+1.37*fsize*strwidth("W", units="inches") alp<-optimize(function(a,H,sw,pp,d) (a*2*1.04*(max(H)+d)+2*sw-pp)^2,H=H,sw=sw,pp=pp, d=d,interval=c(0,1e6))$minimum lims<-c(-max(H)-d-sw/alp,max(H)+d+sw/alp) } } if(hasArg(lims)) lims<-list(...)$lims um<-tree if(!is.ultrametric(um)){ tip.h<-sapply(1:Ntip(tree),nodeheight,tree=tree) for(i in 1:Ntip(tree)){ ii<-which(um$edge[,2]==i) um$edge.length[ii]<-um$edge.length[ii]+(max(tip.h)-tip.h[i]) } } if(type=="phylogram"){ fg<-par()$fg if(!is.ultrametric(tree)){ plotTree(um,ftype=if(tip.labels) "i" else "off", xlim=c(0,lims[2]),lwd=1,color="transparent",...) for(i in 1:Ntip(tree)) lines(c(max(tip.h), tip.h[i]),rep(i,2),lty="dotted") add<-TRUE par(fg="transparent") } else add=FALSE if(method=="plotTree") capture.output(plotTree(tree, ftype=if(tip.labels) "i" else "off",xlim=c(0,lims[2]), add=add,...)) else if(method=="plotSimmap") capture.output(plotSimmap(tree, ftype=if(tip.labels) "i" else "off",xlim=c(0,lims[2]),add=add,...)) par(fg=fg) } else if(type=="fan"){ fg<-par()$fg if(!is.ultrametric(tree)){ plotTree(um,type="fan",ftype=if(tip.labels) "i" else "off",xlim=lims,ylim=lims, lwd=1,color="transparent",...) um<-get("last_plot.phylo",envir=.PlotPhyloEnv) par(fg="transparent") plotTree(tree,type="fan",ftype=if(tip.labels) "i" else "off",xlim=lims, ylim=lims,lwd=1,color="transparent",add=TRUE,...) tt<-get("last_plot.phylo",envir=.PlotPhyloEnv) par(fg="black",lty="solid") for(i in 1:Ntip(tree)) lines(c(um$xx[i],tt$xx[i]),c(um$yy[i],tt$yy[i]),lty="dotted") par(fg="transparent") add<-TRUE } else add<-FALSE if(method=="plotTree") capture.output(plotTree(tree,type="fan", ftype=if(tip.labels) "i" else "off",xlim=lims,ylim=lims,add=add,...)) else if(method=="plotSimmap") capture.output(plotSimmap(tree, type="fan",ftype=if(tip.labels) "i" else "off",xlim=lims, ylim=lims,add=add,...)) par(fg=fg) } obj<-get("last_plot.phylo",envir=.PlotPhyloEnv) x<-x[tree$tip.label]*scale if(is.null(width)) width<-if(type=="fan") (par()$usr[4]-par()$usr[3])/(max(c(max(x)/max(nodeHeights(tree)),1))*length(tree$tip.label)) else if(type=="phylogram") (par()$usr[4]-par()$usr[3])/(2*length(tree$tip.label)) w<-width if(length(col)0) 1 else -1 dx<-s*h*cos(theta)+s*cos(theta)*sw dy<-s*h*sin(theta)+s*sin(theta)*sw x1<-dx+(w/2)*cos(pi/2-theta)-s*min(0,min(x))*cos(theta) y1<-dy-(w/2)*sin(pi/2-theta)-s*min(0,min(x))*sin(theta) x2<-dx-(w/2)*cos(pi/2-theta)-s*min(0,min(x))*cos(theta) y2<-dy+(w/2)*sin(pi/2-theta)-s*min(0,min(x))*sin(theta) x3<-s*x[i]*cos(theta)+x2 y3<-s*x[i]*sin(theta)+y2 x4<-s*x[i]*cos(theta)+x1 y4<-s*x[i]*sin(theta)+y1 polygon(c(x1,x2,x3,x4),c(y1,y2,y3,y4),col=col[i], border=border) } } } invisible(obj) } phytools/R/ratebystate.R0000644000176200001440000000616714546657015015035 0ustar liggesusers## simulation based test for a correlation between the state of x & the rate of y ## written by Liam J. Revell 2013, 2017, 2019, 2021 ratebystate<-function(tree,x,y,nsim=100,corr=c("pearson","spearman"),...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") corr<-corr[1] if(hasArg(sim.method)) sim.method<-list(...)$sim.method else sim.method<-"sim.corrs" if(hasArg(method)) method<-list(...)$method else method<-"by.node" if(hasArg(message)) message<-list(...)$message else message<-TRUE if(hasArg(logarithm)) logarithm<-list(...)$logarithm else logarithm<-FALSE if(!is.binary(tree)) tree<-multi2di(tree,random=FALSE) V<-phyl.vcv(cbind(x[tree$tip.label],y[tree$tip.label]),vcv(tree),lambda=1)$R if(method=="by.branch"){ aa<-c(x[tree$tip.label],fastAnc(tree,x)) names(aa)[1:length(tree$tip)]<-1:length(tree$tip) aa<-rowMeans(matrix(aa[tree$edge],nrow(tree$edge),2)) a<-vector() for(i in 1:tree$Nnode+length(tree$tip)){ j<-which(tree$edge[,1]==i) a[i-length(tree$tip)]<-sum(aa[j]*tree$edge.length[j])/sum(tree$edge.length[j]) } names(a)<-1:tree$Nnode+length(tree$tip) } else a<-fastAnc(tree,x) if(logarithm) a<-exp(a) b<-pic(y,tree)[names(a)]^2 r<-cor(a,b,method=corr) beta<-setNames(lm(b~a)$coefficients[2],NULL) foo<-function(tree,V){ if(sim.method=="fastBM") XY<-fastBM(tree,nsim=2)%*%sqrt(diag(diag(V))) else if(sim.method=="sim.corrs") XY<-sim.corrs(tree,V) a<-fastAnc(tree,XY[,1]) b<-pic(XY[,2],tree)[names(a)]^2 r<-cor(a,b,method=corr) return(r) } r.null<-c(r,replicate(nsim-1,foo(tree,V))) P<-mean(abs(r.null)>=abs(r)) obj<-list(beta=beta,r=r,P=P,corr=corr,method=method) class(obj)<-"ratebystate" obj } # function simulates rate by state evolution for x & y # written by Liam J. Revell 2013 sim.ratebystate<-function(tree,sig2x=1,sig2y=1,beta=c(0,1),...){ if(hasArg(method)) method<-list(...)$method else method<-"by.node" if(hasArg(plot)) plot<-list(...)$plot else plot<-FALSE if(hasArg(logarithm)) logarithm<-list(...)$logarithm else logarithm<-FALSE x<-fastBM(tree,a=if(logarithm) beta[1] else 0,sig2=sig2x,internal=TRUE) if(method=="by.node") ss<-x[1:tree$Nnode+length(tree$tip.label)] else if(method=="by.branch") ss<-rowMeans(matrix(x[tree$edge],nrow(tree$edge),2)) zz<-tree if(!logarithm) zz$edge.length<-beta[2]*zz$edge.length*(beta[1]+ss-min(ss)) else zz$edge.length<-beta[2]*zz$edge.length*exp(ss) y<-fastBM(zz,sig2=sig2y) if(plot) phenogram(zz,x,type="b",colors="blue",ftype="off", xlab="expected variance",ylab="independent variable (x)") x<-x[tree$tip.label] return(cbind(x,y)) } ## S3 print method print.ratebystate<-function(x,digits=6,...){ cat("\nObject of class \"ratebystate\".\n") cat("\nSummary of object:\n") cat(paste(" beta[1] = ",round(x$beta,digits),"\n",sep="")) cat(paste(" ",if(x$corr=="pearson") "Pearson " else "Spearman ","correlation (r) = ",round(x$r,digits), "\n",sep="")) cat(paste(" P-value (from simulation) = ",round(x$P,digits), "\n\n",sep="")) cat(paste("Analysis was conducted using \"",x$method, "\" method.\n\n",sep="")) } phytools/R/fitgammaMk.R0000644000176200001440000003272314546010441014542 0ustar liggesusers## fit model in which the edge rates are distributed according to a ## discretized gamma distribution with shape parameter alpha plot.fitgammaMk<-function(x,...){ if(hasArg(digits)) digits<-list(...)$digits else digits<-3 if(hasArg(colors)) colors<-list(...)$colors else colors<-c("yellow","red") if(is.null(x$marginal)){ stop("missing marginal likelihoods.") } else { r<-qgamma(seq(1/(2*x$nrates),1,by=1/x$nrates),x$alpha,x$alpha) r<-r/mean(r) Rates<-log(apply(x$marginal,1,function(x,y) sum(x*y),y=r)) cols<-setNames(colorRampPalette(colors)(101), 0:100) args<-list(...) if(is.null(args$type)) args$type<-"phylogram" if(is.null(args$direction)) args$direction<-"rightwards" if(is.null(args$fsize)){ if(args$type%in%c("phylogram","cladogram")){ if(args$direction%in%c("rightwards","leftwards")) args$fsize<-min(c(6*par()$pin[2]/Ntip(x$tree),1)) else args$fsize<-min(c(6*par()$pin[1]/Ntip(x$tree),1)) } else { args$fsize<-min(c(0.6*min(par()$pin)/sqrt(Ntip(x$tree)),1)) } } args$plot<-FALSE args$tree<-x$tree nulo<-do.call(plotTree,args) pp<-get("last_plot.phylo",envir=.PlotPhyloEnv) ss<-round((Rates-min(Rates))/diff(range(Rates))*100) tt<-paintBranches(x$tree,edge=x$tree$edge[1,2],state=ss[1]) for(j in 2:length(ss)) tt<-paintBranches(tt,edge=x$tree$edge[j,2], state=ss[j]) args$plot<-TRUE args$colors<-cols args$xlim<-c(-0.3*pp$x.lim[2],pp$x.lim[2]) args$ylim<-pp$y.lim args$add<-TRUE args$split.vertical<-TRUE args$tree<-tt nulo<-do.call(plotSimmap,args) pp<-get("last_plot.phylo",envir=.PlotPhyloEnv) h<-max(nodeHeights(x$tree)) LWD<-diff(par()$usr[1:2])/dev.size("px")[1] Nt<-Ntip(x$tree) lines(x=rep(-0.25*h+LWD*15/2,2),y=c(1+1/40*Nt,Nt-1/40*Nt)) nticks<-10 Y<-cbind(seq(1+1/40*Nt,Nt-1/40*Nt,length.out=nticks), seq(1+1/40*Nt,Nt-1/40*Nt,length.out=nticks)) X<-cbind(rep(-0.25*h+LWD*15/2,nticks), rep(-0.25*h+LWD*15/2+0.02*h,nticks)) for(i in 1:nrow(Y)) lines(X[i,],Y[i,]) add.color.bar(Nt-2/40*Nt-1,cols, title="relative edge rate", lims=NULL,digits=3, direction="upwards", subtitle="",lwd=15, x=-0.25*h, y=1+1/40*Nt,prompt=FALSE) ticks<-exp(seq(min(Rates),max(Rates),length.out=10)) text(x=X[,2],y=Y[,2],signif(ticks,digits),pos=4,cex=0.7) invisible(exp(Rates)) } } as.Qmatrix.fitgammaMk<-function(x,...) as.Qmatrix.fitMk(x,...) anova.fitgammaMk<-function(object,...) anova.fitMk(object,...) logLik.fitgammaMk<-function(object,...){ lik<-object$logLik attr(lik,"df")<-length(object$rates)+1 lik } gamma_pruning<-function(par,nrates=4,tree,x,model=NULL,median=TRUE,...){ if(hasArg(fn_min)) fn_min<-list(...)$fn_min else fn_min<--Inf if(hasArg(marginal)) marginal<-list(...)$marginal else marginal<-FALSE if(marginal){ if(hasArg(edge)) edge<-list(...)$edge else marginal<-FALSE if(hasArg(rate)) rate<-list(...)$rate else marginal<-FALSE } q<-par[1:(length(par)-1)] alpha<-par[length(par)] if(median){ r<-qgamma(seq(1/(2*nrates),1,by=1/nrates),alpha,alpha) r<-r/mean(r) } else { cat("This does not work yet.\n") } if(hasArg(return)) return<-list(...)$return else return<-"likelihood" pw<-if(!is.null(attr(tree,"order"))&& attr(tree,"order")=="postorder") tree else reorder(tree,"postorder") k<-ncol(x) if(is.null(model)){ model<-matrix(1,k,k) diag(model)<-0 } if(hasArg(pi)) pi<-list(...)$pi else pi<-rep(1/k,k) Q<-matrix(0,k,k) Q[]<-c(0,q)[model+1] diag(Q)<--rowSums(Q) L<-rbind(x[pw$tip.label,], matrix(0,pw$Nnode,k, dimnames=list(1:pw$Nnode+Ntip(pw)))) nn<-unique(pw$edge[,1]) pp<-vector(mode="numeric",length=length(nn)) root<-min(nn) for(i in 1:length(nn)){ ee<-which(pw$edge[,1]==nn[i]) PP<-matrix(NA,length(ee),k) for(j in 1:length(ee)){ if(marginal){ if(pw$edge[ee[j],2]==edge){ ind<-rate } else ind<-1:nrates } else ind<-1:nrates P<-Reduce("+",lapply(r[ind], function(rr,nr,Q,edge) expm(Q*rr*edge)/nr, nr=nrates,Q=Q,edge=pw$edge.length[ee[j]])) PP[j,]<-P%*%L[pw$edge[ee[j],2],] } L[nn[i],]<-apply(PP,2,prod) if(nn[i]==root){ if(pi[1]=="fitzjohn") pi<-L[nn[i],]/sum(L[nn[i],]) L[nn[i],]<-pi*L[nn[i],] } pp[i]<-sum(L[nn[i],]) L[nn[i],]<-L[nn[i],]/pp[i] } prob<-sum(log(pp)) if(return=="likelihood") if(is.na(prob)||is.nan(prob)) return(fn_min) else return(prob) else if(return=="conditional") L else if(return=="pi") pi } fitgammaMk<-function(tree,x,model="ER",fixedQ=NULL,nrates=8,...){ median<-TRUE if(hasArg(fn_min)) fn_min<-list(...)$fn_min else fn_min<--Inf if(hasArg(marginal)) marginal<-list(...)$marginal else marginal<-FALSE if(hasArg(parallel)) parallel<-list(...)$parallel else parallel<-TRUE if(hasArg(opt.method)) opt.method<-list(...)$opt.method else opt.method<-"nlminb" if(hasArg(output.liks)) output.liks<-list(...)$output.liks else output.liks<-FALSE if(hasArg(smart_start)) smart_start<-list(...)$smart_start else smart_start<-FALSE if(hasArg(q.init)) q.init<-list(...)$q.init else q.init<-length(unique(x))/sum(tree$edge.length) if(hasArg(alpha.init)) alpha.init<-list(...)$alpha.init else alpha.init<-1.0 if(hasArg(rand_start)) rand_start<-list(...)$rand_start else rand_start<-FALSE if(hasArg(min.q)) min.q<-list(...)$min.q else min.q<-1e-12 if(hasArg(max.q)) max.q<-list(...)$max.q else max.q<-max(nodeHeights(tree))*100 if(hasArg(min.alpha)) min.alpha<-list(...)$min.alpha else min.alpha<-0.1 if(hasArg(max.alpha)) max.alpha<-list(...)$max.alpha else max.alpha<-1000 if(hasArg(logscale)) logscale<-list(...)$logscale else logscale<-TRUE N<-Ntip(tree) M<-tree$Nnode if(is.matrix(x)){ x<-x[tree$tip.label,] m<-ncol(x) states<-colnames(x) } else { x<-to.matrix(x,sort(unique(x))) x<-x[tree$tip.label,] m<-ncol(x) states<-colnames(x) } if(hasArg(pi)) pi<-list(...)$pi else pi<-"equal" if(is.numeric(pi)) root.prior<-"given" if(pi[1]=="equal"){ pi<-setNames(rep(1/m,m),states) root.prior<-"flat" } else if(pi[1]=="estimated"){ pi<-if(!is.null(fixedQ)) statdist(fixedQ) else statdist(summary(fitMk(tree,x,model),quiet=TRUE)$Q) cat(paste("Using pi estimated from the stationary", "distribution of Q assuming a flat prior.\npi =\n")) print(round(pi,6)) cat("\n") root.prior<-"stationary" } else if(pi[1]=="fitzjohn") root.prior<-"nuisance" if(is.numeric(pi)){ pi<-pi/sum(pi) if(is.null(names(pi))) pi<-setNames(pi,states) pi<-pi[states] } if(is.null(fixedQ)){ if(is.character(model)){ rate<-matrix(NA,m,m) if(model=="ER"){ k<-rate[]<-1 diag(rate)<-NA } else if(model=="ARD"){ k<-m*(m-1) rate[col(rate)!=row(rate)]<-1:k } else if(model=="SYM"){ k<-m*(m-1)/2 ii<-col(rate)1){ MM<-index.matrix MM[is.na(MM)]<-0 MM[MM>0]<-1 q.init<-fitMk(pw,x,model=MM,pi=pi,opt.method="nlminb")$rates } if(length(q.init)!=k) q.init<-rep(q.init[1],k) if(rand_start){ q.init<-q.init*rexp(length(q.init),1) alpha.init<-alpha.init*rexp(1) } q.init<-if(logscale) log(q.init) else q.init alpha.init<-if(logscale) log(alpha.init) else alpha.init if(opt.method=="optim"){ fit<-if(logscale) optim(c(q.init,alpha.init),function(p) -gamma_pruning(exp(p),nrates=nrates,tree=pw,x=x,model=MODEL, median=TRUE,pi=pi,fn_min=fn_min),method="L-BFGS-B", lower=c(rep(log(min.q),k),log(min.alpha)), upper=c(rep(log(max.q),k),log(max.alpha))) else optim(c(q.init,alpha.init),function(p) -gamma_pruning(p,nrates=nrates, tree=pw,x=x,model=MODEL,median=TRUE,pi=pi,fn_min=fn_min), method="L-BFGS-B",lower=c(rep(min.q,k),min.alpha), upper=c(rep(max.q,k),max.alpha)) } else if(opt.method=="none"){ fit<-list(objective=-gamma_pruning(c(q.init,alpha.init), nrates=nrates,pw,x,MODEL,median=TRUE,pi=pi),par=q.init) } else { fit<-if(logscale) nlminb(c(q.init,alpha.init),function(p) -gamma_pruning(exp(p), nrates=nrates,tree=pw,x=x,model=MODEL,median=TRUE,pi=pi, fn_min=fn_min),lower=c(rep(log(min.q),k),log(min.alpha)), upper=c(rep(log(max.q),k),log(max.alpha))) else nlminb(c(q.init,alpha.init),function(p) -gamma_pruning(p, nrates=nrates,tree=pw,x=x,model=MODEL,median=TRUE,pi=pi, fn_min=fn_min),lower=c(rep(min.q,k),min.alpha), upper=c(rep(max.q,k),max.alpha)) } if(logscale) fit$par<-exp(fit$par) if(pi[1]=="fitzjohn") pi<-setNames( gamma_pruning(fit$par,nrates=nrates,tree=tree,x=x,model=MODEL, median=TRUE,pi=pi,return="pi"),states) obj<-list(logLik= if(opt.method=="optim") -fit$value else -fit$objective, rates=fit$par[1:(length(fit$par)-1)], index.matrix=index.matrix, states=states, pi=pi, method=opt.method, root.prior=root.prior, nrates=nrates, alpha=fit$par[length(fit$par)]) if(opt.method=="nlminb") obj$opt_results<-fit[c("convergence","iterations","evaluations","message")] else if(opt.method=="optim") obj$opt_results<-fit[c("counts","convergence","message")] if(output.liks) obj$lik.anc<-gamma_pruning(fit$par,nrates=nrates, tree=tree,x=x,model=MODEL,median=TRUE,pi=pi,return="conditional") } else { fit<-gamma_pruning(c(Q[sapply(1:k,function(x,y) which(x==y), index.matrix)],alpha.init),nrates=nrates,tree=tree,x=x,model=MODEL, median=TRUE,pi=pi) if(pi[1]=="fitzjohn") pi<-setNames(gamma_pruning( c(Q[sapply(1:k,function(x,y) which(x==y),index.matrix)],alpha.init), nrates=nrates,tree=tree,x=x,model=MODEL,median=TRUE,pi=pi, return="pi"),states) obj<-list(logLik=fit, rates=Q[sapply(1:k,function(x,y) which(x==y),index.matrix)], index.matrix=index.matrix, states=states, pi=pi, root.prior=root.prior, nrates=nrates, alpha=alpha.init) if(output.liks) obj$lik.anc<-gamma_pruning( c(Q[sapply(1:k,function(x,y) which(x==y),index.matrix)],alpha.init), nrates=nrates,tree=tree,x=x,model=MODEL,median=TRUE,pi=pi, return="conditional") } if(marginal){ ## get marginal likelihoods of each rate on each edge cat(paste(" --\n Computing marginal scaled likelihoods", if(parallel) "(in parallel)" else "(in serial)", "of each\n")) cat(" rate on each edge. Caution: this is NOT fast....\n --\n") flush.console() if(median){ Rates<-qgamma(seq(1/(2*nrates),1,by=1/nrates),obj$alpha,obj$alpha) Rates<-Rates/mean(Rates) } else Rates<-1:nrates if(parallel){ ncores<-min(c(parallel::detectCores()-2,nrow(tree$edge))) mc<-makeCluster(ncores,type="PSOCK") registerDoParallel(cl=mc) tmpRATES<-foreach(i=1:nrow(tree$edge))%dopar%{ foo<-function(X) phytools::gamma_pruning( par=c(obj$rates,obj$alpha), nrates=nrates,tree=tree,x=x,model=MODEL,median=TRUE, pi=pi,marginal=TRUE,edge=tree$edge[i,2],rate=X) sapply(1:nrates,foo) } stopCluster(cl=mc) RATES<-t(sapply(tmpRATES,function(x) x)) dimnames(RATES)<-list(apply(tree$edge,1, function(x) paste(x[1],",",x[2],sep="")), round(Rates,6)) } else { RATES<-matrix(NA,nrow(tree$edge),nrates, dimnames=list(apply(tree$edge,1, function(x) paste(x[1],",",x[2],sep="")), round(Rates,6))) for(i in 1:nrow(RATES)){ for(j in 1:ncol(RATES)){ RATES[i,j]<-gamma_pruning(c(obj$rates,obj$alpha),nrates=nrates, tree=tree,x=x,model=MODEL,median=TRUE,pi=pi,marginal=TRUE, edge=tree$edge[i,2],rate=j) } } } RATES<-t(apply(RATES,1,function(x) exp(x)/sum(exp(x)))) } lik.f<-function(q,alpha){ q<-sapply(1:max(MODEL), function(ind,q,MODEL) q[which(MODEL==ind)], q=q,MODEL=MODEL) gamma_pruning(c(q,alpha),nrates=nrates,tree=pw,x=x,model=MODEL, pi=if(root.prior=="nuisance") "fitzjohn" else pi) } obj$data<-x obj$tree<-tree if(marginal) obj$marginal<-RATES obj$lik<-lik.f class(obj)<-"fitgammaMk" return(obj) } ## print method for objects of class "fitgammaMk" print.fitgammaMk<-function(x,digits=6,...){ cat("Object of class \"fitgammaMk\".\n\n") cat("Fitted (or set) value of Q:\n") Q<-matrix(NA,length(x$states),length(x$states)) Q[]<-c(0,x$rates)[x$index.matrix+1] diag(Q)<-0 diag(Q)<--rowSums(Q) colnames(Q)<-rownames(Q)<-x$states print(round(Q,digits)) cat(paste("\nFitted (or set) value of alpha rate heterogeneity\n(with", x$nrates,"rate categories):",round(x$alpha,digits))) cat("\n\nFitted (or set) value of pi:\n") print(round(x$pi,digits)) cat(paste("due to treating the root prior as (a) ",x$root.prior,".\n", sep="")) cat(paste("\nLog-likelihood:",round(x$logLik,digits),"\n")) cat(paste("\nOptimization method used was \"",x$method,"\"\n\n", sep="")) if(!is.null(x$opt_results$convergence)){ if(x$opt_results$convergence==0) cat("R thinks it has found the ML solution.\n\n") else cat("R thinks optimization may not have converged.\n\n") } } phytools/R/Dtest.R0000644000176200001440000000346714375517350013566 0ustar liggesusers## function to conduct the correlation test of Huelsenbeck et al. ## written by Liam J. Revell calcD<-function(t1,t2){ Do<-mapply(Map.Overlap,t1,t2,SIMPLIFY=FALSE) foo<-function(M){ m1<-rowSums(M) m2<-colSums(M) as.matrix(m1)%*%t(m2) } De<-lapply(Do,foo) Dij<-mapply("-",Do,De,SIMPLIFY=FALSE) D<-sapply(Dij,function(x) sum(abs(x))) E_DX<-mean(D) E_Dij<-Reduce("+",Dij)/length(t1) list(E_DX=E_DX,E_Dij=E_Dij) } Dtest<-function(t1,t2,nsim=100,...){ cat("Note that this function is provided without much testing.\n") cat("Please use with caution.\n\n") cat("Running. (This may take some time.)\n") levs1<-sort(unique(as.vector(getStates(t1,"tips")))) k1<-length(levs1) levs2<-sort(unique(as.vector(getStates(t2,"tips")))) k2<-length(levs2) nrep<-length(t1) obj<-calcD(t1,t2) E_DX<-obj$E_DX E_Dij<-obj$E_Dij ## posterior prediction PD<-0 Pdij<-matrix(0,k1,k2,dimnames=list(levs1,levs2)) cat("|") for(i in 1:nrep){ x<-to.matrix(sim.Mk(t1[[i]],t1[[i]]$Q),levs1) y<-to.matrix(sim.Mk(t2[[i]],t2[[i]]$Q),levs2) T1<-make.simmap(t1[[i]],x,nsim=nsim,message=FALSE,...) T2<-make.simmap(t2[[i]],y,nsim=nsim,message=FALSE,...) tmp<-calcD(T1,T2) PD<-PD+(tmp$E_DX>=E_DX)/nrep Pdij<-Pdij+(tmp$E_Dij>=E_Dij)/nrep cat(".") if(i%%10==0&&i!=nrep) cat("\n") dev.flush() } cat("|\nDone.\n") obj<-list("E(D|X)"=E_DX,"P(D)"=PD,"E(Dij)"=E_Dij, "P(Dij)"=Pdij) class(obj)<-"Dtest" obj } print.Dtest<-function(x,...){ if(hasArg(digits)) digits<-list(...)$digits else digits<-4 x<-lapply(x,function(a,b) if(is.numeric(a)) round(a,b) else a,b=digits) cat("Summary of results from D-test:\n") cat(paste(" E(D|X) = ",x$'E(D|X)',", P(D) = ",x$'P(D)',"\n",sep="")) cat("\n(Type ...$'E(Dij)' and ...$'P(Dij)' for\n pairwise E(D) and P-values.)\n") } phytools/R/compare.chronograms.R0000644000176200001440000000276114375517350016446 0ustar liggesusers## function to compare two time-trees ## written by Liam J. Revell 2017 compare.chronograms<-function(t1,t2,...){ if(hasArg(colors)) colors<-list(...)$colors else colors<-sapply(c("blue","red"),make.transparent,alpha=0.4) if(hasArg(arr.colors)) arr.colors<-list(...)$arr.colors else arr.colors<-sapply(c("blue","red"),make.transparent,alpha=0.7) h1<-sapply(1:Ntip(t1),nodeheight,tree=t1) h2<-sapply(1:Ntip(t2),nodeheight,tree=t2) plotTree(if(max(h1)>max(h2)) t1 else t2,plot=FALSE, mar=c(4.1,1.1,1.1,1.1),direction="leftwards") xlim<-get("last_plot.phylo",envir=.PlotPhyloEnv)$x.lim[2:1] par(fg="transparent",new=TRUE) plotTree(t1,color=colors[1],mar=c(4.1,1.1,1.1,1.1), xlim=xlim,direction="leftwards",lwd=3) T1<-get("last_plot.phylo",envir=.PlotPhyloEnv) par(fg="black") axis(1) par(fg="transparent") plotTree(t2,color=colors[2],mar=c(4.1,1.1,1.1,1.1), xlim=xlim,add=TRUE,direction="leftwards",ftype="off",lwd=3) T2<-get("last_plot.phylo",envir=.PlotPhyloEnv) par(fg="black") for(i in 1:t1$Nnode+Ntip(t1)){ arrows(T1$xx[i],T1$yy[i],T2$xx[i],T2$yy[i],lwd=2, col=if(T1$xx[i]>T2$xx[i]) arr.colors[2] else arr.colors[1], length=0.1) } h<-mapply(function(x,y) if(xmin(h)) 0.005*diff(xlim) else 0,min(h)), rep(T1$yy[i],2),lty="dotted") } phytools/R/splitplotTree.R0000644000176200001440000000740314375517350015347 0ustar liggesusers## functions to split a tree into two (or more) plots by different methods ## written by Liam J. Revell 2012, 2015 plotTree.splits<-function(tree,splits=NULL,file=NULL,fn=NULL,...){ if(is.null(fn)) fn<-function(){} ef<-0.037037037037 ## expansion factor if(!is.null(file)) pdf(file,width=8.5,height=11) if(is.null(splits)) splits<-(floor(0.5*Ntip(tree))+0.5)/Ntip(tree) if(hasArg(y.lim)) y.lim<-list(...)$y.lim else y.lim<-c(0,Ntip(tree)) S<-matrix(c(0,splits,splits,1+1/Ntip(tree)),length(splits)+1,2) S<-cbind(S[,1]+ef*(S[,2]-S[,1]),S[,2]-ef*(S[,2]-S[,1])) S<-S*diff(y.lim)+y.lim[1] for(i in nrow(S):1){ if(is.null(file)&&i=s) Y1<-Y[a,]; Y2<-Y[-a,] b<-(min(Y1)-max(Y2))/2 Y1<-Y1-s+1; Y2<-Y2 H1<-H[a,]; H2<-H[-a,] edge1<-cw$edge[a,]; edge2<-cw$edge[-a,] if(length(H1)==2){ H1<-matrix(H1,1,2); Y1<-matrix(Y1,1,2); edge1<-matrix(edge1,1,2) } if(length(H2)==2){ H2<-matrix(H2,1,2); Y2<-matrix(Y2,1,2); edge2<-matrix(edge2,1,2) } # label offset offset<-0.2*lwd/3+0.2/3 # open plot par(mar=c(0.1,0.1,0.1,0.1)) if(!new.window) layout(matrix(c(1,2),1,2)) # first half plot.new(); if(fsize*max(strwidth(cw$tip.label))<1.0){ k<-(1-fsize*max(strwidth(cw$tip.label)))/max(H) H<-k*H H1<-k*H1 H2<-k*H2 } else message("Font size too large to properly rescale tree to window.") plot.window(xlim=c(0,max(H)+fsize*max(strwidth(cw$tip.label))),ylim=c(1-b,max(rbind(Y1,Y2)))) for(i in 1:nrow(H1)) lines(H1[i,],Y1[i,],lwd=lwd,lend=2) nodes<-unique(edge1[,1]) for(i in 1:length(nodes)) lines(H1[which(edge1[,1]==nodes[i]),1],Y1[which(edge1[,1]==nodes[i]),1],lwd=lwd) for(i in 1:nrow(edge1)) if(edge1[i,1]%in%edge2[,1]) lines(c(H1[i,1],H1[i,1]),c(Y1[i,1],1-b),lwd=lwd,lend=2) tips<-edge1[edge1[,2]<=n,2] for(i in 1:length(tips)) if(ftype) text(H1[which(edge1[,2]==tips[i]),2],Y1[which(edge1[,2]==tips[i]),1],cw$tip.label[tips[i]],pos=4,cex=fsize,font=ftype,offset=offset) # second half if(new.window){ dev.new(); par(mar=c(0.1,0.1,0.1,0.1)) } plot.new() if(max(Y1)>max(Y2)) Y2<-Y2+max(Y1)-max(Y2) plot.window(xlim=c(0,max(H)+fsize*max(strwidth(cw$tip.label))),ylim=c(1,max(rbind(Y1,Y2)+b))) for(i in 1:nrow(H2)) lines(H2[i,],Y2[i,],lwd=lwd,lend=2) nodes<-unique(edge2[,1]) for(i in 1:length(nodes)) lines(H2[which(edge2[,1]==nodes[i]),1],Y2[which(edge2[,1]==nodes[i]),1],lwd=lwd) for(i in 1:nrow(edge2)) if(edge2[i,1]%in%edge1[,1]) lines(c(H2[i,1],H2[i,1]),c(Y2[i,1],max(Y2)+b),lwd=lwd,lend=2) tips<-edge2[edge2[,2]<=n,2] for(i in 1:length(tips)) if(ftype) text(H2[which(edge2[,2]==tips[i]),2],Y2[which(edge2[,2]==tips[i]),1],cw$tip.label[tips[i]],pos=4,cex=fsize,font=ftype,offset=offset) # reset margin and layout layout(1) par(mar=c(5,4,4,2)+0.1) } phytools/R/contMap.R0000644000176200001440000002635714426040447014102 0ustar liggesusers## function plots reconstructed values for ancestral characters along the edges of the tree ## written by Liam J. Revell 2012-2023 contMap<-function(tree,x,res=100,fsize=NULL,ftype=NULL,lwd=4,legend=NULL, lims=NULL,outline=TRUE,sig=3,type="phylogram",direction="rightwards", plot=TRUE,...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(hasArg(mar)) mar<-list(...)$mar else mar<-rep(0.3,4) if(hasArg(offset)) offset<-list(...)$offset else offset<-NULL if(hasArg(method)) method<-list(...)$method else method<-"fastAnc" if(hasArg(hold)) hold<-list(...)$hold else hold<-TRUE if(hasArg(leg.txt)) leg.txt<-list(...)$leg.txt else leg.txt<-"trait value" h<-max(nodeHeights(tree)) steps<-c(0:(res-1)/(res-1)*h,h+h/(res-1)) ## 0:res/res*(h+h/res) H<-nodeHeights(tree) if(method=="fastAnc") a<-fastAnc(tree,x) else if(method=="anc.ML") { fit<-anc.ML(tree,x) a<-fit$ace if(!is.null(fit$missing.x)) x<-c(x,fit$missing.x) } else if(method=="user"){ if(hasArg(anc.states)) anc.states<-list(...)$anc.states else { cat("No ancestral states have been provided. Using states estimated with fastAnc.\n\n") a<-fastAnc(tree,x) } if(length(anc.states)H[i,1]),which(stepsH[i,1]),which(steps=trans[length(trans)]) state<-names(trans)[length(trans)] else { i<-1 while(x>trans[i]){ state<-names(trans)[i] i<-i+1 } } state } ## S3 print method for objects of class "contMap" ## uses print.densityMap internally ## written by Liam J. Revell 2012, 2013, 2014, 2015, 2016, 2023 plot.contMap<-function(x,...){ if(inherits(x,"contMap")){ lims<-x$lims x<-list(tree=x$tree,cols=x$cols) class(x)<-"densityMap" } else stop("x should be an object of class \"contMap\"") H<-nodeHeights(x$tree) # get & set optional arguments if(hasArg(legend)) legend<-list(...)$legend else legend<-NULL if(hasArg(sig)) sig<-list(...)$sig else sig<-3 if(hasArg(fsize)) fsize<-list(...)$fsize else fsize<-NULL if(hasArg(ftype)) ftype<-list(...)$ftype else ftype<-NULL if(hasArg(type)) type<-list(...)$type else type<-"phylogram" if(hasArg(mar)) mar<-list(...)$mar else mar<-rep(0.3,4) if(hasArg(direction)) direction<-list(...)$direction else direction<-"rightwards" if(hasArg(offset)) offset<-list(...)$offset else offset<-NULL if(hasArg(xlim)) xlim<-list(...)$xlim else xlim<-NULL if(hasArg(ylim)) ylim<-list(...)$ylim else ylim<-NULL if(hasArg(leg.txt)) leg.txt<-list(...)$leg.txt else leg.txt<-"trait value" if(hasArg(underscore)) underscore<-list(...)$underscore else underscore<-FALSE if(hasArg(outline)) outline<-list(...)$outline else outline<-TRUE if(hasArg(nodes_only)) nodes_only<-list(...)$nodes_only else nodes_only<-FALSE if(hasArg(arc_height)) arc_height<-list(...)$arc_height else arc_height<-2 if(is.null(legend)) legend<-if(type=="arc") max(H) else 0.5*max(H) if(is.null(fsize)) fsize<-c(1,1) if(length(fsize)==1) fsize<-rep(fsize,2) if(is.null(ftype)) ftype<-c("i","reg") if(length(ftype)==1) ftype<-c(ftype,"reg") if(nodes_only){ if(hasArg(cex)) cex<-list(...)$cex else cex<-c(1.5,1) if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-c(1,4) obj<-x$tree N<-Ntip(obj) node.cols<-setNames(x$cols[ c(names(obj$maps[[which(obj$edge[1,]==(N+1))]][1]), sapply(obj$maps,function(x) names(x[length(x)])))], c(N+1,obj$edge[,2])) node.cols<-node.cols[as.character(1:(N+obj$Nnode))] if(legend&&is.null(ylim)&&type%in%c("phylogram","cladogram")){ if(direction%in%c("rightwards","leftwards")) ylim<-c(1-0.12*(N-1),N) else if(direction%in%c("upwards","downwards")) { pp<-par("pin")[2] sw<-(fsize*(max(strwidth(obj$tip.label,units="inches")))+ 1.37*fsize*strwidth("W",units="inches"))[1] alp<-optimize(function(a,H,sw,pp) (a*1.2*max(H)+sw-pp)^2,H=H,sw=sw,pp=pp, interval=c(0,1e6))$minimum ylim<-if(direction=="downwards") c(min(H)-sw/alp-0.16*max(H),max(H)) else c(min(H)-0.16*max(H),max(H)+sw/alp) } } else if(is.null(ylim)) ylim<-NULL if(is.null(offset)) { if(type%in%c("cladogram","phylogram")) offset<-0.2*lwd[1]/3+0.2/3 else if(type%in%c("fan","arc")) offset<-1 } args<-list(...) args$ylim<-ylim args$tree<-as.phylo(obj) args$offset<-offset args$fsize<-fsize[1] args$lwd<-lwd[1] args$arc_height<-arc_height do.call(plotTree,args) pp<-get("last_plot.phylo",envir=.PlotPhyloEnv) xx<-pp$xx yy<-pp$yy if(type%in%c("phylogram","cladogram")){ if(direction=="rightwards") xx[1:N]<-xx[1:N]+strwidth(paste(obj$tip.label,"__",sep=""),cex=fsize[1])+offset } DROP<-if(type=="arc") DROP<-Ntip(x$tree)+1 else DROP<-NULL points(xx[-DROP],yy[-DROP],pch=if(outline) 21 else 16, col=if(outline) par()$fg else node.cols[-DROP], bg=if(outline) node.cols[-DROP] else NULL, cex=c(rep(cex[2],N),rep(cex[1],obj$Nnode-length(DROP)))) if(legend){ if(is.logical(legend)) legend<-0.5*max(H) if(length(leg.txt)==1) leg.txt<-c(round(lims[1],sig),leg.txt,round(lims[2],sig)) if(type%in%c("phylogram","cladogram")){ if(direction%in%c("rightwards","leftwards")){ add.color.bar(legend,x$cols,title=leg.txt[2], as.numeric(leg.txt[c(1,3)]), digits=sig,prompt=FALSE, x=if(direction=="leftwards") max(H)-legend else 0, y=1-0.08*(N-1),lwd=lwd[2], fsize=fsize[2],outline=outline, direction=if(!is.null(xlim)) if(xlim[2]obj$lims[2]||xlim[1]1) X<- if(as.list) vector(mode="list",length=nsim) else data.frame(row.names=tt$tip.label) for(i in 1:nsim){ a<-if(is.null(anc)) sample(ss,1) else anc STATES<-matrix(NA,nrow(tt$edge),2) root<-Ntip(tt)+1 STATES[which(tt$edge[,1]==root),1]<-a for(j in 1:nrow(tt$edge)){ new<-ss[which(rmultinom(1,1,P[[j]][STATES[j,1],])[,1]==1)] STATES[j,2]<-new ii<-which(tt$edge[,1]==tt$edge[j,2]) if(length(ii)>0) STATES[ii,1]<-new } if(internal){ x<-as.factor(setNames(sapply(1:(Ntip(tt)+tt$Nnode), function(n,S,E) S[which(E==n)[1]],S=STATES,E=tt$edge), c(tt$tip.label,1:tt$Nnode+Ntip(tt)))) } else{ x<-as.factor( setNames(sapply(1:Ntip(tt),function(n,S,E) S[which(E==n)], S=STATES[,2],E=tt$edge[,2]),tt$tip.label)) } if(nsim>1) X[,i]<-x else X<-x } X } ## constant-rate Mk model simulator ## written by Liam J. Revell 2018, 2023 sim.Mk<-function(tree,Q,anc=NULL,nsim=1,...){ if(hasArg(as.list)) as.list<-list(...)$as.list else as.list<-FALSE if(hasArg(internal)) internal<-list(...)$internal else internal<-FALSE ss<-rownames(Q) tt<-reorder(tree) P<-vector(mode="list",length=nrow(tt$edge)) for(i in 1:nrow(tt$edge)) P[[i]]<-expm(Q*tt$edge.length[i]) if(nsim>1) X<- if(as.list) vector(mode="list",length=nsim) else data.frame(row.names=tt$tip.label) for(i in 1:nsim){ if(is.null(anc)) a<-sample(ss,1) else if(is.numeric(anc)) a<-sample(names(anc),1,prob=anc) else a<-anc STATES<-matrix(NA,nrow(tt$edge),2) root<-Ntip(tt)+1 STATES[which(tt$edge[,1]==root),1]<-a for(j in 1:nrow(tt$edge)){ new<-ss[which(rmultinom(1,1,P[[j]][STATES[j,1],])[,1]==1)] STATES[j,2]<-new ii<-which(tt$edge[,1]==tt$edge[j,2]) if(length(ii)>0) STATES[ii,1]<-new } if(internal){ x<-as.factor(setNames(sapply(1:(Ntip(tt)+tt$Nnode), function(n,S,E) S[which(E==n)[1]],S=STATES,E=tt$edge), c(tt$tip.label,1:tt$Nnode+Ntip(tt)))) } else{ x<-as.factor( setNames(sapply(1:Ntip(tt),function(n,S,E) S[which(E==n)], S=STATES[,2],E=tt$edge[,2]),tt$tip.label)) } if(nsim>1) X[[i]]<-x else X<-x } X } anova.fitMk<-function(object,...){ fits<-list(...) nm<-c( deparse(substitute(object)), if(length(fits)>0) sapply(substitute(list(...))[-1],deparse) ) logL<-c(logLik(object), if(length(fits)>0) sapply(fits,logLik)) df<-c(attr(logLik(object),"df"), if(length(fits)>0) sapply(fits,function(x) attr(logLik(x),"df"))) AICvals<-c(AIC(object), if(length(fits)>0) sapply(fits,AIC)) ww<-aic.w(AICvals) result<-data.frame(logL,df,AICvals,unclass(ww)) rownames(result)<-nm colnames(result)<-c("log(L)","d.f.","AIC","weight") models<-c(list(object),fits) attr(result,"models")<-models class(result)<-c(class(result),"anova.fitMk") print(result) invisible(result) } fitMk<-function(tree,x,model="SYM",fixedQ=NULL,...){ if(hasArg(opt.method)) opt.method<-list(...)$opt.method else opt.method<-"nlminb" if(hasArg(lik.func)) lik.func<-list(...)$lik.func else lik.func<-"lik" if(opt.method=="optimParallel"){ if(hasArg(ncores)) ncores<-list(...)$ncores else ncores<-detectCores() if(is.na(ncores)) ncores<-1 args<-list(...) args$tree<-tree args$x<-x args$model<-model args$ncores<-ncores obj<-do.call(fitMk.parallel,args) } else { if(hasArg(output.liks)) output.liks<-list(...)$output.liks else output.liks<-FALSE if(hasArg(smart_start)) smart_start<-list(...)$smart_start else smart_start<-FALSE if(hasArg(q.init)) q.init<-list(...)$q.init else q.init<-length(unique(x))/sum(tree$edge.length) if(hasArg(rand_start)) rand_start<-list(...)$rand_start else rand_start<-FALSE if(hasArg(min.q)) min.q<-list(...)$min.q else min.q<-1e-12 if(hasArg(max.q)) max.q<-list(...)$max.q else max.q<-max(nodeHeights(tree))*100 if(hasArg(logscale)) logscale<-list(...)$logscale else logscale<-FALSE N<-Ntip(tree) M<-tree$Nnode if(is.matrix(x)){ x<-x[tree$tip.label,] m<-ncol(x) states<-colnames(x) } else { x<-to.matrix(x,sort(unique(x))) x<-x[tree$tip.label,] m<-ncol(x) states<-colnames(x) } if(hasArg(pi)) pi<-list(...)$pi else pi<-"equal" if(is.numeric(pi)) root.prior<-"given" if(pi[1]=="equal"){ pi<-setNames(rep(1/m,m),states) root.prior<-"flat" } else if(pi[1]=="estimated"){ pi<-if(!is.null(fixedQ)) statdist(fixedQ) else statdist(summary(fitMk(tree,x,model),quiet=TRUE)$Q) cat(paste("Using pi estimated from the stationary", "distribution of Q assuming a flat prior.\npi =\n")) print(round(pi,6)) cat("\n") root.prior<-"stationary" } else if(pi[1]=="fitzjohn") root.prior<-"nuisance" if(is.numeric(pi)){ pi<-pi/sum(pi) if(is.null(names(pi))) pi<-setNames(pi,states) pi<-pi[states] } if(is.null(fixedQ)){ if(is.character(model)){ rate<-matrix(NA,m,m) if(model=="ER"){ k<-rate[]<-1 diag(rate)<-NA } else if(model=="ARD"){ k<-m*(m-1) rate[col(rate)!=row(rate)]<-1:k } else if(model=="SYM"){ k<-m*(m-1)/2 ii<-col(rate)1){ MM<-index.matrix MM[is.na(MM)]<-0 MM[MM>0]<-1 q.init<-fitMk(pw,x,model=MM,pi=pi,opt.method="nlminb")$rates } if(length(q.init)!=k) q.init<-rep(q.init[1],k) if(rand_start) q.init<-q.init*rexp(length(q.init),1) q.init<-if(logscale) log(q.init) else q.init if(opt.method=="optim"){ if(lik.func=="lik"){ fit<-if(logscale) optim(q.init,function(p) lik(makeQ(m,exp(p),index.matrix),pi=pi), method="L-BFGS-B",lower=rep(log(min.q),k),upper=rep(log(max.q),k)) else optim(q.init,function(p) lik(makeQ(m,p,index.matrix),pi=pi), method="L-BFGS-B",lower=rep(min.q,k),upper=rep(max.q,k)) } else if(lik.func=="pruning") { fit<-if(logscale) optim(q.init,function(p) -pruning(exp(p),tree=pw,x=x,model=MODEL,pi=pi), method="L-BFGS-B",lower=rep(log(min.q),k),upper=rep(log(max.q),k)) else optim(q.init,function(p) -pruning(p,tree=pw,x=x,model=MODEL,pi=pi), method="L-BFGS-B",lower=rep(min.q,k),upper=rep(max.q,k)) } } else if(opt.method=="none"){ if(lik.func=="lik") fit<-list(objective=lik(makeQ(m,q.init,index.matrix),pi=pi), par=q.init) else if(lik.func=="pruning") fit<-list(objective=-pruning(q.init,pw,x,MODEL,pi=pi),par=q.init) } else { if(lik.func=="lik"){ fit<-if(logscale) nlminb(q.init,function(p) lik(makeQ(m,exp(p),index.matrix),pi=pi), lower=rep(log(min.q),k),upper=rep(log(max.q),k)) else nlminb(q.init,function(p) lik(makeQ(m,p,index.matrix), pi=pi),lower=rep(0,k),upper=rep(max.q,k)) } else if(lik.func=="pruning"){ fit<-if(logscale) nlminb(q.init,function(p) -pruning(exp(p),tree=pw,x=x,model=MODEL, pi=pi),lower=rep(log(min.q),k),upper=rep(log(max.q),k)) else nlminb(q.init,function(p) -pruning(p,tree=pw,x=x,model=MODEL, pi=pi),lower=rep(0,k),upper=rep(max.q,k)) } } if(logscale) fit$par<-exp(fit$par) if(pi[1]=="fitzjohn") pi<-setNames( lik(makeQ(m,fit$par,index.matrix),FALSE,pi=pi,output.pi=TRUE), states) obj<-list(logLik= if(opt.method=="optim") -fit$value else -fit$objective, rates=fit$par, index.matrix=index.matrix, states=states, pi=pi, method=opt.method, root.prior=root.prior) if(opt.method=="nlminb") obj$opt_results<-fit[c("convergence","iterations","evaluations","message")] else if(opt.method=="optim") obj$opt_results<-fit[c("counts","convergence","message")] if(output.liks) obj$lik.anc<-lik(makeQ(m,obj$rates,index.matrix),TRUE, pi=pi) } else { fit<-lik(Q,pi=pi) if(pi[1]=="fitzjohn") pi<-setNames(lik(Q,FALSE,pi=pi,output.pi=TRUE),states) obj<-list(logLik=-fit, rates=Q[sapply(1:k,function(x,y) which(x==y),index.matrix)], index.matrix=index.matrix, states=states, pi=pi, root.prior=root.prior) if(output.liks) obj$lik.anc<-lik(makeQ(m,obj$rates,index.matrix),TRUE, pi=pi) } if(lik.func=="lik") lik.f<-function(q) -lik(q,output.liks=FALSE, pi=if(root.prior=="nuisance") "fitzjohn" else pi) else if(lik.func=="pruning") { lik.f<-function(q){ q<-sapply(1:max(MODEL), function(ind,q,MODEL) q[which(MODEL==ind)], q=q,MODEL=MODEL) pruning(q,tree=pw,x=x,model=MODEL, pi=if(root.prior=="nuisance") "fitzjohn" else pi) } } obj$data<-x obj$tree<-tree obj$lik<-lik.f class(obj)<-"fitMk" } return(obj) } makeQ<-function(m,q,index.matrix){ Q<-matrix(0,m,m) Q[]<-c(0,q)[index.matrix+1] diag(Q)<-0 diag(Q)<--rowSums(Q) Q } ## print method for objects of class "fitMk" print.fitMk<-function(x,digits=6,...){ cat("Object of class \"fitMk\".\n\n") cat("Fitted (or set) value of Q:\n") Q<-matrix(NA,length(x$states),length(x$states)) Q[]<-c(0,x$rates)[x$index.matrix+1] diag(Q)<-0 diag(Q)<--rowSums(Q) colnames(Q)<-rownames(Q)<-x$states print(round(Q,digits)) cat("\nFitted (or set) value of pi:\n") print(round(x$pi,digits)) cat(paste("due to treating the root prior as (a) ",x$root.prior,".\n", sep="")) cat(paste("\nLog-likelihood:",round(x$logLik,digits),"\n")) cat(paste("\nOptimization method used was \"",x$method,"\"\n\n", sep="")) if(!is.null(x$opt_results$convergence)){ if(x$opt_results$convergence==0) cat("R thinks it has found the ML solution.\n\n") else cat("R thinks optimization may not have converged.\n\n") } } ## summary method for objects of class "fitMk" summary.fitMk<-function(object,...){ if(hasArg(digits)) digits<-list(...)$digits else digits<-6 if(hasArg(quiet)) quiet<-list(...)$quiet else quiet<-FALSE if(!quiet) cat("Fitted (or set) value of Q:\n") Q<-matrix(NA,length(object$states),length(object$states)) Q[]<-c(0,object$rates)[object$index.matrix+1] diag(Q)<-0 diag(Q)<--rowSums(Q) colnames(Q)<-rownames(Q)<-object$states if(!quiet) print(round(Q,digits)) if(!quiet) cat(paste("\nLog-likelihood:",round(object$logLik,digits),"\n\n")) invisible(list(Q=Q,logLik=object$logLik)) } ## logLik method for objects of class "fitMk" logLik.fitMk<-function(object,...){ lik<-object$logLik if(!is.null(object$index.matrix)) attr(lik,"df")<-max(object$index.matrix,na.rm=TRUE) else attr(lik,"df")<-length(object$rates) lik } ## S3 plot method for objects of class "fitMk" plot.fitMk<-function(x,...){ Q<-as.Qmatrix(x) plot(Q,...) } ## S3 plot method for "gfit" object from geiger::fitDiscrete plot.gfit<-function(x,...){ if("mkn"%in%class(x$lik)==FALSE){ stop("Sorry. No plot method presently available for objects of this type.") object<-NULL } else { chk<-.check.pkg("geiger") if(chk) object<-plot(as.Qmatrix(x),...) else { obj<-list() QQ<-.Qmatrix.from.gfit(x) obj$states<-colnames(QQ) m<-length(obj$states) obj$index.matrix<-matrix(NA,m,m) k<-m*(m-1) obj$index.matrix[col(obj$index.matrix)!=row(obj$index.matrix)]<-1:k obj$rates<-QQ[sapply(1:k,function(x,y) which(x==y),obj$index.matrix)] class(obj)<-"fitMk" object<-plot(obj,...) } } invisible(object) } MIN<-function(x,...) min(x[is.finite(x)],...) MAX<-function(x,...) max(x[is.finite(x)],...) RANGE<-function(x,...) range(x[is.finite(x)],...) ## S3 method for "Qmatrix" object class plot.Qmatrix<-function(x,...){ Q<-unclass(x) if(hasArg(asp)) asp<-list(...)$asp else asp<-1 if(hasArg(signif)) signif<-list(...)$signif else signif<-3 if(hasArg(main)) main<-list(...)$main else main<-NULL if(hasArg(cex.main)) cex.main<-list(...)$cex.main else cex.main<-1.2 if(hasArg(cex.traits)) cex.traits<-list(...)$cex.traits else cex.traits<-1 if(hasArg(cex.rates)) cex.rates<-list(...)$cex.rates else cex.rates<-0.6 if(hasArg(show.zeros)) show.zeros<-list(...)$show.zeros else show.zeros<-TRUE if(hasArg(tol)) tol<-list(...)$tol else tol<-1e-6 if(hasArg(mar)) mar<-list(...)$mar else mar<-c(1.1,1.1,3.1,1.1) if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-1 if(hasArg(umbral)) umbral<-list(...)$umbral else umbral<-FALSE if(hasArg(ncat)) ncat<-list(...)$ncat else ncat<-NULL if(hasArg(spacer)) spacer<-list(...)$spacer else spacer<-0.1 if(hasArg(color)) color<-list(...)$color else color<-FALSE if(hasArg(width)) width<-list(...)$width else width<-FALSE if(hasArg(text)) text<-list(...)$text else text<-TRUE if(hasArg(max.lwd)) max.lwd<-list(...)$max.lwd else max.lwd<-if(text) 5 else 8 if(hasArg(rotate)) rotate<-list(...)$rotate else rotate<-NULL if(hasArg(add)) add<-list(...)$add else add<-FALSE if(hasArg(xlim)) xlim<-list(...)$xlim else xlim<-NULL if(hasArg(ylim)) ylim<-list(...)$ylim else ylim<-NULL if(hasArg(offset)) offset<-list(...)$offset else offset<-0.02 if(hasArg(palette)) palette<-list(...)$palette else palette<-c("blue","purple","red") ## set all Qj){ dx<-v.x[j]-v.x[i] dy<-v.y[j]-v.y[i] slope<-abs(dy/dx) shift.x<-offset*sin(atan(dy/dx))*sign(j-i)*if(dy/dx>0) 1 else -1 shift.y<-offset*cos(atan(dy/dx))*sign(j-i)*if(dy/dx>0) -1 else 1 s<-c(v.x[i]+spacer*cos(atan(slope))*sign(dx)+ if(isSymmetric(Q)) 0 else shift.x, v.y[i]+spacer*sin(atan(slope))*sign(dy)+ if(isSymmetric(Q)) 0 else shift.y) e<-c(v.x[j]+spacer*cos(atan(slope))*sign(-dx)+ if(isSymmetric(Q)) 0 else shift.x, v.y[j]+spacer*sin(atan(slope))*sign(-dy)+ if(isSymmetric(Q)) 0 else shift.y) if(show.zeros||Q[i,j]>tol){ if(text){ if(abs(diff(c(i,j)))==1||abs(diff(c(i,j)))==(nstates-1)) text(mean(c(s[1],e[1]))+1.5*shift.x, mean(c(s[2],e[2]))+1.5*shift.y, round(Q[i,j],signif),cex=cex.rates, srt=atan(dy/dx)*180/pi) else text(mean(c(s[1],e[1]))+0.3*diff(c(s[1],e[1]))+ 1.5*shift.x, mean(c(s[2],e[2]))+0.3*diff(c(s[2],e[2]))+ 1.5*shift.y, round(Q[i,j],signif),cex=cex.rates, srt=atan(dy/dx)*180/pi) } arrows(s[1],s[2],e[1],e[2],length=0.05, code=if(isSymmetric(Q)) 3 else 2, lwd=if(lwd[i,j]==0) 1 else lwd[i,j], lty=if(lwd[i,j]==0) "dotted" else "solid", col=cols[i,j]) } } text(v.x,v.y,rownames(Q),cex=cex.traits, col=make.transparent(par("fg"),0.9)) if(color){ if(dq>tol){ h<-1.5 LWD<-diff(par()$usr[1:2])/dev.size("px")[1] lines(x=rep(0.93*xlim[1]+LWD*15/2,2),y=c(-h/2,h/2)) nticks<-6 Y<-cbind(seq(-h/2,h/2,length.out=nticks), seq(-h/2,h/2,length.out=nticks)) X<-cbind(rep(0.93*xlim[1]+LWD*15/2,nticks), rep(0.93*xlim[1]+LWD*15/2+0.02*h,nticks)) for(i in 1:nrow(Y)) lines(X[i,],Y[i,]) add.color.bar(h,sapply(seq(0,1,length.out=100),col_pal), title="evolutionary rate (q)", lims=NULL,digits=3, direction="upwards", subtitle="",lwd=15, x=0.93*xlim[1],y=-h/2,prompt=FALSE) QQ<-Q diag(QQ)<-0 text(x=X[,2],y=Y[,2],signif(exp(seq(MIN(log(QQ),na.rm=TRUE), MAX(log(QQ),na.rm=TRUE),length.out=6)),signif),pos=4,cex=0.7) } else { BLUE<-function(...) palette[1] h<-1.5 LWD<-diff(par()$usr[1:2])/dev.size("px")[1] lines(x=rep(0.93*xlim[1]+LWD*15/2,2),y=c(-h/2,h/2)) nticks<-6 Y<-cbind(seq(-h/2,h/2,length.out=nticks), seq(-h/2,h/2,length.out=nticks))[nticks,,drop=FALSE] X<-cbind(rep(0.93*xlim[1]+LWD*15/2,nticks), rep(0.93*xlim[1]+LWD*15/2+0.02*h,nticks))[nticks,,drop=FALSE] for(i in 1:nrow(Y)) lines(X[i,],Y[i,]) add.color.bar(h,sapply(seq(0,1,length.out=100),BLUE), title="evolutionary rate (q)", lims=NULL,digits=3, direction="upwards", subtitle="",lwd=15, x=0.93*xlim[1],y=-h/2,prompt=FALSE) QQ<-Q diag(QQ)<-0 text(x=X[,2],y=Y[,2],signif(exp(seq(MIN(log(QQ),na.rm=TRUE), MAX(log(QQ),na.rm=TRUE),length.out=1)),signif),pos=4,cex=0.7) } } object<-data.frame(states=rownames(Q),x=v.x,y=v.y) invisible(object) } ## wraps around expm ## written by Liam Revell 2011, 2017 EXPM<-function(x,...){ e_x<-if(isSymmetric(x)) matexpo(x) else expm(x,...) dimnames(e_x)<-dimnames(x) e_x } ## as.Qmatrix method as.Qmatrix<-function(x,...){ if(identical(class(x),"Qmatrix")) return(x) UseMethod("as.Qmatrix") } as.Qmatrix.default<-function(x, ...){ warning(paste( "as.Qmatrix does not know how to handle objects of class ", class(x),".")) } as.Qmatrix.matrix<-function(x, ...){ if(ncol(x)!=nrow(x)){ warning("\"matrix\" object does not appear to contain a valid Q matrix.\n") } else { diag(x)<--rowSums(x) class(x)<-"Qmatrix" return(x) } } as.Qmatrix.fitMk<-function(x,...){ Q<-matrix(NA,length(x$states),length(x$states)) Q[]<-c(0,x$rates)[x$index.matrix+1] rownames(Q)<-colnames(Q)<-x$states diag(Q)<--rowSums(Q,na.rm=TRUE) class(Q)<-"Qmatrix" Q } as.Qmatrix.ace<-function(x, ...){ if("index.matrix"%in%names(x)){ k<-nrow(x$index.matrix) Q<-matrix(NA,k,k) Q[]<-c(0,x$rates)[x$index.matrix+1] rownames(Q)<-colnames(Q)<-colnames(x$lik.anc) diag(Q)<--rowSums(Q,na.rm=TRUE) class(Q)<-"Qmatrix" return(Q) } else cat("\"ace\" object does not appear to contain a Q matrix.\n") } print.Qmatrix<-function(x,...){ cat("Estimated Q matrix:\n") print(unclass(x),...) } is.Qmatrix<-function(x) "Qmatrix" %in% class(x) phytools/R/dotTree.R0000644000176200001440000002155214437400246014076 0ustar liggesusers## function to plot a tree with dots/circles for a plotted phenotype ## written by Liam J. Revell 2016, 2017, 2018, 2023 dotTree<-function(tree,x,legend=TRUE,method="plotTree",standardize=FALSE,...){ if(is.data.frame(x)) x<-as.matrix(x) if(hasArg(data.type)) data.type<-list(...)$data.type else { ## try to detect type if(is.numeric(x)) data.type<-"continuous" else data.type<-"discrete" } if(data.type=="continuous"){ if(hasArg(colors)) colors<-list(...)$colors else colors<-"blue" dotTree.continuous(tree,x,colors[1],legend,method,standardize,...) } else if(data.type=="discrete"){ if(hasArg(colors)) colors<-list(...)$colors else { ss<-unique(as.vector(x)) colors<-setNames(palette()[1:length(ss)],ss) } dotTree.discrete(tree,x,colors,legend,method,...) } } dotTree.continuous<-function(tree,x,color,legend,method,standardize,...){ if(hasArg(border)) border<-list(...)$border else border<-par()$fg if(hasArg(cex.dot)) cex.dot<-list(...)$cex.dot else cex.dot<-1.0 if(is.data.frame(x)) x<-as.matrix(x) if(is.matrix(x)&&method=="plotTree"){ if(ncol(x)>1) method<-"phylogram" else x<-x[,1] } if(hasArg(fsize)) fsize<-list(...)$fsize else fsize<-c(1,0.8) if(length(fsize)==1) fsize<-rep(fsize,2) if(hasArg(x.space)) x.space<-list(...)$x.space else x.space<-0.1 if(hasArg(k)) k<-list(...)$k else k<-0.8 ## reorder tree tree<-reorder(tree,"cladewise") ## if standardize==TRUE if(standardize){ if(is.matrix(x)){ sd<-apply(x,2,function(x) sqrt(var(x))) x<-(x-matrix(rep(1,Ntip(tree)),Ntip(tree),1)%*%colMeans(x))/ (matrix(rep(1,Ntip(tree)),Ntip(tree),1)%*%sd) } else if(is.vector(x)) x<-(x-mean(x))/sqrt(var(x)) } ## in case any x<0 min.x<-min(x) max.x<-max(x) if(any(x<0)) x<-x-min(x) if(method=="plotTree"){ fsize<-fsize[1] x<-x[tree$tip.label] ## plot tree plotTree(tree,offset=1.7,ylim=c(-Ntip(tree)/25, Ntip(tree)),...) ## get last phylo plot parameters obj<-get("last_plot.phylo",envir=.PlotPhyloEnv) x.tip<-obj$xx[1:obj$Ntip] y.tip<-obj$yy[1:obj$Ntip] ## plot points rr<-(k*x/max(x)+x.space)/2*diff(par()$usr[1:2])/ diff(par()$usr[3:4]) if(k<=0.8&&any(rr>(strwidth("W")*fsize/2))) rr<-rr/max(rr)*strwidth("W")*fsize/2 nulo<-mapply(draw.circle,x=x.tip+1.2*strwidth("W"),y=y.tip, radius=cex.dot*rr,MoreArgs=list(nv=200,col=color,border=border)) ## add legend if(legend){ h<-dot.legend(x=par()$usr[1]+0.1*max(nodeHeights(tree)), y=0,min.x,max.x,Ntip=Ntip(tree), method="plotTree",...) if(standardize) text(h,0.1*(1+par()$usr[3]),"(SD units)",pos=4) } } else if(method=="phylogram"){ if(is.vector(x)) x<-as.matrix(x) x[]<-x[tree$tip.label,] if(hasArg(mar)) mar<-list(...)$mar else mar<-rep(0.1,4) if(hasArg(xlim)) xlim<-list(...)$xlim else xlim<-c(-0.5,0.55+x.space*ncol(x)+x.space/2) if(hasArg(labels)) labels<-list(...)$labels else labels<-FALSE if(hasArg(ylim)) ylim<-list(...)$ylim else ylim<-c(if(legend) -0.1 else 0,if(labels) 1.1 else 1) ## plot tree plot.new() par(mar=mar) plot.window(xlim=xlim,ylim=ylim) h<-phylogram(tree,...) ## get last phylo plot parameters obj<-get("last_plot.phylo",envir=.PlotPhyloEnv) x.tip<-rep(h,obj$Ntip) y.tip<-obj$yy[1:obj$Ntip] ## plot points rr<-(k*x/max(x)+x.space)/2*diff(par()$usr[1:2])/diff(par()$usr[3:4])/ (Ntip(tree)-1) if(k<=0.8&&any(rr>(strwidth("W")*fsize[1]/2))) rr<-rr/max(rr)*strwidth("W")*fsize[1]/2 for(i in 1:ncol(x)){ nulo<-mapply(draw.circle,x=x.tip+1.2*strwidth("W")+x.space*(i-1), y=y.tip,radius=cex.dot*rr[,i],MoreArgs=list(nv=200,col=color, border=border)) } ## add legend if(legend){ h<-dot.legend(x=-0.45,y=-0.04,min.x,max.x,Ntip=Ntip(tree), method="phylogram",...) if(standardize) text(h,-0.04,"(SD units)",pos=4) } if(labels){ text(x=seq(max(x.tip)+1.2*strwidth("W"), max(x.tip)+1.2*strwidth("W")+x.space*(ncol(x)-1),by=x.space), y=rep(1.02,ncol(x)),colnames(x),srt=70,adj=c(0,0.5),cex=fsize[2]) } } } dotTree.discrete<-function(tree,x,color,legend,method,...){ if(hasArg(border)) border<-list(...)$border else border<-par()$fg if(hasArg(cex.dot)) cex.dot<-list(...)$cex.dot else cex.dot<-1.0 if(is.data.frame(x)) x<-as.matrix(x) if(is.matrix(x)&&method=="plotTree"){ if(ncol(x)>1) method<-"phylogram" else x<-x[,1] } if(hasArg(fsize)) fsize<-list(...)$fsize else fsize<-c(1,0.8) if(length(fsize)==1) fsize<-rep(fsize,2) if(hasArg(x.space)) x.space<-list(...)$x.space else x.space<-0.1 ## reorder tree tree<-reorder(tree,"cladewise") if(method=="plotTree"){ x<-x[tree$tip.label] ## plot tree plotTree(tree,offset=1.7,ylim=c(-1/25*Ntip(tree), Ntip(tree)),...) ## get last phylo plot parameters obj<-get("last_plot.phylo",envir=.PlotPhyloEnv) x.tip<-obj$xx[1:obj$Ntip] y.tip<-obj$yy[1:obj$Ntip] ## plot points r<-min(0.8/2*diff(par()$usr[1:2])/diff(par()$usr[3:4]), strwidth("W")*fsize/2) nulo<-mapply(draw.circle,x=x.tip+1.2*strwidth("W"),y=y.tip, col=color[as.character(x)],MoreArgs=list(nv=200, radius=cex.dot*r,border=border)) if(legend){ add.simmap.legend(colors=color,prompt=FALSE, vertical=FALSE,shape="circle", x=par()$usr[1]+0.1*max(nodeHeights(tree)), y=-1/25*Ntip(tree),border=border) } } else if(method=="phylogram"){ if(is.vector(x)) x<-as.matrix(x) x[]<-x[tree$tip.label,] if(hasArg(mar)) mar<-list(...)$mar else mar<-rep(0.1,4) if(hasArg(xlim)) xlim<-list(...)$xlim else xlim<-c(-0.5,0.55+x.space*ncol(x)+x.space/2) if(hasArg(labels)) labels<-list(...)$labels else labels<-FALSE if(hasArg(ylim)) ylim<-list(...)$ylim else ylim<-c(if(legend) -0.1 else 0,if(labels) 1.1 else 1) ## plot tree plot.new() par(mar=mar) plot.window(xlim=xlim,ylim=ylim) h<-phylogram(tree,...) ## get last phylo plot parameters obj<-get("last_plot.phylo",envir=.PlotPhyloEnv) x.tip<-rep(h,obj$Ntip) y.tip<-obj$yy[1:obj$Ntip] ## plot points r<-min(0.8/2*diff(par()$usr[1:2])/diff(par()$usr[3:4])/(Ntip(tree)-1), strwidth("W")*fsize/2) for(i in 1:ncol(x)){ nulo<-mapply(draw.circle,x=x.tip+1.2*strwidth("W")+x.space*(i-1), y=y.tip,col=color[as.character(x[,i])],MoreArgs=list(nv=20, radius=cex.dot*r,border=border)) } ## add legend if(legend){ add.simmap.legend(colors=color,prompt=FALSE, vertical=FALSE,shape="circle",x=-0.45,y=-0.06, border=border) } if(labels){ text(x=seq(max(x.tip)+1.2*strwidth("W"), max(x.tip)+1.2*strwidth("W")+x.space*(ncol(x)-1),by=x.space), y=rep(1.02,ncol(x)),colnames(x),srt=70,adj=c(0,0.5),cex=fsize[2]) } } } ## dot legend ## written by Liam J. Revell 2016, 2023 dot.legend<-function(x,y,min,max,Ntip,length=5,prompt=FALSE, method="plotTree",...){ if(hasArg(border)) border<-list(...)$border else border<-par()$fg if(hasArg(cex.dot)) cex.dot<-list(...)$cex.dot else cex.dot<-1.0 if(hasArg(cex)) cex<-list(...)$cex else cex<-1 if(hasArg(fsize)) fsize<-list(...)$fsize else fsize<-1 if(hasArg(colors)) colors<-list(...)$colors else colors<-"blue" if(hasArg(leg.space)) leg.space<-list(...)$leg.space else leg.space<-0.2 if(hasArg(k)) k<-list(...)$k else k<-0.8 if(prompt){ obj<-locator(1) x<-obj$x y<-obj$y } if(method=="plotTree"){ text(x,y-0.5*(Ntip/25),round(min,2),pos=1,cex=cex) s<-(k*max(min,0)/min(max,max+min)+0.1)/2*diff(par()$usr[1:2])/ diff(par()$usr[3:4]) e<-(k+0.1)/2*diff(par()$usr[1:2])/diff(par()$usr[3:4]) rr<-seq(s,e,length.out=length) if(k<=0.8&&any(rr>(strwidth("W")*fsize/2))) rr<-rr/max(rr)*strwidth("W")*fsize/2 temp<-c(0,cumsum((1+leg.space)*rep(2*max(rr),length-1))) nulo<-mapply(draw.circle,x=x+temp,y=rep(y,length),radius=cex.dot*rr, MoreArgs=list(nv=200,col=colors,border=border)) text(max(x+temp),y-0.5*(Ntip/25),round(max,2),pos=1,cex=cex) y1<-0.1/25*Ntip lines(c(x,max(x+temp)),rep(y-0.5*(Ntip/25)-y1,2)) lines(c(x,x),y-c(y1+0.5*(Ntip/25),2*y1+0.5*(Ntip/25))) lines(c(max(x+temp),max(x+temp)),y-c(y1+0.5*(Ntip/25),2*y1+0.5*(Ntip/25))) } else if(method=="phylogram"){ text(x,y-0.04,round(min,2),pos=1,cex=cex) s<-(k*max(min,0)/(min(max,max+min))+0.1)/2* diff(par()$usr[1:2])/diff(par()$usr[3:4])/(Ntip-1) e<-(k+0.1)/2*diff(par()$usr[1:2])/diff(par()$usr[3:4])/(Ntip-1) rr<-seq(s,e,length.out=length) if(k<=0.8&&any(rr>(strwidth("W")*fsize/2))) rr<-rr/max(rr)*strwidth("W")*fsize/2 temp<-c(0,cumsum((1+leg.space)*rep(2*max(rr),length-1))) nulo<-mapply(draw.circle,x=x+temp,y=rep(y,length),radius=cex.dot*rr, MoreArgs=list(nv=200,col=colors,border=border)) text(max(x+temp),y-0.04,round(max,2),pos=1,cex=cex) y1<-0.01 lines(c(x,max(x+temp)),rep(y-0.02-y1,2)) lines(c(x,x),y-c(y1+0.02,2*y1+0.02)) lines(c(max(x+temp),max(x+temp)),y-c(y1+0.02,2*y1+0.02)) } invisible(max(x+temp)+0.5*max(rr)) }phytools/R/pgls.Ives.R0000644000176200001440000001363214375517350014350 0ustar liggesusers## implements method of Ives et al. 2007 for PGLS regression with sampling error ## written by Liam J. Revell 2012, 2013, 2015 2017 pgls.Ives<-function(tree,X,y,Vx=NULL,Vy=NULL,Cxy=NULL,lower=c(1e-8,1e-8), fixed.b1=NULL){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") cat("\n") cat("---------------------------------------------------------------\n") cat("| **Warning: |\n") cat("| User reports suggest that this method may frequently |\n") cat("| fail to find the ML solution. Please use with caution. |\n") cat("---------------------------------------------------------------\n\n") # likelihood function lik<-function(theta,C,x,y,Mx,My,Mxy,fixed.b1=NULL){ sig2x<-theta[1] sig2y<-theta[2] b1<-if(is.null(fixed.b1)) theta[3] else fixed.b1 a<-theta[4:5] n<-nrow(C) Psi<-matrix(0,2*n,2*n) Psi[1:n,1:n]<-sig2x*C+diag(Mx) Psi[n+1:n,1:n]<-Psi[1:n,n+1:n]<-b1*sig2x*C+diag(Mxy) Psi[n+1:n,n+1:n]<-b1^2*sig2x*C+sig2y*C+diag(My) z<-c(X,y) D<-kronecker(diag(rep(1,2)),matrix(rep(1,n))) L<-dmnorm(z,(D%*%a)[,1],Psi,log=TRUE) return(-L) } # check data input format Xbar<-ybar<-NULL if((length(X)>length(unique(names(X))))&&is.null(Vx)){ a<-aggregate(X,by=list(names(X)),FUN=mean) Xbar<-setNames(a[,2],a[,1]) a<-aggregate(X,by=list(names(X)),FUN=var) Vx<-setNames(a[,2],a[,1]) nx<-summary(as.factor(names(X)))[names(Vx)] Vx<-Vx/nx if(any(is.na(Vx))){ warning("Some species contain only one sample. Substituting mean variance.", call.=FALSE) Vx[which(is.na(Vx))]<-mean(Vx*nx,na.rm=TRUE) } rm(a,nx) } if((length(y)>length(unique(names(y))))&&is.null(Vy)){ a<-aggregate(y,by=list(names(y)),FUN=mean) ybar<-setNames(a[,2],a[,1]) a<-aggregate(y,by=list(names(y)),FUN=var) Vy<-setNames(a[,2],a[,1]) ny<-summary(as.factor(names(y)))[names(Vy)] Vy<-Vy/ny if(any(is.na(Vy))){ warning("Some species contain only one sample. Substituting mean variance.", call.=FALSE) Vy[which(is.na(Vy))]<-mean(Vy*ny,na.rm=TRUE) } rm(a,ny) } if(is.null(Cxy)){ a<-aggregate(X,by=list(names(X)),FUN=mean); a<-setNames(a[,2],a[,1]) b<-aggregate(y,by=list(names(y)),FUN=mean); b<-setNames(b[,2],b[,1]) c<-(X-a[names(X)])*(y-b[names(y)]) d<-aggregate(c,by=list(names(c)),FUN=sum); d<-setNames(d[,2],d[,1]) nxy<-summary(as.factor(names(y)))[names(d)] Cxy<-d/(nxy-1)/nxy if(any(is.na(Cxy))){ warning("Some species contain only one sample. Substituting mean variance.", call.=FALSE) Cxy[which(is.na(Cxy))]<-mean(Cxy*nxy,na.rm=TRUE) } rm(a,b,c,nxy) } if(!is.null(Xbar)) X<-Xbar if(!is.null(ybar)) y<-ybar # perform calculation & organization C<-vcv.phylo(tree) X<-X[tree$tip.label] y<-y[tree$tip.label] Vx<-Vx[tree$tip.label] Vy<-Vy[tree$tip.label] Cxy<-Cxy[tree$tip.label] # get some reasonable starting values for optimization b<-if(is.null(fixed.b1)) runif(n=1,min=0,max=2)*lm(pic(y, tree)~pic(X,tree))$coefficients[2] else fixed.b1 names(b)<-NULL sig2x<-runif(n=1,min=0,max=2)*mean(pic(X,tree)^2) sig2y<-runif(n=1,min=0,max=2)*mean(pic(y,tree)^2) a<-runif(n=2,min=-1,max=1)*c(mean(X),mean(y)) # optimize regression model r<-optim(c(sig2x,sig2y,b,a),lik,C=C,x=X,y=y,Mx=Vx,My=Vy,Mxy=Cxy, fixed.b1=fixed.b1,method="L-BFGS-B", lower=c(lower,-Inf,-Inf,-Inf),control=list(factr=1e10)) k<-if(is.null(fixed.b1)) 5 else 4 if(all(Vx==0)) k<-k-1 if(all(Vy==0)) k<-k-1 # return r obj<-list(beta=c(r$par[5]-r$par[3]*r$par[4], if(is.null(fixed.b1)) r$par[3] else fixed.b1),sig2x=r$par[1], sig2y=r$par[2],a=r$par[4:5],logL=-r$value,convergence=r$convergence, message=r$message,df=c(k,Ntip(tree)-k)) class(obj)<-"pgls.Ives" obj } logLik.pgls.Ives<-function(object,...){ lik<-object$logL attr(lik,"df")<-object$df[1] lik } print.pgls.Ives<-function(x,digits=6,...){ cat("\nResult PGLS with sampling error in x & y") cat("\n (based on Ives et al. 2007):\n\n") cat("Response: y\n") object<-data.frame(x$beta[1],x$beta[2]) colnames(object)<-c("Intercept","beta[1]") rownames(object)<-"y" print(object) cat("\nSummary of ML estimated parameters:\n") object<-data.frame(round(c(x$sig2y,x$sig2x),digits), round(c(x$a[2:1]),digits),c(round(x$logL,digits),"")) colnames(object)<-c("sigma^2","a","log(L)") rownames(object)<-c("y","x") print(object) cat("---------\n") if(x$convergence==0) cat("\nR thinks it has converged.\n\n") else ("\nR may not have converged.\n\n") } ## simpler function to take sampling error into account for y only ## written by Liam J. Revell 2017, 2021 pgls.SEy<-function(model,data,corClass=corBrownian,tree, se=NULL,method=c("REML","ML"),interval=c(0,1000),...){ Call<-match.call() corfunc<-corClass ## preliminaries spp<-rownames(data) data<-cbind(data,spp) if(is.null(se)) se<-setNames(rep(0,Ntip(tree)), tree$tip.label)[spp] else se<-se[spp] ## likelihood function lk<-function(sig2e,data,tree,model,ve,corfunc,spp){ tree$edge.length<-tree$edge.length*sig2e ii<-sapply(1:Ntip(tree),function(x,e) which(e==x), e=tree$edge[,2]) tree$edge.length[ii]<-tree$edge.length[ii]+ve[tree$tip.label] vf<-diag(vcv(tree))[spp] w<-varFixed(~vf) COR<-corfunc(1,tree,form=~spp,...) fit<-gls(model,data=cbind(data,vf),correlation=COR,method=method, weights=w) -logLik(fit) } ## estimate sig2[e] fit<-optimize(lk,interval=interval,data=data,tree=tree,model=model, ve=se^2,corfunc=corfunc,spp=spp) tree$edge.length<-tree$edge.length*fit$minimum ii<-sapply(1:Ntip(tree),function(x,e) which(e==x), e=tree$edge[,2]) tree$edge.length[ii]<-tree$edge.length[ii]+ se[tree$tip.label]^2 vf<-diag(vcv(tree))[spp] w<-varFixed(~vf) ## fit & return model obj<-gls(model,data=cbind(data,vf),correlation=corfunc(1,tree, form=~spp,...),weights=w,method=method) obj$call<-Call obj } phytools/R/sim.rates.R0000644000176200001440000000541314375517350014401 0ustar liggesusers# simulates with multiple evolutionary rates in different parts of the tree # written by Liam J. Revell 2011, 2013, 2015 sim.rates<-function(tree,sig2,anc=0,nsim=1,internal=FALSE,plot=FALSE){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(is.null(tree$mapped.edge)){ message("tree does not contain a mapped discrete character history, using fastBM") X<-fastBM(tree,a=anc,sig2=sig2[1],nsim=nsim,internal=internal) } else { # first name (if necessary) and reorder sig2 if(is.null(names(sig2))){ message("names absent from sig2: assuming same order as $mapped.edge") if(length(sig2)==ncol(tree$mapped.edge)) names(sig2)<-colnames(tree$mapped.edge) else stop("the number of elements in sig2 should match the number of rows in mapped.edge") } sig2<-sig2[colnames(tree$mapped.edge)] # now create a tree for simulation edge.length<-rep(0,nrow(tree$edge)) # scale the edge lengths by the rate for(i in 1:ncol(tree$mapped.edge)) edge.length<-edge.length+sig2[i]*tree$mapped.edge[,i] names(edge.length)<-NULL tree<-list(Nnode=tree$Nnode,edge=tree$edge,tip.label=tree$tip.label,edge.length=edge.length) class(tree)<-"phylo" if(plot) plot(tree) # simulate X<-fastBM(tree,a=anc,nsim=nsim,internal=internal) } X } ## function simulates multiple OU regimes using a difference equation approximation ## written by Liam J. Revell 2017 multiOU<-function(tree,alpha,sig2,theta=NULL,a0=NULL,nsim=1,internal=FALSE,...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(nsim>1) x<-replicate(nsim,multiOU(tree,alpha,sig2,theta,a0,nsim=1,internal,...)) else { rt<-Ntip(tree)+1 if(!inherits(tree,"simmap")){ tree<-paintSubTree(tree,rt,"1") names(alpha)<-names(sig2)<-"1" } if(hasArg(dt)) dt<-list(...)$dt else dt<-1/1000*max(nodeHeights(tree)) ss<-sort(unique(c(getStates(tree,"tips"),getStates(tree,"nodes")))) if(is.null(theta)) theta<-setNames(rep(0,length(ss)),ss) if(is.null(a0)) a0<-0 tree<-reorder(tree,"cladewise") S<-matrix(NA,nrow(tree$edge),2) S[which(tree$edge[,1]==rt),1]<-a0 for(i in 1:nrow(tree$edge)){ x1<-S[i,1] for(j in 1:length(tree$maps[[i]])){ t<-tree$maps[[i]][j] ALPHA<-alpha[names(t)] SIG2<-sig2[names(t)] THETA<-theta[names(t)] t<-c(rep(dt,floor(t/dt)),t%%dt) for(k in 1:length(t)) x1<-x1+ALPHA*(THETA-x1)*t[k]+ rnorm(n=1,sd=sqrt(SIG2*t[k])) } S[i,2]<-x1 if(any(tree$edge[,1]==tree$edge[i,2])) S[which(tree$edge[,1]==tree$edge[i,2]),1]<-S[i,2] } x<-setNames(c(S[1,1],S[,2]),c(tree$edge[1,1], tree$edge[,2]))[as.character(1:(Ntip(tree)+tree$Nnode))] names(x)[1:Ntip(tree)]<-tree$tip.label if(!internal) x<-x[tree$tip.label] } x } phytools/R/pbtree.R0000644000176200001440000002054614375517350013761 0ustar liggesusers## function to simulate a pure-birth phylogenetic tree or trees ## written by Liam J. Revell 2011-2015, 2018 pbtree<-function(b=1,d=0,n=NULL,t=NULL,scale=NULL,nsim=1, type=c("continuous","discrete"),...){ # get arguments if(hasArg(ape)) ape<-list(...)$ape else ape<-TRUE if(hasArg(quiet)) quiet<-list(...)$quiet else quiet<-FALSE if(hasArg(extant.only)) extant.only<-list(...)$extant.only else extant.only<-FALSE if(hasArg(max.count)) max.count<-list(...)$max.count else max.count<-1e5 if(hasArg(method)) method<-list(...)$method else method<-"rejection" if(hasArg(tip.label)){ tip.label<-list(...)$tip.label if(!is.null(tip.label)){ if(is.null(n)){ tip.label<-NULL cat("Warning: tip.label not allowed for n=NULL.\n") cat(" using default labels\n") } else if(length(tip.label)==n){ if(d>0){ cat("Warning: only using labels in tip.label for extant tips.\n") cat(" extinct tips will be labeled X1, X2, etc.\n") } } else if(length(tip.label)!=n) { cat("Warning: length(tip.label) and n do not match.\n") cat(" using default labels\n") tip.label<-NULL } } } else tip.label<-NULL type<-matchType(type[1],c("continuous","discrete")) if(type=="discrete"){ if((b+d)>1){ cat("Warning:\n b + d cannot exceed 1.0 in discrete-time simulations\n") cat(paste(" setting b & d to",b/(b+d),"and",d/(b+d),"respectively\n")) b<-b/(b+d) d<-d/(b+d) } } tol<-1e-12 # done get arguments # if nsim > 1 replicate nsim times if(nsim>1){ trees<-replicate(nsim,pbtree(b,d,n,t,scale,type=type,ape=ape,quiet=quiet,extant.only=extant.only,method=method,tip.label=tip.label),simplify=FALSE) class(trees)<-"multiPhylo" return(trees) } else { if(!is.null(n)) NN<-n else NN<-NULL if(!is.null(n)&&!is.null(t)){ if(method=="rejection"){ # simulate taxa & time stop using rejection sampling to max.count if(!quiet){ cat("simulating with both taxa-stop (n) and time-stop (t) is\n") cat("performed via rejection sampling & may be slow\n\n") } N<-0; T<-0; count<--1 while((N!=n||T0&&extant.only==FALSE) length(getExtant(tree)) else length(tree$tip.label) T<-max(nodeHeights(tree)) } count<-count+1 } if(N==n&&T>=(t-tol)){ if(!quiet) cat(paste(" ",count," trees rejected before finding a tree\n\n",sep="")) } else { if(!quiet) cat(paste(" max count of ",count," reached without finding a tree\n\n",sep="")) tree<-NULL } # done simulate taxa & time stop } else if(method=="direct"){ # simulate using direct sampling (experimental) if(!quiet){ cat("simulating with both taxa-stop (n) & time-stop (t) using\n") cat("'direct' sampling. this is experimental\n") } m<-2 while(m[length(m)]!=n){ ll<-bd<-vector(); m<-2; i<-1 while(sum(ll)1) sample(p,size=1) else p if(birth){ # new edge edge[q,2]<-node edge<-rbind(edge,matrix(c(node,NA,node,NA),2,2,byrow=T)) node<-node+1 } else { edge[q,2]<--dead dead<-dead+1 } edge.length[p]<-edge.length[p]+l if(birth) edge.length<-c(edge.length,rep(0,2)) } edge[edge[,2]<0,2]<-NA o<-is.na(edge[,2]) n<-sum(o) edge<-edge+n p<-which(o) edge[o,2]<-1:sum(is.na(edge[,2])) # build 'phylo' object tree<-list(edge=edge,edge.length=edge.length,tip.label=paste("t",1:n,sep=""),Nnode=n-1) class(tree)<-"phylo" # done simulate using direct sampling (experimental) } } else { if(!is.null(t)){ # simulation time stop node<-1; dead<-1 edge<-matrix(c(node,NA,node,NA),2,2,byrow=T) edge.length<-c(0,0) node<-node+1; tt<-0 while(tt=t) l<-l-tt+t else { birth<-sapply(runif(n=length(l)),function(x) if(x1) sample(p)[1:min(length(p),length(l))] else p for(i in 1:length(l)){ if(birth[i]){ # new edge edge[q[i],2]<-node edge<-rbind(edge,matrix(c(node,NA,node,NA),2,2,byrow=T)) node<-node+1 } else { edge[q[i],2]<--dead dead<-dead+1 } } } edge.length[p]<-edge.length[p]+l[1] edge.length<-c(edge.length,rep(0,2*length(l))) } edge[edge[,2]<0,2]<-NA o<-is.na(edge[,2]) n<-sum(o) edge<-edge+n p<-which(o) edge[o,2]<-1:sum(is.na(edge[,2])) # done unique part of time stop } else if(!is.null(n)) { # simulate taxa stop node<-1 edge<-matrix(c(node,NA,node,NA),2,2,byrow=T) edge.length<-c(0,0) node<-node+1; dead<-1; nn<-2 while(nn1) sample(p)[1:min(length(p),length(l))] else p for(i in 1:length(l)){ if(birth[i]){ # new edge edge[q[i],2]<-node edge<-rbind(edge,matrix(c(node,NA,node,NA),2,2,byrow=T)) node<-node+1 } else { edge[q[i],2]<--dead dead<-dead+1 } } edge.length[p]<-edge.length[p]+l[1] edge.length<-c(edge.length,rep(0,2*length(l))) nn<-sum(is.na(edge[,2])) } edge[edge[,2]<0,2]<-NA o<-is.na(edge[,2]) nn<-sum(o) edge<-edge+nn p<-which(o) l<-if(type=="discrete") min(rgeom(n=sum(o),prob=(b+d))+1) else rexp(n=1,sum(o)*(b+d)) edge.length[p]<-edge.length[p]+l edge[is.na(edge[,2]),2]<-1:sum(is.na(edge[,2])) if((nn-dead+1)>n&&!quiet){ # this might happen in discrete time only cat("Warning:\n due to multiple speciation events in the final time interval\n") cat(" realized n may not equal input n\n\n") if(!is.null(tip.label)){ cat("Warning: length(tip.label) and n do not match.\n") cat(" using default labels\n") tip.label<-NULL } } n<-nn # done unique part of taxa stop } # build 'phylo' object with temporary labels tree<-list(edge=edge,edge.length=edge.length,tip.label=1:n,Nnode=n-1) class(tree)<-"phylo" if(!is.null(scale)){ # rescale if scale!=NULL h<-max(nodeHeights(tree)) tree$edge.length<-scale*tree$edge.length/h } if(d>0&&extant.only){ # prune extinct tips if extant.only==TRUE if(length(getExtinct(tree))==(length(tree$tip.label)-1)){ if(!quiet) cat("Warning:\n no extant tips, tree returned as NULL\n") tree<-NULL } else tree<-drop.tip(tree,getExtinct(tree)) } # if tree!=NULL assign final tip labels if(!is.null(tree)) tree$tip.label<-paste("t",1:length(tree$tip.label),sep="") } # if ape==TRUE make sure 'phylo' is consistent with ape if(ape&&is.null(tree)==FALSE) tree<-read.tree(text=write.tree(tree)) if(!is.null(tip.label)){ th<-max(nodeHeights(tree)) if(length(getExtant(tree,tol=1e-08*th))!=NN){ # simulation must have gone extint before reaching NN tree$tip.label<-paste("X",1:length(tree$tip.label),sep="") } else { ll<-getExtant(tree,tol=1e-08*th) ii<-sapply(ll,function(x,y) which(x==y),y=tree$tip.label) tree$tip.label[ii]<-tip.label tree$tip.label[-ii]<-paste("X",1:(length(tree$tip.label)-length(ii)),sep="") } } # done return(tree) } } phytools/R/add.everywhere.R0000644000176200001440000000142114375517350015403 0ustar liggesusers# function takes a tree and adds a tip in all possible places # returns the set of unrooted trees without branch lengths # written by Liam J. Revell 2011, 2013, 2015 add.everywhere<-function(tree,tip.name){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") tree<-unroot(tree) # unroot tree tree$edge.length<-rep(1,nrow(tree$edge)) # set all edge lengths to 1.0 # create new tip new.tip<-list(edge=matrix(c(2L,1L),1,2),tip.label=tip.name,edge.length=1,Nnode=1L) class(new.tip)<-"phylo" # add the new tip to all edges of the tree trees<-list() class(trees)<-"multiPhylo" for(i in 1:nrow(tree$edge)){ trees[[i]]<-bind.tree(tree,new.tip,where=tree$edge[i,2],position=0.5) trees[[i]]$edge.length<-NULL } return(trees) } phytools/R/add.species.to.genus.R0000644000176200001440000000464114375517350016421 0ustar liggesusers## function identifies the genus from a species name & attempts to add it to the tree ## written by Liam J. Revell 2013 add.species.to.genus<-function(tree,species,genus=NULL,where=c("root","random")){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(!is.ultrametric(tree)) warning("this code has only been tested with ultrametric tree\n your tree may be returned without edge lengths") where<-where[1] if(is.null(genus)){ ## get genus from species name x<-strsplit(species,"")[[1]] i<-1 while(x[i]!="_"&&x[i]!=" ") i<-i+1 genus<-paste(x[2:i-1],collapse="") } ii<-grep(paste(genus,"_",sep=""),tree$tip.label) if(length(ii)>1){ if(!is.monophyletic(tree,tree$tip.label[ii])) warning(paste(genus,"may not be monophyletic\n attaching to the most inclusive group containing members of this genus")) nn<-findMRCA(tree,tree$tip.label[ii]) if(where=="root") tree<-bind.tip(tree,gsub(" ","_",species),where=nn) else if(where=="random"){ tt<-splitTree(tree,list(node=nn,bp=tree$edge.length[which(tree$edge[,2]==nn)])) tt[[2]]<-add.random(tt[[2]],tips=gsub(" ","_",species)) tree<-paste.tree(tt[[1]],tt[[2]]) } else stop("option 'where' not recognized") } else if(length(ii)==1){ nn<-ii if(where=="root") tree<-bind.tip(tree,gsub(" ","_",species),where=nn,position=0.5*tree$edge.length[which(tree$edge[,2]==nn)]) else if(where=="random") tree<-bind.tip(tree,gsub(" ","_",species),where=nn,position=runif(n=1)*tree$edge.length[which(tree$edge[,2]==nn)]) else stop("option 'where' not recognized") } else warning("could not match your species to a genus\n check spelling, including case") tree } ## function take genus backbone tree & converts genus tree to species tree by simulating pure-birth subtrees ## written by Liam J. Revell 2015 genus.to.species.tree<-function(tree,species){ N<-Ntip(tree) genera<-tree$tip.label species<-gsub(" ","_",species) for(i in 1:N){ jj<-grep(paste(genera[i],"_",sep=""),species) nn<-which(tree$tip.label==genera[i]) if(length(jj)>1){ h<-runif(n=1)*tree$edge.length[which(tree$edge[,2]==nn)] tree$edge.length[which(tree$edge[,2]==nn)]<- tree$edge.length[which(tree$edge[,2]==nn)]-h sub.tree<-pbtree(n=length(jj),scale=h,tip.label=species[jj]) tree<-bind.tree(tree,sub.tree,where=nn) } else if(length(jj)==1) tree$tip.label[nn]<-species[jj] } tree } phytools/R/treeSlice.R0000644000176200001440000000567314375517350014423 0ustar liggesusers## function slices a tree at slice and returns all subtrees ## it uses extract.clade(), if trivial==FALSE subtrees with length than 2 taxa are ignored ## for orientation="rootwards" it will return the tree rootward of the slice point ## written by Liam J. Revell 2011, 2012, 2015, 2017 treeSlice<-function(tree,slice=NULL,trivial=FALSE,prompt=FALSE,...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(hasArg(orientation)) orientation<-list(...)$orientation else orientation<-"tipwards" if(prompt){ cat("Inside prompt.\n") plotTree(tree,mar=c(3.1,rep(0.1,3)),...) axis(1) cat("Click at the tree height where cutting is desired...\n") flush.console() xy<-unlist(locator(1)) slice<-xy[1] cat(paste("Slice height is ",signif(slice,6),". Thank you!\n",sep="")) flush.console() lines(rep(slice,2),par()$usr[3:4],lty="dashed") obj<-get("last_plot.phylo",envir=.PlotPhyloEnv) X<-cbind(obj$xx[obj$edge[,1]],obj$xx[obj$edge[,2]]) y<-obj$yy[obj$edge[,2]] if(trivial){ for(i in 1:nrow(X)) if(X[i,1]slice) points(slice,y[i],pch=19) } else { for(i in 1:nrow(X)) if(X[i,1]slice&&obj$edge[i,2]>Ntip(tree)) points(slice,y[i],pch=19) } } tree<-reorder(tree) # reorder cladewise H<-nodeHeights(tree) edges<-which(H[,2]>slice&H[,1]length(tree$tip)] trees<-list() class(trees)<-"multiPhylo" for(i in 1:length(nodes)){ if(nodes[i]>Ntip(tree)){ trees[[i]]<-extract.clade(tree,node=nodes[i]) trees[[i]]$root.edge<-H[which(tree$edge[,2]==nodes[i]),2]-slice } else { z<-list(edge=matrix(c(2,1),1,2), edge.length=H[which(tree$edge[,2]==nodes[i]),2]-slice, tip.label=tree$tip.label[nodes[i]],Nnode=1L) class(z)<-"phylo" trees[[i]]<-z } } return(trees) } else if(orientation=="rootwards"){ obj<-tree obj$node.label<-1:obj$Nnode+Ntip(obj) if(any(nodes<=Ntip(obj))){ tips<-nodes[nodes<=Ntip(obj)] tips<-obj$tip.label[tips] nodes<-nodes[nodes>Ntip(obj)] } else tips<-NULL if(length(nodes)>0){ for(i in 1:length(nodes)){ nn<-which(obj$node.label==nodes[i])+Ntip(obj) parent<-getParent(obj,nn) bp<-slice-nodeheight(obj,parent) obj<-splitTree(obj,list(node=nn,bp=bp))[[1]] obj$tip.label[obj$tip.label=="NA"]<-nodes[i] } } if(!is.null(tips[1])){ for(i in 1:length(tips)){ nn<-which(obj$tip.label==tips[i]) parent<-getParent(obj,nn) obj$edge.length[which(obj$edge[,2]==nn)]<-slice-nodeheight(obj,parent) } } return(obj) } } ## function returns the parent of node or NULL if node is the root getParent<-function(tree,node){ ind<-which(tree$edge[,2]==node) if(length(ind)>0) pp<-tree$edge[which(tree$edge[,2]==node),1] else { pp<-NULL cat("node is the root. returning NULL\n") } pp } phytools/R/branching.diffusion.R0000644000176200001440000000354314375517350016416 0ustar liggesusers## function animates branching random diffusion ## written by Liam Revell 2011, 2013, 2015, 2020 branching.diffusion<-function(sig2=1,b=0.0023,time.stop=1000,ylim=NULL,smooth=TRUE, pause=0.02,record=NULL,path=NULL,...){ if(hasArg(bty)) bty<-list(...)$bty else bty<-"l" N<-1 Y<-matrix(0,1,N) if(is.null(ylim)) ylim<-c(-2*sqrt(sig2*time.stop),2*sqrt(sig2*time.stop)) par(bg="white") plot(0,0,xlim=c(0,time.stop),ylim=ylim,xlab="time",ylab="phenotype", main="branching diffusion",font.main=3,bty=bty) chk<-.check.pkg("animation") if(!chk){ cat(" record != NULL requires the package \"animation\"\n") cat(" Animation will play but not record\n\n") record<-NULL ani.options<-function(...) NULL ani.record<-function(...) NULL ani.replay<-function(...) NULL saveVideo<-function(...) NULL } if(!is.null(record)){ if(is.null(path)) path="C:/Program Files/ffmpeg/bin/ffmpeg.exe" tmp<-strsplit(path,"/")[[1]] ll<-list.files(paste(tmp[2:length(tmp)-1],collapse="/")) if(length(grep(tmp[length(tmp)],ll))>0){ ani.options(interval=0.01,ffmpeg=path,outdir=getwd()) ani.record(reset=TRUE) } else { cat(" record != NULL requires correct path supplied to video renderer\n") cat(" Animation will play but not record\n\n") record<-NULL } } for(i in 2:time.stop){ time<-1:i Y<-rbind(Y,Y[i-1,]) for(j in 1:N){ if(b>runif(n=1)){ Y<-cbind(Y,Y[,j]) N<-N+1 Y[i,N]<-Y[i,j]+rnorm(n=1,sd=sqrt(sig2)) } Y[i,j]<-Y[i,j]+rnorm(n=1,sd=sqrt(sig2)) } dev.hold() plot(0,0,xlim=c(0,time.stop),ylim=ylim,xlab="time",ylab="phenotype", main="branching diffusion",font.main=3,bty=bty) apply(Y,2,lines) dev.flush() if(!is.null(record)) ani.record() Sys.sleep(pause) } if(!is.null(record)) saveVideo(ani.replay(),video.name=record,other.opts="-b 300k", clean=TRUE) } phytools/R/cotangleplot.R0000644000176200001440000000673514375517350015177 0ustar liggesuserscotangleplot<-function(tr1,tr2,type=c("cladogram","phylogram"), use.edge.length=TRUE,tangle=c("both","tree1","tree2"),...){ tr1<-untangle(tr1,"read.tree") tr2<-untangle(tr2,"read.tree") type<-type[1] tangle<-tangle[1] if(!use.edge.length){ tr1<-compute.brlen(tr1) tr2<-compute.brlen(tr2) } if(hasArg(layout)) layout<-list(...)$layout else layout<-c(0.45,0.1,0.45) if(hasArg(nodes)) nodes<-list(...)$nodes else nodes<-"centered" if(hasArg(lty)) lty<-list(...)$lty else lty<-if(type=="phylogram") c("dotted","solid") else if(type=="cladogram") "solid" if(type=="phylogram") if(length(lty)==1) lty<-rep(lty,2) if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-2 if(hasArg(cex)) cex<-list(...)$cex else cex<-1 if(hasArg(color)) color<-list(...)$color else color<-palette()[4] if(tangle=="both"){ capture.output(tmp<-cophylo(tr1,tr2)) tips.tr1<-setNames(1:Ntip(tr1),tmp$trees[[1]]$tip.label) tips.tr2<-setNames(1:Ntip(tr2),tmp$trees[[2]]$tip.label) tips<-sort(rowMeans(cbind(tips.tr1,tips.tr2[names(tips.tr1)]))) tips[]<-1:length(tips) } else if(tangle=="tree1"){ tips<-setNames(1:Ntip(tr2),tr2$tip.label) } else if(tangle=="tree2"){ tips<-setNames(1:Ntip(tr1),tr1$tip.label) } layout(matrix(c(1,2,3),1,3),widths=layout) plotTree(tr1,color="transparent",ftype="off",tips=tips,type=type, nodes=nodes) h<-par()$usr[2] pp<-get("last_plot.phylo",envir=.PlotPhyloEnv) for(i in 1:Ntip(tr1)) lines(c(pp$xx[i],h),rep(pp$yy[i],2), lty="dotted") if(type=="phylogram"){ for(i in 1:nrow(tr1$edge)) lines(pp$xx[tr1$edge[i,]],rep(pp$yy[tr1$edge[i,2]],2), lwd=lwd,col=color,lty=lty[2]) for(i in Ntip(tr1)+1:tr1$Nnode){ dd<-Children(tr1,i) lines(rep(pp$xx[i],length(dd)),pp$yy[dd],lwd=lwd, col=color,lty=lty[1]) } } else if(type=="cladogram"){ par(ljoin=2) for(i in 1:Ntip(tr1)){ AA<-c(i,Ancestors(tr1,i)) ii<-sapply(AA[1:(length(AA)-1)],function(x,y) which(y==x), y=tr1$edge[,2]) lines(c(pp$xx[tr1$edge[ii,2]],pp$xx[Ntip(tr1)+1]), c(pp$yy[tr1$edge[ii,2]],pp$yy[Ntip(tr1)+1]), lwd=lwd+2, col=if(par()$bg=="transparent") "white" else par()$bg, lty="solid") lines(c(pp$xx[tr1$edge[ii,2]],pp$xx[Ntip(tr1)+1]), c(pp$yy[tr1$edge[ii,2]],pp$yy[Ntip(tr1)+1]), lwd=lwd,col=color,lty=lty) } } plot(NA,xlim=c(-1,1),ylim=pp$y.lim,axes=FALSE,xlab="",ylab="") text(rep(0,Ntip(tr1)),tips,gsub("_"," ",names(tips)),cex=cex,font=3) plotTree(tr2,color="transparent",ftype="off",direction="leftwards", tips=tips,type=type) h<-par()$usr[1] pp<-get("last_plot.phylo",envir=.PlotPhyloEnv) for(i in 1:Ntip(tr2)) lines(c(pp$xx[i],h),rep(pp$yy[i],2), lty="dotted") if(type=="phylogram"){ for(i in 1:nrow(tr2$edge)) lines(pp$xx[tr2$edge[i,]],rep(pp$yy[tr2$edge[i,2]],2), lwd=lwd,col=color,lty=lty[2]) for(i in Ntip(tr2)+1:tr2$Nnode){ dd<-Children(tr2,i) lines(rep(pp$xx[i],length(dd)),sort(pp$yy[dd]), lwd=lwd,col=color,lty=lty[1]) } } else if(type=="cladogram"){ for(i in 1:Ntip(tr2)){ AA<-c(i,Ancestors(tr2,i)) ii<-sapply(AA[1:(length(AA)-1)],function(x,y) which(y==x), y=tr2$edge[,2]) lines(c(pp$xx[tr2$edge[ii,2]],pp$xx[Ntip(tr2)+1]), c(pp$yy[tr2$edge[ii,2]],pp$yy[Ntip(tr2)+1]), lwd=lwd+2, col=if(par()$bg=="transparent") "white" else par()$bg, lty="solid") lines(c(pp$xx[tr2$edge[ii,2]],pp$xx[Ntip(tr2)+1]), c(pp$yy[tr2$edge[ii,2]],pp$yy[Ntip(tr2)+1]), lwd=lwd,col=color,lty=lty) } } } phytools/R/drop.tip.simmap.R0000644000176200001440000000666314427004457015525 0ustar liggesusers## functions drop or keep tips for multiple phylogenetic object types ## written by Liam J. Revell 2012, 2015, 2018, 2021, 2023 drop.tip.simmap<-function(phy,tip,...){ if(hasArg(untangle)) untangle<-list(...)$untangle else untangle<-FALSE phy<-reorder(phy) if(!inherits(phy,"simmap")) stop("phy should be object of class \"simmap\".") tip<-which(phy$tip.label%in%tip) edges<-match(tip,phy$edge[,2]) z<-setdiff(1:nrow(phy$edge),edges) phy$edge<-phy$edge[z,] phy$edge.length<-phy$edge.length[z] phy$maps<-phy$maps[z] z<-setdiff(phy$edge[,2],phy$edge[,1]) z<-z[z>Ntip(phy)] while(length(z)>0){ edges<-match(z,phy$edge[,2]) y<-setdiff(1:nrow(phy$edge),edges) phy$edge<-phy$edge[y,] phy$edge.length<-phy$edge.length[y] phy$maps<-phy$maps[y] z<-setdiff(phy$edge[,2],phy$edge[,1]) z<-z[z>Ntip(phy)] } z<-setdiff(phy$edge[,2],phy$edge[,1]) phy$tip.label<-phy$tip.label[z] phy$edge[which(phy$edge[,2]%in%z),2]<-1:Ntip(phy) while(sum(phy$edge[1,1]==phy$edge[,1])==1){ phy$edge<-phy$edge[2:nrow(phy$edge),] phy$edge.length<-phy$edge.length[2:length(phy$edge.length)] phy$maps<-phy$maps[2:length(phy$maps)] } i<-1 while(i1) phy$maps[[i]]<- c(phy$maps[[i]],phy$maps[[z]][2:length(phy$maps[[z]])]) } y<-setdiff(1:nrow(phy$edge),z) phy$edge<-phy$edge[y,] phy$edge.length<-phy$edge.length[y] phy$maps<-phy$maps[y] single<-sum(phy$edge[i,2]==phy$edge[,1])==1 } i<-i+1 } z<-unique(as.vector(phy$edge)) z<-z[z>Ntip(phy)] y<-order(z)+Ntip(phy) for(i in 1:nrow(phy$edge)) for(j in 1:2) if(phy$edge[i,j]%in%z) phy$edge[i,j]<-y[which(phy$edge[i,j]==z)] phy$Nnode<-max(phy$edge)-Ntip(phy) phy$node.states<-matrix(NA,nrow(phy$edge),2) for(i in 1:nrow(phy$edge)) phy$node.states[i,]<- c(names(phy$maps[[i]])[1],names(phy$maps[[i]])[length(phy$maps[[i]])]) if(!is.null(phy$states)) phy$states<-phy$states[phy$tip.label] allstates<-vector() for(i in 1:nrow(phy$edge)) allstates<-c(allstates,names(phy$maps[[i]])) allstates<-unique(allstates) phy$mapped.edge<-matrix(data=0,length(phy$edge.length),length(allstates), dimnames=list(edge=apply(phy$edge,1,function(x) paste(x,collapse=",")), state=allstates)) for(i in 1:length(phy$maps)) for(j in 1:length(phy$maps[[i]])) phy$mapped.edge[i,names(phy$maps[[i]])[j]]<-phy$mapped.edge[i, names(phy$maps[[i]])[j]]+phy$maps[[i]][j] class(phy)<-c("simmap",setdiff(class(phy),"simmap")) if(untangle) phy<-untangle(phy,"read.tree") phy } drop.tip.multiSimmap<-function(phy,tip,...){ if(!inherits(phy,"multiSimmap")) stop("phy is not an object of class \"multiSimmap\".") trees<-lapply(phy,drop.tip.simmap,tip=tip,...) class(trees)<-class(phy) trees } keep.tip.simmap<-function(phy,tip,...){ tips<-setdiff(phy$tip.label,tip) drop.tip.simmap(phy,tip=tips,...) } keep.tip.multiSimmap<-function(phy,tip,...){ trees<-lapply(phy,keep.tip.simmap,tip=tip,...) class(trees)<-class(phy) trees } phytools/R/evol.rate.mcmc.R0000644000176200001440000005063314375517350015315 0ustar liggesusers## these functions uses a Bayesian MCMC approach to estimate heterogeneity ## in the evolutionary rate for a ## continuous character (Revell, Mahler, Peres-Neto, & Redelings. 2012.) ## code written by Liam J. Revell 2010, 2011, 2013, 2015, 2017, 2019, 2022 ## function for Bayesian MCMC ## written by Liam J. Revell 2010, 2011, 2017, 2019 evol.rate.mcmc<-function(tree,x,ngen=10000,control=list(),...){ if(hasArg(quiet)) quiet<-list(...)$quiet else quiet<-FALSE # some minor error checking if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".") if(is.matrix(x)) x<-x[,1] if(is.null(names(x))){ if(length(x)==length(tree$tip)){ message("x has no names; assuming x is in the same order as tree$tip.label") names(x)<-tree$tip.label } else stop("x has no names and is a different length than tree$tip.label") } if(any(is.na(match(tree$tip.label,names(x))))){ message("some species in tree are missing from data, dropping missing taxa from the tree") tree<-drop.tip(tree,tree$tip.label[-match(names(x),tree$tip.label)]) } if(any(is.na(match(names(x),tree$tip.label)))){ message("some species in data are missing from tree, dropping missing taxa from the data") x<-x[tree$tip.label] } if(any(is.na(x))){ message("some data given as 'NA', dropping corresponding species from tree") tree<-drop.tip(tree,names(which(is.na(x)))) } # first, try and obtain reasonable estimates for control parameters # and starting values for the MCMC C<-vcv.phylo(tree) C<-C[names(x),names(x)] n<-nrow(C) one<-matrix(1,n,1) a<-colSums(solve(C))%*%x/sum(solve(C)) # MLE ancestral value, used to start MCMC sig1<-as.numeric(t(x-one%*%a)%*%solve(C)%*%(x-one%*%a)/n) # MLE sigma-squared, used to start MCMC sig2<-sig1 # used to start MCMC flipped=FALSE # used to start MCMC # populate control list con=list(sig1=sig1,sig2=sig2,a=as.numeric(a),sd1=0.2*sig1,sd2=0.2*sig2, sda=0.2*abs(as.numeric(a)),kloc=0.2*mean(diag(C)),sdlnr=1, rand.shift=0.05,print=100,sample=100) # also might use: sig1mu=1000,sig2mu=1000 con[(namc <- names(control))] <- control con<-con[!sapply(con,is.null)] # print control parameters to screen if(!quiet){ message("Control parameters (set by user or default):") str(con) flush.console() } # now detach the starting parameter values (to be compatible with downstream code) sig1<-con$sig1 sig2<-con$sig1 a<-con$a # all internal functions start here # function to return the index of a random edge random.node<-function(phy){ # sum edges cumulatively cum.edge<-vector(mode="numeric") index<-vector(mode="numeric") for(i in 1:length(phy$edge.length)){ if(i==1) cum.edge[i]<-phy$edge.length[1] else cum.edge[i]<-cum.edge[i-1]+phy$edge.length[i] index[i]<-phy$edge[i,2] } # pick random position pos<-runif(1)*cum.edge[length(phy$edge.length)] edge<-1 while(pos>cum.edge[edge]) edge<-edge+1 return (index[edge]) } # return the indices of a vector that match a scalar match.all<-function(s,v){ result<-vector(mode="numeric") j=1 for(i in 1:length(v)){ if(s==v[i]){ result[j]=i j=j+1 } } if(j==1) result<-NA return(result) } # function to return a matrix of the descendant tips from each internal & terminal node compute.descendant.species<-function(phy){ D<-dist.nodes(phy) ntips<-length(phy$tip.label) Cii<-D[ntips+1,] C<-D C[,]<-0 counts<-vector() for(i in 1:nrow(D)) for(j in 1:ncol(D)) C[i,j]<-(Cii[i]+Cii[j]-D[i,j])/2 tol<-1e-10 descendants<-matrix(0,nrow(D),ntips,dimnames=list(rownames(D))) for(i in 1:nrow(C)){ k<-0 for(j in 1:ntips){ if(C[i,j]>=(C[i,i]-tol)){ k<-k+1 descendants[i,k]<-phy$tip.label[j] } } counts[i]<-k } names(counts)<-rownames(descendants) return(descendants=list(species=descendants,counts=counts)) } # take a step on the tree (used in MCMC) tree.step<-function(phy,node,bp,step,up=NA,flip=FALSE){ if(step<0) step=-step # if user has given -step, positivize if(is.na(up)) up=(runif(1)>0.5) # if up/down is not assigned, we must be in the middle of a branch # decide to go up (1) or down (0) with equal probability if(up){ # pick a new position along the branch (or go to the end) new.bp<-min(bp+step,phy$edge.length[match(node,phy$edge[,2])]) # adjust step length to remain step step=step-(new.bp-bp) # check to see if we're done if(step<1e-6){ return(list(node=node,bp=new.bp,flip=flip)) } else { # we're going up, so get the daughters daughters<-phy$edge[match.all(node,phy$edge[,1]),2] # pick a random daughter new.node<-daughters[ceiling(runif(1)*length(daughters))] if(is.na(new.node)){ location<-tree.step(phy,node,phy$edge.length[match(node,phy$edge[,2])], step,up=FALSE,flip) # we're at a tip } else { location<-tree.step(phy,new.node,0,step,up=TRUE,flip) } } } else { # pick a new position along the branch (or go to the start) new.bp<-max(bp-step,0) # adjust step length step=step-(bp-new.bp) # check to see if we're done if(step<1e-6){ return(list(node=node,bp=new.bp,flip=flip)) } else { # we're going down so find out who the parent is parent<-phy$edge[match(node,phy$edge[,2]),][1] # find the other daughter(s) daughters<-phy$edge[match.all(parent,phy$edge[,1]),2] # don't use parent if root if(parent==(length(phy$tip.label)+1)){ parent=NULL # if at the base of the tree } # create a vector of the possible nodes: the parent, and sister(s) possible.nodes<-c(parent,daughters[-match(node,daughters)]) # now pick randomly new.node<-possible.nodes[ceiling(runif(1)*length(possible.nodes))] # if parent if(is.null(parent)==FALSE&&new.node==parent){ location<-tree.step(phy,new.node,phy$edge.length[match(new.node, phy$edge[,2])],step,up=FALSE,flip) } else { location<-tree.step(phy,new.node,0,step,up=TRUE,flip=TRUE) } } } } # log-likelihood function likelihood<-function(y,phy,C,descendants,sig1,sig2,a,loc){ C1<-matrix(0,nrow(C),ncol(C),dimnames=dimnames(C)) C2<-matrix(0,nrow(C),ncol(C),dimnames=dimnames(C)) n<-length(y) D<-matrix(1,n,1) if(loc$node>length(phy$tip.label)){ tr1<-extract.clade(phy,loc$node) tr1$root.edge<-phy$edge.length[match(loc$node,phy$edge[,2])]-loc$bp temp<-vcv.phylo(tr1)+tr1$root.edge } else { temp<-matrix(phy$edge.length[match(loc$node,phy$edge[,2])]-loc$bp, 1,1,dimnames=list(c(phy$tip.label[loc$node]),c(phy$tip.label[loc$node]))) } C2[rownames(temp),colnames(temp)]<-temp C1<-C-C2 # tips<-phy$tip.label[-match(rownames(temp),phy$tip.label)] tips<-rownames(temp) V<-sig1*C1+sig2*C2 logL<-as.numeric(-t(y-D%*%a)%*%solve(V)%*%(y-D%*%a)/2-n*log(2*pi)/2-determinant(V)$modulus[1]/2) return(list(logL=logL,tips=tips)) } # prior probability function log.prior<-function(s1,s2,a,location){ # logpr<-dexp(s1,rate=1/con$sig1mu,log=TRUE)+dexp(s2,rate=1/con$sig2mu,log=TRUE) # exponential prior logpr<-dnorm(log(s1)-log(s2),mean=0,sd=con$sdlnr,log=TRUE)-log(s1*s2) # log-normal return(logpr) } # proposal on sig1 or sig2 propose.sig<-function(sig,scale){ # if normal sig.prime<-abs(sig+rnorm(n=1,sd=scale)) # normal proposal distribution # if cauchy # sig.prime<-abs(sig+rcauchy(n=1,scale=scale)) return(sig.prime) } # proposal on a propose.a<-function(a,scale){ # if normal a.prime<-a+rnorm(n=1,sd=scale) # normal proposal distribution return(a.prime) } # proposal on loc propose.loc<-function(phy,loc,k,r){ loc.prime<-list() loc.prime$flip=FALSE if(runif(1)>r){ loc.prime<-tree.step(phy,loc$node,loc$bp, step=rexp(n=1,rate=1/k)) # update node & bp by random walk: rexp() # loc.prime<-tree.step(phy,loc$node,loc$bp, # step=abs(rnorm(n=1,sd=sqrt(2)/k))) # update node & bp by random walk: rnorm() } else { loc.prime$node<-random.node(phy) # pick random branch loc.prime$bp<-runif(1)*phy$edge.length[match(loc.prime$node,phy$edge[,2])] if((runif(1)>0.5)) loc.prime$flip=TRUE } return(loc.prime) } # obtain remaining starting values for the MCMC location<-list() location$node<-random.node(tree) location$bp<-runif(1)*tree$edge.length[match(location$node,tree$edge[,2])] location$flip<-FALSE descendants<-compute.descendant.species(tree) # compute descendants logL<-likelihood(x,tree,C,descendants,sig1,sig2,a,location)$logL logpr<-log.prior(sig1,sig2,a,location) # create matrix for results results<-matrix(NA,floor(ngen/con$sample)+1,7, dimnames=list(c(0,1:(ngen/con$sample)),c("state","sig1","sig2","a", "node","bp","likelihood"))) curr.gen<-matrix(NA,1,7,dimnames=list("curr",c("state","sig1","sig2","a","node","bp","likelihood"))) results[1,]<-c(0,sig1,sig2,a,location$node,location$bp,logL) # populate the first row curr.gen[1,]<-results[1,] group.tips<-list() tips<-list() group.tips[[1]]<-likelihood(x,tree,C,descendants,sig1,sig2,a,location)$tips tips[[1]]<-group.tips[[1]] message("Starting MCMC run....") if(!quiet){ cat("gen\tsig2(1)\tsig2(2)\ta \tnode\tpos\'n\tlogLik\n") cat(paste(round(results[1,],4),collapse="\t")) cat("\n") flush.console() } j<-2 # now run Markov-chain for(i in 1:ngen){ if(i%%4==1) sig1.prime<-propose.sig(sig1,scale=con$sd1) # update sig1 else sig1.prime<-sig1 if(i%%4==2) sig2.prime<-propose.sig(sig2,scale=con$sd2) # update sig2 else sig2.prime<-sig2 if(i%%4==3) a.prime<-propose.a(a,scale=con$sda) # update a else a.prime<-a if(i%%4==0){ location.prime<-propose.loc(phy=tree,loc=location,k=con$kloc,r=con$rand.shift) if(location.prime$flip==TRUE){ flipped.prime<-!flipped # flip the sigmas } else flipped.prime<-flipped } else { location.prime<-location flipped.prime<-flipped } if(!flipped.prime){ temp<-likelihood(x,tree,C,descendants,sig1.prime,sig2.prime,a.prime,location.prime) logpr.prime<-log.prior(sig1.prime,sig2.prime,a.prime,location.prime) if(exp(temp$logL+logpr.prime-curr.gen[1,"likelihood"]-logpr)>runif(1)){ sig1<-sig1.prime sig2<-sig2.prime a<-a.prime location<-location.prime logL<-temp$logL logpr<-logpr.prime flipped<-flipped.prime group.tips[[i+1]]<-temp$tips } else group.tips[[i+1]]<-group.tips[[i]] } else { temp<-likelihood(x,tree,C,descendants,sig2.prime,sig1.prime,a.prime,location.prime) logpr.prime<-log.prior(sig2.prime,sig1.prime,a.prime,location.prime) if(exp(temp$logL+logpr.prime-curr.gen[1,"likelihood"]-logpr)>runif(1)){ sig1<-sig1.prime sig2<-sig2.prime a<-a.prime location<-location.prime logL<-temp$logL logpr<-logpr.prime flipped<-flipped.prime group.tips[[i+1]]<-setdiff(tree$tip.label,temp$tips) } else group.tips[[i+1]]<-group.tips[[i]] } rm(temp) curr.gen[1,]<-c(i,sig1,sig2,a,location$node,location$bp,logL) if(i%%con$print==0) if(!quiet){ cat(paste(round(curr.gen[1,],4),collapse="\t")) cat("\n") flush.console() } if(i%%con$sample==0){ results[j,]<-curr.gen tips[[j]]<-group.tips[[i+1]] j<-j+1 } } message("Done MCMC run.") # return results obj<-list(mcmc=results,tips=tips,ngen=ngen,sample=con$sample, tree=tree) class(obj)<-"evol.rate.mcmc" obj } ## S3 print method print.evol.rate.mcmc<-function(x, ...){ cat("\nObject of class \"evol.rate.mcmc\" containing the results from a\n") cat("the Bayesian MCMC analysis of a Brownian-motion rate-shift model.\n\n") cat(paste("MCMC was conducted for",x$ngen,"generations sampling every",x$sample,"\n")) cat("generations.\n\n") cat("The most commonly sampled rate shift(s) occurred on the edge(s)\n") pp<-table(x$mcmc[,"node"])/nrow(x$mcmc) node<-names(pp)[which(pp==max(pp))] if(length(node)==1) cat(paste("to node(s) ",node,".\n\n",sep="")) else cat(paste("leading to node(s) ",paste(node,collapse=", "),".\n\n",sep="")) cat("Use the functions posterior.evolrate and minSplit for more detailed\n") cat("analysis of the posterior sample from this analysis.\n\n") } # this function finds the split with the minimum the distance to all the other splits in the sample # written by Liam J. Revell 2010, 2015, 2022 minSplit<-function(tree,split.list,method="sum",printD=FALSE){ # some minor error checking if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".") ## determine is split.list is an object from our MCMC, or a matrix if(inherits(split.list,"evol.rate.mcmc")) split.list<-split.list$mcmc[,c("node","bp")] else if(inherits(split.list,"matrix")) split.list<-split.list[,c("node","bp")] # start by creating a matrix of the nodes of the tree with their descendant nodes D<-dist.nodes(tree) ntips<-length(tree$tip.label) Cii<-D[ntips+1,] C<-D C[,]<-0 for(i in 1:nrow(D)) for(j in 1:ncol(D)) C[i,j]<-(Cii[i]+Cii[j]-D[i,j])/2 tol<-1e-10 descendants<-matrix(0,nrow(D),ncol(D),dimnames=list(rownames(D))) for(i in 1:nrow(C)){ k<-1 for(j in 1:ncol(C)){ if(C[i,j]>=(C[i,i]-tol)){ descendants[i,k]<-j k<-k+1 } } } distances<-matrix(0,nrow(split.list),nrow(split.list)) for(i in 1:nrow(split.list)){ for(j in i:nrow(split.list)){ if(i!=j){ # first, if on the same branch as current average - then just compute the difference if(split.list[i,1]==split.list[j,1]){ distances[i,j]<-abs(split.list[i,2]-split.list[j,2]) } else { distances[i,j]<-D[split.list[i,1],split.list[j,1]] # is the split j downstream if(split.list[j,1]%in%descendants[split.list[i,1],]){ # downstream distances[i,j]<-distances[i,j]-(tree$edge.length[match(split.list[j,1],tree$edge[,2])]-split.list[j,2]) distances[i,j]<-distances[i,j]+(tree$edge.length[match(split.list[i,1],tree$edge[,2])]-split.list[i,2]) } else if(split.list[i,1]%in%descendants[split.list[j,1],]){ # ancestral distances[i,j]<-distances[i,j]-(tree$edge.length[match(split.list[i,1],tree$edge[,2])]-split.list[i,2]) distances[i,j]<-distances[i,j]+(tree$edge.length[match(split.list[j,1],tree$edge[,2])]-split.list[j,2]) } else { # neither distances[i,j]<-distances[i,j]-(tree$edge.length[match(split.list[i,1],tree$edge[,2])]-split.list[i,2]) distances[i,j]<-distances[i,j]-(tree$edge.length[match(split.list[j,1],tree$edge[,2])]-split.list[j,2]) } } distances[j,i]<-distances[i,j] } } } if(method=="sumsq") distances<-distances^2 if(method!="sumsq"&&method!="sum") message("allowable methods are 'sum' and 'sumsq' - using default method ('sum')") if(printD) print(distances) sum.dist<-colSums(distances) ind<-which.min(sum.dist) # this is the index of the minimum split # return minimum split return(list(node=split.list[ind,1],bp=split.list[ind,2])) } # function to analyze the posterior from evol.rate.mcmc() # written by Liam Revell 2011 posterior.evolrate<-function(tree,ave.shift,mcmc,tips,showTree=FALSE){ result<-matrix(NA,nrow(mcmc),7,dimnames=list(NULL,c("state","sig1","sig2","a","node","bp","likelihood"))) tree$node.label<-NULL for(i in 1:nrow(mcmc)){ shift=list(node=mcmc[i,"node"],bp=mcmc[i,"bp"]) temp<-ave.rates(tree,shift,tips[[i]],mcmc[i,"sig1"],mcmc[i,"sig2"],ave.shift,showTree=showTree) result[i,]<-c(mcmc[i,"state"],temp[[1]],temp[[2]],mcmc[i,"a"],mcmc[i,"node"],mcmc[i,"bp"],mcmc[i,"likelihood"]) } return(result) } # average the posterior rates # written by Liam Revell 2011 ave.rates<-function(tree,shift,tips,sig1,sig2,ave.shift,showTree=TRUE){ # first split and scale at shift unscaled<-splitTree(tree,shift) # now scale scaled<-unscaled if(length(setdiff(scaled[[1]]$tip.label,tips))!=1){ scaled[[1]]$edge.length<-scaled[[1]]$edge.length*sig1 scaled[[2]]$edge.length<-scaled[[2]]$edge.length*sig2 if(!is.null(scaled[[2]]$root.edge)) scaled[[2]]$root.edge<-scaled[[2]]$root.edge*sig2 } else { scaled[[1]]$edge.length<-scaled[[1]]$edge.length*sig2 scaled[[2]]$edge.length<-scaled[[2]]$edge.length*sig1 if(!is.null(scaled[[2]]$root.edge)) scaled[[2]]$root.edge<-scaled[[2]]$root.edge*sig1 } # now bind tr.scaled<-paste.tree(scaled[[1]],scaled[[2]]) if(showTree==TRUE) plot(tr.scaled) # now split tr.scaled and tree at ave.shift unscaled<-splitTree(tree,ave.shift) scaled<-splitTree(tr.scaled,ave.shift) # now compute the sig1 and sig2 to return sig1<-sum(scaled[[1]]$edge.length)/sum(unscaled[[1]]$edge.length) sig2<-sum(scaled[[2]]$edge.length)/sum(unscaled[[2]]$edge.length) return(list(sig1=sig1,sig2=sig2)) } ## a bunch of new S3 methods ## written by Liam J. Revell 2019 summary.evol.rate.mcmc<-function(object,...){ if(hasArg(burnin)) burnin<-list(...)$burnin else { burnin<-round(0.2*max(object$mcmc[,"state"])) cat("\nNo burn-in specified. Excluding the first 20% by default.\n\n") } if(hasArg(method)) method<-list(...)$method else method<-"sumsq" ii<-min(which(object$mcmc[,"state"]>=burnin)) mcmc<-object$mcmc[ii:nrow(object$mcmc),] tips<-object$tips[ii:length(object$tips)] tree<-object$tree ms<-minSplit(tree,mcmc,method=method) ps<-posterior.evolrate(tree,ms,mcmc,tips) prob<-(table(factor(ps[,"node"], levels=1:(Ntip(tree)+tree$Nnode)))/ nrow(ps))[tree$edge[,2]] result<-list(min.split=ms,posterior.rates=ps, hpd=setNames(list(HPD(ps[,"sig1"]), HPD(ps[,"sig2"])),c("sig1","sig2")), edge.prob=prob, tree=tree,method=method) class(result)<-"summary.evol.rate.mcmc" result } HPD<-function(x){ if(.check.pkg("coda")) object<-HPDinterval(as.mcmc(x)) else { cat(" HPDinterval requires package coda.\n") cat(" Computing 95% interval from samples only.\n\n") object<-setNames(c(sort(x)[round(0.025*length(x))], sort(x)[round(0.975*length(x))]),c("lower", "upper")) attr(object, "Probability")<-0.95 } object } print.summary.evol.rate.mcmc<-function(x,...){ if(x$method=="sum") cat("\nThe shift location with the minimum distance to all shifts in the\n") else cat("\nThe shift with the minimum (squared) distance to all shifts in the\n") cat(paste("posterior set is found ",round(x$min.split$bp,4), " along the branch leading to node ", x$min.split$node,".\n",sep="")) cat("\nMean \'root-wise\' rate from the posterior sample (sig1): ") cat(round(mean(x$posterior[,"sig1"]),4)) cat(paste("\n 95% HPD for sig1: [",round(x$hpd[["sig1"]][1],4),", ", round(x$hpd[["sig1"]][2],4),"]",sep="")) cat("\nMean \'tip-wise\' rate from the posterior sample (sig2): ") cat(round(mean(x$posterior[,"sig2"]),4)) cat(paste("\n 95% HPD for sig1: [",round(x$hpd[["sig2"]][1],4),", ", round(x$hpd[["sig2"]][2],4),"]",sep="")) cat("\n\n") cat("To plot the mean shift point run plot(...,type=\"min.split\") on the object\n") cat("produced by this function.\n\n") cat("To plot the probability of a shift by edge run plot(...,method=\"edge.prob\")\n") cat("on the object produced by this function.\n\n") } HPD<-function(x){ if(.check.pkg("coda")) hpd<-HPDinterval(as.mcmc(x)) else { cat(" HPDinterval requires package coda.\n") cat(" Computing 95% interval from samples only.\n\n") hpd<-setNames(c(sort(x)[round(0.025*length(x))], sort(x)[round(0.975*length(x))]),c("lower", "upper")) attr(hpd, "Probability")<-0.95 } hpd } plot.summary.evol.rate.mcmc<-function(x,...){ if(hasArg(method)) method<-list(...)$method else method<-"min.split" if(method=="min.split"){ if(hasArg(cex)) cex<-list(...)$cex else cex<-0.5 if(hasArg(lwd.split)) lwd.split<-list(...)$lwd.split else lwd.split<-4 if(hasArg(col.split)) col.split<-list(...)$col.split else col.split<-"red" if(hasArg(col)) col<-list(...)$col else col<-setNames(c("blue","red"),1:2) if(is.null(names(col))) names(col)<-1:2 ii<-which(x$tree$edge[,2]==x$min.split$node) plot(paintSubTree(x$tree,node=x$min.split$node,"2", stem=(x$tree$edge.length[ii]-x$min.split$bp)/ x$tree$edge.length[ii]),col,...) pp<-get("last_plot.phylo",envir=.PlotPhyloEnv) h<-nodeheight(x$tree,getParent(x$tree, x$min.split$node))+x$min.split$bp lines(rep(h,2),rep(pp$yy[x$min.split$node],2)+ cex*c(-1,1),lwd=lwd.split, col=col.split,lend=2) } else if(method=="edge.prob"){ if(hasArg(cex)) cex<-list(...)$cex else cex<-0.5 if(hasArg(piecol)) piecol<-list(...)$piecol else piecol<-c("darkgrey","white") plotTree(x$tree,...) edgelabels(pie=cbind(x$edge.prob,1-x$edge.prob), cex=cex,piecol=piecol) } } phytools/R/densityMap.R0000644000176200001440000002514114426040122014572 0ustar liggesusers# function plots posterior density of mapped states from stochastic mapping # written by Liam J. Revell 2012, 2013, 2014, 2015, 2016, 2021, 2022, 2023 densityMap<-function(trees,res=100,fsize=NULL,ftype=NULL,lwd=3,check=FALSE,legend=NULL, outline=FALSE,type="phylogram",direction="rightwards",plot=TRUE,...){ if(hasArg(mar)) mar<-list(...)$mar else mar<-rep(0.3,4) if(hasArg(offset)) offset<-list(...)$offset else offset<-NULL if(hasArg(states)) states<-list(...)$states else states<-NULL if(hasArg(hold)) hold<-list(...)$hold else hold<-TRUE if(length(lwd)==1) lwd<-rep(lwd,2) else if(length(lwd)>2) lwd<-lwd[1:2] tol<-1e-10 if(!inherits(trees,"multiPhylo")&&inherits(trees,"phylo")) stop("trees not \"multiPhylo\" object; just use plotSimmap.") if(!inherits(trees,"multiPhylo")) stop("trees should be an object of class \"multiPhylo\".") h<-sapply(unclass(trees),function(x) max(nodeHeights(x))) steps<-0:res/res*max(h) trees<-rescaleSimmap(trees,totalDepth=max(h)) if(check){ X<-matrix(FALSE,length(trees),length(trees)) for(i in 1:length(trees)) X[i,]<-sapply(trees,all.equal.phylo,current=trees[[i]]) if(!all(X)) stop("some of the trees don't match in topology or relative branch lengths") } tree<-trees[[1]] trees<-unclass(trees) if(is.null(states)) ss<-sort(unique(c(getStates(tree,"nodes"),getStates(tree,"tips")))) else ss<-states if(!all(ss==c("0","1"))){ c1<-paste(sample(c(letters,LETTERS),6),collapse="") c2<-paste(sample(c(letters,LETTERS),6),collapse="") trees<-lapply(trees,mergeMappedStates,ss[1],c1) trees<-lapply(trees,mergeMappedStates,ss[2],c2) trees<-lapply(trees,mergeMappedStates,c1,"0") trees<-lapply(trees,mergeMappedStates,c2,"1") } H<-nodeHeights(tree) message("sorry - this might take a while; please be patient") tree$maps<-vector(mode="list",length=nrow(tree$edge)) for(i in 1:nrow(tree$edge)){ YY<-cbind(c(H[i,1],steps[intersect(which(steps>H[i,1]),which(stepsH[i,1]),which(steps1){ for(k in 2:length(trees[[j]]$maps[[i]])){ XX[k,1]<-XX[k-1,2] XX[k,2]<-XX[k,1]+trees[[j]]$maps[[i]][k] } } for(k in 1:nrow(YY)){ lower<-which(XX[,1]<=YY[k,1]); lower<-lower[length(lower)] upper<-which(XX[,2]>=(YY[k,2]-tol))[1]; AA<-0 names(lower)<-names(upper)<-NULL if(!all(XX==0)){ for(l in lower:upper) AA<-AA+(min(XX[l,2],YY[k,2])-max(XX[l,1],YY[k,1]))/(YY[k,2]- YY[k,1])*as.numeric(rownames(XX)[l]) } else AA<-as.numeric(rownames(XX)[1]) ZZ[k]<-ZZ[k]+AA/length(trees) } } tree$maps[[i]]<-YY[,2]-YY[,1] names(tree$maps[[i]])<-round(ZZ*1000) } cols<-rainbow(1001,start=0.7,end=0); names(cols)<-0:1000 tree$mapped.edge<-makeMappedEdge(tree$edge,tree$maps) tree$mapped.edge<-tree$mapped.edge[,order(as.numeric(colnames(tree$mapped.edge)))] class(tree)<-c("simmap",setdiff(class(tree),"simmap")) attr(tree,"map.order")<-"right-to-left" x<-list(tree=tree,cols=cols,states=ss) class(x)<-"densityMap" if(plot) plot.densityMap(x,fsize=fsize,ftype=ftype,lwd=lwd,legend=legend,outline=outline, type=type,mar=mar,direction=direction,offset=offset,hold=hold) invisible(x) } ## S3 plot method for objects of class "densityMap" ## also used internally by plot.contMap ## written by Liam J. Revell 2012, 2013, 2014, 2015, 2016, 2020, 2022, 2023 plot.densityMap<-function(x,...){ if(inherits(x,"densityMap")){ tree<-x$tree cols<-x$cols } else stop("x should be an object of class \"densityMap\"") H<-nodeHeights(tree) # get & set optional arguments if(hasArg(legend)) legend<-list(...)$legend else legend<-NULL if(hasArg(fsize)) fsize<-list(...)$fsize else fsize<-NULL if(hasArg(ftype)) ftype<-list(...)$ftype else ftype<-NULL if(hasArg(outline)) outline<-list(...)$outline else outline<-FALSE if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-3 if(length(lwd)==1) lwd<-rep(lwd,2) else if(length(lwd)>2) lwd<-lwd[1:2] if(hasArg(leg.txt)) leg.txt<-list(...)$leg.txt else leg.txt<-c("0",paste("PP(state=",x$states[2],")",sep=""),"1") if(hasArg(type)) type<-list(...)$type else type<-"phylogram" if(hasArg(mar)) mar<-list(...)$mar else mar<-rep(0.3,4) if(hasArg(direction)) direction<-list(...)$direction else direction<-"rightwards" if(hasArg(offset)) offset<-list(...)$offset else offset<-NULL if(hasArg(xlim)) xlim<-list(...)$xlim else xlim<-NULL if(hasArg(ylim)) ylim<-list(...)$ylim else ylim<-NULL if(hasArg(hold)) hold<-list(...)$hold else hold<-TRUE if(hasArg(underscore)) underscore<-list(...)$underscore else underscore<-FALSE if(is.null(legend)) legend<-if(type=="arc") max(H) else 0.5*max(H) if(is.null(fsize)) fsize<-c(1,1) if(length(fsize)==1) fsize<-rep(fsize,2) if(is.null(ftype)) ftype<-c("i","reg") if(length(ftype)==1) ftype<-c(ftype,"reg") if(hasArg(arc_height)) arc_height<-list(...)$arc_height else arc_height<-2 # done optional arguments if(legend){ if(legend>max(H)&&type!="arc"){ message("legend scale cannot be longer than total tree length; resetting") legend<-0.5*max(H) } } if(hold) null<-dev.hold() if(type=="phylogram"){ if(direction%in%c("upwards","downwards")&&legend){ par(mar=mar) plot.new() } N<-length(tree$tip.label) if(legend&&is.null(ylim)){ if(direction%in%c("rightwards","leftwards")) ylim<-c(1-0.12*(N-1),N) else { pp<-par("pin")[2] sw<-(fsize*(max(strwidth(x$tree$tip.label,units="inches")))+ 1.37*fsize*strwidth("W",units="inches"))[1] alp<-optimize(function(a,H,sw,pp) (a*1.2*max(H)+sw-pp)^2,H=H,sw=sw,pp=pp, interval=c(0,1e6))$minimum ylim<-if(direction=="downwards") c(min(H)-sw/alp-0.16*max(H),max(H)) else c(min(H)-0.16*max(H),max(H)+sw/alp) } } else if(is.null(ylim)) ylim<-NULL if(outline){ COL<-par()$col par(col="transparent") plotTree(tree,fsize=fsize[1],lwd=lwd[1]+2, offset=offset+0.2*lwd[1]/3+0.2/3, color=par()$fg, ftype=ftype[1],xlim=xlim, ylim=ylim,mar=mar,direction=direction,hold=FALSE, add=direction%in%c("upwards","downwards")&&legend, underscore=underscore) par(col=COL) } plotSimmap(tree,cols,pts=FALSE,lwd=lwd[1],fsize=fsize[1],mar=mar,ftype=ftype[1],add=outline, xlim=xlim,ylim=ylim,direction=direction,offset=offset,hold=FALSE,underscore=underscore) if(legend){ ff<-function(dd){ if(!("."%in%dd)) dig<-0 else dig<-length(dd)-which(dd==".") dig } dig<-max(sapply(strsplit(leg.txt[c(1,3)],split=""),ff)) if(direction%in%c("rightwards","leftwards")) add.color.bar(legend,cols,title=leg.txt[2],lims<-as.numeric(leg.txt[c(1,3)]), digits=dig,prompt=FALSE,x=if(direction=="leftwards") max(H)-legend else 0, y=1-0.08*(N-1),lwd=lwd[2], fsize=fsize[2],outline=outline, direction=if(!is.null(xlim)) if(xlim[2]1) chk<-TRUE C[nn[i],j]<-sample(x=names(pp)[which(pp==max(pp))],size=1) } } if(chk){ cat("Note:\n") cat(" there may be more than one equally likely\n") cat(" joint reconstruction.\n") } ROOT<-Ntip(pw)+1 daughters<-pw$edge[which(pw$edge[,1]==ROOT),2] L[ROOT,]<-log(pi)+colSums(L[daughters,]) C[ROOT,]<-names(which(L[ROOT,]==max(L[ROOT,]))) cw<-reorder(pw) nn<-unique(as.vector(cw$edge)) states<-setNames(rep(NA,length(nn)),nn) states[1]<-C[ROOT,1] logL<-max(L[ROOT,]) for(i in 2:length(nn)){ mother<-cw$edge[which(cw$edge[,2]==nn[i]),1] states[i]<-C[nn[i],states[as.character(mother)]] } M<-matchNodes(tree,tt,method="distances") anc<-setNames(states[as.character(M[,2])],M[,1]) if(tips){ pp<-sapply(1:Ntip(tt),getParent,tree=tt) anc<-c(setNames(states[as.character(pp)],tt$tip.label[1:Ntip(tt)]), anc) } attr(logL,"df")<-length(anc) object<-list(ace=as.factor(anc),logLik=logL) object } ## plot method for "ancr" object class plot.ancr<-function(x,args.plotTree=list(...),args.nodelabels=list(...),...){ TREE<-attr(x,"tree") TYPE<-attr(x,"type") args.plotTree$tree<-TREE if(is.null(args.plotTree$type)) args.plotTree$type<-"phylogram" if(is.null(args.plotTree$direction)) args.plotTree$direction<-"rightwards" if(is.null(args.plotTree$fsize)){ if(args.plotTree$type%in%c("phylogram","cladogram")){ if(args.plotTree$direction%in%c("rightwards","leftwards")) args.plotTree$fsize<-min(c(6*par()$pin[2]/Ntip(TREE),1)) else args.plotTree$fsize<-min(c(6*par()$pin[1]/Ntip(TREE),1)) } else { args.plotTree$fsize<-min(c(0.6*min(par()$pin)/sqrt(Ntip(TREE)),1)) } } if(is.null(args.plotTree$ftype)) args.plotTree$ftype<-"i" if(is.null(args.plotTree$lwd)) args.plotTree$lwd<-1 if(is.null(args.plotTree$offset)){ if(args.plotTree$type%in%c("phylogram","cladogram")){ if(args.plotTree$direction%in%c("rightwards","leftwards")) args.plotTree$offset<-0.4 else args.plotTree$offset<-1 } else args.plotTree$offset<-2 } do.call(plotTree,args.plotTree) if(TYPE=="marginal"){ if(nrow(x$ace)==Nnode(TREE)){ args.nodelabels$pie<-x$ace data<-attr(x,"data") } else if(nrow(x$ace)==(Ntip(TREE)+Nnode(TREE))){ args.nodelabels$pie<-x$ace[1:Nnode(TREE)+Ntip(TREE),,drop=FALSE] data<-x$ace[1:Ntip(TREE),,drop=FALSE] } else cat("Warning: wrong number of rows in input object.\n\n") } else if(TYPE=="joint"){ if(length(x$ace)==Nnode(TREE)){ data<-attr(x,"data") args.nodelabels$pie<-to.matrix(x$ace,colnames(data)) } else if(nrow(x$ace)==(Ntip(TREE)+Nnode(TREE))){ args.nodelabels$pie<-to.matrix(x$ace[1:Nnode(TREE)+Ntip(TREE)], colnames(attr(x,"data"))) data<-to.matrix(x$ace[1:Ntip(TREE)],colnames(attr(x,"data"))) } else cat("Warning: wrong number of elements in input object.\n\n") } if(is.null(args.nodelabels$cex)){ if(args.plotTree$type%in%c("phylogram","cladogram")){ if(args.plotTree$direction%in%c("rightwards","leftwards")) args.nodelabels$cex<-min(c(6*par()$pin[2]/Ntip(TREE),0.5)) else args.nodelabels$cex<-min(c(6*par()$pin[1]/Ntip(TREE),0.5)) } else { args.nodelabels$cex<-min(c(0.5*min(par()$pin)/sqrt(Ntip(TREE)),0.5)) } } k<-if(TYPE=="marginal") ncol(x$ace) else ncol(attr(x,"data")) if(is.null(args.nodelabels$piecol)){ args.nodelabels$piecol<-palette.colors(k,"Polychrome 36",recycle=TRUE) if(k>36) cat("Warning: maximum number of colors reached. Some colors are recycled.\n\n") } old_fg<-par()$fg par(fg="transparent") do.call(nodelabels,args.nodelabels) if(hasArg(args.tiplabels)) args.tiplabels<-list(...)$args.tiplabels else args.tiplabels<-list(...) args.tiplabels$piecol<-args.nodelabels$piecol args.tiplabels$pie<-data[TREE$tip.label,,drop=FALSE] if(is.null(args.tiplabels$cex)){ if(args.plotTree$type%in%c("phylogram","cladogram")){ if(args.plotTree$direction%in%c("rightwards","leftwards")) args.tiplabels$cex<-min(c(2*par()$pin[2]/Ntip(TREE),0.2)) else args.tiplabels$cex<-min(c(2*par()$pin[1]/Ntip(TREE),0.2)) } else args.tiplabels$cex<-min(c(0.25*min(par()$pin)/sqrt(Ntip(TREE)),0.25)) } do.call(tiplabels,args.tiplabels) par(fg=old_fg) if(hasArg(legend)) legend<-list(...)$legend else legend<-"bottomleft" if(legend!=FALSE){ legend(x=legend,legend=colnames(attr(x,"data")), pch=16,col=args.nodelabels$piecol, pt.cex=1.2,cex=0.8) } object<-list( fsize=args.plotTree$fsize, piecol=args.nodelabels$piecol, node_cex=args.nodelabels$cex, tip_cex=args.nodelabels$cex, legend=legend) invisible(object) } ancr<-function(object,...) UseMethod("ancr") ancr.default<-function(object,...){ warning(paste( "ancr does not know how to handle objects of class ", class(object),".\n")) } logLik.ancr<-function(object,...){ lik<-object$logLik attr(lik,"df")<-attr(object$logLik,"df") lik } print.ancr<-function(x,digits=6,printlen=6,...){ Nnode<-Nnode(attr(x,"tree")) if(!is.null(printlen)) if(printlen>Nnode) printlen<-Nnode if(attr(x,"type")=="marginal"){ cat("Marginal ancestral state estimates:\n") if (is.null(printlen)) print(round(x$ace,digits)) else { ii<-if(nrow(x$ace)>Nnode) 1:printlen+Ntip(attr(x,"tree")) else 1:printlen print(round(x$ace[ii,],digits)) cat("...\n") } } else if(attr(x,"type")=="joint"){ cat("Joint ancestral state estimates:\n") tmp<-data.frame(state=x$ace) if(is.null(printlen)) print(tmp) else { ii<-if(nrow(tmp)>Nnode) 1:printlen+Ntip(attr(x,"tree")) else 1:printlen print(tmp[ii,,drop=FALSE]) cat("...\n") } } cat(paste("\nLog-likelihood =",round(logLik(x), digits),"\n\n")) } ## marginal ancestral states for "anova.fitMk" object ancr.anova.fitMk<-function(object,...){ if(hasArg(weighted)) weighted<-list(...)$weighted else weighted<-TRUE if(hasArg(type)) type<-list(...)$type else type<-"marginal" if(type!="marginal"){ cat("\nOnly type=\"marginal\" supported for objects of class \"anova.fitMk\".\n") cat("Updating type.\n\n") type<-"marginal" } if(weighted){ w<-object$weight fits<-attr(object,"models") anc<-lapply(fits,function(x,...) ancr(x,...)$ace,...) ss<-sort(unique(unlist(lapply(anc,colnames)))) if(any(sapply(attr(object,"models"),class)=="fitHRM")){ for(i in 1:length(anc)){ tmp<-anc[[i]] anc[[i]]<-matrix(0,nrow(tmp),length(ss), dimnames=list(rownames(tmp),ss)) anc[[i]][rownames(tmp),colnames(tmp)]<-tmp } } anc<-mapply("*",anc,w,SIMPLIFY=FALSE) anc<-Reduce("+",anc) foo<-function(obj) unclass(as.Qmatrix(obj)) Q<-lapply(fits,foo) if(any(sapply(attr(object,"models"),class)=="fitHRM")){ for(i in 1:length(Q)){ tmp<-Q[[i]] Q[[i]]<-matrix(0,length(ss),length(ss), dimnames=list(ss,ss)) Q[[i]][rownames(tmp),colnames(tmp)]<-tmp } } Q<-mapply("*",Q,w,SIMPLIFY=FALSE) Q<-Reduce("+",Q) model<-matrix(0,nrow(Q),ncol(Q)) k<-nrow(Q)*(nrow(Q)-1) model[col(model)!=row(model)]<-1:k q<-sapply(1:k,function(i,Q,model) Q[which(model==i)], Q=Q,model=model) TREE<-fits[[1]]$tree DATA<-fits[[1]]$data if(any(sapply(attr(object,"models"),class)=="fitHRM")){ levs<-unique(gsub("*","",ss,fixed=TRUE)) tmp<-DATA[,levs] DATA<-matrix(0,nrow(tmp),length(ss), dimnames=list(rownames(tmp),ss)) for(i in 1:nrow(tmp)){ for(j in 1:length(levs)){ DATA[i,grep(levs[j],ss)]<-tmp[i,levs[j]] } } } log_lik<-pruning(q,TREE,DATA,model=model) attr(log_lik,"df")<-max(model) obj<-list(ace=anc,logLik=log_lik) attr(obj,"tree")<-TREE attr(obj,"data")<-DATA attr(obj,"type")<-"marginal" class(obj)<-"ancr" return(obj) } else { best<-which(object$AIC==min(object$AIC)) fits<-attr(object,"models") return(ancr(fits[[best]],...)) } } ## marginal ancestral states for "fitHRM" object ancr.fitHRM<-function(object,...) ancr.fitMk(object,...) hide.hidden<-function(object,...) UseMethod("hide.hidden") hide.hidden.default<-function(object,...){ warning(paste( "hide.hidden does not know how to handle objects of class ", class(object),".\n")) } hide.hidden.ancr<-function(object,...){ ss<-colnames(object$ace) ii<-grep("*",ss,fixed=TRUE) if(length(ii)>0) ss<-ss[-ii] anc<-matrix(0,nrow(object$ace),length(ss), dimnames=list(rownames(object$ace),ss)) for(i in 1:length(ss)){ anc[,ss[i]]<-rowSums(object$ace[,grep(ss[i], colnames(object$ace)),drop=FALSE]) } anc } ## marginal ancestral states for "fitpolyMk" object ancr.fitpolyMk<-function(object,...) ancr.fitMk(object,...) ## marginal ancestral states for "fitMk" object ancr.fitMk<-function(object,...){ if(hasArg(type)) type<-list(...)$type else type<-"marginal" if(hasArg(tips)) tips<-list(...)$tips else tips<-FALSE x<-object$data tree<-object$tree q<-object$rates model<-object$index.matrix model[is.na(model)]<-0 pi<-object$pi if(type=="marginal"){ plik<-pruning(q,tree,x,model=model,pi=pi, return="conditional") ace<-marginal_asr(q,tree,plik,model,tips) result<-list(ace=ace, logLik=pruning(q,tree,x,model=model,pi=pi)) attr(result$logLik,"df")<-max(model) attr(result,"type")<-"marginal" attr(result,"tree")<-tree attr(result,"data")<-x class(result)<-"ancr" } else if(type=="joint"){ if(hasArg(tol)) tol<-list(...)$tol else tol<-1e-12 result<-joint_asr(q,tree,x,pi,model,tips,tol) attr(result,"type")<-"joint" attr(result,"tree")<-tree attr(result,"data")<-x class(result)<-"ancr" } result } pruning<-function(q,tree,x,model=NULL,...){ if(hasArg(return)) return<-list(...)$return else return<-"likelihood" pw<-if(!is.null(attr(tree,"order"))&& attr(tree,"order")=="postorder") tree else reorder(tree,"postorder") k<-ncol(x) if(is.null(model)){ model<-matrix(1,k,k) diag(model)<-0 } if(hasArg(pi)) pi<-list(...)$pi else pi<-rep(1/k,k) Q<-matrix(0,k,k) Q[]<-c(0,q)[model+1] diag(Q)<--rowSums(Q) L<-rbind(x[pw$tip.label,], matrix(0,pw$Nnode,k, dimnames=list(1:pw$Nnode+Ntip(pw)))) nn<-unique(pw$edge[,1]) pp<-vector(mode="numeric",length=length(nn)) root<-min(nn) for(i in 1:length(nn)){ ee<-which(pw$edge[,1]==nn[i]) PP<-matrix(NA,length(ee),k) for(j in 1:length(ee)){ P<-expm(Q*pw$edge.length[ee[j]]) PP[j,]<-P%*%L[pw$edge[ee[j],2],] } L[nn[i],]<-apply(PP,2,prod) if(nn[i]==root){ if(pi[1]=="fitzjohn") pi<-L[nn[i],]/sum(L[nn[i],]) L[nn[i],]<-pi*L[nn[i],] } pp[i]<-sum(L[nn[i],]) L[nn[i],]<-L[nn[i],]/pp[i] } prob<-sum(log(pp)) if(return=="likelihood") if(is.na(prob)||is.nan(prob)) return(-Inf) else return(prob) else if(return=="conditional") L else if(return=="pi") pi } marginal_asr<-function(q,tree,L,model=NULL,tips=FALSE){ pw<-reorder(tree,"postorder") k<-ncol(L) if(is.null(model)){ model<-matrix(1,k,k) diag(model)<-0 } Q<-matrix(0,k,k) Q[]<-c(0,q)[model+1] diag(Q)<--rowSums(Q) nn<-unique(pw$edge[,1]) for(i in length(nn):1){ ee<-which(pw$edge[,1]==nn[i]) for(j in 1:length(ee)){ P<-expm(Q*pw$edge.length[ee[j]]) pp<-t(L[nn[i],]/(P%*%L[pw$edge[ee[j],2],])) pp[is.nan(pp)]<-0 L[pw$edge[ee[j],2],]<-(pp%*%P)* L[pw$edge[ee[j],2],] } } anc<-L/rep(rowSums(L),k) if(tips) anc else anc[1:Nnode(tree)+Ntip(tree),] } ## marginal ancestral states for "fitgammaMk" object ancr.fitgammaMk<-function(object,...){ if(hasArg(type)) type<-list(...)$type else type<-"marginal" if(hasArg(tips)) tips<-list(...)$tips else tips<-FALSE x<-object$data tree<-object$tree q<-object$rates alpha<-object$alpha nrates<-object$nrates model<-object$index.matrix model[is.na(model)]<-0 pi<-object$pi if(type=="marginal"){ plik<-gamma_pruning(c(q,alpha),nrates,tree,x, model=model,median=TRUE,pi=pi,return="conditional") ace<-marginal_asr_gamma(q,alpha,nrates,tree,plik, model,tips) result<-list(ace=ace, logLik=gamma_pruning(c(q,alpha),nrates,tree,x, model=model,pi=pi)) attr(result$logLik,"df")<-max(model) attr(result,"type")<-"marginal" attr(result,"tree")<-tree attr(result,"data")<-x class(result)<-"ancr" } else if(type=="joint"){ ## turned off for now # if(hasArg(tol)) tol<-list(...)$tol # else tol<-1e-12 # result<-joint_asr(q,tree,x,pi,model,tips,tol) # attr(result,"type")<-"joint" # attr(result,"tree")<-tree # attr(result,"data")<-x # class(result)<-"ancr" msg<-paste("type = \"joint\" does not yet work", "for this object class.") stop(msg) } result } marginal_asr_gamma<-function(q,alpha,nrates,tree,L, model=NULL,tips=FALSE){ median<-TRUE if(median){ r<-qgamma(seq(1/(2*nrates),1,by=1/nrates),alpha,alpha) r<-r/mean(r) } else { stop("This does not work yet.\n") } pw<-reorder(tree,"postorder") k<-ncol(L) if(is.null(model)){ model<-matrix(1,k,k) diag(model)<-0 } Q<-matrix(0,k,k) Q[]<-c(0,q)[model+1] diag(Q)<--rowSums(Q) nn<-unique(pw$edge[,1]) for(i in length(nn):1){ ee<-which(pw$edge[,1]==nn[i]) for(j in 1:length(ee)){ P<-Reduce("+",lapply(r, function(rr,k,Q,edge) EXPM(Q*rr*edge)/k, k=nrates,Q=Q,edge=pw$edge.length[ee[j]])) ## P<-expm(Q*pw$edge.length[ee[j]]) pp<-t(L[nn[i],]/(P%*%L[pw$edge[ee[j],2],])) pp[is.nan(pp)]<-0 L[pw$edge[ee[j],2],]<-(pp%*%P)* L[pw$edge[ee[j],2],] } } anc<-L/rep(rowSums(L),k) if(tips) anc else anc[1:Nnode(tree)+Ntip(tree),] }phytools/R/fitBiogeog.R0000644000176200001440000001023714533756271014555 0ustar liggesusers## first biogeographic (DEC) model (still in progress) fitBiogeog<-function(tree,x,model="DEC",...){ if(hasArg(min.q)) min.q<-list(...)$min.q else min.q<-1e-12 if(hasArg(max.q)) max.q<-list(...)$max.q else max.q<-max(nodeHeights(tree))*100 if(model=="DEC") model<-"ARD" if(hasArg(quiet)) quiet<-list(...)$quiet else quiet<-FALSE if(is.factor(x)) x<-setNames(as.character(x),names(x)) if(is.matrix(x)) X<-strsplit(colnames(x),"+",fixed=TRUE) else X<-strsplit(x,"+",fixed=TRUE) ns<-sapply(X,length) ## get the regions regions<-sort(unique(unlist(X))) nn<-length(regions) ## fix the order of the input data if(is.matrix(x)){ Levs<-sapply(X,function(x) paste(sort(x),collapse="+")) colnames(x)<-Levs } else x<-sapply(X,function(x) paste(sort(x),collapse="+")) ss<-vector() for(i in 1:length(regions)) ss<-c(ss,apply(Combinations(length(regions),i,regions), 1,paste,collapse="+")) if(!any(ss=="0")) ss<-c(0,ss) tmodel<-matrix(0,length(ss),length(ss),dimnames=list(ss,ss)) poly<-strsplit(ss,"+",fixed=TRUE) index<-0 tmodel[1,]<-rep(0,ncol(tmodel)) E<-setNames(rep(0,nn),regions) D<-matrix(rep(0,nn*nn),nn,nn,dimnames=list(regions,regions)) if(model=="ER"){ E[]<-1 D[]<-2 diag(D)<-0 } else if(model=="ARD"){ E[]<-1:nn ind<-(nn+1) for(i in 1:nn) for(j in 1:nn){ if(i!=j){ D[i,j]<-ind ind<-ind+1 } } } for(i in 2:nrow(tmodel)){ for(j in 1:ncol(tmodel)){ if(i==j) tmodel[i,j]<-0 else { INT<-intersect(poly[[i]],poly[[j]]) SDij<-setdiff(poly[[i]],poly[[j]]) SDji<-setdiff(poly[[j]],poly[[i]]) if(length(INT)==0){ if(length(SDji)==1&&length(SDij)==1&&SDji=="0") tmodel[i,j]<-E[SDij] } else { if(length(SDji)==0&&length(SDij)==1) tmodel[i,j]<-E[SDij] else if(length(SDij)==0&&length(SDji)==1){ print(paste(paste(poly[[i]],collapse="+"),"->",paste(poly[[j]],collapse="+"))) tmp<-D[poly[[i]],SDji] tmodel[i,j]<-if(length(tmp)==1) tmp else paste(tmp,collapse="+") } } } } } if(!quiet){ cat("\nThis is the design matrix of the fitted model.\nDoes it make sense?\n\n") print(tmodel) cat("\n") flush.console() } if(is.matrix(x)){ X<-matrix(0,nrow(x),length(ss),dimnames=list(rownames(x),ss)) X[rownames(x),colnames(x)]<-x } else X<-to.matrix(x,ss) ## initialize q q.init<-rexp(n=max(D)) ## optimize the likelihood pw<-reorder(tree,"postorder") lik_func<-function(p) -biogeog_pruning(exp(p),tree=pw,x=X,model=tmodel) dec_fit<-nlminb(log(q.init),lik_func) print(dec_fit) return(dec_fit) } biogeog_pruning<-function(q,tree,x,model=NULL,...){ if(hasArg(return)) return<-list(...)$return else return<-"likelihood" pw<-if(!is.null(attr(tree,"order"))&& attr(tree,"order")=="postorder") tree else reorder(tree,"postorder") k<-ncol(x) if(hasArg(pi)) pi<-list(...)$pi else pi<-rep(1/k,k) Q<-matrix(0,k,k) colnames(Q)<-rownames(Q)<-colnames(model) for(i in 1:nrow(model)){ for(j in 1:ncol(model)){ if(model[i,j]!="0"){ ind<-as.numeric(strsplit(model[i,j],"+",fixed=TRUE)[[1]]) Q[i,j]<-sum(q[ind]) } } } diag(Q)<--rowSums(Q) print(Q) L<-rbind(x[pw$tip.label,], matrix(0,tree$Nnode,k, dimnames=list(1:tree$Nnode+Ntip(tree)))) nn<-unique(pw$edge[,1]) pp<-vector(mode="numeric",length=length(nn)) root<-min(nn) for(i in 1:length(nn)){ ee<-which(pw$edge[,1]==nn[i]) PP<-matrix(NA,length(ee),k) for(j in 1:length(ee)){ P<-expm(Q*pw$edge.length[ee[j]]) PP[j,]<-P%*%L[pw$edge[ee[j],2],] } L[nn[i],]<-apply(PP,2,prod) if(nn[i]==root){ if(pi[1]=="fitzjohn") pi<-L[nn[i],]/sum(L[nn[i],]) L[nn[i],]<-pi*L[nn[i],] } pp[i]<-sum(L[nn[i],]) L[nn[i],]<-L[nn[i],]/pp[i] } prob<-sum(log(pp)) print(prob) if(return=="likelihood") if(is.na(prob)||is.nan(prob)) return(-Inf) else return(prob) else if(return=="conditional") L else if(return=="pi") pi } phytools/R/read.newick.R0000644000176200001440000000707114375517350014670 0ustar liggesusers## function to read a Newick string with node labels & (possible) singles ## written by Liam J. Revell 2013, 2014, 2015, 2017 read.newick<-function(file="",text,...){ # check to see if reading from file if(file!="") text<-scan(file,sep="\n",what="character",...) if(length(text)>1){ tree<-lapply(text,newick) class(tree)<-"multiPhylo" } else tree<-newick(text) return(tree) } # main Newick string function # written by Liam J. Revell 2013, 2014 newick<-function(text){ text<-unlist(strsplit(text, NULL)) tip.label<-vector(mode="character") node.label<-vector(mode="character") edge<-matrix(NA,sum(text=="(")+sum(text==","),2) ei<-vector() edge.length<-vector() currnode<-1 Nnode<-currnode i<-j<-k<-1 while(text[i]!=";"){ if(text[i]=="("){ edge[j,1]<-currnode i<-i+1 # is the next element a label? if(is.na(match(text[i],c("(",")",",",":",";")))){ temp<-getLabel(text,i) tip.label[k]<-temp$label i<-temp$end edge[j,2]<--k k<-k+1 # is there a branch length? if(text[i]==":"){ temp<-getEdgeLength(text,i) edge.length[j]<-temp$edge.length i<-temp$end } } else if(text[i]=="("){ Nnode<-Nnode+1 # creating a new internal node currnode<-Nnode edge[j,2]<-currnode # move to new internal node ei[currnode]<-j } j<-j+1 } else if(text[i]==")"){ i<-i+1 # is the next element a label? if(is.na(match(text[i],c("(",")",",",":",";")))){ temp<-getLabel(text,i) node.label[currnode]<-temp$label i<-temp$end } else node.label[currnode]<-NA ii<-ei[currnode] # is there a branch length? if(text[i]==":"){ temp<-getEdgeLength(text,i) if(currnode>1) edge.length[ii]<-temp$edge.length else root.edge<-temp$edge.length i<-temp$end } if(currnode>1) currnode<-edge[ii,1] # move down the tree ` } else if(text[i]==","){ edge[j,1]<-currnode i<-i+1 # is the next element a label? if(is.na(match(text[i],c("(",")",",",":",";")))){ temp<-getLabel(text,i) tip.label[k]<-temp$label i<-temp$end edge[j,2]<--k k<-k+1 # is there a branch length? if(text[i]==":"){ temp<-getEdgeLength(text,i) edge.length[j]<-temp$edge.length i<-temp$end } } else if(text[i]=="("){ Nnode<-Nnode+1 # creating a new internal node currnode<-Nnode edge[j,2]<-currnode # move to internal node ei[currnode]<-j } j<-j+1 } } Ntip<-k-1 edge<-edge[!is.na(edge[,2]),,drop=F] edge[edge>0]<-edge[edge>0]+Ntip edge[edge<0]<--edge[edge<0] edge.length[is.na(edge.length)]<-0 if(length(edge.length)==0) edge.length<-NULL if(all(is.na(node.label))) node.label<-NULL else node.label[is.na(node.label)]<-"" # assemble into "phylo" object tree<-list(edge=edge,Nnode=as.integer(Nnode),tip.label=tip.label, edge.length=edge.length,node.label=node.label) class(tree)<-"phylo" attr(tree,"order")<-"cladewise" tree } # function gets label # written by Liam J. Revell 2011-2013, 2014 getLabel<-function(text,start,stop.char=c(",",":",")",";")){ i<-0 while(is.na(match(text[i+start],stop.char))) i<-i+1 label<-paste(text[0:(i-1)+start],collapse="") return(list(label=paste(label,collapse=""),end=i+start)) } # function gets branch length # written by Liam J. Revell 2011-2013, 2014 getEdgeLength<-function(text,start){ i<-start+1 stop.char<-c(",",")",";") while(is.na(match(text[i],stop.char))) i<-i+1 edge.length<-as.numeric(paste(text[(start+1):(i-1)],collapse="")) return(list(edge.length=edge.length,end=i)) } phytools/R/plotTree.datamatrix.R0000644000176200001440000000510414375517350016424 0ustar liggesusers## function to plot a grid of discrete character data next to the tips of a tree ## written by Liam J. Revell 2018, 2020, 2021 plotTree.datamatrix<-function(tree,X,...){ N<-Ntip(tree) ss<-lapply(X,function(x) levels(x)) k<-sapply(ss,length) if(hasArg(fsize)) fsize<-list(...)$fsize else fsize<-40*par()$pin[2]/par()$pin[1]/Ntip(tree) if(hasArg(xexp)) xexp<-list(...)$xexp else xexp<-1.3 if(hasArg(yexp)) yexp<-list(...)$yexp else yexp<-1.05 if(hasArg(colors)) colors<-list(...)$colors else { chk<-.check.pkg("RColorBrewer") if(!chk) brewer.pal<-function(...) NULL else { if(hasArg(palettes)) palettes<-list(...)$palettes else { palettes<-c("Accent","Dark2","Paired","Pastel1","Pastel2", "Set1","Set2","Set3") } while(length(palettes)tol){ Q<-Qp NNIs<-.uncompressTipLabel(nni(curr)) curr<-list(curr) class(curr)<-"multiPhylo" NNIs<-c(NNIs,curr) NNIs<-lapply(NNIs,nnls.tree,dm=D,method=method,trace=0, tip.dates=tip.dates) qs<-sapply(NNIs,rss,D=D) ii<-which(qs==min(qs))[1] if(!quiet) message(paste("Best Q =",qs[ii])) Qp<-qs[ii] curr<-NNIs[[ii]] ct<-ct+1 } if(!quiet) message(paste("Solution found after",ct, "set of nearest neighbor interchanges.")) } else if(!quiet) message(paste("No optimization of topology performed.", "Returning start tree with LS edge lengths.")) curr } rss<-function(D,tree){ Dp<-cophenetic(tree)[rownames(D),colnames(D)] sum((D-Dp)^2)/2 } minTreeDist<-function(tree,trees,method="quadratic.path.difference",...){ if(is.null(tree$edge.length)) tree$edge.length<-runif(n=nrow(tree$edge)) e<-tree$edge.length fn<-function(e,tree,trees,m){ tree$edge.length<-e if(method=="quadratic.path.difference") d<-qpd(tree,trees) else d<-sapply(trees,function(x,y) treedist(x,y)[m], y=tree) sum(d^2) } fit<-optim(e,fn,tree=tree,trees=trees,m=method,lower=0, method="L-BFGS-B",...) tree$edge.length<-fit$par attr(tree,"SQD")<-fit$value tree } averageTree<-function(trees,start=NULL,method="quadratic.path.difference", tol=1e-12,quiet=FALSE,...){ if(!quiet) message(paste( "\n Function is attempting to find the phylogeny with ", "\n minimum distance to all trees in set under the ", "\n \"", paste(strsplit(method,"[.]")[[1]],collapse=" "), "\" criterion...\n",sep="")) if(is.null(start)){ if(method%in%c("symmetric.difference","path.difference")) start<-multi2di(consensus(trees,p=0.5),random=FALSE) else start<-ls.consensus(trees,quiet=TRUE) } if(method%in%c("branch.score.difference","quadratic.path.difference")){ D<-Reduce("+",lapply(trees,function(x,t) cophenetic(x)[t,t], t=trees[[1]]$tip.label))/length(trees) rt<-all(sapply(trees,is.ultrametric)) nnls.method<-if(rt) "ultrametric" else "unrooted" } else if(method%in%c("symmetric.difference","path.difference")){ rt<-all(sapply(trees,is.rooted)) if(!rt) start<-unroot(start) } curr<-start SS<-Inf SSp<-sum(sapply(trees,function(x,y,m) treedist(x,y)[m], y=curr,m=method)^2) ct<-0 while((SS-SSp)>tol){ SS<-SSp NNIs<-.uncompressTipLabel(nni(curr)) curr<-list(curr) class(curr)<-"multiPhylo" NNIs<-c(NNIs,curr) if(method=="symmetric.difference") SSp<-colSums(sapply(NNIs,RF.dist,tree2=trees)^2) else if(method=="path.difference") SSp<-colSums(sapply(NNIs,function(x,y,m) sapply(y, function(y,x,m) setNames(treedist(y,x)[m],NULL), y=x,m=m),y=trees,m=method)^2) else { if(nnls.method=="unrooted") NNIs<-lapply(NNIs,unroot) NNIs<-lapply(NNIs,nnls.tree,dm=D,method=nnls.method,trace=0) NNIs<-lapply(NNIs,minTreeDist,trees=trees,method=method, ...) SSp<-sapply(NNIs,function(x) attr(x,"SQD")) } ii<-which(SSp==min(SSp))[1] if(!quiet) message(paste(" Best SS so far =",SSp[ii])) SSp<-SSp[ii] curr<-NNIs[[ii]] plotTree(curr) ct<-ct+1 } if(!quiet) message(paste("\n Solution found after",ct, "set of nearest neighbor interchanges.\n")) curr } qpd<-function(t1,t2){ if(inherits(t1,"phylo")) t1<-list(t1) if(inherits(t2,"phylo")) t2<-list(t2) tips<-t1[[1]]$tip.label P1<-lapply(t1,function(x) cophenetic(x)[tips,tips]) P2<-lapply(t2,function(x) cophenetic(x)[tips,tips]) foo<-function(x,y) sqrt(sum((x-y)^2/2)) sapply(P2,function(x,y) sapply(y,foo,y=x),y=P1) } TREEDIST<-function(t1,t2,method){ obj<-if(method=="symmetric.difference") RF.dist(t1,t2) else if(method=="path.difference") path.dist(t1,t2) else if(method=="weighted.path.difference") path.dist(t1,t2,use.weight=TRUE) else if(method=="branch.score.difference") KF.dist(t1,t2) obj }phytools/R/evol.vcv.R0000644000176200001440000001713214375517350014237 0ustar liggesusers# this function fits the model of Revell & Collar (2009; Evolution) # written by Liam J. Revell 2010, 2011, 2013, 2014, 2015, 2016, 2020, 2021 evol.vcv<-function(tree,X,maxit=2000,vars=FALSE,...){ ## start checks if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".") ## end checks ## likelihood functions (to be used internally) # compute the log-likelihood (from the cholesky matrices) lik.chol<-function(theta,y,C,D,E){ m<-length(y)/dim(C[[1]])[1] n<-length(y)/m p<-length(C) cholR<-array(data=0,dim=c(m,m,p)) l<-1 for(i in 1:p) for(j in 1:m) for(k in j:m){ cholR[j,k,i]<-theta[l] l<-l+1 } V<-matrix(0,nrow(D),nrow(D)) for(i in 1:p) V<-V+kronecker(t(cholR[,,i])%*%cholR[,,i],C[[i]]) V<-V+E a<-solve(t(D)%*%solve(V)%*%D)%*%(t(D)%*%solve(V)%*%y) logL<--t(y-D%*%a)%*%solve(V)%*%(y-D%*%a)/2-n*m*log(2*pi)/2- determinant(V)$modulus[1]/2 return(-logL) } # compute the log-likelihood (from the original matrices) lik.R<-function(theta,y,C,D,E){ m<-length(y)/nrow(C[[1]]) n<-length(y)/m p<-length(C) R<-array(data=0,dim=c(m,m,p)); l<-1 for(i in 1:p) for(j in 1:m) for(k in j:m){ R[j,k,i]<-theta[l] R[k,j,i]<-theta[l] l<-l+1 } V<-matrix(0,nrow(D),nrow(D)) for(i in 1:p) V<-V+kronecker(R[,,i],C[[i]]) V<-V+E a<-solve(t(D)%*%solve(V)%*%D)%*%(t(D)%*%solve(V)%*%y) logL<--t(y-D%*%a)%*%solve(V)%*%(y-D%*%a)/2-n*m*log(2*pi)/2-determinant(V)$modulus[1]/2 return(-logL) } ## end likelihood functions ## start preliminaries if(is.data.frame(X)) X<-as.matrix(X) n<-nrow(X) # number of species m<-ncol(X) # number of traits if(hasArg(err_vcv)){ err_vcv<-list(...)$err_vcv err_vcv<-err_vcv[tree$tip.label] } else { err_vcv<-replicate(n,matrix(0,m,m),simplify=FALSE) names(err_vcv)<-tree$tip.label } E<-matrix(0,n*m,n*m) for(i in 1:n){ ii<-0:(m-1)*n+i E[ii,ii]<-err_vcv[[i]] } tree1rate<-paintSubTree(tree,Ntip(tree)+1,"fitted") tree<-if(inherits(tree,"simmap")) tree else tree1rate p<-ncol(tree$mapped.edge) # number of states D<-matrix(0,n*m,m) for(i in 1:(n*m)) for(j in 1:m) if((j-1)*n1){ C<-multiC(tree) # compute separate C for each state # compute the starting parameter values ss<-vector(mode="numeric") for(i in 1:p) ss<-c(ss,to.upper(chol(R))) # optimize using generic optimizer r=optim(ss,fn=lik.chol,y=y,C=C,D=D,E=E,control=list(maxit=maxit)) # convert parameter estimates to matrices R.i<-array(dim=c(m,m,p)) ss<-colnames(tree$mapped.edge) for(i in 1:p) R.i[,,i]<-matrix(data=t(upper.diag(r$par[((i-1)*m*(m+1)/2+1):(i*(m*(m+1)/2))]))%*% upper.diag(r$par[((i-1)*m*(m+1)/2+1):(i*(m*(m+1)/2))]),m,m,dimnames=list(colnames(X), colnames(X))) dimnames(R.i)<-list(rownames(R),colnames(R),ss) # log-likelihood for the multi-matrix model logL2<--r$value # convert R.i to a vector Rv<-vector(mode="numeric") for(i in 1:p) Rv<-c(Rv,to.upper(R.i[,,i])) H<-hessian(lik.R,Rv,y=y,C=C,D=D,E=E) # convert Hessian diagonal to matrices if(vars){ Vars<-array(dim=c(m,m,p)) Vh<-diag(solve(H)) for(i in 1:p) Vars[,,i]<-matrix(data=t(to.symmetric(Vh[((i-1)*m*(m+1)/2+1):(i*(m*(m+1)/2))])),m,m) dimnames(Vars)<-list(rownames(R),colnames(R),ss) } # report convergence convergence[2]==r$convergence } if(all(convergence==0)) converged<-"Optimization has converged." else converged<-"Optimization may not have converged. Consider increasing maxit." if(p>1){ if(vars) obj<-list(R.single=R,vars.single=vars.single,logL1=as.numeric(logL1), k1=m*(m+1)/2+m,R.multiple=R.i,vars.multiple=Vars,logL.multiple=logL2, k2=p*m*(m+1)/2+m,P.chisq=pchisq(2*(logL2-as.numeric(logL1)),(p-1)*m*(m+1)/2, lower.tail=FALSE),convergence=converged) else obj<-list(R.single=R,logL1=as.numeric(logL1),k1=m*(m+1)/2+m,R.multiple=R.i, logL.multiple=logL2,k2=p*m*(m+1)/2+m,P.chisq=pchisq(2*(logL2-as.numeric(logL1)), (p-1)*m*(m+1)/2,lower.tail=FALSE),convergence=converged) } else { if(vars) obj<-list(R.single=R,vars.single=vars.single,logL1=as.numeric(logL1), k1=m*(m+1)/2+m,convergence="Optimization has converged.") else obj<-list(R.single=R,logL1=as.numeric(logL1),k1=m*(m+1)/2+m, convergence="Optimization has converged.") } class(obj)<-"evol.vcv" obj } # function puts the upper triangle of a square matrix in a vector, by row # written by Liam J. Revell 2013 to.upper<-function(X) t(X)[lower.tri(X,diag=TRUE)] # function puts a vector into the upper triangle of a square matrix, by row # written by Liam J. Revell 2013 upper.diag<-function(x){ m<-(-1+sqrt(1+8*length(x)))/2 X<-lower.tri(matrix(NA,m,m),diag=TRUE) X[X==TRUE]<-x t(X) } # function converts vector to symmetric matrix # written by Liam J. Revell 2013 to.symmetric<-function(x){ if(length(x)==1) X<-matrix(x,1,1) else { X<-upper.diag(x) for(i in 2:nrow(X)) for(j in 1:(i-1)) X[i,j]<-X[j,i] } X } ## S3 print method for object of class "evol.vcv" ## written by Liam J. Revell 2013 print.evol.vcv<-function(x,...){ if(hasArg(digits)) digits<-list(...)$digits else digits<-4 x<-lapply(x,function(a,b) if(is.numeric(a)) round(a,b) else a,b=digits) cat("ML single-matrix model:\n") nn<-paste("R[",t(sapply(1:ncol(x$R.single),paste, 1:ncol(x$R.single),sep=","))[upper.tri(x$R.single,diag=TRUE)],"]", sep="") cat(paste("\t",paste(nn,collapse="\t"),"\tk\tlog(L)","\n",sep="")) cat(paste("fitted",paste(x$R.single[upper.tri(x$R.single,diag=TRUE)], collapse="\t"),x$k1,x$logL1,"\n",sep="\t")) cat("\n") if(!is.null(x$R.multiple)){ cat("ML multi-matrix model:\n") cat(paste("\t",paste(nn,collapse="\t"),"\tk\tlog(L)","\n",sep="")) for(i in 1:dim(x$R.multiple)[3]){ if(i==1) cat(paste(dimnames(x$R.multiple)[[3]][i], paste(x$R.multiple[,,i][upper.tri(x$R.single,diag=TRUE)], collapse="\t"),x$k2,x$logL.multiple,"\n",sep="\t")) else cat(paste(dimnames(x$R.multiple)[[3]][i],paste(x$R.multiple[,,i][upper.tri(x$R.single, diag=TRUE)],collapse="\t"),"\n",sep="\t")) } cat("\n") cat(paste("P-value (based on X^2):",x$P.chisq,"\n\n")) } if(x$convergence[1]=="Optimization has converged.") cat("R thinks it has found the ML solution.\n\n") else cat("Optimization may not have converged.\n\n") } phytools/R/locate.yeti.R0000644000176200001440000002057314375517350014720 0ustar liggesusers## code to place a missing extant taxon into a tree using ML or REML on continuous data ## written by Liam J. Revell 2014, 2018, 2021 locate.yeti<-function(tree,X,...){ if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".") if(hasArg(method)) method<-list(...)$method else method<-"ML" if(hasArg(search)) search<-list(...)$search else search<-"heuristic" if(hasArg(plot)) plot<-list(...)$plot else plot<-FALSE if(hasArg(quiet)) quiet<-list(...)$quiet else quiet<-FALSE if(hasArg(rotate)) rotate<-list(...)$rotate else rotate<-if(method=="ML") TRUE else FALSE root.node<-Ntip(tree)+1 if(hasArg(constraint)){ if(search=="exhaustive") constraint<-list(...)$constraint else { cat("constraint only works with search==\"exhaustive\"\n") constraint<-c(root.node,tree$edge[,2]) } } else constraint<-c(root.node,tree$edge[,2]) if(!is.matrix(X)) X<-as.matrix(X) tip<-setdiff(rownames(X),tree$tip.label) if(method=="ML") mltree<-yetiML(tree,X,quiet,tip,root.node,constraint,plot,search,rotate) else if(method=="REML") mltree<-yetiREML(tree,X,quiet,tip,root.node,constraint,plot,search) else { cat(paste("Do not recognize method ",method,".\n",sep="")) stop() } mltree } yetiML<-function(tree,X,quiet,tip,root.node,constraint,plot,search,rotate){ if(!quiet) cat(paste("Optimizing the phylogenetic position of ",tip," using ML. Please wait....\n",sep="")) if(ncol(X)>1&&rotate){ pca<-phyl.pca(tree,X[tree$tip.label,]) obj<-phyl.vcv(X[tree$tip.label,],vcv(tree),1) X<-(X-matrix(rep(obj$a[,1],nrow(X)),nrow(X),ncol(X),byrow=TRUE))%*%pca$Evec } if(search=="heuristic"){ trees<-list() ee<-c(root.node,tree$edge[,2]) for(i in 1:length(ee)) trees[[i]]<-bind.tip(tree,tip,where=ee[i],position=if(ee[i]==root.node) 0 else 0.5*tree$edge.length[i-1]) class(trees)<-"multiPhylo" lik.edge<-function(tree,XX,rotate){ if(!rotate) XX<-phyl.pca(tree,XX[tree$tip.label,])$S obj<-phyl.vcv(as.matrix(XX[tree$tip.label,]),vcv(tree),1) ll<-vector() for(i in 1:ncol(XX)) ll[i]<-sum(dmnorm(XX[tree$tip.label,i],mean=rep(obj$a[i,1],nrow(XX)),obj$C*obj$R[i,i],log=TRUE)) sum(ll) } logL<-sapply(trees,lik.edge,XX=X,rotate=rotate) if(plot){ ll<-logL[2:length(logL)] ll[ll<=sort(ll,decreasing=TRUE)[ceiling(nrow(tree$edge)/2)]]<-sort(ll,decreasing=TRUE)[ceiling(nrow(tree$edge)/2)] layout(matrix(c(1,2),2,1),heights=c(0.95,0.05)) plotBranchbyTrait(tree,ll,mode="edges",title="log(L)",show.tip.label=FALSE) edgelabels(round(logL[2:length(logL)],1),cex=0.5) plot.new() text(paste("Note: logL <=",round(min(ll),2),"set to",round(min(ll),2),"for visualization only"),x=0.5,y=0.5) } edge<-ee[which(logL==max(logL))] } lik.tree<-function(position,tip,tree,edge,XX,rt,rotate){ if(edge==rt) tree<-bind.tip(tree,tip,edge.length=position,where=edge) else tree<-bind.tip(tree,tip,where=edge,position=position) if(!rotate) XX<-phyl.pca(tree,XX[tree$tip.label,])$S obj<-phyl.vcv(as.matrix(XX[tree$tip.label,]),vcv(tree),1) ll<-vector() for(i in 1:ncol(XX)) ll[i]<-sum(dmnorm(XX[tree$tip.label,i],mean=rep(obj$a[i,1],nrow(XX)),obj$C*obj$R[i,i],log=TRUE)) sum(ll) } if(search=="heuristic"){ ee<-edge if(edge!=root.node) ee<-c(ee,getAncestors(tree,node=edge,type="parent")) if(edge>Ntip(tree)) ee<-c(ee,tree$edge[which(tree$edge[,1]==edge),2]) } else if(search=="exhaustive") ee<-c(root.node,tree$edge[,2]) ee<-intersect(ee,constraint) fit<-vector(mode="list",length=length(ee)) for(i in 1:length(ee)){ if(ee[i]==root.node) fit[[i]]<-optimize(lik.tree,interval=c(max(nodeHeights(tree)),10*max(nodeHeights(tree))),tip=tip,tree=tree, edge=ee[i],XX=X,rt=root.node,rotate=rotate,maximum=TRUE) else fit[[i]]<-optimize(lik.tree,interval=c(0,tree$edge.length[which(tree$edge[,2]==ee[i])]),tip=tip,tree=tree,edge=ee[i], XX=X,rt=root.node,rotate=rotate,maximum=TRUE) } logL<-sapply(fit,function(x) x$objective) if(search=="exhaustive"&&plot){ ll<-sapply(fit,function(x) x$objective) ll<-ll[2:length(ll)] ll[ll<=sort(ll,decreasing=TRUE)[ceiling(nrow(tree$edge)/2)]]<-sort(ll,decreasing=TRUE)[ceiling(nrow(tree$edge)/2)] layout(matrix(c(1,2),2,1),heights=c(0.95,0.05)) plotBranchbyTrait(tree,ll,mode="edges",title="log(L)",show.tip.label=FALSE) edgelabels(round(ll,1),cex=0.5) plot.new() text(paste("Note: logL <=",round(min(ll),2),"set to",round(min(ll),2),"for visualization only"),x=0.5,y=0.5) } fit<-fit[[which(logL==max(logL))]] edge<-ee[which(logL==max(logL))] mltree<-if(edge==root.node) midpoint.root(bind.tip(tree,tip,where=edge,edge.length=fit$maximum)) else bind.tip(tree,tip,where=edge,position=fit$maximum) mltree$logL<-fit$objective if(!quiet) cat("Done.\n") mltree } yetiREML<-function(tree,X,quiet,tip,root.node,constraint,plot,search){ if(!quiet){ cat("---------------------------------------------------------------\n") cat("| **Warning: method=\"REML\" has not been thoroughly tested. |\n") cat("| Use with caution.** |\n") cat("---------------------------------------------------------------\n\n") } if(!quiet) cat(paste("Optimizing the phylogenetic position of ",tip," using REML. Please wait....\n",sep="")) if(search=="heuristic"){ trees<-list() ee<-c(root.node,tree$edge[,2]) for(i in 1:length(ee)) trees[[i]]<-bind.tip(tree,tip,where=ee[i],position=if(ee[i]==root.node) 0 else 0.5*tree$edge.length[i-1]) class(trees)<-"multiPhylo" lik.edge<-function(tree,XX){ tree<-multi2di(tree,random=FALSE) YY<-apply(XX[tree$tip.label,],2,pic,phy=tree) vcv<-t(YY)%*%YY/nrow(YY) E<-eigen(vcv)$vectors ##a<-apply(XX,2,function(x,tree) ace(x,tree,type="continuous",method="pic")$ace[1],tree=tree) ##S<-(X-matrix(rep(a,nrow(X)),nrow(X),ncol(X),byrow=TRUE))%*%E ##ZZ<-apply(S,2,pic,phy=tree) ZZ<-YY%*%E vars<-diag(t(ZZ)%*%ZZ/nrow(ZZ)) ll<-vector() for(i in 1:ncol(ZZ)) ll[i]<-sum(dnorm(ZZ[,i],mean=0,sd=sqrt(vars[i]),log=TRUE)) sum(ll) } logL<-sapply(trees,lik.edge,XX=X) if(plot){ ll<-logL[2:length(logL)] ll[ll<=sort(ll,decreasing=TRUE)[ceiling(nrow(tree$edge)/2)]]<-sort(ll,decreasing=TRUE)[ceiling(nrow(tree$edge)/2)] layout(matrix(c(1,2),2,1),heights=c(0.95,0.05)) plotBranchbyTrait(tree,ll,mode="edges",title="log(L)",show.tip.label=FALSE) edgelabels(round(logL[2:length(logL)],1),cex=0.5) plot.new() text(paste("Note: logL <=",round(min(ll),2),"set to",round(min(ll),2),"for visualization only"),x=0.5,y=0.5) } edge<-ee[which(logL==max(logL))] } lik.tree<-function(position,tip,tree,edge,XX,rt){ if(edge==rt) tree<-bind.tip(tree,tip,edge.length=position,where=edge) else tree<-bind.tip(tree,tip,where=edge,position=position) tree<-multi2di(tree,random=FALSE) YY<-apply(XX,2,pic,phy=tree,scaled=FALSE) vcv<-t(YY)%*%YY/nrow(YY) sum(dmnorm(YY,mean=rep(0,ncol(YY)),varcov=vcv,log=TRUE)) } if(search=="heuristic"){ ee<-edge if(edge!=root.node) ee<-c(ee,getAncestors(tree,node=edge,type="parent")) if(edge>Ntip(tree)) ee<-c(ee,tree$edge[which(tree$edge[,1]==edge),2]) } else if(search=="exhaustive") ee<-c(root.node,tree$edge[,2]) ee<-intersect(ee,constraint) fit<-vector(mode="list",length=length(ee)) for(i in 1:length(ee)){ if(ee[i]==root.node) fit[[i]]<-optimize(lik.tree,interval=c(max(nodeHeights(tree)),10*max(nodeHeights(tree))),tip=tip,tree=tree,edge=ee[i],XX=X,rt=root.node,maximum=TRUE) else fit[[i]]<-optimize(lik.tree,interval=c(0,tree$edge.length[which(tree$edge[,2]==ee[i])]),tip=tip,tree=tree,edge=ee[i],XX=X,rt=root.node,maximum=TRUE) } logL<-sapply(fit,function(x) x$objective) if(search=="exhaustive"&&plot){ ll<-sapply(fit,function(x) x$objective) ll<-ll[2:length(ll)] ll[ll<=sort(ll,decreasing=TRUE)[ceiling(nrow(tree$edge)/2)]]<-sort(ll,decreasing=TRUE)[ceiling(nrow(tree$edge)/2)] layout(matrix(c(1,2),2,1),heights=c(0.95,0.05)) plotBranchbyTrait(tree,ll,mode="edges",title="log(L)",show.tip.label=FALSE) edgelabels(round(ll,1),cex=0.5) plot.new() text(paste("Note: logL <=",round(min(ll),2),"set to",round(min(ll),2),"for visualization only"),x=0.5,y=0.5) } fit<-fit[[which(logL==max(logL))]] edge<-ee[which(logL==max(logL))] mltree<-if(edge==root.node) midpoint.root(bind.tip(tree,tip,where=edge,edge.length=fit$maximum)) else bind.tip(tree,tip,where=edge,position=fit$maximum) mltree$logL<-fit$objective if(!quiet) cat("Done.\n") mltree } phytools/R/project.phylomorphospace.R0000644000176200001440000000372314375517350017537 0ustar liggesusers## morph a phylogeny to a phylomorphospace, vice versa, or there & back again ## written by Liam J. Revell 2018 project.phylomorphospace<-function(tree,X,nsteps=200,sleep=0, direction=c("to","from","both"),...){ direction<-direction[1] tree<-minRotate(reorder(tree,"cladewise"),X[,2],print=FALSE) X<-X[tree$tip.label,] A<-cbind(fastAnc(tree,X[,1]),fastAnc(tree,X[,2])) cladogram<-tree cladogram$edge.length<-NULL mar<-par()$mar plotTree(cladogram,type="cladogram",nodes="centered",plot=FALSE) obj<-get("last_plot.phylo",envir=.PlotPhyloEnv) obj$xx<-obj$xx*(max(c(X[,1],A[,1]))-min(c(X[,1],A[,1])))+ min(c(X[,1],A[,1])) xlim<-range(obj$xx) xlim[2]<-xlim[2]+abs(diff(xlim))*(obj$x.lim[2]-1) obj$yy<-(obj$yy-min(obj$yy))/(max(obj$yy)-min(obj$yy))* (max(c(X[,2],A[,2]))-min(c(X[,2],A[,2])))+min(c(X[,2],A[,2])) ylim<-range(obj$yy) X0<-cbind(obj$xx[1:Ntip(tree)],obj$yy[1:Ntip(tree)]) rownames(X0)<-tree$tip.label A0<-cbind(obj$xx[1:tree$Nnode+Ntip(tree)], obj$yy[1:tree$Nnode+Ntip(tree)]) rownames(A0)<-1:tree$Nnode+Ntip(tree) par(mar=mar,new=TRUE) dev.hold() if(direction%in%c("to","both")) phylomorphospace(tree,X0,A0,label="horizontal",xlim=xlim, ylim=ylim,...) else if(direction=="from") phylomorphospace(tree,X,A,label="radial",xlim=xlim, ylim=ylim,...) dev.flush() if(direction=="both") nsteps<-ceiling(nsteps/2) if(direction%in%c("to","both")){ for(i in 2:nsteps){ Sys.sleep(sleep) dev.hold() phylomorphospace(tree,((nsteps-i)*X0+i*X)/nsteps, ((nsteps-i)*A0+i*A)/nsteps,xlim=xlim,ylim=ylim, ...) dev.flush() } } if(direction%in%c("from","both")){ for(i in (nsteps-1):1){ Sys.sleep(sleep) dev.hold() phylomorphospace(tree,((nsteps-i)*X0+i*X)/nsteps, ((nsteps-i)*A0+i*A)/nsteps,xlim=xlim,ylim=ylim, ...) dev.flush() } dev.hold() phylomorphospace(tree,X0,A0,label="horizontal",xlim=xlim, ylim=ylim,...) dev.flush() } invisible(NULL) } phytools/R/brownie.lite.R0000644000176200001440000001265114431467114015072 0ustar liggesusers## this function fits two or more evolutionary rates for a continuous trait on the tree ## based on O'Meara et al. (2006) ## written by Liam J. Revell 2011/2012, 2019, 2022, 2023 brownie.lite<-function(tree,x,maxit=2000,test="chisq",nsim=100,se=NULL,...){ if(hasArg(quiet)) quiet<-list(...)$quiet else quiet<-FALSE if(hasArg(tol)) tol<-list(...)$tol else tol<-1e-8 # some minor error checking if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(!inherits(tree,"simmap")) tree<-paintSubTree(tree,Ntip(tree)+1,"1") x<-matchDatatoTree(tree,x,"x") x<-x[tree$tip.label] if(!is.null(se)){ se<-matchDatatoTree(tree,se,"se") se<-se[tree$tip.label] } else { se<-rep(0,length(x)) names(se)<-names(x) } n<-length(x) # number of species p<-ncol(tree$mapped.edge) # number of states C1<-vcv.phylo(tree) a<-as.numeric(colSums(solve(C1))%*%x/sum(solve(C1))) sig<-as.numeric(t(x-a)%*%solve(C1)%*%(x-a)/n) # single rate model model1<-optim(c(sig,a),fn=lik.single,y=x,C=C1,se=se, control=list(maxit=maxit),hessian=TRUE, method="L-BFGS-B", lower=c(0,-Inf)) logL1<--model1$value sig1<-model1$par[1] a1<-model1$par[2] vcv1<-solve(model1$hessian) rownames(vcv1)<-c("sig","a") colnames(vcv1)<-rownames(vcv1) # multiple rate model C2<-multiC(tree) s<-c(rep(sig1,p),a1) l<-c(rep(0.0001*sig1,p),-Inf) model2<-optim(s,fn=lik.multiple,y=x,C=C2,se=se, control=list(maxit=maxit),hessian=TRUE, method="L-BFGS-B",lower=l) logL2<--model2$value while(logL1>=(logL2+tol)){ if(!quiet){ message("False convergence on first try; trying again with new starting values.") } model2<-optim(s*2*runif(n=length(s)),fn=lik.multiple, y=x,C=C2,se=se,control=list(maxit=maxit), hessian=TRUE,method="L-BFGS-B",lower=l) logL2<--model2$value } sig.i<-model2$par[1:p] names(sig.i)<-colnames(tree$mapped.edge) a2<-model2$par[p+1] vcv2<-solve(model2$hessian) rownames(vcv2)<-c(colnames(tree$mapped.edge),"a") colnames(vcv2)<-rownames(vcv2) if(model2$convergence==0) converged<-"Optimization has converged." else converged<-"Optimization may not have converged. Consider increasing maxit." if(test=="chisq") xx<-list(sig2.single=sig1,a.single=a1,var.single=vcv1[1,1], logL1=logL1,k1=2,sig2.multiple=sig.i,a.multiple=a2, vcv.multiple=vcv2[1:p,1:p],logL.multiple=logL2,k2=p+1, P.chisq=pchisq(2*(logL2-as.numeric(logL1)),p-1, lower.tail=FALSE),convergence=converged) else if(test=="simulation"){ LR<-2*(logL2-logL1) X<-fastBM(tree,a=a1,sig2=sig1,nsim=(nsim-1)) Xe<-matrix(rnorm(n=length(X),mean=X,sd=rep(se,nsim-1)), nrow(X),ncol(X),dimnames=dimnames(X)) # now compute the P-value based on simulation Psim<-1/nsim for(i in 1:(nsim-1)){ sim<-brownie.lite(tree,Xe[,i],se=se) while(sim$convergence!="Optimization has converged."|| (sim$logL.multiple-sim$logL1)<0){ Xe[,i]<-rnorm(n=length(x),fastBM(tree,a=a1,sig2=sig1),sd=se) sim<-brownie.lite(tree,Xe[,i]) } Psim<-Psim+(LR<=2*(sim$logL.multiple-sim$logL1))/nsim } xx<-list(sig2.single=sig1,a.single=a1,var.single=vcv1[1,1],logL1=logL1, k1=2,sig2.multiple=sig.i,a.multiple=a2,vcv.multiple=vcv2[1:p,1:p], logL.multiple=logL2,k2=p+1,P.sim=Psim,convergence=converged) } class(xx)<-"brownie.lite" return(xx) } ## S3 print method for object of class "brownie.lite" ## written by Liam J. Revell 2013, 2020 print.brownie.lite<-function(x, ...){ if(hasArg(digits)) digits<-list(...)$digits else digits<-getOption("digits") x<-lapply(x,function(a,b) if(is.numeric(a)) round(a,b) else a,b=digits) cat("ML single-rate model:\n") obj<-matrix(c(x$sig2.single,sqrt(x$var.single), x$a.single,x$k1,x$logL1),1,5, dimnames=list("value",c("s^2","se","a","k","logL"))) print(obj,digits=digits) cat("\nML multi-rate model:\n") nn<-c(unlist(strsplit(paste("s^2(",names(x$sig2.multiple),")__", "se(",names(x$sig2.multiple),")",sep=""),"__")),"a","k", "logL") obj<-matrix(c(as.vector(rbind(x$sig2.multiple,sqrt(diag(x$vcv.multiple)))), x$a.multiple,x$k2,x$logL.multiple),1,2*length(x$sig2.multiple)+3, dimnames=list("value",nn)) print(obj,digits=digits) if(!is.null(x$P.chisq)) cat(paste("\nP-value (based on X^2):",x$P.chisq,"\n\n")) else if(!is.null(x$P.sim)) cat(paste("\nP-value (based on simulation):", x$P.sim,"\n\n")) if(x$convergence[1]=="Optimization has converged.") cat("R thinks it has found the ML solution.\n\n") else cat("Optimization may not have converged.\n\n") } # function computes the likelihood for a single rate with sampling error # written by Liam J. Revell 2012 lik.single<-function(theta,y,C,se){ n<-length(y) sig<-theta[1] a<-theta[2] E<-diag(se^2) logL<-as.numeric(-t(y-a)%*%solve(sig*C+E)%*%(y-a)/2- n*log(2*pi)/2-determinant(sig*C+E)$modulus[1]/2) return(-logL) } # function computes the likelihood for multiple rates # written by Liam J. Revell 2012 lik.multiple<-function(theta,y,C,se=NULL){ n<-length(y); p<-length(C) sig<-theta[1:p] a<-theta[p+1] V<-matrix(0,length(y),length(y)) for(i in 1:p) V<-V+sig[i]*C[[i]] E<-diag(se^2) logL<--t(y-a)%*%solve(V+E)%*%(y-a)/2-n*log(2*pi)/2- determinant(V+E)$modulus[1]/2 return(-logL) } ## S3 logLik method for object class logLik.brownie.lite<-function(object,...){ lik<-setNames( c(object$logL1,object$logL.multiple), c("single-rate","multi-rate")) attr(lik,"df")<-c(object$k1,object$k2) lik } phytools/R/add.random.R0000644000176200001440000000254314375517350014504 0ustar liggesusers# function adds a set of tips to random positions in the tree # written by Liam J. Revell 2013, 2015 add.random<-function(tree,n=NULL,tips=NULL,edge.length=NULL,order=c("random","input")){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") # internal function randomPosn<-function(tree){ # sum edges cumulatively cum.edge<-cumsum(tree$edge.length) index<-tree$edge[,2] # pick random position pos<-runif(1)*sum(tree$edge.length) edge<-1; while(pos>cum.edge[edge]) edge<-edge+1 return(list(node=index[edge],posn=cum.edge[edge]-pos)) } # check if tree is ultrametric (required) if(is.ultrametric(tree)) um<-TRUE else um<-FALSE # set n and/or name tips (if not provided) if(is.null(tips)){ if(is.null(n)) n<-1 tips<-paste("t",length(tree$tip)+1:n,sep="") } else n<-length(tips) if(is.null(edge.length)) if(!um) edge.length<-runif(n=n,min=min(tree$edge.length),max=max(tree$edge.length)) # set order if(order[1]=="random"){ o<-sample(1:n) tips<-tips[o] if(!is.null(edge.length)) edge.length<-edge.length[o] } # add tips for(i in 1:n){ where<-randomPosn(tree) if(is.null(edge.length)) tree<-bind.tip(tree,tips[i],where=where$node,position=where$posn) else tree<-bind.tip(tree,tips[i],where=where$node,position=where$posn,edge.length=edge.length[i]) } return(tree) } phytools/R/fastBM.R0000644000176200001440000000763014375517350013653 0ustar liggesusers## Simulates BM evolution more quickly. ## A trend can be simulated by mu!=0. ## mu=0 is standard BM; mu<0 downward trend; mu>0 upward trend. ## Bounds can be simulated by bounds=c(>-Inf,0. ## Written by Liam J. Revell 2011, 2013, 2015, 2017 fastBM<-function(tree,a=0,mu=0,sig2=1,bounds=c(-Inf,Inf),internal=FALSE,nsim=1,...){ # some minor error checking if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".") ## order if(is.null(attr(tree,"order"))||attr(tree,"order")!="cladewise") tree<-reorder(tree) ## check to see if alpha & theta if(hasArg(alpha)) alpha<-list(...)$alpha else alpha<-NULL if(hasArg(theta)) theta<-list(...)$theta else theta<-NULL if(!is.null(alpha)&&is.null(theta)){ cat("Warning: alpha but not theta specified in OU model, setting theta to a.\n") theta<-a } ## check for OU w. trend (not permitted) if(!is.null(alpha)&&mu!=0) cat("Warning: OU with a trend not permitted. Trend parameter will be ignored.\n") ## check for OU w. bounds (not permitted) if(!is.null(alpha)&&(bounds[1]!=-Inf||bounds[2]!=Inf)) cat("Warning: OU with bounds not permitted. Bounds will be ignored.\n") ## if BM if(is.null(alpha)) x<-simBM(tree,a,mu,sig2,bounds,internal,nsim) else x<-if(nsim==1) simOU(tree,alpha,sig2,theta,a,internal) else replicate(nsim,simOU(tree,alpha,sig2,theta,a,internal)) x } ## internal function does BM simulation ## written by Liam J. Revell 2011, 2013 simBM<-function(tree,a,mu,sig2,bounds,internal,nsim){ if(bounds[2] bounds[1]. Simulating without bounds.") bounds<-c(-Inf,Inf) } if(bounds[1]==-Inf&&bounds[2]==Inf) no.bounds=TRUE else no.bounds=FALSE if(abounds[2]){ warning("a must be bounds[1] 0. Setting sig2 to 1.0.") sig2=1.0 } # function for reflection off bounds reflect<-function(yy,bounds){ while(yybounds[2]){ if(yybounds[2]) yy<-2*bounds[2]-yy } return(yy) } # how many species? n<-length(tree$tip) # first simulate changes along each branch x<-matrix(data=rnorm(n=length(tree$edge.length)*nsim,mean=rep(mu*tree$edge.length,nsim),sd=rep(sqrt(sig2*tree$edge.length),nsim)),length(tree$edge.length),nsim) # now add them up y<-array(0,dim=c(nrow(tree$edge),ncol(tree$edge),nsim)) for(i in 1:nrow(x)){ if(tree$edge[i,1]==(n+1)) y[i,1,]<-a else y[i,1,]<-y[match(tree$edge[i,1],tree$edge[,2]),2,] y[i,2,]<-y[i,1,]+x[i,] if(!no.bounds) y[i,2,]<-apply(as.matrix(y[i,2,]),1,function(yy) reflect(yy,bounds)) } rm(x); x<-matrix(data=rbind(y[1,1,],as.matrix(y[,2,])),length(tree$edge.length)+1,nsim) rownames(x)<-c(n+1,tree$edge[,2]) x<-as.matrix(x[as.character(1:(n+tree$Nnode)),]) rownames(x)[1:n]<-tree$tip.label # return simulated data if(internal==TRUE) return(x[1:nrow(x),]) # include internal nodes else return(x[1:length(tree$tip.label),]) # tip nodes only } ## internal function does BM simulation ## written by Liam J. Revell 2013 simOU<-function(tree,alpha,sig2,theta,a0,internal){ tree<-reorder(tree,"cladewise") X<-matrix(0,nrow(tree$edge),ncol(tree$edge)) root<-length(tree$tip.label)+1 X[which(tree$edge[,1]==root),1]<-a0 for(i in 1:nrow(X)){ t<-tree$edge.length[i] s2<-sig2*(1-exp(-2*alpha*t))/(2*alpha) X[i,2]<-exp(-alpha*t)*X[i,1]+(1-exp(-alpha*t))*theta+rnorm(n=1,sd=sqrt(s2)) ii<-which(tree$edge[,1]==tree$edge[i,2]) if(length(ii)>0) X[ii,1]<-X[i,2] } x<-sapply(1:max(tree$edge),function(x,y,tree) y[which(tree$edge==x)[1]],y=X,tree=tree) x<-setNames(x,c(tree$tip.label,1:tree$Nnode+length(tree$tip.label))) if(internal==TRUE) return(x) # include internal nodes else return(x[1:length(tree$tip.label)]) # tip nodes only } phytools/R/fitPagel.R0000644000176200001440000003136114406370472014225 0ustar liggesusers## function fits Pagel '94 model of correlated evolution of two binary characters ## uses fitMk, ape::ace, or geiger::fitDiscrete internally ## written by Liam J. Revell 2014, 2015, 2016, 2020, 2022, 2023 anova.fitPagel<-function(object,...){ fits<-list(...) nm<-c( "independent", deparse(substitute(object)), if(length(fits)>0) sapply(substitute(list(...))[-1],deparse) ) logL<-c(object$independent.logL, object$dependent.logL, if(length(fits)>0) sapply(fits,function(x) x$dependent.logL)) df<-c(attr(object$independent.logL,"df"), attr(object$dependent.logL,"df"), if(length(fits)>0) sapply(fits,function(x) attr(x$dependent.logL,"df"))) AICvals<-c(object$independent.AIC, object$dependent.AIC, if(length(fits)>0) sapply(fits,function(x) x$dependent.AIC)) ww<-aic.w(AICvals) result<-data.frame(logL,df,AICvals,unclass(ww)) rownames(result)<-nm colnames(result)<-c("log(L)","d.f.","AIC","weight") print(result) invisible(result) } fitPagel<-function(tree,x,y,method="fitMk",model="ARD",dep.var="xy",...){ if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".") if(dep.var%in%c("x","y","xy")==FALSE){ cat(" Invalid option for argument \"dep.var\".\n") cat(" Setting dep.var=\"xy\" (x depends on y & vice versa)\n\n") dep.var<-"xy" } if(model%in%c("ER","SYM","ARD")==FALSE){ cat(" Invalid model. Setting model=\"ARD\"\n\n") model<-"ARD" } if(method=="fitDiscrete"){ chk<-.check.pkg("geiger") if(!chk){ cat(" method = \"fitDiscrete\" requires the package \"geiger\"\n") cat(" Defaulting to method = \"fitMk\"\n\n") method<-"fitMk" fitDiscrete<-function(...) NULL } } if(method%in%c("fitDiscrete","ace","fitMk")==FALSE){ cat(paste(" method = \"",method,"\" not found.\n",sep="")) cat(" Defaulting to method = \"fitMk\"\n\n") method<-"fitMk" } if(is.matrix(x)||is.matrix(y)){ if(!is.matrix(x)) x<-to.matrix(as.factor(x),levels(as.factor(x))) x<-t(apply(x,1,function(xx) xx/sum(xx))) if(!is.matrix(y)) y<-to.matrix(as.factor(y),levels(as.factor(y))) y<-t(apply(y,1,function(xx) xx/sum(xx))) if(method!="fitMk"){ cat(paste(" method = \"",method, "\" does not permit input data as matrices\n",sep="")) cat(" Switching to method = \"fitMk\"\n\n") method<-"fitMk" } levels.x<-colnames(x) levels.y<-colnames(y) levels.xy<-as.vector(sapply(levels.x,paste,levels.y,sep="|")) xy<-matrix(NA,nrow(x),4,dimnames=list(rownames(x),levels.xy)) for(i in 1:nrow(xy)) xy[i,]<-as.vector(y[i,]%*%x[i,,drop=FALSE]) } else { if(!is.factor(x)) x<-as.factor(x) levels.x<-levels(x) if(!is.factor(y)) y<-as.factor(y) levels.y<-levels(y) y<-y[names(x)] if(length(levels.x)!=2||length(levels.y)!=2) stop("Only binary characters for x & y currently permitted.") xy<-setNames(factor(paste(x,y,sep="|"), levels=sapply(levels.x,paste,levels.y,sep="|")), names(x)) levels.xy<-levels(xy) } ## fit independent dep.var iQ<-matrix(c(0,1,2,0,3,0,0,2,4,0,0,1,0,4,3,0),4,4,byrow=TRUE) if(model%in%c("ER","SYM")) iQ<-make.sym(iQ) k.iQ<-length(unique(as.vector(iQ)))-1 rownames(iQ)<-colnames(iQ)<-levels.xy fit.iQ<-if(method=="fitDiscrete") fitDiscrete(tree,xy,model=iQ,...) else if(method=="ace") ace(xy,tree,type="discrete",model=iQ,...) else fitMk(tree,if(!is.matrix(xy)) to.matrix(xy,levels(xy)) else xy, model=iQ,...) ## fit dependendent model if(dep.var=="xy") dQ<-matrix(c(0,1,2,0,3,0,0,4,5,0,0,6,0,7,8,0),4,4,byrow=TRUE) else if(dep.var=="x") dQ<-matrix(c(0,1,2,0,3,0,0,4,5,0,0,1,0,6,3,0),4,4,byrow=TRUE) else if(dep.var=="y") dQ<-matrix(c(0,1,2,0,3,0,0,2,4,0,0,5,0,4,6,0),4,4,byrow=TRUE) if(model%in%c("ER","SYM")) dQ<-make.sym(dQ) k.dQ<-length(unique(as.vector(dQ)))-1 rownames(dQ)<-colnames(dQ)<-levels.xy fit.dQ<-if(method=="fitDiscrete") fitDiscrete(tree,xy,model=dQ,...) else if(method=="ace") ace(xy,tree,type="discrete",model=dQ,...) else fitMk(tree,if(!is.matrix(xy)) to.matrix(xy,levels(xy)) else xy, model=dQ,...) ## back translate independent model if(method=="fitDiscrete") iQ<-.Qmatrix.from.gfit(fit.iQ) else { I<-fit.iQ$index.matrix I[I==0]<-NA iQ<-apply(I,2,function(i,x) x[i],x=fit.iQ$rates) iQ[is.na(iQ)]<-0 diag(iQ)<--rowSums(iQ) rownames(iQ)<-colnames(iQ) } ## dependent model if(method=="fitDiscrete") dQ<-.Qmatrix.from.gfit(fit.dQ) else { I<-fit.dQ$index.matrix I[I==0]<-NA dQ<-apply(I,2,function(i,x) x[i],x=fit.dQ$rates) dQ[is.na(dQ)]<-0 diag(dQ)<--rowSums(dQ) rownames(dQ)<-colnames(dQ) } ## assemble object to return obj<-list(independent.Q=iQ, dependent.Q=dQ, independent.logL=logLik(fit.iQ), dependent.logL=logLik(fit.dQ), independent.AIC=2*k.iQ-2*logLik(fit.iQ), dependent.AIC=2*k.dQ-2*logLik(fit.dQ), lik.ratio=2*(logLik(fit.dQ)-logLik(fit.iQ)), P=pchisq(2*(logLik(fit.dQ)-logLik(fit.iQ)), df=k.dQ-k.iQ, lower.tail=FALSE), method=method, dep.var=dep.var, model=model) class(obj)<-"fitPagel" obj } ## print method for objects of class "fitPagel" ## written by Liam J. Revell 2014, 2016 print.fitPagel<-function(x,...){ if(hasArg(digits)) digits<-list(...)$digits else digits<-6 cat("\nPagel's binary character correlation test:\n") cat(paste("\nAssumes \"",x$model, "\" substitution model for both characters\n",sep="")) cat("\nIndependent model rate matrix:\n") print(round(x$independent.Q,digits)) tmp<-if(x$dep.var=="xy") "x & y" else if(x$dep.var=="x") "x only" else if(x$dep.var=="y") "y only" cat(paste("\nDependent (",tmp,") model rate matrix:\n",sep="")) print(round(x$dependent.Q,digits)) cat("\nModel fit:\n") obj<-matrix(c(x$independent.logL,x$dependent.logL, x$independent.AIC,x$dependent.AIC),2,2) rownames(obj)<-c("independent","dependent") colnames(obj)<-c("log-likelihood","AIC") print(round(obj,digits)) cat("\nHypothesis test result:\n") cat(paste(" likelihood-ratio: ",signif(x$lik.ratio,digits),"\n")) cat(paste(" p-value: ",signif(x$P,digits),"\n")) cat(paste("\nModel fitting method used was",x$method,"\n\n")) } ## function borrowed from geiger to pull the Q-matrix from a fit returned by ## fitDiscrete .Qmatrix.from.gfit<-function(x){ if(!.check.pkg("geiger")) argn<-function(...) NULL lik=x$lik numberize=function(x){ y=gsub("q","",x) sp=(nn<-nchar(y))/2 as.numeric(c(substring(y,1,sp),substring(y,sp+1, nn))) } att=attributes(lik) att$k=length(att$levels) Qmat=matrix(0,att$k,att$k) nms=att$argn[att$trns] other=att$argn[!att$trns] if("constrained"%in%class(lik)){ cpars=x$opt[argn(lik)] apars=names(lik(unlist(cpars),pars.only=TRUE)) nms=apars[!apars%in%other] } trns=x$opt[nms] for(i in 1:length(trns)){ nm=names(trns)[i] idx=numberize(nm) Qmat[idx[1],idx[2]]=trns[[i]] } diag(Qmat)=-rowSums(Qmat) rownames(Qmat)<-colnames(Qmat)<-levels(lik) Qmat } ## make the model matrix symmetric make.sym<-function(X){ for(i in 1:nrow(X)) for(j in i:nrow(X)) X[j,i]<-X[i,j] X } ## S3 plot method for objects of class "fitPagel ## written by Liam J. Revell 2016, 2023 plot.fitPagel<-function(x,...){ if(hasArg(mar)) mar<-list(...)$mar else mar<-c(1.1,2.1,3.1,2.1) if(hasArg(show)) show<-list(...)$show else show<-"both" if(hasArg(signif)) signif<-list(...)$signif else signif<-3 if(hasArg(main)) main<-list(...)$main else main<-NULL if(!is.null(main)&&length(main)==1) main<-rep(main,2) if(hasArg(cex.main)) cex.main<-list(...)$cex.main else cex.main<-1.2 if(hasArg(cex.sub)) cex.sub<-list(...)$cex.sub else cex.sub<-1 if(hasArg(cex.traits)) cex.traits<-list(...)$cex.traits else cex.traits<-0.9 if(hasArg(cex.rates)) cex.rates<-list(...)$cex.rates else cex.rates<-0.8 if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-2 ## only used if lwd.by.rate=FALSE if(hasArg(lwd.by.rate)) lwd.by.rate<-list(...)$lwd.by.rate else lwd.by.rate<-FALSE if(lwd.by.rate){ rates<-c(x$independent.Q[x$independent.Q>0],x$dependent.Q[x$dependent.Q>0]) LWD.ind<-round(x$independent.Q/min(rates)) LWD.dep<-round(x$dependent.Q/min(rates)) if(hasArg(max.lwd)) max.lwd<-list(...)$max.lwd else max.lwd<-10 LWD.ind[LWD.ind>max.lwd]<-max.lwd LWD.dep[LWD.dep>max.lwd]<-max.lwd } else LWD.ind<-LWD.dep<-matrix(lwd,nrow(x$dependent.Q), ncol(x$dependent.Q)) if(show=="both") par(mfrow=c(2,1)) if(show%in%c("both","independent")){ ## INDEPENDENT MODEL plot.new() par(mar=mar) plot.window(xlim=c(0,2),ylim=c(0,1),asp=1) mtext(if(!is.null(main)) main[1] else "a) Independent model", side=3,adj=0,line=1.2,cex=cex.main) ## trait 1 text(x=0.15,y=1,"Trait 1:",cex=cex.sub) arrows(x0=0.5,y0=0.15,x1=0.5,y1=0.85, lwd=max(LWD.ind[3,1],1), lty=if(LWD.ind[3,1]==0) "dashed" else "solid", length=0.15,lend=3,angle=20) arrows(x0=0.55,y0=0.85,x1=0.55,y1=0.15, lwd=max(LWD.ind[1,3],1), lty=if(LWD.ind[1,3]==0) "dashed" else "solid", length=0.15,lend=3,angle=20) text(x=0.525,y=0.95,namesplit(rownames(x$dependent.Q)[1])[1], cex=cex.traits) text(x=0.525,y=0.05,namesplit(rownames(x$dependent.Q)[3])[1], cex=cex.traits) text(x=0.60,y=0.5,round(x$independent.Q[1,3],signif),cex=cex.rates,srt=90) text(x=0.45,y=0.5,round(x$independent.Q[3,1],signif),cex=cex.rates,srt=90) ## trait 2 text(x=1.3,y=1,"Trait 2:",cex=cex.sub) arrows(x0=1.65,y0=0.15,x1=1.65,y1=0.85, lwd=max(LWD.ind[2,1],1), lty=if(LWD.ind[2,1]==0) "dashed" else "solid", length=0.15,lend=3,angle=20) arrows(x0=1.70,y0=0.85,x1=1.70,y1=0.15, lwd=max(LWD.ind[1,2],1), lty=if(LWD.ind[1,2]==0) "dashed" else "solid", length=0.15,lend=3,angle=20) text(x=1.675,y=0.95,namesplit(rownames(x$dependent.Q)[1])[2], cex=cex.traits) text(x=1.675,y=0.05,namesplit(rownames(x$dependent.Q)[2])[2], cex=cex.traits) text(x=1.75,y=0.5,round(x$independent.Q[1,2],signif),cex=cex.rates,srt=90) text(x=1.60,y=0.5,round(x$independent.Q[2,1],signif),cex=cex.rates,srt=90) } if(show%in%c("both","dependent")){ ## DEPENDENT MODEL collapse<- if(any(sapply(strsplit(rownames(x$dependent.Q),""),length)>6)) ",\n" else ", " plot.new() par(mar=mar) plot.window(xlim=c(0,2),ylim=c(0,1),asp=1) mtext(if(!is.null(main)) main[2] else "b) Dependent model", side=3,adj=0,line=1.2,cex=cex.main) text(x=0.15,y=0.95,"Trait 1,\nTrait 2:",cex=cex.sub) arrows(x0=0.5,y0=0.15,x1=0.5,y1=0.85, lwd=max(LWD.dep[3,1],1), lty=if(LWD.dep[3,1]==0) "dashed" else "solid", length=0.15,lend=3,angle=20) arrows(x0=0.55,y0=0.85,x1=0.55,y1=0.15, lwd=max(LWD.dep[1,3],1), lty=if(LWD.dep[1,3]==0) "dashed" else "solid", length=0.15,lend=3,angle=20) arrows(x0=1.45,y0=0.05,x1=0.75,y1=0.05, lwd=max(LWD.dep[4,3],1), lty=if(LWD.dep[4,3]==0) "dashed" else "solid", length=0.15,lend=3,angle=20) arrows(x0=0.75,y0=0.1,x1=1.45,y1=0.1, lwd=max(LWD.dep[3,4],1), lty=if(LWD.dep[3,4]==0) "dashed" else "solid", length=0.15,lend=3,angle=20) arrows(x0=1.65,y0=0.15,x1=1.65,y1=0.85, lwd=max(LWD.dep[4,2],1), lty=if(LWD.dep[4,2]==0) "dashed" else "solid", length=0.15,lend=3,angle=20) arrows(x0=1.7,y0=0.85,x1=1.7,y1=0.15, lwd=max(LWD.dep[2,4],1), lty=if(LWD.dep[2,4]==0) "dashed" else "solid", length=0.15,lend=3,angle=20) arrows(x0=1.45,y0=0.9,x1=0.75,y1=0.9, lwd=max(LWD.dep[2,1],1), lty=if(LWD.dep[2,1]==0) "dashed" else "solid", length=0.15,lend=3,angle=20) arrows(x0=0.75,y0=0.95,x1=1.45,y1=0.95, lwd=max(LWD.dep[1,2],1), lty=if(LWD.dep[1,2]==0) "dashed" else "solid", length=0.15,lend=3,angle=20) ## add states text(x=0.525,y=0.95, paste(namesplit(rownames(x$dependent.Q)[1]), collapse=collapse),cex=cex.traits) text(x=1.675,y=0.95, paste(namesplit(rownames(x$dependent.Q)[2]), collapse=collapse),cex=cex.traits) text(x=1.675,y=0.05, paste(namesplit(rownames(x$dependent.Q)[4]), collapse=collapse),cex=cex.traits) text(x=0.525,y=0.05, paste(namesplit(rownames(x$dependent.Q)[3]), collapse=collapse),cex=cex.traits) ## add rates text(x=1.1,y=1,round(x$dependent.Q[1,2],signif), cex=cex.rates) text(x=1.1,y=0.85,round(x$dependent.Q[2,1],signif), cex=cex.rates) text(x=1.6,y=0.5,round(x$dependent.Q[4,2],signif), cex=cex.rates,srt=90) text(x=1.75,y=0.5,round(x$dependent.Q[2,4],signif), cex=cex.rates,srt=90) text(x=1.1,y=0,round(x$dependent.Q[4,3],signif), cex=cex.rates) text(x=1.1,y=0.15,round(x$dependent.Q[3,4],signif), cex=cex.rates) text(x=0.45,y=0.5,round(x$dependent.Q[3,1],signif), cex=cex.rates,srt=90) text(x=0.6,y=0.5,round(x$dependent.Q[1,3],signif), cex=cex.rates,srt=90) } } namesplit<-function(x){ tmp<-strsplit(x,"")[[1]] ii<-which(tmp=="|") c(paste(tmp[1:(ii-1)],collapse=""), paste(tmp[(ii+1):length(tmp)],collapse="")) }phytools/R/fitBayes.R0000644000176200001440000000746414375517350014252 0ustar liggesusers# this function calls various MCMC methods # written by Liam J. Revell 2011, 2015, 2017 fitBayes<-function(tree,x,ngen=10000,model="BM",method="reduced",control=list()){ if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".") if(model=="BM"){ if(method=="reduced") X<-mcmcBM(tree,x,ngen,control) else if(method=="full") X<-mcmcBM.full(tree,x,ngen,control) else stop("This is not a recognized method for model='BM'.") } else if(model=="lambda"){ if(method=="reduced") X<-mcmcLambda(tree,x,ngen,control) else if(method=="full") stop("This method is not yet implmented for model='lambda'.") else stop("This is not a recognized method for model='lambda'.") } else stop("This is not a recognized model.") obj<-list(mcmc=as.data.frame(X),model=model,method=method,tree=tree) class(obj)<-"fitBayes" obj } ## S3 methods for the object class print.fitBayes<-function(x,digits=6,...){ if(hasArg(burnin)) burnin<-list(...)$burnin else burnin<-0.2*max(x$mcmc$gen) ii<-which(((x$mcmc$gen-burnin)^2)==min((x$mcmc$gen-burnin)^2))+1 cat("\nObject of class \"fitBayes\" which consists of a posterior sample") cat("\n(in component \'mcmc\') from a Bayesian MCMC of the model presented") cat("\nin Revell & Reynolds (2012; Evolution).\n\n") cat("Object summary:\n") cat(paste("\tgenerations of MCMC: ",max(x$mcmc$gen),".\n",sep="")) cat(paste("\tsample interval: ",x$mcmc$gen[3]-x$mcmc$gen[2],".\n",sep="")) cat(paste("\tmean sigma^2 from posterior sample: ", round(mean(x$mcmc$sig2[ii:nrow(x$mcmc)]),6),".\n",sep="")) if(x$model=="lambda") cat(paste("\tmean lambda from posterior sample: ", round(mean(x$mcmc$lambda[ii:nrow(x$mcmc)]),6),".\n",sep="")) cat(paste("\nCalculations based on burn-in of",burnin,"generations.\n")) cat("\n") } plot.fitBayes<-function(x,...){ args<-list(...) if(is.null(args$what)) what<-"logLik" else { what<-args$what args$what<-NULL } if(is.null(args$burnin)) burnin<-0.2*max(x$mcmc$gen) else { burnin<-args$burnin args$burnin<-NULL } if(what=="logLik"){ args$x<-x$mcmc$gen args$y<-x$mcmc$logLik if(is.null(args$xlab)) args$xlab<-"generation" if(is.null(args$ylab)) args$ylab<-"log(L)" if(is.null(args$type)) args$type<-"l" if(is.null(args$col)) args$col<-make.transparent("blue",0.5) do.call(plot,args) } else if(what=="sig2"){ ii<-which(((x$mcmc$gen-burnin)^2)==min((x$mcmc$gen-burnin)^2))+1 if(is.null(args$bw)) bw<-0.05*diff(range(x$mcmc$sig2[ii:nrow(x$mcmc)])) else { bw<-args$bw args$bw<-NULL } d<-density(x$mcmc$sig2[ii:nrow(x$mcmc)],bw=bw) args$x<-d$x args$y<-d$y if(is.null(args$xlab)) args$xlab<-expression(paste("posterior distribution of ",sigma^2)) if(is.null(args$ylab)) args$ylab<-"density" if(is.null(args$main)) args$main<-"" if(is.null(args$type)) args$type<-"l" if(is.null(args$col)) args$col<-"blue" do.call(plot,args) polygon(x=c(min(d$x),d$x,max(d$x)),y=c(0,d$y,0), col=make.transparent(args$col,0.2),border=NA) } else if(what=="lambda"){ if(x$model!="lambda") stop("Model of \"fitBayes\" object is not \"lambda\".") else { ii<-which(((x$mcmc$gen-burnin)^2)==min((x$mcmc$gen-burnin)^2))+1 if(is.null(args$bw)) bw<-0.05*diff(range(x$mcmc$lambda[ii:nrow(x$mcmc)])) else { bw<-args$bw args$bw<-NULL } d<-density(x$mcmc$lambda[ii:nrow(x$mcmc)],bw=bw) args$x<-d$x args$y<-d$y if(is.null(args$xlab)) args$xlab<-expression(paste("posterior distribution of ",lambda)) if(is.null(args$ylab)) args$ylab<-"density" if(is.null(args$main)) args$main<-"" if(is.null(args$type)) args$type<-"l" if(is.null(args$col)) args$col<-"blue" do.call(plot,args) polygon(x=c(min(d$x),d$x,max(d$x)),y=c(0,d$y,0), col=make.transparent(args$col,0.2),border=NA) } } } phytools/R/plotBranchbyTrait.R0000644000176200001440000002712014375517350016126 0ustar liggesusers## function to plot probability or trait value by branch ## written by Liam J. Revell 2013, 2014, 2016, 2020 plotBranchbyTrait<-function(tree,x,mode=c("edges","tips","nodes"),palette="rainbow", legend=TRUE,xlims=NULL,...){ mode<-mode[1] if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(mode=="tips"){ x<-c(x[tree$tip.label],fastAnc(tree,x)) names(x)[1:length(tree$tip.label)]<-1:length(tree$tip.label) XX<-matrix(x[tree$edge],nrow(tree$edge),2) x<-rowMeans(XX) } else if(mode=="nodes"){ XX<-matrix(x[tree$edge],nrow(tree$edge),2) x<-rowMeans(XX) } # begin optional arguments if(hasArg(tol)) tol<-list(...)$tol else tol<-1e-6 if(hasArg(prompt)) prompt<-list(...)$prompt else prompt<-FALSE if(hasArg(type)) type<-list(...)$type else type<-"phylogram" if(hasArg(show.tip.label)) show.tip.label<-list(...)$show.tip.label else show.tip.label<-TRUE if(hasArg(show.node.label)) show.node.label<-list(...)$show.node.label else show.node.label<-FALSE if(hasArg(edge.width)) edge.width<-list(...)$edge.width else edge.width<-4 if(hasArg(edge.lty)) edge.lty<-list(...)$edge.lty else edge.lty<-1 if(hasArg(font)) font<-list(...)$font else font<-3 if(hasArg(cex)) cex<-list(...)$cex else cex<-par("cex") if(length(cex)==1) cex<-rep(cex,2) if(hasArg(adj)) adj<-list(...)$adj else adj<-NULL if(hasArg(srt)) srt<-list(...)$srt else srt<-0 if(hasArg(no.margin)) no.margin<-list(...)$no.margin else no.margin<-TRUE if(hasArg(root.edge)) root.edge<-list(...)$root.edge else root.edge<-FALSE if(hasArg(label.offset)) label.offset<-list(...)$label.offset else label.offset<-0.01*max(nodeHeights(tree)) if(hasArg(underscore)) underscore<-list(...)$underscore else underscore<-FALSE if(hasArg(x.lim)) x.lim<-list(...)$x.lim else x.lim<-NULL if(hasArg(y.lim)) y.lim<-list(...)$y.lim else y.lim<-if(legend&&!prompt&&type%in%c("phylogram","cladogram")) c(1-0.06*length(tree$tip.label),length(tree$tip.label)) else NULL if(hasArg(direction)) direction<-list(...)$direction else direction<-"rightwards" if(hasArg(lab4ut)) lab4ut<-list(...)$lab4ut else lab4ut<-NULL if(hasArg(tip.color)) tip.color<-list(...)$tip.color else tip.color<-"black" if(hasArg(plot)) plot<-list(...)$plot else plot<-TRUE if(hasArg(rotate.tree)) rotate.tree<-list(...)$rotate.tree else rotate.tree<-0 if(hasArg(open.angle)) open.angle<-list(...)$open.angle else open.angle<-0 # end optional arguments if(is.function(palette)) cols<-palette(n=1000) else { if(palette=="heat.colors") cols<-heat.colors(n=1000) if(palette=="gray") cols<-gray(1000:1/1000) if(palette=="rainbow") cols<-rainbow(1000,start=0.7,end=0) # blue->red } if(is.null(xlims)) xlims<-range(x)+c(-tol,tol) breaks<-0:1000/1000*(xlims[2]-xlims[1])+xlims[1] whichColor<-function(p,cols,breaks){ i<-1 while(p>=breaks[i]&&p>breaks[i+1]) i<-i+1 cols[i] } colors<-sapply(x,whichColor,cols=cols,breaks=breaks) par(lend=2) # now plot xx<-plot.phylo(tree,type=type,show.tip.label=show.tip.label,show.node.label=show.node.label, edge.color=colors,edge.width=edge.width,edge.lty=edge.lty,font=font,cex=cex[1],adj=adj, srt=srt,no.margin=no.margin,root.edge=root.edge,label.offset=label.offset, underscore=underscore,x.lim=x.lim,y.lim=y.lim,direction=direction,lab4ut=lab4ut, tip.color=tip.color,plot=plot,rotate.tree=rotate.tree,open.angle=open.angle,lend=2, new=FALSE) if(legend==TRUE&&is.logical(legend)) legend<-round(0.3*max(nodeHeights(tree)),2) if(legend){ if(hasArg(title)) title<-list(...)$title else title<-"trait value" if(hasArg(digits)) digits<-list(...)$digits else digits<-1 if(prompt) add.color.bar(legend,cols,title,xlims,digits,prompt=TRUE,fsize=cex[2]) else add.color.bar(legend,cols,title,xlims,digits,prompt=FALSE, x=par()$usr[1]+0.05*(par()$usr[2]-par()$usr[1]), y=par()$usr[3]+0.05*(par()$usr[4]-par()$usr[3]),fsize=cex[2]) } invisible(xx) } # function to add color bar # written by Liam J. Revell 2013, 2015, 2016 add.color.bar<-function(leg,cols,title=NULL,lims=c(0,1),digits=1,prompt=TRUE,lwd=4,outline=TRUE,...){ if(prompt){ cat("Click where you want to draw the bar\n") flush.console() x<-unlist(locator(1)) y<-x[2] x<-x[1] } else { if(hasArg(x)) x<-list(...)$x else x<-0 if(hasArg(y)) y<-list(...)$y else y<-0 } if(hasArg(fsize)) fsize<-list(...)$fsize else fsize<-1.0 if(hasArg(subtitle)) subtitle<-list(...)$subtitle else subtitle<-NULL if(hasArg(direction)) direction<-list(...)$direction else direction<-"rightwards" if(direction%in%c("rightwards","leftwards")){ X<-x+cbind(0:(length(cols)-1)/length(cols),1:length(cols)/length(cols))*(leg) if(direction=="leftwards"){ X<-X[nrow(X):1,] if(!is.null(lims)) lims<-lims[2:1] } Y<-cbind(rep(y,length(cols)),rep(y,length(cols))) } else if(direction%in%c("upwards","downwards")){ Y<-y+cbind(0:(length(cols)-1)/length(cols),1:length(cols)/length(cols))*(leg) if(direction=="downwards"){ X<-X[nrow(X):1,] if(!is.null(lims)) lims<-lims[2:1] } X<-cbind(rep(x,length(cols)),rep(x,length(cols))) } if(outline) lines(c(X[1,1],X[nrow(X),2]),c(Y[1,1],Y[nrow(Y),2]),lwd=lwd+2,lend=2) for(i in 1:length(cols)) lines(X[i,],Y[i,],col=cols[i],lwd=lwd,lend=2) if(direction%in%c("rightwards","leftwards")){ if(!is.null(lims)) text(x=x,y=y, round(lims[1],digits),pos=3,cex=fsize) if(!is.null(lims)) text(x=x+leg,y=y, round(lims[2],digits),pos=3,cex=fsize) if(is.null(title)) title<-"P(state=1)" text(x=(2*x+leg)/2,y=y,title,pos=3,cex=fsize) if(is.null(subtitle)) text(x=(2*x+leg)/2,y=y,paste("length=",round(leg,3),sep=""),pos=1,cex=fsize) else text(x=(2*x+leg)/2,y=y,subtitle,pos=1,cex=fsize) } else if(direction%in%c("upwards","downwards")){ if(!is.null(lims)) text(x=x,y=y-0.02*diff(par()$usr[3:4]),round(lims[1],digits), pos=1,cex=fsize) if(!is.null(lims)) text(x=x,y=y+leg+0.02*diff(par()$usr[3:4]), round(lims[2],digits), pos=3,cex=fsize) if(is.null(title)) title<-"P(state=1)" text(x=x-0.04*diff(par()$usr[1:2]),y=(2*y+leg)/2,title, pos=3,cex=fsize,srt=90) if(is.null(subtitle)) text(x=x+0.04*diff(par()$usr[1:2]),y=(2*y+leg)/2, paste("length=",round(leg,3),sep=""),pos=1, srt=90,cex=fsize) else text(x=x+0.04*diff(par()$usr[1:2]),y=(2*y+leg)/2, subtitle,pos=1,cex=fsize,srt=90) } } ## function to create "edge.widthMap" object edge.widthMap<-function(tree,x,...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") tree<-as.phylo(tree) a<-fastAnc(tree,x) node.values<-c(x[tree$tip.label],a) edge.values<-apply(tree$edge,1,function(e,nv) mean(nv[e]),nv=node.values) edge.widths<-edge.values object<-list(tree=tree,edge.widths=edge.widths, node.values=node.values) class(object)<-"edge.widthMap" object } ## print method print.edge.widthMap<-function(x,...){ cat("Object of class \"edge.widthMap\" containing:\n") cat(paste("(1) Phylogenetic tree with",Ntip(x$tree), "tips and",x$tree$Nnode,"internal nodes.\n")) cat("(2) Vector of node values for a mapped quantitative\n") cat(" trait.\n\n") } ## plot method plot.edge.widthMap<-function(x,max.width=0.9,legend="trait value",...){ if(hasArg(min.width)) min.width<-list(...)$min.width else min.width<-0 if(hasArg(vertical.as.polygon)) vertical.as.polygon<-list(...)$vertical.as.polygon else vertical.as.polygon<-TRUE if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-2 h<-max(nodeHeights(x$tree)) node.values<-x$node.values-min(x$node.values) node.values<-node.values*((max.width-min.width)/ max(node.values))+min.width args.list<-list(...) args.list$tree<-x$tree args.list$type<-"phylogram" if(!is.null(args.list$direction)){ if(!args.list$direction%in%c("leftwards","rightwards")) args.list$direction<-"rightwards" } else args.list$direction<-"rightwards" if(is.null(args.list$ylim)) args.list$ylim<-c(1,Ntip(x$tree)+Ntip(x$tree)/25) if(is.null(args.list$ftype)) args.list$ftype<-"i" if(is.null(args.list$fsize)) args.list$fsize<-36*par()$pin[2]/par()$pin[1]/ Ntip(x$tree) if(is.null(args.list$color)){ args.list$color<-"transparent" color<-"gray62" } else { color<-args.list$color args.list$color<-"transparent" } if(is.null(args.list$border)){ border<-color } else { border<-args.list$border args.list$border<-NULL } do.call(plotTree,args.list) obj<-get("last_plot.phylo",envir=.PlotPhyloEnv) asp<-par()$pin[2]/par()$pin[1]/ (diff(par()$usr[4:3])/diff(par()$usr[2:1])) for(i in 1:nrow(x$tree$edge)){ if(vertical.as.polygon){ xx<-obj$xx[c(x$tree$edge[i,1], x$tree$edge[i,1:2], x$tree$edge[i,2:1], x$tree$edge[i,1])]+c(0, asp*node.values[x$tree$edge[i,1]]/2, 0,0,asp*node.values[x$tree$edge[i,1]]/2,0) yy<-rep(obj$yy[x$tree$edge[i,2]],6)+ c(node.values[x$tree$edge[i,1]], node.values[x$tree$edge[i,1:2]], -node.values[x$tree$edge[i,2:1]], -node.values[x$tree$edge[i,1]])/2 } else { xx<-obj$xx[c(x$tree$edge[i,1:2], x$tree$edge[i,2:1])] yy<-rep(obj$yy[x$tree$edge[i,2]],4)+ c(node.values[x$tree$edge[i,1:2]], -node.values[x$tree$edge[i,2:1]])/2 } polygon(x=crop.to.h(xx,h),y=yy, border=border,col=color,lwd=lwd) } for(i in 1:x$tree$Nnode+Ntip(x$tree)){ nn<-x$tree$edge[which(x$tree$edge[,1]==i),2] yy<-range(obj$yy[nn]) if(vertical.as.polygon){ xx<-rep(obj$xx[i],4)+ asp*c(-node.values[i]/2,node.values[i]/2, node.values[i]/2,-node.values[i]/2) polygon(x=crop.to.h(xx,h), y=c(rep(yy[1],2),rep(yy[2],2))+ c(-rep(node.values[i],2), rep(node.values[i],2))/2, border=border,col=color,lwd=lwd) } else { lines(rep(obj$xx[i],2),yy+c(-node.values[i], node.values[i])/2,lend=2,col=border, lwd=lwd) } } if(border!=color&&vertical.as.polygon){ for(i in 1:nrow(x$tree$edge)){ xx<-obj$xx[c(x$tree$edge[i,1], x$tree$edge[i,1:2], x$tree$edge[i,2:1], x$tree$edge[i,1])]+c(0, asp*node.values[x$tree$edge[i,1]]/2, 0,0,asp*node.values[x$tree$edge[i,1]]/2,0) yy<-rep(obj$yy[x$tree$edge[i,2]],6)+ c(node.values[x$tree$edge[i,1]], node.values[x$tree$edge[i,1:2]], -node.values[x$tree$edge[i,2:1]], -node.values[x$tree$edge[i,1]])/2 polygon(x=crop.to.h(xx,h),y=yy, border=FALSE,col=color) } for(i in 1:x$tree$Nnode+Ntip(x$tree)){ nn<-x$tree$edge[which(x$tree$edge[,1]==i),2] yy<-range(obj$yy[nn]) xx<-rep(obj$xx[i],4)+ asp*c(-node.values[i]/2,node.values[i]/2, node.values[i]/2,-node.values[i]/2) polygon(x=crop.to.h(xx,h), y=c(rep(yy[1],2),rep(yy[2],2))+ c(-rep(node.values[i],2), rep(node.values[i],2))/2, border=FALSE,col=color) } } leg.length<-0.4*h x.adj<-if(obj$direction=="rightwards") 0 else obj$x.lim[2]-leg.length polygon(x=c(0,0,leg.length,leg.length)+x.adj, y=Ntip(x$tree)+Ntip(x$tree)/25+ c(-min.width/2,min.width/2,max(node.values)/2, -max(node.values)/2), border=border,col=color,lwd=lwd) if(border!=color) polygon(x=c(0,0,leg.length,leg.length)+x.adj, y=Ntip(x$tree)+Ntip(x$tree)/25+ c(-min.width/2,min.width/2,max(node.values)/2, -max(node.values)/2), border=FALSE,col=color) text(0+x.adj,Ntip(x$tree)+Ntip(x$tree)/25-0.2*max.width, round(min(x$node.values),2),pos=1, cex=0.8) text(leg.length+x.adj,Ntip(x$tree)+Ntip(x$tree)/25-0.2*max.width, round(max(x$node.values),2),pos=1,cex=0.8) text(leg.length/2+x.adj,Ntip(x$tree)+Ntip(x$tree)/25-0.2*max.width, legend,pos=1,cex=0.8) } crop.to.h<-function(x,h) sapply(x,function(x,h) if(x<=h) x else h,h=h)phytools/R/bd.R0000644000176200001440000000761014375517350013062 0ustar liggesusers## likelihood functions for birth-death & Yule model with incomplete sampling ## written by Liam J. Revell 2017, 2018, 2019, 2020, 2021, 2022 ## based on likelihood functions in Stadler (2012) anova.fit.bd<-function(object,...){ fits<-list(...) nm<-c( deparse(substitute(object)), if(length(fits)>0) sapply(substitute(list(...))[-1],deparse) ) fits<-if(length(fits)==0) list(object) else c(list(object),fits) logL<-sapply(fits,logLik) df<-sapply(fits,function(x) attr(logLik(x),"df")) AIC<-sapply(fits,AIC) weight<-unclass(aic.w(AIC)) result<-data.frame(logL,df,AIC,weight) rownames(result)<-nm colnames(result)<-c("log(L)","d.f.","AIC","weight") print(result) invisible(result) } lik.bd<-function(theta,t,rho=1,N=NULL){ lam<-theta[1] mu<-if(length(theta)==2) theta[2] else 0 if(is.null(N)) N<-length(t)+1 p0ti<-function(rho,lam,mu,t) 1-rho*(lam-mu)/(rho*lam+(lam*(1-rho)-mu)*exp(-(lam-mu)*t)) p1ti<-function(rho,lam,mu,t) rho*(lam-mu)^2*exp(-(lam-mu)*t)/(rho*lam+(lam*(1-rho)-mu)*exp(-(lam-mu)*t))^2 lik<-2*log(p1ti(rho,lam,mu,t[1]))-2*log(1-p0ti(rho,lam,mu,t[1])) for(i in 2:length(t)) lik<-lik+log(lam)+log(p1ti(rho,lam,mu,t[i])) -(lik+lfactorial(N-1)) } ## model-fitting function for birth-death model fit.bd<-function(tree,b=NULL,d=NULL,rho=1,...){ if(!is.ultrametric(tree)){ cat("tree fails is.ultrametric.\n") cat("If you believe your tree actually is ultrametric ") cat("use force.ultrametric & try again.\n") stop() } init<-vector(length=2) if(hasArg(init.b)) init.b<-list(...)$init.b else init.b<-1.1*qb(tree) if(hasArg(init.d)) init.d<-list(...)$init.d else init.d<-0.1*qb(tree) if(hasArg(iter)) iter<-list(...)$iter else iter<-10 if(!is.binary(tree)) tree<-multi2di(tree,random=FALSE) T<-sort(branching.times(tree),decreasing=TRUE) fit<-nlminb(c(init.b,init.d),lik.bd,t=T,rho=rho,lower=rep(0,2), upper=rep(Inf,2)) if(!is.finite(fit$objective)){ count<-0 while(!is.finite(fit$objective)&&count1) ceiling(log10(abs(x))) else 0 signif(x,dd+tens) } print.fit.bd<-function(x,...){ if(hasArg(digits)) digits<-list(...)$digits else digits<-4 cat(paste("\nFitted",x$model,"model:\n\n")) cat(paste("ML(b/lambda) =",SIGNIF(x$b,digits),"\n")) if(x$model=="birth-death") cat(paste("ML(d/mu) =",SIGNIF(x$d,digits),"\n")) cat(paste("log(L) =",SIGNIF(x$logL,digits),"\n")) cat(paste("\nAssumed sampling fraction (rho) =",SIGNIF(x$rho,digits),"\n")) if(x$opt$convergence==0) cat("\nR thinks it has converged.\n\n") else cat("\nR thinks optimization may not have converged.\n\n") } ## S3 logLik method logLik.fit.bd<-function(object,...){ logLik<-object$logL attr(logLik,"df")<-if(object$model=="birth-death") 2 else 1 logLik } ## helper function qb<-function(tree) (Ntip(tree)-2)/sum(tree$edge.length) phytools/R/brownieREML.R0000644000176200001440000000674714375517350014634 0ustar liggesusers## This function is a simplified REML version of brownie.lite() ## written by Liam J. Revell 2011, 2013, 2019, 2021 brownieREML<-function(tree,x,maxit=2000,...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(!inherits(tree,"simmap")) tree<-paintSubTree(tree,Ntip(tree)+1,"1") ## optional arguments if(hasArg(tol)) tol<-list(...)$tol else tol<-1e-8 # bookkeeping if(!is.binary(tree)) tree<-multi2di(tree,random=FALSE) x<-x[tree$tip.label] # order in tip.label order n<-length(x) # number of species p<-ncol(tree$mapped.edge) # number of states # fit the single rate model lik1<-function(sig1,tree,x){ tt<-scaleByMap(tree,setNames(rep(sig1,p),colnames(tree$mapped.edge))) picX<-pic(x,tt,scaled=FALSE,var.contrasts=TRUE) logL<-sum(dnorm(picX[,1],sd=sqrt(picX[,2]),log=TRUE)) return(-logL) } sig1<-mean(pic(x,tree)^2) logL1<--lik1(sig1,tree,x) H<-optimHess(sig1,lik1,tree=tree,x=x) v1<-1/H # fit the multiple rate model lik2<-function(sig2,tree,x){ tt<-scaleByMap(tree,sig2) picX<-pic(x,tt,scaled=F,var.contrasts=T) logL<-sum(dnorm(picX[,1],sd=sqrt(picX[,2]),log=TRUE)) return(-logL) } YY<-optim(setNames(rep(1,p)*runif(n=p),colnames(tree$mapped.edge)),lik2,tree=tree,x=x,method="L-BFGS-B",lower=rep(1e-8,p)) sig2<-YY$par obj<-optimHess(sig2,lik2,tree=tree,x=x) if(any(diag(obj)0) H<-obj[ii,ii] v2<-matrix(Inf,nrow(obj),ncol(obj)) v2[ii,ii]<-if(length(H)>1) solve(H) else 1/H } else v2<-if(length(sig2)>1) solve(obj) else 1/obj logL2<--YY$value if(YY$convergence==0) converged<-"Optimization has converged." else converged<-"Optimization may not have converged. Consider increasing maxit." convergence=(YY$convergence==0) obj<-list(sig2.single=sig1,var.single=v1,logL1=logL1,k1=1,sig2.multiple=sig2,vcv.multiple=v2,logL.multiple=logL2, k2=length(sig2),convergence=converged) class(obj)<-"brownieREML" obj } # This function scales a mapped tree by sig2 # written by Liam J. Revell 2011 scaleByMap<-function(mtree,sig2){ edge.length<-if(length(sig2)>1) mtree$mapped.edge[,names(sig2)]%*%sig2 else mtree$mapped.edge*sig2 tree<-list(Nnode=mtree$Nnode,edge=mtree$edge,tip.label=mtree$tip.label,edge.length=edge.length[,1]) class(tree)<-"phylo" return(tree) } ## S3 print method for "brownieREML" ## S3 print method for object of class "brownie.lite" ## written by Liam J. Revell 2013, 2022 print.brownieREML<-function(x, ...){ if(hasArg(digits)) digits<-list(...)$digits else digits<-getOption("digits") x<-lapply(x,function(a,b) if(is.numeric(a)) round(a,b) else a,b=digits) cat("REML single-rate model:\n") obj<-matrix(c(x$sig2.single,sqrt(x$var.single),x$k1,x$logL1),1,4, dimnames=list("value",c("s^2","se","k","logL"))) print(obj,digits=digits) cat("\nREML multi-rate model:\n") nn<-c(unlist(strsplit(paste("s^2(",names(x$sig2.multiple),")__", "se(",names(x$sig2.multiple),")",sep=""),"__")),"k", "logL") obj<-matrix(c(as.vector(rbind(x$sig2.multiple,sqrt(diag(x$vcv.multiple)))), x$k2,x$logL.multiple),1,2*length(x$sig2.multiple)+2, dimnames=list("value",nn)) print(obj,digits=digits) if(!is.null(x$P.chisq)) cat(paste("\nP-value (based on X^2):",x$P.chisq,"\n\n")) else if(!is.null(x$P.sim)) cat(paste("\nP-value (based on simulation):", x$P.sim,"\n\n")) if(x$convergence[1]=="Optimization has converged.") cat("R thinks it has found the ML solution.\n\n") else cat("Optimization may not have converged.\n\n") } phytools/R/collapseTree.R0000644000176200001440000002404114453056352015111 0ustar liggesusers## function to interactively expand and contract subtrees on a phylogeny ## inspired by the phylogeny interface of sharksrays.org by Gavin Naylor ## written by Liam J. Revell 2015, 2016, 2017, 2018, 2020, 2023 collapseTree<-function(tree,...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(inherits(tree,"simmap")) tree<-as.phylo(tree) if(hasArg(nodes)) nodes<-list(...)$nodes else nodes<-TRUE if(hasArg(hold)) hold<-list(...)$hold else hold<-TRUE if(hasArg(drop.extinct)) drop.extinct<-list(...)$drop.extinct else drop.extinct<-TRUE if(hasArg(sleep)) sleep<-list(...)$sleep else sleep<-0.05 if(is.null(tree$edge.length)){ no.edge<-TRUE tree<-compute.brlen(tree,power=0.5) } else no.edge<-FALSE cat("Click on the nodes that you would like to collapse...\n") flush.console() ## turn off locator bell (it's annoying) options(locatorBell=FALSE) ## check for node labels if(is.null(tree$node.label)) tree$node.label<-as.character(Ntip(tree)+1:tree$Nnode) else if(any(tree$node.label=="")){ tree$node.label[which(tree$node.label)==""]<- which(tree$node.label=="")+Ntip(tree) } ## remove any spaces tree$node.label<-sapply(tree$node.label,gsub,pattern=" ",replacement="_") tree$tip.label<-sapply(tree$tip.label,gsub,pattern=" ",replacement="_") ## copy original tree: otree<-tree<-reorder(tree) ## plot initial tree: if(hold) dev.hold() fan(tree,...) lastPP<-get("last_plot.phylo",envir=.PlotPhyloEnv) points(x=lastPP$xx[1:Ntip(tree)],y=lastPP$yy[1:Ntip(tree)], pch=21,col="blue",bg="white",cex=0.8) points(x=lastPP$xx[1:tree$Nnode+Ntip(tree)], y=lastPP$yy[1:tree$Nnode+Ntip(tree)],pch=21, col="blue",bg="white",cex=1.2) rect(par()$usr[1],par()$usr[4]-3*strheight("W"),par()$usr[2],par()$usr[4], border=0,col=make.transparent("blue",0.2)) textbox(x=par()$usr[1:2],y=par()$usr[4], c("Click nodes to collapse or expand\nRIGHT CLICK (or FINISH in RStudio) to stop"), justify="c",border=0) dev.flush() x<-unlist(locator(1)) if(!is.null(x)){ y<-x[2] x<-x[1] d<-sqrt((x-lastPP$xx)^2+(y-lastPP$yy)^2) nn<-which(d==min(d,na.rm=TRUE)) ## collapse tree & replot: while(!is.null(x)){ obj<-list(tree) if(nn>(Ntip(tree)+1)){ obj<-splitTree(tree,list(node=nn, bp=tree$edge.length[which(tree$edge[,2]==nn)])) obj[[1]]$tip.label[which(obj[[1]]$tip.label=="NA")]<- tree$node.label[nn-Ntip(tree)] tips<-which(tree$tip.label%in%obj[[1]]$tip.label) theta<-atan(lastPP$yy[nn]/lastPP$xx[nn]) if(lastPP$yy[nn]>0&&lastPP$xx[nn]<0) theta<-pi+theta else if(lastPP$yy[nn]<0&&lastPP$xx[nn]<0) theta<-pi+theta else if(lastPP$yy[nn]<0&&lastPP$xx[nn]>0) theta<-2*pi+theta ii<-which((c(tips,Ntip(tree)+1)-c(0,tips))>1) if(ii>1&&ii<=length(tips)) tips<-c(tips[1:(ii-1)],theta/(2*pi)*Ntip(tree),tips[ii:length(tips)]) else if(ii==1) tips<-c(theta/(2*pi)*Ntip(tree),tips) else if(ii>length(tips)) tips<-c(tips,theta/(2*pi)*Ntip(tree)) tree<-read.tree(text=write.tree(obj[[1]])) M<-matrix(NA,min(c(max(4,Ntip(obj[[2]])),10)),length(tips)) for(i in 1:ncol(M)) M[,i]<-seq(from=tips[i],to=i,length.out=nrow(M)) colnames(M)<-tree$tip.label maxY<-seq(from=sum(sapply(obj,Ntip))-length(obj)+1,to=Ntip(tree), length.out=nrow(M)) pw<-reorder(tree,"pruningwise") H<-nodeHeights(tree) for(i in 1:nrow(M)){ if(hold) dev.hold() fan(tree,pw,H,xlim=lastPP$x.lim,ylim=lastPP$y.lim, tips=M[i,],maxY=maxY[i],...) rect(par()$usr[1],par()$usr[4]-3*strheight("W"), par()$usr[2],par()$usr[4], border=0,col=make.transparent("blue",0.2)) textbox(x=par()$usr[1:2],y=par()$usr[4], c("Click nodes to collapse or expand\nRIGHT CLICK (or FINISH in RStudio) to stop"), justify="c",border=0) if(nodes||i==nrow(M)){ lastPP<-get("last_plot.phylo",envir=.PlotPhyloEnv) points(x=lastPP$xx[1:Ntip(tree)],y=lastPP$yy[1:Ntip(tree)], pch=21,col="blue",bg="white",cex=0.8) points(x=lastPP$xx[1:tree$Nnode+Ntip(tree)], y=lastPP$yy[1:tree$Nnode+Ntip(tree)],pch=21, col="blue",bg="white",cex=1.2) } Sys.sleep(sleep) dev.flush() } } else if(nn<=Ntip(tree)) { if(tree$tip.label[nn]%in%otree$node.label){ on<-which(otree$node.label==tree$tip.label[nn])+Ntip(otree) obj<-splitTree(otree,list(node=on, bp=otree$edge.length[which(otree$edge[,2]==on)])) nlabel<-tree$tip.label[nn] tree$tip.label[nn]<-"NA" if(nn==1) tips<-c(rep(nn,Ntip(obj[[2]])),(nn+1):Ntip(tree)) else if(nn>1&&nn0.25&&part<=0.5){ x.lim<-c(-max(R)-sw/alp,max(R)+sw/alp) y.lim<-c(0,max(R)+sw/alp) } else x.lim<-y.lim<-c(-max(R)-sw/alp,max(R)+sw/alp) xlim<-x.lim ylim<-y.lim } # plot tree if(!add) plot.new() plot.window(xlim=xlim,ylim=ylim,asp=1) # plot radial lines (edges) segments(x[,1],y[,1],x[,2],y[,2],col=colors,lwd=lwd,lend=2) # plot circular lines ii<-sapply(1:m+n,function(x,y) which(y==x),y=cw$edge) r<-sapply(1:m+n,function(x,y,R) R[match(x,y)],y=cw$edge,R=R) a1<-sapply(ii,function(x,Y) min(Y[x]),Y=Y) a2<-sapply(ii,function(x,Y) max(Y[x]),Y=Y) draw.arc(rep(0,tree$Nnode),rep(0,tree$Nnode),r,a1,a2,lwd=lwd,col=colors) # plot labels cw$tip.label<-gsub("_"," ",cw$tip.label) for(i in 1:n){ ii<-which(cw$edge[,2]==i) aa<-Y[ii,2]/(2*pi)*360 adj<-if(aa>90&&aa<270) c(1,0.25) else c(0,0.25) tt<-if(aa>90&&aa<270) paste(cw$tip.label[i]," ",sep="") else paste(" ", cw$tip.label[i],sep="") aa<-if(aa>90&&aa<270) 180+aa else aa if(ftype) text(x[ii,2],y[ii,2],tt,srt=aa,adj=adj,cex=fsize,font=ftype) } PP<-list(type="fan",use.edge.length=TRUE,node.pos=1, show.tip.label=if(ftype) TRUE else FALSE,show.node.label=FALSE, font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE,label.offset=offset, x.lim=xlim,y.lim=ylim,direction="rightwards",tip.color="black", Ntip=Ntip(cw),Nnode=cw$Nnode,edge=cw$edge, xx=c(x[sapply(1:n,function(x,y) which(x==y)[1],y=tree$edge[,2]),2],x[1,1], if(m>1) x[sapply(2:m+n,function(x,y) which(x==y)[1],y=tree$edge[,2]),2] else c()), yy=c(y[sapply(1:n,function(x,y) which(x==y)[1],y=tree$edge[,2]),2],y[1,1], if(m>1) y[sapply(2:m+n,function(x,y) which(x==y)[1],y=tree$edge[,2]),2] else c())) assign("last_plot.phylo",PP,envir=.PlotPhyloEnv) } phytools/R/ltt.R0000644000176200001440000004665414520745774013320 0ustar liggesusers## This function computes the data for a lineage-through-time plot and ## (optionally) creates this plot the function does not require a tree ## that is ultrametric. Optionally, the function can remove extinct ## species from the phylogeny. If the input tree is an object of class ## "multiPhylo" then the function will simultaneously plot all ltts. ## written by Liam J. Revell 2010-2015, 2022, 2023 ## ltt method (added 2022) ltt<-function(tree,...) UseMethod("ltt") ltt.default<-function(tree,...){ warning(paste( "ltt does not know how to handle objects of class ", class(tree),".")) } print.ltt.multiSimmap<-function(x,...){ cat(paste(length(x),"objects of class \"ltt.simmap\" in a list\n")) } ltt.multiSimmap<-function(tree,gamma=TRUE,...){ if(!inherits(tree,"multiSimmap")){ stop("tree must be object of class \"multiSimmap\".") } else { obj<-lapply(tree,ltt,plot=FALSE,log.lineages=FALSE,gamma=gamma) class(obj)<-"ltt.multiSimmap" return(obj) } } ## internally used functions BRANCHING<-function(phy,is_ultrametric){ x<-if(is_ultrametric) branching.times(phy) else { sort(setNames(max(nodeHeights(phy))-sapply(1:phy$Nnode+Ntip(phy), nodeheight,tree=phy),1:phy$Nnode+Ntip(phy))) } x } TIPHEIGHTS<-function(phy,is_ultrametric){ x<-if(is_ultrametric) { min(setNames(sapply(1:Ntip(phy),nodeheight,tree=phy),1:Ntip(phy))) } else setNames(sapply(1:Ntip(phy),nodeheight,tree=phy),1:Ntip(phy)) x } ltt.simmap<-function(tree,plot=TRUE,log.lineages=FALSE,gamma=TRUE,...){ ## set tolerance if(hasArg(tol)) tol<-list(...)$tol else tol<-.Machine$double.eps^0.5 ## check if ultrametric is_ultrametric<-is.ultrametric(tree) if(!inherits(tree,"simmap")){ stop("tree must be an object of class \"simmap\".") } else { levs<-sort(unique(c(getStates(tree,"tips"), getStates(tree,"nodes")))) tt<-map.to.singleton(tree) H<-nodeHeights(tt) h<-c(0,max(H)-BRANCHING(tt,is_ultrametric),TIPHEIGHTS(tt,is_ultrametric)) ss<-setNames(as.factor(names(tt$edge.length)), tt$edge[,2]) lineages<-matrix(0,length(h),length(levs), dimnames=list(names(h),levs)) lineages[1,getStates(tree,"nodes")[1]]<-1 ROOT<-Ntip(tt)+1 for(i in 2:length(h)){ if(h[i]=H[,1]),which(h[i]=H[,1]),which(h[i]<=H[,2])) lineages[i,]<-summary(ss[ii]) } ii<-order(h) times<-h[ii] lineages<-lineages[ii,,drop=FALSE] lineages<-cbind(lineages,total=rowSums(lineages)) obj<-list(times=times,ltt=lineages) if(gamma==FALSE){ obj<-list(ltt=lineages,times=times,tree=tree) class(obj)<-"ltt.simmap" } else { gam<-gammatest(ltt(as.phylo(tree),plot=FALSE)) obj<-list(ltt=lineages,times=times,gamma=gam$gamma, p=gam$p,tree=tree) class(obj)<-"ltt.simmap" } } if(plot) plot(obj,log.lineages=log.lineages,...) obj } plot.ltt.multiSimmap<-function(x,...){ if(hasArg(add)) add<-list(...)$add else add<-FALSE hh<-max(sapply(x,function(x) max(nodeHeights(x$tree)))) if(hasArg(alpha)) alpha<-list(...)$alpha else alpha<-0.05 if(hasArg(res)) res<-list(...)$res else res<-1000 if(hasArg(log.lineages)) log.lineages<-list(...)$log.lineages else log.lineages<-FALSE levs<-sort(unique(unlist(lapply(x,function(x) c(getStates(x$tree,"tips"),getStates(x$tree,"nodes")))))) if(hasArg(colors)) colors<-list(...)$colors else colors<-setNames(c(palette()[1:length(levs)+1],par()$fg), c(levs,"total")) if(hasArg(legend)) legend<-list(...)$legend else legend<-"topleft" plot.leg<-TRUE if(is.logical(legend)) if(legend) plot.leg<-TRUE else plot.leg<-FALSE if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-5 if(hasArg(show.total)) show.total<-list(...)$show.total else show.total<-TRUE nn<-max(sapply(x,function(x,tot) if(!tot) max(x$ltt[,-which(colnames(x$ltt)=="total")]) else Ntip(x$tree),tot=show.total)) xlim<-if(hasArg(xlim)) list(...)$xlim else c(0,hh) ylim<-if(hasArg(ylim)) list(...)$ylim else if(log.lineages) log(c(1,1.05*nn)) else c(0,1.05*nn) xlab<-if(hasArg(xlab)) list(...)$xlab else "time" ylab<-if(hasArg(ylab)) list(...)$ylab else if(log.lineages) "log(lineages)" else "lineages" TIMES<-seq(0,hh,length.out=res) LINEAGES<-matrix(0,length(TIMES),length(levs)+1) colnames(LINEAGES)<-c(levs,"total") for(i in 1:length(TIMES)){ for(j in 1:length(x)){ ii<-which(x[[j]]$times<=TIMES[i]) ADD<-if(length(ii)==0) rep(0,length(levs)) else x[[j]]$ltt[max(ii),]/length(x) LINEAGES[i,]<-LINEAGES[i,]+ADD } } args<-list(...) args$res<-NULL args$alpha<-NULL args$log.lineages<-NULL args$colors<-NULL args$legend<-NULL args$show.total<-NULL args$add<-NULL args$xlim<-xlim args$ylim<-ylim args$xlab<-xlab args$ylab<-ylab args$x<-NA if(!add) do.call(plot,args) if(!show.total) dd<-1 else dd<-0 for(i in 1:length(x)){ for(j in 1:(ncol(LINEAGES)-dd)){ nm<-colnames(x[[i]]$ltt)[j] ltt<-if(log.lineages) log(x[[i]]$ltt[,j]) else x[[i]]$ltt[,j] lines(x[[i]]$times,ltt,type="s",lwd=1, col=make.transparent(colors[nm], alpha)) } } for(i in 1:(ncol(LINEAGES)-dd)){ nm<-colnames(LINEAGES)[i] ltt<-if(log.lineages) log(LINEAGES[,i]) else LINEAGES[,i] lines(TIMES,ltt,lwd=lwd,col=colors[nm]) } if(plot.leg){ nm<-c(levs,"total") if(!show.total) nm<-setdiff(nm,"total") legend(legend,legend=nm,pch=22,pt.bg=colors[nm],pt.cex=1.2, cex=0.8,bty="n") } invisible(list(times=TIMES,ltt=LINEAGES)) } plot.ltt.simmap<-function(x,...){ if(hasArg(add)) add<-list(...)$add else add<-FALSE if(hasArg(log.lineages)) log.lineages<-list(...)$log.lineages else log.lineages<-FALSE if(hasArg(colors)) colors<-list(...)$colors else colors<-setNames(c(palette()[2:ncol(x$ltt)],par()$fg), colnames(x$ltt)) if(hasArg(legend)) legend<-list(...)$legend else legend<-"topleft" plot.leg<-TRUE if(is.logical(legend)) if(legend) plot.leg<-TRUE else plot.leg<-FALSE if(hasArg(show.tree)) show.tree<-list(...)$show.tree else show.tree<-FALSE if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-3 if(hasArg(outline)) outline<-list(...)$outline else outline<-show.tree if(hasArg(show.total)) show.total<-list(...)$show.total else show.total<-TRUE xlim<-if(hasArg(xlim)) list(...)$xlim else range(x$times) ylim<-if(hasArg(ylim)) list(...)$ylim else if(log.lineages) log(c(1,1.05*max(x$ltt))) else c(0,1.1*max(x$ltt)) xlab<-if(hasArg(xlab)) list(...)$xlab else "time" ylab<-if(hasArg(ylab)) list(...)$ylab else if(log.lineages) "log(lineages)" else "lineages" args<-list(...) args$log.lineages<-NULL args$colors<-NULL args$legend<-NULL args$show.tree<-NULL args$show.total<-NULL args$add<-NULL args$xlim<-xlim args$ylim<-ylim args$xlab<-xlab args$ylab<-ylab args$x<-NA if(!add) do.call(plot,args) tips<-if(log.lineages) seq(0,log(Ntip(x$tree)), length.out=Ntip(x$tree)) else 1:Ntip(x$tree) if(show.tree){ mar<-par()$mar plot(x$tree, make.transparent(colors[1:(ncol(x$ltt)-1)],0.5), tips=tips,xlim=xlim,ylim=ylim, ftype="off",add=TRUE,lwd=1,mar=mar) plot.window(xlim=xlim,ylim=ylim) } if(!show.total) dd<-1 else dd<-0 for(i in 1:(ncol(x$ltt)-dd)){ LTT<-if(log.lineages) log(x$ltt) else x$ltt if(outline) lines(x$times,LTT[,i],type="s",lwd=lwd+2, col=if(par()$bg=="transparent") "white" else par()$bg) lines(x$times,LTT[,i],type="s",lwd=lwd,col=colors[i]) } if(plot.leg){ nn<-colnames(x$ltt) if(!show.total) nn<-setdiff(nn,"total") legend(legend,nn,pch=22,pt.bg=colors[nn],pt.cex=1.2, cex=0.8,bty="n") } } print.ltt.simmap<-function(x,digits=4,...){ ss<-sort(unique(c(getStates(x$tree,"tips"), getStates(x$tree,"nodes")))) cat("Object of class \"ltt.simmap\" containing:\n\n") cat(paste("(1) A phylogenetic tree with ",Ntip(x$tree), " tips, ",x$tree$Nnode," internal\n",sep= "")) cat(paste(" nodes, and a mapped state with ",length(ss), " states.\n\n",sep="")) cat(paste("(2) A matrix containing the number of lineages in each\n", " state (ltt) and event timings (times) on the tree.\n\n",sep="")) if(!is.null(x$gamma)) cat(paste("(3) A value for Pybus & Harvey's \"gamma\"", " statistic of\n gamma = ",round(x$gamma,digits), ", p-value = ", round(x$p,digits),".\n\n",sep="")) } ltt.multiPhylo<-function(tree,drop.extinct=FALSE,gamma=TRUE,...){ if(!inherits(tree,"multiPhylo")){ stop("tree must be object of class \"multiPhylo\".") } else { obj<-lapply(tree,ltt,plot=FALSE,drop.extinct=drop.extinct, log.lineages=FALSE,gamma=gamma) class(obj)<-"multiLtt" return(obj) } } ltt.phylo<-function(tree,plot=TRUE,drop.extinct=FALSE,log.lineages=TRUE, gamma=TRUE,...){ # set tolerance tol<-1e-6 # check "phylo" object if(!inherits(tree,"phylo")){ stop("tree must be object of class \"phylo\".") } else { # reorder the tree tree<-reorder.phylo(tree,order="cladewise") if(!is.null(tree$node.label)){ node.names<-setNames(tree$node.label,1:tree$Nnode+Ntip(tree)) tree$node.label<-NULL } else node.names<-NULL ## check if tree is ultrametric & if yes, then make *precisely* ultrametric if(is.ultrametric(tree)){ h<-max(nodeHeights(tree)) time<-c(0,h-sort(branching.times(tree),decreasing=TRUE),h) nodes<-as.numeric(names(time)[2:(length(time)-1)]) ltt<-c(cumsum(c(1,sapply(nodes,function(x,y) sum(y==x)-1,y=tree$edge[,1]))), length(tree$tip.label)) names(ltt)<-names(time) } else { # internal functions # drop extinct tips drop.extinct.tips<-function(phy){ temp<-diag(vcv(phy)) if(length(temp[temp<(max(temp)-tol)])>0) pruned.phy<-drop.tip(phy,names(temp[temp<(max(temp)-tol)])) else pruned.phy<-phy return(pruned.phy) } # first, if drop.extinct==TRUE if(drop.extinct==TRUE) tree<-drop.extinct.tips(tree) # compute node heights root<-length(tree$tip)+1 node.height<-matrix(NA,nrow(tree$edge),2) for(i in 1:nrow(tree$edge)){ if(tree$edge[i,1]==root){ node.height[i,1]<-0.0 node.height[i,2]<-tree$edge.length[i] } else { node.height[i,1]<-node.height[match(tree$edge[i,1],tree$edge[,2]),2] node.height[i,2]<-node.height[i,1]+tree$edge.length[i] } } ltt<-vector() tree.length<-max(node.height) # tree length n.extinct<-sum(node.height[tree$edge[,2]<=length(tree$tip),2]<(tree.length-tol)) # fudge things a little bit node.height[tree$edge[,2]<=length(tree$tip),2]<- node.height[tree$edge[,2]<=length(tree$tip),2]+1.1*tol time<-c(0,node.height[,2]); names(time)<-as.character(c(root,tree$edge[,2])) temp<-vector() time<-time[order(time)] time<-time[1:(tree$Nnode+n.extinct+1)] # times # get numbers of lineages for(i in 1:(length(time)-1)){ ltt[i]<-0 for(j in 1:nrow(node.height)) ltt[i]<-ltt[i]+(time[i]>=(node.height[j,1]- tol)&&time[i]<=(node.height[j,2]-tol)) } ltt[i+1]<-0 for(j in 1:nrow(node.height)) ltt[i+1]<-ltt[i+1]+(time[i+1]<=(node.height[j,2]+tol)) # set names (these are the node indices) names(ltt)<-names(time) # append 0,1 for time 0 ltt<-c(1,ltt) time<-c(0,time) # subtract fudge factor time[length(time)]<-time[length(time)]-1.1*tol } if(!is.null(node.names)){ nn<-sapply(names(time),function(x,y) if(any(names(y)==x)) y[which(names(y)==x)] else "",y=node.names) names(ltt)<-names(time)<-nn } if(gamma==FALSE){ obj<-list(ltt=ltt,times=time,tree=tree) class(obj)<-"ltt" } else { gam<-gammatest(list(ltt=ltt,times=time)) obj<-list(ltt=ltt,times=time,gamma=gam$gamma,p=gam$p,tree=tree) class(obj)<-"ltt" } } if(plot) plot(obj,log.lineages=log.lineages,...) obj } ## function computes the gamma-statistic & a two-tailed P-value ## written by Liam J. Revell 2011, 2019 gammatest<-function(x){ n<-max(x$ltt) g<-vector() for(i in 2:(length(x$times))) g[i-1]<-x$times[i]-x$times[i-1] T<-sum((2:n)*g[2:n]) doublesum<-0 for(i in 1:(n-1)) for(k in 1:i) doublesum<-doublesum+k*g[k] gamma<-(1/(n-2)*doublesum-T/2)/(T*sqrt(1/(12*(n-2)))) p<-2*pnorm(abs(gamma),lower.tail=F) object<-list(gamma=gamma,p=p) class(object)<-"gammatest" object } ## print method for object class "gammatest" ## written by Liam J. Revell 2019 print.gammatest<-function(x,...){ if(hasArg(digits)) digits<-list(...)$digits else digits<-4 cat("\nAn object of class \"gammatest\" with:\n") cat(paste("(1) Pybus & Harvey's gamma = ", round(x$gamma,digits),sep="")) cat(paste("\n(2) p-value = ",round(x$p,digits), "\n\n",sep="")) } ## S3 print method for object of class "ltt" ## written by Liam J. Revell 2015 print.ltt<-function(x,digits=4,...){ cat("Object of class \"ltt\" containing:\n\n") cat(paste("(1) A phylogenetic tree with ",Ntip(x$tree), " tips and ",x$tree$Nnode," internal\n",sep= "")) cat(" nodes.\n\n") cat(paste("(2) Vectors containing the number of lineages (ltt) and\n", " branching times (times) on the tree.\n\n",sep="")) if(!is.null(x$gamma)) cat(paste("(3) A value for Pybus & Harvey's \"gamma\"", " statistic of\n gamma = ",round(x$gamma,digits), ", p-value = ", round(x$p,digits),".\n\n",sep="")) } ## S3 print method for object of class "multiLtt" ## written by Liam J. Revell 2015 print.multiLtt<-function(x,...){ cat(paste(length(x),"objects of class \"ltt\" in a list\n")) } ## S3 plot method for object of class "ltt" ## written by Liam J. Revell 2015, 2023 plot.ltt<-function(x,...){ args<-list(...) if(hasArg(show.tree_mode)) show.tree_mode<-list(...)$show.tree_mode else show.tree_mode<-"classic" args$show.tree_mode<-NULL args$x<-x$time if(!is.null(args$log.lineages)){ logl<-args$log.lineages args$log.lineages<-NULL } else logl<-TRUE if(!is.null(args$show.tree)){ show.tree<-args$show.tree args$show.tree<-NULL } else show.tree<-FALSE if(!is.null(args$transparency)){ transparency<-args$transparency args$transparency<-NULL } else transparency<-0.3 args$y<-if(logl) log(x$ltt) else x$ltt if(is.null(args$xlab)) args$xlab<-"time" if(is.null(args$ylab)) args$ylab<-if(logl) "log(lineages)" else "lineages" if(is.null(args$type)) args$type<-"s" if(hasArg(add)){ add<-list(...)$add args$add<-NULL } else add<-FALSE if(!add) do.call(plot,args) else do.call(lines,args) if(show.tree){ tips<-if(par()$ylog) exp(setNames(seq(log(min(args$y)),log(max(args$y)), length.out=Ntip(x$tree)),x$tree$tip.label)) else setNames(1:Ntip(x$tree), x$tree$tip.label) if(show.tree_mode=="classic"){ plotTree(x$tree,color=rgb(0,0,1,transparency), ftype="off",add=TRUE,mar=par()$mar,tips=tips) } else if(show.tree_mode=="next generation"){ ## this doesn't really work yet plotTree(x$tree,color=rgb(0,0,1,transparency), ftype="off",add=TRUE,mar=par()$mar,tips=tips, plot=FALSE) pp<-get("last_plot.phylo",envir=.PlotPhyloEnv) max_yy<-max(pp$yy) max_y<-max(args$y) hh<-c(tips,(pp$yy[1:x$tree$Nnode+Ntip(x$tree)]/max_yy)* args$y[as.character(1:x$tree$Nnode+Ntip(x$tree))]+1) for(i in 1:nrow(x$tree$edge)) lines(pp$xx[x$tree$edge[i,]], hh[x$tree$edge[i,]],col=rgb(0,0,1,transparency),lwd=2) } } } ## S3 plot method for object of class "multiLtt" ## written by Liam J. Revell 2015, 2020 plot.multiLtt<-function(x,...){ max.lineages<-max(sapply(x,function(x) max(x$ltt))) max.time<-max(sapply(x,function(x) max(x$time))) args<-list(...) if(!is.null(args$log.lineages)) logl<-list(...)$log.lineages else logl<-TRUE if(is.null(args$xlim)) args$xlim<-c(0,max.time) if(is.null(args$ylim)) args$ylim<-if(logl) c(0,log(max.lineages)) else c(1,max.lineages) args$x<-x[[1]] do.call(plot,args) args$add<-TRUE if(!is.null(args$log)) args$log<-NULL if(length(x)>2){ for(i in 2:length(x)){ args$x<-x[[i]] do.call(plot,args) } } else { args$x<-x[[2]] do.call(plot,args) } } ## compute the gamma statistic through time by slicing the tree n times ## written by Liam J. Revell 2017 gtt<-function(tree,n=100,...){ if(!inherits(tree,"phylo")) stop("tree must be object of class \"phylo\".") if(inherits(tree,"simmap")) tree<-as.phylo(tree) if(hasArg(plot)) plot<-list(...)$plot else plot<-FALSE obj<-ltt(tree,plot=FALSE) t<-obj$times[which(obj$ltt==3)[1]] h<-max(nodeHeights(tree)) x<-seq(t,h,by=(h-t)/(n-1)) trees<-lapply(x,treeSlice,tree=tree,orientation="rootwards") gamma<-sapply(trees,function(x,plot){ obj<-unlist(gammatest(ltt<-ltt(x,plot=FALSE))); if(plot) plot(ltt,xlim=c(0,h),ylim=c(1,Ntip(tree)), log.lineages=FALSE,log="y"); Sys.sleep(0.01); obj},plot=plot) object<-list(t=x,gamma=gamma[1,],p=gamma[2,],tree=tree) class(object)<-"gtt" object } ## plot method for "gtt" object class plot.gtt<-function(x,...){ args<-list(...) args$x<-x$t args$y<-x$gamma if(!is.null(args$show.tree)){ show.tree<-args$show.tree args$show.tree<-NULL } else show.tree<-TRUE if(is.null(args$xlim)) args$xlim<-c(0,max(x$t)) if(is.null(args$xlab)) args$xlab<-"time" if(is.null(args$ylab)) args$ylab<-expression(gamma) if(is.null(args$lwd)) args$lwd<-3 if(is.null(args$type)) args$type<-"s" if(is.null(args$bty)) args$bty<-"l" if(is.null(args$main)) args$main<-expression(paste(gamma," through time plot")) do.call(plot,args) if(show.tree) plotTree(x$tree,add=TRUE,ftype="off",mar=par()$mar, xlim=args$xlim,color=make.transparent("blue",0.1)) } ## print method for "gtt" object class print.gtt<-function(x,...) cat("Object of class \"gtt\".\n\n") ## perform the MCCR test of Pybus & Harvey (2000) ## written by Liam J. Revell 2018 mccr<-function(obj,rho=1,nsim=100,...){ N<-round(Ntip(obj$tree)/rho) tt<-pbtree(n=N,nsim=nsim) foo<-function(x,m) drop.tip(x,sample(x$tip.label,m)) tt<-lapply(tt,foo,m=N-Ntip(obj$tree)) g<-sapply(tt,function(x) ltt(x,plot=FALSE)$gamma) P<-if(obj$gamma>median(g)) 2*mean(g>=obj$gamma) else 2*mean(g<=obj$gamma) result<-list(gamma=obj$gamma,"P(two-tailed)"=P,null.gamma=g) class(result)<-"mccr" result } ## print method for "mccr" object class print.mccr<-function(x,digits=4,...){ cat("Object of class \"mccr\" consisting of:\n\n") cat(paste("(1) A value for Pybus & Harvey's \"gamma\"", " statistic of \n gamma = ",round(x$gamma,digits), ".\n\n",sep="")) cat(paste("(2) A two-tailed p-value from the MCCR test of ", round(x$'P(two-tailed)',digits),".\n\n", sep = "")) cat(paste("(3) A simulated null-distribution of gamma from ", length(x$null.gamma),"\n simulations.\n\n",sep="")) } ## plot method for "mccr" object class plot.mccr<-function(x,...){ if(hasArg(main)) main<-list(...)$main else main=expression(paste("null distribution of ", gamma)) if(hasArg(las)) las<-list(...)$las else las<-par()$las if(hasArg(cex.axis)) cex.axis<-list(...)$cex.axis else cex.axis<-par()$cex.axis if(hasArg(cex.lab)) cex.lab<-list(...)$cex.lab else cex.lab<-par()$cex.lab hh<-hist(x$null.gamma,breaks=min(c(max(12, round(length(x$null.gamma)/10)),20)), plot=FALSE) if(hasArg(ylim)) ylim<-list(...)$ylim else ylim<-c(0,1.15*max(hh$counts)) plot(hh,xlim=range(c(x$gamma,x$null.gamma)), main=main,xlab=expression(gamma),col="lightgrey", ylim=ylim,las=las,cex.axis=cex.axis,cex.lab=cex.lab) arrows(x0=x$gamma,y0=par()$usr[4],y1=0,length=0.12, col=make.transparent("blue",0.5),lwd=2) text(x$gamma,0.96*par()$usr[4], expression(paste("observed value of ",gamma)), pos=if(x$gamma>mean(x$null.gamma)) 2 else 4, cex=0.9) }phytools/MD50000644000176200001440000004254514547214442012464 0ustar liggesusersb00388e3f4c0df0dd5936c7ab1e3f9f4 *DESCRIPTION d7e60ae7e98574c74db5877e945cd068 *NAMESPACE ec1dee2fc5dce861a4a896e13a10a9a5 *R/Dtest.R 5f60a06d03452eb4bc666a408a802d2d *R/add.everywhere.R 9426283177b929e1b56e9db51ede92aa *R/add.random.R 30f5b1a58539aec4b00e952018bed1d8 *R/add.species.to.genus.R f0df86c98d2fd0c6d76f49ca3172d129 *R/allFurcTrees.R 1b654dce383a756fe4f214a87e4edf8f *R/anc.Bayes.R 717587314843beab5cc2e340d878fb54 *R/anc.ML.R 227c5163b6303989b36dbe9d50a7f53b *R/anc.trend.R 96a051e7661aa1e6e5bb86e2fc88b055 *R/ancThresh.R 8d7a1eca30411b0c4a5dbd317eb8ded3 *R/ansi_phylo.R d72ed296570647cb605d5a44e203698b *R/asr.R b4370ca2e81994950a38971b00b1fbff *R/backbonePhylo.R 257581027aa95c317e9b142070df4aa2 *R/bd.R f6cd6217da06c39a9a772bc12ed4f08e *R/bmPlot.R 894d5f9b5dbf164c92714fd15d41dbf9 *R/branching.diffusion.R a5565533ec8749dcfdeabf1a8f1a0011 *R/brownie.lite.R 77dabd05904e508c0a4212d428ad1c4e *R/brownieREML.R a648aa9a5343145acfad897b61602806 *R/collapseTree.R 1001c3a0359677faf03cd3912d5aacd5 *R/compare.chronograms.R 859d9a5ccb241fac7cd3725def92efb5 *R/consensus.edges.R 39566e4dfb31922a70ec7faf77b401d7 *R/contMap.R da57bb9b366d110d4230a88927918406 *R/cophylo.R c6caa20ceaa72a8a1dc2e71efa9ea19e *R/cospeciation.R 7bac2c7e46584bde715070a091a96588 *R/cotangleplot.R f7ffd39dc1f6c31378ee311508708bfb *R/ctt.R 4780bb72ca9b5e2ba460d397d9b4bfbe *R/densityMap.R a651a11526c62a939580958d664aea3d *R/densityTree.R 6b9d32e18b09e645cdd891c1fdbdc920 *R/dotTree.R f9e7d25514ebb3ae6652e09d83e796f5 *R/drop.tip.simmap.R bef780c00ce923e2306295f2dcd7bf8b *R/estDiversity.R c9d4a3228dab12645f5ba40b4f65e0bd *R/evol.rate.mcmc.R 8cd153f13dd4178fc08a1c27392af646 *R/evol.vcv.R 9c6f7941595c9c8ae1ed18367d332672 *R/evolvcv.lite.R c8494a85a3ac2b0445223a712d908fa0 *R/exhaustiveMP.R 362547498225ba74362a42b118a56fa6 *R/export.as.xml.R fc0a8a0fdd8152f5be6036593472c8e6 *R/fancyTree.R 03fff04c8916711b67d41a1149b5cac7 *R/fastAnc.R cd01d292d5010fb53a51c3e99c33c836 *R/fastBM.R fd4043fe4370b493b19344fc752bcdf5 *R/fitBayes.R 5dea5bbc52a54f447611c336aed8414e *R/fitBiogeog.R 2180796336a37244d12cd384282ae33b *R/fitDiversityModel.R 98e2adc3cc57a6ab7bf772a1b756facc *R/fitHRM.R 9a6361e8073f01d47c843c168d1876d0 *R/fitMk.R 5a85f1321d8b90ccee42893c5a0400c9 *R/fitMk.parallel.R 21e1d3b817b7eb50fe200ea40e9dcd8a *R/fitPagel.R 0d6ebbb6e87e9892c47898a6831e05a5 *R/fitgammaMk.R 8cd79ef739c6750bc21c06985ccaa6a1 *R/fitmultiMk.R b3d4fefeee9b89b74a2bd247e929a906 *R/fitpolyMk.R f76fee5f3a6c579fa48ee4c49968a49c *R/locate.fossil.R 449c353c2342e175fee826d6006d1f84 *R/locate.yeti.R 54b53787c2fab92344f41ede3e02fc0d *R/ls.consensus.R 17b3e287c00f7d6720aa08f8b3e2f739 *R/ltt.R d1669270abede61af74c637d742da68c *R/ltt95.R 07c37a4c09941dfa8088c4eb91ef5c4a *R/make.era.map.R 81602ad21876b8fbdb6fb8830fc8213d *R/make.simmap.R b535cd4a22f407601477a0c787a8f869 *R/map.overlap.R 952c17ed89f2b3cc9bf20af676243e39 *R/map.to.singleton.R bf6c23b046ed30ee9e9183582aceb070 *R/mcmcBM.R 659b234e9ff4b00daa511a06f72d53d2 *R/mcmcBM.full.R 9fc1c1054aa693a9ad32044d21e9f8c4 *R/mcmcLambda.R 6f9919970a1d335797cd885a871b5578 *R/mcmcMk.R 306a63ca65efd0e16b7da49f772363f7 *R/mrp.supertree.R 314991d69ef55a811ae81746e6c58cc3 *R/multi.mantel.R c3ef5e950b24d12acc2dee7d7e5d8a7a *R/multiRF.R 4e289b85aaf98808eb0e7eef9377ecc4 *R/multirateBM.R 88577354c3e54f3c98269577681df2c7 *R/optim.phylo.ls.R 4251fbfa33b24cedd655a575878bee3a *R/paintSubTree.R 5351b1bc47f177de86ccb89f313dcbf3 *R/parsimony.R 86f26b836e23ca7099d522bc2c8ab79c *R/pbtree.R fef356d572879792545c304320125813 *R/pgls.Ives.R d6ae21d0453462f3a71d04494b9e5a08 *R/phenogram.R 2902df38646e4bbe78b79d8d7e4b9e6a *R/phyl.RMA.R 3cbec3ddb43718bf824e1b4b5b1bb92b *R/phyl.cca.R aa9caf1d19e59b4ad1ae7f2a85e8f0a5 *R/phyl.pairedttest.R 57bbce073457df044cea3f6794ab0748 *R/phyl.pca.R 17d0e8f613fafc8cf7e0a719120dd9cd *R/phyl.resid.R 138c9ad5ec8f932775a3ac99b96623de *R/phylANOVA.R 82754e445e944f49ccacc078a185f36c *R/phylo.heatmap.R 3fd0311c0d039889d2cca7347e3aaee8 *R/phylo.impute.R 6685744fedec89f1ed1deeb8864d7a4d *R/phylo.to.map.R 678ed4d64e992b5f382bb384e699ba43 *R/phylomorphospace.R 1047bf81c8871bdddbfbfb3080d4c6a6 *R/phylomorphospace3d.R 8f3d67a1350e71d2fb659b8ff2300c66 *R/phylosig.R 3a5045f97da2d4f697eea1e86e46edb7 *R/plotBranchbyTrait.R cb4d01e8989f95541238253031fe9242 *R/plotSimmap.R 63e433890b55602e22ce473680828e9f *R/plotTree.datamatrix.R a58e6ab65dca2e69dde3266c9d05e51e *R/plotTree.errorbars.R 9037dc151922c837a92591eb6edfc25b *R/plotTree.wBars.R f5a165c47374c61b44e4bdc9146603b4 *R/plotrix_fn.R bc0699095386afd623fa2385c68eb218 *R/project.phylomorphospace.R f15de8f61f8f20d0c668ea292fe9824f *R/ratebystate.R c393517b7ce4f9ccd5a44dfa4d541583 *R/ratebytree.R 71c42fdf5fe89798457eaf2492f61e34 *R/rateshift.R 10aa4276f62187281eaa23d509df6f58 *R/read.newick.R 970fb5a7146e3e1626e50fc14ffaef6f *R/read.simmap.R 4ecad496058c6f0f515d3322084deb6f *R/readNexus.R 934cf40fbad98714d55e1fbe8b82405a *R/rerootingMethod.R ba26eefe861f14105c46ee13652c5b66 *R/resolveNodes.R ea9c74afbb146f341a496a189cc1d751 *R/roundPhylogram.R d8a6bb753f6779a1dd49e769b18775a0 *R/sim.corrs.R a02ce76ea678143f57284dae55f34531 *R/sim.history.R 2ba5a409186dff0e81daecac7ab32dec *R/sim.rates.R de02f79e452899513b9e72530461e288 *R/simBMphylo.R 5ae6a2a091d203ecc04ad6081e11293d *R/skewers.R 606ad5a902660277dce5f3ef7fed7461 *R/splitplotTree.R 9d87bee087f95e6046bfca2448626418 *R/starTree.R 0567456c325cbac2c305158ffa05df91 *R/strahlerNumber.R c37de78fdffbe7d46822429a2b8aa7ff *R/threshBayes.R 5a8a89c2fe9a2e54e4d7ef961e241198 *R/tree.grow.R 7e547545cd50de19581af1e1c179e967 *R/treeSlice.R a085bbafb40a7827793f705c70ada505 *R/utilities.R 882f74c8678eb435c58c8179dda25d84 *R/write.simmap.R c7ed057143200025c768b975a2bbef82 *R/writeAncestors.R 65bf87a538f44806311e8914317b242c *R/writeNexus.R 8e78dfc6a432989f6cf7c6d9459b88d9 *data/anole.data.rda 0cc04b5f3865c524c8ec36dc84eccef6 *data/anoletree.rda d533f9ddde14f988d15e6d77a59a9835 *data/ant.geog.rda fe9ad9a9c0b97a65e37a29841f22ba61 *data/ant.tree.rda 53b7dfb734c08524d0e54d7b43114f90 *data/bat.tree.rda a0ff364395ef4fd28858ac372239a56d *data/bat_virus.data.rda fb02a763d8851e2122872879024e4072 *data/betaCoV.tree.rda 7c9a9a27df82353d416095a61344c82f *data/bonyfish.data.rda 9ac6133c528ddd36a866043de32a8bb3 *data/bonyfish.tree.rda 9503e37aa808607175500d4a5edfbedc *data/butterfly.data.rda aa400805c748b5adcb1004380ad4a94c *data/butterfly.tree.rda 077db297dcc197fb06ab871032a9dc23 *data/cordylid.data.rda 375e66e4969f1787e5611d3ad31ff8ff *data/cordylid.tree.rda 33c69eac5b4edd76f9dce88d45d87c63 *data/darter.tree.rda e3e9bbd916cc1f362063987d2fb26b40 *data/datalist 359a5c5a9f7a5ac79472d7c031e2f093 *data/eel.data.rda 30422a363c2043c410cd7600c98d76c7 *data/eel.tree.rda 41ce6896e060587be9edfc7ce60237a4 *data/elapidae.tree.rda 0416c11b7757a8a1b7d4ac5b1e4b4fb5 *data/flatworm.data.rda 0a5fc0e193972b61d818e4fdf6b733d1 *data/flatworm.tree.rda 4d1cff786b0c0149600f5d2e07d54396 *data/liolaemid.data.rda 814f2a6d362a3a54353344098fa13b0e *data/liolaemid.tree.rda 2e7961b7ea60d665bfd7a65fd23b11db *data/mammal.data.rda 668f4861e702e1a55c5b23ce6bc48d82 *data/mammal.geog.rda 114305e2f421cba146fd300da570ab92 *data/mammal.tree.rda 7a03e270f1e299493a6b82fcb0aed4c3 *data/primate.data.rda 09fb6554f3c3b351056b14705e151395 *data/primate.tree.rda 5807bfb760e5b9d95822d9efe4524639 *data/salamanders.rda c7367501b639064f0b47dbc088213730 *data/sunfish.data.rda 5e76e37fc53b3002673868b074ca89ff *data/sunfish.tree.rda e38bfdd909fc73a1235f987e5f807e26 *data/tortoise.geog.rda 2c70433c9f735a7caa2fbef9020a6c81 *data/tortoise.tree.rda cbe017c5cda110030ca0a8da4906f2d4 *data/tropidurid.data.rda 4fd7dda2457dd774caf6f48630bc00e6 *data/tropidurid.tree.rda e3023f4223c0c3863596df1581c4a468 *data/vertebrate.data.rda f5e1db184a75019f551868c00ed2293a *data/vertebrate.tree.rda b7fbd42a08d4aca73426dbb42de518c3 *data/wasp.data.rda 5f4d2752a6176f1bc9ec31cab308b7ce *data/wasp.trees.rda 2f2bca57d275e889465ad6ec74878d9d *data/whale.tree.rda 795702625f965f86449e06fa3e32a204 *inst/CITATION 0eeedf67eafb985ef91f4b95ab180234 *man/Dtest.Rd 9db1befac8b32dc671f32d10e10bb561 *man/add.arrow.Rd 75b2644f30ab4da61f733498328701cf *man/add.color.bar.Rd f6f5aa6f9c0e56e65241eefb890aa2f2 *man/add.everywhere.Rd 0f9cc478cb675298c676323ac3e401f3 *man/add.random.Rd aef6944e1e5f0e91ac247133a46671bd *man/add.simmap.legend.Rd d979327939e54ed809bd18040afadbb1 *man/add.species.to.genus.Rd bb3c2f7738fd879e9a4a716075243d04 *man/aic.w.Rd 9b1180587170a6feabdb9d63a344be66 *man/allFurcTrees.Rd 759cd903f84f55c25d5587df56f8281b *man/anc.Bayes.Rd 2819efaebb6787ed75738dd4474e374c *man/anc.ML.Rd ea0eed5be19e80b2eac7bbb31ceb6dd2 *man/anc.trend.Rd d4aa243ad5a0a73aad601d7c462c2819 *man/ancThresh.Rd 94d8cc08e205a686d2d365c78ede630b *man/ancr.Rd 6f9987e2c20402ad15a04b20caf796ff *man/anoletree.Rd 5ff23152db5a5afd07470a659e35faf1 *man/ansi_phylo.Rd 5ab3f45c3c3bb41525d3cd55fa6805bd *man/applyBranchLengths.Rd 04e968235151143ee013c4e761ba1ec3 *man/as.Qmatrix.Rd 25fbdcf67e859a25806eb8da34ee97a0 *man/as.multiPhylo.Rd 75097204daf13259873b715ca2abc48f *man/ave.rates.Rd 82d84ab911221d3c9766f200c913ae2d *man/averageTree.Rd 42eb2a0df85937df621d85f46709c836 *man/bd.Rd 1dfee19f35759388e40c68bd8be5c8b5 *man/bind.tip.Rd 8326e426f1dacf916d602d6e7090676a *man/bind.tree.simmap.Rd 222009f3fee57c4b2c6fd0743a0848d2 *man/bmPlot.Rd 9114f76d02ffaaf48e860969efb9b903 *man/branching.diffusion.Rd 35d6c67b96515ab6c02f93c69cf92aa2 *man/brownie.lite.Rd 85d92eb1a089f9949e55177574907b97 *man/brownieREML.Rd f001b485eb7d516f1a6a9791e5c8aa17 *man/cladelabels.Rd a83200d94d7ea3dcd956a045e2981bf1 *man/collapse.to.star.Rd 6b62a90f057db94b2981b1ce8f198315 *man/collapseTree.Rd 8268d970d735c0ee3fbbfe132873f69c *man/compare.chronograms.Rd ef422c53c6ecf1b56d06befc65bd19ed *man/consensus.edges.Rd d5127ae9aad23254c476ac51b5d73e09 *man/contMap.Rd ed76d76d54c59f93b7884eb7f69b6aee *man/cophylo.Rd 2b7ef71150a71e203814dd2ea5ce50e2 *man/cospeciation.Rd e5e0f19fd609d0291734939f851264ea *man/countSimmap.Rd 93c9cf477480641e9ffc9f88d98bf9c4 *man/ctt.Rd 3a215a292e4b26ae98d3c8099689646c *man/density.multiSimmap.Rd cf2616dfef51c884bddbb7677d7f7c46 *man/densityMap.Rd 9740cb989f21577c1cfc068de6bd81d8 *man/densityTree.Rd 1dd73c326f1010fb116fbbcff9127d02 *man/describe.simmap.Rd 787b4f8b91c5f99141f11fc838072b07 *man/di2multi.simmap.Rd ffc1af0ff551b47e7ba5ffb733420159 *man/dotTree.Rd 3da25b0107327763fdd080b4eaf5a534 *man/drop.clade.Rd c18c2dffec865979e87a3689493b47ca *man/drop.leaves.Rd 29768bb95639eb9f7bfec74a789f2189 *man/drop.tip.contMap.Rd 8bdd05c2e200117d92b9d7a4150c3c0b *man/drop.tip.multiSimmap.Rd 04bde9950d09dbbcdfeb4fac15df672f *man/drop.tip.simmap.Rd 7e78a56ff34658c5631be1a81e732e4f *man/edge.widthMap.Rd ef322fdb553cc31f5ba49ff75c6d056d *man/edgeProbs.Rd 97b6d3e250f220492f0ec2ffc06f3b56 *man/estDiversity.Rd 2548d1c342c82be3cd3812a6cbfec67a *man/evol.rate.mcmc.Rd e798c50e91faf5c83a2405d7c42100b5 *man/evol.vcv.Rd 20dea2c166130fe3f07579e6111ecc52 *man/evolvcv.lite.Rd d51954ca4f194074a9cbdc070dae9140 *man/exhaustiveMP.Rd 859b09bf18749998893f3937c0c3dd1b *man/expand.clade.Rd eb48fa60bdc119ae107ef6dfdb361e50 *man/export.as.xml.Rd 9d7cac22e6726c4a3cdd2f6d6bbbaff2 *man/fancyTree.Rd 72f8eb8eb0923ef6f8ed79173c61f98c *man/fastAnc.Rd 84c0558eb6d95d89183cea710e02baf2 *man/fastBM.Rd fad7d5fdb90d4457ee97f376b248ae60 *man/fastMRCA.Rd 76e430a82d422055e64dc26bb49f5ba0 *man/findMRCA.Rd e67c6d396ad5942562754aa355a12057 *man/fit.bd.Rd 4c19c08817765bc169cb409fbb7b9ccb *man/fitBayes.Rd 022cde44f57d16a3bf0bb19fcc4a06a6 *man/fitDiversityModel.Rd ed52c90a8e3f890a000c1385ee8f3eef *man/fitMk.Rd 1368520e6c6428c3a4dc936ca6f50604 *man/fitPagel.Rd a7f76809b42d53afe5fc14580f06f8b3 *man/force.ultrametric.Rd 3f27957d1ad3eab2b692794e4cafbb05 *man/gamma_pruning.Rd c2addf73fd49db1b67903b838bd0950b *man/gammatest.Rd 211d45249e1be899967fd1de7e9acf49 *man/genSeq.Rd 8832081b0b28897a8bcd3100e63c93dc *man/geo.legend.Rd 86493fbac4a2ac291d9b27803aa64759 *man/get.treepos.Rd d99c499499cfc50e3ee15801722913e7 *man/getCladesofSize.Rd 82bcfa252287a80a391f271b503e8b04 *man/getDescendants.Rd 56c8018b0ec752efe174f67b40fdbdeb *man/getExtant.Rd c9c41f8a3ecfde3b6b8a4493b83d2f12 *man/getSisters.Rd f832d1b49f2a03ee00a60d6847dbc24d *man/getStates.Rd 3b6df825d7b41d341fd99d1dca3081f6 *man/labelnodes.Rd d15d898ecf1b993a809f861f373615b7 *man/ladderize.simmap.Rd 4281171046954faf9bb12c501c318e69 *man/lambda.transform.Rd 7855d558334420885fb7941926d7db58 *man/likMlambda.Rd eda17fb6d30d262155d47a59b20d29ee *man/linklabels.Rd 98332b2d416e94b061f74cb05f94e316 *man/locate.fossil.Rd ee5c3db0953c70a2d9201f528782bf30 *man/locate.yeti.Rd bfea65eb7d3aa48309394316f03c847d *man/ls.tree.Rd 399d1a554c579d9ec8a05cd7ecf47cb5 *man/ltt.Rd 0b44c4b8ed1454c6e82a5a1947afdf50 *man/ltt95.Rd a83e37b87da9a03d53032ed76c9765fb *man/make.era.map.Rd ba0fd360dbaf6f05c1f60e786bcc8a83 *man/make.simmap.Rd 2a0a50b9f294bba588255b8de9bb7977 *man/map.overlap.Rd 7b9b360138b88a7ce12991aac74616b0 *man/map.to.singleton.Rd 337516648b18b7f637dcd5464c18ffa9 *man/mapped.states.Rd f71e13916ab9aa6f30f2d4f37a116d18 *man/markChanges.Rd a0f8c3f41f09e8e026d47a767310dd54 *man/matchNodes.Rd dcba07ff5911d38915d9cde448effd0e *man/mergeMappedStates.Rd 8e3a62c04dcdb31b3a9648191c77ab36 *man/midpoint.root.Rd 9e1085ec1416e3704bbaf0170020be73 *man/minRotate.Rd f749f906d34ee6a5abc08129d5e6722a *man/minSplit.Rd e6e18c196e7e5bcd2a203d980828e4fd *man/modified.Grafen.Rd 1837efed114da7c3d9f37191a6d99666 *man/mrp.supertree.Rd 3da6e94bc37748be0485f1c568c700ef *man/multi.mantel.Rd 723471d33630e97cd604525e9d1662aa *man/multiC.Rd a74cce8c5eb5b4ac9051d35be189be4f *man/multiRF.Rd 53e0c7746b6b83bdebacc104217fb9b7 *man/multirateBM.Rd 42f97cd7b94191c1b09826200e5177a7 *man/nodeHeights.Rd cb2d24b1127d9aafc1e8ad6b8fcf84b3 *man/nodelabels.cophylo.Rd 067d6f5a4720096357057d75f0fe609b *man/optim.phylo.ls.Rd 719ff71a78354cb57c03fb742a168a80 *man/orderMappedEdge.Rd 31a1dcb7f90b9a9fa2517e988e923ae4 *man/paintSubTree.Rd d71d0e62b33dd54d9dc81b66608d9528 *man/paste.tree.Rd 1e2c69c5865603407121af70344e8395 *man/pbtree.Rd c93735920d0cc303a93bc2dce2db3d19 *man/pgls.Ives.Rd 0e969957de3e318553a5764f22f52a45 *man/phenogram.Rd 743aa9223c4a7a02cac8d4711c644f79 *man/phyl.RMA.Rd a4cc28307437c92daca927686dd5d3e6 *man/phyl.cca.Rd 245bfeb87fcfa80be0cd5fe3c303945a *man/phyl.pairedttest.Rd a892dd8b85a193a46d111350cb3c085b *man/phyl.pca.Rd 25b1e6a856845c6f81122bfe57fd004e *man/phyl.resid.Rd 0ce04f92eeb8872c69c540221a2b5b77 *man/phyl.vcv.Rd ef0bf8097bede24266fc4d9433f15293 *man/phylANOVA.Rd 65625d25b8c3038dfbc6fc809f7f136e *man/phylo.heatmap.Rd b5c2fcd19bc85a9f07e218ac53652c82 *man/phylo.impute.Rd 7a4418d918c3b44b3b14ffef42886f14 *man/phylo.to.map.Rd 48105bf4f1e89a967e370d988cbd0a3d *man/phylo.toBackbone.Rd 2aae12ea32a19445c73b6ce65555f202 *man/phyloDesign.Rd b704af805f8b4a691b670fcb4728a056 *man/phylomorphospace.Rd 1b94866cd265e3ae6931849aea82377f *man/phylomorphospace3d.Rd f3626ec5dd764320c4278bee4618c102 *man/phylosig.Rd edb695624e65e90e69cbe03d7b5d2ecc *man/phytools-package.Rd df34616a95bc3c99c9507d01980daef8 *man/plot.backbonePhylo.Rd cf75196e8c5f3a53c250b45c5d0ff140 *man/plotBranchbyTrait.Rd c80d7f6de5112b2b8fdf2c5cde11a3a7 *man/plotSimmap.Rd c8053764f8cfccde85b3117c33eb2823 *man/plotThresh.Rd 7b96e19f1a6709a43479acfdb1310aa7 *man/plotTree.Rd d593f6568c87a75b9a2b697e0e56c94a *man/plotTree.datamatrix.Rd 6edcda59bdfb87ca6fb163db2f6474c7 *man/plotTree.errorbars.Rd f8d038fbc649580020b5c571355e642b *man/plotTree.wBars.Rd 57d9055392529f20fc7f0a65a43eae07 *man/posterior.evolrate.Rd 062bb73fce98874574ebb039fb877f4d *man/posthoc.Rd 99144cc9e5344f1cd5fc0be1f825cc70 *man/print.backbonePhylo.Rd b00450025d2c6f93187230a6ae585218 *man/pscore.Rd 847df2ce0631763d1ee2c279cf337b8d *man/ratebystate.Rd d2ea7c89f6599937e624c667fce2a28b *man/ratebytree.Rd 59b10d9e97553ff1d2201b0710478900 *man/rateshift.Rd 221de8c234fe158de4b5e88b8544b6f1 *man/read.newick.Rd 32c005f5d12c3c96d94196e1a9019a0c *man/read.simmap.Rd ebe8a1cee939c82e435970775242f32a *man/reorder.backbonePhylo.Rd 115c606909f441266e96058b36960f59 *man/reorderSimmap.Rd 1364e3a921ef37f9c54a2f8c18c02f17 *man/rep.phylo.Rd e39e629d4765ee971431dedf0281c6ed *man/reroot.Rd 8213b769903630136fd419838be2e56e *man/rerootingMethod.Rd 06609ce2cad25812368415d2391ed98c *man/rescale.Rd 44cfac4714e06d4167b7c467f1bd2a78 *man/rescaleSimmap.Rd 1c3acdbb041e16a80b34285cd610e3d6 *man/resolveNode.Rd 40ad0d9e18cd24a28a2198d7acadddd0 *man/rotateNodes.Rd 481c9c2fbc31904ecd1b983a1353dd8f *man/roundBranches.Rd f1eca2de98f2a31f1e2af17e2c2edde2 *man/roundPhylogram.Rd eac3c48a48824ab2fa9ada3d08491965 *man/rstate.Rd 96fe4fa3221e10a5d80bc8d5059a630f *man/sampleFrom.Rd baee3c7b5087af5aa393c9c5323ef4d3 *man/setMap.Rd 0a16ad7acaf05d8b032fdca15bdb3316 *man/sim.corrs.Rd c21babd993c948c407fa97fe97c9622a *man/sim.history.Rd 53ee36c73a8caf76b3455be301e69899 *man/sim.ratebystate.Rd f5aee64004a3229bce0a22606a10a52e *man/sim.rates.Rd a7cb4350d60326448d44f3d4c93e3c7f *man/simBMphylo.Rd 340d84bd55e0727699dd0aedbf55a906 *man/skewers.Rd 0d75762a3b9c72abf9de55382e3a0932 *man/splitEdgeColor.Rd 884bdec7160a34331f98e2c9a21a6981 *man/splitTree.Rd 76faa5481357fb0b273cf500bdebaeb4 *man/splitplotTree.Rd 7825ad0c20e89de47e6f9c4012578ee7 *man/starTree.Rd e2fee3c537bbe8af3c16082f1343feca *man/strahlerNumber.Rd 116fdf4560bd9d4ff803e90ffe61f343 *man/threshBayes.Rd 969e57ec76c10ee064ab8a14d205ab45 *man/threshDIC.Rd 409df3943faccc3bbeb53d3d302ae4ed *man/threshState.Rd 3aa1c69db16db21662c8e34181a6118c *man/to.matrix.Rd 722d3b134caf3a28d33b3538a86bee96 *man/tree.grow.Rd 3610d94563ccbb18db6d9101002d4353 *man/treeSlice.Rd c457ee45aea0706f91bc2e454fd31737 *man/untangle.Rd 20df97808f0d89dc19b0b2f305fc5626 *man/vcvPhylo.Rd 0b92620afbaaa7c998165c178ce29416 *man/write.simmap.Rd ccf84d2336cdcc6f12e5ff90ee2dfecf *man/writeAncestors.Rd eac9a089acbdb43029ca8af7d18b944d *man/writeNexus.Rd phytools/inst/0000755000176200001440000000000014375517350013122 5ustar liggesusersphytools/inst/CITATION0000644000176200001440000000123514546016440014252 0ustar liggesusersbibentry(bibtype = "Article", title = "{p}hytools 2.0: an updated {R} ecosystem for phylogenetic comparative methods (and other things).", author = person("Liam J.", "Revell"), journal = "PeerJ", year = "2024", volume = "12", pages = "e16505", doi = "10.7717/peerj.16505", header = "To cite phytools in a publication please use:", textVersion = "Revell, L. J. (2024) phytools 2.0: an updated R ecosystem for phylogenetic comparative methods (and other things). PeerJ, 12, e16505.", footer = "As phytools is continually evolving you may also want to cite its version number (found with 'library(help = phytools)' or 'packageVersion(\"phytools\")').")