phytools/0000755000176200001440000000000013502156773012144 5ustar liggesusersphytools/inst/0000755000176200001440000000000013502152212013101 5ustar liggesusersphytools/inst/CITATION0000644000176200001440000000113512130372061014240 0ustar liggesuserscitHeader("To cite phytools in publication use:") citEntry( entry="Article", title="phytools: An R package for phylogenetic comparative biology (and other things).", author="Liam J. Revell", journal="Methods in Ecology and Evolution", year=2012, volume="3", pages="217-223", textVersion="Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). Methods Ecol. Evol. 3 217-223. doi:10.1111/j.2041-210X.2011.00169.x" ) citFooter("As phytools is continually evolving, you may want to cite its version number. Find it with 'help(package=phytools)'.") phytools/NAMESPACE0000644000176200001440000002275513477321725013400 0ustar liggesusersexport(add.arrow, add.color.bar, add.everywhere, add.random, add.simmap.legend, add.species.to.genus, aic.w, allFurcTrees) export(allRotations, anc.Bayes, anc.ML, anc.trend, ancThresh, applyBranchLengths, arc.cladelabels, as.multiPhylo, ave.rates, averageTree) export(backbone.toPhylo, bd, bmPlot, bind.tip, bind.tree.simmap, biplot.phyl.pca, branching.diffusion, brownie.lite, brownieREML) export(cladelabels, coef.phyl.RMA, collapse.to.star, collapseTree, compare.chronograms, consensus.edges, contMap, cophylo, countSimmap) export(compute.mr, cospeciation, ctt) export(density.multiSimmap, densityMap, densityTree, describe.simmap, di2multi.simmap, dot.legend, dotTree, drop.clade, drop.leaves) export(drop.tip.contMap, drop.tip.densityMap, drop.tip.simmap, drop.tip.singleton, Dtest) export(edgelabels.cophylo, edgeProbs, errorbar.contMap, estDiversity, evol.rate.mcmc, evol.vcv, evolvcv.lite, exhaustiveMP) export(expand.clade, export.as.xml, extract.clade.simmap, extract.strahlerNumber) export(fancyTree, fastAnc, fastBM, fastDist, fastHeight, fastMRCA, findMRCA, fit.bd, fit.yule, fitBayes, fitMk, fitmultiMk, fitpolyMk) export(fitDiversityModel, fitPagel, force.ultrametric) export(gammatest, genus.to.species.tree, genSeq, geo.palette, geo.legend, get.treepos, getCladesofSize, getDescendants, getExtant, getExtinct, getnode) export(getParent, getSisters, getStates, gtt) export(labelnodes, ladderize.simmap, lambda.transform, lik.bd, likMlambda, likSurface.rateshift, linklabels, locate.fossil, locate.yeti) export(ls.consensus, ls.tree, ltt, ltt95) export(make.era.map, make.simmap, make.transparent, map.overlap, Map.Overlap, map.to.singleton, mapped.states, markChanges) export(matchLabels, matchNodes, mccr, mcmcMk, mergeMappedStates, midpoint.root, minRotate, minSplit, minTreeDist, modified.Grafen) export(mrp.supertree, multi.mantel, multiC, multiOU, multiRF) export(nodeheight, nodeHeights, nodelabels.cophylo, node.paths) export(optim.phylo.ls, orderMappedEdge) export(paintBranches, paintSubTree, paste.tree, pbtree, pgls.Ives, pgls.SEy, phenogram, phenogram95, phyl.cca, phyl.pairedttest, phyl.pca, phyl.resid, phyl.RMA) export(phyl.vcv, phylo.heatmap, phylo.impute, phylo.toBackbone, phylo.to.map, phylANOVA, phyloDesign, phylomorphospace, phylomorphospace3d, phyloScattergram) export(phylosig, plot.changesMap, plot.contMap, plot.cophylo, plot.densityMap, plot.fitMk, plot.fitPagel, plot.phyl.RMA, plot.phylo.to.map) export(plot.gfit, plotBranchbyTrait, plotSimmap, plotThresh, plotTree, plotTree.barplot, plotTree.boxplot, plotTree.datamatrix, plotTree.errorbars) export(plotTree.singletons, plotTree.splits, plotTree.wBars, posterior.evolrate, posthoc, posthoc.ratebytree, project.phylomorphospace) export(ratebystate, ratebytree, rateshift, read.newick, read.simmap, reorder.backbonePhylo, reorderSimmap, rep.multiPhylo, rep.phylo) export(repPhylo, reroot, rerootingMethod, rescaleSimmap, resolveAllNodes, resolveNode, rotate.multi, rotateNodes, rootedge.to.singleton) export(roundBranches, roundPhylogram, rstate) export(sampleFrom, setMap, sim.corrs, sim.ctt, sim.history, sim.Mk, sim.multiCtt, sim.multiMk, sim.ratebystate, sim.rates, skewers, splitEdgeColor) export(splitplotTree, splitTree, starTree, strahlerNumber) export(threshBayes, threshDIC, threshState, tiplabels.cophylo, tipRotate, to.matrix, treeSlice) export(untangle) export(vcvPhylo) export(write.simmap, writeAncestors, writeNexus) S3method(plot, densityMap) S3method(plot, contMap) S3method(plot, phylo.to.map) S3method(plot, backbonePhylo) S3method(reorder, backbonePhylo) S3method(print, backbonePhylo) S3method(print, phyl.pca) S3method(summary, phyl.pca) S3method(biplot, phyl.pca) S3method(print, brownie.lite) S3method(print, densityMap) S3method(print, contMap) S3method(print, rateshift) S3method(logLik, rateshift) S3method(print, evol.vcv) S3method(plot, ltt95) S3method(print, ltt95) S3method(plot, describe.simmap) S3method(print, describe.simmap) S3method(rep, phylo) S3method(rep, multiPhylo) S3method(print, fitPagel) S3method(print, ltt) S3method(print, multiLtt) S3method(plot, ltt) S3method(plot, multiLtt) S3method(plot, cophylo) S3method(print, cophylo) S3method(plot, simmap) S3method(print, simmap) S3method(summary, simmap) S3method(plot, multiSimmap) S3method(print, multiSimmap) S3method(summary, multiSimmap) S3method(reorder, simmap) S3method(plot, rateshift) S3method(print, fastAnc) S3method(print, anc.ML) S3method(print, fitMk) S3method(summary, fitMk) S3method(logLik, fitMk) S3method(print, brownieREML) S3method(AIC, fitMk) 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(AIC, 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(AIC, 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) importFrom(animation, ani.options, ani.record, ani.replay, saveVideo) importFrom(ape, .PlotPhyloEnv, .uncompressTipLabel, ace, all.equal.phylo, as.DNAbin, as.phylo, bind.tree, branching.times, collapse.singles) importFrom(ape, consensus, compute.brlen, cophenetic.phylo, corBrownian, di2multi, dist.dna, dist.nodes, drop.tip, edgelabels, extract.clade) importFrom(ape, getMRCA, is.binary) importFrom(ape, is.monophyletic, is.rooted, is.ultrametric, ladderize, matexpo, mrca, multi2di) importFrom(ape, nodelabels, Ntip, pic, plot.phylo, prop.part, read.tree, reorder.phylo, root.phylo, rotate, rtree, stree, tiplabels) importFrom(ape, unroot, vcv, vcv.phylo, write.tree) importFrom(clusterGeneration, genPositiveDefMat) importFrom(maps, map) importFrom(mnormt, dmnorm, pd.solve) importFrom(numDeriv, hessian) importFrom(phangorn, allTrees, Ancestors, as.phyDat, dist.hamming, midpoint, NJ, nni, nnls.tree, optim.parsimony, parsimony, phyDat, pratchet, treedist, RF.dist, KF.dist, path.dist, SPR.dist, Children, Descendants, threshStateC) importFrom(plotrix, arctext, draw.arc, draw.circle, draw.ellipse, textbox) importFrom(scatterplot3d, scatterplot3d) importFrom(stats, cophenetic, reorder, runif, setNames, optim, dexp, dnorm, rnorm, var, nlminb, biplot, pchisq, rexp, optimize, logLik, as.dist, pnorm, median, cor, aggregate, rgamma, dgamma, lm, rbinom, rgeom, pt, anova, p.adjust, screeplot, rchisq, optimHess, rmultinom, sd, dunif, dist, plogis, density, coef, cmdscale) importFrom(methods, hasArg) importFrom(graphics, strwidth, par, segments, locator, lines, text, strheight, symbols, plot, layout, plot.new, title, axis, points, plot.window, polygon, rect, curve, image, mtext, arrows, barplot, boxplot, contour, hist, abline, legend, grid) importFrom(utils, flush.console, head, installed.packages, str, capture.output) importFrom(grDevices, palette, colors, dev.hold, dev.flush, rainbow, heat.colors, gray, colorRampPalette, dev.new, rgb, pdf, dev.off, col2rgb) importFrom(combinat, permn) importFrom(coda, as.mcmc, HPDinterval) importFrom(nlme, gls, varFixed) importFrom(MASS, ginv) importFrom(expm, expm) importFrom(gtools, combinations) phytools/data/0000755000176200001440000000000013502152212013035 5ustar liggesusersphytools/data/anoletree.rda0000644000176200001440000001222312564410646015522 0ustar liggesusers] |SE)aAXP@ r$7i"\(-M.M yc)-觟QYE"( XD'"--;1g+vJQ~33g̜yސ982Nt\45%c{E N>mp`nB.pwr@KB=S'Y*r 鈜l!>TC95#OXGL~O4IѩΩ)I$ 'R թӑz~2!dH7\CK58HG(.\Mi( tJ-Щ/  4S 2$2ByC:Ю\9\ȇ|2 %ZDBȷpг),2 %r 9ovg/R 4+ԡSS  ʩq1mCX~  +[= @o%x2 4 9Z?h% W@-@KJ! H8t?@ ~ AA'/?$‡P ./ zt ~ >G(;Gpc!\GCjXn,\Ч>?8 g /gcx2!?>C n&D5˃Ik]x= kieBVn!AnX @h C~W!/bœVp_~Bx%5ECu+.Ӷ^ vPʍ((5+b; 0 Fl ;y!V6Bg1׆K ŠU0ĆydDo+*t)F:m[ֵ56J>N eWb\Ib:p}ڀhVQ˰+o+$k(}划p 8&|ڼKVw7ʼyip:jvc㻵m %a"X)W-u)_ 6y1en߸E ݂Vxkq(:NB= !,5O݉ݒ4^DסZnea*RZ2-ŰQ/!waiieM3NE?Jg`廕_ i1sZgthY-gr56# 8. 6}I7_]k~wF?붋/C+o_ Unl6zc_3ܵς4TohGߦt&gDk| }KǮ k_l"$ל]mPGѬ6=u2љ-;]ba:xS_gIFUUtxހCz"+:6w{P;%r[7q-I$toSTmxu>סS?6u%_8:?q;p;19bKż!/,ѽs*['?P; EUOޣ?;E5LYh?6tAf\[;ѱ.E>2\JY 0 w6:;n ~= &WOFgBﰼIt^oW.xzSwBkt|nAZGO7ԴL~SZknVt`VNƫ߽ʞ_p5A{6t,Y>m&_ъj銊˿BsWYJ'̞}ytb{):ZSJL&K>%{:[SmYhD_mG$e/7O^T~hH6ѱ]wtOA[Uf?t)DC;s~?gUѱ)c=l& ]<~^Ir-19MŐGRѡj7xoj};|̀2{G?.~' X>;&.Λ, Ӽ~]aw7,Lt]ܓn؀j%=oD oy륱=^md:w0ţ% }b3fmuEJx'vגu??Rݯm}>ͪѴf>*^Rp_D+=87o޿{$ ,q{i5:sW ţ2` g7돪ύE,׽8׃[thtt5=ޅؘ3M[^"ڬ?Lygh.٭{8~VqS5!QJxak04"R#I.փKL'N&R6 h.₆!0PQʆޑA C#%PJ4 h)0TG]pxi:&!k䱷5T6tva@L.(0DD ӘajDr"(J4L(0l ץ*[!:xk?}_maB*7-C[6M9HbA2e$UntR/\$5 U,e-wD&Ɣuz򿞜|jp kG6NaMi冡a OYnSv< mVPFrk$',X(]Sfbw l߁i\nXY4Gx3Y/}*EJ Ѱ̣Db KFJ4,(ゆE*,e)eÂ7òv,)[?WV&[mv/Q4ͰplP\Bm7v mu:jyKdCvvٶ]D67hQ-JٰQBJ4l 8s6" 4l,Ѣ#Om0949;Utf½?24ccd;-Vn/lQaK..hC@*m_8.zpwPVcTaC G[?U; UvxMALfĘv'L6E)ѰuJոavҥDÆo #O]lN禡>IFUԷz.єm6dkR6l|L;N)6)Ѱmt:2oy݁$wЬz-ykt1#Siw" sH8r 1(pA#ʹ/PʆJ4 :h8!Qʆ&ʹG͎D9ӭGۭ#rE9'#1J4Qx oqAÁ%(p8H9p]$ں-ކGV 1)pt:7>*y5v}lϠVdLk庩{{ڴAG<5,- x)p4)ӡ3hnL{j!wGwg1vm먥#\}~hş˭Sc/\jdj2į!'ڋQ8Yn/>[<'^~qN/ɘj>3F%.w.mNdC]}.C6]#\}~}Gȷ܆n$6Y>p?SM/1dZ>Vf|e#sp<[k6h51VVbXj3cHKL:cJ$ҀinKc w#y neXXIh306IbL䲌0~3cQK︼;O*ؤڰZRimVƐd `0)lg#$lXp ~ŬAf %R+c`UY0"sX1΃hѐfs0aY lSr45"i2fZAPE.6hRq*I1UEU0lI6AӀmgs1!TeV'+TJy R`ؔY=C$, :l%)r=Ĩ[BtdVe1#nF$FlE5I7. z0),o43tgUC*)X_cekb(kP'W; Sn`XV]j`mb±rW58Oa(ư õkmiʚNf3Id -d ep06ڔY6 j9 1Ul0YnCX=Y;+ۋbe{lQqj%kd̲ذ+5`M٦,i*c*SAPٲ,[-Z\e3(  *9Z01 "{blYE}qw4˺]F0㒙e#q&9V&=Mr*™2)WHQefPw2%I78vV&]E%<6`,r`u*NC  UQhuO*WW.75O=?[>@Ǖ jN6+'&t Nޛ#f|WϻRo-m2hܐ?m{6r{)? .g5N4c͚vTjt)%ۇ]6z -.(7칮F>4ȏ7ShLjX"Lk5%2"㉣0A/ nhFoQI{x[wHUk6bH x$|,2)`sEMd*_ΰU ”6R$c W@LWoŬnphytools/R/0000755000176200001440000000000013502152214012327 5ustar liggesusersphytools/R/backbonePhylo.R0000644000176200001440000002453612741776063015266 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(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<-par("cex")*(max(strwidth(sapply(cw$tip.clade,function(x) x$label), units="inches")))+1.37*par("cex")*strwidth("W",units="inches") alp<-optimize(function(a,H,sw,pp) (a*1.04*max(H)+sw-pp)^2,H=X,sw=sw,pp=pp, interval=c(0,1e6))$minimum 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]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(show.zeros||Q[i,j]>tol){ if(abs(diff(c(i,j)))==1||abs(diff(c(i,j)))==(nstates-1)) text(mean(c(s[1],e[1]))+1.5*shift.x, mean(c(s[2],e[2]))+1.5*shift.y, round(Q[i,j],signif),cex=cex.rates, srt=atan(dy/dx)*180/pi) else text(mean(c(s[1],e[1]))+0.3*diff(c(s[1],e[1]))+ 1.5*shift.x, mean(c(s[2],e[2]))+0.3*diff(c(s[2],e[2]))+ 1.5*shift.y, round(Q[i,j],signif),cex=cex.rates, srt=atan(dy/dx)*180/pi) arrows(s[1],s[2],e[1],e[2],length=0.05, code=if(isSymmetric(Q)) 3 else 2,lwd=lwd) } } text(v.x,v.y,x$states,cex=cex.traits, col=make.transparent("black",0.7)) } ## S3 plot method for objects resulting from fitDiscrete plot.gfit<-function(x,...){ if("mkn"%in%class(x$lik)==FALSE){ stop("Sorry. No plot method presently available for objects of this type.") } 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" plot(obj,...) } } ## wraps around expm ## written by Liam Revell 2011, 2017 EXPM<-function(x,...){ e_x<-if(isSymmetric(x)) matexpo(x) else expm(x,...) dimnames(e_x)<-dimnames(x) e_x } ## function to simulate multiple-rate Mk multiMk ## written by Liam J. Revell 2018 sim.multiMk<-function(tree,Q,anc=NULL,nsim=1,...){ if(hasArg(as.list)) as.list<-list(...)$as.list else as.list<-FALSE ss<-rownames(Q[[1]]) tt<-map.to.singleton(reorder(tree)) P<-vector(mode="list",length=nrow(tt$edge)) for(i in 1:nrow(tt$edge)) P[[i]]<-expm(Q[[names(tt$edge.length)[i]]]*tt$edge.length[i]) if(nsim>1) X<- if(as.list) vector(mode="list",length=nsim) else data.frame(row.names=tt$tip.label) for(i in 1:nsim){ a<-if(is.null(anc)) sample(ss,1) else anc STATES<-matrix(NA,nrow(tt$edge),2) root<-Ntip(tt)+1 STATES[which(tt$edge[,1]==root),1]<-a for(j in 1:nrow(tt$edge)){ new<-ss[which(rmultinom(1,1,P[[j]][STATES[j,1],])[,1]==1)] STATES[j,2]<-new ii<-which(tt$edge[,1]==tt$edge[j,2]) if(length(ii)>0) STATES[ii,1]<-new } x<-as.factor( setNames(sapply(1:Ntip(tt),function(n,S,E) S[which(E==n)], S=STATES[,2],E=tt$edge[,2]),tt$tip.label)) if(nsim>1) X[,i]<-x else X<-x } X } ## constant-rate Mk model simulator ## written by Liam J. Revell 2018 sim.Mk<-function(tree,Q,anc=NULL,nsim=1,...){ if(hasArg(as.list)) as.list<-list(...)$as.list else as.list<-FALSE ss<-rownames(Q) tt<-reorder(tree) P<-vector(mode="list",length=nrow(tt$edge)) for(i in 1:nrow(tt$edge)) P[[i]]<-expm(Q*tt$edge.length[i]) if(nsim>1) X<- if(as.list) vector(mode="list",length=nsim) else data.frame(row.names=tt$tip.label) for(i in 1:nsim){ a<-if(is.null(anc)) sample(ss,1) else anc STATES<-matrix(NA,nrow(tt$edge),2) root<-Ntip(tt)+1 STATES[which(tt$edge[,1]==root),1]<-a for(j in 1:nrow(tt$edge)){ new<-ss[which(rmultinom(1,1,P[[j]][STATES[j,1],])[,1]==1)] STATES[j,2]<-new ii<-which(tt$edge[,1]==tt$edge[j,2]) if(length(ii)>0) STATES[ii,1]<-new } x<-as.factor( setNames(sapply(1:Ntip(tt),function(n,S,E) S[which(E==n)], S=STATES[,2],E=tt$edge[,2]),tt$tip.label)) if(nsim>1) X[[i]]<-x else X<-x } X } phytools/R/read.newick.R0000644000176200001440000000707113123275047014662 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/ls.consensus.R0000644000176200001440000001054212727621740015126 0ustar liggesusersls.consensus<-function(trees,start=NULL,tol=1e-12,quiet=FALSE,...){ D<-Reduce("+",lapply(trees,function(x,t) cophenetic(x)[t,t], t=trees[[1]]$tip.label))/length(trees) if(is.null(start)) start<-NJ(D) if(hasArg(ultrametric)) ultrametric<-list(...)$ultrametric ## should the consensus tree be ultrametric else ultrametric<-all(sapply(trees,is.ultrametric)) if(ultrametric&&!is.rooted(start)) start<-midpoint(start) curr<-nnls.tree(D,tree=start,rooted=ultrametric,trace=0) if(hasArg(optNNI)) optNNI<-list(...)$optNNI else optNNI<-TRUE if(optNNI){ Q<-Inf Qp<-attr(curr,"RSS") if(is.null(Qp)) Qp<-rss(D,curr) ct<-0 while((Q-Qp)>tol){ Q<-Qp NNIs<-.uncompressTipLabel(nni(curr)) curr<-list(curr) class(curr)<-"multiPhylo" NNIs<-c(NNIs,curr) NNIs<-lapply(NNIs,nnls.tree,dm=D,rooted=ultrametric,trace=0) 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)) 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)) } 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(!rt) NNIs<-lapply(NNIs,unroot) NNIs<-lapply(NNIs,nnls.tree,dm=D,rooted=rt,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]] 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/paintSubTree.R0000644000176200001440000000636312564235740015104 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/contMap.R0000644000176200001440000001647513105347341014076 0ustar liggesusers## function plots reconstructed values for ancestral characters along the edges of the tree ## written by Liam J. Revell 2012-2017 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<-0:res/res*max(h) 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 plot.contMap<-function(x,...){ if(inherits(x,"contMap")){ lims<-x$lims x<-list(tree=x$tree,cols=x$cols) class(x)<-"densityMap" } else stop("x should be an object of class \"contMap\"") H<-nodeHeights(x$tree) # get & set optional arguments if(hasArg(legend)) legend<-list(...)$legend else legend<-NULL if(hasArg(fsize)) fsize<-list(...)$fsize else fsize<-NULL if(hasArg(ftype)) ftype<-list(...)$ftype else ftype<-NULL if(hasArg(outline)) outline<-list(...)$outline else outline<-TRUE if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-4 if(hasArg(sig)) sig<-list(...)$sig else sig<-3 if(hasArg(type)) type<-list(...)$type else type<-"phylogram" if(hasArg(mar)) mar<-list(...)$mar else mar<-rep(0.3,4) if(hasArg(direction)) direction<-list(...)$direction else direction<-"rightwards" if(hasArg(offset)) offset<-list(...)$offset else offset<-NULL if(hasArg(xlim)) xlim<-list(...)$xlim else xlim<-NULL if(hasArg(ylim)) ylim<-list(...)$ylim else ylim<-NULL if(hasArg(hold)) hold<-list(...)$hold else hold<-TRUE if(is.null(legend)) legend<-0.5*max(H) if(is.null(fsize)) fsize<-c(1,1) if(length(fsize)==1) fsize<-rep(fsize,2) if(is.null(ftype)) ftype<-c("i","reg") if(length(ftype)==1) ftype<-c(ftype,"reg") if(hasArg(leg.txt)) leg.txt<-list(...)$leg.txt else leg.txt<-"trait value" # done optional arguments leg.txt<-c(round(lims[1],sig),leg.txt,round(lims[2],sig)) plot(x,fsize=fsize,ftype=ftype,lwd=lwd,legend=legend,outline=outline,leg.txt=leg.txt, type=type,mar=mar,direction=direction,offset=offset,xlim=xlim,ylim=ylim,hold=hold) } ## S3 print method for object of class 'contMap' ## written by Liam J. Revell 2013 print.contMap<-function(x,digits=6,...){ cat("Object of class \"contMap\" containing:\n\n") cat(paste("(1) A phylogenetic tree with ",length(x$tree$tip.label)," tips and ",x$tree$Nnode," internal nodes.\n\n",sep="")) cat(paste("(2) A mapped continuous trait on the range (",round(x$lims[1],digits),", ",round(x$lims[2],digits),").\n\n",sep="")) } ## drop tips from an object of class 'contMap' ## written by Liam J. Revell 2014 drop.tip.contMap<-function(x,tip){ if(!inherits(x,"contMap")) cat("x should be an object of class \"contMap\"\n") else { x$tree<-drop.tip.simmap(x$tree,tip) return(x) } } ## add error bars to contMap plot ## written by Liam J. Revell 2017 errorbar.contMap<-function(obj,...){ if(hasArg(x)) x<-list(...)$x else x<-setNames(sapply(1:Ntip(obj$tree),function(x,obj){ ii<-which(obj$tree$edge[,2]==x) ss<-names(obj$tree$maps[[ii]][length(obj$tree$maps[[ii]])]) obj$lims[1]+as.numeric(ss)/(length(obj$cols)-1)*diff(obj$lims) },obj=obj),obj$tree$tip.label) if(hasArg(scale.by.ci)) scale.by.ci<-list(...)$scale.by.ci else scale.by.ci<-TRUE if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-14 tree<-obj$tree aa<-fastAnc(tree,x,CI=TRUE) xlim<-range(aa$CI95) if(xlim[2]>obj$lims[2]||xlim[1]0) cbind(assoc,assoc) else NULL if(is.null(assoc)){ cat("No associations provided or found.\n") rotate<-FALSE } } ## check to verify that all taxa in assoc are in tree ii<-sapply(assoc[,1],"%in%",tr1$tip.label) if(any(!ii)){ assoc<-assoc[ii,] cat("Some species in assoc[,1] not in tr1. Removing species & links.\n") } ii<-sapply(assoc[,2],"%in%",tr2$tip.label) if(any(!ii)){ assoc<-assoc[ii,] cat("Some species in assoc[,2] not in tr2. Removing species & links.\n") } ## now check if rotation is to be performed if(rotate){ cat("Rotating nodes to optimize matching...\n") flush.console() if("exhaustive"%in%methods){ tt1<-allRotations(tr1) tt2<-allRotations(tr2) M1<-M2<-matrix(NA,length(tt1),length(tt2)) for(i in 1:length(tt1)){ for(j in 1:length(tt2)){ x<-setNames(sapply(assoc[,2],match,table=tt2[[j]]$tip.label),assoc[,1]) y<-setNames(sapply(assoc[,1],match,table=tt1[[i]]$tip.label),assoc[,2]) M1[i,j]<-attr(tipRotate(tt1[[i]],x*Ntip(tr1)/Ntip(tr2),methods="just.compute"),"minRotate") M2[i,j]<-attr(tipRotate(tt2[[j]],y*Ntip(tr2)/Ntip(tr1),methods="just.compute"),"minRotate") } } MM<-M1+M2 ij<-which(MM==min(MM),arr.ind=TRUE) obj<-list() for(i in 1:nrow(ij)){ tr1<-tt1[[ij[i,1]]] attr(tr1,"minRotate")<-M1[ij[i,1],ij[i,2]] tr2<-tt2[[ij[i,2]]] attr(tr2,"minRotate")<-M2[ij[i,1],ij[i,2]] tt<-list(tr1,tr2) class(tt)<-"multiPhylo" obj[[i]]<-list(trees=tt,assoc=assoc) class(obj[[i]])<-"cophylo" } if(length(obj)>1) class(obj)<-"multiCophylo" else obj<-obj[[1]] } else if ("all"%in%methods){ tt1<-allRotations(tr1) tt2<-allRotations(tr2) obj<-vector(mode="list",length=length(tt1)*length(tt2)) ij<-1 for(i in 1:length(tt1)){ for(j in 1:length(tt2)){ x<-setNames(sapply(assoc[,2],match,table=tt2[[j]]$tip.label),assoc[,1]) y<-setNames(sapply(assoc[,1],match,table=tt1[[i]]$tip.label),assoc[,2]) obj[[ij]]<-list(trees=c( tipRotate(tt1[[i]],x*Ntip(tr1)/Ntip(tr2),methods="just.compute"), tipRotate(tt2[[j]],y*Ntip(tr2)/Ntip(tr1),methods="just.compute")), assoc=assoc) class(obj[[ij]])<-"cophylo" ij<-ij+1 } } class(obj)<-"multiCophylo" } else { x<-setNames(sapply(assoc[,2],match,table=tr2$tip.label),assoc[,1]) tr1<-tipRotate(tr1,x*Ntip(tr1)/Ntip(tr2),right=tr2,assoc=assoc,...) best.tr1<-Inf x<-setNames(sapply(assoc[,1],match,table=tr1$tip.label),assoc[,2]) tr2<-tipRotate(tr2,x*Ntip(tr2)/Ntip(tr1),left=tr1,assoc=assoc,...) best.tr2<-Inf while((best.tr2-attr(tr2,"minRotate"))>0||(best.tr1-attr(tr1,"minRotate"))>0){ best.tr1<-attr(tr1,"minRotate") best.tr2<-attr(tr2,"minRotate") x<-setNames(sapply(assoc[,2],match,table=tr2$tip.label),assoc[,1]) tr1<-tipRotate(tr1,x*Ntip(tr1)/Ntip(tr2),right=tr2,assoc=assoc,...) x<-setNames(sapply(assoc[,1],match,table=tr1$tip.label),assoc[,2]) tr2<-tipRotate(tr2,x*Ntip(tr2)/Ntip(tr1),left=tr1,assoc=assoc,...) } tt<-list(tr1,tr2) class(tt)<-"multiPhylo" obj<-list(trees=tt,assoc=assoc) class(obj)<-"cophylo" } cat("Done.\n") } else { tt<-list(tr1,tr2) class(tt)<-"multiPhylo" obj<-list(trees=tt,assoc=assoc) class(obj)<-"cophylo" } obj } ## called internally by plot.cophylo to plot a phylogram ## written by Liam J. Revell phylogram<-function(tree,part=1,direction="rightwards",fsize=1,ftype="i",lwd=1,...){ if(hasArg(pts)) pts<-list(...)$pts else pts<-TRUE if(hasArg(edge.col)) edge.col<-list(...)$edge.col else edge.col<-rep("black",nrow(tree$edge)) if(hasArg(tip.lwd)) tip.lwd<-list(...)$tip.lwd else tip.lwd<-1 if(hasArg(tip.lty)) tip.lty<-list(...)$tip.lty else tip.lty<-"dotted" if(hasArg(tip.len)) tip.len<-list(...)$tip.len else tip.len<-0.1 if(pts==TRUE&&tip.len==0) tip.len<-0.1 d<-if(direction=="rightwards") 1 else -1 ## sub "_" for " " tree$tip.label<-gsub("_"," ",tree$tip.label) ## check if edge lenths if(is.null(tree$edge.length)) tree<-compute.brlen(tree) ## rescale tree so it fits in one half of the plot ## with enough space for labels if(ftype=="off") fsize<-0 n<-Ntip(tree) sh<-fsize*strwidth(tree$tip.label) H<-nodeHeights(tree) th<-sapply(1:n,function(i,x,e) x[which(e==i)],x=H[,2], e=tree$edge[,2])+tip.len*max(H) tree$edge.length<-tree$edge.length/max(th/(part-sh)) ## reorder cladewise to assign tip positions cw<-reorder(tree,"cladewise") y<-vector(length=n+cw$Nnode) y[cw$edge[cw$edge[,2]<=n,2]]<-0:(n-1)/(n-1) ## reorder pruningwise for post-order traversal pw<-reorder(tree,"pruningwise") nn<-unique(pw$edge[,1]) ## compute vertical position of each edge for(i in 1:length(nn)){ yy<-y[pw$edge[which(pw$edge[,1]==nn[i]),2]] y[nn[i]]<-mean(range(yy)) } ## compute start & end points of each edge X<-nodeHeights(cw)-0.5 ## plot horizontal edges for(i in 1:nrow(X)) lines(d*X[i,],rep(y[cw$edge[i,2]],2),lwd=lwd,lend=2, col=edge.col[i]) ## plot vertical relationships for(i in 1:tree$Nnode+n){ ee<-which(cw$edge[,1]==i) p<-if(i%in%cw$edge[,2]) which(cw$edge[,2]==i) else NULL if(!is.null(p)){ xx<-c(X[ee,1],X[p,2]) yy<-sort(c(y[cw$edge[ee,2]],y[cw$edge[p,2]])) } else { xx<-c(X[ee,1],X[ee[1],1]) yy<-sort(c(y[cw$edge[ee,2]],mean(y[cw$edge[ee,2]]))) } segments(x0=d*xx[1:(length(xx)-1)],y0=yy[1:(length(yy)-1)], x1=d*xx[2:length(xx)],y1=yy[2:length(yy)],lwd=lwd,lend=2,col=edge.col[ee]) } h<-part-0.5-tip.len*(max(X)-min(X))-fsize*strwidth(tree$tip.label) ## plot links to tips for(i in 1:n){ lines(d*c(X[which(cw$edge[,2]==i),2],h[i]+tip.len*(max(X)-min(X))),rep(y[i],2), lwd=tip.lwd,lty=tip.lty) if(pts) points(d*X[which(cw$edge[,2]==i),2],y[i],pch=16,cex=pts*0.7*sqrt(lwd)) } ## plot tip labels font<-which(c("off","reg","b","i","bi")==ftype)-1 if(font>0){ for(i in 1:n) TEXTBOX(d*(h[i]+fsize*strwidth(tree$tip.label[i])+ tip.len*(max(X)-min(X))),y[i], tree$tip.label[i], pos=if(d<0) 4 else 2,offset=0, cex=fsize,font=font) } PP<-list(type="phylogram",use.edge.length=TRUE,node.pos=1, show.tip.label=if(ftype!="off") TRUE else FALSE,show.node.label=FALSE, font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE,label.offset=0, x.lim=par()$usr[1:2],y.lim=par()$usr[3:4], direction=direction,tip.color="black",Ntip=Ntip(cw),Nnode=cw$Nnode, edge=cw$edge,xx=d*sapply(1:(Ntip(cw)+cw$Nnode), function(x,y,z) y[match(x,z)],y=X,z=cw$edge),yy=y) assign("last_plot.phylo",PP,envir=.PlotPhyloEnv) ## return rightmost or leftmost edge of tip labels invisible(d*max(h+fsize*strwidth(tree$tip.label)+tip.len*(max(X)-min(X)))) } ## 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 plot.cophylo<-function(x,...){ plot.new() 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 x1<-do.call("phylogram",c(list(tree=x$trees[[1]]),leftArgs)) left<-get("last_plot.phylo",envir=.PlotPhyloEnv) x2<-do.call("phylogram",c(list(tree=x$trees[[2]],direction="leftwards"), rightArgs)) right<-get("last_plot.phylo",envir=.PlotPhyloEnv) if(!is.null(x$assoc)) makelinks(x,c(x1,x2),link.type,link.lwd,link.col, link.lty) else cat("No associations provided.\n") if(any(scale.bar>0)) add.scalebar(x,scale.bar,sb.fsize) assign("last_plot.cophylo",list(left=left,right=right),envir=.PlotPhyloEnv) } ## add scale bar ## written by Liam J. Revell 2015 add.scalebar<-function(obj,scale.bar,fsize){ if(scale.bar[1]>0){ s1<-(0.4-max(fsize*strwidth(obj$trees[[1]]$tip.label)))/max(nodeHeights(obj$trees[[1]])) lines(c(-0.5,-0.5+scale.bar[1]*s1),rep(-0.05,2)) lines(rep(-0.5,2),c(-0.05,-0.06)) lines(rep(-0.5+scale.bar[1]*s1,2),c(-0.05,-0.06)) text(mean(c(-0.5,-0.5+scale.bar[1]*s1)),rep(-0.05,2),scale.bar[1],pos=1) } if(scale.bar[2]>0){ s2<-(0.4-max(fsize*strwidth(obj$trees[[2]]$tip.label)))/max(nodeHeights(obj$trees[[2]])) lines(c(0.5-scale.bar[2]*s2,0.5),rep(-0.05,2)) lines(rep(0.5-scale.bar[2]*s2,2),c(-0.05,-0.06)) lines(rep(0.5,2),c(-0.05,-0.06)) text(mean(c(0.5-scale.bar[2]*s2,0.5)),rep(-0.05,2),scale.bar[2],pos=1) } } ## print an object of class "cophylo" ## written by Liam J. Revell 2015 print.cophylo<-function(x, ...){ cat("Object of class \"cophylo\" containing:\n\n") cat("(1) 2 (possibly rotated) phylogenetic trees in an object of class \"multiPhylo\".\n\n") cat("(2) A table of associations between the tips of both trees.\n\n") } ## print method for "multiCophylo" object print.multiCophylo<-function(x, ...) cat("Object of class \"multiCophylo\" containg",length(x),"objects of class \"cophylo\".\n\n") ## written by Liam J. Revell 2015, 2016 tipRotate<-function(tree,x,...){ if(hasArg(fn)) fn<-list(...)$fn else fn<-function(x) x^2 if(hasArg(methods)) methods<-list(...)$methods else methods<-"pre" if("exhaustive"%in%methods) methods<-"exhaustive" if(hasArg(print)) print<-list(...)$print else print<-FALSE if(hasArg(max.exhaustive)) max.exhaustive<-list(...)$max.exhaustive else max.exhaustive<-20 if(hasArg(rotate.multi)) rotate.multi<-list(...)$rotate.multi else rotate.multi<-FALSE if(rotate.multi) rotate.multi<-!is.binary(tree) if(hasArg(anim.cophylo)) anim.cophylo<-list(...)$anim.cophylo else anim.cophylo<-FALSE if(anim.cophylo){ if(hasArg(left)) left<-list(...)$left else left<-NULL if(hasArg(right)) right<-list(...)$right else right<-NULL if(hasArg(assoc)) assoc<-list(...)$assoc else assoc<-NULL if(is.null(left)&&is.null(right)) anim.cophylo<-FALSE if(hasArg(only.accepted)) only.accepted<-list(...)$only.accepted else only.accepted<-TRUE } tree<-reorder(tree) nn<-1:tree$Nnode+length(tree$tip.label) if("just.compute"%in%methods){ foo<-function(phy,x) sum(fn(x-setNames(1:length(phy$tip.label),phy$tip.label)[names(x)])) oo<-pp<-foo(tree,x) } if("exhaustive"%in%methods){ if(Ntip(tree)>max.exhaustive){ cat(paste("\nmethods=\"exhaustive\" not permitted for more than", max.exhaustive,"tips.\n", "If you are sure you want to run an exhaustive search for a tree of this size\n", "increasing argument max.exhaustive & re-run.\n", "Setting methods to \"pre\".\n\n")) methods<-"pre" } else { cat("Running exhaustive search. May be slow!\n") oo<-Inf tt<-allRotations(tree) foo<-function(phy,x) sum(fn(x-setNames(1:length(phy$tip.label),phy$tip.label)[names(x)])) pp<-sapply(tt,foo,x=x) ii<-which(pp==min(pp)) ii<-if(length(ii)>1) sample(ii,1) else ii tt<-tt[[ii]] pp<-pp[ii] } if(print) message(paste("objective:",pp)) tree<-tt } ANIM.COPHYLO<-function(tree){ dev.hold() if(is.null(left)) plot(cophylo(tree,right,assoc=assoc,rotate=FALSE),...) else if(is.null(right)) plot(cophylo(left,tree,assoc=assoc,rotate=FALSE),...) nodelabels.cophylo(node=i+Ntip(tree),pie=1,col="red",cex=0.4, which=if(is.null(left)) "left" else "right") dev.flush() } if("pre"%in%methods){ for(i in 1:tree$Nnode){ if(anim.cophylo) ANIM.COPHYLO(tree) tt<-if(rotate.multi) rotate.multi(tree,nn[i]) else untangle(rotate(tree,nn[i]),"read.tree") oo<-sum(fn(x-setNames(1:length(tree$tip.label),tree$tip.label)[names(x)])) if(inherits(tt,"phylo")) pp<-sum(fn(x-setNames(1:length(tt$tip.label),tt$tip.label)[names(x)])) if(anim.cophylo&&!only.accepted) ANIM.COPHYLO(tt) else if(inherits(tt,"multiPhylo")){ foo<-function(phy,x) sum(fn(x-setNames(1:length(phy$tip.label),phy$tip.label)[names(x)])) pp<-sapply(tt,foo,x=x) if(anim.cophylo&&!only.accepted) nulo<-lapply(tt,ANIM.COPHYLO) ii<-which(pp==min(pp)) ii<-if(length(ii)>1) sample(ii,1) else ii tt<-tt[[ii]] pp<-pp[ii] } if(oo>pp) tree<-tt if(print) message(paste("objective:",min(oo,pp))) } } if("post"%in%methods){ for(i in tree$Nnode:1){ if(anim.cophylo) ANIM.COPHYLO(tree) tt<-if(rotate.multi) rotate.multi(tree,nn[i]) else untangle(rotate(tree,nn[i]),"read.tree") oo<-sum(fn(x-setNames(1:length(tree$tip.label),tree$tip.label)[names(x)])) if(inherits(tt,"phylo")) pp<-sum(fn(x-setNames(1:length(tt$tip.label),tt$tip.label)[names(x)])) if(anim.cophylo&&!only.accepted) ANIM.COPHYLO(tt) else if(inherits(tt,"multiPhylo")){ foo<-function(phy,x) sum(fn(x-setNames(1:length(phy$tip.label),phy$tip.label)[names(x)])) pp<-sapply(tt,foo,x=x) if(anim.cophylo&&!only.accepted) nulo<-lapply(tt,ANIM.COPHYLO) ii<-which(pp==min(pp)) ii<-if(length(ii)>1) sample(ii,1) else ii tt<-tt[[ii]] pp<-pp[ii] } if(oo>pp) tree<-tt if(print) message(paste("objective:",min(oo,pp))) } } attr(tree,"minRotate")<-min(oo,pp) if(anim.cophylo) ANIM.COPHYLO(tree) tree } ## multi2di for "multiPhylo" object MULTI2DI<-function(x){ obj<-lapply(x,multi2di) class(obj)<-"multiPhylo" obj } ## labeling methods for plotted "cophylo" object ## written by Liam J. Revell 2015 nodelabels.cophylo<-function(...,which=c("left","right")){ obj<-get("last_plot.cophylo",envir=.PlotPhyloEnv) if(which[1]=="left") assign("last_plot.phylo",obj[[1]],envir=.PlotPhyloEnv) else if(which[1]=="right") assign("last_plot.phylo",obj[[2]],envir=.PlotPhyloEnv) nodelabels(...) } edgelabels.cophylo<-function(...,which=c("left","right")){ obj<-get("last_plot.cophylo",envir=.PlotPhyloEnv) if(which[1]=="left") assign("last_plot.phylo",obj[[1]],envir=.PlotPhyloEnv) else if(which[1]=="right") assign("last_plot.phylo",obj[[2]],envir=.PlotPhyloEnv) edgelabels(...) } tiplabels.cophylo<-function(...,which=c("left","right")){ obj<-get("last_plot.cophylo",envir=.PlotPhyloEnv) if(which[1]=="left") assign("last_plot.phylo",obj[[1]],envir=.PlotPhyloEnv) else if(which[1]=="right") assign("last_plot.phylo",obj[[2]],envir=.PlotPhyloEnv) tiplabels(...) } ## function to draw sigmoidal links ## modified from https://stackoverflow.com/questions/32046889/connecting-two-points-with-curved-lines-s-ish-curve-in-r drawCurve<-function(x,y,scale=0.01,...){ x1<-x[1] x2<-x[2] y1<-y[1] y2<-y[2] curve(plogis(x,scale=scale,location=(x1+x2)/2)*(y2-y1)+y1, x1,x2,add=TRUE,...) } ## S3 summary method ## written by Liam J. Revell 2016 summary.cophylo<-function(object,...){ cat("\nCo-phylogenetic (\"cophylo\") object:",deparse(substitute(object)), "\n\n") cat(paste("Tree 1 (left tree) is an object of class \"phylo\" containing", Ntip(object$trees[[1]]),"species.\n\n")) cat(paste("Tree 2 (right tree) is an object of class \"phylo\" containing", Ntip(object$trees[[2]]),"species.\n\n")) cat("Association (assoc) table as follows:\n\n") maxl<-max(sapply(strsplit(object$assoc[,1],""),length)) cat(paste("\tleft:",paste(rep(" ",max(0,maxl-5)),collapse=""), "\t----\tright:\n",sep="")) nulo<-apply(object$assoc,1,function(x,maxl) cat(paste("\t",x[1], paste(rep(" ",maxl-length(strsplit(x[1],split="")[[1]])), collapse=""),"\t----\t",x[2],"\n",sep="")),maxl=maxl) cat("\n") } phytools/R/plotBranchbyTrait.R0000644000176200001440000001441113022022441016101 0ustar liggesusers## function to plot probability or trait value by branch ## written by Liam J. Revell 2013, 2014, 2016 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(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,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) 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])) } 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) } } phytools/R/sim.rates.R0000644000176200001440000000530113061416301014356 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/splitplotTree.R0000644000176200001440000000740312563246417015347 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/anc.ML.R0000644000176200001440000002305613424153210013530 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") } phytools/R/add.species.to.genus.R0000644000176200001440000000464112616504147016415 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/phyl.resid.R0000644000176200001440000000375312561736201014553 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/make.simmap.R0000644000176200001440000004216513440066336014676 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 make.simmap<-function(tree,x,model="SYM",nsim=1,...){ if(inherits(tree,"multiPhylo")){ ff<-function(yy,x,model,nsim,...){ zz<-make.simmap(yy,x,model,nsim,...) if(nsim>1) class(zz)<-NULL return(zz) } if(nsim>1) mtrees<-unlist(sapply(tree,ff,x,model,nsim,...,simplify=FALSE),recursive=FALSE) else mtrees<-sapply(tree,ff,x,model,nsim,...,simplify=FALSE) class(mtrees)<-c("multiSimmap","multiPhylo") } else { ## get optional arguments if(hasArg(pi)) pi<-list(...)$pi else pi<-"equal" if(hasArg(message)) pm<-list(...)$message else pm<-TRUE if(hasArg(tol)) tol<-list(...)$tol else tol<-0 if(hasArg(Q)) Q<-list(...)$Q else Q<-"empirical" if(hasArg(burnin)) burnin<-list(...)$burnin else burnin<-1000 if(hasArg(samplefreq)) samplefreq<-list(...)$samplefreq else samplefreq<-100 if(hasArg(vQ)) vQ<-list(...)$vQ else vQ<-0.1 prior<-list(alpha=1,beta=1,use.empirical=FALSE) if(hasArg(prior)){ pr<-list(...)$prior prior[names(pr)]<-pr } ## done optional arguments # check if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".") # if vector convert to binary matrix if(!is.matrix(x)) xx<-to.matrix(x,sort(unique(x))) else xx<-x xx<-xx[tree$tip.label,] xx<-xx/rowSums(xx) # reorder to cladewise tree<-bt<-reorder.phylo(tree,"cladewise") if(!is.binary(bt)) bt<-multi2di(bt) # 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 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 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 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 lapply(1:nsim,function(x,y) y, y=pi) if(pm) printmessage(Reduce('+',Q)/length(Q),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.matrix(Q)){ XX<-getPars(bt,xx,model,Q=Q,tree,tol,m,pi=pi,args=list(...)) L<-XX$L logL<-XX$loglik 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 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 the 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 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) II<-obj$index.matrix+1 lvls<-obj$states if(liks){ L<-obj$lik.anc rownames(L)<-N+1:nrow(L) if(!is.binary(tree)){ ancNames<-matchNodes(tree,bt) L<-L[as.character(ancNames[,2]),] rownames(L)<-ancNames[,1] } L<-rbind(xx,L) rownames(L)[1:N]<-1:N } else L<-NULL Q<-matrix(c(0,obj$rates)[II],m,m,dimnames=list(lvls,lvls)) if(any(rowSums(Q,na.rm=TRUE)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 with states:\n", sep="")) if(length(ss)>printlen) cat(paste("\t",paste(ss[1:printlen],collapse=", "),", ...\n",sep="")) else cat(paste("\t",paste(ss,collapse=", "),"\n",sep="")) rlab<-if(is.rooted(x)) "Rooted" else "Unrooted" cat("\n",rlab,"; includes branch lengths.\n",sep="") } print.multiSimmap<-function(x,details=FALSE,...){ N<-length(x) cat(N,"phylogenetic trees with mapped discrete characters\n") if(details){ n<-sapply(x,Ntip) s<-sapply(x,function(x) length(unique(c(getStates(x,"tips"),getStates(x,"nodes"))))) for(i in 1:N) cat("tree",i,":",n[i],"tips,",s[i],"mapped states\n") } } ## S3 summary method for objects of class "simmap" & "multiSimmap" summary.simmap<-function(object,...) describe.simmap(object,...) summary.multiSimmap<-function(object,...) describe.simmap(object,...) ## for backward compatibility with any function using apeAce internally apeAce<-function(tree,x,model,fixedQ=NULL,...){ if(hasArg(output.liks)){ output.liks<-list(...)$output.liks return(fitMk(tree,x,model,fixedQ,...)) } else { output.liks<-TRUE return(fitMk(tree,x,model,fixedQ,output.liks=TRUE,...)) } } ## S3 logLik methods for "simmap" & "multiSimmap" logLik.simmap<-function(object,...) object$logL logLik.multiSimmap<-function(object,...) sapply(object,function(x) x$logL) ## S3 density method for "multiSimmap" density.multiSimmap<-function(x,...){ if(hasArg(method)) method<-list(...)$method else method<-"changes" if(!method%in%c("densityMap","changes")){ cat("method not recognized. Setting to default method.\n\n") method<-"changes" } if(method=="densityMap") obj<-densityMap(x,plot=FALSE,...) else if(method=="changes"){ if(hasArg(bw)) bw<-list(...)$bw else bw<-1 tmp<-summary(x) ab<-lapply(2:ncol(tmp$count),function(i,x) x[,i],x=tmp$count) names(ab)<-sapply(strsplit(colnames(tmp$count)[2:ncol(tmp$count)], ","),function(x) paste(x,collapse="->")) ab<-lapply(ab,function(x){ class(x)<-"mcmc" x }) if(.check.pkg("coda")){ hpd.ab<-lapply(ab,HPDinterval) } else { cat(" HPDinterval requires package coda.\n") cat(" Computing 95% interval from samples only.\n\n") hpd95<-function(x){ obj<-setNames(c(sort(x)[round(0.025*length(x))], sort(x)[round(0.975*length(x))]), c("lower","upper")) attr(obj,"Probability")<-0.95 obj } hpd.ab<-lapply(ab,hpd95) } minmax<-range(unlist(ab)) pcalc<-function(x,mm) hist(x,breaks=seq(mm[1]-1.5,mm[2]+1.5,bw),plot=FALSE) p.ab<-lapply(ab,pcalc,mm=minmax) states<-colnames(tmp$ace) trans<-names(ab) obj<-list(hpd=hpd.ab, p=p.ab, states=states,trans=trans, bw=bw, mins=sapply(ab,min), meds=sapply(ab,median), means=sapply(ab,mean), maxs=sapply(ab,max)) class(obj)<-"changesMap" } else if(method=="timings"){ cat("This method doesn't work yet.\n") obj<-NULL } obj } ## S3 plot method for "changesMap" object from density.multiSimmap plot.changesMap<-function(x,...){ p<-x$p hpd<-x$hpd bw<-x$bw if(length(x$trans)==2){ plot(p[[1]]$mids,p[[1]]$density,xlim=c(min(x$mins)-1, max(x$maxs)+1),ylim=c(0,1.2*max(c(p[[1]]$density, p[[2]]$density))), type="n",xlab="number of changes", ylab="relative frequency across stochastic maps") 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=make.transparent("red",0.3),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=make.transparent("blue",0.3),border=FALSE) lines(p[[2]]$mids-bw/2,p[[2]]$density,type="s") add.simmap.legend(colors=setNames(c(make.transparent("red",0.3), make.transparent("blue",0.3)),x$trans[1:2]), prompt=FALSE,x=min(x$mins),y=0.95*par()$usr[4]) 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)) text(mean(hpd[[1]]),max(p[[1]]$density)+dd, paste("HPD(",x$trans[1],")",sep=""), 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)) text(mean(hpd[[2]]),max(p[[2]]$density)+dd, paste("HPD(",x$trans[2],")",sep=""), pos=3) } else { k<-length(x$states) par(mfrow=c(k,k)) ii<-1 max.d<-max(unlist(lapply(p,function(x) x$density))) for(i in 1:k){ for(j in 1:k){ if(i==j) plot.new() else { plot(p[[ii]]$mids,p[[ii]]$density,xlim=c(min(x$mins)-1, max(x$maxs)+1),ylim=c(0,1.2*max.d), type="n",xlab="number of changes", ylab="relative frequency",main=x$trans[ii],font.main=1) ##title(main=) 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=make.transparent("blue",0.3),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/locate.fossil.R0000644000176200001440000001022213353261264015226 0ustar liggesusers## code to place a fossil taxon into a tree using ML and continuous data ## written by Liam J. Revell 2014, 2015, 2017 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(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) } fossilML<-function(tree,X,quiet,tip,edge.constraint,time.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 } 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]) upper<-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(class(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/fitpolyMk.R0000644000176200001440000001667013440246646014460 0ustar liggesusers## fitpolyMk ## written by Liam J. Revell 2019 fitpolyMk<-function(tree,x,model="SYM",ordered=FALSE,...){ if(hasArg(quiet)) quiet<-list(...)$quiet else quiet<-FALSE if(is.factor(x)) x<-setNames(as.character(x),names(x)) X<-strsplit(x,"+",fixed=TRUE) ns<-sapply(X,length) if(all(ns==1)){ cat("No polymorphic species found. Use fitMk.\n\n") object<-NULL } else { ## get the states states<-sort(unique(unlist(X))) if(ordered){ ss<-vector() for(i in 1:(length(states)-1)) ss<-c(ss,states[i],paste(states[i],states[i+1],sep="+")) ss<-c(ss,states[i+1]) tmodel<-matrix(0,length(ss),length(ss),dimnames=list(ss,ss)) } else { ss<-vector() for(i in 1:length(states)) ss<-c(ss,apply(combinations(length(states),i,states), 1,paste,collapse="+")) tmodel<-matrix(0,length(ss),length(ss),dimnames=list(ss,ss)) } poly<-strsplit(ss,"+",fixed=TRUE) index<-0 for(i in 1:nrow(tmodel)){ for(j in i:ncol(tmodel)){ INT<-intersect(poly[[i]],poly[[j]]) SDij<-setdiff(poly[[i]],poly[[j]]) SDji<-setdiff(poly[[j]],poly[[i]]) if(length(INT)>0 &&(0%in%c(length(SDij),length(SDji))) &&(1%in%c(length(SDij),length(SDji)))){ if(model=="ER"){ tmodel[i,j]<-tmodel[j,i]<-1 } else if(model%in%c("ARD","SYM")){ index<-index+1 tmodel[i,j]<-index if(model=="SYM") tmodel[j,i]<-index else { tmodel[j,i]<-index+1 index<-index+1 } } else if(model=="transient") { if(length(poly[[i]])>length(poly[[j]])){ tmodel[i,j]<-1 tmodel[j,i]<-2 } else { tmodel[i,j]<-2 tmodel[j,i]<-1 } } } } } if(!quiet){ cat("\nThis is the design matrix of the fitted model. Does it make sense?\n\n") print(tmodel) cat("\n") } X<-to.matrix(x,ss) object<-fitMk(tree,X,model=tmodel,...) } object$model<-model object$ordered<-ordered 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(x$pi) cat(paste("\nLog-likelihood:",round(x$logLik,digits),"\n")) cat(paste("\nOptimization method used was \"",x$method,"\"\n\n",sep="")) } ## logLik method for objects of class "fitpolyMk" logLik.fitpolyMk<-function(object,...){ lik<-object$logLik attr(lik,"df")<-length(object$rates) lik } ## AIC method AIC.fitpolyMk<-function(object,...,k=2){ np<-length(object$rates) -2*logLik(object)+np*k } ## 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 Q<-matrix(NA,length(x$states),length(x$states)) Q[]<-c(0,x$rates)[x$index.matrix+1] diag(Q)<-0 spacer<-0.1 plot.new() par(mar=mar) xylim<-c(-1.2,1.2) plot.window(xlim=xylim,ylim=xylim,asp=1) if(!is.null(main)) title(main=main,cex.main=cex.main) nstates<-length(x$states) if(x$ordered){ step<-360/nstates angles<-seq(-floor(nstates/2)*step,360-ceiling(nstates/2)*step,by=step)/180*pi if(nstates==2) angles<-angles+pi/2 v.x<-sin(angles) v.y<-cos(angles) for(i in 1:nstates) for(j in 1:nstates) if(if(!isSymmetric(Q)) i!=j else i>j){ dx<-v.x[j]-v.x[i] dy<-v.y[j]-v.y[i] slope<-abs(dy/dx) shift.x<-0.02*sin(atan(dy/dx))*sign(j-i)*if(dy/dx>0) 1 else -1 shift.y<-0.02*cos(atan(dy/dx))*sign(j-i)*if(dy/dx>0) -1 else 1 s<-c(v.x[i]+spacer*cos(atan(slope))*sign(dx)+ if(isSymmetric(Q)) 0 else shift.x, v.y[i]+spacer*sin(atan(slope))*sign(dy)+ if(isSymmetric(Q)) 0 else shift.y) e<-c(v.x[j]+spacer*cos(atan(slope))*sign(-dx)+ if(isSymmetric(Q)) 0 else shift.x, v.y[j]+spacer*sin(atan(slope))*sign(-dy)+ if(isSymmetric(Q)) 0 else shift.y) if(x$index.matrix[i,j]!=0){ if(abs(diff(c(i,j)))==1||abs(diff(c(i,j)))==(nstates-1)) text(mean(c(s[1],e[1]))+1.5*shift.x, mean(c(s[2],e[2]))+1.5*shift.y, round(Q[i,j],signif),cex=cex.rates, srt=atan(dy/dx)*180/pi) else text(mean(c(s[1],e[1]))+0.3*diff(c(s[1],e[1]))+ 1.5*shift.x, mean(c(s[2],e[2]))+0.3*diff(c(s[2],e[2]))+ 1.5*shift.y, round(Q[i,j],signif),cex=cex.rates, srt=atan(dy/dx)*180/pi) arrows(s[1],s[2],e[1],e[2],length=0.05, code=if(isSymmetric(Q)) 3 else 2,lwd=lwd) } } text(v.x,v.y,x$states,cex=cex.traits, col=make.transparent("black",0.7)) } else { Ns<-inv.ncombn(nstates) step.y<-2/(Ns-1) v.x<-v.y<-vector() for(i in 1:Ns){ nc<-ncombn(Ns,i) v.x<-c(v.x,if(nc>1) seq(-1,1,by=2/(nc-1)) else 0) v.y<-c(v.y,rep(1-rep((i-1)*step.y,nc))) } for(i in 1:nstates) for(j in 1:nstates) if(if(!isSymmetric(Q)) i!=j else i>j){ dx<-v.x[j]-v.x[i] dy<-v.y[j]-v.y[i] slope<-abs(dy/dx) shift.x<-0.02*sin(atan(dy/dx))*sign(j-i)*if(dy/dx>0) 1 else -1 shift.y<-0.02*cos(atan(dy/dx))*sign(j-i)*if(dy/dx>0) -1 else 1 s<-c(v.x[i]+spacer*cos(atan(slope))*sign(dx)+ if(isSymmetric(Q)) 0 else shift.x, v.y[i]+spacer*sin(atan(slope))*sign(dy)+ if(isSymmetric(Q)) 0 else shift.y) e<-c(v.x[j]+spacer*cos(atan(slope))*sign(-dx)+ if(isSymmetric(Q)) 0 else shift.x, v.y[j]+spacer*sin(atan(slope))*sign(-dy)+ if(isSymmetric(Q)) 0 else shift.y) if(x$index.matrix[i,j]!=0){ if(abs(diff(c(i,j)))==1||abs(diff(c(i,j)))==(nstates-1)) text(mean(c(s[1],e[1]))+1.5*shift.x, mean(c(s[2],e[2]))+1.5*shift.y, round(Q[i,j],signif),cex=cex.rates, srt=atan(dy/dx)*180/pi) else text(mean(c(s[1],e[1]))+0.3*diff(c(s[1],e[1]))+ 1.5*shift.x, mean(c(s[2],e[2]))+0.3*diff(c(s[2],e[2]))+ 1.5*shift.y, round(Q[i,j],signif),cex=cex.rates, srt=atan(dy/dx)*180/pi) arrows(s[1],s[2],e[1],e[2],length=0.05, code=if(isSymmetric(Q)) 3 else 2,lwd=lwd) } } text(v.x,v.y,x$states,cex=cex.traits, col=make.transparent("black",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) } phytools/R/ratebystate.R0000644000176200001440000000610413440066554015016 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 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) V<-phyl.vcv(cbind(x,y),vcv(tree),lambda=1)$R if(method=="by.branch"){ aa<-c(x[tree$tip.label],fastAnc(tree,x)) names(aa)[1:length(tree$tip)]<-1:length(tree$tip) aa<-rowMeans(matrix(aa[tree$edge],nrow(tree$edge),2)) a<-vector() for(i in 1:tree$Nnode+length(tree$tip)){ j<-which(tree$edge[,1]==i) a[i-length(tree$tip)]<-sum(aa[j]*tree$edge.length[j])/sum(tree$edge.length[j]) } names(a)<-1:tree$Nnode+length(tree$tip) } else a<-fastAnc(tree,x) if(logarithm) a<-exp(a) b<-pic(y,tree)[names(a)]^2 r<-cor(a,b,method=corr) beta<-setNames(lm(b~a)$coefficients[2],NULL) foo<-function(tree,V){ if(sim.method=="fastBM") XY<-fastBM(tree,nsim=2)%*%sqrt(diag(diag(V))) else if(sim.method=="sim.corrs") XY<-sim.corrs(tree,V) a<-fastAnc(tree,XY[,1]) b<-pic(XY[,2],tree)[names(a)]^2 r<-cor(a,b,method=corr) return(r) } r.null<-c(r,replicate(nsim-1,foo(tree,V))) P<-mean(abs(r.null)>=abs(r)) obj<-list(beta=beta,r=r,P=P,corr=corr,method=method) class(obj)<-"ratebystate" obj } # function simulates rate by state evolution for x & y # written by Liam J. Revell 2013 sim.ratebystate<-function(tree,sig2x=1,sig2y=1,beta=c(0,1),...){ if(hasArg(method)) method<-list(...)$method else method<-"by.node" if(hasArg(plot)) plot<-list(...)$plot else plot<-FALSE if(hasArg(logarithm)) logarithm<-list(...)$logarithm else logarithm<-FALSE x<-fastBM(tree,a=if(logarithm) beta[1] else 0,sig2=sig2x,internal=TRUE) if(method=="by.node") ss<-x[1:tree$Nnode+length(tree$tip.label)] else if(method=="by.branch") ss<-rowMeans(matrix(x[tree$edge],nrow(tree$edge),2)) zz<-tree if(!logarithm) zz$edge.length<-beta[2]*zz$edge.length*(beta[1]+ss-min(ss)) else zz$edge.length<-beta[2]*zz$edge.length*exp(ss) y<-fastBM(zz,sig2=sig2y) if(plot) phenogram(zz,x,type="b",colors="blue",ftype="off", xlab="expected variance",ylab="independent variable (x)") x<-x[tree$tip.label] return(cbind(x,y)) } ## S3 print method print.ratebystate<-function(x,digits=6,...){ cat("\nObject of class \"ratebystate\".\n") cat("\nSummary of object:\n") cat(paste(" beta[1] = ",round(x$beta,digits),"\n",sep="")) cat(paste(" ",if(x$corr=="pearson") "Pearson " else "Spearman ","correlation (r) = ",round(x$r,digits), "\n",sep="")) cat(paste(" P-value (from simulation) = ",round(x$P,digits), "\n\n",sep="")) cat(paste("Analysis was conducted using \"",x$method, "\" method.\n\n",sep="")) } phytools/R/bmPlot.R0000644000176200001440000001006212564206726013725 0ustar liggesusers# visualize discrete time Brownian simulation on a tree # written by Liam J. Revell 2012, 2013, 2015 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,...){ 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") for(i in 1:length(X)) lines(X[[i]],T[[i]]) if(hasArg(colors)) cols<-list(...)$colors else cols<-"black" return(cols) } # plots type="threshold" th<-function(X,T,...){ 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") 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)) 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)) 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)) } 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/multi.mantel.R0000644000176200001440000000620113207557454015103 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 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 unfoldLower<-function(X){ if(class(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/fitmultiMk.R0000644000176200001440000001140113211613076014601 0ustar liggesusers## new function to fit multi-regime Mk model ## written by Liam J. Revell 2017 ## adapted from ape::ace by E. Paradis et al. 2013 fitmultiMk<-function(tree,x,model="ER",...){ if(!inherits(tree,"simmap")){ stop("tree should be an object of class \"simmap\". Use fitMk.\n") } else { regimes<-mapped.states(tree) nregimes<-length(regimes) } if(hasArg(q.init)) q.init<-list(...)$q.init else q.init<-length(unique(x))/sum(tree$edge.length) if(hasArg(opt.method)) opt.method<-list(...)$opt.method else opt.method<-"nlminb" if(hasArg(min.q)) min.q<-list(...)$min.q else min.q<-1e-12 if(is.matrix(x)){ x<-x[tree$tip.label,] m<-ncol(x) states<-colnames(x) } else { x<-to.matrix(x,sort(unique(x))) x<-x[tree$tip.label,] m<-ncol(x) states<-colnames(x) } if(hasArg(pi)) pi<-list(...)$pi else pi<-"equal" if(pi[1]=="equal") pi<-setNames(rep(1/m,m),states) else pi<-pi/sum(pi) if(is.character(model)){ rate<-matrix(NA,m,m) if(model=="ER"){ k<-rate[]<-1 diag(rate)<-NA } else if(model=="ARD"){ k<-m*(m-1) rate[col(rate)!=row(rate)]<-1:k } else if(model=="SYM"){ k<-m*(m-1)/2 ii<-col(rate)length(tree$tip.label),2]) points(c(XX[1,1],XX[tree$edge[,2]>length(tree$tip.label),2]),c(YY[1,1], YY[tree$edge[,2]>length(tree$tip.label),2]),pch=pch,cex=node.size[1], col=if(pch%in%c(1:20)) con$col.node[as.character(zz)] else "black", bg=if(pch%in%c(21:25)) con$col.node[as.character(zz)] else NULL) zz<-tree$edge[tree$edge[,2]<=length(tree$tip.label),2] points(XX[tree$edge[,2]<=length(tree$tip.label),2],YY[tree$edge[,2]<=length(tree$tip.label),2], pch=pch,cex=node.size[2],col=if(pch%in%c(1:20)) con$col.node[as.character(zz)] else "black", bg=if(pch%in%c(21:25)) con$col.node[as.character(zz)] else NULL) zz<-sapply(1:length(tree$tip.label),function(x,y) which(x==y),y=tree$edge[,2]) if(label!="off"){ asp<-(par()$usr[2]-par()$usr[1])/(par()$usr[4]-par()$usr[3]) for(i in 1:length(tree$tip.label)){ ii<-which(tree$edge[,2]==i) aa<-atan(asp*(YY[ii,2]-YY[ii,1])/(XX[ii,2]-XX[ii,1]))/(2*pi)*360 adj<-if(XX[ii,2]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))^2)) d<-d*dscale V.diff<-V.diff*dscale^2 ## maximize the likelihood if(!fixed) fit<-optim(c(mean(pic(d,multi2di(tree))^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))^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/densityMap.R0000644000176200001440000002275713476542032014617 0ustar liggesusers# function plots posterior density of mapped states from stochastic mapping # written by Liam J. Revell 2012, 2013, 2014, 2015, 2016 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")) 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 plot.densityMap<-function(x,...){ if(class(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(is.null(legend)) legend<-0.5*max(H) if(is.null(fsize)) fsize<-c(1,1) if(length(fsize)==1) fsize<-rep(fsize,2) if(is.null(ftype)) ftype<-c("i","reg") if(length(ftype)==1) ftype<-c(ftype,"reg") # done optional arguments if(legend){ if(legend>max(H)){ message("legend scale cannot be longer than total tree length; resetting") legend<-0.5*max(H) } } if(hold) null<-dev.hold() if(type=="phylogram"){ if(direction%in%c("upwards","downwards")&&legend){ par(mar=mar) plot.new() } N<-length(tree$tip.label) if(legend&&is.null(ylim)){ if(direction%in%c("rightwards","leftwards")) ylim<-c(1-0.12*(N-1),N) else { pp<-par("pin")[2] sw<-(fsize*(max(strwidth(x$tree$tip.label,units="inches")))+ 1.37*fsize*strwidth("W",units="inches"))[1] alp<-optimize(function(a,H,sw,pp) (a*1.2*max(H)+sw-pp)^2,H=H,sw=sw,pp=pp, interval=c(0,1e6))$minimum ylim<-if(direction=="downwards") c(min(H)-sw/alp-0.16*max(H),max(H)) else c(min(H)-0.16*max(H),max(H)+sw/alp) } } else if(is.null(ylim)) ylim<-NULL if(outline){ par(col="transparent") plotTree(tree,fsize=fsize[1],lwd=lwd[1]+2, offset=offset+0.2*lwd[1]/3+0.2/3,ftype=ftype[1],xlim=xlim, ylim=ylim,mar=mar,direction=direction,hold=FALSE, add=direction%in%c("upwards","downwards")&&legend) par(col="black") } 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) 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], direction=if(!is.null(xlim)) if(xlim[2]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,],XX[(n+1):nrow(XX),]) else XX<-rbind(yy,YY$lik.anc[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\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\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/estDiversity.R0000644000176200001440000000503713477063153015173 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/fastAnc.R0000644000176200001440000000565713463332441014056 0ustar liggesusers## function does fast estimation of ML ancestral states using ace ## written by Liam J. Revell 2012, 2013, 2015, 2019 fastAnc<-function(tree,x,vars=FALSE,CI=FALSE,...){ if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".") if(length(class(tree)>1)) class(tree)<-"phylo" if(hasArg(anc.states)) anc.states<-list(...)$anc.states else anc.states<-NULL if(!is.null(anc.states)){ nodes<-as.numeric(names(anc.states)) tt<-tree for(i in 1:length(nodes)){ M<-matchNodes(tt,tree,method="distances",quiet=TRUE) ii<-M[which(M[,2]==nodes[i]),1] tt<-bind.tip(tt,nodes[i],edge.length=0,where=ii) } x<-c(x,anc.states) } else tt<-tree if(!is.binary(tt)) btree<-multi2di(tt) else btree<-tt M<-btree$Nnode N<-length(btree$tip.label) anc<-v<-vector() for(i in 1:M+N){ a<-multi2di(ape::root.phylo(btree,node=i)) 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/phylANOVA.R0000644000176200001440000000615013201475366014231 0ustar liggesusers# function conducts phylogenetic ANOVA & posthoc tests # some code from phy.anova() in "geiger" # written by Liam Revell 2011, 2015, 2017 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))^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/pgls.Ives.R0000644000176200001440000001350013371301315014325 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 pgls.SEy<-function(model,data,corClass=corBrownian,tree=tree, se=NULL,method=c("REML","ML"),interval=c(0,1000),...){ Call<-match.call() corfunc<-corClass ## preliminaries data<-data[tree$tip.label,] if(is.null(se)) se<-setNames(rep(0,Ntip(tree)), tree$tip.label) ## likelihood function lk<-function(sig2e,data,tree,model,ve,corfunc){ 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)) w<-varFixed(~vf) COR<-corfunc(1,tree,...) 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) 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)) w<-varFixed(~vf) ## fit & return model obj<-gls(model,data=cbind(data,vf),correlation=corfunc(1,tree),weights=w, method=method) obj$call<-Call obj } phytools/R/compare.chronograms.R0000644000176200001440000000276113162731762016444 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/optim.phylo.ls.R0000644000176200001440000000636113440066505015367 0ustar liggesusers# function performs least-squares phylogeny inference by nni # written by Liam J. Revell 2011, 2013, 2015, 2019 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(class(D)=="dist") D<-as.matrix(D) # compute the number of species n<-nrow(D) if(is.null(stree)) stree<-rtree(n=n,tip.label=rownames(D),br=NULL,rooted=F) # random starting tree else if(!inherits(stree,"phylo")){ cat("starting tree must be an object of class \"phylo.\" using random starting tree.\n") stree<-rtree(n=n,tip.label=rownames(D),br=NULL,rooted=F) # random starting tree } if(!is.binary(stree)) stree<-multi2di(stree) if(is.rooted(stree)) stree<-unroot(stree) # get ls branch lengths for stree best.tree<-ls.tree(stree,D) Q<-attr(best.tree,"Q-score") bestQ<-0 # to start the loop # for search Nnni<-0 # loop while Q is not improved by nni while(bestQ-Q=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) 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 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 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="white") else if(shape=="ellipse") draw.ellipse(obj$xx[ii],obj$yy[ii],0.8*w[i],h, col="white") 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="white", 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(class(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 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)) list(where=obj$edge[ii,2],pos=pos[ii]) } else stop("Does not work for the plotted tree type.") } ## fastDist: uses fastHeight to compute patristic distance between a pair of species fastDist<-function(tree,sp1,sp2){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(is.null(tree$edge.length)) stop("tree should have edge lengths.") if(sp1==sp2) 0 else fastHeight(tree,sp1,sp1)+fastHeight(tree,sp2,sp2)- 2*fastHeight(tree,sp1,sp2) } ## function reorders simmap tree ## written Liam Revell 2011, 2013, 2015, 2019 reorderSimmap<-function(tree,order="cladewise",index.only=FALSE,...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") ii<-reorder.phylo(tree,order,index.only=TRUE,...) if(!index.only){ if(inherits(ii,"phylo")) ii<-whichorder(ii$edge[,2], tree$edge[,2]) ## bug workaround tree$edge<-tree$edge[ii,] tree$edge.length<-tree$edge.length[ii] if(!is.null(tree$maps)){ tree$maps<-tree$maps[ii] tree$mapped.edge<-tree$mapped.edge[ii,,drop=FALSE] } attr(tree,"order")<-order return(tree) } else return(ii) } ## S3 reorder method for objects of class "simmap" reorder.simmap<-function(x,...) reorderSimmap(x,...) # function whichorder # written by Liam Revell 2011, 2013, 2015 whichorder<-function(x,y) sapply(x,function(x,y) which(x==y),y=y) # function returns random state with probability given by y # written by Liam J. Revell 2013, 2015 rstate<-function(y){ if(length(y)==1) return(names(y)[1]) else { p<-y/sum(y) if(any(p<0)){ warning("Some probabilities (slightly?) < 0. Setting p < 0 to zero.") p[p<0]<-0 } return(names(which(rmultinom(1,1,p)[,1]==1))) } } ## mark the changes on a plotted "simmap" object ## written by Liam J. Revell 2015 markChanges<-function(tree,colors=NULL,cex=1,lwd=2,plot=TRUE){ states<-sort(unique(getStates(tree))) if(is.null(colors)) colors<-setNames(palette()[1:length(states)], states) obj<-get("last_plot.phylo",envir=.PlotPhyloEnv) nc<-sapply(tree$maps,length)-1 ii<-which(nc>0) nc<-nc[ii] xx<-yy<-vector() for(i in 1:length(ii)){ for(j in 1:nc[i]){ ss<-names(tree$maps[[ii[i]]])[j+1] mm<-tree$edge[ii[i],1] dd<-tree$edge[ii[i],2] x<-rep(obj$xx[mm]+cumsum(tree$maps[[ii[i]]])[j],2) y<-c(obj$yy[dd]-0.5*mean(strheight(LETTERS)*cex), obj$yy[dd]+0.5*mean(strheight(LETTERS)*cex)) if(plot) lines(x,y,lwd=lwd,col=colors[ss],lend=2) xx<-c(xx,setNames(x[1], paste(names(tree$maps[[ii[i]]])[j:(j+1)], collapse="->"))) yy<-c(yy,mean(y)) } } XY<-cbind(xx,yy) colnames(XY)<-c("x","y") invisible(XY) } ## function to label clades ## written by Liam J. Revell 2014, 2015 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)){ 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)) } ## internal function used by cladelabels ## written by Liam J. Revell 2014, 2015 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)) lines(c(h-wl*cw,h), c(y[1]-ec*sh,y[1]-ec*sh)) lines(c(h-wl*cw,h), c(y[2]+ec*sh,y[2]+ec*sh)) text(h+cw,mean(y), label,srt=if(orientation=="horizontal") 0 else 90, adj=if(orientation=="horizontal") 0 else 0.5,cex=cex) } ## 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 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 drop.clade<-function(tree,tip){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") nn<-if(!is.null(tree$node.label)) c(tree$node.label,"NA") else "NA" tree<-drop.tip(tree,tip,trim.internal=FALSE) while(sum(tree$tip.label%in%nn)>1) tree<-drop.tip(tree,tree$tip.label[tree$tip.label%in%nn], trim.internal=FALSE) tree } ## function to re-root a phylogeny along an edge ## written by Liam J. Revell 2011-2016, 2019 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(is.null(position)) position<-tree$edge.length[which(tree$edge[,2]==node.number)] 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) 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) if(interactive) plotTree(obj,...) obj } ## function to add an arrow pointing to a tip or node in the tree ## written by Liam J. Revell 2014, 2017 add.arrow<-function(tree=NULL,tip,...){ lastPP<-get("last_plot.phylo",envir=.PlotPhyloEnv) if(!is.null(tree)){ if(inherits(tree,"contMap")) tree<-tree$tree else if(inherits(tree,"densityMap")) tree<-tree$tree } if(is.numeric(tip)){ ii<-tip if(!is.null(tree)&&ii<=Ntip(tree)) tip<-tree$tip.label[ii] else tip<-"" } else if(is.character(tip)&&!is.null(tree)) ii<-which(tree$tip.label==tip) if(hasArg(offset)) offset<-list(...)$offset else offset<-1 strw<-lastPP$cex*(strwidth(tip)+offset*mean(strwidth(c(LETTERS,letters)))) if(hasArg(arrl)) arrl<-list(...)$arrl else { if(lastPP$type=="fan") arrl<-0.3*max(lastPP$xx) else if(lastPP$type=="phylogram") arrl<-0.15*max(lastPP$xx) } if(hasArg(hedl)) hedl<-list(...)$hedl else hedl<-arrl/3 if(hasArg(angle)) angle<-list(...)$angle else angle<-45 arra<-angle*pi/180 asp<-if(lastPP$type=="fan") 1 else (par()$usr[4]-par()$usr[3])/(par()$usr[2]-par()$usr[1]) if(hasArg(col)) col<-list(...)$col else col<-"black" if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-2 if(lastPP$type=="fan") theta<-atan2(lastPP$yy[ii],lastPP$xx[ii]) else if(lastPP$type=="phylogram") theta<-0 segments(x0=lastPP$xx[ii]+cos(theta)*(strw+arrl), y0=lastPP$yy[ii]+sin(theta)*(strw+arrl), x1=lastPP$xx[ii]+cos(theta)*strw, y1=lastPP$yy[ii]+sin(theta)*strw, col=col,lwd=lwd,lend="round") segments(x0=lastPP$xx[ii]+cos(theta)*strw+cos(theta+arra/2)*hedl, y0=lastPP$yy[ii]+sin(theta)*strw+sin(theta+arra/2)*hedl*asp, x1=lastPP$xx[ii]+cos(theta)*strw, y1=lastPP$yy[ii]+sin(theta)*strw, col=col,lwd=lwd,lend="round") segments(x0=lastPP$xx[ii]+cos(theta)*strw+cos(theta-arra/2)*hedl, y0=lastPP$yy[ii]+sin(theta)*strw+sin(theta-arra/2)*hedl*asp, x1=lastPP$xx[ii]+cos(theta)*strw, y1=lastPP$yy[ii]+sin(theta)*strw, col=col,lwd=lwd,lend="round") invisible(list(x0=lastPP$xx[ii]+cos(theta)*(strw+arrl), y0=lastPP$yy[ii]+sin(theta)*(strw+arrl), x1=lastPP$xx[ii]+cos(theta)*strw, y1=lastPP$yy[ii]+sin(theta)*strw)) } ## function to ladderize phylogeny with mapped discrete character ## written by Liam J. Revell 2014, 2015, 2019 ladderize.simmap<-function(tree,right=TRUE){ if(!inherits(tree,"simmap")){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") else { cat("Do not detect a mapped character. Using ape::ladderize.\n") obj<-ladderize(tree,right=right) } } else { obj<-read.tree(text=write.tree(ladderize(tree,right=right))) rN<-Ntip(obj)+1 T<-cbind(1:Ntip(obj),sapply(obj$tip.label, function(x,y) which(y==x),y=tree$tip.label)) N<-matchNodes(obj,tree) M<-rbind(T,N[N[,1]!=rN,]) ii<-sapply(M[,1],function(x,y) which(y==x),y=obj$edge[,2]) jj<-sapply(M[,2],function(x,y) which(y==x),y=tree$edge[,2]) obj$maps<-vector(length=nrow(tree$edge),mode="list") obj$mapped.edge<-matrix(NA,nrow(tree$edge),ncol(tree$mapped.edge), dimnames=list(apply(tree$edge,1,paste,collapse=","), colnames(tree$mapped.edge))) if(!is.null(tree$states)) obj$states<-tree$states[sapply(obj$tip.label, function(x,y) which(y==x),y=tree$tip.label)] if(!is.null(tree$node.states)) obj$node.states<-matrix(NA,nrow(tree$edge),2) for(i in 1:length(ii)){ obj$maps[[ii[i]]]<-tree$maps[[jj[i]]] obj$mapped.edge[ii[i],]<-tree$mapped.edge[jj[i],] if(!is.null(tree$node.states)) obj$node.states[ii[i],]<- tree$node.states[jj[i],] } class(obj)<-c("simmap","phylo") } obj } ## for backward compatibility repPhylo<-function(tree,times) rep(tree,times) ## S3 method rep for objects of class "phylo" and "multiPhylo" ## written by Liam J. Revell 2014 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(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 rescale simmap style trees ## written by Liam J. Revell 2012, 2013, 2014, 2015, 2017 rescaleSimmap<-function(tree,...){ if(inherits(tree,"multiPhylo")){ cls<-class(tree) trees<-unclass(tree) trees<-lapply(trees,rescaleSimmap,...) class(trees)<-cls return(trees) } else if(inherits(tree,"phylo")){ 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 \"phylo\" or \"multiPhylo\"") } ## function to drop one or more tips from a tree but retain all ancestral nodes as singletons ## written by Liam J. Revell 2014, 2015 drop.tip.singleton<-function(tree,tip){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") N<-Ntip(tree) m<-length(tip) ii<-sapply(tip,function(x,y) which(y==x),y=tree$tip.label) tree$tip.label<-tree$tip.label[-ii] ii<-sapply(ii,function(x,y) which(y==x),y=tree$edge[,2]) tree$edge<-tree$edge[-ii,] tree$edge.length<-tree$edge.length[-ii] tree$edge[tree$edge<=N]<-as.integer(rank(tree$edge[tree$edge<=N])) tree$edge[tree$edge>N]<-tree$edge[tree$edge>N]-m N<-N-m if(any(sapply(tree$edge[tree$edge[,2]>N,2],"%in%",tree$edge[,1])==FALSE)) internal<-TRUE else internal<-FALSE while(internal){ ii<-which(sapply(tree$edge[,2],"%in%",c(1:N,tree$edge[,1]))==FALSE)[1] nn<-tree$edge[ii,2] tree$edge<-tree$edge[-ii,] tree$edge.length<-tree$edge.length[-ii] tree$edge[tree$edge>nn]<-tree$edge[tree$edge>nn]-1 tree$Nnode<-tree$Nnode-length(ii) if(any(sapply(tree$edge[tree$edge[,2]>N,2],"%in%",tree$edge[,1])==FALSE)) internal<-TRUE else internal<-FALSE } tree } ## 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 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(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],...) 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) } } # function to summarize the results of stochastic mapping # written by Liam J. Revell 2013, 2014, 2015 describe.simmap<-function(tree,...){ if(hasArg(plot)) plot<-list(...)$plot else plot<-FALSE if(hasArg(check.equal)) check.equal<-list(...)$check.equal else check.equal<-FALSE if(hasArg(message)) message<-list(...)$message else message<-FALSE if(hasArg(ref.tree)) ref.tree<-list(...)$ref.tree else ref.tree<-NULL if(inherits(tree,"multiPhylo")){ if(check.equal){ TT<-sapply(tree,function(x,y) sapply(y,all.equal.phylo,x),y=tree) check<-all(TT) if(!check) cat("Note: Some trees are not equal.\nA \"reference\" tree will be computed if none was provided.\n\n") } else check<-TRUE YY<-getStates(tree) states<-sort(unique(as.vector(YY))) if(is.null(ref.tree)&&check) ZZ<-t(apply(YY,1,function(x,levels,Nsim) summary(factor(x,levels))/Nsim,levels=states,Nsim=length(tree))) else { if(is.null(ref.tree)){ cat("No reference tree provided & some trees are unequal.\nComputing majority-rule consensus tree.\n") ref.tree<-consensus(tree,p=0.5) } YYp<-matrix(NA,ref.tree$Nnode,length(tree),dimnames=list(1:ref.tree$Nnode+Ntip(ref.tree),NULL)) for(i in 1:length(tree)){ M<-matchNodes(ref.tree,tree[[i]]) jj<-sapply(M[,2],function(x,y) if(x%in%y) which(as.numeric(y)==x) else NA,y=as.numeric(rownames(YY))) YYp[,i]<-YY[jj,i] } ZZ<-t(apply(YYp,1,function(x,levels) summary(factor(x[!is.na(x)],levels))/sum(!is.na(x)),levels=states)) } XX<-countSimmap(tree,states,FALSE) XX<-XX[,-(which(as.vector(diag(-1,length(states)))==-1)+1)] AA<-t(sapply(unclass(tree),function(x) c(colSums(x$mapped.edge),sum(x$edge.length)))) colnames(AA)[ncol(AA)]<-"total" BB<-getStates(tree,type="tips") CC<-t(apply(BB,1,function(x,levels,Nsim) summary(factor(x,levels))/Nsim,levels=states,Nsim=length(tree))) x<-list(count=XX,times=AA,ace=ZZ,tips=CC,tree=tree,ref.tree=if(!is.null(ref.tree)) ref.tree else NULL) class(x)<-"describe.simmap" } else if(inherits(tree,"phylo")){ XX<-countSimmap(tree,message=FALSE) YY<-getStates(tree) states<-sort(unique(YY)) AA<-setNames(c(colSums(tree$mapped.edge),sum(tree$edge.length)),c(colnames(tree$mapped.edge),"total")) AA<-rbind(AA,AA/AA[length(AA)]); rownames(AA)<-c("raw","prop") x<-list(N=XX$N,Tr=XX$Tr,times=AA,states=YY,tree=tree) class(x)<-"describe.simmap" } if(message) print(x) if(plot) plot(x) x } ## function finds the height of a given node ## written by Liam Revell 2014, 2015, 2016 nodeheight<-function(tree,node,...){ if(hasArg(root.edge)) root.edge<-list(...)$root.edge else root.edge<-FALSE if(root.edge) ROOT<-if(!is.null(tree$root.edge)) tree$root.edge else 0 else ROOT<-0 if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(node==(Ntip(tree)+1)) h<-0 else { a<-setdiff(c(getAncestors(tree,node),node),Ntip(tree)+1) h<-sum(tree$edge.length[sapply(a,function(x,e) which(e==x),e=tree$edge[,2])]) } h+ROOT } # fast pairwise MRCA function # written by Liam Revell 2012, 2014, 2015 fastMRCA<-function(tree,sp1,sp2){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") x<-match(sp1,tree$tip.label) y<-match(sp2,tree$tip.label) a<-c(x,getAncestors(tree,x)) b<-c(y,getAncestors(tree,y)) z<-a%in%b return(a[min(which(z))]) } ## function to find the height of the MRCA of sp1 & sp2 ## written by Liam J. Revell 2014, 2015 fastHeight<-function(tree,sp1,sp2){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(is.null(tree$edge.length)) stop("tree should have edge lengths.") sp1<-which(tree$tip.label==sp1) sp2<-which(tree$tip.label==sp2) a1<-c(sp1,getAncestors(tree,sp1)) a2<-c(sp2,getAncestors(tree,sp2)) a12<-intersect(a1,a2) if(length(a12)>1){ a12<-a12[2:length(a12)-1] h<-sapply(a12,function(i,tree) tree$edge.length[which(tree$edge[,2]==i)],tree=tree) return(sum(h)) } else return(0) } ## function gets ancestor node numbers, to be used internally by ## written by Liam J. Revell 2014 getAncestors<-function(tree,node,type=c("all","parent")){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") type<-type[1] if(type=="all"){ aa<-vector() rt<-Ntip(tree)+1 currnode<-node while(currnode!=rt){ currnode<-getAncestors(tree,currnode,"parent") aa<-c(aa,currnode) } return(aa) } else if(type=="parent"){ aa<-tree$edge[which(tree$edge[,2]==node),1] return(aa) } else stop("do not recognize type") } ## function for midpoint rooting ## written by Liam J. Revell 2014 midpoint.root<-function(tree){ D<-cophenetic(tree) dd<-max(D) ii<-which(D==dd)[1] ii<-c(ceiling(ii/nrow(D)),ii%%nrow(D)) if(ii[2]==0) ii[2]<-nrow(D) spp<-rownames(D)[ii] nn<-which(tree$tip.label==spp[2]) tree<-reroot(tree,nn,tree$edge.length[which(tree$edge[,2]==nn)]) aa<-getAncestors(tree,which(tree$tip.label==spp[1])) D<-c(0,dist.nodes(tree)[which(tree$tip.label==spp[1]),aa]) names(D)[1]<-which(tree$tip.label==spp[1]) i<-0 while(D[i+1]<(dd/2)) i<-i+1 tree<-reroot(tree,as.numeric(names(D)[i]),D[i+1]-dd/2) tree } # function computes phylogenetic variance-covariance matrix, including for internal nodes # written by Liam J. Revell 2011, 2013, 2014, 2015 vcvPhylo<-function(tree,anc.nodes=TRUE,...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") # get & set optional arguments if(hasArg(internal)) internal<-list(...)$internal else internal<-anc.nodes if(internal!=anc.nodes){ message(paste("arguments \"internal\" and \"anc.nodes\" are synonyms; setting internal =",anc.nodes)) internal<-anc.nodes } if(hasArg(model)) model<-list(...)$model else model<-"BM" if(hasArg(tol)) tol<-list(...)$tol else tol<-1e-12 if(model=="OU"){ if(hasArg(alpha)) alpha<-list(...)$alpha else alpha<-0 } if(model=="OU"&&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 mergeMappedStates<-function(tree,old.states,new.state){ if(inherits(tree,"multiPhylo")){ tree<-unclass(tree) tree<-lapply(tree,mergeMappedStates,old.states=old.states,new.state=new.state) class(tree)<-"multiPhylo" } else if(inherits(tree,"phylo")) { 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 \"phylo\" or \"multiPhylo\".") 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 phyl.vcv<-function(X,C,lambda){ C<-lambda.transform(lambda,C) invC<-solve(C) a<-matrix(colSums(invC%*%X)/sum(invC),ncol(X),1) A<-matrix(rep(a,nrow(X)),nrow(X),ncol(X),byrow=T) V<-t(X-A)%*%invC%*%(X-A)/(nrow(C)-1) return(list(C=C,R=V,alpha=a)) } # lambda transformation of C # written by Liam Revell 2011 lambda.transform<-function(lambda,C){ if(lambda==1) return(C) else { V<-diag(diag(C)) C<-C-V C.lambda<-(V+lambda*C) return(C.lambda) } } # likelihood function for joint estimation of lambda for multiple traits # written by Liam Revell 2011/2012 likMlambda<-function(lambda,X,C){ # compute R, conditioned on lambda temp<-phyl.vcv(X,C,lambda); C<-temp$C; R<-temp$R; a<-temp$alpha # prep n<-nrow(X); m<-ncol(X); D<-matrix(0,n*m,m) for(i in 1:(n*m)) for(j in 1:m) if((j-1)*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 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"){ if(inherits(tree,"simmap")) tree<-read.simmap(text=write.simmap(tree)) else tree<-if(Ntip(tree)>1) read.tree(text=write.tree(tree)) else read.newick(text=write.tree(tree)) } ii<-!names(obj)%in%names(attributes(tree)) attributes(tree)<-c(attributes(tree),obj[ii]) } tree } phytools/R/consensus.edges.R0000644000176200001440000000242612731425027015574 0ustar liggesusers## compute consensus edge lengths from a set of trees given (or not) a consensus topology ## written by Liam J. Revell 2016 consensus.edges<-function(trees,method=c("mean.edge","least.squares"),...){ if(hasArg(consensus.tree)) consensus.tree<-list(...)$consensus.tree else consensus.tree<-consensus(trees,p=0.5) 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 tree<-nnls.tree(D,tree=tree,rooted=all(sapply(trees,is.ultrametric))) } tree }phytools/R/rateshift.R0000644000176200001440000002203013463333341014450 0ustar liggesusers## find the temporal position of a rate shift using ML ## written by Liam J. Revell 2013, 2014, 2015 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 fn<-if(method=="ML") brownie.lite else brownieREML if(!fixed.shift[1]){ if(print){ cat("Optimization progress:\n\n") if(nrates>1) cat(paste(c("iter",paste("shift",1:(nrates-1),sep=":"),"logL\n"),collapse="\t")) else cat("iter\ts^2(1)\tlogL\n") } else if(niter==1) { if(!quiet) cat("Optimizing. Please wait.\n\n") flush.console() } else { if(!quiet) cat("Optimization progress:\n|") flush.console() } } else { if(!quiet) cat("Estimating rates conditioned on input shift points...\n\n") nrates<-if(fixed.shift[1]!=TRUE) length(fixed.shift)+1 else 1 if(nrates>2) fixed.shift<-sort(fixed.shift) names(fixed.shift)<-NULL } lik<-function(par,tree,y,nrates,plot,print,iter,Tol,maxh,minL){ shift<-sort(c(setNames(0,1),setNames(par,2:nrates))) if((any(shift[2:length(shift)]<=0)||any(shift>=maxh))) logL<-minL else { tree<-make.era.map(tree,shift,tol=Tol/10) if(plot){ plotSimmap(tree,setNames(rainbow(nrates),1:nrates),lwd=3,ftype="off",mar=c(0.1,0.1,4.1,0.1)) title(main=paste("Optimizing rate shift(s), round",iter,"....",sep=" ")) for(i in 2:(length(shift))) lines(rep(shift[i],2),c(0,length(tree$tip.label)+1),lty="dashed") } logL<-fn(tree,y)$logL.multiple } if(print){ if(nrates>1) cat(paste(c(iter,round(shift[2:length(shift)],4),round(logL,4),"\n"),collapse="\t")) else cat(paste(c(iter,round(par,4),round(logL,4),"\n"),collapse="\t")) } -logL } h<-max(nodeHeights(tree)) N<-length(tree$tip.label) x<-x[tree$tip.label] if(!fixed.shift[1]){ fit<-list() for(i in 1:niter){ if(nrates>1) par<-sort(runif(n=nrates-1)*h) if(nrates==1){ fit[[i]]<-fn(make.era.map(tree,setNames(0,1)),x) fit[[i]]$convergence<-if(fit[[i]]$convergence=="Optimization has converged.") 0 else 1 } else suppressWarnings(fit[[i]]<-optim(par,lik,tree=tree,y=x,nrates=nrates,print=print,plot=plot, iter=i,Tol=tol,maxh=h,minL=minL)) if(!print&&niter>1){ if(!quiet) cat(".") flush.console() } } if(!print&&niter>1) if(!quiet) cat("|\nDone.\n\n") ll<-sapply(fit,function(x) if(nrates>1) x$value else -x$logL1) fit<-fit[[which(ll==min(ll))[1]]] frequency.best<-mean(ll<=(min(ll)+1e-4)) likHess<-if(method=="ML") function(par,tree,y,nrates,tol,maxh){ sig2<-par[1:nrates] shift<-if(nrates>1) setNames(c(0,par[1:(nrates-1)+nrates]),1:nrates) else shift<-setNames(0,1) tree<-make.era.map(tree,shift,tol=tol/10) mC<-multiC(tree) mC<-mapply("*",mC,sig2,SIMPLIFY=FALSE) V<-Reduce("+",mC) invV<-solve(V) a<-as.numeric(colSums(invV)%*%x/sum(invV)) logL<-sum(dmnorm(y,rep(a,length(x)),V,log=TRUE)) -logL } else if(method=="REML") function(par,tree,y,nrates,tol,maxh){ sig2<-par[1:nrates] shift<-if(nrates>1) setNames(c(0,par[1:(nrates-1)+nrates]),1:nrates) else shift<-setNames(0,1) tree<-make.era.map(tree,shift,tol=tol/10) tree<-scaleByMap(tree,setNames(sig2,1:nrates)) picX<-pic(y,tree,scaled=FALSE,var.contrasts=TRUE) logL<-sum(dnorm(picX[,1],sd=sqrt(picX[,2]),log=TRUE)) -logL } mtree<-if(nrates>1) make.era.map(tree,c(0,fit$par)) else make.era.map(tree,0) obj<-fn(mtree,x) 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 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 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="")) cat(paste(c("",paste("s^2(",names(x$sig2),")","\tse(",names(x$sig2),")",sep=""), "k","logL","\n"),collapse="\t")) cat(paste(paste(c("value",paste(x$sig2,round(sqroot(diag(x$vcv)[1:length(x$sig2)]),digits), sep="\t"),2*length(x$sig2),x$logL),collapse="\t"),"\n\n",sep="")) if(!is.null(x$shift)){ cat("Shift point(s) between regimes (height above root):\n") nn<-sapply(strsplit(names(x$shift),"<->"),paste,collapse="|") cat(paste(c("",paste(nn,paste("se(",nn,")",sep=""),sep="\t"),"\n"), collapse="\t")) cat(paste(paste(c("value",paste(x$shift, round(sqroot(diag(x$vcv)[1:length(x$shift)+length(x$sig2)]),digits), sep="\t")),collapse="\t"),"\n\n",sep="")) } else cat("This is a one-rate model.\n\n") if(x$method=="ML") cat("Model fit using ML.\n\n") else if(x$method=="REML") cat("Model 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 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 plot.rateshift<-function(x,...){ if(length(x$sig2)>1){ cols<-colorRampPalette(c("blue","purple","red"))(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)) plot(x$tree,ylim=c(-0.1*Ntip(x$tree),Ntip(x$tree)), colors=colors,...) 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 { colors<-setNames("blue",1) plot(x$tree,ylim=c(-0.1*Ntip(x$tree),Ntip(x$tree)), colors=colors,...) txt<-as.character(round(x$sig2,3)) add.simmap.legend(leg=expression(paste(sigma^2," = ",sep="")), colors="blue",prompt=FALSE,x=0,y=-0.05*Ntip(x$tree)) text(x=5.5*strwidth("W"),y=-0.05*Ntip(x$tree),round(x$sig2,3)) } } ## 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/export.as.xml.R0000644000176200001440000000242412561714575015220 0ustar liggesusers# makes xml data and tree file for SIMMAP # written by Liam J. Revell 2012, 2015 export.as.xml<-function(file,trees,X){ if(is.vector(X)) X<-data.frame(X) if(class(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/add.everywhere.R0000644000176200001440000000137412561705251015404 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/project.phylomorphospace.R0000644000176200001440000000372313252541223017524 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/phyl.pca.R0000644000176200001440000001334513062262203014177 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 (in progress) ## written by Liam Revell 2010, 2011, 2013, 2015, 2016, 2017 ref. Revell (2009; Evolution) phyl.pca<-function(tree,Y,method="BM",mode="cov",...){ ## get optional argument if(hasArg(opt)) opt<-list(...)$opt else opt<-"ML" # check tree if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") # check mode if(length(strsplit(mode,split="")[[1]])<=2){ message(paste("mode = \"",mode, "\" not a valid option; setting mode = \"cov\"",sep="")) mode<-"cov" } if(all(strsplit(mode,split="")[[1]]==strsplit("correlation", split="")[[1]][1:length(strsplit(mode,split="")[[1]])])) mode<-"corr" else if(all(strsplit(mode,split="")[[1]]==strsplit("covariance", split="")[[1]][1:length(strsplit(mode,split="")[[1]])])) mode<-"cov" else { message(paste("mode = \"",mode, "\" not a valid option; setting mode = \"cov\"",sep="")) mode="cov" } # preliminaries n<-nrow(Y) m<-ncol(Y) # check and sort data if(n>Ntip(tree)) stop("number of rows in Y cannot be greater than number of taxa in your tree") Y<-as.matrix(Y) if(is.null(rownames(Y))){ if(nrow(Y)==n){ print("Y has no names. function will assume that the row order of Y matches tree$tip.label") rownames(Y)<-tree$tip.label } else stop("Y has no names and does not have the same number of rows as tips in tree") } else if(length(setdiff(rownames(Y),tree$tip.label))!=0) stop("Y has rownames, but some rownames of Y not found in tree") # analyze C<-vcv.phylo(tree)[rownames(Y),rownames(Y)] if(method=="BM"){ temp<-phyl.vcv(Y,C,1.0) V<-temp$R a<-t(temp$alpha) C<-temp$C } else if(method=="lambda"){ if(opt=="ML") temp<-optimize(f=likMlambda,interval=c(0,maxLambda(tree)),X=Y, C=C,maximum=TRUE) else if(opt=="REML") temp<-optimize(f=remlMlambda,interval=c(0,maxLambda(tree)), tree=tree,X=Y,maximum=TRUE) else if(opt=="fixed"){ if(hasArg(lambda)) lambda<-list(...)$lambda else { cat(" opt=\"fixed\" requires the user to specify lambda.\n") cat(" setting lambda to 1.0.\n") lambda<-1.0 } temp<-list(maximum=lambda,objective=likMlambda(lambda,X=Y,C=C)) } lambda<-temp$maximum logL<-as.numeric(temp$objective) temp<-phyl.vcv(Y,C,lambda) V<-temp$R a<-t(temp$alpha) C<-temp$C } invC<-solve(C) ## get inverse of C # if correlation matrix if(mode=="corr"){ Y=Y/matrix(rep(sqrt(diag(V)),n),n,m,byrow=T) # standardize Y V=V/(sqrt(diag(V))%*%t(sqrt(diag(V)))) # change V to correlation matrix a<-matrix(colSums(invC%*%Y)/sum(invC),m,1) # recalculate a } es=eigen(V) # eigenanalyze obj<-list() obj$Eval<-diag(es$values[1:min(n-1,m)]) obj$Evec<-es$vectors[,1:min(n-1,m)] dimnames(obj$Eval)<-list(paste("PC",1:min(n-1,m),sep=""), paste("PC",1:min(n-1,m),sep="")) dimnames(obj$Evec)<-list(colnames(Y),paste("PC",1:min(n-1,m),sep="")) A<-matrix(rep(a,n),n,m,byrow=T) obj$S<-(Y-A)%*%obj$Evec # compute scores in the species space Ccv<-t(Y-A)%*%invC%*%obj$S/(n-1) # compute cross covariance matrix and loadings obj$L<-matrix(,m,min(n-1,m),dimnames=list(colnames(Y),paste("PC",1:min(n-1,m),sep=""))) for(i in 1:m) for(j in 1:min(n-1,m)) obj$L[i,j]<-Ccv[i,j]/sqrt(V[i,i]*obj$Eval[j,j]) if(method=="lambda"){ obj$lambda<-lambda obj$logL.lambda<-logL } ## 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) } phytools/R/ltt.R0000644000176200001440000002367213477254216013307 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 ltt<-function(tree,plot=TRUE,drop.extinct=FALSE,log.lineages=TRUE,gamma=TRUE,...){ # set tolerance tol<-1e-6 # check "phylo" object if(!inherits(tree,"phylo")&&!inherits(tree,"multiPhylo")) stop("tree must be object of class \"phylo\" or \"multiPhylo\".") if(inherits(tree,"multiPhylo")){ obj<-lapply(tree,ltt,plot=FALSE,drop.extinct=drop.extinct, log.lineages=log.lineages,gamma=gamma) class(obj)<-"multiLtt" } 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 nodes.\n\n",sep= "")) cat(paste("(2) Vectors containing the number of lineages (ltt) ", "and 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 ",round(x$gamma,digits),", p-value = ", round(x$p,digits),".\n\n",sep="")) } ## S3 print method for object of class "multiLtt" ## written by Liam J. Revell 2015 print.multiLtt<-function(x,...){ cat(paste(length(x),"objects of class \"ltt\" in a list\n")) } ## S3 plot method for object of class "ltt" ## written by Liam J. Revell 2015 plot.ltt<-function(x,...){ args<-list(...) args$x<-x$time if(!is.null(args$log.lineages)){ logl<-args$log.lineages args$log.lineages<-NULL } else logl<-TRUE if(!is.null(args$show.tree)){ show.tree<-args$show.tree args$show.tree<-NULL } else show.tree<-FALSE if(!is.null(args$transparency)){ transparency<-args$transparency args$transparency<-NULL } else transparency<-0.3 args$y<-if(logl) log(x$ltt) else x$ltt if(is.null(args$xlab)) args$xlab<-"time" if(is.null(args$ylab)) args$ylab<-if(logl) "log(lineages)" else "lineages" if(is.null(args$type)) args$type<-"s" if(hasArg(add)){ add<-list(...)$add args$add<-NULL } else add<-FALSE if(!add) do.call(plot,args) else do.call(lines,args) if(show.tree){ tips<-if(par()$ylog) setNames(exp(1:Ntip(x$tree)),x$tree$tip.label) else setNames(1:Ntip(x$tree),x$tree$tip.label) plotTree(x$tree,color=rgb(0,0,1,transparency), ftype="off",add=TRUE,mar=par()$mar,tips=tips) } } ## S3 plot method for object of class "multiLtt" ## written by Liam J. Revell 2015 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(0,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(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" 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 ",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)," simulations.\n\n",sep="")) } ## plot method for "mccr" object class plot.mccr<-function(x,...){ hist(x$null.gamma,breaks=min(c(max(12,round(length(x$null.gamma)/10)),20)), xlim=range(c(x$gamma,x$null.gamma)), main=expression(paste("null distribution of ", gamma)),xlab=expression(gamma),col="lightgrey") 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.98*par()$usr[4], expression(paste("observed value of ",gamma)), pos=if(x$gamma>mean(x$null.gamma)) 2 else 4) }phytools/R/add.random.R0000644000176200001440000000247412562127030014473 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/mcmcLambda.R0000644000176200001440000001265412107744173014515 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/densityTree.R0000644000176200001440000000647213212271751014770 0ustar liggesusers## function to make a color (e.g., "blue") transparent with alpha level alpha make.transparent<-function(color,alpha){ RGB<-col2rgb(color)[,1]/255 rgb(RGB[1],RGB[2],RGB[3],alpha) } ## 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/writeAncestors.R0000644000176200001440000000737612562012240015502 0ustar liggesusers# function writes a "phylo" object to a Newick string with ancestor state estimates # written by Liam J. Revell 2013, 2015 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(class(tree)=="multiPhylo") XX<-mapply(writeAnc,tree,Anc,MoreArgs=list(digits=digits)) else if(class(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/collapseTree.R0000644000176200001440000002346113353255357015122 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 collapseTree<-function(tree,...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(hasArg(nodes)) nodes<-list(...)$nodes else nodes<-TRUE if(hasArg(hold)) hold<-list(...)$hold else hold<-TRUE if(hasArg(drop.extinct)) drop.extinct<-list(...)$drop.extinct else drop.extinct<-TRUE if(is.null(tree$edge.length)){ no.edge<-TRUE tree<-compute.brlen(tree,power=0.5) } else no.edge<-FALSE cat("Click on the nodes that you would like to collapse...\n") flush.console() ## turn off locator bell (it's annoying) options(locatorBell=FALSE) ## check for node labels if(is.null(tree$node.label)) tree$node.label<-as.character(Ntip(tree)+1:tree$Nnode) else if(any(tree$node.label=="")){ tree$node.label[which(tree$node.label)==""]<- which(tree$node.label=="")+Ntip(tree) } ## remove any spaces tree$node.label<-sapply(tree$node.label,gsub,pattern=" ",replacement="_") tree$tip.label<-sapply(tree$tip.label,gsub,pattern=" ",replacement="_") ## copy original tree: otree<-tree<-reorder(tree) ## plot initial tree: if(hold) dev.hold() fan(tree,...) lastPP<-get("last_plot.phylo",envir=.PlotPhyloEnv) points(x=lastPP$xx[1:Ntip(tree)],y=lastPP$yy[1:Ntip(tree)], pch=21,col="blue",bg="white",cex=0.8) points(x=lastPP$xx[1:tree$Nnode+Ntip(tree)], y=lastPP$yy[1:tree$Nnode+Ntip(tree)],pch=21, col="blue",bg="white",cex=1.2) rect(par()$usr[1],par()$usr[4]-3*strheight("W"),par()$usr[2],par()$usr[4], border=0,col=make.transparent("blue",0.2)) textbox(x=par()$usr[1:2],y=par()$usr[4], c("Click nodes to collapse or expand\nRIGHT CLICK to stop"), justify="c",border=0) dev.flush() x<-unlist(locator(1)) if(!is.null(x)){ y<-x[2] x<-x[1] d<-sqrt((x-lastPP$xx)^2+(y-lastPP$yy)^2) nn<-which(d==min(d,na.rm=TRUE)) ## collapse tree & replot: while(!is.null(x)){ obj<-list(tree) if(nn>(Ntip(tree)+1)){ obj<-splitTree(tree,list(node=nn, bp=tree$edge.length[which(tree$edge[,2]==nn)])) obj[[1]]$tip.label[which(obj[[1]]$tip.label=="NA")]<- tree$node.label[nn-Ntip(tree)] tips<-which(tree$tip.label%in%obj[[1]]$tip.label) theta<-atan(lastPP$yy[nn]/lastPP$xx[nn]) if(lastPP$yy[nn]>0&&lastPP$xx[nn]<0) theta<-pi+theta else if(lastPP$yy[nn]<0&&lastPP$xx[nn]<0) theta<-pi+theta else if(lastPP$yy[nn]<0&&lastPP$xx[nn]>0) theta<-2*pi+theta ii<-which((c(tips,Ntip(tree)+1)-c(0,tips))>1) if(ii>1&&ii<=length(tips)) tips<-c(tips[1:(ii-1)],theta/(2*pi)*Ntip(tree),tips[ii:length(tips)]) else if(ii==1) tips<-c(theta/(2*pi)*Ntip(tree),tips) else if(ii>length(tips)) tips<-c(tips,theta/(2*pi)*Ntip(tree)) tree<-read.tree(text=write.tree(obj[[1]])) M<-matrix(NA,min(c(max(4,Ntip(obj[[2]])),10)),length(tips)) for(i in 1:ncol(M)) M[,i]<-seq(from=tips[i],to=i,length.out=nrow(M)) colnames(M)<-tree$tip.label maxY<-seq(from=sum(sapply(obj,Ntip))-length(obj)+1,to=Ntip(tree), length.out=nrow(M)) pw<-reorder(tree,"pruningwise") H<-nodeHeights(tree) for(i in 1:nrow(M)){ if(hold) dev.hold() fan(tree,pw,H,xlim=lastPP$x.lim,ylim=lastPP$y.lim, tips=M[i,],maxY=maxY[i],...) rect(par()$usr[1],par()$usr[4]-3*strheight("W"), par()$usr[2],par()$usr[4], border=0,col=make.transparent("blue",0.2)) textbox(x=par()$usr[1:2],y=par()$usr[4], c("Click nodes to collapse or expand\nRIGHT CLICK to stop"), justify="c",border=0) if(nodes||i==nrow(M)){ lastPP<-get("last_plot.phylo",envir=.PlotPhyloEnv) points(x=lastPP$xx[1:Ntip(tree)],y=lastPP$yy[1:Ntip(tree)], pch=21,col="blue",bg="white",cex=0.8) points(x=lastPP$xx[1:tree$Nnode+Ntip(tree)], y=lastPP$yy[1:tree$Nnode+Ntip(tree)],pch=21, col="blue",bg="white",cex=1.2) } dev.flush() } } else if(nn<=Ntip(tree)) { if(tree$tip.label[nn]%in%otree$node.label){ on<-which(otree$node.label==tree$tip.label[nn])+Ntip(otree) obj<-splitTree(otree,list(node=on, bp=otree$edge.length[which(otree$edge[,2]==on)])) nlabel<-tree$tip.label[nn] tree$tip.label[nn]<-"NA" if(nn==1) tips<-c(rep(nn,Ntip(obj[[2]])),(nn+1):Ntip(tree)) else if(nn>1&&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/fancyTree.R0000644000176200001440000002503313476545666014430 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 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,...) 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 droptipTree<-function(tree,...){ if(hasArg(tip)) tip<-list(...)$tip else stop("need to provide tip or tips to drop") 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) dtree<-drop.tip(tree,tip); dtree$root.edge<- max(nodeHeights(tree))-max(nodeHeights(dtree)) plot.phylo(dtree,edge.width=2,no.margin=TRUE,root.edge=TRUE) 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/pbtree.R0000644000176200001440000002054613353261764013761 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/phylo.impute.R0000644000176200001440000000427213463332377015134 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(ninterval[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/allFurcTrees.R0000644000176200001440000000326112107731037015055 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/resolveNodes.R0000644000176200001440000000405612752433644015146 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/phyl.cca.R0000644000176200001440000001054413201657102014161 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/bd.R0000644000176200001440000000615113440066221013045 0ustar liggesusers## likelihood functions for birth-death & Yule model with incomplete sampling ## written by Liam J. Revell 2017, 2018, 2019 ## based on likelihood functions in Stadler (2012) 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) 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){ cat("no colors provided. using the following legend:\n") print(colors) } } # swap out "_" character for spaces (assumes _ is a place holder) 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")) updownPhylogram(tree,colors,fsize,ftype,lwd,pts,node.numbers,mar,add,offset, direction,setEnv,xlim,ylim,nodes,tips,split.vertical,lend,asp,plot) else plotPhylogram(tree,colors,fsize,ftype,lwd,pts,node.numbers,mar,add,offset, direction,setEnv,xlim,ylim,nodes,tips,split.vertical,lend,asp,plot) } else if(type=="fan"){ plotFan(tree,colors,fsize,ftype,lwd,mar,add,part,setEnv,xlim,ylim,tips, maxY,lend,plot) } else if(type=="cladogram"){ plotCladogram(tree,colors,fsize,ftype,lwd,mar,add,offset,direction,xlim,ylim, nodes,tips,lend,asp,plot) } if(hold) null<-dev.flush() } } ## function to plot simmap tree in type "phylogram" ## written by Liam J. Revell 2011-2017 updownPhylogram<-function(tree,colors,fsize,ftype,lwd,pts,node.numbers,mar, add,offset,direction,setEnv,xlim,ylim,placement,tips,split.vertical,lend, asp,plot){ 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 tips[gsub(" ","_",cw$tip.label)] # get Y coordinates of the nodes nodes<-unique(pw$edge[,1]) for(i in 1:m){ if(placement=="intermediate"){ desc<-pw$edge[which(pw$edge[,1]==nodes[i]),2] Y[nodes[i]]<-(min(Y[desc])+max(Y[desc]))/2 } else if(placement=="centered"){ desc<-getDescendants(pw,nodes[i]) desc<-desc[desc<=Ntip(pw)] Y[nodes[i]]<-(min(Y[desc])+max(Y[desc]))/2 } else if(placement=="weighted"){ desc<-pw$edge[which(pw$edge[,1]==nodes[i]),2] n1<-desc[which(Y[desc]==min(Y[desc]))] n2<-desc[which(Y[desc]==max(Y[desc]))] v1<-pw$edge.length[which(pw$edge[,2]==n1)] v2<-pw$edge.length[which(pw$edge[,2]==n2)] Y[nodes[i]]<-((1/v1)*Y[n1]+(1/v2)*Y[n2])/(1/v1+1/v2) } else if(placement=="inner"){ desc<-getDescendants(pw,nodes[i]) desc<-desc[desc<=Ntip(pw)] mm<-which(abs(Y[desc]-median(Y[1:Ntip(pw)]))==min(abs(Y[desc]- median(Y[1:Ntip(pw)])))) if(length(mm>1)) mm<-mm[which(Y[desc][mm]==min(Y[desc][mm]))] Y[nodes[i]]<-Y[desc][mm] } } # compute node heights H<-nodeHeights(cw) # open plot par(mar=mar) if(is.null(offset)) offset<-0.2*lwd/3+0.2/3 if(!add) plot.new() ### if(is.null(ylim)){ pp<-par("pin")[2] sw<-fsize*(max(strwidth(cw$tip.label,units="inches")))+ offsetFudge*fsize*strwidth("W",units="inches") alp<-optimize(function(a,H,sw,pp) (a*1.04*max(H)+sw-pp)^2,H=H,sw=sw,pp=pp, interval=c(0,1e6))$minimum ylim<-if(direction=="downwards") c(min(H)-sw/alp,max(H)) else c(min(H),max(H)+sw/alp) } if(is.null(xlim)) xlim=range(Y) if(direction=="downwards") H<-max(H)-H plot.window(xlim=xlim,ylim=ylim,asp=asp) #### if(plot){ if(!split.vertical){ for(i in 1:m) lines(Y[cw$edge[which(cw$edge[,1]==nodes[i]),2]], H[which(cw$edge[,1]==nodes[i]),1], col=colors[names(cw$maps[[match(nodes[i], cw$edge[,1])]])[1]],lwd=lwd) } for(i in 1:nrow(cw$edge)){ x<-H[i,1] for(j in 1:length(cw$maps[[i]])){ if(direction=="downwards") lines(c(Y[cw$edge[i,2]],Y[cw$edge[i,2]]),c(x,x-cw$maps[[i]][j]), col=colors[names(cw$maps[[i]])[j]],lwd=lwd,lend=lend) else lines(c(Y[cw$edge[i,2]],Y[cw$edge[i,2]]),c(x,x+cw$maps[[i]][j]), col=colors[names(cw$maps[[i]])[j]],lwd=lwd,lend=lend) if(pts) points(c(Y[cw$edge[i,2]],Y[cw$edge[i,2]]),c(x,x+cw$maps[[i]][j]), pch=20,lwd=(lwd-1)) x<-x+if(direction=="downwards") -cw$maps[[i]][j] else cw$maps[[i]][j] j<-j+1 } } if(node.numbers){ symbols(mean(Y[cw$edge[cw$edge[,1]==(Ntip(cw)+1),2]]), if(direction=="downwards") max(H) else 0, rectangles=matrix(c(1.2*fsize*strwidth(as.character(Ntip(cw)+1)), 1.4*fsize*strheight(as.character(Ntip(cw)+1))),1,2),inches=FALSE, bg="white",add=TRUE) text(mean(Y[cw$edge[cw$edge[,1]==(Ntip(cw)+1),2]]), if(direction=="downwards") max(H) else 0,Ntip(cw)+1, cex=fsize) for(i in 1:nrow(cw$edge)){ x<-H[i,2] if(cw$edge[i,2]>Ntip(cw)){ symbols(Y[cw$edge[i,2]],x, rectangles=matrix(c(1.2*fsize*strwidth(as.character(cw$edge[i,2])), 1.4*fsize*strheight(as.character(cw$edge[i,2]))),1,2),inches=FALSE, bg="white",add=TRUE) text(Y[cw$edge[i,2]],x,cw$edge[i,2],cex=fsize) } } } if(direction=="downwards") pos<-if(par()$usr[3]>par()$usr[4]) 2 else 4 if(direction=="upwards") pos<-if(par()$usr[3]>par()$usr[4]) 2 else 4 for(i in 1:n){ shift<-offset*fsize*strwidth("W")*(diff(par()$usr[3:4])/diff(par()$usr[1:2])) if((direction=="downwards"&&diff(par()$usr[3:4])>0) || (direction=="upwards"&&diff(par()$usr[3:4])<0)) shift<--shift if(ftype){ text(labels=cw$tip.label[i],Y[i], H[which(cw$edge[,2]==i),2]+shift, pos=pos,offset=0,cex=fsize,font=ftype, srt=if(direction=="downwards") 270 else 90) } } } if(setEnv){ PP<-list(type="phylogram",use.edge.length=TRUE,node.pos=1, show.tip.label=if(ftype) TRUE else FALSE,show.node.label=FALSE, font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE,label.offset=offset, x.lim=xlim,y.lim=ylim, direction=direction,tip.color="black",Ntip=Ntip(cw),Nnode=cw$Nnode, edge=cw$edge,xx=Y[,1],yy=sapply(1:(Ntip(cw)+cw$Nnode), function(x,y,z) y[match(x,z)],y=H,z=cw$edge)) assign("last_plot.phylo",PP,envir=.PlotPhyloEnv) } if(plot) if(split.vertical) splitEdgeColor(cw,colors,lwd) } # function to plot simmap tree in type "phylogram" # written by Liam J. Revell 2011-2017 plotPhylogram<-function(tree,colors,fsize,ftype,lwd,pts,node.numbers,mar, add,offset,direction,setEnv,xlim,ylim,placement,tips,split.vertical,lend, asp,plot){ 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 tips[gsub(" ","_",cw$tip.label)] # get Y coordinates of the nodes nodes<-unique(pw$edge[,1]) for(i in 1:m){ if(placement=="intermediate"){ desc<-pw$edge[which(pw$edge[,1]==nodes[i]),2] Y[nodes[i]]<-(min(Y[desc])+max(Y[desc]))/2 } else if(placement=="centered"){ desc<-getDescendants(pw,nodes[i]) desc<-desc[desc<=Ntip(pw)] Y[nodes[i]]<-(min(Y[desc])+max(Y[desc]))/2 } else if(placement=="weighted"){ desc<-pw$edge[which(pw$edge[,1]==nodes[i]),2] n1<-desc[which(Y[desc]==min(Y[desc]))] n2<-desc[which(Y[desc]==max(Y[desc]))] v1<-pw$edge.length[which(pw$edge[,2]==n1)] v2<-pw$edge.length[which(pw$edge[,2]==n2)] Y[nodes[i]]<-((1/v1)*Y[n1]+(1/v2)*Y[n2])/(1/v1+1/v2) } else if(placement=="inner"){ desc<-getDescendants(pw,nodes[i]) desc<-desc[desc<=Ntip(pw)] mm<-which(abs(Y[desc]-median(Y[1:Ntip(pw)]))==min(abs(Y[desc]- median(Y[1:Ntip(pw)])))) if(length(mm>1)) mm<-mm[which(Y[desc][mm]==min(Y[desc][mm]))] Y[nodes[i]]<-Y[desc][mm] } } # compute node heights H<-nodeHeights(cw) # open plot par(mar=mar) if(is.null(offset)) offset<-0.2*lwd/3+0.2/3 if(!add) plot.new() ### if(is.null(xlim)){ pp<-par("pin")[1] sw<-fsize*(max(strwidth(cw$tip.label,units="inches")))+ offsetFudge*fsize*strwidth("W",units="inches") alp<-optimize(function(a,H,sw,pp) (a*1.04*max(H)+sw-pp)^2,H=H,sw=sw,pp=pp, interval=c(0,1e6))$minimum xlim<-if(direction=="leftwards") c(min(H)-sw/alp,max(H)) else c(min(H),max(H)+sw/alp) } if(is.null(ylim)) ylim=range(Y) if(direction=="leftwards") H<-max(H)-H plot.window(xlim=xlim,ylim=ylim,asp=asp) if(plot){ #### if(!split.vertical){ for(i in 1:m) lines(H[which(cw$edge[,1]==nodes[i]),1], Y[cw$edge[which(cw$edge[,1]==nodes[i]),2]],col=colors[names(cw$maps[[match(nodes[i], cw$edge[,1])]])[1]],lwd=lwd) } for(i in 1:nrow(cw$edge)){ x<-H[i,1] for(j in 1:length(cw$maps[[i]])){ if(direction=="leftwards") lines(c(x,x-cw$maps[[i]][j]),c(Y[cw$edge[i,2]],Y[cw$edge[i,2]]), col=colors[names(cw$maps[[i]])[j]],lwd=lwd,lend=lend) else lines(c(x,x+cw$maps[[i]][j]),c(Y[cw$edge[i,2]],Y[cw$edge[i,2]]), col=colors[names(cw$maps[[i]])[j]],lwd=lwd,lend=lend) if(pts) points(c(x,x+cw$maps[[i]][j]),c(Y[cw$edge[i,2]],Y[cw$edge[i,2]]), pch=20,lwd=(lwd-1)) x<-x+if(direction=="leftwards") -cw$maps[[i]][j] else cw$maps[[i]][j] j<-j+1 } } if(node.numbers){ symbols(if(direction=="leftwards") max(H) else 0, mean(Y[cw$edge[cw$edge[,1]==(Ntip(cw)+1),2]]), rectangles=matrix(c(1.2*fsize*strwidth(as.character(Ntip(cw)+1)), 1.4*fsize*strheight(as.character(Ntip(cw)+1))),1,2),inches=FALSE, bg="white",add=TRUE) text(if(direction=="leftwards") max(H) else 0, mean(Y[cw$edge[cw$edge[,1]==(Ntip(cw)+1),2]]),Ntip(cw)+1, cex=fsize) for(i in 1:nrow(cw$edge)){ x<-H[i,2] if(cw$edge[i,2]>Ntip(cw)){ symbols(x,Y[cw$edge[i,2]], rectangles=matrix(c(1.2*fsize*strwidth(as.character(cw$edge[i,2])), 1.4*fsize*strheight(as.character(cw$edge[i,2]))),1,2),inches=FALSE, bg="white",add=TRUE) text(x,Y[cw$edge[i,2]],cw$edge[i,2],cex=fsize) } } } if(direction=="leftwards") pos<-if(par()$usr[1]>par()$usr[2]) 4 else 2 if(direction=="rightwards") pos<-if(par()$usr[1]>par()$usr[2]) 2 else 4 for(i in 1:n) if(ftype) text(H[which(cw$edge[,2]==i),2],Y[i],cw$tip.label[i],pos=pos, offset=offset,cex=fsize,font=ftype) } if(setEnv){ PP<-list(type="phylogram",use.edge.length=TRUE,node.pos=1, show.tip.label=if(ftype) TRUE else FALSE,show.node.label=FALSE, font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE,label.offset=offset, x.lim=xlim,y.lim=ylim, direction=direction,tip.color="black",Ntip=Ntip(cw),Nnode=cw$Nnode, edge=cw$edge,xx=sapply(1:(Ntip(cw)+cw$Nnode), function(x,y,z) y[match(x,z)],y=H,z=cw$edge),yy=Y[,1]) assign("last_plot.phylo",PP,envir=.PlotPhyloEnv) } if(plot) if(split.vertical) splitEdgeColor(cw,colors,lwd) } # function to plot simmap tree in type "fan" # written by Liam J. Revell 2013-2017 plotFan<-function(tree,colors,fsize,ftype,lwd,mar,add,part,setEnv,xlim,ylim,tips,maxY,lend,plot){ if(!plot) cat("plot=FALSE option is not permitted for type=\"fan\". Tree will be plotted.\n") # 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]," ",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) } if(setEnv){ PP<-list(type="fan",use.edge.length=TRUE,node.pos=1, show.tip.label=if(ftype) TRUE else FALSE,show.node.label=FALSE, font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE,label.offset=offset, x.lim=xlim,y.lim=ylim,direction="rightwards",tip.color="black", Ntip=Ntip(cw),Nnode=cw$Nnode,edge=cw$edge, xx=c(x[sapply(1:n,function(x,y) which(x==y)[1],y=cw$edge[,2]),2],x[1,1], if(m>1) x[sapply(2:m+n,function(x,y) which(x==y)[1],y=cw$edge[,2]),2] else c()), yy=c(y[sapply(1:n,function(x,y) which(x==y)[1],y=cw$edge[,2]),2],y[1,1], if(m>1) y[sapply(2:m+n,function(x,y) which(x==y)[1],y=cw$edge[,2]),2] else c())) assign("last_plot.phylo",PP,envir=.PlotPhyloEnv) } } ## internal function for slanted cladogram ## written by Liam J. Revell 2017 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){ 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 tips[gsub(" ","_",cw$tip.label)] # get Y coordinates of the nodes nodes<-unique(pw$edge[,1]) for(i in 1:m){ if(placement=="intermediate"){ desc<-pw$edge[which(pw$edge[,1]==nodes[i]),2] Y[nodes[i]]<-(min(Y[desc])+max(Y[desc]))/2 } else if(placement=="centered"){ desc<-getDescendants(pw,nodes[i]) desc<-desc[desc<=Ntip(pw)] Y[nodes[i]]<-(min(Y[desc])+max(Y[desc]))/2 } else if(placement=="weighted"){ desc<-pw$edge[which(pw$edge[,1]==nodes[i]),2] n1<-desc[which(Y[desc]==min(Y[desc]))] n2<-desc[which(Y[desc]==max(Y[desc]))] v1<-pw$edge.length[which(pw$edge[,2]==n1)] v2<-pw$edge.length[which(pw$edge[,2]==n2)] Y[nodes[i]]<-((1/v1)*Y[n1]+(1/v2)*Y[n2])/(1/v1+1/v2) } else if(placement=="inner"){ desc<-getDescendants(pw,nodes[i]) desc<-desc[desc<=Ntip(pw)] mm<-which(abs(Y[desc]-median(Y[1:Ntip(pw)]))==min(abs(Y[desc]- median(Y[1:Ntip(pw)])))) if(length(mm>1)) mm<-mm[which(Y[desc][mm]==min(Y[desc][mm]))] Y[nodes[i]]<-Y[desc][mm] } } # compute node heights H<-nodeHeights(cw) # open plot par(mar=mar) if(is.null(offset)) offset<-0.2*lwd/3+0.2/3 if(!add) plot.new() ### if(is.null(xlim)){ pp<-par("pin")[1] sw<-fsize*(max(strwidth(cw$tip.label,units="inches")))+ offsetFudge*fsize*strwidth("W",units="inches") alp<-optimize(function(a,H,sw,pp) (a*1.04*max(H)+sw-pp)^2,H=H,sw=sw,pp=pp, interval=c(0,1e6))$minimum xlim<-if(direction=="leftwards") c(min(H)-sw/alp,max(H)) else c(min(H),max(H)+sw/alp) } if(is.null(ylim)) ylim=range(Y) if(direction=="leftwards") H<-max(H)-H plot.window(xlim=xlim,ylim=ylim,asp=asp) if(plot){ #### for(i in 1:nrow(cw$edge)){ x<-H[i,1] y<-Y[cw$edge[i,1]] m<-(Y[cw$edge[i,2]]-Y[cw$edge[i,1]])/(H[i,2]-H[i,1]) if(is.finite(m)){ for(j in 1:length(cw$maps[[i]])){ if(direction=="leftwards") lines(c(x,x-cw$maps[[i]][j]),c(y,y-cw$maps[[i]][j]*m), col=colors[names(cw$maps[[i]])[j]],lwd=lwd,lend=lend) else lines(c(x,x+cw$maps[[i]][j]),c(y,y+cw$maps[[i]][j]*m), col=colors[names(cw$maps[[i]])[j]],lwd=lwd,lend=lend) x<-x+if(direction=="leftwards") -cw$maps[[i]][j] else cw$maps[[i]][j] y<-y+if(direction=="leftwards") -m*cw$maps[[i]][j] else m*cw$maps[[i]][j] j<-j+1 } } else { lines(rep(x,2),Y[cw$edge[i,]],col=colors[names(cw$maps[[i]])[1]],lwd=lwd, lend=lend) } } if(direction=="leftwards") pos<-if(par()$usr[1]>par()$usr[2]) 4 else 2 if(direction=="rightwards") pos<-if(par()$usr[1]>par()$usr[2]) 2 else 4 for(i in 1:n) if(ftype) text(H[which(cw$edge[,2]==i),2],Y[i],cw$tip.label[i],pos=pos, offset=offset,cex=fsize,font=ftype) } PP<-list(type="phylogram",use.edge.length=TRUE,node.pos=1, show.tip.label=if(ftype) TRUE else FALSE,show.node.label=FALSE, font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE,label.offset=offset, x.lim=xlim,y.lim=ylim, direction=direction,tip.color="black",Ntip=Ntip(cw),Nnode=cw$Nnode, edge=cw$edge,xx=sapply(1:(Ntip(cw)+cw$Nnode), function(x,y,z) y[match(x,z)],y=H,z=cw$edge),yy=Y[,1]) assign("last_plot.phylo",PP,envir=.PlotPhyloEnv) } ## adds legend to an open stochastic map style plot ## written by Liam J. Revell 2013, 2016, 2017 add.simmap.legend<-function(leg=NULL,colors,prompt=TRUE,vertical=TRUE,...){ if(hasArg(shape)) shape<-list(...)$shape else shape<-"square" if(prompt){ cat("Click where you want to draw the legend\n") x<-unlist(locator(1)) y<-x[2] x<-x[1] } else { if(hasArg(x)) x<-list(...)$x else x<-0 if(hasArg(y)) y<-list(...)$y else y<-0 } if(hasArg(fsize)) fsize<-list(...)$fsize else fsize<-1.0 if(is.null(leg)) leg<-names(colors) h<-fsize*strheight(LETTERS[1]) w<-par()$mfcol[2]*h*abs(diff(par()$usr[1:2])/diff(par()$usr[3:4])) flipped<-par()$usr[1]>par()$usr[2] if(vertical){ y<-y-0:(length(leg)-1)*1.5*h x<-rep(x+w/2,length(y)) text(x + if(flipped) -w else w,y,leg,pos=4,cex=fsize/par()$cex) } else { sp<-abs(fsize*max(strwidth(leg))) x<-x + if(flipped) w/2-0:(length(leg)-1)*1.5*(sp+w) else -w/2+0:(length(leg)-1)*1.5*(sp+w) y<-rep(y+w/2,length(x)) text(x,y,leg,pos=4,cex=fsize/par()$cex) } if(shape=="square") symbols(x,y,squares=rep(w,length(x)),bg=colors,add=TRUE,inches=FALSE) else if(shape=="circle") nulo<-mapply(draw.circle,x=x,y=y,col=colors, MoreArgs=list(nv=200,radius=w/2)) else stop(paste("shape=\"",shape,"\" is not a recognized option.",sep="")) } # function plots a tree; in the new version this is just a wrapper for plotSimmap # written by Liam Revell 2012-2017 plotTree<-function(tree,...){ if(hasArg(color)) color<-list(...)$color else color<-NULL if(hasArg(fsize)) fsize<-list(...)$fsize else fsize<-1.0 if(hasArg(ftype)) ftype<-list(...)$ftype else ftype<-"reg" if(hasArg(lwd)) lwd<-list(...)$lwd else lwd<-2 if(hasArg(pts)) pts<-list(...)$pts else pts<-FALSE if(hasArg(node.numbers)) node.numbers<-list(...)$node.numbers else node.numbers<-FALSE if(hasArg(mar)) mar<-list(...)$mar else mar<-NULL if(hasArg(add)) add<-list(...)$add else add<-FALSE if(hasArg(offset)) offset<-list(...)$offset else offset<-NULL if(hasArg(type)) type<-list(...)$type else type<-"phylogram" if(hasArg(direction)) direction<-list(...)$direction else direction<-"rightwards" if(hasArg(setEnv)) setEnv<-list(...)$setEnv else setEnv<-TRUE if(hasArg(part)) part<-list(...)$part else part<-1.0 if(hasArg(xlim)) xlim<-list(...)$xlim else xlim<-NULL if(hasArg(ylim)) ylim<-list(...)$ylim else ylim<-NULL if(hasArg(nodes)) nodes<-list(...)$nodes else nodes<-"intermediate" if(hasArg(tips)) tips<-list(...)$tips else tips<-NULL if(hasArg(maxY)) maxY<-list(...)$maxY else maxY<-NULL if(hasArg(hold)) hold<-list(...)$hold else hold<-TRUE if(hasArg(lend)) lend<-list(...)$lend else lend<-2 if(hasArg(asp)) asp<-list(...)$asp else asp<-NA if(hasArg(plot)) plot<-list(...)$plot else plot<-TRUE if(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) } 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) } } ## 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/ancThresh.R0000644000176200001440000003437613474622276014430 0ustar liggesusers## function performs ancestral character estimation under the threshold model ## written by Liam J. Revell 2012, 2013, 2014, 2017, 2019 ancThresh<-function(tree,x,ngen=10000,sequence=NULL,method="mcmc",model=c("BM","OU","lambda"),control=list(),...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") # 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) l<-sapply(x,function(x) runif(n=1,min=th[x]-1,max=th[x])) # set plausible starting liability 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])) # now change the upper limit of th to Inf th[length(th)]<-Inf # 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){ 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\nof 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$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) 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=par()$usr[1],y=par()$usr[1],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])) } 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/evol.rate.mcmc.R0000644000176200001440000005060113475612053015304 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 ## 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 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 a list from our mcmc run, or a matrix if(class(split.list)=="list") split.list<-split.list$mcmc[,c("node","bp")] else if(class(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/plotTree.datamatrix.R0000644000176200001440000000425113240702253016412 0ustar liggesusers## function to plot a grid of discrete character data next to the tips of a tree ## written by Liam J. Revell 2018 plotTree.datamatrix<-function(tree,X,...){ N<-Ntip(tree) ss<-sapply(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 { palettes<-c("Accent","Dark2","Paired","Pastel1","Pastel2", "Set1","Set2","Set3") while(length(palettes)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(type=="phylogram"){ if(x$direction=="downwards"&&direction=="rightwards"){ cat("\"phylo.to.map\" direction is \"downwards\" but plot direction has been given as \"rightwards\".\n") cat("Re-optimizing object....\n") cc<-aggregate(coords,by=list(rownames(coords)),mean) cc<-matrix(as.matrix(cc[,2:3]),nrow(cc),2,dimnames=list(cc[,1],colnames(cc)[2:3])) tree<-minRotate(tree,cc[,1]) } else if(x$direction=="rightwards"&&direction=="downwards"){ cat("\"phylo.to.map\" direction is \"rightwards\" but plot direction has been given as \"downwards\".\n") cat("Re-optimizing object....\n") cc<-aggregate(coords,by=list(rownames(coords)),mean) cc<-matrix(as.matrix(cc[,2:3]),nrow(cc),2,dimnames=list(cc[,1],colnames(cc)[2:3])) tree<-minRotate(tree,cc[,2]) } } # recompute ylim or xlim to leave space for the tree if(type=="phylogram"){ if(direction=="downwards"){ if(!ftype) ylim<-c(ylim[1],ylim[2]+0.03*diff(ylim)) ylim<-c(ylim[1],ylim[2]+ split[1]/split[2]*(ylim[2]-ylim[1])) } else if(direction=="rightwards"){ if(!ftype) xlim<-c(xlim[1]-0.03*diff(xlim),xlim[2]) xlim<-c(xlim[1]-split[1]/split[2]*(xlim[2]-xlim[1]),xlim[2]) } } # open & size a new plot if(all(mar==0)) mar<-mar+0.01 plot.new() par(mar=mar) plot.window(xlim=xlim,ylim=ylim,asp=asp) map(map,add=TRUE,fill=TRUE,col="gray95",mar=rep(0,4)) if(type=="phylogram"){ ## preliminaries cw<-reorder(tree,"cladewise") if(!is.binary(cw)) cw<-multi2di(cw) n<-Ntip(cw) if(direction=="downwards"){ # plot a white rectangle dx<-abs(diff(xlim)) rect(xlim[1]-1.04*dx,ylim[2]-split[1]*(ylim[2]-ylim[1]), xlim[2]+1.04*dx,ylim[2],col="white",border="white") # 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) lines(range(x[cw$edge[which(cw$edge[,1]==i),2]]), Y[which(cw$edge[,1]==i),1],lwd=lwd[1],lend=2) # plot tip labels for(i in 1:n){ if(ftype) text(x[i],Y[which(cw$edge[,2]==i),2], paste(" ",sub("_"," ",cw$tip.label[i]),sep=""), pos=4,offset=c(0,1), srt=-90,cex=fsize,font=ftype) if(pts) points(x[i],Y[which(cw$edge[,2]==i),2],pch=21, bg=colors[cw$tip.label,][i,2], cex=cex.points[1]) } PP<-list(type="phylogram",use.edge.length=TRUE,node.pos=1, show.tip.label=if(ftype) TRUE else FALSE,show.node.label=FALSE, font=ftype,cex=fsize,adj=0,srt=0,no.margin=FALSE, label.offset=fsize*strwidth(" ")/(par()$usr[2]- par()$usr[1])*(par()$usr[4]-par()$usr[3]), x.lim=par()$usr[1:2],y.lim=par()$usr[3:4], direction=direction,tip.color="black",Ntip=Ntip(cw), Nnode=cw$Nnode,edge=cw$edge,xx=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="white",border="white") 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) lines(X[which(cw$edge[,1]==i),1], range(y[cw$edge[which(cw$edge[,1]==i),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=par()$usr[1:2],y.lim=par()$usr[3:4], direction=direction,tip.color="black",Ntip=Ntip(cw),Nnode=cw$Nnode, edge=cw$edge,xx=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 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(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) } 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/write.simmap.R0000644000176200001440000000550013044122633015074 0ustar liggesusers## function writes a modified "phylo" object to a simmap Newick string ## written by Liam Revell 2011, 2013, 2015, 2017 write.simmap<-function(tree,file=NULL,append=FALSE,map.order=NULL,quiet=FALSE){ if(inherits(tree,"multiPhylo")){ if(is.null(file)) obj<-vector(mode="character",length=length(tree)) for(i in 1:length(tree)){ if(is.null(file)) obj[i]<-write.simmap(tree[[i]],file,if(i==1) append else TRUE,map.order,quiet) else write.simmap(tree[[i]],file,if(i==1) append else TRUE,map.order,quiet) } if(is.null(file)) return(obj) } else { if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\" or \"multiPhylo\".") if(is.null(tree$maps)) stop("tree is does not contain a stochastic character map.") 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<-length(tree$tip) 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]<-":{"; j<-j+1 if(map.order=="L"){ for(l in 1:length(tree$maps[[i]])){ string[j]<-paste(c(names(tree$maps[[i]])[l],",",round(tree$maps[[i]][l],8)),collapse="") string[j+1]<-":"; j<-j+2 } } else { for(l in length(tree$maps[[i]]):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-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){ 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="") if(is.null(file)) return(string) else write(string,file=file,append=append) } } phytools/R/mcmcBM.full.R0000644000176200001440000001022511746536333014571 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/fastBM.R0000644000176200001440000000745713116240566013654 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/ctt.R0000644000176200001440000001221013211366237013251 0ustar liggesusers## computing the mean number of character changes through time from a set of stochastic map trees ## written by Liam J. Revell 2017 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/exhaustiveMP.R0000644000176200001440000000560712107732706015116 0ustar liggesusers# function does branch & bound or exhaustive MP tree search # uses "phangorn (Schliep 2011) & "ape" (Paradis & Strimmer 2004) # data is a phyDat object; method can be "branch.and.bound" or "exhaustive" # written by Liam J. Revell 2011, 2013 exhaustiveMP<-function(data,tree=NULL,method="branch.and.bound"){ if(method=="branch.and.bound"){ if(length(data)>15) 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/ltt95.R0000644000176200001440000001215613500216151013437 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]&&iirunif(n=1)){ q<-qp likQ<-likQp } 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),sep="\t")) cat("\n") flush.console() } if(plot) plot(1:i,PS[1:i,"logLik"],col="darkgrey",xlab="generation", ylab="log(L)",xlim=c(0,ngen),type="l") } cat("Done.\n") class(PS)<-"mcmcMk" attr(PS,"model")<-model attr(PS,"index.matrix")<-index.matrix attr(PS,"states")<-states PS } 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,...){ plot(x[,"gen"],x[,"logLik"],type="s",xlab="generation",ylab="log(L)", col="grey",bty="l",main="Likelihood profile from MCMC", font.main=1) } summary.mcmcMk<-function(object,...){ 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 } 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) 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,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){ plot(x[[1]],main="estimated posterior density for q", bty="l",font.main=1,xlim=xlim,ylim=ylim, xlab="q") 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){ plot(x[[1]],xlim=xlim,ylim=ylim, main=expression(paste("estimated posterior density for ", Q[ij])),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/sim.history.R0000644000176200001440000001054513477256632014773 0ustar liggesusers## function simulates stochastic character history under some model ## written by Liam J. Revell 2011, 2013, 2014, 2016 sim.history<-function(tree,Q,anc=NULL,nsim=1,...){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(hasArg(message)) message<-list(...)$message else message<-TRUE # reorder to cladewise tree<-reorder.phylo(tree,"cladewise") # check Q if(!isSymmetric(Q)) if(message) cat("Note - the rate of substitution from i->j should be given by Q[j,i].\n") 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) } } # 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/evol.vcv.R0000644000176200001440000001512512730064411014223 0ustar liggesusers# this function fits the model of Revell & Collar (2009; Evolution) # written by Liam J. Revell 2010, 2011, 2013, 2014, 2015, 2016 evol.vcv<-function(tree,X,maxit=2000,vars=FALSE,...){ if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".") n<-nrow(X) # number of species m<-ncol(X) # number of traits if(hasArg(se)){ se<-list(...)$se se<-se[tree$tip.label] } else { se<-replicate(n,matrix(0,m,m),simplify=FALSE) names(se)<-tree$tip.label } SE<-matrix(0,n*m,n*m) for(i in 1:n){ ii<-0:(m-1)*n+i SE[ii,ii]<-se[[i]] } 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)*nmaxLambda(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) return(as.numeric(K)) # return K else { P=0.0 simX<-x for(i in 1:nsim){ a<-sum(invC%*%simX)/sum(invC) simK<-(t(simX-a)%*%(simX-a)/(t(simX-a)%*%invC%*%(simX-a)))/((sum(diag(C))-n/sum(invC))/(n-1)) if(simK>=K) P<-P+1/nsim # calculate P-value for randomization test simX<-sample(simX) # randomize x } return(list(K=as.numeric(K),P=P)) # return K & P } } 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 return(logL) } 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) return(list(K=as.numeric(K),sig2=as.numeric(sig2),logL=res$objective[1,1])) else { P=0.0 simX<-x 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)) simK<-(t(simX-a)%*%(simX-a)/(t(simX-a)%*%invCe%*%(simX-a)))/((sum(diag(Ce))-n/sum(invCe))/(n-1)) # calculate K if(simK>=K) P<-P+1/nsim # calculate P-value for randomization test o<-sample(1:n) simX<-x[o]; M<-diag(se[o]^2) # randomize x & errors } return(list(K=as.numeric(K),P=P,sig2=as.numeric(sig2),logL=res$objective[1,1])) # return K & P } } } else if(method=="lambda"){ # function to compute C with lambda lambda.transform<-function(C,lambda){ dC<-diag(diag(C)) C<-lambda*(C-dC)+dC return(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 return(logL) } # 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 return(-logL) } C<-vcv.phylo(tree) x<-x[rownames(C)] maxlam<-maxLambda(tree) if(!me){ res<-optimize(f=likelihoodLambda,interval=c(0,maxlam),y=x,C=C,maximum=TRUE) # optimize lambda if(!test) return(list(lambda=res$maximum,logL=res$objective[1,1])) # return lambda and log-likelihood else { logL0<-likelihoodLambda(theta=0,C=C,y=x) # compute likelihood of lambda=0 P<-as.numeric(pchisq(2*(res$objective[1,1]-logL0),df=1,lower.tail=FALSE)) # P-value return(list(lambda=res$maximum,logL=res$objective[1,1],logL0=logL0[1,1],P=P)) # return lambda, logL, and P-value } } else { M<-M[rownames(C),colnames(C)] if(is.null(start)) s<-c(0.02*runif(n=1)*mean(pic(x,multi2di(tree))^2),runif(n=1)) else s<-start res<-optim(s,likelihoodLambda.me,C=C,y=x,M=M,method="L-BFGS-B",lower=c(0,0),upper=c(Inf,maxlam),control=control) if(!test) return(list(lambda=res$par[2],sig2=res$par[1],logL=-res$value,convergence=res$convergence,message=res$message)) else { res0<-optim(c(s[1],0),likelihoodLambda.me,C=C,y=x,M=M,method="L-BFGS-B",lower=c(0,0),upper=c(Inf,1e-10),control=control) P<-as.numeric(pchisq(2*(res0$value-res$value),df=1,lower.tail=FALSE)) return(list(lambda=res$par[2],sig2=res$par[1],logL=-res$value,convergence=res$convergence,message=res$message,logL0=-res0$value,P=P)) } } } else stop(paste("do not recognize method = \"",method,"\"; methods are \"K\" and \"lambda\"",sep="")) } phytools/R/map.to.singleton.R0000644000176200001440000001203113061612026015650 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="rightward",tip.color="black",Ntip=Ntip(cw),Nnode=cw$Nnode, edge=cw$edge,xx=sapply(1:(Ntip(cw)+cw$Nnode), function(x,y,z) y[match(x,z)],y=X,z=cw$edge),yy=y) assign("last_plot.phylo",PP,envir=.PlotPhyloEnv) } ## function to reorder the edges of the tree for postorder traversal should *only* be used internally to ## plotTree.singletons (i.e., is not designed for general use). ## written by Liam J. Revell 2013 reorderPhylo<-function(x,order="pruningwise",index.only=FALSE,...){ if(index.only) stop("index.only=TRUE not permitted") if(order!="pruningwise") stop("function only returns trees in modified pruningwise format for plotTree.singletons") if(attr(x,"order")!="cladewise") stop("input tree should be in cladewise order.") aa<-lapply(x$edge[,1],getDescendants,tree=x) ll<-sapply(aa,length) ii<-order(ll) x$edge<-x$edge[ii,] x$edge.length<-x$edge.length[ii] attr(x,"order")<-"pruningwise" return(x) } ## function converts a tree with a root edge to a tree with a singleton node instead ## written by Liam J. Revell 2016 rootedge.to.singleton<-function(tree){ cw<-reorder(tree,"cladewise") root.edge<-if(!is.null(cw$root.edge)) cw$root.edge else 0 cw$edge[which(cw$edge>Ntip(cw))]<-cw$edge[which(cw$edge>Ntip(cw))]+1 cw$edge<-rbind(Ntip(cw)+c(1,2),cw$edge) cw$Nnode<-cw$Nnode+1 cw$edge.length<-c(root.edge,cw$edge.length) cw } phytools/R/threshBayes.R0000644000176200001440000001660613303017572014752 0ustar liggesusers## Function fits the threshold model for two characters using Bayesian MCMC. ## All characters should be provided either in the form of a numeric matrix, X, or as ## a data frame in which the discrete character is coded as a factor ## Row names of X should match the species names of the tree. ## types=c("discrete","discrete"), c("discrete","continuous"), c("cont","disc") etc. should ## be used to indicate the data type of each column in X ## written by Liam J. Revell 2012, 2014, 2017, 2018 threshBayes<-function(tree,X,types=NULL,ngen=10000,control=list(),...){ if(hasArg(burnin)) burnin<-list(...)$burnin else burnin<-round(0.2*ngen) 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) } # 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") 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,7,dimnames=list(NULL,c("gen","sig1","sig2", "a1","a2","r","logL"))) Z[1,]<-c(0,sig2,a,r,lik(a,V,invV,detV,D,Y)) 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)) # start MCMC cat("Starting MCMC....\n") for(i in 1:ngen){ lik1<-lik(a,V,invV,detV,D,Y)+log(all(P[,disc]==X[,disc])) d<-i%%npar if(ngen>=1000) if(i%%1000==0) if(!con$quiet) cat(paste("gen ",i,"\n",sep="")) Yp<-Y sig2p<-sig2 ap<-a rp<-r if(d<=length(Y[,disc])&&d>0){ # update liabilities ind<-c(d%%n,disc[ceiling(d/n)]) if(ind[1]==0) ind[1]<-n Yp[ind[1],ind[2]]<-Y[ind[1],ind[2]]+rnorm(n=1,sd=sqrt(con$propliab)) } else { if((d-length(Y[,disc]))==1||(d-length(Y[,disc]))==2){ # update sig2 if(!((d-length(Y[,disc]))%in%disc)){ j<-d-length(Y[,disc]) sig2p[j]<-sig2[j]+rnorm(n=1,sd=sqrt(con$propvar[j])) if(sig2p[j]<0) sig2p[j]=-sig2p[j] 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((d-length(Y[,disc]))==3||(d-length(Y[,disc]))==4){ # update a j<-d-length(Y[,disc]) ap[j-2]<-a[j-2]+rnorm(n=1,sd=sqrt(con$propvar[j])) } else if(d==0) { # update 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)))) if(p.odds>runif(n=1)){ Y<-Yp sig2<-sig2p a<-ap r<-rp V<-Vp invV<-invVp detV<-detVp logL<-lik2 } else logL<-lik1 if(i%%con$sample==0){ Z[i/con$sample+1,]<-c(i,sig2,a,r,logL) L[i/con$sample+1,]<-c(i,Y[,1],Y[,2]) } } cat("Done MCMC.\n") obj<-list(par=as.data.frame(Z),liab=as.data.frame(L), burnin=burnin,levels=levels,types=types) 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.threshBayes<-function(x,...){ if(hasArg(burnin)) burnin<-list(...)$burnin else burnin<-x$burnin if(hasArg(bw)) bw<-list(...)$bw else bw<-0.05 if(hasArg(xlim)) xlim<-list(...)$xlim else xlim<-c(-1,1) 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) if(hasArg(ylim)) ylim<-list(...)$ylim else ylim<-c(0,1.2*max(d$y)) plot(d,xlim=xlim,ylim=ylim,col="blue",xlab="Posterior sample of r", ylab="Density",main="") polygon(x=c(min(d$x),d$x,max(d$x)),y=c(0,d$y,0), col=make.transparent("blue",0.2)) r<-mean(x$par$r[ii:nrow(x$par)]) lines(rep(r,2),c(0,par()$usr[4]),col="blue",lty="dashed", lwd=2) text(r,0.95*par()$usr[4],"mean post-burnin\nvalue of r",cex=0.7, pos=if(r>0) 2 else 4) }phytools/R/fitDiversityModel.R0000644000176200001440000001200313477066010016125 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/fitPagel.R0000644000176200001440000002520613440066417014224 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 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.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)) ## 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,to.matrix(xy,levels(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,to.matrix(xy,levels(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,...){ 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(x$independent.Q) 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(x$dependent.Q) 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(obj) cat("\nHypothesis test result:\n") cat(paste(" likelihood-ratio: ",signif(x$lik.ratio,7),"\n")) cat(paste(" p-value: ",signif(x$P,7),"\n")) cat(paste("\nModel fitting method used was",x$method,"\n\n")) } ## function borrowed from geiger to pull the Q-matrix from a fit returned by ## fitDiscrete .Qmatrix.from.gfit<-function(x){ if(!.check.pkg("geiger")) argn<-function(...) NULL lik=x$lik numberize=function(x){ y=gsub("q","",x) sp=(nn<-nchar(y))/2 as.numeric(c(substring(y,1,sp),substring(y,sp+1, nn))) } att=attributes(lik) att$k=length(att$levels) Qmat=matrix(0,att$k,att$k) nms=att$argn[att$trns] other=att$argn[!att$trns] if("constrained"%in%class(lik)){ cpars=x$opt[argn(lik)] apars=names(lik(unlist(cpars),pars.only=TRUE)) nms=apars[!apars%in%other] } trns=x$opt[nms] for(i in 1:length(trns)){ nm=names(trns)[i] idx=numberize(nm) Qmat[idx[1],idx[2]]=trns[[i]] } diag(Qmat)=-rowSums(Qmat) rownames(Qmat)<-colnames(Qmat)<-levels(lik) Qmat } ## make the model matrix symmetric make.sym<-function(X){ for(i in 1:nrow(X)) for(j in i:nrow(X)) X[j,i]<-X[i,j] X } ## S3 plot method for objects of class "fitPagel ## written by Liam J. Revell 2016 plot.fitPagel<-function(x,...){ if(hasArg(signif)) signif<-list(...)$signif else signif<-3 if(hasArg(main)) main<-list(...)$main else main<-NULL if(!is.null(main)&&length(main)==1) main<-rep(main,2) if(hasArg(cex.main)) cex.main<-list(...)$cex.main else cex.main<-1.2 if(hasArg(cex.sub)) cex.sub<-list(...)$cex.sub else cex.sub<-1 if(hasArg(cex.traits)) cex.traits<-list(...)$cex.traits else cex.traits<-0.9 if(hasArg(cex.rates)) cex.rates<-list(...)$cex.rates else cex.rates<-0.8 if(hasArg(lwd.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(2,nrow(x$dependent.Q), ncol(x$dependent.Q)) par(mfrow=c(2,1)) ## INDEPENDENT MODEL plot.new() par(mar=c(1.1,2.1,3.1,2.1)) plot.window(xlim=c(0,2),ylim=c(0,1),asp=1) mtext(if(!is.null(main)) main[1] else "a) Independent model", side=3,adj=0,line=1.2,cex=cex.main) ## trait 1 text(x=0.15,y=1,"Trait 1:",cex=cex.sub) arrows(x0=0.5,y0=0.15,x1=0.5,y1=0.85, lwd=max(LWD.ind[3,1],1), lty=if(LWD.ind[3,1]==0) "dashed" else "solid", length=0.15,lend=3,angle=20) arrows(x0=0.55,y0=0.85,x1=0.55,y1=0.15, lwd=max(LWD.ind[1,3],1), lty=if(LWD.ind[1,3]==0) "dashed" else "solid", length=0.15,lend=3,angle=20) text(x=0.525,y=0.95,namesplit(rownames(x$dependent.Q)[1])[1], cex=cex.traits) text(x=0.525,y=0.05,namesplit(rownames(x$dependent.Q)[3])[1], cex=cex.traits) text(x=0.60,y=0.5,round(x$independent.Q[1,3],signif),cex=cex.rates,srt=90) text(x=0.45,y=0.5,round(x$independent.Q[3,1],signif),cex=cex.rates,srt=90) ## trait 2 text(x=1.3,y=1,"Trait 2:",cex=cex.sub) arrows(x0=1.65,y0=0.15,x1=1.65,y1=0.85, lwd=max(LWD.ind[2,1],1), lty=if(LWD.ind[2,1]==0) "dashed" else "solid", length=0.15,lend=3,angle=20) arrows(x0=1.70,y0=0.85,x1=1.70,y1=0.15, lwd=max(LWD.ind[1,2],1), lty=if(LWD.ind[1,2]==0) "dashed" else "solid", length=0.15,lend=3,angle=20) text(x=1.675,y=0.95,namesplit(rownames(x$dependent.Q)[1])[2], cex=cex.traits) text(x=1.675,y=0.05,namesplit(rownames(x$dependent.Q)[2])[2], cex=cex.traits) text(x=1.75,y=0.5,round(x$independent.Q[1,2],signif),cex=cex.rates,srt=90) text(x=1.60,y=0.5,round(x$independent.Q[2,1],signif),cex=cex.rates,srt=90) ## DEPENDENT MODEL collapse<- if(any(sapply(strsplit(rownames(x$dependent.Q),""),length)>6)) ",\n" else ", " plot.new() par(mar=c(1.1,2.1,3.1,2.1)) plot.window(xlim=c(0,2),ylim=c(0,1),asp=1) mtext(if(!is.null(main)) main[2] else "b) Dependent model", side=3,adj=0,line=1.2,cex=cex.main) text(x=0.15,y=0.95,"Trait 1,\nTrait 2:",cex=cex.sub) arrows(x0=0.5,y0=0.15,x1=0.5,y1=0.85, lwd=max(LWD.dep[3,1],1), lty=if(LWD.dep[3,1]==0) "dashed" else "solid", length=0.15,lend=3,angle=20) arrows(x0=0.55,y0=0.85,x1=0.55,y1=0.15, lwd=max(LWD.dep[1,3],1), lty=if(LWD.dep[1,3]==0) "dashed" else "solid", length=0.15,lend=3,angle=20) arrows(x0=1.45,y0=0.05,x1=0.75,y1=0.05, lwd=max(LWD.dep[4,3],1), lty=if(LWD.dep[4,3]==0) "dashed" else "solid", length=0.15,lend=3,angle=20) arrows(x0=0.75,y0=0.1,x1=1.45,y1=0.1, lwd=max(LWD.dep[3,4],1), lty=if(LWD.dep[3,4]==0) "dashed" else "solid", length=0.15,lend=3,angle=20) arrows(x0=1.65,y0=0.15,x1=1.65,y1=0.85, lwd=max(LWD.dep[4,2],1), lty=if(LWD.dep[4,2]==0) "dashed" else "solid", length=0.15,lend=3,angle=20) arrows(x0=1.7,y0=0.85,x1=1.7,y1=0.15, lwd=max(LWD.dep[2,4],1), lty=if(LWD.dep[2,4]==0) "dashed" else "solid", length=0.15,lend=3,angle=20) arrows(x0=1.45,y0=0.9,x1=0.75,y1=0.9, lwd=max(LWD.dep[2,1],1), lty=if(LWD.dep[2,1]==0) "dashed" else "solid", length=0.15,lend=3,angle=20) arrows(x0=0.75,y0=0.95,x1=1.45,y1=0.95, lwd=max(LWD.dep[1,2],1), lty=if(LWD.dep[1,2]==0) "dashed" else "solid", length=0.15,lend=3,angle=20) ## add states text(x=0.525,y=0.95, paste(namesplit(rownames(x$dependent.Q)[1]), collapse=collapse),cex=cex.traits) text(x=1.675,y=0.95, paste(namesplit(rownames(x$dependent.Q)[2]), collapse=collapse),cex=cex.traits) text(x=1.675,y=0.05, paste(namesplit(rownames(x$dependent.Q)[4]), collapse=collapse),cex=cex.traits) text(x=0.525,y=0.05, paste(namesplit(rownames(x$dependent.Q)[3]), collapse=collapse),cex=cex.traits) ## add rates text(x=1.1,y=1,round(x$dependent.Q[1,2],signif), cex=cex.rates) text(x=1.1,y=0.85,round(x$dependent.Q[2,1],signif), cex=cex.rates) text(x=1.6,y=0.5,round(x$dependent.Q[4,2],signif), cex=cex.rates,srt=90) text(x=1.75,y=0.5,round(x$dependent.Q[2,4],signif), cex=cex.rates,srt=90) text(x=1.1,y=0,round(x$dependent.Q[4,3],signif), cex=cex.rates) text(x=1.1,y=0.15,round(x$dependent.Q[3,4],signif), cex=cex.rates) text(x=0.45,y=0.5,round(x$dependent.Q[3,1],signif), cex=cex.rates,srt=90) text(x=0.6,y=0.5,round(x$dependent.Q[1,3],signif), cex=cex.rates,srt=90) } namesplit<-function(x){ tmp<-strsplit(x,"")[[1]] ii<-which(tmp=="|") c(paste(tmp[1:(ii-1)],collapse=""), paste(tmp[(ii+1):length(tmp)],collapse="")) }phytools/R/treeSlice.R0000644000176200001440000000567313072304210014401 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/phylomorphospace3d.R0000644000176200001440000000703313237375710016315 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 .check.pkg<-function(pkg){ if(pkg%in%rownames(installed.packages())){ require(pkg,character.only=TRUE) return(TRUE) } else return(FALSE) } phytools/R/evolvcv.lite.R0000644000176200001440000001531113475631455015115 0ustar liggesusers## function is simplified version of evol.vcv ## written by Liam J. Revell 2011, 2012, 2013, 2017, 2019 evolvcv.lite<-function(tree,X,maxit=2000,tol=1e-10){ if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".") # model 1: common variances & correlation lik1<-function(theta,C,D,y){ v<-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) 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){ p<-(length(theta)-1)/2 v<-matrix(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]]) 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 correlation lik3<-function(theta,C,D,y){ p<-length(theta)-2 v<-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]]) 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){ p<-length(theta)/3 v<-matrix(theta[1:(2*p)],p,2,byrow=T) 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]]) 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") 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)*n1){ ## MODELS 2-4 for(i in 2:4){ 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) cat(paste("Model ",i,": ",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 ",i,".)\n\n",sep="")) else cat(paste("\n(Model ",i,"optimization may not have converged.)\n\n",sep="")) } } } phytools/R/fitBayes.R0000644000176200001440000000746413201374341014236 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/anc.Bayes.R0000644000176200001440000001160513201672220014260 0ustar liggesusers## function does Bayes ancestral character estimation ## written by Liam J. Revell 2011, 2013, 2015, 2017 anc.Bayes<-function(tree,x,ngen=10000,control=list()){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") # give the function some defaults (in case none are provided) temp<-phyl.vcv(as.matrix(x),vcv(tree),1) sig2<-temp$R[1,1] a<-temp$alpha y<-rep(a,tree$Nnode-1) pr.mean<-c(1000,rep(0,tree$Nnode)) pr.var<-c(pr.mean[1]^2,rep(1000,tree$Nnode)) prop<-rep(0.01*max(temp$C)*sig2,tree$Nnode+1) # populate control list con=list(sig2=sig2,a=a,y=y,pr.mean=pr.mean,pr.var=pr.var,prop=prop,sample=100) con[(namc<-names(control))]<-control con<-con[!sapply(con,is.null)] # print control parameters to screen message("Control parameters (set by user or default):"); str(con) # function returns the log-likelihood likelihood<-function(C,invC,detC,x,sig2,a,y){ z<-c(x,y)-rep(a,nrow(C)) logLik<--z%*%invC%*%z/(2*sig2)-nrow(C)*log(2*pi)/2-nrow(C)*log(sig2)/2-detC/2 return(logLik) } # function returns the prior log.prior<-function(pr.mean,pr.var,sig2,a,y) pp<-dexp(sig2,rate=1/pr.mean[1],log=TRUE)+sum(dnorm(c(a,y),mean=pr.mean[2:length(pr.mean)],sd=sqrt(pr.var[1+1:tree$Nnode]),log=TRUE)) # compute C C<-vcvPhylo(tree) # check to make sure that C will be non-singular if(any(tree$edge.length<=(10*.Machine$double.eps))) stop("some branch lengths are 0 or nearly zero") invC<-solve(C) detC<-determinant(C,logarithm=TRUE)$modulus[1] # now set starting values for MCMC sig2<-con$sig2; a<-con$a; y<-con$y x<-x[tree$tip.label] if(is.null(names(y))) names(y)<-length(tree$tip)+2:tree$Nnode else y[as.character(length(tree$tip)+2:tree$Nnode)] L<-likelihood(C,invC,detC,x,sig2,a,y) Pr<-log.prior(con$pr.mean,con$pr.var,sig2,a,y) # store X<-matrix(NA,ngen/con$sample+1,tree$Nnode+3,dimnames=list(NULL,c("gen","sig2",length(tree$tip)+1:tree$Nnode,"logLik"))) X[1,]<-c(0,sig2,a,y,L) message("Starting MCMC...") # start MCMC for(i in 1:ngen){ j<-(i-1)%%(tree$Nnode+1) if(j==0){ # update sig2 sig2.prime<-sig2+rnorm(n=1,sd=sqrt(con$prop[j+1])) if(sig2.prime<0) sig2.prime<--sig2.prime L.prime<-likelihood(C,invC,detC,x,sig2.prime,a,y) Pr.prime<-log.prior(con$pr.mean,con$pr.var,sig2.prime,a,y) post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L)) if(post.odds>runif(n=1)){ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2.prime,a,y,L.prime) sig2<-sig2.prime L<-L.prime Pr<-Pr.prime } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,y,L) } else if(j==1){ # update a a.prime<-a+rnorm(n=1,sd=sqrt(con$prop[j+1])) L.prime<-likelihood(C,invC,detC,x,sig2,a.prime,y) Pr.prime<-log.prior(con$pr.mean,con$pr.var,sig2,a.prime,y) post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L)) if(post.odds>runif(n=1)){ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a.prime,y,L.prime) a<-a.prime L<-L.prime Pr<-Pr.prime } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,y,L) } else { k<-j-1 # update node k y.prime<-y y.prime[k]<-y[k]+rnorm(n=1,sd=sqrt(con$prop[j+1])) L.prime<-likelihood(C,invC,detC,x,sig2,a,y.prime) Pr.prime<-log.prior(con$pr.mean,con$pr.var,sig2,a,y.prime) post.odds<-min(1,exp(Pr.prime+L.prime-Pr-L)) if(post.odds>runif(n=1)){ if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,y.prime,L.prime) y<-y.prime L<-L.prime Pr<-Pr.prime } else if(i%%con$sample==0) X[i/con$sample+1,]<-c(i,sig2,a,y,L) } } # done MCMC message("Done MCMC.") obj<-list(mcmc=as.data.frame(X),tree=tree) class(obj)<-"anc.Bayes" obj } ## S3 methods print.anc.Bayes<-function(x,digits=6,printlen=NULL,...){ cat("\nObject of class \"anc.Bayes\" consisting of a posterior") cat("\n sample from a Bayesian ancestral state analysis:\n") if(hasArg(burnin)) burnin<-list(...)$burnin else burnin<-0.2*max(x$mcmc$gen) ii<-which(((x$mcmc$gen-burnin)^2)==min((x$mcmc$gen-burnin)^2)) Nnode<-x$tree$Nnode cat("\nMean ancestral states from posterior distribution:\n") ace<-colMeans(x$mcmc[ii:nrow(x$mcmc),as.character(1:Nnode+Ntip(x$tree))]) if(is.null(printlen)||printlen>=Nnode) print(round(ace,digits)) else printDotDot(ace,digits,printlen) cat(paste("\nBased on a burn-in of ",burnin," generations.\n\n",sep="")) invisible(ace) } 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) } }phytools/R/Dtest.R0000644000176200001440000000346713353210150013545 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/multiRF.R0000644000176200001440000000217213440066454014051 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/branching.diffusion.R0000644000176200001440000000314212517441667016414 0ustar liggesusers# function animates branching random diffusion # written by Liam Revell 2011, 2013, 2015 branching.diffusion<-function(sig2=1,b=0.0023,time.stop=1000,ylim=NULL,smooth=TRUE,pause=0.02,record=NULL,path=NULL){ 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") 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 } 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") 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/read.simmap.R0000644000176200001440000002223312564236166014674 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 text_to_tree<-function(text,version,rev.order,trans){ text<-unlist(strsplit(text, NULL)) 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) grep("\\&prob",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/map.overlap.R0000644000176200001440000000616012704702630014707 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/skewers.R0000644000176200001440000000240512235062700014140 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/phyl.RMA.R0000644000176200001440000000602213073265705014061 0ustar liggesusers## this function computes a phylogenetic reduced major axis (RMA) regression ## written by Liam Revell 2010, 2011, 2012, 2015, 2016, 2017 phyl.RMA<-function(x,y,tree,method="BM",lambda=NULL,fixed=FALSE,h0=1.0){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") x<-x[tree$tip.label]; y<-y[tree$tip.label] # bind the x & y into columns X<-cbind(x,y) if(method=="lambda") if(fixed==FALSE) result<-optimize(f=likMlambda,interval=c(0,1),X=X,C=vcv(tree), maximum=TRUE) else result<-list(objective=likMlambda(lambda,X,vcv(tree)),maximum=lambda) else if(method=="BM") result<-list(objective=likMlambda(1.0,X,vcv(tree)),maximum=1.0) else stop("do not recognize method") est.lambda<-result$maximum # estimated lambda C<-vcv(tree) C<-lambda.transform(est.lambda,C) temp<-phyl.vcv(X,vcv(tree),lambda=est.lambda) beta1<-sign(temp$R[1,2])*sqrt(temp$R[2,2]/temp$R[1,1]) beta0<-temp$a[2]-beta1*temp$a[1] r<-y-(beta0+beta1*x) r2<-temp$R[1,2]^2/(temp$R[1,1]*temp$R[2,2]) if(sign(beta1)!=sign(h0)){ warning("b & h0 have different signs; hypothesis test invalid") T<-0 } else T<-abs(log(abs(beta1))-log(abs(h0)))/sqrt((1-r2)/(Ntip(tree)-2)) df<-2+(Ntip(tree)-2)/(1+0.5*r2) P<-2*pt(T,df=df,lower.tail=FALSE) test<-c(r2,T,df,P); names(test)<-c("r2","T","df","P") object<-list(RMA.beta=c(beta0,beta1),V=temp$R,lambda=est.lambda, logL=as.numeric(result$objective),test=test,h0=h0,model=method, resid=as.matrix(r),data=cbind(x,y),tree=tree) class(object)<-"phyl.RMA" object } ## S3 methods for "phyl.RMA" object class print.phyl.RMA<-function(x,...){ cat("\nCoefficients:\n") print(coef(x)) cat("\nVCV matrix:\n") print(x$V) cat("\n") if(x$model=="BM") cat("Model for the covariance structure of the error is \"BM\"\n") else cat("Model for the covariance structure of the error is \"lambda\"\n") cat("\nEstimates (or set values):\n") print(setNames(c(x$lambda,x$logL),c("lambda","log(L)"))) cat("\n") cat("Hypothesis test based on Clarke (1980; Biometrika):\n") print(round(x$test,6)) cat(paste("\nNote that the null hypothesis test is h0 =",x$h0, "\n\n")) } coef.phyl.RMA<-function(object,...){ val<-setNames(object$RMA.beta,c("(Intercept)","x")) val } residuals.phyl.RMA<-function(object,...) object$resid[,1] plot.phyl.RMA<-function(x,...){ phylomorphospace(x$tree,x$data,node.size=c(0,0),ftype="off") points(x$data,cex=1.2,pch=21,bg="grey") x0<-ace(x$data[,1],x$tree,method="pic")$ace[1] y0<-ace(x$data[,2],x$tree,method="pic")$ace[1] a0<-y0-x$h0*x0 abline(a=a0,b=x$h0,lwd=2,col="grey",lty="dashed") abline(a=coef(x)[1],b=coef(x)[2],lwd=2,col="red") tmp<-legend(x=0,y=0,legend=c(expression(beta[RMA]),expression(h[0])), lty=c("solid","dashed"),lwd=c(2,2),plot=FALSE) legend(x=if(x$h0>0) par()$usr[1] else par()$usr[2]-tmp$rect$w, y=par()$usr[4],col=c("red","grey"), legend=c(expression(beta[RMA]),expression(h[0])), lty=c("solid","dashed"),lwd=c(2,2), bg=make.transparent("white",0.75)) } phytools/R/drop.tip.simmap.R0000644000176200001440000000556313353261107015515 0ustar liggesusers## function drops tip or tips from an object of class "simmap" ## written by Liam J. Revell 2012, 2015, 2018 drop.tip.simmap<-function(tree,tip){ if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".") tip<-which(tree$tip.label%in%tip) edges<-match(tip,tree$edge[,2]) z<-setdiff(1:nrow(tree$edge),edges) tree$edge<-tree$edge[z,] tree$edge.length<-tree$edge.length[z] tree$maps<-tree$maps[z] z<-setdiff(tree$edge[,2],tree$edge[,1]) z<-z[z>Ntip(tree)] while(length(z)>0){ edges<-match(z,tree$edge[,2]) y<-setdiff(1:nrow(tree$edge),edges) tree$edge<-tree$edge[y,] tree$edge.length<-tree$edge.length[y] tree$maps<-tree$maps[y] z<-setdiff(tree$edge[,2],tree$edge[,1]) z<-z[z>Ntip(tree)] } z<-setdiff(tree$edge[,2],tree$edge[,1]) tree$tip.label<-tree$tip.label[z] tree$edge[which(tree$edge[,2]%in%z),2]<-1:Ntip(tree) while(sum(tree$edge[1,1]==tree$edge[,1])==1){ tree$edge<-tree$edge[2:nrow(tree$edge),] tree$edge.length<-tree$edge.length[2:length(tree$edge.length)] tree$maps<-tree$maps[2:length(tree$maps)] } i<-1 while(i1) tree$maps[[i]]<-c(tree$maps[[i]],tree$maps[[z]][2:length(tree$maps[[z]])]) } y<-setdiff(1:nrow(tree$edge),z) tree$edge<-tree$edge[y,] tree$edge.length<-tree$edge.length[y] tree$maps<-tree$maps[y] single<-sum(tree$edge[i,2]==tree$edge[,1])==1 } i<-i+1 } z<-unique(as.vector(tree$edge)) z<-z[z>Ntip(tree)] y<-order(z)+Ntip(tree) for(i in 1:nrow(tree$edge)) for(j in 1:2) if(tree$edge[i,j]%in%z) tree$edge[i,j]<-y[which(tree$edge[i,j]==z)] tree$Nnode<-max(tree$edge)-Ntip(tree) tree$node.states<-matrix(NA,nrow(tree$edge),2) for(i in 1:nrow(tree$edge)) tree$node.states[i,]<-c(names(tree$maps[[i]])[1],names(tree$maps[[i]])[length(tree$maps[[i]])]) if(!is.null(tree$states)) tree$states<-tree$states[tree$tip.label] 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(edge=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")) return(tree) } phytools/R/phenogram.R0000644000176200001440000001635213160246164014451 0ustar liggesusers## function creates a phenogram (i.e., 'traitgram') ## written by Liam J. Revell 2011, 2012, 2013, 2014, 2015, 2016 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 ## 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) 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) else tt<-x[1:length(tree$tip)] print(tt) } 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); axis(2); 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 spreadlabels<-function(tree,x,fsize=1,cost=c(1,1),range=NULL,label.pos=NULL){ if(!is.null(label.pos)) return(label.pos[tree$tip.label]) else { if(is.null(range)) range<-range(x) 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))) return(rr$par) } } } phytools/R/dotTree.R0000644000176200001440000002062513375345245014105 0ustar liggesusers## function to plot a tree with dots/circles for a plotted phenotype ## written by Liam J. Revell 2016, 2017, 2018 dotTree<-function(tree,x,legend=TRUE,method="plotTree",standardize=FALSE,...){ if(is.data.frame(x)) x<-as.matrix(x) if(hasArg(data.type)) data.type<-list(...)$data.type else { ## try to detect type if(is.numeric(x)) data.type<-"continuous" else data.type<-"discrete" } if(data.type=="continuous"){ if(hasArg(colors)) colors<-list(...)$colors else colors<-"blue" dotTree.continuous(tree,x,colors[1],legend,method,standardize,...) } else if(data.type=="discrete"){ if(hasArg(colors)) colors<-list(...)$colors else { ss<-unique(as.vector(x)) colors<-setNames(palette()[1:length(ss)],ss) } dotTree.discrete(tree,x,colors,legend,method,...) } } dotTree.continuous<-function(tree,x,color,legend,method,standardize,...){ if(is.data.frame(x)) x<-as.matrix(x) if(is.matrix(x)&&method=="plotTree"){ if(ncol(x)>1) method<-"phylogram" else x<-x[,1] } if(hasArg(fsize)) fsize<-list(...)$fsize else fsize<-c(1,0.8) if(length(fsize)==1) fsize<-rep(fsize,2) if(hasArg(x.space)) x.space<-list(...)$x.space else x.space<-0.1 if(hasArg(k)) k<-list(...)$k else k<-0.8 ## reorder tree tree<-reorder(tree,"cladewise") ## if standardize==TRUE if(standardize){ if(is.matrix(x)){ sd<-apply(x,2,function(x) sqrt(var(x))) x<-(x-matrix(rep(1,Ntip(tree)),Ntip(tree),1)%*%colMeans(x))/ (matrix(rep(1,Ntip(tree)),Ntip(tree),1)%*%sd) } else if(is.vector(x)) x<-(x-mean(x))/sqrt(var(x)) } ## in case any x<0 min.x<-min(x) max.x<-max(x) if(any(x<0)) x<-x-min(x) if(method=="plotTree"){ fsize<-fsize[1] x<-x[tree$tip.label] ## plot tree plotTree(tree,offset=1.7,ylim=c(-Ntip(tree)/25, Ntip(tree)),...) ## get last phylo plot parameters obj<-get("last_plot.phylo",envir=.PlotPhyloEnv) x.tip<-obj$xx[1:obj$Ntip] y.tip<-obj$yy[1:obj$Ntip] ## plot points rr<-(k*x/max(x)+x.space)/2*diff(par()$usr[1:2])/ diff(par()$usr[3:4]) if(k<=0.8&&any(rr>(strwidth("W")*fsize/2))) rr<-rr/max(rr)*strwidth("W")*fsize/2 nulo<-mapply(draw.circle,x=x.tip+1.2*strwidth("W"),y=y.tip, radius=rr,MoreArgs=list(nv=200,col=color)) ## add legend if(legend){ h<-dot.legend(x=par()$usr[1]+0.1*max(nodeHeights(tree)), y=0,min.x,max.x,Ntip=Ntip(tree), method="plotTree",...) if(standardize) text(h,0.1*(1+par()$usr[3]),"(SD units)",pos=4) } } else if(method=="phylogram"){ if(is.vector(x)) x<-as.matrix(x) x[]<-x[tree$tip.label,] if(hasArg(mar)) mar<-list(...)$mar else mar<-rep(0.1,4) if(hasArg(xlim)) xlim<-list(...)$xlim else xlim<-c(-0.5,0.55+x.space*ncol(x)+x.space/2) if(hasArg(labels)) labels<-list(...)$labels else labels<-FALSE if(hasArg(ylim)) ylim<-list(...)$ylim else ylim<-c(if(legend) -0.1 else 0,if(labels) 1.1 else 1) ## plot tree plot.new() par(mar=mar) plot.window(xlim=xlim,ylim=ylim) h<-phylogram(tree,...) ## get last phylo plot parameters obj<-get("last_plot.phylo",envir=.PlotPhyloEnv) x.tip<-rep(h,obj$Ntip) y.tip<-obj$yy[1:obj$Ntip] ## plot points rr<-(k*x/max(x)+x.space)/2*diff(par()$usr[1:2])/diff(par()$usr[3:4])/ (Ntip(tree)-1) if(k<=0.8&&any(rr>(strwidth("W")*fsize[1]/2))) rr<-rr/max(rr)*strwidth("W")*fsize[1]/2 for(i in 1:ncol(x)){ nulo<-mapply(draw.circle,x=x.tip+1.2*strwidth("W")+x.space*(i-1), y=y.tip,radius=rr[,i],MoreArgs=list(nv=200,col=color)) } ## add legend if(legend){ h<-dot.legend(x=-0.45,y=-0.04,min.x,max.x,Ntip=Ntip(tree), method="phylogram",...) if(standardize) text(h,-0.04,"(SD units)",pos=4) } if(labels){ text(x=seq(max(x.tip)+1.2*strwidth("W"), max(x.tip)+1.2*strwidth("W")+x.space*(ncol(x)-1),by=x.space), y=rep(1.02,ncol(x)),colnames(x),srt=70,adj=c(0,0.5),cex=fsize[2]) } } } dotTree.discrete<-function(tree,x,color,legend,method,...){ if(is.data.frame(x)) x<-as.matrix(x) if(is.matrix(x)&&method=="plotTree"){ if(ncol(x)>1) method<-"phylogram" else x<-x[,1] } if(hasArg(fsize)) fsize<-list(...)$fsize else fsize<-c(1,0.8) if(length(fsize)==1) fsize<-rep(fsize,2) if(hasArg(x.space)) x.space<-list(...)$x.space else x.space<-0.1 ## reorder tree tree<-reorder(tree,"cladewise") if(method=="plotTree"){ x<-x[tree$tip.label] ## plot tree plotTree(tree,offset=1.7,ylim=c(-1/25*Ntip(tree), Ntip(tree)),...) ## get last phylo plot parameters obj<-get("last_plot.phylo",envir=.PlotPhyloEnv) x.tip<-obj$xx[1:obj$Ntip] y.tip<-obj$yy[1:obj$Ntip] ## plot points r<-min(0.8/2*diff(par()$usr[1:2])/diff(par()$usr[3:4]), strwidth("W")*fsize/2) nulo<-mapply(draw.circle,x=x.tip+1.2*strwidth("W"),y=y.tip, col=color[as.character(x)],MoreArgs=list(nv=200,radius=r)) if(legend){ add.simmap.legend(colors=color,prompt=FALSE, vertical=FALSE,shape="circle", x=par()$usr[1]+0.1*max(nodeHeights(tree)), y=-1/25*Ntip(tree)) } } else if(method=="phylogram"){ if(is.vector(x)) x<-as.matrix(x) x[]<-x[tree$tip.label,] if(hasArg(mar)) mar<-list(...)$mar else mar<-rep(0.1,4) if(hasArg(xlim)) xlim<-list(...)$xlim else xlim<-c(-0.5,0.55+x.space*ncol(x)+x.space/2) if(hasArg(labels)) labels<-list(...)$labels else labels<-FALSE if(hasArg(ylim)) ylim<-list(...)$ylim else ylim<-c(if(legend) -0.1 else 0,if(labels) 1.1 else 1) ## plot tree plot.new() par(mar=mar) plot.window(xlim=xlim,ylim=ylim) h<-phylogram(tree,...) ## get last phylo plot parameters obj<-get("last_plot.phylo",envir=.PlotPhyloEnv) x.tip<-rep(h,obj$Ntip) y.tip<-obj$yy[1:obj$Ntip] ## plot points r<-min(0.8/2*diff(par()$usr[1:2])/diff(par()$usr[3:4])/(Ntip(tree)-1), strwidth("W")*fsize/2) for(i in 1:ncol(x)){ nulo<-mapply(draw.circle,x=x.tip+1.2*strwidth("W")+x.space*(i-1), y=y.tip,col=color[as.character(x[,i])],MoreArgs=list(nv=20, radius=r)) } ## add legend if(legend){ add.simmap.legend(colors=color,prompt=FALSE, vertical=FALSE,shape="circle",x=-0.45,y=-0.06) } if(labels){ text(x=seq(max(x.tip)+1.2*strwidth("W"), max(x.tip)+1.2*strwidth("W")+x.space*(ncol(x)-1),by=x.space), y=rep(1.02,ncol(x)),colnames(x),srt=70,adj=c(0,0.5),cex=fsize[2]) } } } ## dot legend ## written by Liam J. Revell 2016 dot.legend<-function(x,y,min,max,Ntip,length=5,prompt=FALSE, method="plotTree",...){ if(hasArg(cex)) cex<-list(...)$cex else cex<-1 if(hasArg(fsize)) fsize<-list(...)$fsize else fsize<-1 if(hasArg(colors)) colors<-list(...)$colors else colors<-"blue" if(hasArg(leg.space)) leg.space<-list(...)$leg.space else leg.space<-0.2 if(hasArg(k)) k<-list(...)$k else k<-0.8 if(prompt){ obj<-locator(1) x<-obj$x y<-obj$y } if(method=="plotTree"){ text(x,y-0.5*(Ntip/25),round(min,2),pos=1,cex=cex) s<-(k*max(min,0)/min(max,max+min)+0.1)/2*diff(par()$usr[1:2])/ diff(par()$usr[3:4]) e<-(k+0.1)/2*diff(par()$usr[1:2])/diff(par()$usr[3:4]) rr<-seq(s,e,length.out=length) if(k<=0.8&&any(rr>(strwidth("W")*fsize/2))) rr<-rr/max(rr)*strwidth("W")*fsize/2 temp<-c(0,cumsum((1+leg.space)*rep(2*max(rr),length-1))) nulo<-mapply(draw.circle,x=x+temp,y=rep(y,length),radius=rr, MoreArgs=list(nv=200,col=colors)) ## draw.circle(x+temp,rep(y,length),nv=200,radius=rr,col=colors) text(max(x+temp),y-0.5*(Ntip/25),round(max,2),pos=1,cex=cex) y1<-0.1/25*Ntip lines(c(x,max(x+temp)),rep(y-0.5*(Ntip/25)-y1,2)) lines(c(x,x),y-c(y1+0.5*(Ntip/25),2*y1+0.5*(Ntip/25))) lines(c(max(x+temp),max(x+temp)),y-c(y1+0.5*(Ntip/25),2*y1+0.5*(Ntip/25))) } else if(method=="phylogram"){ text(x,y-0.04,round(min,2),pos=1,cex=cex) s<-(k*max(min,0)/(min(max,max+min))+0.1)/2* diff(par()$usr[1:2])/diff(par()$usr[3:4])/(Ntip-1) e<-(k+0.1)/2*diff(par()$usr[1:2])/diff(par()$usr[3:4])/(Ntip-1) rr<-seq(s,e,length.out=length) if(k<=0.8&&any(rr>(strwidth("W")*fsize/2))) rr<-rr/max(rr)*strwidth("W")*fsize/2 temp<-c(0,cumsum((1+leg.space)*rep(2*max(rr),length-1))) nulo<-mapply(draw.circle,x=x+temp,y=rep(y,length),radius=rr, MoreArgs=list(nv=200,col=colors)) ## draw.circle(x+temp,rep(y,length),nv=200,radius=rr,col=colors) text(max(x+temp),y-0.04,round(max,2),pos=1,cex=cex) y1<-0.01 lines(c(x,max(x+temp)),rep(y-0.02-y1,2)) lines(c(x,x),y-c(y1+0.02,2*y1+0.02)) lines(c(max(x+temp),max(x+temp)),y-c(y1+0.02,2*y1+0.02)) } invisible(max(x+temp)+0.5*max(rr)) }phytools/R/writeNexus.R0000644000176200001440000000213312562012303014625 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/brownieREML.R0000644000176200001440000000632313474626110014614 0ustar liggesusers## This function is a simplified REML version of brownie.lite() ## written by Liam J. Revell 2011, 2013, 2019 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) 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 print.brownieREML<-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("REML single-rate model:\n") cat("\ts^2\tse\tk\tlogL\n") cat(paste("value",x$sig2.single,round(sqrt(x$var.single),digits),x$k1,x$logL1,"\n\n",sep="\t")) cat("REML multi-rate model:\n") cat(paste(c("",paste("s^2(",names(x$sig2.multiple),")","\tse(",names(x$sig2.multiple),")",sep=""), "k","logL","\n"),collapse="\t")) cat(paste(paste(c("value",paste(x$sig2.multiple,round(sqrt(diag(x$vcv.multiple)),digits),sep="\t"),x$k2, x$logL.multiple),collapse="\t"),"\n\n",sep="")) if(x$convergence[1]=="Optimization has converged.") cat("R thinks it has found the REML solution.\n\n") else cat("Optimization may not have converged.\n\n") } phytools/R/strahlerNumber.R0000644000176200001440000000352612561737207015474 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/sim.corrs.R0000644000176200001440000000257512561736726014426 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/roundPhylogram.R0000644000176200001440000000613112727074156015505 0ustar liggesusers## function plots a round phylogram ## written by Liam J. Revell 2014, 2015, 2016 roundPhylogram<-function(tree,fsize=1.0,ftype="reg",lwd=2,mar=NULL,offset=NULL, direction="rightwards",type="phylogram",xlim=NULL,ylim=NULL,...){ if(inherits(tree,"multiPhylo")){ par(ask=TRUE) tt<-lapply(tree,roundPhylogram,fsize=fsize,ftype=ftype,lwd=lwd,mar=mar,offset=offset, direction=direction,type=type,xlim=xlim,ylim=ylim) } else { if(hasArg(lty)) lty<-list(...)$lty else lty<-"solid" if(length(lty)!=nrow(tree$edge)) lty<-rep(lty,ceiling(nrow(tree$edge)/length(lty))) if(length(lwd)!=nrow(tree$edge)) lwd<-rep(lwd,ceiling(nrow(tree$edge)/length(lwd))) if(type=="cladogram"||is.null(tree$edge.length)) tree<-compute.brlen(tree) ftype<-which(c("off","reg","b","i","bi")==ftype)-1 if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") # swap out "_" character for spaces (assumes _ is a place holder) tree$tip.label<-gsub("_"," ",tree$tip.label) if(is.null(mar)) mar=rep(0.1,4) n<-length(tree$tip.label) # set offset fudge (empirically determined) offsetFudge<-1.37 # reorder cladewise to assign tip positions cw<-reorder(tree,"cladewise") io<-reorder(tree,index.only=TRUE) lwd<-lwd[io] lty<-lty[io] y<-vector(length=n+cw$Nnode) y[cw$edge[cw$edge[,2]<=n,2]]<-1:n # reorder pruningwise for post-order traversal pw<-reorder(tree,"pruningwise") nn<-unique(pw$edge[,1]) # compute vertical position of each edge for(i in 1:length(nn)){ yy<-y[pw$edge[which(pw$edge[,1]==nn[i]),2]] y[nn[i]]<-mean(range(yy)) } # compute start & end points of each edge X<-nodeHeights(cw) if(is.null(xlim)){ pp<-par("pin")[1] sw<-fsize*(max(strwidth(cw$tip.label,units="inches")))+offsetFudge*fsize*strwidth("W",units="inches") alp<-optimize(function(a,H,sw,pp) (a*1.04*max(H)+sw-pp)^2,H=X,sw=sw,pp=pp,interval=c(0,1e6))$minimum xlim<-c(min(X),max(X)+sw/alp) } if(is.null(ylim)) ylim=c(1,max(y)) ## end preliminaries # open & size a new plot plot.new() par(mar=mar) if(is.null(offset)) offset<-0.2*lwd/3+0.2/3 plot.window(xlim=xlim,ylim=ylim) # plot edges for(i in 1:nrow(X)){ x<-NULL b<-y[cw$edge[i,1]] c<-X[i,1] d<-if(y[cw$edge[i,2]]>y[cw$edge[i,1]]) 1 else -1 xx<-X[i,2] yy<-y[cw$edge[i,2]] a<-(xx-c)/(yy-b)^2 curve(d*sqrt((x-c)/a)+b,from=X[i,1],to=X[i,2],add=TRUE,lwd=lwd[i],lty=lty[i]) } # plot tip labels for(i in 1:n) if(ftype) text(X[which(cw$edge[,2]==i),2],y[i],tree$tip.label[i],pos=4,offset=offset,font=ftype,cex=fsize) PP<-list(type=type,use.edge.length=if(type=="phylogram") TRUE else FALSE,node.pos=1, show.tip.label=if(ftype) TRUE else FALSE,show.node.label=FALSE,font=ftype,cex=fsize, adj=0,srt=0,no.margin=FALSE,label.offset=offset,x.lim=par()$usr[1:2],y.lim=par()$usr[3:4], direction=direction,tip.color="black",Ntip=length(cw$tip.label),Nnode=cw$Nnode,edge=cw$edge, xx=sapply(1:(length(cw$tip.label)+cw$Nnode),function(x,y,z) y[match(x,z)],y=X,z=cw$edge), yy=y) assign("last_plot.phylo",PP,envir=.PlotPhyloEnv) } } phytools/R/mcmcBM.R0000644000176200001440000001012011746536303013617 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/make.era.map.R0000644000176200001440000000364112564235635014735 0ustar liggesusers# function creates a mapped tree in which the mappings are based on eras defined by "limits" # written by Liam J. Revell 2011, 2013, 2015 make.era.map<-function(tree,limits,...){ ## set tolerance if(hasArg(tol)) tol<-list(...)$tol else tol<-1e-5 # check if(!inherits(tree,"phylo")) stop("tree should be object of class \"phylo\".") H<-nodeHeights(tree) # compute node heights if(limits[1]>tol){ warning("first value in limits should be zero.") limits[1]<-0 } while(limits[length(limits)]>max(H)){ warning("last value in limits should be less than the total tree height.") limits<-limits[1:(length(limits)-1)] } if(is.null(names(limits))) names(limits)<-1:length(limits) limits[length(limits)+1]<-max(H) maps<-list() # ok, now go through the edges of the tree for(i in 1:nrow(tree$edge)){ s<-1 while((H[i,1]>=(limits[s]-tol)&&H[i,1]limits[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/anc.trend.R0000644000176200001440000000534313201660663014343 0ustar liggesusers## this function estimates ancestral traits with a trend ## written by Liam J. Revell 2011, 2013, 2015, 2017 anc.trend<-function(tree,x,maxit=2000){ if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") ## check if tree is ultrametric if(is.ultrametric(tree)) cat("Warning: the trend model is generally non-identifiable for ultrametric trees.\n") # preliminaries # set global tol<-1e-8 # check to make sure that C will be non-singular if(any(tree$edge.length<=(10*.Machine$double.eps))) stop("some branch lengths are 0 or nearly zero") # compute C D<-dist.nodes(tree) ntips<-length(tree$tip.label) Cii<-D[ntips+1,] C<-D; C[,]<-0 counts<-vector() for(i in 1:nrow(D)) for(j in 1:ncol(D)) C[i,j]<-(Cii[i]+Cii[j]-D[i,j])/2 dimnames(C)[[1]][1:length(tree$tip)]<-tree$tip.label dimnames(C)[[2]][1:length(tree$tip)]<-tree$tip.label C<-C[c(1:ntips,(ntips+2):nrow(C)),c(1:ntips,(ntips+2):ncol(C))] # sort x by tree$tip.label x<-x[tree$tip.label] # function returns the negative log-likelihood likelihood<-function(theta,x,C){ a<-theta[1] u<-theta[2] sig2<-theta[3] y<-theta[4:length(theta)] logLik<-dmnorm(x=c(x,y),mean=(a+diag(C)*u), varcov=sig2*C,log=TRUE) return(-logLik) } # get reasonable starting values for the optimizer a<-mean(x) sig2<-var(x)/max(C) # perform ML optimization result<-optim(par=c(a,0,sig2,rep(a,tree$Nnode-1)),likelihood, x=x,C=C,method="L-BFGS-B",lower=c(-Inf,-Inf,tol,rep(-Inf,tree$Nnode-1)), control=list(maxit=maxit)) # return the result ace<-c(result$par[c(1,4:length(result$par))]) names(ace)<-c(as.character(tree$edge[1,1]), rownames(C)[(length(tree$tip.label)+1):nrow(C)]) obj<-list(ace=ace,mu=result$par[2],sig2=result$par[3], logL=-result$value,convergence=result$convergence, message=result$message) class(obj)<-"anc.trend" obj } ## print method for "anc.trend" ## written by Liam J. Revell 2015, 2017 print.anc.trend<-function(x,digits=6,printlen=NULL,...){ cat("Ancestral character estimates using anc.trend:\n") Nnode<-length(x$ace) if(is.null(printlen)||printlen>=Nnode) print(round(x$ace,digits)) else printDotDot(x$ace,digits,printlen) cat("\nParameter estimates:\n") cat(paste("\tmu",paste(rep(" ",digits),collapse=""),"\tsig^2", paste(rep(" ",max(digits-3,1)),collapse=""),"\tlog(L)\n",sep="")) cat(paste("\t",round(x$mu,digits),"\t",round(x$sig2,digits),"\t", round(x$logL,digits),"\n"),sep="") if(x$convergence==0) cat("\nR thinks it has converged.\n\n") else cat("\nR thinks function may not have converged.\n\n") } ## logLik method for "anc.trend" logLik.anc.trend<-function(object,...){ lik<-object$logL attr(lik,"df")<-length(object$ace)+2 lik } phytools/R/brownie.lite.R0000644000176200001440000001202013474625015015062 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 brownie.lite<-function(tree,x,maxit=2000,test="chisq",nsim=100,se=NULL,...){ if(hasArg(quiet)) quiet<-list(...)$quiet else quiet<-FALSE # some minor error checking if(!inherits(tree,"phylo")) stop("tree should be an object of class \"phylo\".") if(!inherits(tree,"simmap")) tree<-paintSubTree(tree,Ntip(tree)+1,"1") x<-matchDatatoTree(tree,x,"x") x<-x[tree$tip.label] if(!is.null(se)) se<-matchDatatoTree(tree,se,"se") 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(logL21&&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) 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) 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/MD50000644000176200001440000003415313502156773012462 0ustar liggesusers695480cb7d494457dbb4b62204907d17 *DESCRIPTION b15b39c12c29a79ca2d2d2724e7927f1 *NAMESPACE ec1dee2fc5dce861a4a896e13a10a9a5 *R/Dtest.R ee8f279c7051fd15e5f3b69a78b13d42 *R/add.everywhere.R 00125e455cd6c2a9a162f414c82b31d3 *R/add.random.R 30f5b1a58539aec4b00e952018bed1d8 *R/add.species.to.genus.R f0df86c98d2fd0c6d76f49ca3172d129 *R/allFurcTrees.R f1b04dd672234dbaa538ed81128c98d4 *R/anc.Bayes.R 5c884f89b5a0ef91a4136d3d171d91d9 *R/anc.ML.R 227c5163b6303989b36dbe9d50a7f53b *R/anc.trend.R a335897383764455737708ab6e1f7de0 *R/ancThresh.R bc3139a0d0a2b4bef405deaae471973c *R/backbonePhylo.R 878e6142121a5bb413a772d46681337c *R/bd.R 403f6c3609b1b82650665a0a04eeba87 *R/bmPlot.R 97f2cdd07a3595bb221fe3e8618e23c6 *R/branching.diffusion.R bed62ca73f3a69cbe975a89823254996 *R/brownie.lite.R d81faab1ac079af1ce2016b7e004bcce *R/brownieREML.R 4d4aa10c4b0d535c2cb7258bae32e929 *R/collapseTree.R 1001c3a0359677faf03cd3912d5aacd5 *R/compare.chronograms.R be284dbd922c8e640b06f22aeea30eb6 *R/consensus.edges.R 68a21244d41c2e62759f84fdef32eb10 *R/contMap.R ca84810482c72fff11b7cc05c1ca994a *R/cophylo.R ece9154811c9dafff59917deb9acab13 *R/cospeciation.R 5a714a5ff9ab89fc5d41ca1dbd38e3ce *R/ctt.R df6af26598144f917f3c3c0456e1b99a *R/densityMap.R 910df2ef42c9774fe20114acdff67479 *R/densityTree.R 4d0db3cfa22ee367a93e56c4459c0db4 *R/dotTree.R 70a8db5e7ea6c926c19e792168050491 *R/drop.tip.simmap.R bef780c00ce923e2306295f2dcd7bf8b *R/estDiversity.R 016534b15b0de0b6183169eb2358b998 *R/evol.rate.mcmc.R 868cab31eaeca1f3cf672e02fa12367a *R/evol.vcv.R 64dd4d0dffce8e81e10b7db2ed426a90 *R/evolvcv.lite.R 164c5aba763c4823fae1a2747cbbdde8 *R/exhaustiveMP.R 0c94431c709b011b1a19a5238b7a3352 *R/export.as.xml.R 735f273b2b5adb875a1b396477753c55 *R/fancyTree.R a1ebd3392c1313f685add9284121415c *R/fastAnc.R 1fb690b492fa00b02e86eaf49b5e48b6 *R/fastBM.R fd4043fe4370b493b19344fc752bcdf5 *R/fitBayes.R 2180796336a37244d12cd384282ae33b *R/fitDiversityModel.R f9d67f71229c0c64f2b994be6d41ca0b *R/fitMk.R 2e794826087ce98675c88ac57b1afa53 *R/fitPagel.R 8ff22a90b8b69a9bc17630ee4b985b4a *R/fitmultiMk.R e37b2515ecf333a5005acbf73e65c542 *R/fitpolyMk.R 14efc2d387e2360f9f37721f7a6b77a6 *R/locate.fossil.R ae5cd392abeb954e238903bbbfc01239 *R/locate.yeti.R e41cd28e97c6101b3e0c7c4b955abb1a *R/ls.consensus.R a8d77379cec7a4b884d530e1a11bdf8d *R/ltt.R d1669270abede61af74c637d742da68c *R/ltt95.R 07c37a4c09941dfa8088c4eb91ef5c4a *R/make.era.map.R 5763767db74598b3ebacf4ec23f10e51 *R/make.simmap.R b535cd4a22f407601477a0c787a8f869 *R/map.overlap.R 746ca01035baf52f94704cb916bd8e20 *R/map.to.singleton.R bf6c23b046ed30ee9e9183582aceb070 *R/mcmcBM.R 659b234e9ff4b00daa511a06f72d53d2 *R/mcmcBM.full.R 9fc1c1054aa693a9ad32044d21e9f8c4 *R/mcmcLambda.R 9ddc013feabf0450203bd3bfc9a526a2 *R/mcmcMk.R fc4256396ce1f5ddb507ba23411de327 *R/mrp.supertree.R 85d6d587e9ec2def6809ea805193bd79 *R/multi.mantel.R c3ef5e950b24d12acc2dee7d7e5d8a7a *R/multiRF.R 88f2251a19a0a6cff21d4c7e5fcb34ea *R/optim.phylo.ls.R 4251fbfa33b24cedd655a575878bee3a *R/paintSubTree.R 86f26b836e23ca7099d522bc2c8ab79c *R/pbtree.R a189790284945deed14a053d6e0c4c38 *R/pgls.Ives.R 0a3f71e1a3714c0fc5ed5fce53b9aa54 *R/phenogram.R 93cdbb83a29c009a6381af932cb78b87 *R/phyl.RMA.R 3cbec3ddb43718bf824e1b4b5b1bb92b *R/phyl.cca.R 2e0314f7d261000550c22b529bfb6908 *R/phyl.pairedttest.R f489cc46a3084533493e7d2dff93472e *R/phyl.pca.R 17d0e8f613fafc8cf7e0a719120dd9cd *R/phyl.resid.R 9265547de9fc901a0e0af7d58706b142 *R/phylANOVA.R 5f9b57848acd0490c9c4842be5d1e1be *R/phylo.heatmap.R 3fd0311c0d039889d2cca7347e3aaee8 *R/phylo.impute.R 57c437adb54a1e56d5144cea6ef1ab87 *R/phylo.to.map.R 5b170e562f81cdca01065b74999bb43d *R/phylomorphospace.R ba04cc646aeb4d77be7af8bf3b1f21ac *R/phylomorphospace3d.R 88e81eb2a2b9844e2694fb586524bfd8 *R/phylosig.R e33f55e3b5f7397f8c40678aee95569a *R/plotBranchbyTrait.R 6aed422c3ef54dd7180e45bd400245f0 *R/plotSimmap.R c9f1bff41eba65d96f74ad36910f0ca4 *R/plotTree.datamatrix.R a58e6ab65dca2e69dde3266c9d05e51e *R/plotTree.errorbars.R 9f36a04d3449c0f6a4e59b0154ee802a *R/plotTree.wBars.R bc0699095386afd623fa2385c68eb218 *R/project.phylomorphospace.R de8c966ad29e2ef0b7d6838e34bd8f81 *R/ratebystate.R c393517b7ce4f9ccd5a44dfa4d541583 *R/ratebytree.R 5f808f6878e031af61d4042b0dcbcb5e *R/rateshift.R 10aa4276f62187281eaa23d509df6f58 *R/read.newick.R 8d676810a59c68f20f5fc37bfe9b841a *R/read.simmap.R 782540c3e7967df671440da8834fbb5d *R/rerootingMethod.R ba26eefe861f14105c46ee13652c5b66 *R/resolveNodes.R 9bb4ea1e15eaeba8b3ea0f4ffc3c9255 *R/roundPhylogram.R d8a6bb753f6779a1dd49e769b18775a0 *R/sim.corrs.R 2d5ed29d27771157fd8c09a3d022f712 *R/sim.history.R f83f44a29df59f5ff489e0120c4c328b *R/sim.rates.R 5ae6a2a091d203ecc04ad6081e11293d *R/skewers.R 606ad5a902660277dce5f3ef7fed7461 *R/splitplotTree.R c8bfa07dd3238d97fcaafe5a369e5e89 *R/starTree.R 0567456c325cbac2c305158ffa05df91 *R/strahlerNumber.R dd4024c95dfabe33b4bf6a684472e9e1 *R/threshBayes.R 7e547545cd50de19581af1e1c179e967 *R/treeSlice.R 05ba7a1384dfa75921f349b50d07102a *R/utilities.R 1b4554bf48441cd340449ea0360bcbb8 *R/write.simmap.R 67b049f3e083513ff41ab9ca2bd940b5 *R/writeAncestors.R 65bf87a538f44806311e8914317b242c *R/writeNexus.R 3ab25de6b1e5d2b15860347db6d973d5 *data/anoletree.rda 0eb3bef3466bd6d264c669571621c2d1 *inst/CITATION 1628861f7a4f11cf2a38db0ab5e386e3 *man/Dtest.Rd a42234316b9c07cea61f6dc37aa855e1 *man/add.arrow.Rd 77fe3499abcd34af02fc571931597b79 *man/add.color.bar.Rd 4c61574818477466c1e568cc917535b5 *man/add.everywhere.Rd 0dad38ab36dfc6171120c7a224f7532a *man/add.random.Rd 54b5cce6e4c6f9cdcce89a82bdc7da36 *man/add.simmap.legend.Rd 59b392854e8c4ad3a3faa3c89a356193 *man/add.species.to.genus.Rd fa8cb1ee2a166a10032c51b707478324 *man/aic.w.Rd ddbaa1f624e77bd0b5c8be0fb07b407a *man/allFurcTrees.Rd 85936328bf79f82b91cf3bc471435be1 *man/anc.Bayes.Rd c2d5dd74076f99d94278763ed1b86859 *man/anc.ML.Rd 42b510e0e3d422a7f6444f6714ccb36b *man/anc.trend.Rd 9ac79b1dc9310be258548c6e8920fa2a *man/ancThresh.Rd 9ee43b3984459b93625cb3171605821e *man/anoletree.Rd ba7274925fef31f711d97b43ea309e57 *man/applyBranchLengths.Rd 9438d11405f55849b8b13173e0aa677f *man/as.multiPhylo.Rd 3e59cf4772028c0afc738956ca2d9d72 *man/ave.rates.Rd 68be8a968b68910972815c5e610818cd *man/averageTree.Rd df9eb1fbf7c6e779c99d61590ff5ec47 *man/bd.Rd 46db3b7e5e5467a50b1054dbf12fdff7 *man/bind.tip.Rd 03055c413de00dafb1073b21281d165a *man/bind.tree.simmap.Rd 917f71b6d2a4c9dd57327fa7e59b67af *man/bmPlot.Rd 6ac0b3fedd5b7d537dc29725f24c10b1 *man/branching.diffusion.Rd 3efad4c9f0e17f04e82100850115179b *man/brownie.lite.Rd 7d0707141e7f33fdefe95684828b3cd8 *man/brownieREML.Rd abeb701a5213e15d9e24816563654492 *man/cladelabels.Rd 382c028d6426220349650059ebe0c57a *man/collapse.to.star.Rd 0cc32904ef46fc7de7a6316c6ee2bca9 *man/collapseTree.Rd 1f9343d3cf45806772283782852d7e8e *man/compare.chronograms.Rd 8134029f04090ff83a7a8d4b3b92da56 *man/consensus.edges.Rd d3bb7e690b4111dfeb8a280c661381fe *man/contMap.Rd b92e5d59971e2644948b3144e42ca05e *man/cophylo.Rd 317b82dc60100850b36380cbc1bc0414 *man/cospeciation.Rd c6d0a78ac01eba19deae9beeceab701f *man/countSimmap.Rd 4670f04899c3e02fa4a604da67f67543 *man/ctt.Rd 44b463769214182e756294911bf65ff9 *man/density.multiSimmap.Rd 473862be45bc652c0389ec2c0754f473 *man/densityMap.Rd e37396af91b60fbd5d4761e632d6d230 *man/densityTree.Rd ae007bd9a1d1e3eb349e739bd3fd5bbc *man/describe.simmap.Rd 0ea6310926c9aee94ae48d102ddd5c6d *man/di2multi.simmap.Rd 1101b7f761cbfa5efa20a14bbd20f824 *man/dotTree.Rd c92235efc1cf6791a2871a0b59bf94b1 *man/drop.clade.Rd 139cf35fd81a07386ea5489a3c8a549e *man/drop.leaves.Rd 4dbacec8bf2b24739708948c5c6f2251 *man/drop.tip.contMap.Rd 0f4c4d6f030921fe8f033e54a5ba2226 *man/drop.tip.simmap.Rd ddcd0b3224754d09a211b6e3e8514819 *man/edgeProbs.Rd 6c00e1009e2f8fb0684f9169cc4347ab *man/estDiversity.Rd 209ae913c5034e5dba28fec8e53a8f54 *man/evol.rate.mcmc.Rd c5115b6ba849cafaeeedca0383611007 *man/evol.vcv.Rd 79889f5151dfcc5ff5637701f51310cb *man/evolvcv.lite.Rd 5e9db6f84e3c38a1c6b8811e19bee52b *man/exhaustiveMP.Rd 45729cc9dfdd0f4f158b82aba2e35797 *man/expand.clade.Rd 34ed62c06cd7594dd8cb095efdae57d2 *man/export.as.xml.Rd 811fa5bc82377a1e7667e2a1d883e731 *man/fancyTree.Rd 04d938b72c389510be41bf795826623f *man/fastAnc.Rd 4b4c57d045a77d6038356712712083d6 *man/fastBM.Rd a39df830514ea734e89fd17d9ab43a4a *man/fastMRCA.Rd 065cd067c18c357b94dca00464926e3a *man/findMRCA.Rd 86f237c32b1a3c7760abeab9da8a9c91 *man/fit.bd.Rd 49ed43ad08cbd76688cea935958535d2 *man/fitBayes.Rd 5b14d1e7dc563e1f12eb43bdaeea4c6d *man/fitDiversityModel.Rd 2c43b4dd1066850b63054306947daf2a *man/fitMk.Rd bea2ad13789c51fcb577038d9319a4aa *man/fitPagel.Rd ba9a3f05a5e21858e0b73853b71893f0 *man/force.ultrametric.Rd 1b8c690f7a0c981bdeb6023ceea6986d *man/gammatest.Rd 08ee1eea8d20f28764252086749d1128 *man/genSeq.Rd f11ab7e0202bf75021320a02c2b38eee *man/geo.legend.Rd 379801042e4427cb09999bbec9ab188a *man/get.treepos.Rd 6ca10ad3d8ae7823a3ebebeaaa903a26 *man/getCladesofSize.Rd 2c3e136e9127347805d388c859461c89 *man/getDescendants.Rd c12e715c595000142190c93a3f8abafb *man/getExtant.Rd e47f8181eef421508252f92e91591e36 *man/getSisters.Rd 50941930ec6026a6fb9b0020a7e9e3e3 *man/getStates.Rd 8b8dc22bbb4f27f8643c92132893220f *man/labelnodes.Rd 6646d5ead70ad65f04beea64d37d5517 *man/ladderize.simmap.Rd ff08765e41c8a2b1e3e042864c79de0c *man/lambda.transform.Rd 0f5026b76d6a327c9ca4119ed164b9d0 *man/likMlambda.Rd 6f8d9fe13ce8560d4e1dcfcabceb0cd9 *man/linklabels.Rd 568ff73eea0724e5a606bbac25adfc01 *man/locate.fossil.Rd 8fe45222d27403c659a50ee61f9b9b8a *man/locate.yeti.Rd ef1c244dadc67ee3408fc1a14f28247e *man/ls.tree.Rd 5b554c6a24195a95782b286350873fa3 *man/ltt.Rd 15505ac5c126b8aed12bcfdbc7df7fc5 *man/ltt95.Rd 591beece8fd31d854eefe71fa7e0d9c8 *man/make.era.map.Rd b3a57167a875f057cd79e32bcf69e700 *man/make.simmap.Rd 248ea743586822eece51923a29ad4586 *man/map.overlap.Rd 9d29a0b9779a409dafad71d9ca298a99 *man/map.to.singleton.Rd 7bc0bf4a400013d8506a144b98663d09 *man/mapped.states.Rd 5d30f9c9f2ce25e3a8b021655ed9b7fe *man/markChanges.Rd d4eedfe3675ef08a5529e4675a869cc2 *man/matchNodes.Rd 669bc2a3346a22f36e880ecec8e0166c *man/mergeMappedStates.Rd 0d7e957ddc867ece972e5070a09961a1 *man/midpoint.root.Rd c501fb94bba6f0abd92eb80204d60c73 *man/minRotate.Rd e0f089562d6459b9287215c5cbf73e66 *man/minSplit.Rd 68daddc0f7d38de5d9906dc75e06b8e8 *man/modified.Grafen.Rd 21b24064a70b57ac2d5d3e8ddd1dd85c *man/mrp.supertree.Rd c7d1907952e1fa3ba93de87b3eb0ecbb *man/multi.mantel.Rd cd0d9ef3074a74277c4dd5e0eba2cdda *man/multiC.Rd 3c941d1cbd831b77c07e82845a0bff29 *man/multiRF.Rd 771381f4158bb262fd0a9c7df8c33508 *man/nodeHeights.Rd b8061afef967e33d70e5646761eea00e *man/nodelabels.cophylo.Rd 8fadd2a9383b7352c41d749cf9e38495 *man/optim.phylo.ls.Rd 63d57fedac44429aea25ebf22f53c772 *man/orderMappedEdge.Rd 342aa020929fb830ffbfb869be45a526 *man/paintSubTree.Rd 4aec9a1fefe5f96ac6652a0e5fcc63eb *man/paste.tree.Rd f5c03b1a3eeba0ee10d31e06c0dbae64 *man/pbtree.Rd 15b7eb28339e9434bd8fcf3e493d943d *man/pgls.Ives.Rd 735e181c4a63b8a7888a137a6f08c163 *man/phenogram.Rd f333aaf7288b2a3a7bba9fdb23c41f74 *man/phyl.RMA.Rd 3d17ac3e055a980bca3c14b258fa47ec *man/phyl.cca.Rd b261584560bba587759477876797fa9d *man/phyl.pairedttest.Rd 7f2431f2523a95a75abda63cef313a5f *man/phyl.pca.Rd 38cdeda5e6c9e2cc9a3131ef1ee321ba *man/phyl.resid.Rd 3c99d938db7562590e8f8533c36ad407 *man/phyl.vcv.Rd defc24db768a211b0b6fadab410cab0a *man/phylANOVA.Rd b816f2e3fac3e259d0f1f57baf626678 *man/phylo.heatmap.Rd e3016d1a2cde7ba1beabc7d82c26742b *man/phylo.impute.Rd beaf00a5ab11a694db48329d6ad50498 *man/phylo.to.map.Rd 95aa8b498df77e1b9ea962512e42ce2f *man/phylo.toBackbone.Rd 3a1b3861ce38f29feca5081c7acc4908 *man/phyloDesign.Rd d9bbcd083d9fa1d46fdc60798a91124d *man/phylomorphospace.Rd b82dd727b2a6717a6fefab297a491ab3 *man/phylomorphospace3d.Rd 18a569e5bf535e689d85ded39eb166a6 *man/phylosig.Rd b1215539c6b3d560e8b0782d290197cc *man/phytools-package.Rd aecc4ccca42174f15c6280dbb5aa13fe *man/plot.backbonePhylo.Rd 674746269036e9bf5645e31bab29207e *man/plotBranchbyTrait.Rd cf7911a80ce4148ea610f1b9105a104f *man/plotSimmap.Rd b36ef27480457d0dc3f32c490e997a7d *man/plotThresh.Rd 7abaec7aa366e41647df0bf3073a36ef *man/plotTree.Rd d1d9b2dcbb4d27288aa2d926878076cd *man/plotTree.datamatrix.Rd 028fb0ca902c0cf9ffcdc47ad85da56e *man/plotTree.errorbars.Rd 43e41e68a0aa285d0f86f3e9e3cafcb5 *man/plotTree.wBars.Rd 9c8297109561037f067dd7d469f12acb *man/posterior.evolrate.Rd 9f409f4328ac4802d1700eec2233361b *man/posthoc.Rd 4bfa72a7ac47c3e185164f8c35dd5e13 *man/print.backbonePhylo.Rd 290d33851c41fa14071fbf4a03fdab8c *man/ratebystate.Rd 965d44fc3495f0a78625481c262b4d98 *man/ratebytree.Rd 1ec56f1e5610a932300c356e7b1242d1 *man/rateshift.Rd 83b256d15cc236468fc5a08c4c99e411 *man/read.newick.Rd 6cc642b69b90cc39e37a97e90792dc0f *man/read.simmap.Rd 0a719edd23de05fb878911f9cf05367e *man/reorder.backbonePhylo.Rd 1b9465c231435640da167fc86f10de30 *man/reorderSimmap.Rd 66b1bb2aaeca6af053fd7102d51bc93f *man/rep.phylo.Rd 3af87269dc3bca7472fdba1c179cbdba *man/reroot.Rd 66d53a0cc692e45faa83d918ea5af981 *man/rerootingMethod.Rd 7fb2034ee0d06ddd28baf54a19a5df31 *man/rescaleSimmap.Rd e136bc897dd8258ec0038da1fda579aa *man/resolveNode.Rd e1d563fcfc4085113c43b6191046463f *man/rotateNodes.Rd 62ccf8e731d76584828667850f3e4d5c *man/roundBranches.Rd 113dfd2e24ee88ec929f865a41b014ee *man/roundPhylogram.Rd 582c0539a965268cb3783ec1cfc69341 *man/rstate.Rd 56d1e0ab7594a041e03a96cf512b7c56 *man/sampleFrom.Rd 2c1a135a517a2a91c076b38a984200a5 *man/setMap.Rd cdb9901fa0e51ebb9ede03b79d569d43 *man/sim.corrs.Rd 71630091d59f0d68efbffe783f53ecf4 *man/sim.history.Rd d4619609a325632ef2c834f485c505b0 *man/sim.ratebystate.Rd 246a5aaa7168a0ff7cc9168d4395d4b5 *man/sim.rates.Rd e0716598bfe6497b75aac3a5de7d1d1a *man/skewers.Rd 8afbcc3a0809d9abc1337996402b395f *man/splitEdgeColor.Rd f0b7c55fe94d87a63fcc473557ba356c *man/splitTree.Rd c4c25d51cb5afc0a3ca9e8c50aa4f8a5 *man/splitplotTree.Rd e3ebd622b81458023c71dc8b846bc8bc *man/starTree.Rd e3cb564ff8ac467e211b63893e5bd8ab *man/strahlerNumber.Rd c0f81009eacfc0138a58487d766b3e6d *man/threshBayes.Rd 4c943bdc70f92faf2626a05b4dd5737a *man/threshDIC.Rd 1f469e57b425d3d1368c1b5a20f6677e *man/threshState.Rd 75b7d2745c01bd834c7b1b8523b9859e *man/to.matrix.Rd fd4b7e0ad5c598fbc1d33cd733a49164 *man/treeSlice.Rd 4f2a39ca94120586ad59463cc247bf83 *man/untangle.Rd 8698e88dd7441c86162d8ab4eddf3439 *man/vcvPhylo.Rd 58a800384eddd90f48ea26c6f515c1fb *man/write.simmap.Rd 9ae66799d04b136a287a1038d6f70fd7 *man/writeAncestors.Rd 81b95726f7c7c8b1308d35fc5a9e9d2e *man/writeNexus.Rd phytools/DESCRIPTION0000644000176200001440000000366613502156773013665 0ustar liggesusersPackage: phytools Version: 0.6-99 Date: 2019-6-18 Title: Phylogenetic Tools for Comparative Biology (and Other Things) Author: Liam J. Revell Maintainer: Liam J. Revell Depends: R (>= 3.2.0), ape (>= 4.0), maps Imports: animation, clusterGeneration, coda, combinat, expm, graphics, grDevices, gtools, MASS, methods, mnormt, nlme, numDeriv, phangorn (>= 2.3.1), plotrix, scatterplot3d, stats, utils Suggests: geiger, RColorBrewer, rgl ZipData: no Description: A wide range of functions for phylogenetic analysis. Functionality is concentrated in phylogenetic comparative biology, but also includes a diverse array of methods for visualizing, manipulating, reading or writing, and even inferring phylogenetic trees and data. Included among the functions in phylogenetic comparative biology are various for ancestral state reconstruction, model-fitting, simulation of phylogenies and data, and multivariate analysis. There are a broad range of plotting methods for phylogenies and comparative data which include, but are not restricted to, methods for mapping trait evolution on trees, for projecting trees into phenotypic space or a geographic map, and for visualizing correlated speciation between trees. Finally, there are a number of functions for reading, writing, analyzing, inferring, simulating, and manipulating phylogenetic trees and comparative data not covered by other packages. For instance, there are functions for randomly or non-randomly attaching species or clades to a phylogeny, for estimating supertrees or consensus phylogenies from a set, for simulating trees and phylogenetic data under a range of models, and for a wide variety of other manipulations and analyses that phylogenetic biologists might find useful in their research. License: GPL (>= 2) URL: http://github.com/liamrevell/phytools Packaged: 2019-06-18 12:09:52 UTC; liamj Repository: CRAN Date/Publication: 2019-06-18 12:50:03 UTC NeedsCompilation: no phytools/man/0000755000176200001440000000000013502152213012700 5ustar liggesusersphytools/man/markChanges.Rd0000644000176200001440000000207613501605303015421 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{ This function adds the reconstructed changes to a plotted tree with a stochastically mapped discrete character. } \value{ This function returns (invisibly) a matrix containing the x & y coordinates of the marked changes on the plotted tree. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{plotSimmap}} } \keyword{phylogenetics} \keyword{plotting} phytools/man/nodeHeights.Rd0000644000176200001440000000337612656150131015447 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 heighest tip which will be given by \code{max(nodeHeights(tree))}. Generally speaking, \code{nodeHeights} will be faster if the heights of all or a large proportion of nodes is needed, wherease \code{nodeheight} will be faster if the height of one or a small number of nodes are needed. } \value{ Either a matrix of the same dimensions as \code{tree$edge} containing the height above the root of each node in \code{edge} (for \code{nodeHeights}); or a single positive number (for \code{nodeheight}). } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{vcvPhylo}} } \examples{ tree<-rtree(10) X<-nodeHeights(tree) } \keyword{phylogenetics} \keyword{utilities} \keyword{comparative method} phytools/man/posterior.evolrate.Rd0000644000176200001440000000277512147207406017061 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 burnin excluded).} \item{tips}{list of stips in state sig(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{ This fucntion takes a phylogenetic tree, an average split position, and a raw MCMC output from \code{evol.rate.mcmc} and returns a posterior sample of evolutionary rates rootward (\eqn{\sigma(1)^2}) and tipward (\eqn{\sigma(2)^2}) from the average split. } \value{ A matrix containing the posterior sample of evolutionary rates and shift-points between rates. } \references{ Revell, L. J., D. L. Mahler, P. Peres-Neto, and B. D. Redelings (2012) A new method for identifying exceptional phenotypic diversification. \emph{Evolution}, \bold{66}, 135-146. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{evol.rate.mcmc}}, \code{\link{minSplit}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{bayesian} phytools/man/cophylo.Rd0000644000176200001440000000644313173402644014665 0ustar liggesusers\name{cophylo} \alias{cophylo} \alias{plot.cophylo} \title{Creates a co-phylogenetic plot} \usage{ cophylo(tr1, tr2, assoc=NULL, rotate=TRUE, ...) \method{plot}{cophylo}(x, ...) } \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{...}{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{ This function creates 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. } \details{ If no matrix of associations, \code{assoc}, is provided, then \code{cophylo} will look for exact matches of tip labels between trees. } \value{ An object of class \code{"cophylo"} which includes the following components or a pair of plotted facing phylogenies with links between tips as specified in \code{assoc}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{cophyloplot}}, \code{\link{plotSimmap}} } \examples{ tr1<-pbtree(n=26,tip.label=LETTERS) tr2<-pbtree(n=26,tip.label=sample(LETTERS)) obj<-cophylo(tr1,tr2) plot(obj) } \keyword{phylogenetics} \keyword{plotting} phytools/man/expand.clade.Rd0000644000176200001440000000302513115121314015513 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{ The purpose of this function is to compute a custom tip-spacing for users who want to expand or contract the tip-spacing of the descendant taxa from a given node or nodes. } \value{ The function returns an object of class \code{"expand.clade"} which consists of the (possibly re-ordered) tree and a numerical vector with the calculated tip spacing based on the expansion factor specified by the user. This object can be plotted using the S3 \code{plot} method for the object class; or it can be plotted simplying by calling a standard plotting function on the tree & tip spacings. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{plotting} phytools/man/brownie.lite.Rd0000644000176200001440000000662613474625703015623 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{ This function takes an object of class \code{"phylo"} or class \code{"simmap"} with a mapped binary or multistate trait (see \code{\link{read.simmap}}) and data for a single continuously valued character. It then fits the Brownian rate variation ("noncensored") model of O'Meara et al. (2006; \emph{Evolution}). This is also the basic model implemented in Brian O'Meara's \emph{Brownie} software. } \details{ 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 components: \item{sig2.single}{is the rate 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 from the multi-rate model.} \item{a.multiple}{is the estimated state at the root node for the multi-rate model.} \item{var.multiple}{\emph{p} x \emph{p} variance-covariance matrix for the \emph{p} rates - the square-roots of the diagonals should give the standard error for each rate.} \item{logL.multiple}{log-likelihood of the multi-rate model.} \item{k2}{number of parameters in the multi-rate model (\emph{p}+1).} \item{P.chisq}{P-value for a likelihood ratio test against the \eqn{\chi^2} distribution; or} \item{P.sim}{P-value for a likelihood ratio test agains a simulated null distribution.} \item{convergence}{logical value indicating if the likelihood optimization converged.} } \references{ O'Meara, B. C., C. Ane, M. J. Sanderson, and P. C. Wainwright. (2006) Testing for different rates of continuous trait evolution using likelihood. \emph{Evolution}, \bold{60}, 922--933. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{brownieREML}}, \code{\link{evol.vcv}}, \code{\link{ratebytree}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{maximum likelihood} phytools/man/add.simmap.legend.Rd0000644000176200001440000000257612464424310016461 0ustar liggesusers\name{add.simmap.legend} \alias{add.simmap.legend} \title{Add legend to stochastically mapped tree} \usage{ add.simmap.legend(leg=NULL, colors, prompt=TRUE, vertical=TRUE, ...) } \arguments{ \item{leg}{states for the discrete character in the order of \code{colors}.} \item{colors}{colors for the legend in the order of \code{leg}, or, if \code{leg=NULL}, named vector of colors in which \code{names(colors} are the states of the mapped discrete character.} \item{prompt}{logical value indicating whether the location of the legend should be obtained interactively (i.e., by clicking in the plotting area).} \item{vertical}{logical value indiciating whether to plot the legend vertically (if \code{TRUE}) or horizontally.} \item{...}{optional arguments including: \code{x} x-coordinate of the legend (if \code{prompt=FALSE}); \code{y} y-coordinate of the legend; and \code{shape} which can be \code{shape="square"}, the default, or \code{shape="circle"}.} } \description{ This function adds a legend (by default, interactively) to a plotted stochastic character mapped tree. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{plotSimmap}} } \keyword{phylogenetics} \keyword{plotting} \keyword{comparative method} phytools/man/ave.rates.Rd0000644000176200001440000000173612464424722015103 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}{rate 1.} \item{sig2}{rate 2.} \item{ave.shift}{average shift from all samples.} \item{showTree}{logical value indicating whether to plot the rate-stretched tree.} } \description{ Primarily used internally by \code{\link{posterior.evolrate}}. } \value{ A list of the rates. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{evol.rate.mcmc}}, \code{\link{minSplit}}, \code{\link{posterior.evolrate}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{bayesian} phytools/man/anc.Bayes.Rd0000644000176200001440000000500513201673647015011 0ustar liggesusers\name{anc.Bayes} \alias{anc.Bayes} \title{Bayesian ancestral character estimation} \usage{ anc.Bayes(tree, x, ngen=10000, control=list()) } \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{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.} } \description{ This function uses Bayesian MCMC to sample from the posterior distribution for the states at internal nodes in the tree. } \value{ 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{ The \code{print} method also returns (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). The object class \code{plot} method by default plots a likelihood profile from the MCMC. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ace}}, \code{\link{anc.ML}}, \code{\link{anc.trend}}, \code{\link{evol.rate.mcmc}}, \code{\link{fastAnc}} } \examples{ tree<-pbtree(n=50) x<-fastBM(tree,sig2=2) # simulate using fastBM obj<-anc.Bayes(tree,x,ngen=10000) # sample ancestral states print(obj,printlen=20) ## estimates } \keyword{phylogenetics} \keyword{comparative method} \keyword{bayesian} phytools/man/phylANOVA.Rd0000644000176200001440000000410413502027354014736 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{ 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). } \details{ This function uses a little bit of code from both \code{phy.anova} in the \emph{geiger} package and \code{\link{pairwise.t.test}}. } \value{ An object of class \code{"phylANOVA"} containing the following elements: \item{F}{F from observed data.} \item{Pf}{P-value for F from simulation.} \item{T}{matrix of t-values.} \item{Pt}{matrix of multiple test corrected P-values from posthoc t-tests.} } \references{ Garland, T., Jr., A. W. Dickerman, C. M. Janis, & J. A. Jones. (1993) Phylogenetic analysis of covariance by computer simulation. \emph{Systematic Biology}, \bold{42}, 265-292. Harmon, L. J., J. T. Weir, C. D. Brock, R. E. Glor, W. Challenger. (2008) GEIGER: investigating evolutionary radiations. \emph{Bioinformatics}, 24, 129-131. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{anova}}, \code{\link{pairwise.t.test}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{statistics} \keyword{least squares} \keyword{simulation} phytools/man/paste.tree.Rd0000644000176200001440000000152012464432435015254 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{ Primarily internal function for \code{\link{posterior.evolrate}}; can be used to graft a clade into a receptor tree, at the "sticky tip" labeled with \code{"NA"}. } \details{ The donor clade needs to have a root edge, even if it is zero length. } \value{ A tree. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \examples{ tr1<-rtree(10) tr2<-rtree(10) tr1$tip.label[1]<-"NA" tr2$root.edge<-0 tr3<-paste.tree(tr1,tr2) } \keyword{phylogenetics} \keyword{utilities} phytools/man/branching.diffusion.Rd0000644000176200001440000000274413502024265017123 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.} \item{b}{birthrate for branching process.} \item{time.stop}{number of generations to run.} \item{ylim}{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.)} } \description{ This function creates an animation of branching random diffusion (i.e., BM with speciation). } \value{ An animated plot and (optionally) a recorded video file. For animation to be recorded to file, the function requires the package \emph{animation} as well as a video renderer. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{bmPlot}}, \code{\link{fastBM}} } \keyword{phylogenetics} \keyword{animation} \keyword{plotting} \keyword{simulation} phytools/man/fitDiversityModel.Rd0000644000176200001440000000523213477250034016652 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{ This function fits a diversity-dependent phenotypic evolution model (based on Mahler et al. 2010). } \value{ An object of class \code{"fitDiversityModel"} consisting of the following components: \item{logL}{log-likelihood of the fitted model.} \item{sig0}{estimated starting value for the rate at the root of the tree.} \item{psi}{the estimated rate of change in the rate associated with the addition of a lineage.} \item{vcv}{a matrix with the variances and covariance of the estimated parameters (from the Hessian).} } \references{ Mahler, D. L, L. J. Revell, R. E. Glor, and J. B. Losos. 2010. Ecological opportunity and the rate of morphological evolution in the diversification of Greater Antillean anoles. \emph{Evolution}, \bold{64}, 2731-2745. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{brownie.lite}}, \code{\link{estDiversity}}, \code{\link{evol.rate.mcmc}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{maximum likelihood} phytools/man/getCladesofSize.Rd0000644000176200001440000000146412464426315016264 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. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{extract.clade}}, \code{\link{getDescendants}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/get.treepos.Rd0000644000176200001440000000210113477451443015442 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{ Both functions return the phylogenetic position of a mouse click on a plotted tree. \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. } \details{ Both functions are primarily meant to be used internally by other \emph{phytools} functions. } \value{ A list for \code{get.treepos} and a node number for \code{getnode}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{utilities} phytools/man/evol.rate.mcmc.Rd0000644000176200001440000000601513502031775016017 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{ 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. } \details{ Default values of \code{control} are given in Revell et al. (2012). } \value{ An object of class \code{"evol.rate.mcmc"} consisting of at least the following elements: \item{mcmc}{results from the MCMC run.} \item{tips}{list of stips in rate \eqn{\sigma(1)^2} for each sampled generation of MCMC (to polarize the rate shift).} } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Revell, L. J., D. L. Mahler, P. Peres-Neto, and B. D. Redelings. (2012) A new method for identifying exceptional phenotypic diversification. \emph{Evolution}, \bold{66}, 135-146. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{anc.Bayes}}, \code{\link{brownie.lite}}, \code{\link{evol.vcv}}, \code{\link{minSplit}}, \code{\link{posterior.evolrate}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{bayesian} phytools/man/plotTree.datamatrix.Rd0000644000176200001440000000171213240703504017127 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{ Function plots a phylogeny next to a matrix of discrete character data. } \value{ Invisibly returns a list containing the font size, a list of the colors used for each column of the plotted data matrix, and the x-coordinate of the rightmost edge of the matrix. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{dotTree}}, \code{\link{phylo.heatmap}} } \keyword{phylogenetics} \keyword{plotting} \keyword{comparative method} phytools/man/cospeciation.Rd0000644000176200001440000000375113066527020015664 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{ 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 no similarity between trees! } \value{ An object of class \code{"cospeciation"}, which includes the test-statistic, the null distribution, and a p-value for the test of the null hypothesis of no topological similarity between the two trees. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{cophylo}} } \keyword{phylogenetics} \keyword{plotting} phytools/man/locate.fossil.Rd0000644000176200001440000000352313353257506015756 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{ This function uses ML to place a fossil lineage into a tree using continuous traits. } \value{ Optimized tree as an object of class \code{"phylo"}. } \references{ Felsenstein, J. (1981) Maximum likelihood estimation of evolutionary trees from continuous characters. \emph{American Journal of Human Genetics}, 25, 471-492. Felsenstein, J. (2002) Quantitative characters, phylogenies, and morphometrics. In: MacLeod, N. and P. Forey (Eds.) \emph{Morphology, Shape and Phylogeny} (pp. 27-44). Taylor and Francis, London. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Revell, L. J., D. L. Mahler, R. G. Reynolds, and G. J. Slater. (2015) Placing cryptic, recently extinct, or hypothesized taxa into an ultrametric phylogeny using continuous, character data: A case study with the lizard \emph{Anolis roosevelti}. \emph{Evolution}, \bold{69}, 1027-1035. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{inference} \keyword{maximum likelihood} phytools/man/averageTree.Rd0000644000176200001440000000240113066526150015430 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{ These functions compute average trees or consensus trees by various criteria. } \value{ An object of class \code{"phylo"} with edge lengths. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} phytools/man/countSimmap.Rd0000644000176200001440000000341213474632465015512 0ustar liggesusers\name{countSimmap} \alias{countSimmap} \title{Counts the number of character changes on a object of class "simmap" or "multiSimmap"} \usage{ countSimmap(tree, states=NULL, message=TRUE) } \arguments{ \item{tree}{an object of class \code{"simmap"} or \code{"multiSimmap"}.} \item{states}{optional argument with the states for the mapped character. If not provided, these will be computed from the tree. This is useful if averaging across many trees, some of which may lack certain states.} \item{message}{optional logical argument indicating whether or not to return an informative message about the function output.} } \description{ 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{ tree<-pbtree(n=100,scale=1) Q<-matrix(c(-2,1,1,1,-2,1,1,1,-2),3,3) colnames(Q)<-rownames(Q)<-c("A","B","C") mtree<-sim.history(tree,Q) countSimmap(mtree,states=rownames(Q)) } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/ls.tree.Rd0000644000176200001440000000131413502025677014557 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. Generally intended as a function to be used internally by \code{\link{optim.phylo.ls}}. } \value{ A tree with branch lengths. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{inference} \keyword{least squares} phytools/man/writeAncestors.Rd0000644000176200001440000000327113066534572016227 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-percent 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-percent confidence intervals.} } \description{ This function writes a tree to file with ancestral character states and (optionally) 95-percent confidence intervals stored as node value.. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \value{ A file, string, or vector of strings. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ace}}, \code{\link{fastAnc}}, \code{\link{write.tree}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{input/output} phytools/man/findMRCA.Rd0000644000176200001440000000354413476612177014604 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{ This function returns node number of the most recent common ancestor of a set of taxa. If \code{tips=NULL} the function is redundant with \code{\link{mrca}} (for \code{type="node"}) or \code{\link{vcv.phylo}}, but much slower (for \code{type="height"}). } \details{ 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 \code{phytools 0.5-66} forward \code{findMRCA} uses \code{\link{getMRCA}} in the \emph{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 to ensure backward compatibility. } \value{ The node number of the MRCA, or a matrix of node numbers (if \code{tips==NULL}) - for \code{type="node"}; or the height of the MRCA, or a matrix of heights (if \code{tips==NULL}) - for \code{type="height"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{findMRCA}}, \code{\link{mrca}} } \examples{ tree<-pbtree(n=20) anc<-findMRCA(tree,c("t1","t10","t15")) } \keyword{phylogenetics} \keyword{utilities} phytools/man/anc.trend.Rd0000644000176200001440000000337013201722504015050 0ustar liggesusers\name{anc.trend} \alias{anc.trend} \title{Ancestral character estimation with a trend} \usage{ anc.trend(tree, x, maxit=2000) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{x}{a vector of tip values for species; \code{names(x)} should be the species names.} \item{maxit}{an optional integer value indicating the maximum number of iterations for optimization.} } \description{ This function estimates the evolutionary parameters and ancestral states for Brownian evolution with directional trend. } \details{ Note that this will generally only work and produce sensible results for a phylogeny with some non-contemporary tips (i.e., a tree with some fossil species). The function uses \code{\link{optim}} with \code{method=} \code{"L-BFGS-B"}; however optimization is only constrained for the \code{sig2} which must be >0. } \value{ An object of class \code{"anc.trend"} with the following components: \item{ace}{a vector with the ancestral states.} \item{mu}{a trend parameter per unit time.} \item{sig2}{the variance of the BM process.} \item{logL}{the log-likelihood.} \item{convergence}{the value of \code{$convergence} returned by \code{optim()} (0 is good).} } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ace}}, \code{\link{anc.Bayes}}, \code{\link{anc.ML}}, \code{\link{optim}} } \examples{ tree<-rtree(20) x<-fastBM(tree,mu=2) # simulate using fastBM with a trend (m!=0) anc.trend(tree,x) # fit model & estimate ancestral states } \keyword{phylogenetics} \keyword{comparative method} \keyword{maximum likelihood} phytools/man/threshState.Rd0000644000176200001440000000165512464427133015510 0ustar liggesusers\name{threshState} \alias{threshState} \title{Computes value for a threshold character from a liability and thresholds} \usage{ threshState(x, thresholds) } \arguments{ \item{x}{liability.} \item{thresholds}{a named vector containing the thresholds.} } \description{ Primarily to be used internally by \code{\link{ancThresh}}; can also be used to simulate threshold traits. } \value{ A discrete character value. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Revell, L. J. (2014) Ancestral character estimation under the threshold model from quantitative genetics. \emph{Evolution}, bold{68}, 743-759. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ancThresh}}, \code{\link{threshDIC}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{simulation} phytools/man/phyl.vcv.Rd0000644000176200001440000000250013502026725014745 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{ Primarily an internal function for \code{\link{phyl.pca}}; this can be used to compute the phylogenetic trait variance-covariance matrix given a phylogenetic VCV, lambda, and a data matrix. This function should not be confused with \code{\link{vcv.phylo}} in the \emph{ape} package (although one of the objects returned is the output of \code{vcv.phylo}). } \value{ A list containing three elements, as follows: \code{C}, the matrix \code{vcv.phylo} transformed by \code{lambda}; \code{R}, the among trait variance-covariance matrix for the data in \code{X}; and \code{alpha}, a vector of ancestral states at the root node of the tree. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{statistics} \keyword{utilities} phytools/man/rateshift.Rd0000644000176200001440000000435413066533644015206 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{ Function finds the location of one or more rate shifts. \code{likSurface.rateshift} plots the likelihood surface (which is sometimes quite rugged). } \value{ A fitted object of class \code{"rateshift"}, or, in the case of \code{likSurface.rateshift}, a likelihood surface for the shift points. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{brownie.lite}} } \keyword{phylogenetics} \keyword{comparative method} phytools/man/bd.Rd0000644000176200001440000000171413474623427013601 0ustar liggesusers\name{bd} \alias{bd} \title{Convert object of class "birthdeath" to raw birth & death rates} \usage{ bd(x) } \arguments{ \item{x}{object of class \code{"birthdeath"}.} } \description{ This function converts an object of class \code{"birthdeath"} to a vector with the ML birth & death rates. Note that this is somewhat unecessary as \emph{phytools} now contains functions to fit birth-death and pure-birth diversification models from trees (\code{\link{fit.bd}} and \code{\link{fit.yule}}) that also take into account incomplete sampling fraction. } \value{ A vector. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{birthdeath}}, \code{\link{fit.bd}}, \code{\link{fit.yule}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{utilities} phytools/man/orderMappedEdge.Rd0000644000176200001440000000240712517456367016247 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{ This function takes a modified object of class \code{"multiPhylo"} with a mapped discrete character (e.g., see \code{\link{read.simmap}} and sorts the columns of each \code{tree$mapped.edge} 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{ A modified object of class \code{"phylo"} or \code{"multiPhylo"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/splitTree.Rd0000644000176200001440000000170612464427305015163 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{ Primarily an internal function for \code{\link{posterior.evolrate}}, this function splits the tree at a given point, and returns the two subtrees as an object of class \code{"multiPhylo"}. } \details{ Probably do not use this unless you can figure out what you are doing. } \value{ Two trees in a list. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/writeNexus.Rd0000644000176200001440000000140212464426713015360 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{ This function writes one or multiple phylogenetic trees to file in NEXUS format. Redundant with \code{ape::\link{write.nexus}}. } \value{ Trees written to file. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{write.simmap}}, \code{\link{write.nexus}} } \keyword{phylogenetics} \keyword{input/output} phytools/man/bmPlot.Rd0000644000176200001440000000652513502024021014427 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).} \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{ This function conducts 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. The function will first rescale and round the branch lengths to integer length, if they are not already in integer values. If integer branch lengths are provided, the user should also set \code{ngen} to be equal to the total height of the tree in generations (and thus avoid rescaling). For \code{type="threshold"} the visualization is of the threshold model (Felsenstein 2012), in which the evolving character is liability and the segments of evolution are colored by their value for the threshold trait. If \code{type="threshold"} is used, the function requires at least one addition input: \code{thresholds}, a vector containing the ordered thresholds between states. The user can also provide the colors for plotting in \code{colors}. Note that one more color than threshold should be provided as one threshold implies two states; two thresholds, three states; etc. If no value for \code{colors} is provided, the function will recycle a set of four colors up to the number of times required by \code{thresholds}. Finally, the optional argument \code{return.tree=TRUE} will tell the function to return a list with the tip and note states and an object of class \code{"phylo"} with (for \code{type="threshold"}), the state for the threshold model through time mapped on the branches of the tree in discrete time. } \value{ This function conducts and plots discrete time Brownian simulation and returns a vector containing the simulated states at internal nodes and tips of the tree. It also returns, by default (although this can be turned off) a tree with the branch lengths in discrete time and with a mapped discrete character (for \code{type="threshold"}). } \references{ Felsenstein, J. 2012. A comparative method for both discrete and continuous characters using the threshold model. \emph{American Naturalist}, \bold{179}, 145-156. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Revell, L. J. (2014) Ancestral character estimation under the threshold model from quantitative genetics. \emph{Evolution}, bold{68}, 743-759. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{fastBM}}, \code{\link{pbtree}}, \code{\link{phenogram}}, \code{\link{threshBayes}} } \examples{ # plot BM simulation on 20 taxon tree tree<-pbtree(n=20) x<-bmPlot(tree) # plot simulation of a threshold character tree<-pbtree(n=20) x<-bmPlot(tree,type="threshold",thresholds=c(0,1,2)) } \keyword{phylogenetics} \keyword{plotting} \keyword{simulation} phytools/man/splitplotTree.Rd0000644000176200001440000000321313201721503016040 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 "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{ Function plots a tree in two columns or windows. } \value{ Plots a tree. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{plotTree}}, \code{\link{plotSimmap}} } \keyword{phylogenetics} \keyword{plotting} phytools/man/applyBranchLengths.Rd0000644000176200001440000000150213502023475016764 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{ This function applies the set of branch lengths from a reference tree to a target tree while reconciling any mappings (as in \code{\link{read.simmap}}) with the new branch lengths. } \value{ An object of class \code{"phylo"} or \code{"simmap"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/getSisters.Rd0000644000176200001440000000241513477452222015343 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{ This function takes a tree and node or tip number of label and returns the number or label of the sister or sisters to that node or tip. } \value{ If \code{mode="number"} this function returns an integer or vector containing the node number of numbers of the sister node or tip. If \code{mode="label"} then this function returns a list containing up to two vectors: one for the node numbers of labels of sister nodes (if applicable); and the other containing the tip labels of the sister tips. } \seealso{ \code{\link{getDescendants}}, \code{\link{Siblings}} } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/add.species.to.genus.Rd0000644000176200001440000000552413502031543017122 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. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{add.random}}, \code{\link{bind.tip}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/ladderize.simmap.Rd0000644000176200001440000000147313477463102016441 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{ This function 'ladderizes' an object of class \code{"phylo"} with a mapped discrete character. For more information see \code{\link{ladderize}}. } \value{ A ladderized object of class \code{"simmap"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{make.simmap}}, \code{\link{ladderize}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/getExtant.Rd0000644000176200001440000000222313502025301015126 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{ 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. \code{getExtinct} returns the complement. } \value{ A vector with the tip names of extant or extinct species in the tree. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{nodeHeights}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/add.arrow.Rd0000644000176200001440000000304213201722271015052 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. If \code{tree=NULL} then the tip or node number 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{ This function adds an arrow to a plotted tree. } \details{ This function presently works for radial (\code{type="fan"}) and right facing square phylograms (\code{type=} \code{"phylogram"}). Trees can be plotted using phytools function \code{plotTree}, \code{plotSimmap}, \code{contMap}, \code{densityMap}, and ape S3 method \code{plot.phylo}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{nodelabels}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/minRotate.Rd0000644000176200001440000000352513501606170015143 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{ This function 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 functions are designed primarily to be used internally by other \emph{phytools} functions and particularly by \code{\link{phylo.to.map}} (in the case of \code{minRotate}) and by \code{\link{cophylo}} (in the case of \code{tipRotate}). } \value{ A node-rotated object of class \code{"phylo"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/plotTree.Rd0000644000176200001440000000174212464431027015002 0ustar liggesusers\name{plotTree} \alias{plotTree} \title{Plots rooted phylogenetic tree} \usage{ plotTree(tree, ...) } \arguments{ \item{tree}{a phylogenetic tree in \code{"phylo"} format; or multiple trees as an object of class \code{"multiPhylo"}.} \item{...}{optional arguments.} } \description{ This function plots a rooted phylogram. Arguments in \code{...} are passed to \code{\link{plotSimmap}}, with the exception of optional argument \code{color} which is used to determine the plotted color of the branch lengths of the tree. } \value{ This function plots a rooted phylogram. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{plot.phylo}}, \code{\link{plotSimmap}} } \examples{ tree<-pbtree(n=25) plotTree(tree,color="blue",ftype="i") } \keyword{phylogenetics} \keyword{plotting} phytools/man/phyloDesign.Rd0000644000176200001440000000171312517471505015473 0ustar liggesusers\name{phyloDesign} \alias{phyloDesign} \title{Compute design matrix for least squares analyses} \usage{ phyloDesign(tree) } \arguments{ \item{tree}{phylogenetic tree.} } \description{ Primarily an internal function for \code{\link{optim.phylo.ls}}, this function creates a design matrix for least squares phylogenetic analysis. } \details{ This function returns a matrix containing the edges in the tree (in columns) and pairs of tip node numbers (in rows). Values in the matrix are either \code{1} if the edge is on the shortest path between the two tips; and \code{0} otherwise. Probably do not use unless you know what you're doing. } \value{ A matrix. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{inference} \keyword{least squares} phytools/man/sim.rates.Rd0000644000176200001440000000357513061416345015117 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 alpha parameter.} \item{theta}{single value or vector of values of the OU theta parameter.} \item{a0}{optional value of the root state. Defaults to zero.} \item{...}{optional arguments.} } \description{ 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. } \details{ \code{multiOU} uses a difference equation approximation of the OU process. } \value{ A vector (for \code{nsim=1}) or matrix containing the tip states for the \code{n} species in the tree. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{fastBM}}, \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{sim.history}} } \keyword{phylogenetics} \keyword{simulation} \keyword{comparative method} phytools/man/rotateNodes.Rd0000644000176200001440000000403112760461620015466 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. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/ltt95.Rd0000644000176200001440000000403113500171624014153 0ustar liggesusers\name{ltt95} \alias{ltt95} \alias{plot.ltt95} \title{Creates a (1-\eqn{\alpha})-percent 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})-percent 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})-percent CI by various methods. } \details{ This function creates a plot and invisibly returns an object of class \code{"ltt95"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ltt}} } \keyword{phylogenetics} \keyword{plotting} \keyword{diversification analysis} phytools/man/contMap.Rd0000644000176200001440000001054013474632226014607 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 detemines the line width of the plotted error bars.} } \description{ 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). \code{errorbar.contMap} adds error bars to an existing plot. } \value{ Plots a tree. An object of class \code{"contMap"} is returned invisibly. \code{errorbar.contMap} adds colorful error bars to a plotted tree. } \references{ Felsenstein, J. 1985. Phylogenies and the comparative method. \emph{American Naturalist}, \bold{125}, 1-15. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Revell, L. J. 2013. Two new graphical methods for mapping trait evolution on phylogenies. \emph{Methods in Ecology and Evolution}, \bold{4}, 754-759. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{anc.ML}}, \code{\link{densityMap}}, \code{\link{fastAnc}}, \code{\link{plotSimmap}} } \keyword{phylogenetics} \keyword{plotting} \keyword{comparative method} phytools/man/di2multi.simmap.Rd0000644000176200001440000000423413475346750016234 0ustar liggesusers\name{di2multi.simmap} \alias{di2multi.simmap} \alias{multi2di.simmap} \alias{di2multi.multiSimmap} \alias{multi2di.multiSimmap} \alias{di2multi.contMap} \alias{multi2di.contMap} \alias{di2multi.densityMap} \alias{multi2di.densityMap} \title{Collapse or resolve polytomies in a tree with a character painted on the edges} \usage{ \method{di2multi}{simmap}(phy, ...) \method{multi2di}{simmap}(phy, ...) \method{di2multi}{multiSimmap}(phy, ...) \method{multi2di}{multiSimmap}(phy, ...) \method{di2multi}{contMap}(phy, ...) \method{multi2di}{contMap}(phy, ...) \method{di2multi}{densityMap}(phy, ...) \method{multi2di}{densityMap}(phy, ...) } \arguments{ \item{phy}{object of class \code{"simmap"}, \code{"multiSimmap"}, \code{"contMap"}, or \code{"densityMap"} containing a character mapped onto the edges of a tree or set of trees.} \item{...}{optional arguments: \code{tol}, length below which edges should be treated as having zero length; and \code{random}, specifying whether to resolve polytomies randomly (if \code{TRUE}) or in the order in which they are encountered.} } \description{ The method \code{di2multi} collapses branches of zero length (or, more specifically, branches with length shorter than \code{tol}) to create a polytomy in a tree or set of trees. The method \code{multi2di} resolves polytomies by adding branches of zero length (while preserving the mappings) in a tree or set of trees. } \details{ This methods should theoretically behave similarly to \code{\link{di2multi}} and \code{\link{multi2di}} from the \emph{ape} package. } \value{ An object of class \code{"simmap"}, \code{"multiSimmap"}, \code{"contMap"}, or \code{"densityMap"}, depending on the class of \code{phy}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{contMap}}, \code{\link{densityMap}}, \code{\link{di2multi}}, \code{\link{make.simmap}}, \code{\link{multi2di}}, \code{\link{read.simmap}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{utilities} phytools/man/linklabels.Rd0000644000176200001440000000250213071021460015306 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{ Function adds tip labels to a plotted tree by drawing curved, bent, or straight linking lines. } \details{ The idea underlying this function is that the user should first plot the tree without tip labels, but set the area of the plotting device to be sufficient to accommodate the tip labels once they have been added. The function then can be called to add tip labels connected by linking lines to the tips of the plotted tree. } \value{ This function annotates a plot. } \seealso{ \code{\link{cladelabels}}, \code{\link{nodelabels}}, \code{\link{tiplabels}} } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{plotting} \keyword{utilities} phytools/man/phyl.cca.Rd0000644000176200001440000000345613201657212014705 0ustar liggesusers\name{phyl.cca} \alias{phyl.cca} \title{Phylogenetic canonical correlation analysis} \usage{ phyl.cca(tree, X, Y, lambda=1.0, fixed=TRUE) } \arguments{ \item{tree}{a phylogenetic tree in \code{"phylo"} format.} \item{X}{a data matrix with traits in columns.} \item{Y}{data matrix with traits in columns, to be correlated with \code{X}.} \item{lambda}{optionally, a (fixed) value for \code{lambda}.} \item{fixed}{optionally, a logical value indicating whether or not to estimate \code{lambda} using likelihood.} } \description{ This function performs phylogenetic canonical correlation analysis (e.g., Revell & Harrison 2008; \emph{Bioinformatics}). } \details{ (Optional) joint optimization of \eqn{\lambda} is performed using \code{\link{optimize}} on the interval (0,1). } \value{ An object of class \code{"phyl.cca"} containing the following components: \item{cor}{canonical correlations.} \item{xcoef}{coefficients for the canonical variables for \code{X}.} \item{ycoef}{coefficients for the canonical variables for \code{Y}.} \item{xscores}{matrix with the canonical scores for \code{X}.} \item{yscores}{matrix with the canonical scores for \code{Y}.} \item{chisq}{vector of \eqn{\chi^2} values.} \item{p}{P-values for the hypothesis test that the \emph{i}th and all subsequent correlations are zero.} } \references{ Revell, L. J., Harrison, A. S. (2008) PCCA: A program for phylogenetic canonical correlation analysis. \emph{Bioinformatics}, \bold{24}, 1018-1020. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{phyl.pca}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{statistics} phytools/man/sim.corrs.Rd0000644000176200001440000000307213201721576015122 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}{is a phylogenetic tree in 'phylo' format; or a modified 'phylo' tree with a mapped discrete character.} \item{vcv}{is a square covariance matrix or named list of matrices (one for each mapped state on the tree).} \item{anc}{optional vector of values for the root state.} \item{internal}{logical value indicating whether to return states at internal nodes.} } \description{ This function conducts BM simulation on a tree with multiple rates and/or multiple evolutionary correlations between characters. If \code{vcv} is a single matrix, instead of a list of matrices, \code{sim.corrs} will simulate multivariate BM with a single rate matrix. } \value{ A matrix containing the multivariate tip states for the \code{n} species in the tree (and nodes if \code{internal=} \code{TRUE}). } \references{ Revell, L. J., and D. C. Collar (2009) Phylogenetic analysis of the evolutionary correlation using likelihood. \emph{Evolution}, \bold{63}, 1090-1100. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{fastBM}}, \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{sim.history}}, \code{\link{sim.rates}} } \keyword{phylogenetics} \keyword{simulation} \keyword{comparative method} phytools/man/mrp.supertree.Rd0000644000176200001440000000620113502032126016001 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 \emph{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 \emph{phangorn} package (Schliep, 2011) for optimization, and \code{\link{prop.part}} from \emph{ape} package (Paradis et al. 2004). See \code{\link{pratchet}} or \code{\link{optim.parsimony}} for optional arguments, which vary slightly depending on the method. All optional arguments of these methods are available to the user with one exception. The argument \code{tree} in \code{\link{optim.parsimony}} is supplied instead as \code{start}. In addition to being an object of class \code{"phylo"}, \code{start} can also be assigned the string values of \code{"NJ"} or \code{"random"}, in which case either a neighbor-joining or random tree will be used as the starting tree for optimization. The function \code{compute.mr} computes the matrix-representation matrix of the input trees. It is used internally by \code{mrp.supertree}, but can also be used to export an object that can be written to file if desired. } \value{ An object of class \code{"phylo"} or \code{"multiPhylo"} that is the MP or set of MP MRP trees. In the case of \code{compute.mr}, an object of class \code{"phyDat"} or a matrix. } \references{ Baum, B. R., (1992) Combining trees as a way of combining data sets for phylogenetic inference, and the desirability of combining gene trees. \emph{Taxon}, \bold{41}, 3-10. Felsenstein, J. (2004) \emph{Inferring Phylogenies}. Sinauer. Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290. Ragan, M. A. (1992) Phylogenetic inference based on matrix representation of trees. \emph{Molecular Phylogenetics and Evolution}, \emph{1}, 53-58. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Schliep, K. P. (2011) phangorn: phylogenetic analysis in R. \emph{Bioinformatics}, \bold{27}, 592-593. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{exhaustiveMP}}, \code{\link{optim.parsimony}}, \code{\link{pratchet}} } \keyword{phylogenetics} \keyword{inference} \keyword{parsimony} \keyword{supertree} phytools/man/ltt.Rd0000644000176200001440000000652613420510175014007 0ustar liggesusers\name{ltt} \alias{ltt} \alias{gtt} \alias{mccr} \title{Creates lineage-through-time plot (including extinct lineages)} \usage{ ltt(tree, plot=TRUE, drop.extinct=FALSE, log.lineages=TRUE, gamma=TRUE, ...) gtt(tree, n=100, ...) mccr(obj, rho=1, nsim=100, ...) } \arguments{ \item{tree}{is a phylogenetic tree in \code{"phylo"} format, or an object of class \code{"multiPhylo"} containing a list of phylogenetic trees.} \item{plot}{a logical value indicating whether or not to create LTT plot.} \item{drop.extinct}{logical value indicating whether or not to drop extinct tips from the tree.} \item{log.lineages}{logical value indicating whether LTT plot should be on log-linear (default) or linear-linear scale.} \item{gamma}{logical value indicating whether or not to compute eqn{gamma} from Pybus & Harvey (2000; \emph{Proc. Roy. Soc. B}).} \item{n}{for \code{gtt} the number of time intervals to use to track \eqn{\gamma} through time.} \item{obj}{for \code{mccr} an object of class \code{"ltt"}.} \item{rho}{for \code{mccr} sampling fraction.} \item{nsim}{for \code{mccr} number of simulations to use for the MCCR test.} \item{...}{other arguments to be passed to plotting methods. See \code{\link{plot.default}}.} } \description{ The function \code{ltt} computes LTT plot with extant and extinct lineages, and optionally conducts \eqn{\gamma}-test of Pybus & Harvey (2000). The object returned by \code{ltt} can be plotted or re-plotted using \code{\link{plot}}. The function \code{gtt} computes the value of Pybus & Harvey's \eqn{\gamma} statistic through time by slice 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. } \details{ Although it is calculated here, it's unclear how to interpret the \eqn{\gamma}-statistic if not all the tips in the tree are contemporaneous. } \value{ \code{ltt} returns an object of class \code{"ltt"} which includes the following components: \item{times}{a vector of branching times.} \item{ltt}{a vector of linages.} \item{gamma}{optionally, a value for the gamma-statistic.} \item{p}{two-tailed P-value for the gamma-test.} If \code{tree} is an object of class \code{"multiPhylo"}, then an object of class \code{"multiLtt"} is returned consisting of a list of object of class \code{"ltt"}. \code{gtt} returns an object of class \code{"gtt"}. \code{mccr} returns of object of class \code{"mccr"}. } \references{ Pybus, O. G., and P. H. Harvey (2000) Testing macro-evolutionary models using incomplete molecular phylogenies. \emph{Proc. R. Soc. Lond. B}, \bold{267}, 2267-2272. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{gammatest}}, \code{\link{ltt95}} } \examples{ trees<-pbtree(n=100,scale=100,nsim=10) obj<-ltt(trees,plot=FALSE) plot(obj,log="y",log.lineages=FALSE,main="lineage through time plots") tree<-pbtree(b=1,d=0.25,t=4) obj<-ltt(tree,gamma=FALSE) obj } \keyword{phylogenetics} \keyword{plotting} \keyword{diversification analysis} phytools/man/fit.bd.Rd0000644000176200001440000000440213476613555014362 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{ 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. \code{fit.yule} returns an object of class \code{"fit.yule"}. } \references{ Nee, S., May, R. M. and Harvey, P. H. (1994) The reconstructed evolutionary process. \emph{Philosophical Transactions of the Royal Society of London B}, \bold{344}, 305-311. Stadler, T. (2012) How can we improve the accuracy of macroevolutionary rate estimates? \emph{Systematic Biology}, \bold{62}, 321-329. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{birthdeath}} } \examples{ \dontrun{ ## fit BD & Yule models bd<-fit.bd(tree,rho=0.8) yule<-fit.yule(tree,rho=0.8) ## compare fitted models AIC(yule,bd) } } \keyword{comparative methods} \keyword{diversification} \keyword{phylogenetics} phytools/man/force.ultrametric.Rd0000644000176200001440000000306713477252236016646 0ustar liggesusers\name{force.ultrametric} \alias{force.ultrametric} \title{Forces 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 phangorn function \code{\link{nnls.tree}} internally), or \code{"extend"}.} } \description{ This function forces an object of class \code{"phylo"} to be ultrametric. This is achieved either by using \code{\link{nnls.tree}} from the phangorn package to compute the set of edge lengths that result in a minimized sum-of-squares distance between the patristic distance of the output and input trees (\code{method="nnls"}); or by simply extending all the external edges of the tree to match the external edge with the greatest total height (\code{method="extend"}). Note that neither of these should be treated as formal statistical methods for inferring an ultrametric tree. Rather, this method can be deployed when a genuinely ultrametric tree read from file fails \code{\link{is.ultrametric}} for reasons of numerical precision. } \value{ An ultrametric tree in an object of class \code{"phylo"}. } \seealso{ \code{\link{is.ultrametric}}, \code{\link{nnls.tree}} } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{statistics} \keyword{utilities} phytools/man/phylo.to.map.Rd0000644000176200001440000000614413502027650015532 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 "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{ \code{phylo.to.map} creates an object of class \code{"phylo.to.map"} and (optionally) plots that object. \code{plot.phylo.to.map} plots an object of class \code{"phylo.to.map"} in which the tips of the tree point to coordinates on a geographic map. } \value{ \code{phylo.to.map} creates an object of class \code{"phylo.to.map"} and (if \code{plot=TRUE}) plots a phylogeny projected onto a geographic map. \code{plot.phylo.to.map} plots on object of class \code{"phylo.to.map"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{plotting} phytools/man/fancyTree.Rd0000644000176200001440000001303613502025116015113 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{ This function plots different types of phylogenetic trees. If \code{type="extinction"} (or any unambiguous abbreviation) the function will plot a tree in which branches preceding the MRCA of all extant taxa and branches leading only to extnct lineages are plotted with dashed red lines. If \code{type="traitgram3d"} the function will plot a three dimensional traitgram (that is, a projection of the tree into three dimensional morphospace where two dimensions are the phenotypic trait and the third axis is time since the root). In this case, the additional argument \code{X}, a matrix containing the tip values of all species (with species IDs as row names) should be supplied. Optionally, the user can also supply the matrix \code{A}, which contains the ancestral states in the tree with rows labeled by node number. If \code{type="droptip"} the function will create a two panel figure in which the first panel is the tree with lineages to be pruned highlighted; and the second panel is the pruned tree. In this case, the additional argument \code{tip}, the tip name or vector of tip names to be dropped, must be supplied. If \code{type="densitymap"}, a posterior probability density "heat-map" is created based on a set of trees in a \code{"multiPhylo"} object containing a binary [0,1] mapped character. (See \code{\link{densityMap}} for additional optional arguments if \code{type="densitymap"}.) This option just calls the function \code{\link{densityMap}} internally. 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"}. Much like \code{type="densitymap"}, this option just calls the function \code{\link{contMap}} internally. If \code{type="phenogram95"} a 95-percent phenogram is plotted using transparency to visualize uncertainty at ancestral nodes and along branches. Most of the options of \code{\link{phenogram}} are available. Finally, if \code{type="scattergram"} a phylogenetic scatter plot matrix containing \code{\link{contMap}} style trees on the diagonal and \code{\link{phylomorphospace}} plots in non-diagonal panels is produced. For this type a trait matrix \code{X} must also be supplied. The only additional arguments available for this type are \code{ftype}, \code{fsize}, \code{colors}, and \code{label}. (See \code{\link{phylomorphospace}} for details on how these arguments should be used.) This function calls \code{\link{phyloScattergram}} (which is also now exported to the name space) internally. In addition to creating a plot, \code{phyloScattergram} also returns an object of class \code{"phyloScattergram"} which can be replotted using different options if desired. Presently only \code{type="traitgram3d"} uses the list \code{control} which can be supplied the same set of control parameters as \code{\link{phylomorphospace3d}}, as well as the control parameter \code{maxit} which will be passed to \code{\link{anc.ML}}. Finally, the optional argument \code{hold} will be passed to multiple methods if supplied. It is a logical value that indicates whether or not the output to the graphical device should be held using \code{\link{dev.hold}} before plotting (defaults to \code{hold=TRUE}). } \value{ This function plots different types of phylogenetic trees. For \code{type="droptip"} the function also returns the pruned tree. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{contMap}}, \code{\link{densityMap}}, \code{\link{drop.tip}}, \code{\link{phenogram}}, \code{\link{phylomorphospace3d}}, \code{\link{plot.phylo}}, \code{\link{plotSimmap}} } \examples{ # plot tree with extinction set.seed(10) tree<-pbtree(b=1,d=0.4,t=4) fancyTree(tree,type="extinction") \dontrun{ # plot 3D traitgram tree<-pbtree(n=50,scale=10) Y<-sim.corrs(tree,vcv=matrix(c(1,0.75,0.75,1),2,2)) fancyTree(tree,type="traitgram3d",X=Y,control=list(spin=FALSE)) # plot with internal nodes from simulation Y<-sim.corrs(tree,vcv=matrix(c(1,0.75,0.75,1),2,2),internal=TRUE) B<-Y[length(tree$tip)+1:tree$Nnode,]; Y<-Y[1:length(tree$tip),] fancyTree(tree,type="traitgram3d",X=Y,A=B,control=list(simple.axes=TRUE,spin=FALSE)) } # plot with dropped tips tree<-pbtree(n=30) tips<-sample(tree$tip.label)[1:10] pruned<-fancyTree(tree,type="droptip",tip=tips) \dontrun{ # plot 95-percent CI phenogram tree<-pbtree(n=30) x<-fastBM(tree) fancyTree(tree,type="phenogram95",x=x) } } \keyword{phylogenetics} \keyword{plotting} \keyword{utilities} phytools/man/reroot.Rd0000644000176200001440000000344713201721554014517 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{ This function 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 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 phytools>=0.4-47. } \value{ A phylogenetic tree in \code{"phylo"} format. } \references{ Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{splitTree}}, \code{\link{paste.tree}}, \code{\link{root}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/labelnodes.Rd0000644000176200001440000000226613066536233015322 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{ Function adds node labels to a plotted object of class \code{"phylo"}. The nodes to be labels can be selected interactively by the user (i.e., by clicking on the corresponding nodes of the plotted tree). } \value{ Invisibly returns a vector of the node indices for the labeled nodes. } \seealso{ \code{\link{cladelabels}}, \code{\link{nodelabels}} } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{plotting} \keyword{utilities} phytools/man/multi.mantel.Rd0000644000176200001440000000416613501607337015622 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}{tne number of permutations used.} } \details{ Printing the object to screen will result in a summary of the analysis similar to \code{summary.lm}, but with p-values derived from Mantel permutations. Methods \code{residuals} and \code{fitted} can be used to return residual and fitted matrices, respectively. } \references{ Mantel, N. (1967) The detection of disease clustering and a generalized regression approach. \emph{Cancer Research}, \bold{27}, 209--220. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{comparative method} \keyword{statistics} \keyword{least squares} phytools/man/map.overlap.Rd0000644000176200001440000000404013501563133015417 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{ This function computes the fraction of a stochastic character mapping that is shared between two differently mapped trees. In \code{map.overlap} it will compute a single quantity giving the overall similarity of the maps, consequently this measure only makes sense of some or all of the states are shared between the two mapped tress. In \code{Map.Overlap} what is computed instead is a matrix in which the rows correspond to the states observed in \code{tree1} and the columns give the states for \code{tree2}, with the numerical values of the matrix showing the total overlap between each pair of mapped states on the two trees. } \value{ A numerical value on the interval (0, 1), for \code{map.overlap}; or a matrix whose elements should sum to 1.0 (\code{Map.Overlap}). } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{make.simmap}}, \code{\link{read.simmap}} } \keyword{phylogenetics} \keyword{comparative method} phytools/man/roundPhylogram.Rd0000644000176200001440000000333113066534146016217 0ustar liggesusers\name{roundPhylogram} \alias{roundPhylogram} \title{Plot a round phylogram} \usage{ roundPhylogram(tree, fsize=1.0, ftype="reg", lwd=2, mar=NULL, offset=NULL, direction="rightwards", type="phylogram", xlim=NULL, ylim=NULL, ...) } \arguments{ \item{tree}{an object of class "phylo" or "multiPhylo" containing one or multiple phylogenies.} \item{fsize}{relative font size for tip labels.} \item{ftype}{font type - options are \code{"reg"}, \code{"i"} (italics), \code{"b"} (bold), or \code{"bi"} (bold-italics).} \item{lwd}{line width for plotting.} \item{mar}{vector containing the margins for the plot to be passed to \code{\link{par}}. If not specified, the default margins are [0.1,0.1,0.1,0.1].} \item{offset}{offset for the tip labels.} \item{direction}{plotting direction. Only the option \code{direction="rightwards"} is presently supported.} \item{type}{plot type. Can be \code{"phylogram"} or \code{"cladogram"}. If \code{type="cladogram"} then the branch lengths are not necessary (and, indeed, are not used).} \item{xlim}{x-limits for the plot.} \item{ylim}{y-limits for the plot.} \item{...}{optional arguments.} } \description{ Function plots one or multiple round phylograms. } \details{ The underscore character \code{"_"} is automatically swapped for a space in tip labels, as in \code{\link{plotSimmap}}. } \value{ Plots a tree. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{plotSimmap}}, \code{\link{plotTree}} } \keyword{phylogenetics} \keyword{plotting} \keyword{comparative method} phytools/man/edgeProbs.Rd0000644000176200001440000000242712620733055015117 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{ This function computes the relative frequencies of character state changes along edges from a sample of stochastically mapped character histories. This function assumes that all trees in the sample differ only in their mapped histories & not at all in topology or branch lengths. Note that it only asks whether the starting and ending states of the edge differ in a particular way, and thus ignores multiple-hits along a single edge. } \value{ The object that is returned is a matrix with the state changes & the relative frequency of each state change. Rows are in the order of the matrix \code{edge} for any of the mapped trees. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{plotSimmap}} } \keyword{phylogenetics} \keyword{plotting} phytools/man/skewers.Rd0000644000176200001440000000364112464427353014676 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{ This function performs the random skewers matrix comparison method of Cheverud (1996; also see Cheverud & Marroig 2007 for more details). In addition, it includes a more robust hypothesis test in which random covariance matrices are simulated under a variety of models, and then the mean correlation between response vectors to random skewers are computed. } \value{ A list with the following components: \item{r}{mean random skewers correlation.} \item{p}{p-value from simulation.} } \references{ Cheverud, J. M. (1996) Quantitative genetic analysis of cranial morphology in the cotton-top (Saguinus oedipus) and saddle-back (S. fuscicollis) tamarins. \emph{J. Evol. Biol.}, \bold{9}, 5--42. Cheverud, J. M. & Marroig, G. (2007) Comparing covariance matrices: Random skewers method compared to the common principal components model. \emph{Genetics & Molecular Biology}, \bold{30}, 461--469. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{comparative method} \keyword{statistics} phytools/man/add.color.bar.Rd0000644000176200001440000000350413066536410015613 0ustar liggesusers\name{add.color.bar} \alias{add.color.bar} \title{Add color bar to a plot} \usage{ add.color.bar(leg, cols, title=NULL, lims=c(0,1), digits=1, prompt=TRUE, lwd=4, outline=TRUE, ...) } \arguments{ \item{leg}{numerical value for the length of the legend.} \item{cols}{colors for the legend.} \item{title}{text to plot above the bar.} \item{lims}{range for the bar.} \item{digits}{digits for plotted numbers.} \item{prompt}{logical value indicating whether the location of the legend should be obtained interactively.} \item{lwd}{width of the plotted bar.} \item{outline}{logical value indicated whether or not to outline the plotted color bar with a 1 pt line.} \item{...}{optional arguments including: \code{x} x-coordinate of the legend (if \code{prompt=FALSE}); \code{y} y-coordinate of the legend; \code{subtitle} optional legend subtitle; \code{direction} direction of the color bar (i.e., increase from left to right or from right to left); and \code{fsize}, font size for the legend text.} } \description{ This function adds a color bar to a plot created by \code{\link{plotBranchbyTrait}}. A color bar can be added by clicking on a location within the plot (when \code{prompt=TRUE}) or by setting \code{prompt=FALSE} and supplying x & y coordinates for the object. This function is also used internally by S3 methods \code{\link{plot.contMap}} and \code{\link{plot.densityMap}}, as well as by \code{\link{errorbar.contMap}}. } \references{ Revell, L. J. (2013) Two new graphical methods for mapping trait evolution on phylogenies. \emph{Methods in Ecology and Evolution}, \bold{4}, 754-759. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{contMap}}, \code{\link{densityMap}}, \code{\link{errorbar.contMap}}, \code{\link{plotBranchbyTrait}} } \keyword{phylogenetics} \keyword{plotting} \keyword{comparative method} phytools/man/add.everywhere.Rd0000644000176200001440000000161213066523303016112 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. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \seealso{ \code{\link{allFurcTrees}}, \code{\link{exhaustiveMP}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/make.era.map.Rd0000644000176200001440000000226113501560411015431 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{ This function creates a temporal map on the tree based on \code{limits} provided by the user. } \value{ An object of class \code{"simmap"} with the specified eras mapped as different regimes. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{plotSimmap}} } \examples{ tree<-pbtree(n=1000,scale=100) tree<-make.era.map(tree,c(0,25,50,75)) plot(tree,ftype="off",lwd=1) } \keyword{phylogenetics} \keyword{comparative method} phytools/man/mergeMappedStates.Rd0000644000176200001440000000213513502026154016606 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{ This function merges two or mapped states on the tree to get one new state. For instance, one could merge the states \code{"C"}, \code{"G"}, and \code{"T"} and define the new the state \code{"not-A"}. } \value{ An object of class \code{"simmap"} or \code{"multiSimmap"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{make.simmap}}, \code{\link{read.simmap}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{simulation} \keyword{bayesian} \keyword{utilities} phytools/man/sampleFrom.Rd0000644000176200001440000000155612464427604015322 0ustar liggesusers\name{sampleFrom} \alias{sampleFrom} \title{Sample from a set of distributions} \usage{ sampleFrom(xbar=0, xvar=1, n=1, randn=NULL, type="norm") } \arguments{ \item{xbar}{a named vector of means.} \item{xvar}{a named vector of variances.} \item{n}{a vector containing the sample sizes of each species.} \item{randn}{a range of sample sizes are to be random.} \item{type}{\code{"norm"} is the only distribution implemented so far.} } \description{ Function samples from a set of normal distributions with parameters given in \code{xbar} and \code{xvar}. } \value{ A vector, with labels. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{statistics} phytools/man/starTree.Rd0000644000176200001440000000137612464427273015010 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{ This function creates a star phylogeny. } \details{ Creates a star phylogeny with (optionally) user specified branch lengths. } \value{ An object of class \code{"phylo"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{stree}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/treeSlice.Rd0000644000176200001440000000322713072304613015117 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{ 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 "ape" package. It can also be used to crop the terminal fraction of a tree for \code{orientation="rootwards"}. } \value{ An object of class \code{"phylo"} or \code{"multiPhylo"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{extract.clade}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/ctt.Rd0000644000176200001440000000274713211273567014010 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{ This function generates a 'changes through time' plot in the style of a lineage-through-time (LTT) plot. It shows the mean rate or the mean number of changes per unit time from a set of stochastic character map trees. } \value{ An object of class \code{"ctt"} or \code{"multiCtt"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ltt}} } \keyword{phylogenetics} \keyword{plotting} \keyword{comparative method} \keyword{discrete character} phytools/man/plotTree.errorbars.Rd0000644000176200001440000000220313066533510016772 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. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ltt}}, \code{\link{plotTree}} } \keyword{phylogenetics} \keyword{plotting} phytools/man/fitBayes.Rd0000644000176200001440000000472013201657614014753 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{ This function uses Bayesian MCMC to sample terminal states (species means) as well as evolutionary parameters. } \value{ An object of class \code{"fitBayes"} that includes a matrix (\code{mcmc}) with a number of rows \code{ngen/control$sample+1} containing the posterior sample and likelihoods. Matrix columns are labeled by species (for species means and variances), or by the corresponding evolutionary parameter. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Revell, L. J. and R. G. Reynolds. (2012) A new Bayesian method for fitting evolutionary models to comparative data with intraspecific variation. \emph{Evolution}, 66, 2697-2707. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{anc.Bayes}}, \code{\link{brownie.lite}}, \code{\link{evol.rate.mcmc}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{bayesian} phytools/man/nodelabels.cophylo.Rd0000644000176200001440000000264612612446276017003 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. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{cophylo}}, \code{\link{edgelabels}}, \code{\link{nodelabels}}, \code{\link{tiplabels}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/locate.yeti.Rd0000644000176200001440000000346713353257555015444 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{ This function uses ML (or REML) to place a recently extinct, cryptic, or missing taxon on an ultrametric (i.e., time-calibrated) phylogeny. } \value{ Optimized tree as an object of class \code{"phylo"}. } \references{ Felsenstein, J. (1981) Maximum likelihood estimation of evolutionary trees from continuous characters. \emph{American Journal of Human Genetics}, 25, 471-492. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Revell, L. J., D. L. Mahler, R. G. Reynolds, and G. J. Slater. (2015) Placing cryptic, recently extinct, or hypothesized taxa into an ultrametric phylogeny using continuous, character data: A case study with the lizard \emph{Anolis roosevelti}. \emph{Evolution}, \bold{69}, 1027-1035. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{inference} \keyword{maximum likelihood} phytools/man/fastAnc.Rd0000644000176200001440000000410413476610057014564 0ustar liggesusers\name{fastAnc} \alias{fastAnc} \title{(Reasonably) fast estimation of ML ancestral states} \usage{ fastAnc(tree, x, vars=FALSE, CI=FALSE, ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{x}{a vector of tip values for species; \code{names(x)} should be the species names.} \item{vars}{a logical value indicating whether or not to compute variances on the ancestral state estimates. Variances are based on Equation (6) of Rohlf (2001).} \item{CI}{a logical value indicating whether or not to compute 95-percent confidence intervals on state estimates.} \item{...}{optional arguments. Presently this consists of \code{anc.states}, a named vector containing ancestral states to fix. Names should correspond to node numbers in the input tree.} } \description{ This function performs (reasonably) fast estimation of the ML ancestral states for a continuous trait by taking advantage of the fact that the state computed for the root node of the tree during Felsenstein's (1985) contrasts algorithm is also the MLE of the root node. Thus, the function re-roots the tree at all internal nodes and computes the contrasts state at the root each time. The function can also (optionally) compute variances or 95-percent confidence intervals on the estimates. } \value{ An object of class \code{"fastAnc"} consisting of either: a named vector containing the states at internal nodes - names are node numbers; or a list containing ancestral state estimates (\code{ace}), variances on the estimates (\code{var}), and/or 95-percent confidence intervals (\code{CI95}). } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ace}}, \code{\link{anc.Bayes}}, \code{\link{anc.ML}}, \code{\link{pic}} } \examples{ tree<-pbtree(n=50) x<-fastBM(tree) # simulate using fastBM fastAnc(tree,x) # estimate states } \keyword{phylogenetics} \keyword{comparative method} \keyword{maximum likelihood} phytools/man/drop.leaves.Rd0000644000176200001440000000141712464425503015427 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. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/plotSimmap.Rd0000644000176200001440000001213113100245200015303 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=1.0, xlim=NULL, ylim=NULL, nodes="intermediate", tips=NULL, maxY=NULL, hold=TRUE, split.vertical=FALSE, lend=2, asp=NA, plot=TRUE) \method{plot}{simmap}(x, ...) \method{plot}{multiSimmap}(x, ...) } \arguments{ \item{tree}{a modified object of class "phylo" or "multiPhylo" containing a stochastic mapping or set of mappings (e.g., see \code{\link{read.simmap}} & \code{\link{make.simmap}}).} \item{colors}{a vector with names translating the mapped states to colors - see \code{Examples}.} \item{fsize}{relative font size for tip labels.} \item{ftype}{font type - options are \code{"reg"}, \code{"i"} (italics), \code{"b"} (bold), or \code{"bi"} (bold-italics).} \item{lwd}{line width for plotting.} \item{pts}{logical value indicating whether or not to plot filled circles at each vertex of the tree, as well as at transition points between mapped states. Default is \code{FALSE}.} \item{node.numbers}{a logical value indicating whether or not node numbers should be plotted.} \item{mar}{vector containing the margins for the plot to be passed to \code{\link{par}}. If not specified, the default margins are [0.1,0.1,0.1,0.1].} \item{add}{a logical value indicating whether or not to add the plotted tree to the current plot (\code{TRUE}) or create a new plot (\code{FALSE}, the default).} \item{offset}{offset for the tip labels. Primarily to be used internally by \code{\link{densityMap}}.} \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 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{plot}{logical value indicating whether or not to actually plot the tree. (See equivalent argument in \code{\link{plot.phylo}}.)} \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{ Function plots one or multiple stochastic character mapped trees. } \details{ The underscore character \code{"_"} is automatically swapped for a space in tip labels, as in \code{\link{plot.phylo}}. } \value{ Plots a tree. } \references{ Bollback, J. P. (2006) Stochastic character mapping of discrete traits on phylogenies. \emph{BMC Bioinformatics}, \bold{7}, 88. Felsenstein, J. (2004) \emph{Inferring Phylogenies}. Sinauer. Huelsenbeck, J. P., R. Neilsen, and J. P. Bollback. (2003) Stochastic mapping of morphological characters. \emph{Systematic Biology}, \bold{52}, 131-138. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{densityMap}}, \code{\link{make.simmap}}, \code{\link{read.simmap}} } \examples{ # simulate a mapped tree Q<-matrix(c(-2,1,1,1,-2,1,1,1,-2),3,3) rownames(Q)<-colnames(Q)<-letters[1:3] tree<-sim.history(pbtree(n=100,scale=1),Q) cols<-setNames(c("blue","red","green"),letters[1:3]) # plot the mapping plot(tree,cols,ftype="i",fsize=0.7) } \keyword{phylogenetics} \keyword{plotting} \keyword{comparative method} phytools/man/strahlerNumber.Rd0000644000176200001440000000243212464427254016205 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{ The function \code{strahlerNumber} computes the Strahler number of all nodes and tips in the tree. For more information about Strahler numbers see \url{http://en.wikipedia.org/wiki/Strahler_number}. The function \code{extract.strahlerNumber} extracts all of the most inclusive clades of Strahler number \code{i}. } \value{ Either a vector with the Strahler number for each tip and internal node; or (for \code{extract.strahlerNumber} the set of (most inclusive) subtrees with Strahler number \code{i} as an object of class \code{"multiPhylo"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/read.simmap.Rd0000644000176200001440000000544312464430640015406 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.} \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). Uses some modified code from \code{\link{read.nexus}} from the "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{ A modified object of class \code{"phylo"} (or list of 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.} } \references{ Bollback, J. P. (2006) Stochastic character mapping of discrete traits on phylogenies. \emph{BMC Bioinformatics}, \bold{7}, 88. Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{brownie.lite}}, \code{\link{evol.vcv}}, \code{\link{read.tree}}, \code{\link{read.nexus}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{input/output} phytools/man/evol.vcv.Rd0000644000176200001440000000600313475631714014751 0ustar liggesusers\name{evol.vcv} \alias{evol.vcv} \title{Likelihood test for variation in the evolutionary variance-covariance matrix} \usage{ evol.vcv(tree, X, maxit=2000, vars=FALSE, ...) } \arguments{ \item{tree}{an object of class \code{"simmap"}. If \code{tree} is an object of class \code{"phylo"} then a simple multivariate Brownian motion model will be fit to the data in \code{X}.} \item{X}{an \code{n} x \code{m} matrix of tip values for \code{m} continuously valued traits in \code{n} species - row names should be species names.} \item{maxit}{an optional integer value indicating the maximum number of iterations for optimization. This quantity may need to be increased for difficult optimizations.} \item{vars}{an optional logical value indicating whether or not to estimate the variances of the parameter estimates from the Hessian matrix.} \item{...}{optional arguments.} } \description{ This function takes an object of class \code{"simmap"} with a mapped binary or multistate trait and data for an arbitrary number of continuously valued character. It then fits the multiple evolutionary variance-covariance matrix (rate matrix) model of Revell & Collar (2009; \emph{Evolution}). } \details{ This function performs optimization by maximizing the likelihood with respect to the Cholesky matrices using \code{\link{optim}}. Optimization is by \code{method="Nelder-Mead"}. Using box constraints does not make sense here as they would be applied to the Cholesky matrix rather than the target parameters. Users may have to increase \code{maxit} for large trees and/or more than two traits. } \value{ An object of class \code{"evol.vcv"} with the following components: \item{R.single}{vcv matrix for the single rate matrix model.} \item{vars.single}{optionally, a matrix containing the variances of the elements of \code{R.single}.} \item{logL1}{log-likelihood for single matrix model.} \item{k1}{number of parameters in the single marix model.} \item{R.multiple}{\code{m} x \code{m} x \code{p} array containing the \code{p} estimated vcv matrices for the \code{p} regimes painted on the tree.} \item{vars.multiple}{optionally, an array containing the variances of the parameter estimates in \code{R.multiple}.} \item{logL.multiple}{log-likelihood of the multi-matrix model.} \item{k2}{number of parameters estimated in this model.} \item{P.chisq}{P-value of the \eqn{\chi^2} test on the likelihood ratio.} \item{convergence}{logical value indicating whether or not the optimization has converged.} } \references{ Revell, L. J., and D. C. Collar (2009) Phylogenetic analysis of the evolutionary correlation using likelihood. \emph{Evolution}, \bold{63}, 1090-1100. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{evol.rate.mcmc}}, \code{\link{brownie.lite}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{maximum likelihood} phytools/man/phylo.impute.Rd0000644000176200001440000000325013440253075015635 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 imputation using Maximum Likelihood. } \details{ This function performs phylogenetic imputation in which the evolution of the characters in \code{X} is assumed to have occured by correlation multivariate Brownian motion. Missing values are imputed by maximizing their likelihood jointly with the parameters of the Brownian model. The function \code{\link{evol.vcv}} is used internally to compute the likelihood. Note that the \emph{Rphylopars} package (\url{https://CRAN.R-project.org/package=Rphylopars}) also does phylogenetic imputation for multivariate trait data and it seems to be much faster. } \value{ An object of class \code{"phylo.impute"} consisting of a complete data frame with missing values imputed. Since optimization is performed numerically using likelihood, a summary of the optimization can be seen by evaluating \code{attr(object,"optim")}, in which \code{object} is of class \code{"phylo.impute"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{evol.vcv}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{continuous character} phytools/man/print.backbonePhylo.Rd0000644000176200001440000000125112464430742017115 0ustar liggesusers\name{print.backbonePhylo} \alias{print.backbonePhylo} \title{Print method for backbone phylogeny} \usage{ \method{print}{backbonePhylo}(x, ...) } \arguments{ \item{x}{an object of class \code{"backbonePhylo"}.} \item{...}{optional arguments.} } \description{ Print method for an object of class \code{"backbonePhylo"}. } \value{ Prints to screen. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{phylo.toBackbone}} } \keyword{phylogenetics} \keyword{plotting} phytools/man/posthoc.Rd0000644000176200001440000000076513161575070014671 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{ This function conducts posthoc test. } \details{ So far is only implemented for object class \code{"ratebytree"}. } \value{ An object. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ratebytree}} } \keyword{statistics} phytools/man/bind.tip.Rd0000644000176200001440000000317613365674035014727 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{below} 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{below} node to add 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{ Functions adds a new tip to the tree. 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. } \details{ Wrapper function for 'ape' \code{\link{bind.tree}}. Note that \code{interactive=TRUE} works only for right-facing phylograms. } \value{ An object of class \code{"phylo"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/ancThresh.Rd0000644000176200001440000000623113201660041015107 0ustar liggesusers\name{ancThresh} \alias{ancThresh} \title{Ancestral character estimation under the threshold model using Bayesian MCMC} \usage{ ancThresh(tree, x, ngen=10000, 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 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{ \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, although with other components. } \references{ Felsenstein, J. (2012) A comparative method for both discrete and continuous characters using the threshold model. \emph{American Naturalist}, \bold{179}, 145-156. Revell, L. J. (2014) Ancestral character estimation under the threshold model from quantitative genetics. \emph{Evolution}, bold{68}, 743-759. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{anc.Bayes}}, \code{\link{threshBayes}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{bayesian} phytools/man/matchNodes.Rd0000644000176200001440000000410313501605523015260 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 umambiguous shortening of \code{"descendants"} or \code{"distances"} is also permitted.} \item{...}{optional arguments which may or may not be used depending on the value of \code{method}. \code{tol} is a tolerance value for the difference from exact matching that is allowed for \code{method="distances"}. \code{corr}, which is \code{FALSE} by default, indicates whether to match nodes under \code{method="distances"} using the correlation (\code{corr=TRUE}) or the absolute similarity of distances.} } \description{ This function returns a matrix in which the first column contains \emph{all} of the internal nodes of \code{tr1} and the second column contains the matching nodes from \code{tr2}, inasmuch as they can be identified. For \code{method="descendants"}, pairs of matching nodes are defined by sharing all descendant leaves in common. For \code{method="distances"}, nodes are considered to matched if the share the same set of distances (or proportional distances, for optional argument \code{corr=TRUE}) to all tips. \code{matchLabels} is functionally equivalent but matches node (tip) indices based on identifying matching in the labels only. } \value{ A matrix in which the first column contains the nodes of \code{tr1} with the second column containing matching nodes in \code{tr2}, with the criterion for matching defined by \code{method}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/Dtest.Rd0000644000176200001440000000303513353174736014275 0ustar liggesusers\name{Dtest} \alias{Dtest} \title{Conducts correlational D-test from stochastic mapping} \usage{ Dtest(t1, t2, nsim=100, ...) } \arguments{ \item{t1}{set of stochastic map trees (i.e., object of class \code{"multiSimmap"} for character 1. Note that \code{t1} and \code{t2} should be of the same length.} \item{t2}{set of stochastic map trees (i.e., object of class \code{"multiSimmap"} for character 2. Note that \code{t1} and \code{t2} should be of the same length.} \item{nsim}{number of simulations to use in the test.} \item{...}{arguments to be passed internally to \code{make.simmap}. Note that (for now) these must be the same for both \code{t1} and \code{t2} (that is to say, we are not able to assume different trait evolution models for each tree).} } \description{ This function conducts the 'D-test' of Huelsenbeck et al. (2003). } \details{ Note that this function has been included without much testing, and so the user should be wary. } \value{ An object of class \code{"Dtest"}. } \references{ Huelsenbeck, J. P., R. Neilsen, and J. P. Bollback (2003) Stochastic mapping of morphological characters. \emph{Systematic Biology}, \bold{52}, 131-138. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{make.simmap}}, \code{\link{map.overlap}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{simulation} \keyword{bayesian} phytools/man/phylomorphospace.Rd0000644000176200001440000000742413252542661016606 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 taits at internal nodes in the tree - if not supplied, these values will be estimated using \code{\link{fastAnc}}.} \item{label}{string indicating whether to plot the tip labels in the same direction as the terminal edge (\code{label="radial"}), horizontally \code{label="horizontal"}, or not at all \code{"off"}. \code{label=TRUE} and \code{label=FALSE} are also acceptable, for compatibility with phytools <= 0.3-03.} \item{control}{a list containing the following optional control parameters: \code{col.edge}: a vector of edge colors; and \code{col.node}: a vector of node colors.} \item{nsteps}{for \code{project.phylomorphospace} the number of frames in the animation between the phylogeny & the phylomorphospace or \emph{vice versa}.} \item{sleep}{for \code{project.phylomorphospace} the time between frames.} \item{direction}{for \code{project.phylomorphospace} whether to morph \code{"to"} a phylomorphospace, \code{"from"} a phylomorphospace, or there & back again (\code{"both"}).} \item{...}{optional arguments for plotting, including \code{xlim}, \code{ylim}, \code{xlab}, \code{ylab}, \code{lwd}, \code{colors}, \code{fsize}, and \code{node.by.map}. \code{colors} is only used when there is a mapped discrete character on the tree, in which case \code{control$col.edge} is ignored. \code{fsize} is relative to the default, which is \code{textxy(...,cx=0.75)}. \code{node.by.map} is a logical value (defaults to \code{FALSE} which tells the function whether or not to plot the node colors using the colors of the mapped discrete character. Setting this option to \code{TRUE} will cause \code{control$col.node} to be ignored. \code{node.size} is a vector containing the point size relative to the default (see \code{\link{par}} for plotted internal nodes and tips, respectively. Defaults to \code{node.size=c(1,1.3)}. If only one number is provided it will be recycled. \code{axes} is a logical value indicating whether or not axes should be plotted (see \code{\link{plot.default}}. Finally, \code{add} indicates whether to add the phylmorphospace to the current plot.} } \description{ This function creates a phylomorphospace plot (a projection of the tree into morphospace) for two characters following Sidlauskas (2008; \emph{Evolution}). It will also plot a discrete character mapped on tree. \code{project.phylomorphospace} animates the phylomorphospace projection. } \value{ This function creates a phylomorphospace plot } \references{ Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-90. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Sidlauskas, B. (2008) Continuous and arrested morphological diversification in sister clades of characiform fishes: A phylomorphospace approach. \emph{Evolution}, \bold{62}, 3135-3156. } \author{Liam Revell \email{liam.revell@umb.edu}} \examples{ tree<-pbtree(n=25) X<-fastBM(tree,nsim=2) phylomorphospace(tree,X,xlab="trait 1",ylab="trait 2") } \keyword{phylogenetics} \keyword{comparative method} \keyword{plotting} phytools/man/consensus.edges.Rd0000644000176200001440000000257212701474445016321 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 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{ This function computes consensus edge lengths by different methods. } \value{ An object of class \code{"phylo"} with edge lengths. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} phytools/man/multiC.Rd0000644000176200001440000000172313501610015014425 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{ 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. } \value{ A list of matrices. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{evolvcv.lite}}, \code{\link{read.simmap}}, \code{\link{vcvPhylo}}, \code{\link{vcv.phylo}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/plot.backbonePhylo.Rd0000644000176200001440000000372212742001411016726 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{ Function plots a backbone tree (stored as an object of class \code{"backbonePhylo"}) with triangles as subtrees. } \value{ Plots a tree. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{phylo.toBackbone}} } \examples{ ## first create our backbone tree with ## random subtree diversities tree<-phytools:::lambdaTree(pbtree(n=10),lambda=0.5) ## create a translation table ## leaving a couple of single-taxon clades for fun tip.label<-sample(tree$tip.label,8) clade.label<-LETTERS[1:8] N<-ceiling(runif(n=8,min=1,max=20)) ## set crown node depth to 1/2 the maximum depth depth<-sapply(tip.label,function(x,y) 0.5*y$edge.length[which(tree$edge[,2]== which(y$tip.label==x))],y=tree) trans<-data.frame(tip.label,clade.label,N,depth) rownames(trans)<-NULL rm(tip.label,clade.label,N,depth) ## here's what trans looks like trans ## convert obj<-phylo.toBackbone(tree,trans) ## plot plot(obj) } \keyword{phylogenetics} \keyword{plotting} phytools/man/phenogram.Rd0000644000176200001440000001027613066532165015172 0ustar liggesusers\name{phenogram} \alias{phenogram} \title{Plot phenogram (traitgram)} \usage{ phenogram(tree, x, fsize=1.0, ftype="reg", colors=NULL, axes=list(), add=FALSE, ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}, with or without a mapped discrete character.} \item{x}{a vector containing the states at the tips \emph{or} the states at all the tips and the internal nodes of the tree.} \item{fsize}{relative font size for tip labels.} \item{ftype}{font type - options are \code{"reg"}, \code{"i"} (italics), \code{"b"} (bold), or \code{"bi"} (bold-italics).} \item{colors}{colors for plotting the mapped character (if available) in \code{tree}. If no character is mapped on the tree, then a single color for all the branches of the tree can be provided.} \item{axes}{list of axis dimensions. Items are \code{time} and \code{trait}.} \item{add}{optional logical value indicating whether to add to an open plot. If \code{TRUE}, then new axes will not be plotted.} \item{...}{optional arguments including \code{xlim}, \code{ylim}, \code{log}, \code{main}, \code{sub}, \code{xlab}, \code{ylab}, \code{asp}, \code{type}, \code{lty}, \code{lwd}, \code{offset}, and \code{digits} are as in \code{\link{plot.default}} or \code{\link{par}}. Note that \code{axes} overrides \code{xlim} and \code{ylim}. \code{spread.labels} is a logical value indicating whether or not to minimize tip label overlap (default is \code{TRUE}); \code{spread.cost} is a numeric vector indicating the relative penalty to be used for label overlap and deviance, respectively (if \code{spread.labels=TRUE}); \code{spread.range} is the range over which to (potentially) spread the labels - note that if labels do not overlap, not all of that range will be used; finally, \code{link} is a numeric value by which to offset the tip labels, linking them to the tips with a dashed line (default is \code{0}, if \code{spread.labels=FALSE}, or 10-percent 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{ 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. } \details{ For \code{spread.labels=TRUE} numerical optimization is performed to optimize the distribution of the labels vertically, where the solution depends on the vector \code{spread.cost} containing the cost of overlap (first) and the cost of deviation from the vertical position of the tip. Note that because this is done via numerical optimization, plotting may hang briefly while the best solution is found (especially for large trees). } \value{ Plots a traitgram, optionally with a mapped discrete character, and (invisibly) returns a matrix containing the coordinates of the plotted tip labels. } \references{ Evans, M. E. K., Smith, S. A., Flynn, R. S., Donoghue, M. J. (2009) Climate, niche evolution, and diversification of the "bird-cage" evening primroses (Oenothera, sections Anogra and Kleinia). \emph{American Naturalist}, \bold{173}, 225-240. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \examples{ \dontrun{ tree<-pbtree(n=20,scale=2) x<-fastBM(tree) phenogram(tree,x) # or, simulate a discrete character history tree<-sim.history(tree,Q=matrix(c(-1,1,1,-1),2,2),anc="1") # simulate in which the rate depends on the state x<-sim.rates(tree,c(1,10)) phenogram(tree,x) # now use spread.labels tree<-pbtree(n=40) x<-fastBM(tree) phenogram(tree,x,spread.labels=TRUE,spread.cost=c(1,0)) } } \keyword{phylogenetics} \keyword{plotting} \keyword{comparative method} phytools/man/minSplit.Rd0000644000176200001440000000304113501606413014771 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 components: \item{node}{node for the minimum split.} \item{bp}{location on the branch leading to \code{node} of the minimum split.} } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Revell, L. J., D. L. Mahler, P. Peres-Neto, and B. D. Redelings (2012) A new method for identifying exceptional phenotypic diversification. \emph{Evolution}, \bold{66}, 135-146. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{evol.rate.mcmc}}, \code{\link{posterior.evolrate}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{bayesian} phytools/man/densityMap.Rd0000644000176200001440000000731013066527052015321 0ustar liggesusers\name{densityMap} \alias{densityMap} \alias{plot.densityMap} \title{Plot posterior density of stochastic mapping on a tree} \usage{ densityMap(trees, res=100, fsize=NULL, ftype=NULL, lwd=3, check=FALSE, legend=NULL, outline=FALSE, type="phylogram", direction="rightwards", plot=TRUE, ...) \method{plot}{densityMap}(x, ...) } \arguments{ \item{trees}{set of phylogenetic trees in a modified \code{"multiPhylo"} object. Values for a two-state discrete character are mapped on the tree. See \code{\link{make.simmap}} and \code{\link{read.simmap}} for details.} \item{res}{resolution for gradient plotting. Larger numbers indicate a finer (smoother) gradient.} \item{fsize}{relative font size - can be a vector with the second element giving the font size for the legend.} \item{ftype}{font type - see options in \code{\link{plotSimmap}}. As with \code{fsize}, can be a vector with the second element giving font type for the legend.} \item{lwd}{line width for branches. If a vector of two elements is supplied, the second element will be taken to be the desired width of the legend bar.} \item{check}{check to make sure that the topology and branch lengths of all phylogenies in \code{trees} are equal.} \item{legend}{if \code{FALSE} no legend is plotted; if a numeric value, it gives the length of the legend in units of branch length. Default is 0.5 times the total tree length.} \item{outline}{logical value indicating whether or not to outline the branches of the tree in black.} \item{type}{type of plot desired. Options are \code{"phylogram"} for a rightward square phylogram; and \code{"fan"} for a circular phylogram.} \item{plot}{logical value indicating whether or not to plot the tree. If \code{plot=FALSE} then an object of class \code{"densityMap"} will be returned without plotting.} \item{direction}{plotting direction for \code{type="phylogram"}.} \item{x}{for \code{plot.densityMap}, an object of class \code{"densityMap"}.} \item{...}{optional arguments for \code{plot.densityMap}. These include all the arguments of \code{densityMap} except \code{trees} and \code{res}. Additional optional arguments include \code{mar} (margins), \code{offset} (tip label offset), and \code{hold} (whether or not to use \code{dev.hold} to hold output to graphical device before plotting; defaults to \code{hold=TRUE}). Also, the argument \code{states} can be used to 'order' the states on the probability axis (that is, which state should correspond to a posterior probability of 0 or 1). Some other plotting arguments, such as \code{xlim} and \code{ylim}, may also work.} } \description{ Function plots a tree with the posterior density for a mapped character from stochastic character mapping on the tree. Since the mapped value is the probability of being in state "1", only binary [0,1] characters are allowed. } \value{ Plots a tree and returns an object of class \code{"densityMap"} invisibly. } \references{ Bollback, J. P. 2006. Stochastic character mapping of discrete traits on phylogenies. \emph{BMC Bioinformatics}, \bold{7}, 88. Huelsenbeck, J. P., R. Neilsen, and J. P. Bollback. 2003. Stochastic mapping of morphological characters. \emph{Systematic Biology}, \bold{52}, 131-138. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Revell, L. J. 2013. Two new graphical methods for mapping trait evolution on phylogenies. \emph{Methods in Ecology and Evolution}, \bold{4}, 754-759. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{make.simmap}}, \code{\link{plotSimmap}}, \code{\link{read.simmap}} } \keyword{phylogenetics} \keyword{plotting} \keyword{comparative method} phytools/man/optim.phylo.ls.Rd0000644000176200001440000000427313502026374016104 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{ This function performs phylogeny inference using least-squares. } \details{ Function uses \code{\link{nni}} from the \emph{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: Modesl and estimation procedures. \emph{American Journal of Human Genetics}, \bold{19}, 233-257. Felsenstein, J. (2004) \emph{Inferring Phylogenies}. Sinauer. Paradis, E., J. Claude, and K. Strimmer. (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Schliep, K. P. (2011) phangorn: phylogenetic analysis in R. \emph{Bioinformatics}, \bold{27}, 592-593. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{exhaustiveMP}}, \code{\link{nni}} } \keyword{phylogenetics} \keyword{inference} \keyword{distance matrix} \keyword{least squares} phytools/man/to.matrix.Rd0000644000176200001440000000135712464427052015136 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{ This function takes a vector of characters and computes a binary matrix. Primarily to be used internally by \code{\link{make.simmap}} and \code{\link{rerootingMethod}}. } \value{ A binary matrix of dimensions \code{length(x)} by \code{length(seq)}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{utilities} phytools/man/setMap.Rd0000644000176200001440000000250513502030615014423 0ustar liggesusers\name{setMap} \alias{setMap} \alias{setMap.contMap} \alias{setMap.densityMap} \alias{setMap.phyloScattergram} \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, ...) } \arguments{ \item{x}{an object of class \code{"contMap"}, \code{"densityMap"}, or \code{"phyloScattergram"}.} \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{ Function to change the color map (ramp) in an object of class \code{"contMap"}, \code{"densityMap"}, or \code{"phyloScattergram"}. } \value{ An object of class \code{"contMap"}, \code{"densityMap"}, or \code{"phyloScattergram"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Revell, L. J. 2013. Two new graphical methods for mapping trait evolution on phylogenies. \emph{Methods in Ecology and Evolution}, \bold{4}, 754-759. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{contMap}}, \code{\link{densityMap}} } \keyword{phylogenetics} \keyword{plotting} phytools/man/likMlambda.Rd0000644000176200001440000000201013477463754015247 0ustar liggesusers\name{likMlambda} \alias{likMlambda} \title{Likelihood for joint 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{ Computes the joint likelihood of Pagel's \eqn{\lambda} parameter. } \details{ Generally intended to be used internally by other methods that do joint optimization of \eqn{\lambda} (e.g., \code{\link{phyl.pca}}). } \value{ The log-likelihood. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{math} \keyword{comparative method} \keyword{utilities} phytools/man/phyl.pca.Rd0000644000176200001440000000472313502026543014721 0ustar liggesusers\name{phyl.pca} \alias{phyl.pca} \alias{biplot.phyl.pca} \title{Phylogenetic principal components analysis} \usage{ phyl.pca(tree, Y, method="BM", mode="cov", ...) \method{biplot}{phyl.pca}(x, ...) } \arguments{ \item{tree}{phylogeny as an object of class \code{"phylo"}.} \item{Y}{data matrix with traits in columns.} \item{method}{method to obtain the correlation structure: can be \code{"BM"} or \code{"lambda"}.} \item{mode}{is the mode for the PCA: can be \code{"cov"} or \code{"corr"}.} \item{x}{object of class \code{"phyl.pca"} for \code{biplot.phyl.pca}.} \item{...}{for S3 plotting method \code{biplot.phyl.pca}, other arguments to be passed to \code{\link{biplot}}.} } \description{ This function performs phylogenetic PCA (e.g., Revell 2009; \emph{Evolution}). } \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. } \value{ An object of class \code{"phyl.pca"} consisting of a list with some or all of the following components: \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 lambda (\code{method="lambda"} only).} \item{logL}{log-likelihood for lambda model (\code{method="logL"} only).} } \references{ Revell, L. J. (2009) Size-correction and principal components for interspecific comparative studies. \emph{Evolution}, \bold{63}, 3258-3268. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}, Joan Maspons} \seealso{ \code{\link{phyl.cca}}, \code{\link{phyl.resid}} } \keyword{phylogenetics} \keyword{maximum likelihood} \keyword{comparative method} \keyword{statistics} phytools/man/untangle.Rd0000644000176200001440000000204713066534416015025 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{ This function attempts to untangle the branches of a tree that are tangled in plotting with \code{\link{plot.phylo}}, \code{\link{plotTree}}, or \code{\link{plotSimmap}}. } \value{ An object of class \code{"phylo"} or \code{"simmap"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/sim.history.Rd0000644000176200001440000000641213236602434015473 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, ...) 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} normally this is the \emph{transpose} of the matrix produced by \code{fitDiscrete} in the geiger package or \code{\link{make.simmap}} in 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{...}{other optional arguments. Currently only \code{message}, a logical value indicating whether or not to turn on informational messages (defaults to \code{message=TRUE}).} } \description{ 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 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. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{fitMk}}, \code{\link{fitmultiMk}}, \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{plotSimmap}}, \code{\link{sim.rates}} } \keyword{phylogenetics} \keyword{simulation} phytools/man/threshBayes.Rd0000644000176200001440000000627113302625201015456 0ustar liggesusers\name{threshBayes} \alias{threshBayes} \title{Threshold model using Bayesian MCMC} \usage{ threshBayes(tree, X, types=NULL, ngen=10000, control=list(), ...) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} \item{X}{a numeric matrix containing values for a numerically coded discrete character and a continuous character; or two discrete characters. The row names of \code{X} should be species names. Discrete characters need to be provided as numeric values of \code{0} or \code{1} and only binary traits are permitted.} \item{types}{a vector of length \code{ncol(X)} containing the data types for each column of \code{X}, for instance \code{c("discrete","continuous")}.} \item{ngen}{a integer indicating the number of generations for the MCMC.} \item{control}{a list of control parameters for the MCMC. Control parameters include: \code{sample}, the sampling interval for the MCMC; \code{propvar}, a vector containing (in this order) proposal variances for the two rates (if the type is \code{"discrete"} this will be ignored), the two ancestral states, and the correlation; \code{propliab}, a single proposal variance for the liabilities; \code{pr.mean}, a vector for the mean of the prior probability distributions for each parameter, in the same order as \code{propvar}; \code{pr.liab}, currently ignored; \code{pr.var}, a vector with variances for the prior densities for each parameter, in the same order as \code{pr.mean} - note that for the rates we use an exponential distribution so the first two means are currently ignored; and \code{pr.vliab} currently ignored.} \item{...}{other optional arguments.} } \description{ This function uses Bayesian MCMC to fit the quantitative genetics threshold model (Felsenstein 2012) to data for two discrete characters or one discrete and one continuous character. } \value{ This function returns an object of class \code{"threshBayes"} consisting of a list with at least the following two elements: \code{par} a matrix containing the posterior sample for the model parameters (evolutionary rates, ancestral states, and correlation); \code{liab} a matrix containing the posterior sample of the liabilities. For continuous characters, the liabilities are treated as known and so the posterior samples are just the observed values. } \details{ The \code{plot} method for the object class \code{"threshBayes"} can be used to plot a posterior density of the correlation coefficient, \emph{r}. Discrete characters must be binary, coded as \code{0} and \code{1}. } \references{ Felsenstein, J. (2012) A comparative method for both discrete and continuous characters using the threshold model. \emph{American Naturalist}, \bold{179}, 145-156. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Revell, L. J. (2014) Ancestral character estimation under the threshold model from quantitative genetics. \emph{Evolution}, bold{68}, 743-759. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{anc.Bayes}}, \code{\link{bmPlot}}, \code{\link{evol.rate.mcmc}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{bayesian} phytools/man/plotThresh.Rd0000644000176200001440000000372413066533367015353 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 percent 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{ This function uses the object returned by \code{\link{ancThresh}} to plot the posterior probabilities of ancestral states under the threshold model. It is also called internally by \code{\link{ancThresh}}. } \value{ Plots a tree. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Revell, L. J. (2014) Ancestral character estimation under the threshold model from quantitative genetics. \emph{Evolution}, bold{68}, 743-759. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ancThresh}}, \code{\link{plot.phylo}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{bayesian} phytools/man/anoletree.Rd0000644000176200001440000000133513164532055015161 0ustar liggesusers\name{anoletree} \alias{anoletree} \title{Phylogeny of Greater Antillean anole ecomorph species with mapped discrete character} \description{ A phylogeny of Greater Antillean anole species with a mapped discrete character - 'ecomorph class.' Data and tree are from Mahler et al. (2010). } \usage{ data(anoletree) } \format{ The data are stored as a modified object of class \code{"simmap"} with a mapped discrete character. (E.g., see \code{\link{read.simmap}}.) } \source{ 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. } \keyword{datasets} phytools/man/splitEdgeColor.Rd0000644000176200001440000000165612572446464016142 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{ 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. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{plotSimmap}} } \keyword{phylogenetics} \keyword{plotting} \keyword{comparative method} phytools/man/vcvPhylo.Rd0000644000176200001440000000173512464427003015017 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{ This function returns a so-called \emph{phylogenetic variance covariance matrix} (e.g., see \code{\link{vcv.phylo}}), but (optionally) including ancestral nodes and under different evolutionary models. } \value{ A matrix. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{statistics} \keyword{utilities} phytools/man/phylosig.Rd0000644000176200001440000000634413066533213015044 0ustar liggesusers\name{phylosig} \alias{phylosig} \title{Compute phylogenetic signal with two methods} \usage{ phylosig(tree, x, method="K", test=FALSE, nsim=1000, se=NULL, start=NULL, control=list()) } \arguments{ \item{tree}{a phylogenetic tree in \code{"phylo"} format.} \item{x}{vector containing values for a single continuously distributed trait.} \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) sigma^2 and 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}.} } \description{ 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). } \details{ \eqn{\lambda} optimization is performed using \code{\link{optimize}} with the range of lambda set between 0 and the theoretical upper limit of lambda (determined by the relative height of the most recent internal node on the tree). } \value{ If \code{(method="K")}, a list with the following components: \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")}, a list with the following components: \item{lambda}{fitted value of lambda.} \item{sig2}{rate of evolution, for estimation with sampling error.} \item{logL}{log-likelihood.} \item{logL0}{log-likelihood for \code{lambda=0.0}.} \item{P}{P-value of the likelihood ratio test.} \item{convergence}{value for convergence, for estimation with sampling error only. (See \code{\link{optim}}).} \item{message}{message from \code{\link{optim}}, for estimation with sampling error only.} } \references{ Blomberg, S. P., T. Garland Jr., A. R. Ives (2003) Testing for phylogenetic signal in comparative data: Behavioral traits are more labile. \emph{Evolution}, \bold{57}, 717-745. Ives, A. R., P. E. Midford, T. Garland Jr. (2007) Within-species variation and measurement error in phylogenetic comparative biology. \emph{Systematic Biology}, \bold{56}, 252-270. Pagel, M. (1999) Inferring the historical patterns of biological evolution. \emph{Nature}, \bold{401}, 877-884. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \examples{ tree<-pbtree(n=100) x<-fastBM(tree) phylosig(tree,x,method="lambda",test=TRUE) } \keyword{phylogenetics} \keyword{comparative method} \keyword{maximum likelihood} \keyword{simulation} phytools/man/read.newick.Rd0000644000176200001440000000256212635356700015403 0ustar liggesusers\name{read.newick} \alias{read.newick} \title{Robust Newick style tree reader} \usage{ read.newick(file="", text, ...) } \arguments{ \item{file}{name of text file with single Newick style tree or multiple trees, one per line.} \item{text}{character string containing tree.} \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{ This function reads a Newick style tree from file. } \details{ This function is almost completely redundant with \code{\link{read.tree}}; however it is 'robust' in that it does not fail if the tree contains so-called 'singles' (nodes with only one descendant). } \value{ An object of class \code{"phylo"}, possibly containing singles (see \code{\link{collapse.singles}}). } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{read.tree}}, \code{\link{read.nexus}} } \examples{ tree<-"((Human,Chimp),Gorilla),Monkey);" phy<-read.newick(text=tree) } \keyword{phylogenetics} \keyword{input/output} phytools/man/plotBranchbyTrait.Rd0000644000176200001440000000552513066533261016644 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 "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.} } \description{ Function plots a tree with branches colored by the value for a quantitative trait or probability, by various methods. Unlike most other tree plotting functions in phytools, this function calls \code{\link{plot.phylo}} (not \code{plotSimmap}) internally. } \details{ Note that if \code{prompt=TRUE}, the function will prompt for the position of the legend. } \value{ Plots a phylogeny. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{plotting} \keyword{comparative method} phytools/man/export.as.xml.Rd0000644000176200001440000000211013353267421015717 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{ This function exports trees & character data in XML format. } \details{ Can be used to create input file for the program SIMMAP v1.5 (Bollback 2006). } \value{ A file. } \references{ Bollback, J. P. (2006) Stochastic character mapping of discrete traits on phylogenies. \emph{BMC Bioinformatics}, \bold{7}, 88. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{make.simmap}}, \code{\link{read.nexus}}, \code{\link{read.simmap}}, \code{\link{write.simmap}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/rerootingMethod.Rd0000644000176200001440000000567613242622344016366 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 revsersible model. \code{model=c("ER","SYM")} recommended.} \item{...}{optional arguments. Presently the logical argument \code{tips}. If \code{tips=TRUE}, then the function will also compute the empirical Bayes posterior probabilities of the tips following Yang (2006). Note that \code{...} is passed internally to \code{fitMk}, but should be used in this way with caution because any arguments that conflict with the default arguments of the method will cause the function execution to fail. The most practical use of this would be to force a particular value of the transition matrix, \code{Q}, via the argument \code{fixedQ}.} } \description{ 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. } \details{ This function calls \code{\link{fitMk}} internally. \code{fitMk} uses some code adapted from \code{ace} in the ape package. \code{print} and \code{plot} methods are now available for the object class. } \value{ An object of class \code{"rerootingMethod"} containing at least the following elements: \item{loglik}{the log-likelihood.} \item{Q}{the fitted transition matrix between states.} \item{marginal.anc}{the marginal ancestral state reconstructions for each node (and, optionally, each tip).} } \references{ Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Yang, Z., Kumar, S., Nei, M. (1995) A new method of inference of ancestral nucleotide and amino acid sequences. \emph{Genetics}, \bold{141}, 1641-1650. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ace}}, \code{\link{fitMk}}, \code{\link{make.simmap}} } \keyword{phylogenetics} \keyword{bayesian} \keyword{comparative method} \keyword{maximum likelihood} phytools/man/map.to.singleton.Rd0000644000176200001440000000436013501740505016377 0ustar liggesusers\name{map.to.singleton} \alias{map.to.singleton} \alias{plotTree.singletons} \alias{drop.tip.singleton} \alias{rootedge.to.singleton} \title{Converts a mapped tree to a tree with singleton nodes} \usage{ map.to.singleton(tree) plotTree.singletons(tree) drop.tip.singleton(tree, 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{tip}{for \code{drop.tip.singleton}, a tip label or vector of tip labels.} } \description{ The function \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. The states for each edge are stored in \code{names(tree$edge.length)}. In a sense this is just an alternative way to use the general structure of the \code{"phylo"} object to encode a tree with a mapped character. \code{plotTree.singletons} plots a tree with singleton nodes. Note that \code{\link{plotTree}} and \code{\link{plot.phylo}} now have no trouble graphing trees with singleton nodes - but they do this by just ignoring the singletons. \code{plotTree.singletons} marks the singletons as nodes on the plotted phylogeny. \code{drop.tip.singleton} drops tips from the tree leaving ancestral nodes for all remaining tips as singletons. Finally, \code{rootedge.to.singleton} converts a tree with a root edge to a tree with a singleton node instead. } \value{ An object of class \code{"phylo"} with singleton nodes. \code{plotTree.singletons} graphs a tree in which the singleton nodes are shown. If \code{names(tree$edge.length)!=NULL} \code{plotTree.singletons} will use a different color from \code{\link{palette}} for each mapped state. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{collapse.singles}}, \code{\link{drop.tip}}, \code{\link{make.simmap}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/reorder.backbonePhylo.Rd0000644000176200001440000000144512464430556017433 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. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{phylo.toBackbone}} } \keyword{phylogenetics} \keyword{plotting} phytools/man/paintSubTree.Rd0000644000176200001440000000365313066531605015616 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{ This function maps or "paints" an arbitrary, i.e., user-specified, discrete character history on the tree. \code{paintSubTree} paints the clade downstream of \code{node} with a particular state; whereas \code{paintBranches} paints only a specified branch. } \value{ An object of class \code{"simmap"} that contains the specified paintings as a mapped discrete character. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{plotSimmap}}, \code{\link{sim.history}} } \keyword{phylogenetics} \keyword{comparative method} phytools/man/phylo.heatmap.Rd0000644000176200001440000000375513201722134015753 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{ Functions creates a multivariate phylogenetic \code{\link{heatmap}}. } \value{ Function creates a plot. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \examples{ # simulate tree tree <- pbtree(n=20,scale=1) # simulate continuous character X <- fastBM(tree, nsim=5) phylo.heatmap(tree, X, grid=TRUE) } \keyword{phylogenetics} \keyword{plotting} phytools/man/allFurcTrees.Rd0000644000176200001440000000226112464424344015600 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 caution for \code{n} greater than about 8, as in this case the number of possible trees is extremely large. } \value{ A list of trees as an object of class \code{"multiPhylo"}. } \references{ Felsenstein, J. 2004. \emph{Inferring Phylogenies}. Sinauer. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{add.everywhere}}, \code{\link{exhaustiveMP}} } \keyword{phylogenetics} \keyword{inference} phytools/man/exhaustiveMP.Rd0000644000176200001440000000312513502025005015610 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 indicatingn method to use: \code{"branch.and.bound"}, implementing a branch-and-bound search (obviously), or \code{"exhaustive"}.} } \description{ This function does exhaustive and branch & bound MP searches. } \details{ Should probably not be used for more than about 8 species (and definitely not more than 10 species). Performs parsimony calculations using \code{\link{parsimony}} in the \code{phangorn} package (Schliep, 2011). } \value{ A \code{"phylo"} or \code{"multiPhylo"} object that is the MP tree or set of MP trees. It also returns the parsimony scores in \code{attr(trees,"pscore")} or \code{attr(trees[[i]],"pscore")} for the ith tree. } \references{ Felsenstein, J. (2004) \emph{Inferring Phylogenies}. Sinauer. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Schliep, K. P. (2011) phangorn: phylogenetic analysis in R. \emph{Bioinformatics}, \bold{27}, 592-593. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{mrp.supertree}}, \code{\link{optim.parsimony}}, \code{\link{pratchet}} } \keyword{phylogenetics} \keyword{inference} \keyword{parsimony} phytools/man/write.simmap.Rd0000644000176200001440000000332113066534534015624 0ustar liggesusers\name{write.simmap} \alias{write.simmap} \title{Write a stochastic character mapped tree to file} \usage{ write.simmap(tree, file=NULL, append=FALSE, map.order=NULL, quiet=FALSE) } \arguments{ \item{tree}{an object of class \code{"simmap"} or \code{"multiSimmap"}.} \item{file}{an optional filename.} \item{append}{a logical value indicating whether to append to file.} \item{map.order}{a optional value specifying whether to write the map in left-to-right or right-to-left order. Acceptable values are "left-to-right" or "right-to-left" or some abbreviation of either. If not provided, \code{write.simmap} will use \code{attr(tree,"map.order")} if available.} \item{quiet}{logical value indicating whether or not to print a warning message when \code{map.order} is neither specified by a function argument or as an attribute of \code{tree}.} } \description{ This function writes stochastic character mapped trees to file using the Newick style format of SIMMAP v1.0 (Bollback 2006). } \value{ A file or string (if \code{file=NULL}). } \references{ Bollback, J. P. (2006) Stochastic character mapping of discrete traits on phylogenies. \emph{BMC Bioinformatics}, \bold{7}, 88. Huelsenbeck, J. P., R. Neilsen, and J. P. Bollback (2003) Stochastic mapping of morphological characters. \emph{Systematic Biology}, \bold{52}, 131-138. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{plotSimmap}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{input/output} phytools/man/phyl.pairedttest.Rd0000644000176200001440000000524013207251313016476 0ustar liggesusers\name{phyl.pairedttest} \alias{phyl.pairedttest} \title{Phylogenetic paired 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{ This function conducts a phylogenetic paired t-test, roughly following Lindenfors et al. (2010; \emph{J. Evol. Biol.}). This is 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. } \details{ 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 components: \item{dbar}{phylogenetic mean difference.} \item{se}{standard error of \code{dbar}.} \item{sig2}{estimated evolutionary variance (of the difference).} \item{lambda}{fitted (or fixed) value of \ifelse{html}{\out{λ}}{\eqn{\lambda}{lambda}}.} \item{logL}{log-likelihood of the fitted model.} \item{t.dbar}{t-value (\code{(dbar-h0)/se} where \code{se} is computed from the Hessian).} \item{P.dbar}{P-value.} \item{df}{the degrees of freedom.} \item{h0}{the null hypothesis that was tested.} } \references{ Lindenfors, P., L. J. Revell, and C. L. Nunn (2010) Sexual dimorphism in primate aerobic capacity: A phylogenetic test. \emph{J. Evol. Biol.}, \bold{23}, 1183-1194. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{comparative method} \keyword{maximum likelihood} \keyword{statistics} phytools/man/threshDIC.Rd0000644000176200001440000000325712464427146015033 0ustar liggesusers\name{threshDIC} \alias{threshDIC} \title{Deviance Information Criterion from the threshold model} \usage{ threshDIC(tree, x, mcmc, burnin=NULL, sequence=NULL, method="pD") } \arguments{ \item{tree}{phylogenetic tree.} \item{x}{a named vector containing discrete character states; or a matrix containing the tip species, in rows, and probabilities of being in each state, in columns.} \item{mcmc}{list object returned by \code{\link{ancThresh}}.} \item{burnin}{number of generations (not samples) to exclude as burn in; if not supplied then 20 percent of generations are excluded.} \item{sequence}{assumed ordering of the discrete character state. If not supplied and \code{x} is a vector then numerical-alphabetical order is assumed; if not supplied and \code{x} is a matrix, then the column order of \code{x} is used.} \item{method}{method for computing the effective number of parameters (options are \code{"pD"} and \code{"pV"}).} } \description{ This function computes the Deviance Information Criterion from the MCMC object returned by \code{\link{ancThresh}}. } \value{ A vector containing the mean deviance and deviance for the parameter means, the effective number of parameters, and the DIC. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Revell, L. J. (2014) Ancestral character estimation under the threshold model from quantitative genetics. \emph{Evolution}, bold{68}, 743-759. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ancThresh}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{bayesian} phytools/man/make.simmap.Rd0000644000176200001440000001632713502026044015404 0ustar liggesusers\name{make.simmap} \alias{make.simmap} \title{Simulate stochastic character maps on a phylogenetic tree or trees} \usage{ make.simmap(tree, x, model="SYM", nsim=1, ...) } \arguments{ \item{tree}{a phylogenetic tree as an object of class \code{"phylo"}, or a list of trees as an object of class \code{"multiPhylo"}.} \item{x}{a vector containing the tip states for a discretely valued character, or a matrix containing the prior probabilities of tip states in rows and character states as column names. The names (if \code{x} is a vector) or row names (if \code{x} is a matrix) should match the tip labels of the tree. The vector can be of class \code{"factor"}, \code{"character"}, or \code{"numeric"} (although in the lattermost case its content should obviously be only integer values).} \item{model}{a character string containing the model or a transition model specified in the form of a matrix. See \code{\link{ace}} for more details.} \item{nsim}{number of simulations. If \code{tree} is an object of class \code{"multiPhylo"}, then \code{nsim} simulations will be conducted \emph{per} input tree.} \item{...}{optional arguments. So far, \code{pi} gives the prior distribution on the root node of the tree. Acceptable values for \code{pi} are \code{"equal"}, \code{"estimated"}, or a vector with the frequencies. If \code{pi="estimated"} then the stationary distribution is estimated by numerically solving \code{pi*Q=0} for \code{pi}, and this is used as a prior on the root. The function defaults to \code{pi="equal"} which results in the root node being sampled from the conditional scaled likelihood distribution at the root. \code{message} tells whether or not to print a message containing the rate matrix, \emph{Q} and state frequencies. \code{message} defaults to \code{TRUE}. For optional argument \code{Q="mcmc"} (see below) the mean value of \code{Q} from the posterior sample is printed. \code{tol} gives the tolerance for zero elements in \code{Q}. (Elements less then \code{tol} will be reset to \code{tol}). Optional argument \code{Q} can be a string (\code{"empirical"} or \code{"mcmc"}), or a fixed value of the transition matrix, \emph{Q}. If \code{"empirical"} than a single value of \emph{Q}, the most likely value, is used for all simulations. If \code{"mcmc"}, then \code{nsim} values of \emph{Q} are first obtained from the posterior distribution for \emph{Q} using Bayesian MCMC, then a simulated stochastic character map is generated for each sampled value of \emph{Q}. Optional argument \code{vQ} can consist of a single numeric value or a vector containing the variances of the (normal) proposal distributions for the MCMC. The order of \code{vQ} is assumed to be in the order of the \code{index.matrix} in \code{\link{ace}} for the chosen model. \code{prior} is a list containing \code{alpha} and \code{beta} parameters for the \eqn{\Gamma} prior distribution on the transition rates in \emph{Q}. Note that \code{alpha} and \code{beta} can be single values or vectors, if different priors are desired for each value in the transition matrix \emph{Q}. As for \code{vQ}, the order of \code{prior} is assumed to correspond with the order of \code{index.matrix} as in \code{\link{ace}}. \code{prior} can also be given the optional logical value \code{use.empirical} which tells the function whether or not to give the prior distribution the empirical mean for \emph{Q}. If \code{TRUE} then only \code{prior$beta} is used and \code{prior$alpha} is set equal to \code{prior$beta} times the empirical mean of \emph{Q}. \code{burnin} and \code{samplefreq} are burn-in and sample frequency for the MCMC, respectively.} } \description{ This function performs stochastic mapping using several different alternative methods. 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. } \details{ \code{make.simmap} uses code modified from \code{\link{ace}} (by Paradis et al.) to perform Felsenstein's pruning algorithm to compute the likelihood. As of \emph{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 \emph{phytools} <= 0.2-26. Between \emph{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 \emph{phytools} 0.2-33 and \emph{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. These issues should be fixed in all later versions. \code{Q="mcmc"} and \code{Q} set to a fixed value were introduced to \emph{phytools} >= 0.2-53. 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. Huelsenbeck, J. P., R. Neilsen, and J. P. Bollback (2003) Stochastic mapping of morphological characters. \emph{Systematic Biology}, \bold{52}, 131-138. Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{brownie.lite}}, \code{\link{brownieREML}}, \code{\link{countSimmap}}, \code{\link{describe.simmap}}, \code{\link{evol.vcv}}, \code{\link{plotSimmap}}, \code{\link{read.simmap}}, \code{\link{write.simmap}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{simulation} \keyword{bayesian} phytools/man/multiRF.Rd0000644000176200001440000000246413100216452014557 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 argumenet indicating whether or not to resolve multifurcating trees. (Defaults to \code{FALSE}.)} } \description{ Computes the Robinson-Foulds (Robinson & Foulds 1981) distance between a set of trees in an object of class \code{"multiPhylo"}. } \details{ Computes the Robinson-Foulds distance between all phylogenies in an object of class \code{"multiPhylo"}. Uses \code{\link{prop.part}} internally for most of the heavy lifting. } \value{ A matrix containing distances. } \references{ Robinson, D. R., Foulds, L. R. (1981) Comparison of phylogenetic trees. \emph{Mathematical Biosciences}, \bold{53}, 131-147. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/fastBM.Rd0000644000176200001440000000347013201722667014363 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.} \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{ This function conducts (reasonably) fast quantitative trait simulation on a phylogeny under several different models: Brownian motion (default), BM with a trend (for \code{mu!=0}), bounds (for \code{bounds!=c(-Inf,} \code{Inf)}), and OU. } \value{ A vector (for \code{nsim=1}) or matrix containing the tip states for the \code{n} species in the tree, and (optionally) the ancestral states for internal nodes. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{sim.corrs}} } \examples{ tree<-pbtree(n=1000) x<-fastBM(tree,sig2=0.1) # Brownian motion y<-fastBM(tree,mu=1) # with a trend } \keyword{phylogenetics} \keyword{simulation} phytools/man/compare.chronograms.Rd0000644000176200001440000000160413474631113017150 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{ This function plots two trees, with semi-transparent colors by default, & uses arrows to highlight differences in depth of corresponding nodes between the trees. } \value{ Function creates a plot. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{plotting} phytools/man/reorderSimmap.Rd0000644000176200001440000000211612564377435016026 0ustar liggesusers\name{reorderSimmap} \alias{reorderSimmap} \title{Reorder edges of a simmap tree} \usage{ reorderSimmap(tree, order="cladewise", index.only=FALSE, ...) } \arguments{ \item{tree}{a modified object of class \code{"phylo"}.} \item{order}{either \code{"cladewise"} or \code{"pruningwise"} (see \code{\link{reorder.phylo}}).} \item{index.only}{logical value indicating whether only an index should be returned.} \item{...}{other arguments.} } \description{ Function returns a reordered modified \code{"phylo"} object by using \code{reorder.phylo} but then sorting the additional elements \code{$mapped.edge} and \code{$maps} to have the same order as \code{$edge}. } \value{ A modified object of class \code{"phylo"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{reorder.phylo}}, \code{\link{plotSimmap}} } \keyword{phylogenetics} \keyword{utilities} \keyword{comparative method} phytools/man/phylo.toBackbone.Rd0000644000176200001440000000270213502027745016404 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. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{plot.backbonePhylo}} } \keyword{phylogenetics} \keyword{plotting} phytools/man/aic.w.Rd0000644000176200001440000000144413021351177014201 0ustar liggesusers\name{aic.w} \alias{aic.w} \title{Computes AIC weights} \usage{ aic.w(aic) } \arguments{ \item{aic}{vector of AIC values for different fitted models. If the vector has names, these names will be inherited by the vector returned by the function.} } \description{ This function computes AIC weights for a set of 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 AIC weights. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{statistics} \keyword{utilities} phytools/man/phytools-package.Rd0000644000176200001440000000152212464431244016453 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 comparative biology; as well as several other functions for tree inference, manipulation, and analysis that are not implemented in other R packages. The complete list of functions can be displayed with \code{library(help = phytools)}. More information on \pkg{phytools} can be found at \url{http://www.phytools.org} or \url{http://blog.phytools.org}. } \author{ Liam J. Revell Maintainer: Liam J. Revell } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \keyword{package} phytools/man/cladelabels.Rd0000644000176200001440000000462113127211726015435 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",...) } \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{...}{optional arguments for \code{arc.cladelabels}.} } \description{ This function adds clade labels to a plotted tree. } \details{ \code{cladelabels} presently works only for rightward facing plotted phylogenies - but no warning will be returned if your tree does not conform to this requirement! \code{arc.cladelabels} is designed to do a similar thing to \code{cladelabels}, but for plotted fan trees. This function checks to ensure that the most recently plotted tree was plotted with \code{type="fan"} style. } \references{ Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{nodelabels}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/lambda.transform.Rd0000644000176200001440000000162113502025521016422 0ustar liggesusers\name{lambda.transform} \alias{lambda.transform} \title{Lambda transformation of matrix} \usage{ lambda.transform(lambda, C) } \arguments{ \item{lambda}{scalar, usually (but not necessarily) on the interval 0,1.} \item{C}{matrix probably returned by \code{\link{vcv.phylo}}.} } \description{ Function multiplies the off-diagonals of a square matrix by \code{lambda}. Used internally in \code{\link{phyl.pca}} and other functions. } \value{ An among-species phylogenetic variance covariance matrix (e.g., \code{\link{vcv.phylo}}) in which the off-diagonal elements have been multiplied by \code{lambda}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{math} \keyword{comparative method} phytools/man/modified.Grafen.Rd0000644000176200001440000000215513501606521016160 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{ 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{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{compute.brlen}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/mapped.states.Rd0000644000176200001440000000152512673645401015760 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. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{comparative method} \keyword{phylogenetics} \keyword{utilities} phytools/man/as.multiPhylo.Rd0000644000176200001440000000170213066524027015752 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. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/densityTree.Rd0000644000176200001440000000470613100175716015504 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 to render transparent.} } \description{ Functions plots a posterior sample of trees, including with mapped discrete characters. \code{make.transparent} is used internally and converts a color to transparent with a certain user-specified \code{alpha} level. } \value{ Function creates a plot. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{plotting} phytools/man/fastMRCA.Rd0000644000176200001440000000273113475632545014616 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{ This function 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. } \details{ 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 ape package.) } \value{ The node number of the MRCA, the height above the root (for \code{fastHeight}), or the patristic distance between two taxa (for \code{fastDist}). } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{getMRCA}}, \code{\link{findMRCA}}, \code{\link{mrca}} } \examples{ tree<-pbtree(n=2000) anc<-fastMRCA(tree,"t1","t15") } \keyword{phylogenetics} \keyword{utilities} phytools/man/pgls.Ives.Rd0000644000176200001440000001057013201657340015053 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=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 \code{sig2x} and \code{sig2y}, respectively. (Must be >0.)} \item{fixed.b1}{fixed regression slope. 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 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{ This function fits the phylogenetic regression model with within-species sampling error following Ives et al. (2007). \code{pgls.SEy} fits a simpler model in which only sampling error in \code{y} is taken into account. This function uses \code{\link{gls}} from the nlme package internally for optimization and returns an object of class \code{"gls"} that is compatible with all methods for that object class. } \details{ 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 components: \item{beta}{a vector or matrix of regression coefficients.} \item{sig2x}{fitted BM rate for \code{X}.} \item{sig2y}{fitted BM rate for \code{y}.} \item{a}{fitted ancestral states for \code{X} and \code{y}.} \item{logL}{log-likelihood.} \item{convergence}{a value for convergence. \code{convergence=0} is good; see \code{\link{optim}} for more details.} \item{message}{a message for convergence.} In the case of \code{pgls.SEy}, an object of class \code{"gls"}. } \references{ Ives, A. R., P. E. Midford, and T. Garland Jr. (2007) Within-species measurement error in phylogenetic comparative methods. \emph{Systematic Biology}, \bold{56}, 252-270. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{brownie.lite}}, \code{\link{phylosig}}, \code{\link{phyl.resid}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{statistics} \keyword{least squares} \keyword{maximum likelihood} phytools/man/fitPagel.Rd0000644000176200001440000000571612723356050014744 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}. For S3 \code{plot} method, an object of class \code{"fitPagel"}.} \item{y}{a second binary character for the species in \code{tree}.} \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 ape for optimization, or to \code{"fitDiscrete"} (if the geiger package is installed) to use geiger's \code{fitDiscrete} for optimization.} \item{model}{model of evolution for the individual characters. Can be \code{model="ER"}, \code{"SYM"} (equivalent to \code{"ER"} in this case), and \code{"ARD"}.} \item{dep.var}{dependent variable. If \code{dep.var="xy"} than the rate of subsitution in \code{x} depends on \code{y} & vice versa. If \code{dep.var="x"} than the substitution rate in \code{x} depends on \code{y}, but not the converse. Finally, if \code{dep.var="y"} than the rate of substitution in \code{y} depends on \code{x}, but not the converse.} \item{...}{optional arguments to be passed to \code{\link{fitMk}}, \code{\link{ace}}, or \code{fitDiscrete}. For \code{plot} method optional arguments include (but may not be limited to): \code{signif}, the number of digits for the rates to be plotted; \code{main}, a character vector of length two with the headings for each subplot; \code{cex.main}, \code{cex.sub}, \code{cex.traits}, and \code{cex.rates}, font sizes for the various text elements of the plot; and \code{lwd.by.rate}, a logical argument specifying whether or not to scale arrow line widths in proportion to the estimated rates.} } \description{ This function fit's Pagel's (1994) model for the correlated evolution of two binary characters. \code{plot.fitPagel} plots the fitted models using arrows. } \value{ An object of class \code{"fitPagel"} which contains the optimized matrices under an independence & a dependence model, log-likelihoods, a likelihood ratio, and a P-value for the independence model based on a chi-squared test. \code{plot.fitPagel} creates a plot showing the different fitted models with arrows. } \references{ Pagel, M. (1994) Detecting correlated evolution on phylogenies: A general method for the comparative analysis fo discrete characters. \emph{Proceedings of the Royal Society B}, \bold{255}, 37-45. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ace}}, \code{\link{fitMk}}, \code{\link{make.simmap}} } \keyword{phylogenetics} \keyword{comparative method} phytools/man/resolveNode.Rd0000644000176200001440000000304512752351115015466 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{ 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. } \details{ For \code{resolveNode} applied to a multifurcation with \emph{n} descendants, the number of resolved trees will be equal to the number of possible rooted trees of \emph{n} taxa. (For instance, three for a trifurcation, 15 for a quadrifurcation, and so on.) For \code{resolveAllNodes} the number of fully resolved trees will be equal to the product of numbers for \code{resolveNode} applied to each multifurcation separately. (For instance, 45 for a tree containing one trifurcation and one quadrifurcation.) } \value{ An object of class \code{"multiPhylo"} - or, if the input tree is already fully resolved, an object of class \code{"phylo"} indentical to \code{tree}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{multi2di}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/bind.tree.simmap.Rd0000644000176200001440000000201112717637451016343 0ustar liggesusers\name{bind.tree.simmap} \alias{bind.tree.simmap} \title{Attaches a new tip to a tree} \usage{ bind.tree.simmap(x, y, where="root") } \arguments{ \item{x}{an object of class \code{"simmap"}. (The receptor tree.)} \item{y}{an object of class \code{"simmap"}. (The tree being grafted.)} \item{where}{node number to attach new tip, or the root node if \code{where="root"}.} } \description{ This function grafts tree \code{y} onto tree \code{x} at node \code{where}. } \details{ This function wraps around \code{\link{bind.tree}} for objects of class \code{"simmap"}; however it presently only allows \code{y} to be grafted at a node of \code{x} and it does not allow \code{y} to possess a root edge. } \value{ An object of class \code{"simmap"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/describe.simmap.Rd0000644000176200001440000000435412673645450016264 0ustar liggesusers\name{describe.simmap} \alias{describe.simmap} \alias{summary.simmap} \alias{summary.multiSimmap} \alias{plot.describe.simmap} \title{Summarizes a stochastic mapped tree or set of trees} \usage{ describe.simmap(tree, ...) \method{summary}{simmap}(object, ...) \method{summary}{multiSimmap}(object, ...) \method{plot}{describe.simmap}(x, ...) } \arguments{ \item{tree}{a single tree or a set of trees as an object of class \code{"simmap"} or \code{"multiSimmap"}, respectively.} \item{object}{object of class \code{"simmap"} or \code{"multiSimmap"}.} \item{x}{for S3 \code{plot} method, an object of class \code{"describe.simmap"}.} \item{...}{optional arguments which include: \code{plot}, a logical value indicating whether or not to plot the posterior probabilities at nodes (default is \code{plot=FALSE}); \code{check.equal}, a logical value indicating whether or not to check if all trees are equal using \code{\link{all.equal.phylo}} (default is \code{check.equal=FALSE}); and \code{message}, a logical indicating whether or not to print an informative message to the screen (default is \code{message=TRUE}).} } \description{ This function summarizes the result of one or more stochastic maps. } \value{ An object of class \code{"describe.simmap"} with the following elements: \item{count}{a matrix containing the number and types of transitions for each tree, if \code{tree} is an object of class \code{"multiSimmap"}.} \item{times}{a matrix containg the times spend in each state on each tree.} \item{ace}{the posterior probabilities of each node being in each state, if \code{tree} is an object of class \code{"multiSimmap"}.} \item{legend}{a vector containing the plot legend, if \code{plot=TRUE}.} if \code{class(tree)="simmap"} then the function simply returns the results of \code{\link{countSimmap}} combined with the states at each node of the tree and a matrix containing the total and relative times spent in each state on the tree. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{comparative method} \keyword{phylogenetics} \keyword{utilities} phytools/man/drop.tip.contMap.Rd0000644000176200001440000000233412464425536016351 0ustar liggesusers\name{drop.tip.contMap} \alias{drop.tip.contMap} \alias{drop.tip.densityMap} \title{Drop tip or tips from an object of class "contMap" or "densityMap"} \usage{ drop.tip.contMap(x, tip) drop.tip.densityMap(x, tip) } \arguments{ \item{x}{an object of class \code{"contMap"} or \code{"densityMap"}.} \item{tip}{name or names of species to be dropped.} } \description{ This function drops one or multiple tips from an object of class \code{"contMap"} or \code{"densityMap"}. This function is equivalent to \code{\link{drop.tip}} but for an object of this class. } \details{ For more information about objects of class \code{"contMap"} or \code{"densityMap"}, please refer to the documentation pages for \code{\link{contMap}} or \code{\link{densityMap}}, respectively. } \value{ An object of class \code{"contMap"} or \code{"densityMap"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{contMap}}, \code{\link{densityMap}}, \code{\link{drop.tip}}, \code{\link{drop.tip.simmap}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/midpoint.root.Rd0000644000176200001440000000235413501605766016017 0ustar liggesusers\name{midpoint.root} \alias{midpoint.root} \title{Midpoint root a phylogeny} \usage{ midpoint.root(tree) } \arguments{ \item{tree}{an object of class \code{"phylo"}.} } \description{ This function midpoint roots a rooted or unrooted tree (Farris 1972). } \details{ Midpoint rooting involves locating the midpoint of the longest path between any two tips and putting the root in that location. This function performs the same operation as \code{\link{midpoint}} in the phangorn package, but uses no phangorn code internally. } \value{ An object of class \code{"phylo"} containing a rooted phylogenetic tree. } \references{ Farris, J. (1972) Estimating phylogenetic trees from distance matrices. \emph{American Naturalist}, \bold{106}, 645-667. Paradis, E., J. Claude, and K. Strimmer (2004) APE: Analyses of phylogenetics and evolution in R language. \emph{Bioinformatics}, \bold{20}, 289-290. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{midpoint}}, \code{\link{reroot}}, \code{\link{root}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/phylomorphospace3d.Rd0000644000176200001440000000552613066533150017032 0ustar liggesusers\name{phylomorphospace3d} \alias{phylomorphospace3d} \title{Creates tree-dimensional phylomorphospace plot} \usage{ phylomorphospace3d(tree, X, A=NULL, label=TRUE, control=list(), method=c("dynamic","static"), ...) } \arguments{ \item{tree}{a phylogenetic tree in \code{"phylo"} format.} \item{X}{an \code{n} x 3 matrix of tip values for two characters in \code{n} species.} \item{A}{an optional \code{m} x 3 matrix (for \code{m} nodes) of values for two taits at internal nodes in the tree - if not supplied, these values will be estimated using \code{\link{anc.ML}}.} \item{label}{logical value indicating whether to print tip labels next to terminal nodes in the plot (presently doesn't do anything, but labels can be dropped using \code{control}).} \item{control}{a list containing the following optional control parameters: \code{spin}: a logical value indicating whether to animate the plot when created; \code{axes}: a logical indicating whether to plot the axes; \code{box}: a logical value indicating whether to plot in box; \code{simple.axes}: logical value indicating whether to replace \code{box} and \code{axes} with simpler axes; \code{lwd}: line widths; \code{ftype}: font type ("off" turns off labels altogether); \code{col.edge} a vector of colors of length \code{nrow(tree$edge)}.} \item{method}{a string either \code{"dynamic"} for a dynamic (animated) plot created using \code{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{ This function creates a phylomorphospace plot for three characters using the 3D visualization package, 'rgl'. } \value{ This function creates a three dimensional phylomorphospace plot. The function returns a function from \code{spin3d} (for \code{method="dynamic"}); or a series of functions from \code{\link{scatterplot3d}} (for \code{method="static"}). } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Sidlauskas, B. (2008) Continuous and arrested morphological diversification in sister clades of characiform fishes: A phylomorphospace approach. \emph{Evolution}, \bold{62}, 3135-3156. } \author{Liam Revell \email{liam.revell@umb.edu}} \examples{ tree<-pbtree(n=26,tip.label=LETTERS) X<-fastBM(tree,nsim=3) \dontrun{ phylomorphospace3d(tree,X,control=list(spin=FALSE)) } phylomorphospace3d(tree,X,method="static") } \seealso{ \code{\link{fancyTree}}, \code{\link{phenogram}}, \code{\link{phylomorphospace}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{plotting} phytools/man/getStates.Rd0000644000176200001440000000173212464426375015160 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")) } \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{ This function gets the states from the nodes or tips of a mapped tree (e.g., \code{\link{make.simmap}}). } \value{ A named vector (for \code{"phylo"}) or matrix (for \code{"multiPhylo"}). } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{describe.simmap}}, \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{sim.history}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/phyl.RMA.Rd0000644000176200001440000000525213066536755014613 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 \code{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{ This function performs phylogenetic RMA regression. } \details{ Optionally jointly estimates lambda if \code{method="lambda"}. Likelihood optimization of lambda is performed using \code{\link{optimize}} on the interval (0,1). Note that some statistician think there is \emph{never} a condition in which a reduced-major-axis regression should be used. 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. } \value{ An object of class \code{"phyl.RMA"} consisting of a list with the following components: \item{RMA.beta}{a vector of RMA regression coefficients.} \item{V}{a VCV matrix for the traits.} \item{lambda}{fitted value of lambda (\code{method="lambda"} only).} \item{logL}{log-likelihood (\code{method="lambda"} only).} \item{test}{a vector containing results for hypothesis tests on \code{beta}.} \item{resid}{a vector of residuals for \code{y} given \code{x}.} } \references{ Clarke, M. R. B. (1980) The reduced major axis of a bivariate sample. \emph{Biometrika}, \bold{67}, 441-446. McArdle, B. H. (1988) The structural relationship: Regression in biology. \emph{Can. J. Zool.}, \bold{66}, 2329-2339. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{phyl.cca}}, \code{\link{phyl.pca}}, \code{\link{phyl.resid}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{maximum likelihood} \keyword{statistics} phytools/man/roundBranches.Rd0000644000176200001440000000161613066534104016000 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{ This function rounds the branch lengths of a tree or trees and reconciles any mappings for objects of class \code{"simmap"} or \code{"multiSimmap"}. } \value{ An object of class \code{"phylo"}, \code{"multiPhylo"}, \code{"simmap"}, or \code{"multiSimmap"}, with rounded edge lengths. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/gammatest.Rd0000644000176200001440000000210513477255452015173 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. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ltt}}, \code{\link{mccr}} } \examples{ tree<-pbtree(n=200) gammatest(ltt(tree,plot=FALSE)) } \keyword{phylogenetics} \keyword{comparative method} \keyword{diversification} phytools/man/genSeq.Rd0000644000176200001440000000250713477256622014441 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 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. Uses \code{\link{sim.Mk}} internally. } \value{ An object of class \code{"DNAbin"} or \code{"phyDat"}, or a matrix of nucleotides. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \examples{ ## simulate gamma rate heterogeneity tree<-pbtree(n=26,tip.label=LETTERS,scale=0.1) gg<-rgamma(n=100,shape=0.25,rate=0.25) dna<-genSeq(tree,l=100,rate=gg) } \keyword{phylogenetics} \keyword{simulation} phytools/man/phyl.resid.Rd0000644000176200001440000000451113201722210015245 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{ 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; \emph{Evolution}). } \details{ 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 components: \item{beta}{a vector or matrix of regression coefficients.} \item{resid}{a vector or matrix of residuals for species.} \item{lambda}{a vector of lambda values (\code{method="lambda"} only).} \item{logL}{a vector of log-likelihoods (\code{method="lambda"} only).} } \references{ Revell, L. J. (2009) Size-correction and principal components for interspecific comparative studies. \emph{Evolution}, \bold{63}, 3258-3268. Revell, L. J. (2010) Phylogenetic signal and linear regression on species data. \emph{Methods in Ecology and Evolution}, \bold{1}, 319-329. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{phyl.pca}}, \code{\link{gls}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{statistics} \keyword{least squares} \keyword{maximum likelihood} phytools/man/anc.ML.Rd0000644000176200001440000000515413502023305014243 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 ont he tree. It's possible that only \code{model="BM"} & \code{model="EB"} work in the present version as \code{model="OU"} has not be thoroughly tested & some bugs were reported for an earlier version.} \item{...}{other 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 has been ameliorated in \emph{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{optim()} (0 is good).} } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Schluter, D., Price, T., Mooers, A. O., and Ludwig, D. (1997) Likelihood of ancestor states in adaptive radiation. \emph{Evolution} \bold{51}, 1699-1711. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ace}}, \code{\link{anc.Bayes}}, \code{\link{fastAnc}}, \code{\link{optim}} } \examples{ tree<-pbtree(n=50) x<-fastBM(tree) # simulate using fastBM anc.ML(tree,x) # fit model & estimate ancestral states } \keyword{phylogenetics} \keyword{comparative method} \keyword{maximum likelihood} phytools/man/fitMk.Rd0000644000176200001440000001340413477252074014264 0ustar liggesusers\name{fitMk} \alias{fitMk} \alias{plot.fitMk} \alias{plot.gfit} \alias{fitmultiMk} \alias{fitpolyMk} \alias{plot.fitpolyMk} \alias{mcmcMk} \alias{plot.mcmcMk} \alias{density.mcmcMk} \alias{plot.density.mcmcMk} \title{Fits Mk model} \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, ...) \method{plot}{fitpolyMk}(x, ...) mcmcMk(tree, x, model="ER", ngen=10000, ...) \method{plot}{mcmcMk}(x, ...) \method{density}{mcmcMk}(x, ...) \method{plot}{density.mcmcMk}(x, ...) } \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{ngen}{number of generations of MCMC for \code{mcmcMk}.} \item{...}{optional arguments, including \code{pi}, the prior distribution at the root node (defaults to \code{pi="equal"}). 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}).} } \description{ The function \code{fitMk} fits a so-called M\emph{k} model for discrete character evolution. \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 geiger's \code{fitDiscrete} function. Both plots portray the fitted model using a graph of arrows connecting states. The function \code{fitmultiMk} fits an M\emph{k} model in which the transition rates between character states are allowed to vary depending on the mapped state of a discrete character on the tree. It can be combined with, for example, \code{\link{paintSubTree}} to test hypotheses about how the process of discrete character evolution for \code{x} varies between different parts of the tree. The function \code{fitpolyMk} fits an M\emph{k} model to data for a discrete character with intraspecific polymorphism. Polymorphic species should be coded with the name of the two or more states recorded for the species separated by a space (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. Finally, the function \code{mcmcMk} runs a Bayesian MCMC version of \code{fitMk}. The shape of the prior distribution of the transition rates is exponential, with a rate parameter that can be controlled by the user via the optional argument \code{prior.rate}. 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 method \code{plot.mcmcMk} plots a log-likelihood trace from the MCMC. 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 \emph{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. } \details{ Note that both \code{fitMk} and \code{fitmultiMk} recycle code from \code{\link{ace}} in the \emph{ape} package for computing the likelihood. \code{fitpolyMk} and \code{mcmcMk} use \code{fitMk} internally to compute the likelihood. } \value{ An object of class \code{"fitMk"}, \code{"fitmultiMk"}, \code{"fitpolyMk"}, or \code{"mcmcMk"}. In the case of \code{density.mcmcMk} an object of class \code{"density.mcmcMk"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{ace}}, \code{\link{make.simmap}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{maximum likelihood} phytools/man/rep.phylo.Rd0000644000176200001440000000212112464430505015114 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{ S3 method \code{rep} for object of class \code{"phylo"} or \code{"multiPhylo"}. \code{repPhylo} is just an alias for \code{rep.phylo} and \code{rep.multiPhylo}. } \value{ An object of class \code{"multiPhylo"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \examples{ tree<-pbtree(n=100) trees<-rep(tree,100) } \seealso{ \code{\link{c.phylo}}, \code{\link{rep}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/dotTree.Rd0000644000176200001440000000511613445167023014613 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. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{plotting} phytools/man/estDiversity.Rd0000644000176200001440000000517112464425605015707 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{ This function estimates the lineage density at each node in the tree based on a biogeographic model (based on 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. In \code{method="simulation"}, stochastic character mapping is used to generate optional argument \code{nsim} stochastic maps of ancestral biogeography. Then the lineage density at each node is computed as the number of co-existing lineages with the same biogeography as the focal node, averaged acrossed stochastic maps. The importance of this distinction may depend on the degree to which reconstructions at internal nodes are independent, which relates to the distinction between marginal and joint reconstruction (e.g., see Yang 2006). } \value{ A vector containing the estimated lineage density at each node } \references{ Mahler, D. L, L. J. Revell, R. E. Glor, and J. B. Losos. (2010) Ecological opportunity and the rate of morphological evolution in the diversification of Greater Antillean anoles. \emph{Evolution}, \bold{64}, 2731-2745. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Yang, Z. (2006) \emph{Computational Molecular Evolution}. Oxford University Press. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{fitDiversityModel}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{maximum likelihood} phytools/man/rescaleSimmap.Rd0000644000176200001440000000203712464427715016000 0ustar liggesusers\name{rescaleSimmap} \alias{rescaleSimmap} \title{Rescale SIMMAP style tree} \usage{ rescaleSimmap(tree, ...) } \arguments{ \item{tree}{a phylogenetic tree in modified \code{"phylo"} format with a discrete character mapping (e.g., see \code{\link{read.simmap}} or \code{\link{make.simmap}}).} \item{...}{other arguments, such as \code{depth}.} } \description{ This function scales a tree with a mapped discrete character 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 'geiger' package for SIMMAP style trees. } \value{ A phylogenetic tree in modified \code{"phylo"} format. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{make.simmap}}, \code{\link{read.simmap}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/evolvcv.lite.Rd0000644000176200001440000000324113475631677015640 0ustar liggesusers\name{evolvcv.lite} \alias{evolvcv.lite} \title{Likelihood test for a shift in the evolutionary correlation between traits} \usage{ evolvcv.lite(tree, X, maxit=2000, tol=1e-10) } \arguments{ \item{tree}{an object of class \code{"simmap"}. If \code{tree} is an object of class \code{"phylo"} then a simple multivariate Brownian motion model will be fit to the data in \code{X}.} \item{X}{an \code{n} x \code{m} matrix of tip values for \code{m} continuously valued traits in \code{n} species - row names should be species names.} \item{maxit}{an optional integer value indicating the maximum number of iterations for optimization - may need to be increased for large trees.} \item{tol}{tolerance value for \code{"L-BFGS-B"} optimization.} } \description{ This function takes an object of class \code{"simmap"} with a mapped binary or multistate trait and data for two and only two continuously valued character. It then fits four different evolutionary models: common rates and correlation; different rates, common correlation; different correlations, common rates; no common structure. } \value{ A list with the results summarized for each model. } \references{ Revell, L. J., and D. C. Collar (2009) Phylogenetic analysis of the evolutionary correlation using likelihood. \emph{Evolution}, \bold{63}, 1090-1100. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{brownie.lite}}, \code{\link{evol.vcv}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{maximum likelihood} phytools/man/rstate.Rd0000644000176200001440000000143012464427623014507 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{ Primarily an internal function for \code{\link{make.simmap}}. } \details{ This function picks a random element in a vector according to the probability assigned that element. It returns the name. Uses \code{\link{rmultinom}}. } \value{ A character or string. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{math} \keyword{utilities} \keyword{statistics} phytools/man/pbtree.Rd0000644000176200001440000001050213066531647014467 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}).} } \description{ This function simulates stochastic birth-death trees. Simulation can be performed conditioning on \code{n}, on \code{t}, or on both simultaneously. If the both, then (for optional argument \code{method="rejection"}) rejection sampling is performed whereby trees are simulated given \code{b} and \code{t} until a tree containing \code{n} taxa is found. The giving-up point can be set using the optional argument \code{max.count}. Simulations can also be performed in continuous time (the default) or discrete time; the difference being that wait times in the continous-time simulation come from the exponential distribution; whereas waiting times in discrete-time simulations come from the geometric distribution. In addition, discrete-time simulations allow for the possibility that multiple speciation events can occur at (exactly) the same time, so long as they are on separate branches. Finally, sometimes for stopping criterion \code{n} in discrete-time there will be a number of tips different from \code{n}. This indicates that the last event contained more than one speciation event, and a warning is printed. \code{method="direct"} is presently experimental. It does not really perform direct sampling; however waiting times & birth or death events are sampled first - with only wait-times consistent with \code{n} and \code{t} being retained. This rejection sampling occurs one layer earlier than for \code{method="rejection"}. This results in a significant (several-fold) speed-up of the code and enables sampling conditioned on \code{n} and \code{t} simultaneously for much higher \code{b} and \code{d}. At the present time, \code{extant.only=TRUE} does not work for this mode, nor does \code{type="discrete"}. Note that if \code{ape=FALSE}, then the function will run faster, and the tree is theoretically compatible with the ape \code{"phylo"} standard; however some downstream errors with functions such as \code{\link{bind.tree}} have been observed. } \value{ A tree or list of trees as an object of class \code{"phylo"} or \code{"multiPhylo"}, respectively. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \examples{ # simulate a pure-birth tree with 400 tips, scaled to a length of 1.0 tree<-pbtree(n=400,scale=1) # simulate a pure-birth tree conditioning on n & t tt<-log(50)-log(2) tree<-pbtree(n=50,t=tt) } \keyword{phylogenetics} \keyword{simulation} phytools/man/add.random.Rd0000644000176200001440000000333513201722356015211 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)}.} \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 asssigned 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. 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. } \details{ 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. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{allFurcTrees}}, \code{\link{add.everywhere}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/ratebytree.Rd0000644000176200001440000001532113502032226015340 0ustar liggesusers\name{ratebytree} \alias{ratebytree} \alias{posthoc.ratebytree} \title{Likelihood test for rate variation among trees} \usage{ ratebytree(trees, x, ...) \method{posthoc}{ratebytree}(x, ...) } \arguments{ \item{trees}{an object of class \code{"multiPhylo"}.} \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{ 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 the \emph{censored} approach of O'Meara et al. (2006; Revell et al. \emph{In review}) 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 Mk 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"}. 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"}. } \details{ At present it is not possible to specify different models to fit for the different trees - although if (for instance) character evolution on tree 1 proceeded by a strong \emph{OU} process while character evolution on tree 2 was by \emph{BM}, we would probably reject a constant-process model and tree 2 should show a very low value of \code{alpha}. To compute the standard errors for each fitted paramater value, the function computes the negative inverse of the Hessian matrix at the MLEs; however, if this matrix is computationally singular generalized inverse (\code{\link{ginv}}) will be used instead without warning. The function also conducts a likelihood-ratio test to compare the two models. For continuous character, optional arguments presently include the following: \code{model}, the model of continuous trait evolution (options are \code{"BM"}, the default, \code{"OU"}, and \code{"EB"}). \code{tol}, used as a minimum value for the fitting rates, to prevent problems in optimization. \code{trace}, a logical value indicating whether or not to report progress in the optimization. \code{test}, the method for hypothesis testing (options are \code{"chisq"} and \code{"simulation"}). \code{quiet}, a logical value indicating whether or not to run perfectly quietly. Finally, \code{se}, a list of vectors containing the standard errors for each value of \code{x}. For \code{type="discrete"} the optional arguments are slightly different. The argument \code{model} can be used, but it must assume the values \code{"ER"}, \code{"SYM"}, \code{"ARD"}, or a numeric matrix following \code{\link{ace}}. Finally, for \code{type= "diversification"} models are so far \code{"birth-death"}, \code{"equal-extinction"}, and \code{"equal-specation"}, and \code{"Yule"}. It is also important to consider supplying the sampling fractions, \code{rho}, which is a vector of values between 0 and 1 of the same length as \code{trees}. If not provided the method will assume a sampling fraction of 1.0 for all trees - which is seldom true of empirical studies. } \value{ An object of class \code{"ratebytree"} or an object of class \code{"posthoc.ratebytree"} in the case of the method \code{posthoc}. } \references{ Adams, D. C. (2012) Comparing evolutionary rates for different phenotypic traits on a phylogeny using likelihood. \emph{Syst. Biol.}, \bold{62}, 181-192. Lewis, P. O. (2001) A likelihood approach to estimating phylogeny from discrete morphological character data. \emph{Systematic Biology}, \bold{50}, 913-925. Nee, S., May, R. M. and Harvey, P. H. (1994) The reconstructed evolutionary process. \emph{Philosophical Transactions of the Royal Society of London B}, \bold{344}, 305-311. O'Meara, B. C., C. Ane, M. J. Sanderson, and P. C. Wainwright. (2006) Testing for different rates of continuous trait evolution using likelihood. \emph{Evolution}, \bold{60}, 922-933. Stadler, T. (2012) How can we improve the accuracy of macroevolutionary rate estimates? \emph{Systematic Biology}, \bold{62}, 321-329. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. Revell, L. J. (2018) Comparing the rates of speciation and extinction between phylogenetic trees. emph{Ecology and Evolution}, \bold{8}, 5303-5312. Revell, L. J., Gonzalez-Valenzuela, L. E., Alfonso, A., Castellanos-Garcia, L. A., Guarnizo, C. E., and Crawford, A. J. (2018) Comparing evolutionary rates between trees, clades, & traits. \emph{Methods Ecol. Evol.}, \bold{9}, 994-1005. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{brownie.lite}}, \code{\link{fitMk}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{maximum likelihood} phytools/man/plotTree.wBars.Rd0000644000176200001440000000703113353242355016056 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 argument is \code{add}. Generally this should not be used; however it can be used 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.} } \description{ \code{plotTree.wbars} plots a phylogeny in phylogram or fan style with bars at the tips representing the values for a phenotypic trait. \code{plotTree.barplot} creates a split plot in which a right-facing phylogram is on the left, and a bar plot is shown on the right. \code{plotTree.boxplot} creates a split plot in which a right-facing phylogram is on the left, and a box plot is shown on the right. } \value{ Plots a tree with an associated bar plot for a continuously valued character at the tips. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{barplot}}, \code{\link{dotTree}}, \code{\link{plotSimmap}}, \code{\link{plotTree}} } \keyword{phylogenetics} \keyword{plotting} \keyword{comparative method} phytools/man/ratebystate.Rd0000644000176200001440000000427313201657506015537 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{ This function attempts to ask if the rate of a continuous character, \code{y}, depends on the state of a separate continuous trait, \code{x}. This is accomplished by regressing the squared contrasts in \code{y} on the branch or node ancestral estimates of \code{x}. } \value{ This function returns an object of class \code{"ratebystate"} with up to the following four elements: \item{beta}{value of the regression coefficient for square of the contrasts in \code{y} regressed on the ancestral or branch-wise estimated states for \code{x}.} \item{r}{correlation coefficient for \code{corr=corr}.} \item{corr}{string giving the value of \code{corr}.} \item{method}{string giving the value of \code{method}.} } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{fastAnc}}, \code{\link{pic}} } \keyword{phylogenetics} \keyword{comparative method} phytools/man/brownieREML.Rd0000644000176200001440000000446613474626324015347 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{ This function takes an object of class \code{"phylo"} or an object of class \code{"simmap"} with a mapped binary or multistate trait (see \code{\link{read.simmap}}) and data for a single continuously valued character. It then uses restricted maximum likelihood (REML) to fit the Brownian rate variation ("noncensored") model of O'Meara et al. (2006; \emph{Evolution}). This function is similar to \code{\link{brownie.lite}} but uses REML (which is faster and unbiased) instead of ML. REML optimization takes advantage of Felsenstein's (1985) contrasts algorithm. } \value{ An object of class \code{"brownieREML"} containing the following components: \item{sig2.single}{is the rate 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 from the multi-rate model.} \item{logL2}{log-likelihood of the multi-rate model.} \item{convergence}{numerical value from \code{\link{optim}}.} } \references{ Felsenstein, J. 1985. Phylogenies and the comparative method. \emph{American Naturalist}, \bold{125}, 1-15. O'Meara, B. C., C. Ane, M. J. Sanderson, and P. C. Wainwright. 2006. Testing for different rates of continuous trait evolution using likelihood. \emph{Evolution}, \bold{60}, 922-933. Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{brownie.lite}}, \code{\link{evol.vcv}}, \code{\link{evol.rate.mcmc}}, \code{\link{ratebytree}} } \keyword{phylogenetics} \keyword{comparative method} phytools/man/density.multiSimmap.Rd0000644000176200001440000000433513201722605017157 0ustar liggesusers\name{density.multiSimmap} \alias{density.multiSimmap} \alias{plot.changesMap} \title{Computes a posterior distribution for the number and types of changes on the tree} \usage{ \method{density}{multiSimmap}(x, ...) \method{plot}{changesMap}(x, ...) } \arguments{ \item{x}{object of class \code{"multiSimmap"} (see \code{\link{make.simmap}}), or, in the case \code{plot.changesMap}, an object of class \code{"changesMap"} produced via a call to \code{density.multiSimmap}.} \item{...}{optional arguments. For \code{density.multiSimmap} these consist of \code{bw} (bandwidth) & \code{method} (\code{"changes"}, \code{"densityMap"}, or \code{"timings"}).} } \details{ In \code{density.multiSimmap} \code{method="changes"}, the default, results in a posterior distribution of the number & types of changes on the tree. If the package \emph{coda} has been installed, then the function \code{HPD.interval} is used to compute a 95-percent high probability density interval for the number of changes of each type on the tree. Otherwise, the central 95-percent of the posterior sample is returned as an estimate of the 95-percent HPD interval for each change type. The method also computes the full posterior density for each change type using a bandwidth specified by the user. \code{method="densityMap"} computes a standard \code{"\link{densityMap}"} object, and thus only permits binary characters. Finally \code{method="changes"} has not yet been implemented. \code{plot.changesMap} plots the posterior density returned by \code{density.multiSimmap} for \code{method=} \code{"changes"}. } \description{ This function summarizes the result of one or more stochastic maps. } \value{ For \code{method="changes"} \code{density.multiSimmap} returns an object of class \code{"changesMap"}. For \code{method="densityMap"} \code{density.multiSimmap} returns an object of class \code{"\link{densityMap}"}. \code{plot.changesMap} generates a plot. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{comparative method} \keyword{phylogenetics} \keyword{utilities} phytools/man/sim.ratebystate.Rd0000644000176200001440000000350512464427402016323 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 \code{x}.} \item{sig2y}{variance of the Brownian process of evolution for \code{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 \code{x} and the Brownian rate in \code{y}.} \item{...}{optional arguments which include \code{method} (\code{"by.node"} or \code{"by.branch"} indicating whether to assume the rate varies as a function of the node state or the mean branch state); \code{plot}, a logical value indicating whether or not to plot a phenogram with the branches used for simulation of \code{y} after rescaling by the state of \code{x}; and \code{logarithm}, a logical value indicating whether or not simulate changes in the variance of Brownian evolution for \code{y} as an additive \code{logarithm=FALSE} or multiplicative function of \code{x}. The default is \code{logarithm=FALSE}.} } \description{ This function attempts to simulate two characters under a model in which the rate of evolution for the second (\code{y}) depends on the states for the first \code{x}. See \code{\link{ratebystate}} for more details. } \value{ This function returns a matrix. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{fastBM}}, \code{\link{ratebystate}} } \keyword{phylogenetics} \keyword{comparative method} \keyword{simulation} phytools/man/getDescendants.Rd0000644000176200001440000000224413477452001016135 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{ \code{getDescendants} returns the set of node & tip numbers descended from \code{node}. \code{getParent} returns the \emph{single} parent node of a specified node number (or \code{NULL} if \code{node} is already the root). } \value{ The set of node and tip numbers for the nodes and tips descended from \code{node} in a vector, or for \code{getParent} the single node preceding \code{node} in the tree. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{Descendants}}, \code{\link{paintSubTree}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/collapseTree.Rd0000644000176200001440000000231213353255457015631 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 to end. } \value{ Returns the final plotted tree. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{plotTree}}, \code{\link{plotSimmap}} } \keyword{phylogenetics} \keyword{plotting} phytools/man/drop.clade.Rd0000644000176200001440000000134612464425470015224 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{ Mostly internal function for \code{\link{posterior.evolrate}}; function drops the clade containing the species in \code{tip}. } \details{ Probably should not use unless you know what you're doing. } \value{ An object of class \code{"phylo"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{utilities} phytools/man/collapse.to.star.Rd0000644000176200001440000000155613474630640016406 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{ This function collapses a subtree to a star. 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. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{splitTree}}, \code{\link{starTree}} } \keyword{phylogenetics} \keyword{utilities} phytools/man/geo.legend.Rd0000644000176200001440000000244013477321647015222 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{ The function \code{geo.legend} adds a geological (or other temporal) legend to a plotted tree. The function \code{geo.palette} returns a geological time color palette to the user. } \value{ \code{geo.legend} adds a visual element to a plotted tree and invisible returns an object of class \code{geo.legend} containing the time periods and colors of the painted legend. \code{geo.palette} simply returns a geological timescale color palette as an object of class \code{"geo.palette"}. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \keyword{phylogenetics} \keyword{plotting} phytools/man/drop.tip.simmap.Rd0000644000176200001440000000307712464425555016244 0ustar liggesusers\name{drop.tip.simmap} \alias{drop.tip.simmap} \alias{extract.clade.simmap} \title{Drop tips or extract clade from tree with mapped discrete character} \usage{ drop.tip.simmap(tree, tip) extract.clade.simmap(tree, node) } \arguments{ \item{tree}{a modified object of class \code{"phylo"} (see \code{\link{read.simmap}}).} \item{tip}{name or names of species to be dropped.} \item{node}{node number for the root node of the clade to be extracted.} } \description{ This function drops one or multiple tips from the modified \code{"phylo"} object with a mapped binary or multistate trait (see \code{\link{read.simmap}}) while maintaining the matrix \code{$mapped.edge} and list of mappings by branch \code{maps}. This function is equivalent to \code{\link{drop.tip}} but for a tree with a mapped discrete character. \code{extract.clade.simmap} is functionally equivalent to \code{\link{extract.clade}} but preserves discrete character mappings on the tree. } \value{ A modified object of class \code{"phylo"} containing the elements \code{maps} and \code{$mapped.edge} with the time spent in each state along each edge of the tree. } \references{ Revell, L. J. (2012) phytools: An R package for phylogenetic comparative biology (and other things). \emph{Methods Ecol. Evol.}, \bold{3}, 217-223. } \author{Liam Revell \email{liam.revell@umb.edu}} \seealso{ \code{\link{brownie.lite}}, \code{\link{drop.tip}}, \code{\link{extract.clade}}, \code{\link{make.simmap}}, \code{\link{read.simmap}}, \code{\link{sim.history}} } \keyword{phylogenetics} \keyword{utilities}